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 <mira...@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).
Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 221177) +++ exp_ch6.adb (working copy) @@ -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,