Commit 200b7162 by Bob Duff Committed by Arnaud Charlet

exp_ch6.ads (BIP_Storage_Pool): New "extra implicit parameter" that gets passed…

exp_ch6.ads (BIP_Storage_Pool): New "extra implicit parameter" that gets passed in the same cases where...

2011-10-13  Bob Duff  <duff@adacore.com>

	* exp_ch6.ads (BIP_Storage_Pool): New "extra implicit parameter"
	that gets passed in the same cases where BIP_Alloc_Form is passed
	(caller-unknown-size results). BIP_Storage_Pool is used when
	BIP_Alloc_Form = User_Storage_Pool.  In that case, a pointer
	to the user-defined storage pool is passed at the call site,
	and this pool is used in callee to allocate the result.
	* exp_ch6.adb (Add_Unconstrained_Actuals_To_Build_In_Place_Call): New
	version of Add_Alloc_Form_Actual_To_Build_In_Place_Call. Passes
	the additional BIP_Storage_Pool actual.
	(Expand_N_Extended_Return_Statement): Allocate the function
	result using the user-defined storage pool, if BIP_Alloc_Form =
	User_Storage_Pool.
	* sem_ch6.adb: Add the "extra formal" for BIP_Storage_Pool.
	* exp_ch4.adb: Don't overwrite storage pool set by
	Expand_N_Extended_Return_Statement.
	* s-stopoo.ads, rtsfind.ads (Root_Storage_Pool_Ptr): New type,
	for use in build-in-place function calls within allocators
	where the access type has a user-defined storage pool.

From-SVN: r179903
parent 9f8d1e5c
2011-10-13 Bob Duff <duff@adacore.com>
* exp_ch6.ads (BIP_Storage_Pool): New "extra implicit parameter"
that gets passed in the same cases where BIP_Alloc_Form is passed
(caller-unknown-size results). BIP_Storage_Pool is used when
BIP_Alloc_Form = User_Storage_Pool. In that case, a pointer
to the user-defined storage pool is passed at the call site,
and this pool is used in callee to allocate the result.
* exp_ch6.adb (Add_Unconstrained_Actuals_To_Build_In_Place_Call): New
version of Add_Alloc_Form_Actual_To_Build_In_Place_Call. Passes
the additional BIP_Storage_Pool actual.
(Expand_N_Extended_Return_Statement): Allocate the function
result using the user-defined storage pool, if BIP_Alloc_Form =
User_Storage_Pool.
* sem_ch6.adb: Add the "extra formal" for BIP_Storage_Pool.
* exp_ch4.adb: Don't overwrite storage pool set by
Expand_N_Extended_Return_Statement.
* s-stopoo.ads, rtsfind.ads (Root_Storage_Pool_Ptr): New type,
for use in build-in-place function calls within allocators
where the access type has a user-defined storage pool.
2011-10-13 Sergey Rybin <rybin@adacore.com> 2011-10-13 Sergey Rybin <rybin@adacore.com>
* gnat_ugn.texi, vms_data.ads: Add an option to control enumeration * gnat_ugn.texi, vms_data.ads: Add an option to control enumeration
......
...@@ -3526,23 +3526,28 @@ package body Exp_Ch4 is ...@@ -3526,23 +3526,28 @@ package body Exp_Ch4 is
end if; end if;
-- Set the storage pool and find the appropriate version of Allocate to -- Set the storage pool and find the appropriate version of Allocate to
-- call. -- call. But don't overwrite the storage pool if it is already set,
-- which can happen for build-in-place function returns (see
-- Exp_Ch4.Expand_N_Extended_Return_Statement).
Pool := Associated_Storage_Pool (Root_Type (PtrT)); if No (Storage_Pool (N)) then
Set_Storage_Pool (N, Pool); Pool := Associated_Storage_Pool (Root_Type (PtrT));
if Present (Pool) then if Present (Pool) then
if Is_RTE (Pool, RE_SS_Pool) then Set_Storage_Pool (N, Pool);
if VM_Target = No_VM then
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
end if;
elsif Is_Class_Wide_Type (Etype (Pool)) then if Is_RTE (Pool, RE_SS_Pool) then
Set_Procedure_To_Call (N, RTE (RE_Allocate_Any)); if VM_Target = No_VM then
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
end if;
else elsif Is_Class_Wide_Type (Etype (Pool)) then
Set_Procedure_To_Call (N, Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
Find_Prim_Op (Etype (Pool), Name_Allocate));
else
Set_Procedure_To_Call (N,
Find_Prim_Op (Etype (Pool), Name_Allocate));
end if;
end if; end if;
end if; end if;
......
...@@ -94,15 +94,18 @@ package body Exp_Ch6 is ...@@ -94,15 +94,18 @@ package body Exp_Ch6 is
-- along directly to the build-in-place function. Finally, if Return_Object -- along directly to the build-in-place function. Finally, if Return_Object
-- is empty, then pass a null literal as the actual. -- is empty, then pass a null literal as the actual.
procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id; (Function_Call : Node_Id;
Function_Id : Entity_Id; Function_Id : Entity_Id;
Alloc_Form : BIP_Allocation_Form := Unspecified; Alloc_Form : BIP_Allocation_Form := Unspecified;
Alloc_Form_Exp : Node_Id := Empty); Alloc_Form_Exp : Node_Id := Empty;
-- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation, Pool_Actual : Node_Id := Make_Null (No_Location));
-- if any, to be done by a build-in-place function. If Alloc_Form_Exp is -- Ada 2005 (AI-318-02): Add the actuals needed for a build-in-place
-- present, then use it, otherwise pass a literal corresponding to the -- function call that returns a caller-unknown-size result (BIP_Alloc_Form
-- Alloc_Form parameter (which must not be Unspecified in that case). -- and BIP_Storage_Pool). If Alloc_Form_Exp is present, then use it,
-- otherwise pass a literal corresponding to the Alloc_Form parameter
-- (which must not be Unspecified in that case). Pool_Actual is the
-- parameter to pass to BIP_Storage_Pool.
procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call : Node_Id; (Func_Call : Node_Id;
...@@ -252,18 +255,20 @@ package body Exp_Ch6 is ...@@ -252,18 +255,20 @@ package body Exp_Ch6 is
end Add_Access_Actual_To_Build_In_Place_Call; end Add_Access_Actual_To_Build_In_Place_Call;
-------------------------------------------------- --------------------------------------------------
-- Add_Alloc_Form_Actual_To_Build_In_Place_Call -- -- Add_Unconstrained_Actuals_To_Build_In_Place_Call --
-------------------------------------------------- --------------------------------------------------
procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id; (Function_Call : Node_Id;
Function_Id : Entity_Id; Function_Id : Entity_Id;
Alloc_Form : BIP_Allocation_Form := Unspecified; Alloc_Form : BIP_Allocation_Form := Unspecified;
Alloc_Form_Exp : Node_Id := Empty) Alloc_Form_Exp : Node_Id := Empty;
Pool_Actual : Node_Id := Make_Null (No_Location))
is is
Loc : constant Source_Ptr := Sloc (Function_Call); Loc : constant Source_Ptr := Sloc (Function_Call);
Alloc_Form_Actual : Node_Id; Alloc_Form_Actual : Node_Id;
Alloc_Form_Formal : Node_Id; Alloc_Form_Formal : Node_Id;
Pool_Formal : Node_Id;
begin begin
-- The allocation form generally doesn't need to be passed in the case -- The allocation form generally doesn't need to be passed in the case
...@@ -305,7 +310,15 @@ package body Exp_Ch6 is ...@@ -305,7 +310,15 @@ package body Exp_Ch6 is
Add_Extra_Actual_To_Call Add_Extra_Actual_To_Call
(Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
end Add_Alloc_Form_Actual_To_Build_In_Place_Call;
-- Pass the Storage_Pool parameter
Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool);
Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal));
Add_Extra_Actual_To_Call
(Function_Call, Pool_Formal, Pool_Actual);
end Add_Unconstrained_Actuals_To_Build_In_Place_Call;
----------------------------------------------------------- -----------------------------------------------------------
-- Add_Finalization_Master_Actual_To_Build_In_Place_Call -- -- Add_Finalization_Master_Actual_To_Build_In_Place_Call --
...@@ -541,6 +554,8 @@ package body Exp_Ch6 is ...@@ -541,6 +554,8 @@ package body Exp_Ch6 is
case Kind is case Kind is
when BIP_Alloc_Form => when BIP_Alloc_Form =>
return "BIPalloc"; return "BIPalloc";
when BIP_Storage_Pool =>
return "BIPstoragepool";
when BIP_Finalization_Master => when BIP_Finalization_Master =>
return "BIPfinalizationmaster"; return "BIPfinalizationmaster";
when BIP_Master => when BIP_Master =>
...@@ -4638,11 +4653,12 @@ package body Exp_Ch6 is ...@@ -4638,11 +4653,12 @@ package body Exp_Ch6 is
Alloc_Expr : Node_Id) return Node_Id Alloc_Expr : Node_Id) return Node_Id
is is
begin begin
pragma Assert (Is_Build_In_Place_Function (Func_Id));
-- Processing for build-in-place object allocation. This is disabled -- Processing for build-in-place object allocation. This is disabled
-- on .NET/JVM because the targets do not support pools. -- on .NET/JVM because the targets do not support pools.
if VM_Target = No_VM if VM_Target = No_VM
and then Is_Build_In_Place_Function (Func_Id)
and then Needs_Finalization (Ret_Typ) and then Needs_Finalization (Ret_Typ)
then then
declare declare
...@@ -5121,8 +5137,12 @@ package body Exp_Ch6 is ...@@ -5121,8 +5137,12 @@ package body Exp_Ch6 is
Alloc_Obj_Id : Entity_Id; Alloc_Obj_Id : Entity_Id;
Alloc_Obj_Decl : Node_Id; Alloc_Obj_Decl : Node_Id;
Alloc_If_Stmt : Node_Id; Alloc_If_Stmt : Node_Id;
Heap_Allocator : Node_Id;
SS_Allocator : Node_Id; SS_Allocator : Node_Id;
Heap_Allocator : Node_Id;
Pool_Decl : Node_Id;
Pool_Allocator : Node_Id;
Pool_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
begin begin
-- Reuse the itype created for the function's implicit -- Reuse the itype created for the function's implicit
...@@ -5216,6 +5236,25 @@ package body Exp_Ch6 is ...@@ -5216,6 +5236,25 @@ package body Exp_Ch6 is
Set_No_Initialization (Heap_Allocator); Set_No_Initialization (Heap_Allocator);
end if; end if;
-- The Pool_Allocator is just like the Heap_Allocator,
-- except we set Storage_Pool and Procedure_To_Call so it
-- will use the user-defined storage pool.
Pool_Allocator := New_Copy_Tree (Heap_Allocator);
Pool_Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Pool_Id,
Subtype_Mark =>
New_Reference_To (RTE (RE_Root_Storage_Pool), Loc),
Name =>
Make_Explicit_Dereference (Loc,
New_Reference_To
(Build_In_Place_Formal
(Par_Func, BIP_Storage_Pool), Loc)));
Set_Storage_Pool (Pool_Allocator, Pool_Id);
Set_Procedure_To_Call
(Pool_Allocator, RTE (RE_Allocate_Any));
-- If the No_Allocators restriction is active, then only -- If the No_Allocators restriction is active, then only
-- an allocator for secondary stack allocation is needed. -- an allocator for secondary stack allocation is needed.
-- It's OK for such allocators to have Comes_From_Source -- It's OK for such allocators to have Comes_From_Source
...@@ -5225,22 +5264,25 @@ package body Exp_Ch6 is ...@@ -5225,22 +5264,25 @@ package body Exp_Ch6 is
if Restriction_Active (No_Allocators) then if Restriction_Active (No_Allocators) then
SS_Allocator := Heap_Allocator; SS_Allocator := Heap_Allocator;
Heap_Allocator := Make_Null (Loc); Heap_Allocator := Make_Null (Loc);
Pool_Allocator := Make_Null (Loc);
-- Otherwise the heap allocator may be needed, so we make -- Otherwise the heap and pool allocators may be needed,
-- another allocator for secondary stack allocation. -- so we make another allocator for secondary stack
-- allocation.
else else
SS_Allocator := New_Copy_Tree (Heap_Allocator); SS_Allocator := New_Copy_Tree (Heap_Allocator);
-- The heap allocator is marked Comes_From_Source -- The heap and pool allocators are marked
-- since it corresponds to an explicit user-written -- Comes_From_Source since they correspond to an
-- allocator (that is, it will only be executed on -- explicit user-written allocator (that is, it will
-- behalf of callers that call the function as -- only be executed on behalf of callers that call the
-- initialization for such an allocator). This -- function as initialization for such an
-- prevents errors when No_Implicit_Heap_Allocations -- allocator). This prevents errors when
-- is in force. -- No_Implicit_Heap_Allocations is in force.
Set_Comes_From_Source (Heap_Allocator, True); Set_Comes_From_Source (Heap_Allocator, True);
Set_Comes_From_Source (Pool_Allocator, True);
end if; end if;
-- The allocator is returned on the secondary stack. We -- The allocator is returned on the secondary stack. We
...@@ -5269,10 +5311,12 @@ package body Exp_Ch6 is ...@@ -5269,10 +5311,12 @@ package body Exp_Ch6 is
-- Create an if statement to test the BIP_Alloc_Form -- Create an if statement to test the BIP_Alloc_Form
-- formal and initialize the access object to either the -- formal and initialize the access object to either the
-- BIP_Object_Access formal (BIP_Alloc_Form = 0), the -- BIP_Object_Access formal (BIP_Alloc_Form =
-- result of allocating the object in the secondary stack -- Caller_Allocation), the result of allocating the
-- (BIP_Alloc_Form = 1), or else an allocator to create -- object in the secondary stack (BIP_Alloc_Form =
-- the return object in the heap (BIP_Alloc_Form = 2). -- Secondary_Stack), or else an allocator to create the
-- return object in the heap or user-defined pool
-- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
-- ??? An unchecked type conversion must be made in the -- ??? An unchecked type conversion must be made in the
-- case of assigning the access object formal to the -- case of assigning the access object formal to the
...@@ -5320,15 +5364,34 @@ package body Exp_Ch6 is ...@@ -5320,15 +5364,34 @@ package body Exp_Ch6 is
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name =>
New_Reference_To (Alloc_Obj_Id, Loc), New_Reference_To (Alloc_Obj_Id, Loc),
Expression => SS_Allocator)))), Expression => SS_Allocator))),
Make_Elsif_Part (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (Obj_Alloc_Formal, Loc),
Right_Opnd =>
Make_Integer_Literal (Loc,
UI_From_Int (BIP_Allocation_Form'Pos
(Global_Heap)))),
Then_Statements => New_List (
Build_Heap_Allocator
(Temp_Id => Alloc_Obj_Id,
Temp_Typ => Ref_Type,
Func_Id => Par_Func,
Ret_Typ => Return_Obj_Typ,
Alloc_Expr => Heap_Allocator)))),
Else_Statements => New_List ( Else_Statements => New_List (
Pool_Decl,
Build_Heap_Allocator Build_Heap_Allocator
(Temp_Id => Alloc_Obj_Id, (Temp_Id => Alloc_Obj_Id,
Temp_Typ => Ref_Type, Temp_Typ => Ref_Type,
Func_Id => Par_Func, Func_Id => Par_Func,
Ret_Typ => Return_Obj_Typ, Ret_Typ => Return_Obj_Typ,
Alloc_Expr => Heap_Allocator))); Alloc_Expr => Pool_Allocator)));
-- If a separate initialization assignment was created -- If a separate initialization assignment was created
-- earlier, append that following the assignment of the -- earlier, append that following the assignment of the
...@@ -7592,7 +7655,7 @@ package body Exp_Ch6 is ...@@ -7592,7 +7655,7 @@ package body Exp_Ch6 is
-- called as a dispatching operation and must be treated similarly -- called as a dispatching operation and must be treated similarly
-- to functions with unconstrained result subtypes. -- to functions with unconstrained result subtypes.
Add_Alloc_Form_Actual_To_Build_In_Place_Call Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation); (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
Add_Finalization_Master_Actual_To_Build_In_Place_Call Add_Finalization_Master_Actual_To_Build_In_Place_Call
...@@ -7623,11 +7686,29 @@ package body Exp_Ch6 is ...@@ -7623,11 +7686,29 @@ package body Exp_Ch6 is
-- operations. ??? -- operations. ???
else else
-- Pass an allocation parameter indicating that the function should -- No user-defined pool; pass an allocation parameter indicating that
-- allocate its result on the heap. -- the function should allocate its result on the heap.
if No (Associated_Storage_Pool (Acc_Type)) then
Add_Alloc_Form_Actual_To_Build_In_Place_Call Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Global_Heap); (Func_Call, Function_Id, Alloc_Form => Global_Heap);
-- User-defined pool; pass an allocation parameter indicating that
-- the function should allocate its result in the pool, and pass the
-- pool. We need 'Unrestricted_Access here, because 'Access is
-- illegal, because the storage pool is not aliased.
else
Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => User_Storage_Pool,
Pool_Actual =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To
(Associated_Storage_Pool (Acc_Type), Loc),
Attribute_Name => Name_Unrestricted_Access));
end if;
Add_Finalization_Master_Actual_To_Build_In_Place_Call Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Acc_Type); (Func_Call, Function_Id, Acc_Type);
...@@ -7796,7 +7877,7 @@ package body Exp_Ch6 is ...@@ -7796,7 +7877,7 @@ package body Exp_Ch6 is
-- called as a dispatching operation and must be treated similarly -- called as a dispatching operation and must be treated similarly
-- to functions with unconstrained result subtypes. -- to functions with unconstrained result subtypes.
Add_Alloc_Form_Actual_To_Build_In_Place_Call Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation); (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
Add_Finalization_Master_Actual_To_Build_In_Place_Call Add_Finalization_Master_Actual_To_Build_In_Place_Call
...@@ -7820,7 +7901,7 @@ package body Exp_Ch6 is ...@@ -7820,7 +7901,7 @@ package body Exp_Ch6 is
-- Pass an allocation parameter indicating that the function should -- Pass an allocation parameter indicating that the function should
-- allocate its result on the secondary stack. -- allocate its result on the secondary stack.
Add_Alloc_Form_Actual_To_Build_In_Place_Call Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Secondary_Stack); (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
Add_Finalization_Master_Actual_To_Build_In_Place_Call Add_Finalization_Master_Actual_To_Build_In_Place_Call
...@@ -7898,7 +7979,7 @@ package body Exp_Ch6 is ...@@ -7898,7 +7979,7 @@ package body Exp_Ch6 is
-- controlling result, because dispatching calls to the function needs -- controlling result, because dispatching calls to the function needs
-- to be treated effectively the same as calls to class-wide functions. -- to be treated effectively the same as calls to class-wide functions.
Add_Alloc_Form_Actual_To_Build_In_Place_Call Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Func_Id, Alloc_Form => Caller_Allocation); (Func_Call, Func_Id, Alloc_Form => Caller_Allocation);
Add_Finalization_Master_Actual_To_Build_In_Place_Call Add_Finalization_Master_Actual_To_Build_In_Place_Call
...@@ -8047,19 +8128,23 @@ package body Exp_Ch6 is ...@@ -8047,19 +8128,23 @@ package body Exp_Ch6 is
-- has an unconstrained or tagged result type). -- has an unconstrained or tagged result type).
if Needs_BIP_Alloc_Form (Enclosing_Func) then if Needs_BIP_Alloc_Form (Enclosing_Func) then
Add_Alloc_Form_Actual_To_Build_In_Place_Call Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, (Func_Call,
Function_Id, Function_Id,
Alloc_Form_Exp => Alloc_Form_Exp =>
New_Reference_To New_Reference_To
(Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form), (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form),
Loc),
Pool_Actual =>
New_Reference_To
(Build_In_Place_Formal (Enclosing_Func, BIP_Storage_Pool),
Loc)); Loc));
-- Otherwise, if enclosing function has a constrained result subtype, -- Otherwise, if enclosing function has a constrained result subtype,
-- then caller allocation will be used. -- then caller allocation will be used.
else else
Add_Alloc_Form_Actual_To_Build_In_Place_Call Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation); (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
end if; end if;
...@@ -8102,7 +8187,7 @@ package body Exp_Ch6 is ...@@ -8102,7 +8187,7 @@ package body Exp_Ch6 is
-- called as a dispatching operation and must be treated similarly -- called as a dispatching operation and must be treated similarly
-- to functions with unconstrained result subtypes. -- to functions with unconstrained result subtypes.
Add_Alloc_Form_Actual_To_Build_In_Place_Call Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation); (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
-- In other unconstrained cases, pass an indication to do the allocation -- In other unconstrained cases, pass an indication to do the allocation
...@@ -8111,7 +8196,7 @@ package body Exp_Ch6 is ...@@ -8111,7 +8196,7 @@ package body Exp_Ch6 is
-- scope is established to ensure eventual cleanup of the result. -- scope is established to ensure eventual cleanup of the result.
else else
Add_Alloc_Form_Actual_To_Build_In_Place_Call Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, (Func_Call,
Function_Id, Function_Id,
Alloc_Form => Secondary_Stack); Alloc_Form => Secondary_Stack);
......
...@@ -88,15 +88,20 @@ package Exp_Ch6 is ...@@ -88,15 +88,20 @@ package Exp_Ch6 is
type BIP_Formal_Kind is type BIP_Formal_Kind is
-- Ada 2005 (AI-318-02): This type defines the kinds of implicit extra -- Ada 2005 (AI-318-02): This type defines the kinds of implicit extra
-- formals created for build-in-place functions. The order of the above -- formals created for build-in-place functions. The order of these
-- enumeration literals matches the order in which the formals are -- enumeration literals matches the order in which the formals are
-- declared. See Sem_Ch6.Create_Extra_Formals. -- declared. See Sem_Ch6.Create_Extra_Formals.
(BIP_Alloc_Form, (BIP_Alloc_Form,
-- Present if result subtype is unconstrained, or if the result type -- Present if result subtype is unconstrained or tagged. Indicates
-- is tagged. Indicates whether the return object is allocated by the -- whether the return object is allocated by the caller or callee, and
-- caller or callee, and if the callee, whether to use the secondary -- if the callee, whether to use the secondary stack or the heap. See
-- stack or the heap. See Create_Extra_Formals. -- Create_Extra_Formals.
BIP_Storage_Pool,
-- Present if result subtype is unconstrained or tagged. If
-- BIP_Alloc_Form = User_Storage_Pool, this is a pointer to the pool
-- (of type access to Root_Storage_Pool'Class). Otherwise null.
BIP_Finalization_Master, BIP_Finalization_Master,
-- Present if result type needs finalization. Pointer to caller's -- Present if result type needs finalization. Pointer to caller's
...@@ -114,8 +119,7 @@ package Exp_Ch6 is ...@@ -114,8 +119,7 @@ package Exp_Ch6 is
-- the return object, or null if BIP_Alloc_Form indicates allocated by -- the return object, or null if BIP_Alloc_Form indicates allocated by
-- callee. -- callee.
-- --
-- ??? We also need to be able to pass in some way to access a user- -- ??? We might also need to be able to pass in a constrained flag.
-- defined storage pool at some point. And perhaps a constrained flag.
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String; function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String;
-- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names -- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names
......
...@@ -1346,6 +1346,7 @@ package Rtsfind is ...@@ -1346,6 +1346,7 @@ package Rtsfind is
RE_Storage_Offset, -- System.Storage_Elements RE_Storage_Offset, -- System.Storage_Elements
RE_To_Address, -- System.Storage_Elements RE_To_Address, -- System.Storage_Elements
RE_Root_Storage_Pool_Ptr, -- System.Storage_Pools
RE_Allocate_Any, -- System.Storage_Pools RE_Allocate_Any, -- System.Storage_Pools
RE_Deallocate_Any, -- System.Storage_Pools RE_Deallocate_Any, -- System.Storage_Pools
RE_Root_Storage_Pool, -- System.Storage_Pools RE_Root_Storage_Pool, -- System.Storage_Pools
...@@ -2542,6 +2543,7 @@ package Rtsfind is ...@@ -2542,6 +2543,7 @@ package Rtsfind is
RE_Storage_Offset => System_Storage_Elements, RE_Storage_Offset => System_Storage_Elements,
RE_To_Address => System_Storage_Elements, RE_To_Address => System_Storage_Elements,
RE_Root_Storage_Pool_Ptr => System_Storage_Pools,
RE_Allocate_Any => System_Storage_Pools, RE_Allocate_Any => System_Storage_Pools,
RE_Deallocate_Any => System_Storage_Pools, RE_Deallocate_Any => System_Storage_Pools,
RE_Root_Storage_Pool => System_Storage_Pools, RE_Root_Storage_Pool => System_Storage_Pools,
......
...@@ -65,6 +65,14 @@ private ...@@ -65,6 +65,14 @@ private
type Root_Storage_Pool is abstract type Root_Storage_Pool is abstract
new Ada.Finalization.Limited_Controlled with null record; new Ada.Finalization.Limited_Controlled with null record;
type Root_Storage_Pool_Ptr is access all Root_Storage_Pool'Class;
for Root_Storage_Pool_Ptr'Storage_Size use 0;
-- Type of the BIP_Storage_Pool extra parameter (see Exp_Ch6). The
-- Storage_Size clause is necessary, because otherwise we have a
-- chicken&egg problem; we can't be creating collection finalization code
-- in this low-level package, because that involves Pool_Global, which
-- imports this package.
-- ??? Are these two still needed? It might be possible to use Subpools. -- ??? Are these two still needed? It might be possible to use Subpools.
-- Allocate_Any_Controlled / Deallocate_Any_Controlled for non-controlled -- Allocate_Any_Controlled / Deallocate_Any_Controlled for non-controlled
-- objects. -- objects.
......
...@@ -6482,6 +6482,15 @@ package body Sem_Ch6 is ...@@ -6482,6 +6482,15 @@ package body Sem_Ch6 is
Add_Extra_Formal Add_Extra_Formal
(E, Standard_Natural, (E, Standard_Natural,
E, BIP_Formal_Suffix (BIP_Alloc_Form)); E, BIP_Formal_Suffix (BIP_Alloc_Form));
-- Whenever we need BIP_Alloc_Form, we also need
-- BIP_Storage_Pool, in case BIP_Alloc_Form indicates to use a
-- user-defined pool.
Discard :=
Add_Extra_Formal
(E, RTE (RE_Root_Storage_Pool_Ptr),
E, BIP_Formal_Suffix (BIP_Storage_Pool));
end if; end if;
-- In the case of functions whose result type needs finalization, -- In the case of functions whose result type needs finalization,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment