[Ada] Create new attribute Finalization_Size for header of control objects

This patch creates a new attribute Finalization_Size for all objects. Its
result is an integer which represents the internal header size (including
padding) required by the object's type to store the additional data used
during finalization.

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

--  fail.ads

with Ada.Text_IO;
package Fail is
   type T is new Integer;
   package Integer_IO is new Ada.Text_IO.Integer_IO (T);
   Error_1 : Integer := 5'Finalization_Size;          --  ERROR
   Error_2 : Integer := (5 + 31)'Finalization_Size;   --  ERROR
   Error_3 : Integer := Integer_IO'Finalization_Size; --  ERROR
end Fail;

--  fail_second_pass.ads

package Fail_Second_Pass is
  type T2 is new Integer;
  Error : Integer := T2'Finalization_Size; --  ERROR
end Fail_Second_Pass;

--  pass.adb

with Ada.Finalization;     use Ada.Finalization;
with Simple_Storage_Pools; use Simple_Storage_Pools;
with Ada.Text_IO;          use Ada.Text_IO;
procedure Pass is
   type Parent is tagged null record;

   type Non_Ctrl_Child is new Parent with record
      Comp : Integer;
   end record;

   type Ctrl is new Controlled with null record;

   type Ctrl_Child is new Parent with record
      Comp : Ctrl;
   end record;

   type Grand_Child is new Ctrl_Child with null record;

   type Limited_Child is new Limited_Controlled with null record;

   type Array_Child is array (1..50) of Ctrl_Child;

   type Unconst_Array_Child is array (Integer range <>) of Ctrl_Child;

   protected type Prot_Type is
      entry Test;
   private
      Internal : Integer := 0;
   end Prot_Type;

   task type Task_Type is
      entry Test;
   end Task_Type;

   protected body Prot_Type is
     entry Test when True is begin null; end;
   end Prot_Type;

   task body Task_Type is
   begin
      accept Test do null; end Test;
   end Task_Type;

   function Make_Any_Parent
     (Is_Controlled : Boolean) return Parent'Class
   is
   begin
      if Is_Controlled then
         return Result : Ctrl_Child;
      else
         return Result : Non_Ctrl_Child;
      end if;
   end Make_Any_Parent;

   procedure Test (Id : String; Got : Integer; Expect : Integer) is
   begin
     if Expect /= Got then
        Put_Line ("ERROR For " & Id & ", expected value " & Expect'Img &
                  " does not match the recieved value " & Got'Img);
     end if;
   end Test;

   P                  : Parent;
   CC                 : Ctrl_Child;
   NCC                : Non_Ctrl_Child;
   Grand_Child_Inst   : Grand_Child;
   Array_Child_Inst   : Array_Child;
   Pool_Inst          : Simple_Pool;
   Unconst_Array_Inst : Unconst_Array_Child (1..100);
   Prot_Type_Inst     : Prot_Type;
   Task_Type_Inst     : Task_Type;
   Limited_Child_Inst : Limited_Child;
   F_Size             : Integer := CC'Finalization_Size;

begin
   Test ("CC vs Controlled",                                             --  OK
           Make_Any_Parent (True)'Finalization_Size,
           CC'Finalization_Size);                                  
   Test ("NCC vs Non-Controlled",                                        --  OK
           Make_Any_Parent (False)'Finalization_Size, NCC'Finalization_Size);
   Test ("Non-Controlled parent", P'Finalization_Size, 0);               --  OK
   Test ("Task", Task_Type_Inst'Finalization_Size, 0);                   --  OK
   Test ("Grand child", Grand_Child_Inst'Finalization_Size, F_Size);     --  OK
   Test ("Array child", Array_Child_Inst'Finalization_Size, F_Size);     --  OK
   Test ("Pool inst", Pool_Inst'Finalization_Size, F_Size);              --  OK
   Test ("Uconst array", Unconst_Array_Inst'Finalization_Size, F_Size);  --  OK
   Test ("Protected type", Prot_Type_Inst'Finalization_Size, F_Size);    --  OK
   Test ("Limited child", Limited_Child_Inst'Finalization_Size, F_Size); --  OK
   Task_Type_Inst.Test;
end Pass;

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

$ gcc -c fail.ads
$ gcc -c fail_second_pass.ads
$ gnatmake -gnatws -q pass.adb
$ pass
fail.ads:5:26: prefix of attribute must be a name
fail.ads:5:26: qualify expression to turn it into a name
fail.ads:6:33: prefix of attribute must be a name
fail.ads:6:33: qualify expression to turn it into a name
fail_second_pass.ads:3:22: invalid use of subtype mark in expression or call

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

2017-01-06  Justin Squirek  <squirek@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Add entry for
	expansion of Finalization_Size attribute.
	* sem_attr.adb (Analyze_Attribute): Add entry to check the
	semantics of Finalization_Size.
	(Eval_Attribute): Add null entry for Finalization_Size.
	* sem_attr.ads: Add Finalization_Size to the implementation
	dependent attribute list.
	* snames.ads-tmpl: Add name entry for Finalization_Size attribute.

[Ada] Create new attribute Finalization_Size for header of control objects

Commit Message

Patch