diff mbox series

[Ada] Crash on partial initialization of controlled component

Message ID 20180522134735.GA122202@adacore.com
State New
Headers show
Series [Ada] Crash on partial initialization of controlled component | expand

Commit Message

Pierre-Marie de Rodat May 22, 2018, 1:47 p.m. UTC
This patch modifies the late expansion of record aggregates to ensure that the
generated code which handles a controlled component initialized by a function
call is inserted in line with the rest of the initialization code, rather than
before the record aggregate. This way the function call has proper access to
the discriminants of the object being created.

Tested on x86_64-pc-linux-gnu, committed on trunk

2018-05-22  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* exp_aggr.adb (Initialize_Ctrl_Record_Component): Insert the generated
	code for a transient component in line with the rest of the
	initialization code, rather than before the aggregate. This ensures
	that the component has proper visibility of the discriminants.

gcc/testsuite/

	* gnat.dg/controlled8.adb: New testcase.
diff mbox series

Patch

--- gcc/ada/exp_aggr.adb
+++ gcc/ada/exp_aggr.adb
@@ -2846,7 +2846,7 @@  package body Exp_Aggr is
 
          In_Place_Expansion :=
            Nkind (Init_Expr) = N_Function_Call
-                and then not Is_Build_In_Place_Result_Type (Comp_Typ);
+             and then not Is_Build_In_Place_Result_Type (Comp_Typ);
 
          --  The initialization expression is a controlled function call.
          --  Perform in-place removal of side effects to avoid creating a
@@ -2865,7 +2865,11 @@  package body Exp_Aggr is
             Set_No_Side_Effect_Removal (Init_Expr);
 
             --  Install all hook-related declarations and prepare the clean up
-            --  statements.
+            --  statements. The generated code follows the initialization order
+            --  of individual components and discriminants, rather than being
+            --  inserted prior to the aggregate. This ensures that a transient
+            --  component which mentions a discriminant has proper visibility
+            --  of the discriminant.
 
             Process_Transient_Component
               (Loc        => Loc,
@@ -2873,7 +2877,7 @@  package body Exp_Aggr is
                Init_Expr  => Init_Expr,
                Fin_Call   => Fin_Call,
                Hook_Clear => Hook_Clear,
-               Aggr       => N);
+               Stmts      => Stmts);
          end if;
 
          --  Use the noncontrolled component initialization circuitry to

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/controlled8.adb
@@ -0,0 +1,63 @@ 
+--  { dg-do compile }
+
+with Ada.Finalization; use Ada.Finalization;
+
+procedure Controlled8
+  (Int_Input : Integer;
+   Str_Input : String)
+is
+   type Ctrl is new Controlled with null record;
+   type Integer_Ptr is access all Integer;
+   type String_Ptr  is access all String;
+
+   function Func (Val : Integer) return Ctrl is
+   begin return Result : Ctrl; end Func;
+
+   function Func (Val : String) return Ctrl is
+   begin return Result : Ctrl; end Func;
+
+   type Rec_1 (Val : Integer) is record
+      Comp : Ctrl := Func (Val);
+   end record;
+
+   type Rec_2 (Val : access Integer) is record
+      Comp : Ctrl := Func (Val.all);
+   end record;
+
+   type Rec_3 (Val : Integer_Ptr) is record
+      Comp : Ctrl := Func (Val.all);
+   end record;
+
+   type Rec_4 (Val : access String) is record
+      Comp : Ctrl := Func (Val.all);
+   end record;
+
+   type Rec_5 (Val : String_Ptr) is record
+      Comp : Ctrl := Func (Val.all);
+   end record;
+
+   Int_Heap  : constant Integer_Ptr := new Integer'(Int_Input);
+   Int_Stack : aliased  Integer     := Int_Input;
+   Str_Heap  : constant String_Ptr  := new String'(Str_Input);
+   Str_Stack : aliased  String      := Str_Input;
+
+   Obj_1  : constant Rec_1 := (Val => Int_Input, others => <>);
+
+   Obj_2  : constant Rec_2 := (Val => Int_Heap, others => <>);
+   Obj_3  : constant Rec_2 := (Val => Int_Stack'Access, others => <>);
+   Obj_4  : constant Rec_2 := (Val => new Integer'(Int_Input), others => <>);
+
+   Obj_5  : constant Rec_3 := (Val => Int_Heap, others => <>);
+   Obj_6  : constant Rec_3 := (Val => Int_Stack'Access, others => <>);
+   Obj_7  : constant Rec_3 := (Val => new Integer'(Int_Input), others => <>);
+
+   Obj_8  : constant Rec_4 := (Val => Str_Heap, others => <>);
+   Obj_9  : constant Rec_4 := (Val => Str_Stack'Access, others => <>);
+   Obj_10 : constant Rec_4 := (Val => new String'(Str_Input), others => <>);
+
+   Obj_11 : constant Rec_5 := (Val => Str_Heap, others => <>);
+   Obj_12 : constant Rec_5 := (Val => Str_Stack'Access, others => <>);
+   Obj_13 : constant Rec_5 := (Val => new String'(Str_Input), others => <>);
+begin
+   null;
+end Controlled8;