| Message ID | 20111123110039.GA17810@adacore.com |
|---|---|
| State | New |
| Headers | show |
Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 181654) +++ exp_ch6.adb (working copy) @@ -6700,6 +6700,14 @@ Make_Explicit_Dereference (Loc, Prefix => New_Reference_To (Temp, Loc))); + -- Ada 2005 (AI-251): If the type of the returned object is + -- an interface then add an implicit type conversion to force + -- displacement of the "this" pointer. + + if Is_Interface (R_Type) then + Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp))); + end if; + Analyze_And_Resolve (Exp, R_Type); end;
If a function returns a class-wide interface object then the compiler generates code that leaves the interface object not well initialized. This causes wrong dispatching calls at runtime. The following test must compile and execute without run-time errors. package Pkg is type Iface is interface; procedure Prim_1 (Obj : Iface) is abstract; procedure Prim_2 (Obj : Iface) is abstract; type Root is tagged null record; procedure Prim_2 (Obj : Root); procedure Prim_1 (Obj : Root); type DT is new Root and Iface with null record; function Create return Iface'Class; end; with GNAT.IO; use GNAT.IO; package body Pkg is procedure Prim_2 (Obj : Root) is begin raise Program_Error; end; procedure Prim_1 (Obj : Root) is begin Put_Line ("OK"); end; function Create return Iface'Class is begin return DT'(Root with null record); end; end; with Pkg; use Pkg; procedure Main is begin Create.Prim_1; end; Command: gnatmake -gnat05 main; ./main Output: OK Tested on x86_64-pc-linux-gnu, committed on trunk 2011-11-23 Javier Miranda <miranda@adacore.com> * exp_ch6.adb (Expand_Simple_Function_Return): Add missing implicit type conversion when the returned object is allocated in the secondary stack and the type of the returned object is an interface. Done to force generation of displacement of the "this" pointer.