+2010-09-09 Robert Dewar <dewar@adacore.com>
+
+ * prj-env.adb: Minor code reorganization.
+ * par-ch3.adb: Minor reformatting.
+ * gcc-interface/Make-lang.in: Update dependencies.
+
+2010-09-09 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch9.adb (Build_Activation_Chain_Entity): The construct enclosing
+ a task declaration can be an entry body.
+
+2010-09-09 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Make_DT): Decorate as "static" variables containing
+ tags of library level tagged types.
+ (Make_Tags): Disable backend optimizations about aliasing for
+ declarations of access to dispatch tables.
+
+2010-09-09 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Reset_Entity): If the entity is an itype created as a
+ subtype for a null-excluding access type, recover the original
+ subtype_mark to get the proper visibility on the original name.
+
+2010-09-09 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch3.adb (Build_Untagged_Equality): For Ada2012, new procedure to
+ create the primitive equality operation for an untagged record. The
+ operation is the predefined equality if no record component has a
+ user-defined equality, or if there is a user-defined equality for the
+ type as a whole, or when the type is derived and it has an inherited
+ equality. Otherwise the body of the operations is built as for tagged
+ types.
+ (Expand_Freeze_Record_Type): Call Build_Untagged_Equality when needed.
+ (Make_Eq_Body): New function to create the expanded body of the equality
+ operation for tagged and untagged records. In both cases the operation
+ composes, and the primitive operation of each record component is used
+ to generate the equality function for the type.
+ * exp_ch4.adb (Expand_Composite_Equality): In Ada2012, if a component
+ has an abstract equality defined, replace its call with a
+ Raise_Program_Error.
+ * sem_ch6.adb (New_Overloaded_Entity): if Ada2012, verify that a
+ user-defined equality operator for an untagged record type does not
+ happen after type is frozen, and appears in the visible part if partial
+ view of type is not limited.
+
+2010-09-09 Tristan Gingold <gingold@adacore.com>
+
+ * gnatlbr.adb: Make Create_Directory more portable: use __gnat_mkdir.
+
+2010-09-09 Bob Duff <duff@adacore.com>
+
+ * gnat_ugn.texi: Remove incorrect statement about -E being the default.
+
2010-09-09 Pascal Obry <obry@adacore.com>
* gnat_ugn.texi: Update doc on windows related topics.
-- the code expansion for controlled components (when control actions
-- are active) can lead to very large blocks that GCC3 handles poorly.
+ procedure Build_Untagged_Equality (Typ : Entity_Id);
+ -- AI05-0123: equality on untagged records composes. This procedure
+ -- build the equality routine for an untagged record that has components
+ -- of a record type that have user-defined primitive equality operations.
+ -- The resulting operation is a TSS subprogram.
+
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
-- Create An Equality function for the non-tagged variant record 'Typ'
-- and attach it to the TSS list
function Is_Variable_Size_Record (E : Entity_Id) return Boolean;
-- Returns true if E has variable size components
+ function Make_Eq_Body
+ (Typ : Entity_Id;
+ Eq_Name : Name_Id) return Node_Id;
+ -- Build the body of a primitive equality operation for a tagged record
+ -- type, or in Ada2012 for any record type that has components with a
+ -- user-defined equality. Factored out of Predefined_Primitive_Bodies.
+
function Make_Eq_Case
(E : Entity_Id;
CL : Node_Id;
Set_Is_Pure (Proc_Name);
end Build_Slice_Assignment;
+ -----------------------------
+ -- Build_Untagged_Equality --
+ -----------------------------
+
+ procedure Build_Untagged_Equality (Typ : Entity_Id) is
+ Build_Eq : Boolean;
+ Comp : Entity_Id;
+ Decl : Node_Id;
+ Op : Entity_Id;
+ Prim : Elmt_Id;
+ Eq_Op : Entity_Id;
+
+ function User_Defined_Eq (T : Entity_Id) return Entity_Id;
+ -- Check whether the type T has a user-defined primitive
+ -- equality. If true for a component of Typ, we have to
+ -- build the primitive equality for it.
+
+ ---------------------
+ -- User_Defined_Eq --
+ ---------------------
+
+ function User_Defined_Eq (T : Entity_Id) return Entity_Id is
+ Prim : Elmt_Id;
+ Op : Entity_Id;
+
+ begin
+ Op := TSS (T, TSS_Composite_Equality);
+
+ if Present (Op) then
+ return Op;
+ end if;
+
+ Prim := First_Elmt (Collect_Primitive_Operations (T));
+ while Present (Prim) loop
+ Op := Node (Prim);
+
+ if Chars (Op) = Name_Op_Eq
+ and then Etype (Op) = Standard_Boolean
+ and then Etype (First_Formal (Op)) = T
+ and then Etype (Next_Formal (First_Formal (Op))) = T
+ then
+ return Op;
+ end if;
+
+ Next_Elmt (Prim);
+ end loop;
+
+ return Empty;
+ end User_Defined_Eq;
+
+ -- Start of processing for Build_Untagged_Equality
+
+ begin
+ -- If a record component has a primitive equality operation, we must
+ -- builde the corresponding one for the current type.
+
+ Build_Eq := False;
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ if Is_Record_Type (Etype (Comp))
+ and then Present (User_Defined_Eq (Etype (Comp)))
+ then
+ Build_Eq := True;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ -- If there is a user-defined equality for the type, we do not create
+ -- the implicit one.
+
+ Prim := First_Elmt (Collect_Primitive_Operations (Typ));
+ Eq_Op := Empty;
+ while Present (Prim) loop
+ if Chars (Node (Prim)) = Name_Op_Eq
+ and then Comes_From_Source (Node (Prim))
+ then
+ Eq_Op := Node (Prim);
+ Build_Eq := False;
+ exit;
+ end if;
+
+ Next_Elmt (Prim);
+ end loop;
+
+ -- If the type is derived, inherit the operation, if present, from the
+ -- parent type. It may have been declared after the type derivation.
+ -- If the parent type itself is derived, it may have inherited an
+ -- operation that has itself been overridden, so update its alias
+ -- and related flags. Ditto for inequality.
+
+ if No (Eq_Op) and then Is_Derived_Type (Typ) then
+ Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
+ while Present (Prim) loop
+ if Chars (Node (Prim)) = Name_Op_Eq then
+ Copy_TSS (Node (Prim), Typ);
+ Build_Eq := False;
+
+ declare
+ Op : constant Entity_Id := User_Defined_Eq (Typ);
+ Eq_Op : constant Entity_Id := Node (Prim);
+ NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
+
+ begin
+ if Present (Op) then
+ Set_Alias (Op, Eq_Op);
+ Set_Is_Abstract_Subprogram
+ (Op, Is_Abstract_Subprogram (Eq_Op));
+
+ if Chars (Next_Entity (Op)) = Name_Op_Ne then
+ Set_Alias (Next_Entity (Op), NE_Op);
+ Set_Is_Abstract_Subprogram
+ (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
+ end if;
+ end if;
+ end;
+
+ exit;
+ end if;
+
+ Next_Elmt (Prim);
+ end loop;
+ end if;
+
+ -- If not inherited and not user-defined, build body as for a type
+ -- with tagged components.
+
+ if Build_Eq then
+ Decl :=
+ Make_Eq_Body
+ (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
+ Op := Defining_Entity (Decl);
+ Set_TSS (Typ, Op);
+ Set_Is_Pure (Op);
+
+ if Is_Library_Level_Entity (Typ) then
+ Set_Is_Public (Op);
+ end if;
+ end if;
+ end Build_Untagged_Equality;
+
------------------------------------
-- Build_Variant_Record_Equality --
------------------------------------
end if;
end if;
- -- In the non-tagged case, an equality function is provided only for
- -- variant records (that are not unchecked unions).
+ -- In the non-tagged case, ever since Ada83 an equality function must
+ -- be provided for variant records that are not unchecked unions.
+ -- In Ada2012 the equality function composes, and thus must be built
+ -- explicitly just as for tagged records.
elsif Has_Discriminants (Def_Id)
and then not Is_Limited_Type (Def_Id)
Build_Variant_Record_Equality (Def_Id);
end if;
end;
+
+ elsif Ada_Version >= Ada_12
+ and then Comes_From_Source (Def_Id)
+ and then Convention (Def_Id) = Convention_Ada
+ then
+ Build_Untagged_Equality (Def_Id);
end if;
-- Before building the record initialization procedure, if we are
end loop;
end Make_Controlling_Function_Wrappers;
+ -------------------
+ -- Make_Eq_Body --
+ -------------------
+
+ function Make_Eq_Body
+ (Typ : Entity_Id;
+ Eq_Name : Name_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Parent (Typ));
+ Decl : Node_Id;
+ Def : constant Node_Id := Parent (Typ);
+ Stmts : constant List_Id := New_List;
+ Variant_Case : Boolean := Has_Discriminants (Typ);
+ Comps : Node_Id := Empty;
+ Typ_Def : Node_Id := Type_Definition (Def);
+
+ begin
+ Decl :=
+ Predef_Spec_Or_Body (Loc,
+ Tag_Typ => Typ,
+ Name => Eq_Name,
+ Profile => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_X),
+ Parameter_Type => New_Reference_To (Typ, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Y),
+ Parameter_Type => New_Reference_To (Typ, Loc))),
+
+ Ret_Type => Standard_Boolean,
+ For_Body => True);
+
+ if Variant_Case then
+ if Nkind (Typ_Def) = N_Derived_Type_Definition then
+ Typ_Def := Record_Extension_Part (Typ_Def);
+ end if;
+
+ if Present (Typ_Def) then
+ Comps := Component_List (Typ_Def);
+ end if;
+
+ Variant_Case := Present (Comps)
+ and then Present (Variant_Part (Comps));
+ end if;
+
+ if Variant_Case then
+ Append_To (Stmts,
+ Make_Eq_If (Typ, Discriminant_Specifications (Def)));
+ Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
+ Append_To (Stmts,
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Reference_To (Standard_True, Loc)));
+
+ else
+ Append_To (Stmts,
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Expand_Record_Equality
+ (Typ,
+ Typ => Typ,
+ Lhs => Make_Identifier (Loc, Name_X),
+ Rhs => Make_Identifier (Loc, Name_Y),
+ Bodies => Declarations (Decl))));
+ end if;
+
+ Set_Handled_Statement_Sequence
+ (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ return Decl;
+ end Make_Eq_Body;
+
------------------
-- Make_Eq_Case --
------------------
-- Body for equality
if Eq_Needed then
- Decl :=
- Predef_Spec_Or_Body (Loc,
- Tag_Typ => Tag_Typ,
- Name => Eq_Name,
- Profile => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_X),
- Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Y),
- Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
-
- Ret_Type => Standard_Boolean,
- For_Body => True);
-
- declare
- Def : constant Node_Id := Parent (Tag_Typ);
- Stmts : constant List_Id := New_List;
- Variant_Case : Boolean := Has_Discriminants (Tag_Typ);
- Comps : Node_Id := Empty;
- Typ_Def : Node_Id := Type_Definition (Def);
-
- begin
- if Variant_Case then
- if Nkind (Typ_Def) = N_Derived_Type_Definition then
- Typ_Def := Record_Extension_Part (Typ_Def);
- end if;
-
- if Present (Typ_Def) then
- Comps := Component_List (Typ_Def);
- end if;
-
- Variant_Case := Present (Comps)
- and then Present (Variant_Part (Comps));
- end if;
-
- if Variant_Case then
- Append_To (Stmts,
- Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def)));
- Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps));
- Append_To (Stmts,
- Make_Simple_Return_Statement (Loc,
- Expression => New_Reference_To (Standard_True, Loc)));
-
- else
- Append_To (Stmts,
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Expand_Record_Equality (Tag_Typ,
- Typ => Tag_Typ,
- Lhs => Make_Identifier (Loc, Name_X),
- Rhs => Make_Identifier (Loc, Name_Y),
- Bodies => Declarations (Decl))));
- end if;
-
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc, Stmts));
- end;
+ Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
Append_To (Res, Decl);
end if;
Lhs_Discr_Val,
Rhs_Discr_Val));
end;
+
+ else
+ return
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Eq_Op, Loc),
+ Parameter_Associations => New_List (Lhs, Rhs));
end if;
+ end if;
- -- Shouldn't this be an else, we can't fall through the above
- -- IF, right???
+ elsif Ada_Version >= Ada_12 then
- return
- Make_Function_Call (Loc,
- Name => New_Reference_To (Eq_Op, Loc),
- Parameter_Associations => New_List (Lhs, Rhs));
- end if;
+ -- if no TSS has been created for the type, check whether there is
+ -- a primitive equality declared for it. If it is abstract replace
+ -- the call with an explicit raise.
+
+ declare
+ Prim : Elmt_Id;
+
+ begin
+ Prim := First_Elmt (Collect_Primitive_Operations (Full_Type));
+ while Present (Prim) loop
+ if Chars (Node (Prim)) = Name_Op_Eq then
+ if Is_Abstract_Subprogram (Node (Prim)) then
+ return
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Explicit_Raise);
+ else
+ return
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Node (Prim), Loc),
+ Parameter_Associations => New_List (Lhs, Rhs));
+ end if;
+ end if;
+
+ Next_Elmt (Prim);
+ end loop;
+ end;
+
+ -- Predfined equality applies iff no user-defined primitive exists
+
+ return Make_Op_Eq (Loc, Lhs, Rhs);
else
return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
end if;
else
+
-- It can be a simple record or the full view of a scalar private
return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
begin
-- Loop to find enclosing construct containing activation chain variable
+ -- The construct is a body, a block, or an extended return.
P := Parent (N);
while not Nkind_In (P, N_Subprogram_Body,
+ N_Entry_Body,
N_Package_Declaration,
N_Package_Body,
N_Block_Statement,
(RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+ Set_Is_Statically_Allocated (DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+
-- Generate the SCIL node for the previous object declaration
-- because it has a tag initialization.
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+ Set_Is_Statically_Allocated (DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+
-- Generate the SCIL node for the previous object declaration
-- because it has a tag initialization.
Analyze_List (Result);
Set_Suppress_Init_Proc (Base_Type (DT_Prims));
+ -- Disable backend optimizations based on assumptions about the
+ -- aliasing status of objects designated by the access to the
+ -- dispatch table. Required to handle dispatch tables imported
+ -- from C++.
+
+ Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc));
+
-- Add the freezing nodes of these declarations; required to avoid
-- generating these freezing nodes in wrong scopes (for example in
-- the IC routine of a derivation of Typ).
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \
ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \
- ada/erroutc.ads ada/exp_atag.ads ada/exp_atag.adb ada/exp_dist.ads \
- ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/fname-uf.ads \
- ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \
- ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \
- ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/sem.ads \
- ada/sem_aux.ads ada/sem_ch7.ads ada/sem_dist.ads ada/sem_util.ads \
- ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
+ ada/erroutc.ads ada/exp_atag.ads ada/exp_atag.adb ada/exp_disp.ads \
+ ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \
+ ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \
+ ada/lib.ads ada/lib-load.ads ada/namet.ads ada/nlists.ads \
+ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \
+ ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch7.ads \
+ ada/sem_disp.ads ada/sem_dist.ads ada/sem_util.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \
- ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \
- ada/erroutc.ads ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads \
- ada/fname.ads ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads \
- ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads ada/hostparm.ads \
- ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \
- ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/nlists.ads \
- ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
- ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \
- ada/sem.ads ada/sem_aux.ads ada/sem_ch13.ads ada/sem_ch13.adb \
- ada/sem_ch3.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads \
- ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
- ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
- ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
- ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
- ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/urealp.adb
+ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/exp_disp.ads ada/exp_dist.ads \
+ ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/fname-uf.ads \
+ ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb \
+ ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \
+ ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \
+ ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
+ ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
+ ada/rtsfind.ads ada/rtsfind.adb ada/sem.ads ada/sem_aux.ads \
+ ada/sem_ch13.ads ada/sem_ch13.adb ada/sem_ch3.ads ada/sem_ch7.ads \
+ ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
+ ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
+ ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \
+ ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb
ada/sem_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
@item ^-E^/STORE_TRACEBACKS^
@cindex @option{^-E^/STORE_TRACEBACKS^} (@command{gnatbind})
Store tracebacks in exception occurrences when the target supports it.
-This is the default with the zero cost exception mechanism.
@ignore
@c The following may get moved to an appendix
This option is currently supported on the following targets:
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Make : constant String := "make";
Make_Path : String_Access;
- procedure Create_Directory (Name : System.Address; Mode : Integer);
- pragma Import (C, Create_Directory, "decc$mkdir");
+ procedure Create_Directory (Name : System.Address);
+ pragma Import (C, Create_Directory, "__gnat_mkdir");
begin
if Argument_Count = 0 then
-- Create the new top level library directory
if not Is_Directory (Lib_Dir.all) then
- Create_Directory (C_Lib_Dir'Address, 8#755#);
+ Create_Directory (C_Lib_Dir'Address);
end if;
full_name (C_ADC_File'Address, F_ADC_File'Address);
function P_Defining_Character_Literal return Node_Id is
Literal_Node : Node_Id;
-
begin
Literal_Node := Token_Node;
Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
-- For the object path, we make a distinction depending on
-- Including_Libraries.
- if Objects_Path and then Including_Libraries then
+ if Objects_Path and Including_Libraries then
if Project.Objects_Path_File_With_Libs = No_Path then
Object_Path_Table.Init (Object_Paths);
Process_Object_Dirs := True;
-- If there is something to do, set Seen to False for all projects,
-- then call the recursive procedure Add for Project.
- if Process_Source_Dirs or else Process_Object_Dirs then
+ if Process_Source_Dirs or Process_Object_Dirs then
For_All_Projects (Project, Dummy);
end if;
N2 := Get_Associated_Node (N);
E := Entity (N2);
+ -- If the entity is an itype created as a subtype of an access type
+ -- with a null exclusion restore source entity for proper visibility.
+ -- The itype will be created anew in the instance.
+
if Present (E) then
+ if Is_Itype (E)
+ and then Ekind (E) = E_Access_Subtype
+ and then Is_Entity_Name (N)
+ and then Chars (Etype (E)) = Chars (N)
+ then
+ E := Etype (E);
+ Set_Entity (N2, E);
+ Set_Etype (N2, E);
+ end if;
+
if Is_Global (E) then
Set_Global_Type (N, N2);
elsif Nkind (N) = N_Op_Concat
and then Is_Generic_Type (Etype (N2))
- and then
- (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
- or else Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
+ and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
+ or else
+ Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
and then Is_Intrinsic_Subprogram (E)
then
null;
and then Is_Generic_Unit (Scope (Gen_Id))
and then In_Open_Scopes (Scope (Gen_Id))
then
- -- This is an instantiation of a child unit within a sibling,
- -- so that the generic parent is in scope. An eventual instance
- -- must occur within the scope of an instance of the parent.
- -- Make name in instance into an expanded name, to preserve the
- -- identifier of the parent, so it can be resolved subsequently.
+ -- This is an instantiation of a child unit within a sibling, so
+ -- that the generic parent is in scope. An eventual instance must
+ -- occur within the scope of an instance of the parent. Make name
+ -- in instance into an expanded name, to preserve the identifier
+ -- of the parent, so it can be resolved subsequently.
Rewrite (Name (N2),
Make_Expanded_Name (Loc,
and then not Is_Dispatching_Operation (S)
then
Make_Inequality_Operator (S);
+
+ -- In Ada 2012, a primitive equality operator on a record type
+ -- must appear before the type is frozen, and have the same
+ -- visibility as the type.
+
+ declare
+ Typ : constant Entity_Id := Etype (First_Formal (S));
+ Decl : constant Node_Id := Unit_Declaration_Node (S);
+
+ begin
+ if Ada_Version >= Ada_12
+ and then Nkind (Decl) = N_Subprogram_Declaration
+ and then Is_Record_Type (Typ)
+ then
+ if Is_Frozen (Typ) then
+ Error_Msg_NE
+ ("equality operator must be declared "
+ & "before type& is frozen", S, Typ);
+
+ elsif List_Containing (Parent (Typ))
+ /=
+ List_Containing (Decl)
+ and then not Is_Limited_Type (Typ)
+ then
+ Error_Msg_N
+ ("equality operator appears too late", S);
+ end if;
+ end if;
+ end;
end if;
end New_Overloaded_Entity;
projects / thirdparty / gcc.git / commitdiff
