[Ada] Missing finalization in case expression

[Ada] Missing finalization in case expression

This patch modifies the processing of controlled transient objects within case
expressions represented by an Expression_With_Actions node. The inspection of
an individual action must continue in case it denotes a complex expression,
such as a case statement, which in turn may contain additional transients.

------------
-- Source --
------------

--  pack.ads

with Ada.Finalization; use Ada.Finalization;

package Pack is
   function Next_Id return Natural;

   type Ctrl is new Controlled with record
      Id : Natural := 0;
   end record;

   procedure Adjust (Obj : in out Ctrl);
   procedure Finalize (Obj : in out Ctrl);
   procedure Initialize (Obj : in out Ctrl);

   function New_Ctrl return Ctrl;

   Empty : constant Ctrl := (Controlled with Id => 1);

   type Enum is (One, Two, Three);

   type Ctrl_Rec is record
      Comp : Ctrl;
      Kind : Enum;
   end record;

   procedure Proc (Obj : Ctrl_Rec);
end Pack;

--  pack.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Pack is
   Id_Gen : Natural := 1;

   procedure Adjust (Obj : in out Ctrl) is
      Old_Id : constant Natural := Obj.Id;
      New_Id : Natural;

   begin
      if Old_Id = 0 then
         Put_Line ("  adj: ERROR already finalized");
      else
         New_Id := Old_Id * 100;
         Put_Line ("  adj: " & Old_Id'Img & " ->" & New_Id'Img);
         Obj.Id := New_Id;
      end if;
   end Adjust;

   procedure Finalize (Obj : in out Ctrl) is
      Old_Id : constant Natural := Obj.Id;

   begin
      if Old_Id = 0 then
         Put_Line ("  fin: ERROR already finalized");
      else
         Put_Line ("  fin: " & Old_Id'Img);
         Obj.Id := 0;
      end if;
   end Finalize;

   procedure Initialize (Obj : in out Ctrl) is
      New_Id : constant Natural := Next_Id;
   begin
      Put_Line ("  ini: " & New_Id'Img);
      Obj.Id := New_Id;
   end Initialize;

   procedure Proc (Obj : Ctrl_Rec) is
   begin
      Put_Line ("proc : " & Obj.Comp.Id'Img);
   end Proc;

   function Next_Id return Natural is
   begin
      Id_Gen := Id_Gen + 1;
      return Id_Gen;
   end Next_Id;

   function New_Ctrl return Ctrl is
      Obj : Ctrl;
   begin
      return Obj;
   end New_Ctrl;
end Pack;

--  main.adb

with Ada.Text_IO; use Ada.Text_IO;
with Pack;        use Pack;

procedure Main is
   procedure Proc_Case_Expr (Mode : Enum) is
   begin
      Put_Line ("proc_case_expr: " & Mode'Img);
      Proc (case Mode is
               when One   => (Kind => Two,   Comp => Empty),
               when Two   => (Kind => Three, Comp => Empty),
               when Three => (Kind => One,   Comp => New_Ctrl));
   end Proc_Case_Expr;

   procedure Proc_If_Expr (Mode : Enum) is
   begin
      Put_Line ("proc_if_expr: " & Mode'Img);
      Proc ((if    Mode = One then (Kind => Two,   Comp => Empty)
             elsif Mode = Two then (Kind => Three, Comp => Empty)
             else                  (Kind => One,   Comp => New_Ctrl)));
   end Proc_If_Expr;

begin
   Proc_Case_Expr (One);
   Proc_Case_Expr (Two);
   Proc_Case_Expr (Three);

   Proc_If_Expr (One);
   Proc_If_Expr (Two);
   Proc_If_Expr (Three);
end Main;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q main.adb
$ ./main
proc_case_expr: ONE
  adj:  1 -> 100
proc :  100
  fin:  100
proc_case_expr: TWO
  adj:  1 -> 100
proc :  100
  fin:  100
proc_case_expr: THREE
  ini:  2
  adj:  2 -> 200
  fin:  2
  adj:  200 -> 20000
proc :  20000
  fin:  20000
  fin:  200
proc_if_expr: ONE
  adj:  1 -> 100
proc :  100
  fin:  100
proc_if_expr: TWO
  adj:  1 -> 100
proc :  100
  fin:  100
proc_if_expr: THREE
  ini:  3
  adj:  3 -> 300
  fin:  3
  adj:  300 -> 30000
proc :  30000
  fin:  30000
  fin:  300
  fin:  1

2018-01-11  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* exp_ch4.adb (Process_Action): Do not abandon the inspection of an
	individual action because the action may denote a complex expression,
	such as a case statement, which in turn may contain additional
	transient objects.

From-SVN: r256486