-- 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.
+ -- AI05-0123: Equality on untagged records composes. This procedure
+ -- builds the equality routine for an untagged record that has components
+ -- of a record type that has user-defined primitive equality operations.
-- The resulting operation is a TSS subprogram.
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
(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
+ -- type, or in Ada 2012 for any record type that has components with a
-- user-defined equality. Factored out of Predefined_Primitive_Bodies.
function Make_Eq_Case
-- invoking the inherited subprogram's parent subprogram and extended
-- with a null association list.
+ function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
+ -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
+ -- null procedures inherited from an interface type that have not been
+ -- overridden. Only one null procedure will be created for a given set of
+ -- inherited null procedures with homographic profiles.
+
function Predef_Spec_Or_Body
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
if Has_Task (Full_Type) then
if Restriction_Active (No_Task_Hierarchy) then
-
- -- 3 is System.Tasking.Library_Task_Level
- -- (should be rtsfindable constant ???)
-
- Append_To (Args, Make_Integer_Literal (Loc, 3));
-
+ Append_To (Args,
+ New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
else
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
end if;
and then Has_New_Controlled_Component (Enclos_Type)
and then Has_Controlled_Component (Typ)
then
- if Is_Inherently_Limited_Type (Typ) then
+ if Is_Immutably_Limited_Type (Typ) then
Controller_Typ := RTE (RE_Limited_Record_Controller);
else
Controller_Typ := RTE (RE_Record_Controller);
if Needs_Finalization (Typ)
and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
- and then not Is_Inherently_Limited_Type (Typ)
+ and then not Is_Immutably_Limited_Type (Typ)
then
declare
Ref : constant Node_Id :=
if Has_Task (Rec_Type) then
if Restriction_Active (No_Task_Hierarchy) then
-
- -- 3 is System.Tasking.Library_Task_Level
-
- Append_To (Args, Make_Integer_Literal (Loc, 3));
+ Append_To (Args,
+ New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
else
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
end if;
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.
+ -- Check whether the type T has a user-defined primitive equality. If so
+ -- return it, else return Empty. If true for a component of Typ, we have
+ -- to build the primitive equality for it.
---------------------
-- User_Defined_Eq --
begin
-- If a record component has a primitive equality operation, we must
- -- builde the corresponding one for the current type.
+ -- build the corresponding one for the current type.
Build_Eq := False;
Comp := First_Component (Typ);
Eq_Op := Empty;
while Present (Prim) loop
if Chars (Node (Prim)) = Name_Op_Eq
- and then Comes_From_Source (Node (Prim))
+ and then Comes_From_Source (Node (Prim))
+
+ -- Don't we also need to check formal types and return type as in
+ -- User_Defined_Eq above???
+
then
Eq_Op := Node (Prim);
Build_Eq := False;
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.
+ -- 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)));
(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 loop;
end if;
- -- If not inherited and not user-defined, build body as for a type
- -- with tagged components.
+ -- 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));
+ Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
Op := Defining_Entity (Decl);
Set_TSS (Typ, Op);
Set_Is_Pure (Op);
-- creating the object (via allocator) and initializing it.
if Is_Return_Object (Def_Id)
- and then Is_Inherently_Limited_Type (Typ)
+ and then Is_Immutably_Limited_Type (Typ)
then
null;
Iface : constant Entity_Id := Root_Type (Typ);
Expr_N : Node_Id := Expr;
Expr_Typ : Entity_Id;
-
- Decl_1 : Node_Id;
- Decl_2 : Node_Id;
New_Expr : Node_Id;
+ Obj_Id : Entity_Id;
+ Tag_Comp : Node_Id;
begin
-- If the original node of the expression was a conversion
-- to this specific class-wide interface type then we
- -- restore the original node to generate code that
- -- statically displaces the pointer to the interface
- -- component.
+ -- restore the original node because we must copy the object
+ -- before displacing the pointer to reference the secondary
+ -- tag component. This code must be kept synchronized with
+ -- the expansion done by routine Expand_Interface_Conversion
if not Comes_From_Source (Expr_N)
- and then Nkind (Expr_N) = N_Unchecked_Type_Conversion
+ and then Nkind (Expr_N) = N_Explicit_Dereference
and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
and then Etype (Original_Node (Expr_N)) = Typ
then
Set_Expression (N, Expr_N);
end if;
+ Obj_Id := Make_Temporary (Loc, 'D', Expr_N);
Expr_Typ := Base_Type (Etype (Expr_N));
if Is_Class_Wide_Type (Expr_Typ) then
-- CW : I'Class := Obj;
-- by
-- Tmp : T := Obj;
- -- CW : I'Class renames TiC!(Tmp.I_Tag);
+ -- type Ityp is not null access I'Class;
+ -- CW : I'Class renames Ityp(Tmp.I_Tag'Address).all;
if Comes_From_Source (Expr_N)
and then Nkind (Expr_N) = N_Identifier
and then not Is_Interface (Expr_Typ)
+ and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
and then (Expr_Typ = Etype (Expr_Typ)
or else not
Is_Variable_Size_Record (Etype (Expr_Typ)))
then
- Decl_1 :=
+ -- Copy the object
+
+ Insert_Action (N,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Temporary (Loc, 'D', Expr_N),
+ Defining_Identifier => Obj_Id,
Object_Definition =>
New_Occurrence_Of (Expr_Typ, Loc),
Expression =>
- Unchecked_Convert_To (Expr_Typ,
- Relocate_Node (Expr_N)));
+ Relocate_Node (Expr_N)));
-- Statically reference the tag associated with the
-- interface
- Decl_2 :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'D'),
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Name =>
- Unchecked_Convert_To (Typ,
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of
- (Defining_Identifier (Decl_1), Loc),
- Selector_Name =>
- New_Reference_To
- (Find_Interface_Tag (Expr_Typ, Iface),
- Loc))));
-
- -- General case:
+ Tag_Comp :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Selector_Name =>
+ New_Reference_To
+ (Find_Interface_Tag (Expr_Typ, Iface), Loc));
-- Replace
-- IW : I'Class := Obj;
-- by
-- type Equiv_Record is record ... end record;
-- implicit subtype CW is <Class_Wide_Subtype>;
- -- Temp : CW := CW!(Obj'Address);
- -- IW : I'Class renames Displace (Temp, I'Tag);
+ -- Tmp : CW := CW!(Obj);
+ -- type Ityp is not null access I'Class;
+ -- IW : I'Class renames
+ -- Ityp!(Displace (Temp'Address, I'Tag)).all;
else
- -- Generate the equivalent record type
+ -- Generate the equivalent record type and update the
+ -- subtype indication to reference it.
Expand_Subtype_From_Expr
(N => N,
Unc_Type => Typ,
Subtype_Indic => Object_Definition (N),
- Exp => Expression (N));
+ Exp => Expr_N);
+
+ if not Is_Interface (Etype (Expr_N)) then
+ New_Expr := Relocate_Node (Expr_N);
+
+ -- For interface types we use 'Address which displaces
+ -- the pointer to the base of the object (if required)
- if not Is_Interface (Etype (Expression (N))) then
- New_Expr := Relocate_Node (Expression (N));
else
New_Expr :=
- Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Expression (N)),
- Attribute_Name => Name_Address)));
+ Unchecked_Convert_To (Etype (Object_Definition (N)),
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Expr_N),
+ Attribute_Name => Name_Address))));
end if;
- Decl_1 :=
+ -- Copy the object
+
+ Insert_Action (N,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Temporary (Loc, 'D', New_Expr),
- Object_Definition =>
+ Defining_Identifier => Obj_Id,
+ Object_Definition =>
New_Occurrence_Of
- (Etype (Object_Definition (N)), Loc),
- Expression =>
- Unchecked_Convert_To
- (Etype (Object_Definition (N)), New_Expr));
-
- Decl_2 :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'D'),
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Name =>
- Unchecked_Convert_To (Typ,
- Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Displace), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of
- (Defining_Identifier (Decl_1), Loc),
- Attribute_Name => Name_Address),
-
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To
- (Node
- (First_Elmt
- (Access_Disp_Table (Iface))),
- Loc))))))));
+ (Etype (Object_Definition (N)), Loc),
+ Expression => New_Expr));
+
+ -- Dynamically reference the tag associated with the
+ -- interface.
+
+ Tag_Comp :=
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Displace), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Attribute_Name => Name_Address),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Iface))),
+ Loc)));
end if;
- Insert_Action (N, Decl_1);
- Rewrite (N, Decl_2);
- Analyze (N);
+ Rewrite (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'D'),
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Name => Convert_Tag_To_Interface (Typ, Tag_Comp)));
+
+ Analyze (N, Suppress => All_Checks);
- -- Replace internal identifier of Decl_2 by the identifier
- -- found in the sources. We also have to exchange entities
- -- containing their defining identifiers to ensure the
- -- correct replacement of the object declaration by this
- -- object renaming declaration (because such definings
- -- identifier have been previously added by Enter_Name to
- -- the current scope). We must preserve the homonym chain
- -- of the source entity as well.
+ -- Replace internal identifier of rewriten node by the
+ -- identifier found in the sources. We also have to exchange
+ -- entities containing their defining identifiers to ensure
+ -- the correct replacement of the object declaration by this
+ -- object renaming declaration ---because these identifiers
+ -- were previously added by Enter_Name to the current scope.
+ -- We must preserve the homonym chain of the source entity
+ -- as well.
Set_Chars (Defining_Identifier (N), Chars (Def_Id));
Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
and then No_Initialization (Expr)
then
null;
- else
+
+ -- Otherwise apply a constraint check now if no prev error
+
+ elsif Nkind (Expr) /= N_Error then
Apply_Constraint_Check (Expr, Typ);
-- If the expression has been marked as requiring a range
-- renaming declaration.
if Needs_Finalization (Typ)
- and then not Is_Inherently_Limited_Type (Typ)
+ and then not Is_Immutably_Limited_Type (Typ)
and then not Rewrite_As_Renaming
then
Insert_Actions_After (Init_After,
Loc := Sloc (First (Component_Items (Comp_List)));
end if;
- if Is_Inherently_Limited_Type (T) then
+ if Is_Immutably_Limited_Type (T) then
Controller_Type := RTE (RE_Limited_Record_Controller);
else
Controller_Type := RTE (RE_Record_Controller);
-------------------------------
procedure Expand_Freeze_Record_Type (N : Node_Id) is
- Def_Id : constant Node_Id := Entity (N);
- Type_Decl : constant Node_Id := Parent (Def_Id);
- Comp : Entity_Id;
- Comp_Typ : Entity_Id;
- Has_Static_DT : Boolean := False;
- Predef_List : List_Id;
+ Def_Id : constant Node_Id := Entity (N);
+ Type_Decl : constant Node_Id := Parent (Def_Id);
+ Comp : Entity_Id;
+ Comp_Typ : Entity_Id;
+ Predef_List : List_Id;
Flist : Entity_Id := Empty;
-- Finalization list allocated for the case of a type with anonymous
-- user-defined equality function). Used to pass this entity from
-- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
- Wrapper_Decl_List : List_Id := No_List;
- Wrapper_Body_List : List_Id := No_List;
+ Wrapper_Decl_List : List_Id := No_List;
+ Wrapper_Body_List : List_Id := No_List;
-- Start of processing for Expand_Freeze_Record_Type
elsif Is_Derived_Type (Def_Id)
and then not Is_Tagged_Type (Def_Id)
- -- If we have a derived Unchecked_Union, we do not inherit the
- -- discriminant checking functions from the parent type since the
- -- discriminants are non existent.
+ -- If we have a derived Unchecked_Union, we do not inherit the
+ -- discriminant checking functions from the parent type since the
+ -- discriminants are non existent.
and then not Is_Unchecked_Union (Def_Id)
and then Has_Discriminants (Def_Id)
-- declaration.
Comp := First_Component (Def_Id);
-
while Present (Comp) loop
Comp_Typ := Etype (Comp);
-- just use it.
if Is_Tagged_Type (Def_Id) then
- Has_Static_DT :=
- Static_Dispatch_Tables
- and then Is_Library_Level_Tagged_Type (Def_Id);
-- Add the _Tag component
Set_CPP_Constructors (Def_Id);
else
- if not Has_Static_DT then
+ if not Building_Static_DT (Def_Id) then
-- Usually inherited primitives are not delayed but the first
-- Ada extension of a CPP_Class is an exception since the
-- Similarly, if this is an inherited operation whose parent is
-- not frozen yet, it is not in the DT of the parent, and we
-- generate an explicit freeze node for the inherited operation
- -- so that it is properly inserted in the DT of the current
- -- type.
+ -- so it is properly inserted in the DT of the current type.
declare
- Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
+ Elmt : Elmt_Id;
Subp : Entity_Id;
begin
+ Elmt := First_Elmt (Primitive_Operations (Def_Id));
while Present (Elmt) loop
Subp := Node (Elmt);
then
null;
+ -- Do not add the spec of predefined primitives in case of
+ -- CIL and Java tagged types
+
+ elsif Convention (Def_Id) = Convention_CIL
+ or else Convention (Def_Id) = Convention_Java
+ then
+ null;
+
-- Do not add the spec of the predefined primitives if we are
-- compiling under restriction No_Dispatching_Calls
Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
end if;
+ -- Ada 2005 (AI-251): For a nonabstract type extension, build
+ -- null procedure declarations for each set of homographic null
+ -- procedures that are inherited from interface types but not
+ -- overridden. This is done to ensure that the dispatch table
+ -- entry associated with such null primitives are properly filled.
+
+ if Ada_Version >= Ada_05
+ and then Etype (Def_Id) /= Def_Id
+ and then not Is_Abstract_Type (Def_Id)
+ and then Has_Interfaces (Def_Id)
+ then
+ Insert_Actions (N, Make_Null_Procedure_Specs (Def_Id));
+ end if;
+
Set_Is_Frozen (Def_Id);
- Set_All_DT_Position (Def_Id);
+ if not Is_Derived_Type (Def_Id)
+ or else Is_Tagged_Type (Etype (Def_Id))
+ then
+ Set_All_DT_Position (Def_Id);
+ end if;
-- Add the controlled component before the freezing actions
-- referenced in those actions.
-- Dispatch tables of library level tagged types are built
-- later (see Analyze_Declarations).
- if not Has_Static_DT then
+ if not Building_Static_DT (Def_Id) then
Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
end if;
end if;
-- 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
+ -- In Ada 2012 the equality function composes, and thus must be built
-- explicitly just as for tagged records.
elsif Has_Discriminants (Def_Id)
declare
Comps : constant Node_Id :=
Component_List (Type_Definition (Type_Decl));
-
begin
if Present (Comps)
and then Present (Variant_Part (Comps))
end if;
end;
- elsif Ada_Version >= Ada_12
- and then Comes_From_Source (Def_Id)
+ -- Otherwise create primitive equality operation (AI05-0123)
+
+ -- This is done unconditionally to ensure that tools can be linked
+ -- properly with user programs compiled with older language versions.
+ -- It might be worth including a switch to revert to a non-composable
+ -- equality for untagged records, even though no program depending on
+ -- non-composability has surfaced ???
+
+ elsif Comes_From_Source (Def_Id)
and then Convention (Def_Id) = Convention_Ada
+ and then not Is_Limited_Type (Def_Id)
then
Build_Untagged_Equality (Def_Id);
end if;
end if;
-- For tagged type that are not interfaces, build bodies of primitive
- -- operations. Note that we do this after building the record
- -- initialization procedure, since the primitive operations may need
- -- the initialization routine. There is no need to add predefined
- -- primitives of interfaces because all their predefined primitives
- -- are abstract.
+ -- operations. Note: do this after building the record initialization
+ -- procedure, since the primitive operations may need the initialization
+ -- routine. There is no need to add predefined primitives of interfaces
+ -- because all their predefined primitives are abstract.
if Is_Tagged_Type (Def_Id)
and then not Is_Interface (Def_Id)
then
null;
+ -- Do not add the body of predefined primitives in case of
+ -- CIL and Java tagged types.
+
+ elsif Convention (Def_Id) = Convention_CIL
+ or else Convention (Def_Id) = Convention_Java
+ then
+ null;
+
-- Do not add the body of the predefined primitives if we are
-- compiling under restriction No_Dispatching_Calls or if we are
-- compiling a CPP tagged type.
Comps := Component_List (Typ_Def);
end if;
- Variant_Case := Present (Comps)
- and then Present (Variant_Part (Comps));
+ Variant_Case :=
+ Present (Comps) and then Present (Variant_Part (Comps));
end if;
if Variant_Case then
end if;
end Make_Eq_If;
+ -------------------------------
+ -- Make_Null_Procedure_Specs --
+ -------------------------------
+
+ function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is
+ Decl_List : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Tag_Typ);
+ Formal : Entity_Id;
+ Formal_List : List_Id;
+ New_Param_Spec : Node_Id;
+ Parent_Subp : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Subp : Entity_Id;
+
+ begin
+ Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+ while Present (Prim_Elmt) loop
+ Subp := Node (Prim_Elmt);
+
+ -- If a null procedure inherited from an interface has not been
+ -- overridden, then we build a null procedure declaration to
+ -- override the inherited procedure.
+
+ Parent_Subp := Alias (Subp);
+
+ if Present (Parent_Subp)
+ and then Is_Null_Interface_Primitive (Parent_Subp)
+ then
+ Formal_List := No_List;
+ Formal := First_Formal (Subp);
+
+ if Present (Formal) then
+ Formal_List := New_List;
+
+ while Present (Formal) loop
+
+ -- Copy the parameter spec including default expressions
+
+ New_Param_Spec :=
+ New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
+
+ -- Generate a new defining identifier for the new formal.
+ -- required because New_Copy_Tree does not duplicate
+ -- semantic fields (except itypes).
+
+ Set_Defining_Identifier (New_Param_Spec,
+ Make_Defining_Identifier (Sloc (Formal),
+ Chars => Chars (Formal)));
+
+ -- For controlling arguments we must change their
+ -- parameter type to reference the tagged type (instead
+ -- of the interface type)
+
+ if Is_Controlling_Formal (Formal) then
+ if Nkind (Parameter_Type (Parent (Formal)))
+ = N_Identifier
+ then
+ Set_Parameter_Type (New_Param_Spec,
+ New_Occurrence_Of (Tag_Typ, Loc));
+
+ else pragma Assert
+ (Nkind (Parameter_Type (Parent (Formal)))
+ = N_Access_Definition);
+ Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
+ New_Occurrence_Of (Tag_Typ, Loc));
+ end if;
+ end if;
+
+ Append (New_Param_Spec, Formal_List);
+
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ Append_To (Decl_List,
+ Make_Subprogram_Declaration (Loc,
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Subp)),
+ Parameter_Specifications => Formal_List,
+ Null_Present => True)));
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ return Decl_List;
+ end Make_Null_Procedure_Specs;
+
-------------------------------------
-- Make_Predefined_Primitive_Specs --
-------------------------------------
OSDN Git Service
