===================================================================
@@ -4379,7 +4379,7 @@
(Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc));
-- If the object decl was already rewritten as a renaming, then we
- -- don't want to do the object allocation and transformation of of
+ -- don't want to do the object allocation and transformation of
-- the return object declaration to a renaming. This case occurs
-- when the return object is initialized by a call to another
-- build-in-place function, and that function is responsible for
@@ -6266,18 +6266,60 @@
if Is_Class_Wide_Type (Etype (Exp))
and then Is_Interface (Etype (Exp))
- and then Nkind (Exp) = N_Explicit_Dereference
then
- Tag_Node :=
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Base_Address), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Address),
- Duplicate_Subexpr (Prefix (Exp)))))));
+ -- If the expression is an explicit dereference then we can
+ -- directly displace the pointer to reference the base of
+ -- the object.
+
+ if Nkind (Exp) = N_Explicit_Dereference then
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ Duplicate_Subexpr (Prefix (Exp)))))));
+
+ -- Similar case to the previous one but the expression is a
+ -- renaming of an explicit dereference.
+
+ elsif Nkind (Exp) = N_Identifier
+ and then Present (Renamed_Object (Entity (Exp)))
+ and then Nkind (Renamed_Object (Entity (Exp)))
+ = N_Explicit_Dereference
+ then
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ Duplicate_Subexpr
+ (Prefix
+ (Renamed_Object (Entity (Exp)))))))));
+
+ -- Common case: obtain the address of the actual object and
+ -- displace the pointer to reference the base of the object.
+
+ else
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Exp),
+ Attribute_Name => Name_Address)))));
+ end if;
else
Tag_Node :=
Make_Attribute_Reference (Loc,
For functions returning class-wide interface types the compiler may generate erroneous code implementing the Ada rule 6.5(8/3), thus causing an unexpected exception at runtime. After this patch the following test compiles and executes without errors. package Ifaces is type Iface is limited interface; end; package Roots is type Root is tagged record X : integer; end record; end; with Ifaces; use Ifaces; with Roots; use Roots; package Maps is type DT is new Root and Iface with null record; function Get_Iface return Iface'Class; end; package body Maps is function Prim return Iface'Class is Obj : DT; begin return Obj; end; function Get_Iface return Iface'Class is begin return Prim; -- test end; end; with Maps; use Maps; with Ifaces; use Ifaces; procedure debug is Junk : Iface'Class := Get_Iface; begin null; end debug; Command: gnatmake debug; ./debug Tested on x86_64-pc-linux-gnu, committed on trunk 2015-03-04 Javier Miranda <miranda@adacore.com> * exp_ch6.adb (Expand_Simple_Function_Return): When the returned object is a class-wide interface object and we generate the accessibility described in RM 6.5(8/3) then displace the pointer to the object to reference the base of the object (to get access to the TSD of the object).