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 <squi...@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.
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 244125)
+++ exp_attr.adb (working copy)
@@ -3136,6 +3136,117 @@
Analyze_And_Resolve (N, Standard_String);
end External_Tag;
+ -----------------------
+ -- Finalization_Size --
+ -----------------------
+
+ when Attribute_Finalization_Size => Finalization_Size : declare
+
+ function Calculate_Header_Size return Node_Id;
+ -- Generate a runtime call to calculate the size of the hidden
+ -- header along with any added padding which would precede a
+ -- heap-allocated object of the prefix type.
+
+ ---------------------------
+ -- Calculate_Header_Size --
+ ---------------------------
+
+ function Calculate_Header_Size return Node_Id is
+ begin
+ -- Generate:
+ -- Universal_Integer
+ -- (Header_Size_With_Padding (N'Alignment))
+
+ return
+ Convert_To (Universal_Integer,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Header_Size_With_Padding), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Copy_Tree (Pref),
+ Attribute_Name => Name_Alignment))));
+ end Calculate_Header_Size;
+
+ -- Local variables
+
+ Size : constant Entity_Id := Make_Temporary (Loc, 'S');
+
+ -- Start of Finalization_Size
+
+ begin
+ -- An object of a class-wide type requires a runtime check to
+ -- determine whether it is actually controlled or not. Depending on
+ -- the outcome of this check, the Finalization_Size of the object
+ -- may be zero or some positive value.
+ --
+ -- In this scenario, Obj'Finalization_Size is expanded into
+ --
+ -- Size : Integer := 0;
+ --
+ -- if Needs_Finalization (Pref'Tag) then
+ -- Size :=
+ -- Universal_Integer
+ -- (Header_Size_With_Padding (Pref'Alignment));
+ -- end if;
+ --
+ -- and the attribute reference is replaced with a reference to Size.
+
+ if Is_Class_Wide_Type (Ptyp) then
+ Insert_Actions (N, New_List (
+
+ -- Generate:
+ -- Size : Integer := 0;
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Size,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Integer, Loc),
+ Expression => Make_Integer_Literal (Loc, 0)),
+
+ -- Generate:
+ -- if Needs_Finalization (Pref'Tag) then
+ -- Size := Universal_Integer
+ -- (Header_Size_With_Padding (Pref'Alignment));
+ -- end if;
+
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Needs_Finalization), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Tag,
+ Prefix =>
+ New_Copy_Tree (Pref)))),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Size, Loc),
+ Expression => Calculate_Header_Size)))));
+
+ Rewrite (N, New_Occurrence_Of (Size, Loc));
+
+ -- The the prefix is known to be controlled at compile time.
+ -- Calculate its Finalization_Size by calling runtime routine
+ -- Header_Size_With_Padding.
+
+ elsif Needs_Finalization (Ptyp) then
+ Rewrite (N, Calculate_Header_Size);
+
+ -- The prefix is not a controlled object, its Finalization_Size
+ -- is zero.
+
+ else
+ Rewrite (N, Make_Integer_Literal (Loc, 0));
+ end if;
+
+ Analyze (N);
+ end Finalization_Size;
+
-----------
-- First --
-----------
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 244124)
+++ sem_attr.adb (working copy)
@@ -3833,6 +3833,16 @@
Check_Standard_Prefix;
Rewrite (N, New_Occurrence_Of (Boolean_Literals (Fast_Math), Loc));
+ -----------------------
+ -- Finalization_Size --
+ -----------------------
+
+ when Attribute_Finalization_Size =>
+ Check_E0;
+ Analyze_And_Resolve (P);
+ Check_Object_Reference (P);
+ Set_Etype (N, Universal_Integer);
+
-----------
-- First --
-----------
@@ -8398,6 +8408,13 @@
Fold_Uint (N,
Eval_Fat.Exponent (P_Base_Type, Expr_Value_R (E1)), Static);
+ -----------------------
+ -- Finalization_Size --
+ -----------------------
+
+ when Attribute_Finalization_Size =>
+ null;
+
-----------
-- First --
-----------
Index: sem_attr.ads
===================================================================
--- sem_attr.ads (revision 244124)
+++ sem_attr.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -242,6 +242,16 @@
-- enumeration value. Constraint_Error is raised if no value of the
-- enumeration type corresponds to the given integer value.
+ -----------------------
+ -- Finalization_Size --
+ -----------------------
+
+ Attribute_Finalization_Size => True,
+ -- For every object, Finalization_Size will return the size of the
+ -- internal header required for finalization (including padding). If
+ -- the type is not controlled or contains no controlled components
+ -- then the result is always zero.
+
-----------------
-- Fixed_Value --
-----------------
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 244126)
+++ snames.ads-tmpl (working copy)
@@ -885,6 +885,7 @@
Name_Exponent : constant Name_Id := N + $;
Name_External_Tag : constant Name_Id := N + $;
Name_Fast_Math : constant Name_Id := N + $; -- GNAT
+ Name_Finalization_Size : constant Name_Id := N + $; -- GNAT
Name_First : constant Name_Id := N + $;
Name_First_Bit : constant Name_Id := N + $;
Name_First_Valid : constant Name_Id := N + $; -- Ada 12
@@ -1524,6 +1525,7 @@
Attribute_Exponent,
Attribute_External_Tag,
Attribute_Fast_Math,
+ Attribute_Finalization_Size,
Attribute_First,
Attribute_First_Bit,
Attribute_First_Valid,
