===================================================================
@@ -1976,14 +1976,29 @@ package body Exp_Ch5 is
Reason => CE_Tag_Check_Failed));
end if;
- Append_To (L,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Op, Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (F_Typ,
- Duplicate_Subexpr (Lhs)),
- Unchecked_Convert_To (F_Typ,
- Duplicate_Subexpr (Rhs)))));
+ declare
+ Left_N : Node_Id := Duplicate_Subexpr (Lhs);
+ Right_N : Node_Id := Duplicate_Subexpr (Rhs);
+
+ begin
+ -- In order to dispatch the call to _assign the type of
+ -- the actuals must match. Add conversion (if required).
+
+ if Etype (Lhs) /= F_Typ then
+ Left_N := Unchecked_Convert_To (F_Typ, Left_N);
+ end if;
+
+ if Etype (Rhs) /= F_Typ then
+ Right_N := Unchecked_Convert_To (F_Typ, Right_N);
+ end if;
+
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (Op, Loc),
+ Parameter_Associations => New_List (
+ Node1 => Left_N,
+ Node2 => Right_N)));
+ end;
end;
else
===================================================================
@@ -464,6 +464,57 @@ package body Exp_Disp is
end if;
end Build_Static_Dispatch_Tables;
+ ------------------------------
+ -- Convert_Tag_To_Interface --
+ ------------------------------
+
+ function Convert_Tag_To_Interface
+ (Typ : Entity_Id;
+ Expr : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Anon_Type : Entity_Id;
+ Result : Node_Id;
+
+ begin
+ pragma Assert (Is_Class_Wide_Type (Typ)
+ and then Is_Interface (Typ)
+ and then
+ ((Nkind (Expr) = N_Selected_Component
+ and then Is_Tag (Entity (Selector_Name (Expr))))
+ or else
+ (Nkind (Expr) = N_Function_Call
+ and then RTE_Available (RE_Displace)
+ and then Entity (Name (Expr)) = RTE (RE_Displace))));
+
+ Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
+ Set_Directly_Designated_Type (Anon_Type, Typ);
+ Set_Etype (Anon_Type, Anon_Type);
+ Set_Can_Never_Be_Null (Anon_Type);
+
+ -- Decorate the size and alignment attributes of the anonymous access
+ -- type, as required by gigi.
+
+ Layout_Type (Anon_Type);
+
+ if Nkind (Expr) = N_Selected_Component
+ and then Is_Tag (Entity (Selector_Name (Expr)))
+ then
+ Result :=
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (Anon_Type,
+ Make_Attribute_Reference (Loc,
+ Prefix => Expr,
+ Attribute_Name => Name_Address)));
+ else
+ Result :=
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (Anon_Type, Expr));
+ end if;
+
+ return Result;
+ end Convert_Tag_To_Interface;
+
-------------------
-- CPP_Num_Prims --
-------------------
@@ -1152,15 +1203,18 @@ package body Exp_Disp is
pragma Assert (Iface_Tag /= Empty);
-- Keep separate access types to interfaces because one internal
- -- function is used to handle the null value (see following comment)
+ -- function is used to handle the null value (see following comments)
if not Is_Access_Type (Etype (N)) then
+
+ -- Statically displace the pointer to the object to reference
+ -- the component containing the secondary dispatch table.
+
Rewrite (N,
- Unchecked_Convert_To (Etype (N),
+ Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Expression (N)),
- Selector_Name =>
- New_Occurrence_Of (Iface_Tag, Loc))));
+ Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))));
else
-- Build internal function to handle the case in which the
@@ -7976,6 +8030,11 @@ package body Exp_Disp is
if Present (Interface_Alias (Prim)) then
Write_Str (", AI_Alias of ");
+
+ if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
+ Write_Str ("null primitive ");
+ end if;
+
Write_Name
(Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
Write_Char (':');
===================================================================
@@ -186,6 +186,33 @@ package Exp_Disp is
-- bodies they are added to the end of the list of declarations of the
-- package body.
+ function Convert_Tag_To_Interface
+ (Typ : Entity_Id; Expr : Node_Id) return Node_Id;
+ pragma Inline (Convert_Tag_To_Interface);
+ -- This function is used in class-wide interface conversions; the expanded
+ -- code generated to convert a tagged object to a class-wide interface type
+ -- involves referencing the tag component containing the secondary dispatch
+ -- table associated with the interface. Given the expression Expr that
+ -- references a tag component, we cannot generate an unchecked conversion
+ -- to leave the expression decorated with the class-wide interface type Typ
+ -- because an unchecked conversion cannot be seen as a no-op. An unchecked
+ -- conversion is conceptually a function call and therefore the RM allows
+ -- the backend to obtain a copy of the value of the actual object and store
+ -- it in some other place (like a register); in such case the interface
+ -- conversion is not equivalent to a displacement of the pointer to the
+ -- interface and any further displacement fails. Although the functionality
+ -- of this function is simple and could be done directly, the purpose of
+ -- this routine is to leave well documented in the sources these
+ -- occurrences.
+
+ -- If Expr is an N_Selected_Component that references a tag generate:
+ -- type ityp is non null access Typ;
+ -- ityp!(Expr'Address).all
+
+ -- if Expr is an N_Function_Call to Ada.Tags.Displace then generate:
+ -- type ityp is non null access Typ;
+ -- ityp!(Expr).all
+
function CPP_Num_Prims (Typ : Entity_Id) return Nat;
-- Return the number of primitives of the C++ part of the dispatch table.
-- For types that are not derivations of CPP types return 0.
===================================================================
@@ -3760,12 +3760,15 @@ package body Sprint is
when Access_Kind =>
Write_Header (Ekind (Typ) = E_Access_Type);
+
+ if Can_Never_Be_Null (Typ) then
+ Write_Str ("not null ");
+ end if;
+
Write_Str ("access ");
if Is_Access_Constant (Typ) then
Write_Str ("constant ");
- elsif Can_Never_Be_Null (Typ) then
- Write_Str ("not null ");
end if;
Write_Id (Directly_Designated_Type (Typ));
===================================================================
@@ -4809,20 +4809,20 @@ package body Exp_Ch3 is
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
@@ -4839,6 +4839,7 @@ package body Exp_Ch3 is
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
@@ -4849,122 +4850,114 @@ package body Exp_Ch3 is
-- 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);
-
- -- 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.
+ 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 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));