OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2011-08-29  Robert Dewar  <dewar@adacore.com>

	* a-exexpr-gcc.adb, a-synbar.adb, sem_ch13.adb: Minor reformatting.

2011-08-29  Bob Duff  <duff@adacore.com>

	* sem_aggr.adb (Resolve_Aggr_Expr): Call this routine even in the case
	of <>, because this is the routine that checks for dimensionality
	errors (for example, for a two-dimensional array, (others => <>) should
	be (others => (others => <>)).

2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* impunit.adb: Add new run-time units.
	* freeze.adb, exp_ch7.ads, exp_ch7.adb, exp_util.ads, exp_util.adb,
	s-stposu.ads, s-stposu.adb: Code clean up.
	Handle protected class-wide or task class-wide types
	Handle C/C++/CIL/Java types.
	* s-spsufi.adb, s-spsufi.ads: New files.

From-SVN: r178205
This commit is contained in:
Arnaud Charlet 2011-08-29 13:12:17 +02:00
parent 5accd7b6ca
commit ca5af305a1
21 changed files with 889 additions and 475 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
gcc/ada/ChangeLog
View File

@ -1,3 +1,23 @@
2011-08-29 Robert Dewar <dewar@adacore.com>
* a-exexpr-gcc.adb, a-synbar.adb, sem_ch13.adb: Minor reformatting.
2011-08-29 Bob Duff <duff@adacore.com>
* sem_aggr.adb (Resolve_Aggr_Expr): Call this routine even in the case
of <>, because this is the routine that checks for dimensionality
errors (for example, for a two-dimensional array, (others => <>) should
be (others => (others => <>)).
2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
* impunit.adb: Add new run-time units.
* freeze.adb, exp_ch7.ads, exp_ch7.adb, exp_util.ads, exp_util.adb,
s-stposu.ads, s-stposu.adb: Code clean up.
Handle protected class-wide or task class-wide types
Handle C/C++/CIL/Java types.
* s-spsufi.adb, s-spsufi.ads: New files.
2011-08-29 Yannick Moy <moy@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): Reject test-case on

5
gcc/ada/Makefile.rtl
View File

@ -155,7 +155,6 @@ GNATRTL_NONTASKING_OBJS= \
a-envvar$(objext) \
a-except$(objext) \
a-exctra$(objext) \
a-fihema$(objext) \
a-finali$(objext) \
a-flteio$(objext) \
a-fwteio$(objext) \
@ -291,6 +290,7 @@ GNATRTL_NONTASKING_OBJS= \
a-tiunio$(objext) \
a-unccon$(objext) \
a-uncdea$(objext) \
a-undesu$(objext) \
a-wichha$(objext) \
a-wichun$(objext) \
a-widcha$(objext) \
@ -496,6 +496,7 @@ GNATRTL_NONTASKING_OBJS= \
s-ficobl$(objext) \
s-fileio$(objext) \
s-filofl$(objext) \
s-finmas$(objext) \
s-finroo$(objext) \
s-fishfl$(objext) \
s-flocon$(objext) \
@ -606,12 +607,14 @@ GNATRTL_NONTASKING_OBJS= \
s-sequio$(objext) \
s-shasto$(objext) \
s-soflin$(objext) \
s-spsufi$(objext) \
s-stache$(objext) \
s-stalib$(objext) \
s-stausa$(objext) \
s-stchop$(objext) \
s-stoele$(objext) \
s-stopoo$(objext) \
s-stposu$(objext) \
s-stratt$(objext) \
s-strhas$(objext) \
s-string$(objext) \

46
gcc/ada/a-exexpr-gcc.adb
View File

@ -277,13 +277,15 @@ package body Exception_Propagation is
procedure GNAT_GCC_Exception_Cleanup
(Reason : Unwind_Reason_Code;
Excep : not null GNAT_GCC_Exception_Access) is
Excep : not null GNAT_GCC_Exception_Access)
is
pragma Unreferenced (Reason);
procedure Free is new Unchecked_Deallocation
(GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
Copy : GNAT_GCC_Exception_Access := Excep;
begin
-- Simply free the memory
@ -303,6 +305,7 @@ package body Exception_Propagation is
UW_Argument : System.Address) return Unwind_Reason_Code
is
pragma Unreferenced (UW_Version, UW_Eclass, UW_Context, UW_Argument);
begin
-- Terminate when the end of the stack is reached
@ -332,6 +335,7 @@ package body Exception_Propagation is
Reraised : Boolean := False)
is
pragma Unreferenced (Excep, Current, Reraised);
begin
-- In the GNAT-SJLJ case this "stack" only exists implicitly, by way of
-- local occurrence declarations together with save/restore operations
@ -345,8 +349,10 @@ package body Exception_Propagation is
-------------------------
procedure Setup_Current_Excep
(GCC_Exception : not null GCC_Exception_Access) is
(GCC_Exception : not null GCC_Exception_Access)
is
Excep : constant EOA := Get_Current_Excep.all;
begin
-- Setup the exception occurrence
@ -356,7 +362,7 @@ package body Exception_Propagation is
declare
GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
To_GNAT_GCC_Exception (GCC_Exception);
To_GNAT_GCC_Exception (GCC_Exception);
begin
Excep.all := GNAT_Occurrence.Occurrence;
end;
@ -404,7 +410,8 @@ package body Exception_Propagation is
-----------------------------
procedure Reraise_GCC_Exception
(GCC_Exception : not null GCC_Exception_Access) is
(GCC_Exception : not null GCC_Exception_Access)
is
begin
-- Simply propagate it
Propagate_GCC_Exception (GCC_Exception);
@ -418,7 +425,8 @@ package body Exception_Propagation is
-- the two phase scheme it implements.
procedure Propagate_GCC_Exception
(GCC_Exception : not null GCC_Exception_Access) is
(GCC_Exception : not null GCC_Exception_Access)
is
begin
-- Perform a standard raise first. If a regular handler is found, it
-- will be entered after all the intermediate cleanups have run. If
@ -436,15 +444,15 @@ package body Exception_Propagation is
-- Now, un a forced unwind to trigger cleanups. Control should not
-- resume there, if there are cleanups and in any cases as the
-- unwinding hook calls Unhandled_Exception_Terminate when end of stack
-- is reached.
-- unwinding hook calls Unhandled_Exception_Terminate when end of
-- stack is reached.
Unwind_ForcedUnwind (GCC_Exception,
CleanupUnwind_Handler'Address,
System.Null_Address);
-- We get here in case of error.
-- The debugger has been notified before the second step above.
-- We get here in case of error. The debugger has been notified before
-- the second step above.
Setup_Current_Excep (GCC_Exception);
Unhandled_Exception_Terminate;
@ -455,8 +463,8 @@ package body Exception_Propagation is
-------------------------
-- Build an object suitable for the libgcc processing and call
-- Unwind_RaiseException to actually throw, taking care of handling
-- the two phase scheme it implements.
-- Unwind_RaiseException to actually do the raise, taking care of
-- handling the two phase scheme it implements.
procedure Propagate_Exception
(E : Exception_Id;
@ -494,14 +502,16 @@ package body Exception_Propagation is
-- Allocate the GCC exception
GCC_Exception := new GNAT_GCC_Exception'
(Header => (Class => GNAT_Exception_Class,
Cleanup => GNAT_GCC_Exception_Cleanup'Address,
Private1 => 0,
Private2 => 0),
Occurrence => Excep.all);
GCC_Exception :=
new GNAT_GCC_Exception'
(Header => (Class => GNAT_Exception_Class,
Cleanup => GNAT_GCC_Exception_Cleanup'Address,
Private1 => 0,
Private2 => 0),
Occurrence => Excep.all);
-- Propagate it
-- Propagate it.
Propagate_GCC_Exception (To_GCC_Exception (GCC_Exception));
end Propagate_Exception;

1
gcc/ada/a-synbar.adb
View File

@ -61,7 +61,6 @@ package body Ada.Synchronous_Barriers is
Notified := Wait'Count = 0;
end Wait;
end Synchronous_Barrier;
----------------------

17
gcc/ada/a-undesu.adb
View File

@ -17,20 +17,15 @@
-- ??? What is the header version here, see a-uncdea.adb. No GPL?
with System.Storage_Pools.Subpools; use System.Storage_Pools.Subpools;
with System.Storage_Pools.Subpools,
System.Storage_Pools.Subpools.Finalization;
use System.Storage_Pools.Subpools,
System.Storage_Pools.Subpools.Finalization;
procedure Ada.Unchecked_Deallocate_Subpool
(Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle)
is
begin
-- Finalize all controlled objects allocated on the input subpool
-- ??? It is awkward to create a child of Storage_Pools.Subpools for the
-- sole purpose of exporting Finalize_Subpool.
-- Finalize_Subpool (Subpool);
-- Dispatch to the user-defined implementation of Deallocate_Subpool
Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
Finalize_And_Deallocate (Subpool);
end Ada.Unchecked_Deallocate_Subpool;

40
gcc/ada/exp_ch3.adb
View File

@ -6626,35 +6626,31 @@ package body Exp_Ch3 is
-- finalization support if not needed.
if not Comes_From_Source (Def_Id)
and then not Has_Private_Declaration (Def_Id)
and then not Has_Private_Declaration (Def_Id)
then
null;
elsif (Needs_Finalization (Desig_Type)
and then Convention (Desig_Type) /= Convention_Java
and then Convention (Desig_Type) /= Convention_CIL)
-- An exception is made for types defined in the run-time because
-- Ada.Tags.Tag itself is such a type and cannot afford this
-- unnecessary overhead that would generates a loop in the
-- expansion scheme. Another exception is if Restrictions
-- (No_Finalization) is active, since then we know nothing is
-- controlled.
elsif Restriction_Active (No_Finalization)
or else In_Runtime (Def_Id)
then
null;
-- The machinery assumes that incomplete or private types are
-- always completed by a controlled full vies.
elsif Needs_Finalization (Desig_Type)
or else
(Is_Incomplete_Or_Private_Type (Desig_Type)
and then No (Full_View (Desig_Type))
-- An exception is made for types defined in the run-time
-- because Ada.Tags.Tag itself is such a type and cannot
-- afford this unnecessary overhead that would generates a
-- loop in the expansion scheme...
and then not In_Runtime (Def_Id)
-- Another exception is if Restrictions (No_Finalization)
-- is active, since then we know nothing is controlled.
and then not Restriction_Active (No_Finalization))
-- If the designated type is not frozen yet, its controlled
-- status must be retrieved explicitly.
and then No (Full_View (Desig_Type)))
or else
(Is_Array_Type (Desig_Type)
and then not Is_Frozen (Desig_Type)
and then Needs_Finalization (Component_Type (Desig_Type)))
then
Build_Finalization_Master (Def_Id);

248
gcc/ada/exp_ch4.adb
View File

@ -91,12 +91,13 @@ package body Exp_Ch4 is
-- If a boolean array assignment can be done in place, build call to
-- corresponding library procedure.
procedure Complete_Controlled_Allocation (Temp_Decl : Node_Id);
-- Subsidiary to Expand_N_Allocator and Expand_Allocator_Expression. Formal
-- Temp_Decl is the declaration of a temporary which hold the value of the
-- original allocator. Create a custom Allocate routine for the expression
-- of Temp_Decl. The routine does special processing for anonymous access
-- types.
function Current_Unit_First_Declaration return Node_Id;
-- Return the current unit's first declaration. If the declaration list is
-- empty, the routine generates a null statement and returns it.
function Current_Unit_Scope return Entity_Id;
-- Return the scope of the current unit. If the current unit is a body,
-- return the scope of the spec.
procedure Displace_Allocator_Pointer (N : Node_Id);
-- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
@ -375,121 +376,78 @@ package body Exp_Ch4 is
end Build_Boolean_Array_Proc_Call;
------------------------------------
-- Complete_Controlled_Allocation --
-- Current_Unit_First_Declaration --
------------------------------------
procedure Complete_Controlled_Allocation (Temp_Decl : Node_Id) is
pragma Assert (Nkind (Temp_Decl) = N_Object_Declaration);
Ptr_Typ : constant Entity_Id := Etype (Defining_Identifier (Temp_Decl));
function First_Declaration_Of_Current_Unit return Node_Id;
-- Return the current unit's first declaration. If the declaration list
-- is empty, the routine generates a null statement and returns it.
---------------------------------------
-- First_Declaration_Of_Current_Unit --
---------------------------------------
function First_Declaration_Of_Current_Unit return Node_Id is
Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit));
Decl : Node_Id;
Decls : List_Id;
begin
if Nkind (Sem_U) = N_Package_Declaration then
Sem_U := Specification (Sem_U);
Decls := Visible_Declarations (Sem_U);
if No (Decls) then
Decl := Make_Null_Statement (Sloc (Sem_U));
Decls := New_List (Decl);
Set_Visible_Declarations (Sem_U, Decls);
else
Decl := First (Decls);
end if;
else
Decls := Declarations (Sem_U);
if No (Decls) then
Decl := Make_Null_Statement (Sloc (Sem_U));
Decls := New_List (Decl);
Set_Declarations (Sem_U, Decls);
else
Decl := First (Decls);
end if;
end if;
return Decl;
end First_Declaration_Of_Current_Unit;
-- Start of processing for Complete_Controlled_Allocation
function Current_Unit_First_Declaration return Node_Id is
Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit));
Decl : Node_Id;
Decls : List_Id;
begin
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
if Nkind (Sem_U) = N_Package_Declaration then
Sem_U := Specification (Sem_U);
Decls := Visible_Declarations (Sem_U);
if Restriction_Active (No_Finalization) then
return;
if No (Decls) then
Decl := Make_Null_Statement (Sloc (Sem_U));
Decls := New_List (Decl);
Set_Visible_Declarations (Sem_U, Decls);
-- Do nothing if the access type may never allocate an object
elsif Is_Empty_List (Decls) then
Decl := Make_Null_Statement (Sloc (Sem_U));
Append_To (Decls, Decl);
elsif No_Pool_Assigned (Ptr_Typ) then
return;
else
Decl := First (Decls);
end if;
-- Access-to-controlled types are not supported on .NET/JVM
else
Decls := Declarations (Sem_U);
elsif VM_Target /= No_VM then
return;
if No (Decls) then
Decl := Make_Null_Statement (Sloc (Sem_U));
Decls := New_List (Decl);
Set_Declarations (Sem_U, Decls);
elsif Is_Empty_List (Decls) then
Decl := Make_Null_Statement (Sloc (Sem_U));
Append_To (Decls, Decl);
else
Decl := First (Decls);
end if;
end if;
-- ??? Now that finalization masters act as heterogeneous lists, it
-- might be worthed to revisit the global master approach.
return Decl;
end Current_Unit_First_Declaration;
-- Processing for anonymous access-to-controlled types. These access
-- types receive a special finalization master which appears in the
-- declarations of the enclosing semantic unit.
------------------------
-- Current_Unit_Scope --
------------------------
if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then No (Finalization_Master (Ptr_Typ))
and then
(not Restriction_Active (No_Nested_Finalization)
or else Is_Library_Level_Entity (Ptr_Typ))
then
declare
Pool_Id : constant Entity_Id :=
Get_Global_Pool_For_Access_Type (Ptr_Typ);
Scop : Node_Id := Cunit_Entity (Current_Sem_Unit);
function Current_Unit_Scope return Entity_Id is
Scop_Id : Entity_Id := Cunit_Entity (Current_Sem_Unit);
Subp_Bod : Node_Id;
begin
-- Use the scope of the current semantic unit when analyzing
begin
if Ekind (Scop_Id) = E_Subprogram_Body then
if Ekind (Scop) = E_Subprogram_Body then
Scop := Corresponding_Spec (Parent (Parent (Parent (Scop))));
end if;
-- When processing subprogram bodies, the proper scope is always
-- that of the spec.
Build_Finalization_Master
(Typ => Ptr_Typ,
Ins_Node => First_Declaration_Of_Current_Unit,
Encl_Scope => Scop);
Subp_Bod := Scop_Id;
while Present (Subp_Bod)
and then Nkind (Subp_Bod) /= N_Subprogram_Body
loop
Subp_Bod := Parent (Subp_Bod);
end loop;
-- Decorate the anonymous access type and the allocator node
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
Set_Storage_Pool (Expression (Temp_Decl), Pool_Id);
end;
Scop_Id := Corresponding_Spec (Subp_Bod);
end if;
-- Since the temporary object reuses the original allocator, generate a
-- custom Allocate routine for the temporary.
if Present (Finalization_Master (Ptr_Typ)) then
Build_Allocate_Deallocate_Proc
(N => Temp_Decl,
Is_Allocate => True);
end if;
end Complete_Controlled_Allocation;
return Scop_Id;
end Current_Unit_Scope;
--------------------------------
-- Displace_Allocator_Pointer --
@ -777,14 +735,13 @@ package body Exp_Ch4 is
return;
end if;
-- Actions inserted before:
-- Temp : constant ptr_T := new T'(Expression);
-- <no CW> Temp._tag := T'tag;
-- <CTRL> Adjust (Finalizable (Temp.all));
-- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
-- Actions inserted before:
-- Temp : constant ptr_T := new T'(Expression);
-- Temp._tag = T'tag; -- when not class-wide
-- [Deep_]Adjust (Temp.all);
-- We analyze by hand the new internal allocator to avoid
-- any recursion and inappropriate call to Initialize
-- We analyze by hand the new internal allocator to avoid any
-- recursion and inappropriate call to Initialize
-- We don't want to remove side effects when the expression must be
-- built in place. In the case of a build-in-place function call,
@ -858,7 +815,7 @@ package body Exp_Ch4 is
Set_No_Initialization (Expression (Temp_Decl));
Insert_Action (N, Temp_Decl);
Complete_Controlled_Allocation (Temp_Decl);
Build_Allocate_Deallocate_Proc (Temp_Decl, True);
Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
-- Attach the object to the associated finalization master.
@ -889,7 +846,7 @@ package body Exp_Ch4 is
Expression => Node);
Insert_Action (N, Temp_Decl);
Complete_Controlled_Allocation (Temp_Decl);
Build_Allocate_Deallocate_Proc (Temp_Decl, True);
-- Attach the object to the associated finalization master.
-- This is done manually on .NET/JVM since those compilers do
@ -961,7 +918,7 @@ package body Exp_Ch4 is
Set_No_Initialization (Expression (Temp_Decl));
Insert_Action (N, Temp_Decl);
Complete_Controlled_Allocation (Temp_Decl);
Build_Allocate_Deallocate_Proc (Temp_Decl, True);
Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
else
@ -976,7 +933,7 @@ package body Exp_Ch4 is
Expression => Node);
Insert_Action (N, Temp_Decl);
Complete_Controlled_Allocation (Temp_Decl);
Build_Allocate_Deallocate_Proc (Temp_Decl, True);
end if;
-- Generate an additional object containing the address of the
@ -1119,7 +1076,7 @@ package body Exp_Ch4 is
Set_No_Initialization (Expression (Temp_Decl));
Insert_Action (N, Temp_Decl);
Complete_Controlled_Allocation (Temp_Decl);
Build_Allocate_Deallocate_Proc (Temp_Decl, True);
Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
-- Attach the object to the associated finalization master. Thisis
@ -3250,8 +3207,9 @@ package body Exp_Ch4 is
Etyp : constant Entity_Id := Etype (Expression (N));
Loc : constant Source_Ptr := Sloc (N);
Desig : Entity_Id;
Temp : Entity_Id;
Nod : Node_Id;
Pool : Entity_Id;
Temp : Entity_Id;
procedure Rewrite_Coextension (N : Node_Id);
-- Static coextensions have the same lifetime as the entity they
@ -3374,22 +3332,51 @@ package body Exp_Ch4 is
Validate_Remote_Access_To_Class_Wide_Type (N);
-- Set the Storage Pool
-- Processing for anonymous access-to-controlled types. These access
-- types receive a special finalization master which appears in the
-- declarations of the enclosing semantic unit. This expansion is done
-- now to ensure that any additional types generated by this routine
-- or Expand_Allocator_Expression inherit the proper type attributes.
Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
if Ekind (PtrT) = E_Anonymous_Access_Type
and then Needs_Finalization (Dtyp)
then
-- Anonymous access-to-controlled types allocate on the global pool
if Present (Storage_Pool (N)) then
if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
if No (Associated_Storage_Pool (PtrT)) then
Set_Associated_Storage_Pool (PtrT,
Get_Global_Pool_For_Access_Type (PtrT));
end if;
-- The finalization master must be inserted and analyzed as part of
-- the current semantic unit.
if No (Finalization_Master (PtrT)) then
Build_Finalization_Master
(Typ => PtrT,
Ins_Node => Current_Unit_First_Declaration,
Encl_Scope => Current_Unit_Scope);
end if;
end if;
-- Set the storage pool and find the appropriate version of Allocate to
-- call.
Pool := Associated_Storage_Pool (Root_Type (PtrT));
Set_Storage_Pool (N, Pool);
if Present (Pool) then
if Is_RTE (Pool, RE_SS_Pool) then
if VM_Target = No_VM then
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
end if;
elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
elsif Is_Class_Wide_Type (Etype (Pool)) then
Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
else
Set_Procedure_To_Call (N,
Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
Find_Prim_Op (Etype (Pool), Name_Allocate));
end if;
end if;
@ -3550,7 +3537,7 @@ package body Exp_Ch4 is
and then Present (Finalization_Master (PtrT))
then
Build_Allocate_Deallocate_Proc
(N => Parent (N),
(N => N,
Is_Allocate => True);
end if;
@ -3788,14 +3775,13 @@ package body Exp_Ch4 is
Nod := Relocate_Node (N);
-- Here is the transformation:
-- input: new T
-- output: Temp : constant ptr_T := new T;
-- Init (Temp.all, ...);
-- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
-- <CTRL> Initialize (Finalizable (Temp.all));
-- input: new Ctrl_Typ
-- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
-- Ctrl_TypIP (Temp.all, ...);
-- [Deep_]Initialize (Temp.all);
-- Here ptr_T is the pointer type for the allocator, and is the
-- subtype of the allocator.
-- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
-- is the subtype of the allocator.
Temp_Decl :=
Make_Object_Declaration (Loc,
@ -3807,7 +3793,7 @@ package body Exp_Ch4 is
Set_Assignment_OK (Temp_Decl);
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
Complete_Controlled_Allocation (Temp_Decl);
Build_Allocate_Deallocate_Proc (Temp_Decl, True);
-- If the designated type is a task type or contains tasks,
-- create block to activate created tasks, and insert
@ -3844,7 +3830,7 @@ package body Exp_Ch4 is
-- Special processing for .NET/JVM, the allocated object is
-- attached to the finalization master. Generate:
-- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
-- Attach (<PtrT>FC, Root_Controlled_Ptr (Init_Arg1));
-- Types derived from [Limited_]Controlled are the only
-- ones considered since they have fields Prev and Next.

178
gcc/ada/exp_ch7.adb
View File

@ -777,9 +777,8 @@ package body Exp_Ch7 is
return
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Exception_Choices =>
New_List (Make_Others_Choice (Loc)),
Statements => New_List (
Make_If_Statement (Loc,
Condition =>
@ -807,6 +806,7 @@ package body Exp_Ch7 is
Encl_Scope : Entity_Id := Empty)
is
Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ);
Ptr_Typ : Entity_Id := Root_Type (Base_Type (Typ));
function In_Deallocation_Instance (E : Entity_Id) return Boolean;
-- Determine whether entity E is inside a wrapper package created for
@ -840,41 +840,57 @@ package body Exp_Ch7 is
-- Start of processing for Build_Finalization_Master
begin
if Is_Private_Type (Ptr_Typ)
and then Present (Full_View (Ptr_Typ))
then
Ptr_Typ := Full_View (Ptr_Typ);
end if;
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
if Restriction_Active (No_Finalization) then
return;
-- Do not process C, C++, CIL and Java types since it is assumend that
-- the non-Ada side will handle their clean up.
elsif Convention (Desig_Typ) = Convention_C
or else Convention (Desig_Typ) = Convention_CIL
or else Convention (Desig_Typ) = Convention_CPP
or else Convention (Desig_Typ) = Convention_Java
then
return;
-- Various machinery such as freezing may have already created a
-- finalization master.
elsif Present (Finalization_Master (Typ)) then
elsif Present (Finalization_Master (Ptr_Typ)) then
return;
-- Do not process types that return on the secondary stack
elsif Present (Associated_Storage_Pool (Typ))
and then Is_RTE (Associated_Storage_Pool (Typ), RE_SS_Pool)
elsif Present (Associated_Storage_Pool (Ptr_Typ))
and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
then
return;
-- Do not process types which may never allocate an object
elsif No_Pool_Assigned (Typ) then
elsif No_Pool_Assigned (Ptr_Typ) then
return;
-- Do not process access types coming from Ada.Unchecked_Deallocation
-- instances. Even though the designated type may be controlled, the
-- access type will never participate in allocation.
elsif In_Deallocation_Instance (Typ) then
elsif In_Deallocation_Instance (Ptr_Typ) then
return;
-- Ignore the general use of anonymous access types unless the context
-- requires a finalization master.
elsif Ekind (Typ) = E_Anonymous_Access_Type
elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then No (Ins_Node)
then
return;
@ -883,7 +899,7 @@ package body Exp_Ch7 is
-- Finalization is in effect since masters are controlled objects.
elsif Restriction_Active (No_Nested_Finalization)
and then not Is_Library_Level_Entity (Typ)
and then not Is_Library_Level_Entity (Ptr_Typ)
then
return;
@ -898,19 +914,12 @@ package body Exp_Ch7 is
end if;
declare
Loc : constant Source_Ptr := Sloc (Typ);
Loc : constant Source_Ptr := Sloc (Ptr_Typ);
Actions : constant List_Id := New_List;
Fin_Mas_Id : Entity_Id;
Pool_Id : Entity_Id;
Ptr_Typ : Entity_Id := Typ;
begin
-- Access subtypes must use the storage pool of their base type
if Ekind (Ptr_Typ) = E_Access_Subtype then
Ptr_Typ := Base_Type (Ptr_Typ);
end if;
-- Generate:
-- Fnn : aliased Finalization_Master;
@ -994,11 +1003,10 @@ package body Exp_Ch7 is
Pop_Scope;
elsif Ekind (Typ) = E_Access_Subtype
or else (Ekind (Desig_Typ) = E_Incomplete_Type
and then Has_Completion_In_Body (Desig_Typ))
elsif Ekind (Desig_Typ) = E_Incomplete_Type
and then Has_Completion_In_Body (Desig_Typ)
then
Insert_Actions (Parent (Typ), Actions);
Insert_Actions (Parent (Ptr_Typ), Actions);
-- If the designated type is not yet frozen, then append the actions
-- to that type's freeze actions. The actions need to be appended to
@ -1013,10 +1021,10 @@ package body Exp_Ch7 is
then
Append_Freeze_Actions (Desig_Typ, Actions);
elsif Present (Freeze_Node (Typ))
and then not Analyzed (Freeze_Node (Typ))
elsif Present (Freeze_Node (Ptr_Typ))
and then not Analyzed (Freeze_Node (Ptr_Typ))
then
Append_Freeze_Actions (Typ, Actions);
Append_Freeze_Actions (Ptr_Typ, Actions);
-- If there's a pool created locally for the access type, then we
-- need to ensure that the master gets created after the pool object,
@ -1027,12 +1035,12 @@ package body Exp_Ch7 is
-- this point. (This seems a little unclean.???)
elsif VM_Target = No_VM
and then Scope (Pool_Id) = Scope (Typ)
and then Scope (Pool_Id) = Scope (Ptr_Typ)
then
Insert_List_After_And_Analyze (Parent (Pool_Id), Actions);
else
Insert_Actions (Parent (Typ), Actions);
Insert_Actions (Parent (Ptr_Typ), Actions);
end if;
end;
end Build_Finalization_Master;
@ -1448,8 +1456,8 @@ package body Exp_Ch7 is
-- The local exception does not need to be reraised for library-
-- level finalizers. Generate:
--
-- if Raised then
-- Raise_From_Controlled_Operation (E, Abort);
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- end if;
if not For_Package
@ -2297,6 +2305,10 @@ package body Exp_Ch7 is
if Is_Controlled (Typ) then
Init := Find_Prim_Op (Typ, Name_Initialize);
if Present (Init) then
Init := Ultimate_Alias (Init);
end if;
end if;
return
@ -2349,6 +2361,12 @@ package body Exp_Ch7 is
Utyp := Typ;
end if;
if Is_Private_Type (Utyp)
and then Present (Full_View (Utyp))
then
Utyp := Full_View (Utyp);
end if;
-- The init procedures are arranged as follows:
-- Object : Controlled_Type;
@ -3086,20 +3104,13 @@ package body Exp_Ch7 is
E_Id : Entity_Id;
Raised_Id : Entity_Id) return Node_Id
is
Params : List_Id;
Proc_Id : Entity_Id;
begin
-- The default parameter is the local exception occurrence
Params := New_List (New_Reference_To (E_Id, Loc));
-- Standard run-time, .NET/JVM targets, this case handles finalization
-- exceptions raised during an abort.
-- Standard run-time, .NET/JVM targets
if RTE_Available (RE_Raise_From_Controlled_Operation) then
Proc_Id := RTE (RE_Raise_From_Controlled_Operation);
Append_To (Params, New_Reference_To (Abort_Id, Loc));
-- Restricted runtime: exception messages are not supported and hence
-- Raise_From_Controlled_Operation is not supported.
@ -3109,17 +3120,24 @@ package body Exp_Ch7 is
end if;
-- Generate:
-- if Raised_Id then
-- if Raised_Id and then not Abort_Id then
-- <Proc_Id> (<Params>);
-- end if;
return
Make_If_Statement (Loc,
Condition => New_Reference_To (Raised_Id, Loc),
Condition =>
Make_And_Then (Loc,
Left_Opnd => New_Reference_To (Raised_Id, Loc),
Right_Opnd =>
Make_Op_Not (Loc,
Right_Opnd => New_Reference_To (Abort_Id, Loc))),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Proc_Id, Loc),
Parameter_Associations => Params)));
Parameter_Associations =>
New_List (New_Reference_To (E_Id, Loc)))));
end Build_Raise_Statement;
-----------------------------
@ -4325,8 +4343,8 @@ package body Exp_Ch7 is
-- exception
-- when others =>
-- if not Rnn then
-- Rnn := True;
-- if not Raised then
-- Raised := True;
-- Save_Occurrence
-- (Enn, Get_Current_Excep.all.all);
-- end if;
@ -4405,8 +4423,8 @@ package body Exp_Ch7 is
end loop;
-- Generate:
-- if Rnn then
-- Raise_From_Controlled_Operation (E, Abort);
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- end if;
if Built
@ -4723,8 +4741,8 @@ package body Exp_Ch7 is
-- ...
-- end loop;
--
-- if Raised then
-- Raise_From_Controlled_Operation (E, Abort);
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
@ -4789,8 +4807,8 @@ package body Exp_Ch7 is
-- end loop;
-- end;
-- if Raised then
-- Raise_From_Controlled_Operation (E, Abort);
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- end if;
-- raise;
@ -4957,8 +4975,8 @@ package body Exp_Ch7 is
-- begin
-- <core loop>
-- if Raised then -- Expection handlers allowed
-- Raise_From_Controlled_Operation (E, Abort);
-- if Raised and then not Abort then -- Expection handlers OK
-- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
@ -5249,11 +5267,11 @@ package body Exp_Ch7 is
-- <final loop>
-- if Raised then -- Exception handlers allowed
-- Raise_From_Controlled_Operation (E, Abort);
-- if Raised and then not Abort then -- Exception handlers OK
-- Raise_From_Controlled_Operation (E);
-- end if;
-- raise; -- Exception handlers allowed
-- raise; -- Exception handlers OK
-- end;
Stmts := New_List (Build_Counter_Assignment, Final_Loop);
@ -5537,8 +5555,8 @@ package body Exp_Ch7 is
-- end;
-- end if;
--
-- if Raised then
-- Raise_From_Controlled_Object (E, Abort);
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
@ -5622,8 +5640,8 @@ package body Exp_Ch7 is
-- end if;
-- end;
--
-- if Raised then
-- Raise_From_Controlled_Object (E, Abort);
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
@ -6036,8 +6054,8 @@ package body Exp_Ch7 is
-- begin
-- <adjust statements>
-- if Raised then
-- Raise_From_Controlled_Operation (E, Abort);
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
@ -6618,15 +6636,10 @@ package body Exp_Ch7 is
-- Raised : Boolean := False;
-- begin
-- if V.Finalized then
-- return;
-- end if;
-- <finalize statements>
-- V.Finalized := True;
-- if Raised then
-- Raise_From_Controlled_Operation (E, Abort);
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
@ -6917,16 +6930,29 @@ package body Exp_Ch7 is
--------------------------------
procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
Is_Task : constant Boolean :=
Ekind (Typ) = E_Record_Type
and then Is_Concurrent_Record_Type (Typ)
and then Ekind (Corresponding_Concurrent_Type (Typ)) =
E_Task_Type;
Loc : constant Source_Ptr := Sloc (Typ);
Proc_Id : Entity_Id;
Stmts : List_Id;
begin
-- The corresponding records of task types are not controlled by design.
-- For the sake of completeness, create an empty Finalize_Address to be
-- used in task class-wide allocations.
if Is_Task then
null;
-- Nothing to do if the type is not controlled or it already has a
-- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
-- come from source. These are usually generated for completeness and
-- do not need the Finalize_Address primitive.
if not Needs_Finalization (Typ)
elsif not Needs_Finalization (Typ)
or else Is_Abstract_Type (Typ)
or else Present (TSS (Typ, TSS_Finalize_Address))
or else
@ -6944,7 +6970,9 @@ package body Exp_Ch7 is
-- Generate:
-- procedure <Typ>FD (V : System.Address) is
-- begin
-- declare
-- null; -- for tasks
--
-- declare -- for all other types
-- type Pnn is access all Typ;
-- for Pnn'Storage_Size use 0;
-- begin
@ -6952,6 +6980,12 @@ package body Exp_Ch7 is
-- end;
-- end TypFD;
if Is_Task then
Stmts := New_List (Make_Null_Statement (Loc));
else
Stmts := Make_Finalize_Address_Stmts (Typ);
end if;
Discard_Node (
Make_Subprogram_Body (Loc,
Specification =>
@ -6969,8 +7003,7 @@ package body Exp_Ch7 is
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements =>
Make_Finalize_Address_Stmts (Typ))));
Statements => Stmts)));
Set_TSS (Typ, Proc_Id);
end Make_Finalize_Address_Body;
@ -7218,7 +7251,7 @@ package body Exp_Ch7 is
-- Generate:
-- when E : others =>
-- Raise_From_Controlled_Operation (E, False);
-- Raise_From_Controlled_Operation (E);
-- or:
@ -7250,8 +7283,7 @@ package body Exp_Ch7 is
New_Reference_To
(RTE (RE_Raise_From_Controlled_Operation), Loc),
Parameter_Associations => New_List (
New_Reference_To (E_Occ, Loc),
New_Reference_To (Standard_False, Loc)));
New_Reference_To (E_Occ, Loc)));
-- Restricted runtime: exception messages are not supported

4
gcc/ada/exp_ch7.ads
View File

@ -84,8 +84,8 @@ package Exp_Ch7 is
-- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_
-- Deep_Record_Body. Generate the following conditional raise statement:
--
-- if Raised_Id then
-- Raise_From_Controlled_Operation (E_Id, Abort_Id);
-- if Raised_Id and then not Abort_Id then
-- Raise_From_Controlled_Operation (E_Id);
-- end if;
--
-- Abort_Id is a local boolean flag which is set when the finalization was

171
gcc/ada/exp_util.adb
View File

@ -327,10 +327,11 @@ package body Exp_Util is
(N : Node_Id;
Is_Allocate : Boolean)
is
Expr : constant Node_Id := Expression (N);
Ptr_Typ : constant Entity_Id := Etype (Expr);
Desig_Typ : constant Entity_Id :=
Available_View (Designated_Type (Ptr_Typ));
Desig_Typ : Entity_Id;
Expr : Node_Id;
Pool_Id : Entity_Id;
Proc_To_Call : Node_Id := Empty;
Ptr_Typ : Entity_Id;
function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
-- Locate TSS primitive Finalize_Address in type Typ
@ -351,13 +352,33 @@ package body Exp_Util is
Utyp : Entity_Id := Typ;
begin
-- Handle protected class-wide or task class-wide types
if Is_Class_Wide_Type (Utyp) then
if Is_Concurrent_Type (Root_Type (Utyp)) then
Utyp := Root_Type (Utyp);
elsif Is_Private_Type (Root_Type (Utyp))
and then Present (Full_View (Root_Type (Utyp)))
and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
then
Utyp := Full_View (Root_Type (Utyp));
end if;
end if;
-- Handle private types
if Is_Private_Type (Utyp)
and then Present (Full_View (Utyp))
then
Utyp := Full_View (Utyp);
end if;
if Is_Concurrent_Type (Utyp) then
-- Handle protected and task types
if Is_Concurrent_Type (Utyp)
and then Present (Corresponding_Record_Type (Utyp))
then
Utyp := Corresponding_Record_Type (Utyp);
end if;
@ -459,18 +480,91 @@ package body Exp_Util is
-- Start of processing for Build_Allocate_Deallocate_Proc
begin
-- The allocation / deallocation of a non-controlled object does not
-- need the machinery created by this routine.
-- Obtain the attributes of the allocation / deallocation
if not Needs_Finalization (Desig_Typ) then
if Nkind (N) = N_Free_Statement then
Expr := Expression (N);
Ptr_Typ := Base_Type (Etype (Expr));
Proc_To_Call := Procedure_To_Call (N);
else
if Nkind (N) = N_Object_Declaration then
Expr := Expression (N);
else
Expr := N;
end if;
Ptr_Typ := Base_Type (Etype (Expr));
-- The allocator may have been rewritten into something else
if Nkind (Expr) = N_Allocator then
Proc_To_Call := Procedure_To_Call (Expr);
end if;
end if;
Pool_Id := Associated_Storage_Pool (Ptr_Typ);
Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
-- Handle concurrent types
if Is_Concurrent_Type (Desig_Typ)
and then Present (Corresponding_Record_Type (Desig_Typ))
then
Desig_Typ := Corresponding_Record_Type (Desig_Typ);
end if;
-- Do not process allocations / deallocations without a pool
if No (Pool_Id) then
return;
-- The allocator or free statement has already been expanded and already
-- has a custom Allocate / Deallocate routine.
-- Do not process allocations on / deallocations from the secondary
-- stack.
elsif Is_RTE (Pool_Id, RE_SS_Pool) then
return;
-- Do not replicate the machinery if the allocator / free has already
-- been expanded and has a custom Allocate / Deallocate.
elsif Present (Proc_To_Call)
and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
then
return;
end if;
if Needs_Finalization (Desig_Typ) then
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
if Restriction_Active (No_Finalization) then
return;
-- Do nothing if the access type may never allocate / deallocate
-- objects.
elsif No_Pool_Assigned (Ptr_Typ) then
return;
-- Access-to-controlled types are not supported on .NET/JVM since
-- these targets cannot support pools and address arithmetic.
elsif VM_Target /= No_VM then
return;
end if;
-- The allocation / deallocation of a controlled object must be
-- chained on / detached from a finalization master.
pragma Assert (Present (Finalization_Master (Ptr_Typ)));
-- The only other kind of allocation / deallocation supported by this
-- routine is on / from a subpool.
elsif Nkind (Expr) = N_Allocator
and then Present (Procedure_To_Call (Expr))
and then Is_Allocate_Deallocate_Proc (Procedure_To_Call (Expr))
and then No (Subpool_Handle_Name (Expr))
then
return;
end if;
@ -486,36 +580,27 @@ package body Exp_Util is
Fin_Addr_Id : Entity_Id;
Fin_Mas_Act : Node_Id;
Fin_Mas_Id : Entity_Id;
Fin_Mas_Typ : Entity_Id;
Proc_To_Call : Entity_Id;
Subpool : Node_Id := Empty;
begin
-- When dealing with an access subtype, always use the base type
-- since it carries all the attributes.
if Ekind (Ptr_Typ) = E_Access_Subtype then
Fin_Mas_Typ := Base_Type (Ptr_Typ);
else
Fin_Mas_Typ := Ptr_Typ;
end if;
Actuals := New_List;
-- Step 1: Construct all the actuals for the call to library routine
-- Allocate_Any_Controlled / Deallocate_Any_Controlled.
-- a) Storage pool
Append_To (Actuals,
New_Reference_To (Associated_Storage_Pool (Fin_Mas_Typ), Loc));
Actuals := New_List (New_Reference_To (Pool_Id, Loc));
if Is_Allocate then
-- b) Subpool
if Present (Subpool_Handle_Name (Expr)) then
Append_To (Actuals,
New_Reference_To (Entity (Subpool_Handle_Name (Expr)), Loc));
if Nkind (Expr) = N_Allocator then
Subpool := Subpool_Handle_Name (Expr);
end if;
if Present (Subpool) then
Append_To (Actuals, New_Reference_To (Entity (Subpool), Loc));
else
Append_To (Actuals, Make_Null (Loc));
end if;
@ -523,7 +608,7 @@ package body Exp_Util is
-- c) Finalization master
if Needs_Finalization (Desig_Typ) then
Fin_Mas_Id := Finalization_Master (Fin_Mas_Typ);
Fin_Mas_Id := Finalization_Master (Ptr_Typ);
Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
-- Handle the case where the master is actually a pointer to a
@ -545,7 +630,9 @@ package body Exp_Util is
Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
if Present (Fin_Addr_Id) then
if Needs_Finalization (Desig_Typ) then
pragma Assert (Present (Fin_Addr_Id));
Append_To (Actuals,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Fin_Addr_Id, Loc),
@ -654,11 +741,23 @@ package body Exp_Util is
Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
end;
-- The object is statically known to be controlled
else
Append_To (Actuals, New_Reference_To (Standard_True, Loc));
end if;
else
Append_To (Actuals, New_Reference_To (Standard_False, Loc));
end if;
-- i) On_Subpool
if Is_Allocate then
Append_To (Actuals,
New_Reference_To (Boolean_Literals (Present (Subpool)), Loc));
end if;
-- Step 2: Build a wrapper Allocate / Deallocate which internally
-- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
@ -5296,6 +5395,16 @@ package body Exp_Util is
if Restriction_Active (No_Finalization) then
return False;
-- C, C++, CIL and Java types are not considered controlled. It is
-- assumed that the non-Ada side will handle their clean up.
elsif Convention (T) = Convention_C
or else Convention (T) = Convention_CIL
or else Convention (T) = Convention_CPP
or else Convention (T) = Convention_Java
then
return False;
else
-- Class-wide types are treated as controlled because derivations
-- from the root type can introduce controlled components.

9
gcc/ada/exp_util.ads
View File

@ -198,8 +198,13 @@ package Exp_Util is
(N : Node_Id;
Is_Allocate : Boolean);
-- Create a custom Allocate/Deallocate to be associated with an allocation
-- or deallocation of a controlled or class-wide object. In the case of
-- allocation, N is the declaration of the temporary variable which
-- or deallocation:
--
-- 1) controlled objects
-- 2) class-wide objects
-- 3) any kind of object on a subpool
--
-- N must be an allocator or the declaration of a temporary variable which
-- represents the expression of the original allocator node, otherwise N
-- must be a free statement. If flag Is_Allocate is set, the generated
-- routine is allocate, deallocate otherwise.

27
gcc/ada/freeze.adb
View File

@ -1439,27 +1439,24 @@ package body Freeze is
end loop;
end;
-- We add finalization collections to access types whose designated
-- types require finalization. This is normally done when freezing
-- the type, but this misses recursive type definitions where the
-- later members of the recursion introduce controlled components
-- (such as can happen when incomplete types are involved), as well
-- cases where a component type is private and the controlled full
-- type occurs after the access type is frozen. Cases that don't
-- need a finalization collection are generic formal types (the
-- actual type will have it) and types with Java and CIL conventions,
-- since those are used for API bindings. (Are there any other cases
-- that should be excluded here???)
-- We add finalization masters to access types whose designated types
-- require finalization. This is normally done when freezing the
-- type, but this misses recursive type definitions where the later
-- members of the recursion introduce controlled components (such as
-- can happen when incomplete types are involved), as well cases
-- where a component type is private and the controlled full type
-- occurs after the access type is frozen. Cases that don't need a
-- finalization master are generic formal types (the actual type will
-- have it) and types with Java and CIL conventions, since those are
-- used for API bindings. (Are there any other cases that should be
-- excluded here???)
elsif Is_Access_Type (E)
and then Comes_From_Source (E)
and then not Is_Generic_Type (E)
and then Needs_Finalization (Designated_Type (E))
and then No (Associated_Collection (E))
and then Convention (Designated_Type (E)) /= Convention_Java
and then Convention (Designated_Type (E)) /= Convention_CIL
then
Build_Finalization_Collection (E);
Build_Finalization_Master (E);
end if;
Next_Entity (E);

4
gcc/ada/impunit.adb
View File

@ -346,6 +346,7 @@ package body Impunit is
"s-addima", -- System.Address_Image
"s-assert", -- System.Assertions
"s-finmas", -- System.Finalization_Masters
"s-memory", -- System.Memory
"s-parint", -- System.Partition_Interface
"s-pooglo", -- System.Pool_Global
@ -508,6 +509,7 @@ package body Impunit is
Non_Imp_File_Names_12 : constant File_List := (
"s-multip", -- System.Multiprocessors
"s-mudido", -- System.Multiprocessors.Dispatching_Domains
"s-stposu", -- System.Storage_Pools.Subpools
"a-cobove", -- Ada.Containers.Bounded_Vectors
"a-cbdlli", -- Ada.Containers.Bounded_Doubly_Linked_Lists
"a-cborse", -- Ada.Containers.Bounded_Ordered_Sets
@ -521,11 +523,13 @@ package body Impunit is
"a-extiin", -- Ada.Execution_Time.Interrupts
"a-iteint", -- Ada.Iterator_Interfaces
"a-synbar", -- Ada.Synchronous_Barriers
"a-undesu", -- Ada.Unchecked_Deallocate_Subpool
-----------------------------------------
-- GNAT Defined Additions to Ada 20012 --
-----------------------------------------
"s-spsufi", -- System.Storage_Pools.Subpools.Finalization
"a-cofove", -- Ada.Containers.Formal_Vectors
"a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists
"a-cforse", -- Ada.Containers.Formal_Ordered_Sets

2
gcc/ada/s-finmas.ads
View File

@ -35,6 +35,8 @@ with Ada.Unchecked_Conversion;
with System.Storage_Elements;
with System.Storage_Pools;
pragma Compiler_Unit;
package System.Finalization_Masters is
pragma Preelaborate (System.Finalization_Masters);

62
gcc/ada/s-spsufi.adb Normal file
View File

@ -0,0 +1,62 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S . --
-- F I N A L I Z A T I O N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body System.Storage_Pools.Subpools.Finalization is
-----------------------------
-- Finalize_And_Deallocate --
-----------------------------
procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle) is
begin
-- Do nothing if the subpool was never created or never used. The latter
-- case may arise with an array of subpool implementations.
if Subpool = null
or else Subpool.Owner = null
or else Subpool.Node = null
then
return;
end if;
-- Clean up all controlled objects allocated through the subpool
Finalize_Subpool (Subpool);
-- Dispatch to the user-defined implementation of Deallocate_Subpool
Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
Subpool := null;
end Finalize_And_Deallocate;
end System.Storage_Pools.Subpools.Finalization;

44
gcc/ada/s-spsufi.ads Normal file
View File

@ -0,0 +1,44 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S . --
-- F I N A L I Z A T I O N --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Compiler_Unit;
package System.Storage_Pools.Subpools.Finalization is
procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle);
-- This routine performs the following actions:
-- 1) Finalize all objects chained on the subpool's master
-- 2) Remove the the subpool from the owner's list of subpools
-- 3) Deallocate the doubly linked list node associated with the subpool
-- 4) Call Deallocate_Subpool
end System.Storage_Pools.Subpools.Finalization;

195
gcc/ada/s-stposu.adb
View File

@ -61,10 +61,6 @@ package body System.Storage_Pools.Subpools is
Alignment : System.Storage_Elements.Storage_Count)
is
begin
-- ??? The use of Allocate is very dangerous as it does not handle
-- controlled objects properly. Perhaps we should provide an
-- implementation which raises Program_Error instead.
-- Dispatch to the user-defined implementations of Allocate_From_Subpool
-- and Default_Subpool_For_Pool.
@ -83,13 +79,14 @@ package body System.Storage_Pools.Subpools is
procedure Allocate_Any_Controlled
(Pool : in out Root_Storage_Pool'Class;
Context_Subpool : Subpool_Handle := null;
Context_Master : Finalization_Masters.Finalization_Master_Ptr := null;
Fin_Address : Finalization_Masters.Finalize_Address_Ptr := null;
Context_Subpool : Subpool_Handle;
Context_Master : Finalization_Masters.Finalization_Master_Ptr;
Fin_Address : Finalization_Masters.Finalize_Address_Ptr;
Addr : out System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Is_Controlled : Boolean := True)
Is_Controlled : Boolean;
On_Subpool : Boolean)
is
Is_Subpool_Allocation : constant Boolean :=
Pool in Root_Storage_Pool_With_Subpools'Class;
@ -108,7 +105,7 @@ package body System.Storage_Pools.Subpools is
-- Step 1: Pool-related runtime checks
-- Allocation on a pool_with_subpools. In this scenario there is a
-- master for each subpool.
-- master for each subpool. The master of the access type is ignored.
if Is_Subpool_Allocation then
@ -120,26 +117,21 @@ package body System.Storage_Pools.Subpools is
Default_Subpool_For_Pool
(Root_Storage_Pool_With_Subpools'Class (Pool));
-- Ensure proper ownership
if Subpool.Owner /=
Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
then
raise Program_Error with "incorrect owner of default subpool";
end if;
-- Allocation with a Subpool_Handle
else
Subpool := Context_Subpool;
end if;
-- Ensure proper ownership
-- Ensure proper ownership and chaining of the subpool
if Subpool.Owner /=
Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
then
raise Program_Error with "incorrect owner of subpool";
end if;
if Subpool.Owner /=
Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
or else Subpool.Node = null
or else Subpool.Node.Prev = null
or else Subpool.Node.Next = null
then
raise Program_Error with "incorrect owner of subpool";
end if;
Master := Subpool.Master'Unchecked_Access;
@ -148,25 +140,35 @@ package body System.Storage_Pools.Subpools is
-- each access-to-controlled type. No context subpool should be present.
else
-- If the master is missing, then the expansion of the access type
-- failed to create one. This is a serious error.
if Context_Master = null then
raise Program_Error with "missing master in pool allocation";
end if;
-- If a subpool is present, then this is the result of erroneous
-- allocator expansion. This is not a serious error, but it should
-- still be detected.
elsif Context_Subpool /= null then
if Context_Subpool /= null then
raise Program_Error with "subpool not required in pool allocation";
end if;
-- If the allocation is intended to be on a subpool, but the access
-- type's pool does not support subpools, then this is the result of
-- erroneous end-user code.
if On_Subpool then
raise Program_Error
with "pool of access type does not support subpools";
end if;
Master := Context_Master;
end if;
-- Step 2: Master-related runtime checks and size calculations
-- Step 2: Master and Finalize_Address-related runtime checks and size
-- calculations.
-- Allocation of a descendant from [Limited_]Controlled, a class-wide
-- object or a record with controlled components.
@ -180,6 +182,15 @@ package body System.Storage_Pools.Subpools is
raise Program_Error with "allocation after finalization started";
end if;
-- Check whether primitive Finalize_Address is available. If it is
-- not, then either the expansion of the designated type failed or
-- the expansion of the allocator failed. This is a serious error.
if Fin_Address = null then
raise Program_Error
with "primitive Finalize_Address not available";
end if;
-- The size must acount for the hidden header preceding the object.
-- Account for possible padding space before the header due to a
-- larger alignment.
@ -224,29 +235,20 @@ package body System.Storage_Pools.Subpools is
-- due to larger alignment, the header is placed right next to the
-- object:
-- N_Addr N_Ptr
-- | |
-- V V
-- +-------+---------------+----------------------+
-- |Padding| Header | Object |
-- +-------+---------------+----------------------+
-- ^ ^ ^
-- | +- Header_Size -+
-- | |
-- +- Header_And_Padding --+
-- N_Addr N_Ptr
-- | |
-- V V
-- +-------+---------------+----------------------+
-- |Padding| Header | Object |
-- +-------+---------------+----------------------+
-- ^ ^ ^
-- | +- Header_Size -+
-- | |
-- +- Header_And_Padding --+
N_Ptr :=
Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size);
-- Check whether primitive Finalize_Address is available. If it is
-- not, then either the expansion of the designated type failed or
-- the expansion of the allocator failed. This is a serious error.
if Fin_Address = null then
raise Program_Error
with "primitive Finalize_Address not available";
end if;
N_Ptr.Finalize_Address := Fin_Address;
-- Prepend the allocated object to the finalization master
@ -268,6 +270,10 @@ package body System.Storage_Pools.Subpools is
procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is
begin
-- Ensure that the node has not been attached already
pragma Assert (N.Prev = null and then N.Next = null);
Lock_Task.all;
L.Next.Prev := N;
@ -290,7 +296,7 @@ package body System.Storage_Pools.Subpools is
Addr : System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Is_Controlled : Boolean := True)
Is_Controlled : Boolean)
is
N_Addr : Address;
N_Ptr : FM_Node_Ptr;
@ -360,7 +366,7 @@ package body System.Storage_Pools.Subpools is
procedure Detach (N : not null SP_Node_Ptr) is
begin
-- N must be attached to some list
-- Ensure that the node is attached to some list
pragma Assert (N.Next /= null and then N.Prev /= null);
@ -379,22 +385,22 @@ package body System.Storage_Pools.Subpools is
-- Finalize --
--------------
overriding procedure Finalize
(Pool : in out Root_Storage_Pool_With_Subpools)
is
overriding procedure Finalize (Controller : in out Pool_Controller) is
begin
Finalize_Pool (Controller.Enclosing_Pool.all);
end Finalize;
-------------------
-- Finalize_Pool --
-------------------
procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
Curr_Ptr : SP_Node_Ptr;
Ex_Occur : Exception_Occurrence;
Next_Ptr : SP_Node_Ptr;
Raised : Boolean := False;
begin
-- Uninitialized pools do not have subpools and do not contain objects
-- of any kind.
if not Pool.Initialized then
return;
end if;
-- It is possible for multiple tasks to cause the finalization of a
-- common pool. Allow only one task to finalize the contents.
@ -415,11 +421,12 @@ package body System.Storage_Pools.Subpools is
while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop
Next_Ptr := Curr_Ptr.Next;
-- Remove the subpool node from the subpool list
-- Perform the following actions:
Detach (Curr_Ptr);
-- Finalize the current subpool
-- 1) Finalize all objects chained on the subpool's master
-- 2) Remove the the subpool from the owner's list of subpools
-- 3) Deallocate the doubly linked list node associated with the
-- subpool.
begin
Finalize_Subpool (Curr_Ptr.Subpool);
@ -432,11 +439,6 @@ package body System.Storage_Pools.Subpools is
end if;
end;
-- Since subpool nodes are not allocated on the owner pool, they must
-- be explicitly destroyed.
Free (Curr_Ptr);
Curr_Ptr := Next_Ptr;
end loop;
@ -446,7 +448,7 @@ package body System.Storage_Pools.Subpools is
if Raised then
Reraise_Occurrence (Ex_Occur);
end if;
end Finalize;
end Finalize_Pool;
----------------------
-- Finalize_Subpool --
@ -454,9 +456,49 @@ package body System.Storage_Pools.Subpools is
procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is
begin
-- Do nothing if the subpool was never used
if Subpool.Owner = null
or else Subpool.Node = null
then
return;
end if;
-- Clean up all controlled objects chained on the subpool's master
Finalize (Subpool.Master);
-- Remove the subpool from its owner's list of subpools
Detach (Subpool.Node);
-- Destroy the associated doubly linked list node which was created in
-- Set_Pool_Of_Subpool.
Free (Subpool.Node);
end Finalize_Subpool;
----------------
-- Initialize --
----------------
overriding procedure Initialize (Controller : in out Pool_Controller) is
begin
Initialize_Pool (Controller.Enclosing_Pool.all);
end Initialize;
---------------------
-- Initialize_Pool --
---------------------
procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
begin
-- The dummy head must point to itself in both directions
Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
end Initialize_Pool;
---------------------
-- Pool_Of_Subpool --
---------------------
@ -478,15 +520,6 @@ package body System.Storage_Pools.Subpools is
N_Ptr : SP_Node_Ptr;
begin
if not Pool.Initialized then
-- The dummy head must point to itself in both directions
Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
Pool.Initialized := True;
end if;
-- If the subpool is already owned, raise Program_Error. This is a
-- direct violation of the RM rules.
@ -502,13 +535,15 @@ package body System.Storage_Pools.Subpools is
with "subpool creation after finalization started";
end if;
-- Create a subpool node, decorate it and associate it with the subpool
-- list of Pool.
Subpool.Owner := Pool'Unchecked_Access;
-- Create a subpool node and decorate it. Since this node is not
-- allocated on the owner's pool, it must be explicitly destroyed by
-- Finalize_And_Detach.
N_Ptr := new SP_Node;
Subpool.Owner := Pool'Unchecked_Access;
N_Ptr.Subpool := Subpool;
Subpool.Node := N_Ptr;
Attach (N_Ptr, Pool.Subpools'Unchecked_Access);
end Set_Pool_Of_Subpool;

216
gcc/ada/s-stposu.ads
View File

@ -33,6 +33,8 @@
-- --
------------------------------------------------------------------------------
with Ada.Finalization;
with System.Finalization_Masters;
with System.Storage_Elements;
@ -61,7 +63,8 @@ package System.Storage_Pools.Subpools is
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count);
-- Allocate an object described by Size_In_Storage_Elements and Alignment
-- on the default subpool of Pool.
-- on the default subpool of Pool. Controlled types allocated through this
-- routine will NOT be handled properly.
procedure Allocate_From_Subpool
(Pool : in out Root_Storage_Pool_With_Subpools;
@ -126,50 +129,45 @@ package System.Storage_Pools.Subpools is
private
-- Model
-- Pool_With_Subpools
-- +----> +---------------------+ <----+
-- | +---------- Subpools | |
-- | | +---------------------+ |
-- | | : User data : |
-- | | '.....................' |
-- | | |
-- | | SP_Node SP_Node |
-- | +-> +-------+ +-------+ |
-- | | Prev <-----> Prev | |
-- | +-------+ +-------+ |
-- | | Next <---->| Next | |
-- | +-------+ +-------+ |
-- | +----Subpool| |Subpool----+ |
-- | | +-------+ +-------+ | |
-- | | | |
-- | | Subpool Subpool | |
-- | +-> +-------+ +-------+ <-+ |
-- +------- Owner | | Owner -------+
-- +-------+ +-------+
-- +------------------- Master| | Master---------------+
-- | +-------+ +-------+ |
-- | : User : : User : |
-- | : Data : : Data : |
-- | '.......' '.......' |
-- | |
-- | Heap |
-- .. | ..................................................... | ..
-- : | | :
-- : | Object Object Object Object | :
-- : +-> +------+ +------+ +------+ +------+ <-+ :
-- : | Prev <--> Prev <--> Prev | | Prev | :
-- : +------+ +------+ +------+ +------+ :
-- : | Next <--> Next <--> Next | | Next | :
-- : +------+ +------+ +------+ +------+ :
-- : | FA | | FA | | FA | | FA | :
-- : +------+ +------+ +------+ +------+ :
-- : : : : : : : : : :
-- : : : : : : : : : :
-- : '......' '......' '......' '......' :
-- : :
-- '.............................................................'
-- Pool_With_Subpools SP_Node SP_Node SP_Node
-- +-->+--------------------+ +-----+ +-----+ +-----+
-- | | Subpools -------->| ------->| ------->| ------->
-- | +--------------------+ +-----+ +-----+ +-----+
-- | |Finalization_Started|<------ |<------- |<------- |<---
-- | +--------------------+ +-----+ +-----+ +-----+
-- +--- Controller.Encl_Pool| | nul | | + | | + |
-- | +--------------------+ +-----+ +--|--+ +--:--+
-- | : : Dummy | ^ :
-- | : : | | :
-- | Root_Subpool V |
-- | +-------------+ |
-- +-------------------------------- Owner | |
-- FM_Node FM_Node +-------------+ |
-- +-----+ +-----+<-- Master.Objects| |
-- <------ |<------ | +-------------+ |
-- +-----+ +-----+ | Node -------+
-- | ------>| -----> +-------------+
-- +-----+ +-----+ : :
-- |ctrl | Dummy : :
-- | obj |
-- +-----+
--
-- SP_Nodes are created on the heap. FM_Nodes and associated objects are
-- created on the pool_with_subpools.
type Any_Storage_Pool_With_Subpools_Ptr
is access all Root_Storage_Pool_With_Subpools'Class;
for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0;
-- A pool controller is a special controlled object which ensures the
-- proper initialization and finalization of the enclosing pool.
type Pool_Controller (Enclosing_Pool : Any_Storage_Pool_With_Subpools_Ptr)
is new Ada.Finalization.Limited_Controlled with null record;
-- Subpool list types. Each pool_with_subpools contains a list of subpools.
-- This is an indirect doubly linked list since subpools are not supposed
-- to be allocatable by language design.
type SP_Node;
type SP_Node_Ptr is access all SP_Node;
@ -180,19 +178,26 @@ private
Subpool : Subpool_Handle := null;
end record;
-- Root_Storage_Pool_With_Subpools internal structure
-- Root_Storage_Pool_With_Subpools internal structure. The type uses a
-- special controller to perform initialization and finalization actions
-- on itself. This is necessary because the end user of this package may
-- decide to override Initialize and Finalize, thus disabling the desired
-- behavior.
-- Pool_With_Subpools SP_Node SP_Node SP_Node
-- +-->+--------------------+ +-----+ +-----+ +-----+
-- | | Subpools -------->| ------->| ------->| ------->
-- | +--------------------+ +-----+ +-----+ +-----+
-- | |Finalization_Started| : : : : : :
-- | +--------------------+
-- +--- Controller.Encl_Pool|
-- +--------------------+
-- : End-user :
-- : components :
type Root_Storage_Pool_With_Subpools is abstract
new Root_Storage_Pool with
record
Initialized : Boolean := False;
pragma Atomic (Initialized);
-- Even though this type is derived from Limited_Controlled, overriding
-- Initialize would have no effect since the type is abstract. Routine
-- Set_Pool_Of_Subpool is tasked with the initialization of a pool with
-- subpools because it has to be called at some point. This flag is used
-- to prevent the resetting of the subpool chain.
Subpools : aliased SP_Node;
-- A doubly linked list of subpools
@ -201,22 +206,47 @@ private
-- A flag which prevents the creation of new subpools while the master
-- pool is being finalized. The flag needs to be atomic because it is
-- accessed without Lock_Task / Unlock_Task.
end record;
type Any_Storage_Pool_With_Subpools_Ptr
is access all Root_Storage_Pool_With_Subpools'Class;
for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0;
Controller : Pool_Controller
(Root_Storage_Pool_With_Subpools'Unchecked_Access);
-- A component which ensures that the enclosing pool is initialized and
-- finalized at the appropriate places.
end record;
-- A subpool is an abstraction layer which sits on top of a pool. It
-- contains links to all controlled objects allocated on a particular
-- subpool.
-- Pool_With_Subpools SP_Node SP_Node SP_Node
-- +-->+----------------+ +-----+ +-----+ +-----+
-- | | Subpools ------>| ------->| ------->| ------->
-- | +----------------+ +-----+ +-----+ +-----+
-- | : :<------ |<------- |<------- |
-- | : : +-----+ +-----+ +-----+
-- | |null | | + | | + |
-- | +-----+ +--|--+ +--:--+
-- | | ^ :
-- | Root_Subpool V |
-- | +-------------+ |
-- +---------------------------- Owner | |
-- +-------------+ |
-- .......... Master | |
-- +-------------+ |
-- | Node -------+
-- +-------------+
-- : End-user :
-- : components :
type Root_Subpool is abstract tagged limited record
Owner : Any_Storage_Pool_With_Subpools_Ptr := null;
-- A reference to the master pool_with_subpools
Master : aliased System.Finalization_Masters.Finalization_Master;
-- A collection of controlled objects
Node : SP_Node_Ptr := null;
-- A link to the doubly linked list node which contains the subpool.
-- This back pointer is used in subpool deallocation.
end record;
-- ??? Once Storage_Pools.Allocate_Any is removed, this should be renamed
@ -224,32 +254,86 @@ private
procedure Allocate_Any_Controlled
(Pool : in out Root_Storage_Pool'Class;
Context_Subpool : Subpool_Handle := null;
Context_Master : Finalization_Masters.Finalization_Master_Ptr := null;
Fin_Address : Finalization_Masters.Finalize_Address_Ptr := null;
Context_Subpool : Subpool_Handle;
Context_Master : Finalization_Masters.Finalization_Master_Ptr;
Fin_Address : Finalization_Masters.Finalize_Address_Ptr;
Addr : out System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Is_Controlled : Boolean := True);
Is_Controlled : Boolean;
On_Subpool : Boolean);
-- Compiler interface. This version of Allocate handles all possible cases,
-- either on a pool or a pool_with_subpools.
-- either on a pool or a pool_with_subpools, regardless of the controlled
-- status of the allocated object. Parameter usage:
--
-- * Pool - The pool associated with the access type. Pool can be any
-- derivation from Root_Storage_Pool, including a pool_with_subpools.
--
-- * Context_Subpool - The subpool handle name of an allocator. If no
-- subpool handle is present at the point of allocation, the actual
-- would be null.
--
-- * Context_Master - The finalization master associated with the access
-- type. If the access type's designated type is not controlled, the
-- actual would be null.
--
-- * Fin_Address - TSS routine Finalize_Address of the designated type.
-- If the designated type is not controlled, the actual would be null.
--
-- * Addr - The address of the allocated object.
--
-- * Storage_Size - The size of the allocated object.
--
-- * Alignment - The alignment of the allocated object.
--
-- * Is_Controlled - A flag which determines whether the allocated object
-- is controlled. When set to True, the machinery generates additional
-- data.
--
-- * On_Subpool - A flag which determines whether the a subpool handle
-- name is present at the point of allocation. This is used for error
-- diagnostics.
procedure Deallocate_Any_Controlled
(Pool : in out Root_Storage_Pool'Class;
Addr : System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Is_Controlled : Boolean := True);
Is_Controlled : Boolean);
-- Compiler interface. This version of Deallocate handles all possible
-- cases, either from a pool or a pool_with_subpools.
-- cases, either from a pool or a pool_with_subpools, regardless of the
-- controlled status of the deallocated object. Parameter usage:
--
-- * Pool - The pool associated with the access type. Pool can be any
-- derivation from Root_Storage_Pool, including a pool_with_subpools.
--
-- * Addr - The address of the allocated object.
--
-- * Storage_Size - The size of the allocated object.
--
-- * Alignment - The alignment of the allocated object.
--
-- * Is_Controlled - A flag which determines whether the allocated object
-- is controlled. When set to True, the machinery generates additional
-- data.
overriding procedure Finalize
(Pool : in out Root_Storage_Pool_With_Subpools);
overriding procedure Finalize (Controller : in out Pool_Controller);
-- Buffer routine, calls Finalize_Pool
procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
-- Iterate over all subpools of Pool, detach them one by one and finalize
-- their masters. This action first detaches a controlled object from a
-- particular master, then invokes its Finalize_Address primitive.
procedure Finalize_Subpool (Subpool : not null Subpool_Handle);
-- Finalize the master of a subpool
-- Finalize all controlled objects chained on Subpool's master. Remove the
-- subpool from its owner's list. Deallocate the associated doubly linked
-- list node.
overriding procedure Initialize (Controller : in out Pool_Controller);
-- Buffer routine, calls Initialize_Pool
procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
-- Setup the doubly linked list of subpools
end System.Storage_Pools.Subpools;

63
gcc/ada/sem_aggr.adb
View File

@ -1309,6 +1309,10 @@ package body Sem_Aggr is
-- for discrete choices such as "L .. H => Expr" or the OTHERS choice).
-- In this event we do not resolve Expr unless expansion is disabled.
-- To know why, see the DELAYED COMPONENT RESOLUTION note above.
--
-- NOTE: In the case of "... => <>", we pass the in the
-- N_Component_Association node as Expr, since there is no Expression in
-- that case, and we need a Sloc for the error message.
---------
-- Add --
@ -1635,6 +1639,13 @@ package body Sem_Aggr is
end if;
end if;
-- If it's "... => <>", nothing to resolve
if Nkind (Expr) = N_Component_Association then
pragma Assert (Box_Present (Expr));
return Success;
end if;
-- Ada 2005 (AI-231): Propagate the type to the nested aggregate.
-- Required to check the null-exclusion attribute (if present).
-- This value may be overridden later on.
@ -1644,19 +1655,29 @@ package body Sem_Aggr is
Resolution_OK := Resolve_Array_Aggregate
(Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
-- Do not resolve the expressions of discrete or others choices
-- unless the expression covers a single component, or the expander
-- is inactive.
else
elsif Single_Elmt
or else not Expander_Active
or else In_Spec_Expression
then
Analyze_And_Resolve (Expr, Component_Typ);
Check_Expr_OK_In_Limited_Aggregate (Expr);
Check_Non_Static_Context (Expr);
Aggregate_Constraint_Checks (Expr, Component_Typ);
Check_Unset_Reference (Expr);
-- If it's "... => <>", nothing to resolve
if Nkind (Expr) = N_Component_Association then
pragma Assert (Box_Present (Expr));
return Success;
end if;
-- Do not resolve the expressions of discrete or others choices
-- unless the expression covers a single component, or the
-- expander is inactive.
if Single_Elmt
or else not Expander_Active
or else In_Spec_Expression
then
Analyze_And_Resolve (Expr, Component_Typ);
Check_Expr_OK_In_Limited_Aggregate (Expr);
Check_Non_Static_Context (Expr);
Aggregate_Constraint_Checks (Expr, Component_Typ);
Check_Unset_Reference (Expr);
end if;
end if;
if Raises_Constraint_Error (Expr)
@ -1988,9 +2009,15 @@ package body Sem_Aggr is
-- Ada 2005 (AI-287): In case of default initialization of a
-- component the expander will generate calls to the
-- corresponding initialization subprogram.
-- corresponding initialization subprogram. We need to call
-- Resolve_Aggr_Expr to check the rules about
-- dimensionality.
null;
if not Resolve_Aggr_Expr (Assoc,
Single_Elmt => Single_Choice)
then
return Failure;
end if;
elsif not Resolve_Aggr_Expr (Expression (Assoc),
Single_Elmt => Single_Choice)
@ -2321,9 +2348,13 @@ package body Sem_Aggr is
-- Ada 2005 (AI-287): In case of default initialization of a
-- component the expander will generate calls to the
-- corresponding initialization subprogram.
-- corresponding initialization subprogram. We need to call
-- Resolve_Aggr_Expr to check the rules about
-- dimensionality.
null;
if not Resolve_Aggr_Expr (Assoc, Single_Elmt => False) then
return Failure;
end if;
elsif not Resolve_Aggr_Expr (Expression (Assoc),
Single_Elmt => False)

1
gcc/ada/sem_ch13.adb
View File

@ -1471,6 +1471,7 @@ package body Sem_Ch13 is
else
case A_Id is
-- For Pre/Post cases, insert immediately after the
-- entity declaration, since that is the required pragma
-- placement.

11
gcc/ada/sem_ch6.adb
View File

@ -2348,7 +2348,7 @@ package body Sem_Ch6 is
-- the proper back-annotations.
if not Is_Frozen (Spec_Id)
and then (Expander_Active or ASIS_Mode)
and then (Expander_Active or else ASIS_Mode)
then
-- Force the generation of its freezing node to ensure proper
-- management of access types in the backend.
@ -6081,14 +6081,13 @@ package body Sem_Ch6 is
end if;
-- In the case of functions whose result type needs finalization,
-- add an extra formal of type Ada.Finalization.Heap_Management.
-- Finalization_Collection_Ptr.
-- add an extra formal which represents the finalization master.
if Needs_BIP_Collection (E) then
if Needs_BIP_Finalization_Master (E) then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Finalization_Collection_Ptr),
E, BIP_Formal_Suffix (BIP_Collection));
(E, RTE (RE_Finalization_Master_Ptr),
E, BIP_Formal_Suffix (BIP_Finalization_Master));
end if;
-- If the result type contains tasks, we have two extra formals: