* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@164055
138bc75d-0d04-0410-961f-
82ee72b054a4
+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 / platform / upstream / linaro-gcc.git / commitdiff