From patchwork Thu Oct 13 10:38:07 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 119411 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 35383B6F86 for ; Thu, 13 Oct 2011 21:38:35 +1100 (EST) Received: (qmail 30640 invoked by alias); 13 Oct 2011 10:38:30 -0000 Received: (qmail 30629 invoked by uid 22791); 13 Oct 2011 10:38:27 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00,TW_TM X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 13 Oct 2011 10:38:08 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 44AE32BB4AF; Thu, 13 Oct 2011 06:38:07 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id hHQyLAvJ63xi; Thu, 13 Oct 2011 06:38:07 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 3045B2BB342; Thu, 13 Oct 2011 06:38:07 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 1E32F3FEE8; Thu, 13 Oct 2011 06:38:07 -0400 (EDT) Date: Thu, 13 Oct 2011 06:38:07 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [Ada] Support for user-defined storage pools in limited function returns Message-ID: <20111013103806.GA4705@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This patch fixes a bug in which the global heap was used, even when a user-defined storage pool had been specified. The bug occurred when the function result type is immutably limited (so build-in-place is used), and the result subtype is unconstrained or tagged (so has caller-unknown-size), and the call site is the initial value for an allocator of an access type with a user-defined storage pool. The following test should run silently. gnatmake -f -gnat05 driver with Ada.Text_IO; with S; with P; procedure Driver is begin P.Alloc; raise Program_Error; exception when S.Pool_Error => null; -- OK end Driver; package P is procedure Alloc; end P; with S; package body P is type T is tagged limited null record; function C return T'Class is begin return T'(null record); end C; P : S.Test_Pool; type T_Access is access T'Class; for T_Access'Storage_Pool use P; procedure Alloc is X : T_Access := new T'Class'(C); -- XXX Here Pool_Error must be raised. begin null; end Alloc; end P; with System.Storage_Elements; with System.Storage_Pools; package S is type Test_Pool is new System.Storage_Pools.Root_Storage_Pool with null record; procedure Allocate (Pool : in out Test_Pool; Storage_Address : out System.Address; Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count); procedure Deallocate (Pool : in out Test_Pool; Storage_Address : in System.Address; Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count); function Storage_Size (Pool : in Test_Pool) return System.Storage_Elements.Storage_Count; Pool_Error : exception; end S; with P; package body S is procedure Allocate (Pool : in out Test_Pool; Storage_Address : out System.Address; Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count) is begin raise Pool_Error; end Allocate; procedure Deallocate (Pool : in out Test_Pool; Storage_Address : in System.Address; Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count) is begin raise Program_Error; end Deallocate; function Storage_Size (Pool : in Test_Pool) return System.Storage_Elements.Storage_Count is begin raise Program_Error; return 0; end Storage_Size; end S; Tested on x86_64-pc-linux-gnu, committed on trunk 2011-10-13 Bob Duff * 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. Index: rtsfind.ads =================================================================== --- rtsfind.ads (revision 179894) +++ rtsfind.ads (working copy) @@ -1346,6 +1346,7 @@ RE_Storage_Offset, -- System.Storage_Elements RE_To_Address, -- System.Storage_Elements + RE_Root_Storage_Pool_Ptr, -- System.Storage_Pools RE_Allocate_Any, -- System.Storage_Pools RE_Deallocate_Any, -- System.Storage_Pools RE_Root_Storage_Pool, -- System.Storage_Pools @@ -2542,6 +2543,7 @@ RE_Storage_Offset => System_Storage_Elements, RE_To_Address => System_Storage_Elements, + RE_Root_Storage_Pool_Ptr => System_Storage_Pools, RE_Allocate_Any => System_Storage_Pools, RE_Deallocate_Any => System_Storage_Pools, RE_Root_Storage_Pool => System_Storage_Pools, Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 179894) +++ exp_ch4.adb (working copy) @@ -3526,23 +3526,28 @@ end if; -- 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)); - Set_Storage_Pool (N, Pool); + if No (Storage_Pool (N)) then + Pool := Associated_Storage_Pool (Root_Type (PtrT)); - 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; + if Present (Pool) then + Set_Storage_Pool (N, Pool); - elsif Is_Class_Wide_Type (Etype (Pool)) then - Set_Procedure_To_Call (N, RTE (RE_Allocate_Any)); + 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; - else - Set_Procedure_To_Call (N, - Find_Prim_Op (Etype (Pool), Name_Allocate)); + 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 (Pool), Name_Allocate)); + end if; end if; end if; Index: s-stopoo.ads =================================================================== --- s-stopoo.ads (revision 179894) +++ s-stopoo.ads (working copy) @@ -65,6 +65,14 @@ type Root_Storage_Pool is abstract 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. -- Allocate_Any_Controlled / Deallocate_Any_Controlled for non-controlled -- objects. Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 179894) +++ exp_ch6.adb (working copy) @@ -94,15 +94,18 @@ -- along directly to the build-in-place function. Finally, if Return_Object -- 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_Id : Entity_Id; Alloc_Form : BIP_Allocation_Form := Unspecified; - Alloc_Form_Exp : Node_Id := Empty); - -- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation, - -- if any, to be done by a build-in-place function. 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). + Alloc_Form_Exp : Node_Id := Empty; + Pool_Actual : Node_Id := Make_Null (No_Location)); + -- Ada 2005 (AI-318-02): Add the actuals needed for a build-in-place + -- function call that returns a caller-unknown-size result (BIP_Alloc_Form + -- 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 (Func_Call : Node_Id; @@ -252,18 +255,20 @@ 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_Id : Entity_Id; 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 Loc : constant Source_Ptr := Sloc (Function_Call); Alloc_Form_Actual : Node_Id; Alloc_Form_Formal : Node_Id; + Pool_Formal : Node_Id; begin -- The allocation form generally doesn't need to be passed in the case @@ -305,8 +310,16 @@ Add_Extra_Actual_To_Call (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 -- ----------------------------------------------------------- @@ -541,6 +554,8 @@ case Kind is when BIP_Alloc_Form => return "BIPalloc"; + when BIP_Storage_Pool => + return "BIPstoragepool"; when BIP_Finalization_Master => return "BIPfinalizationmaster"; when BIP_Master => @@ -4638,11 +4653,12 @@ Alloc_Expr : Node_Id) return Node_Id is begin + pragma Assert (Is_Build_In_Place_Function (Func_Id)); + -- Processing for build-in-place object allocation. This is disabled -- on .NET/JVM because the targets do not support pools. if VM_Target = No_VM - and then Is_Build_In_Place_Function (Func_Id) and then Needs_Finalization (Ret_Typ) then declare @@ -5121,9 +5137,13 @@ Alloc_Obj_Id : Entity_Id; Alloc_Obj_Decl : Node_Id; Alloc_If_Stmt : Node_Id; + SS_Allocator : Node_Id; Heap_Allocator : Node_Id; - SS_Allocator : Node_Id; + Pool_Decl : Node_Id; + Pool_Allocator : Node_Id; + Pool_Id : constant Entity_Id := Make_Temporary (Loc, 'P'); + begin -- Reuse the itype created for the function's implicit -- access formal. This avoids the need to create a new @@ -5216,6 +5236,25 @@ Set_No_Initialization (Heap_Allocator); 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 -- an allocator for secondary stack allocation is needed. -- It's OK for such allocators to have Comes_From_Source @@ -5225,22 +5264,25 @@ if Restriction_Active (No_Allocators) then SS_Allocator := Heap_Allocator; Heap_Allocator := Make_Null (Loc); + Pool_Allocator := Make_Null (Loc); - -- Otherwise the heap allocator may be needed, so we make - -- another allocator for secondary stack allocation. + -- Otherwise the heap and pool allocators may be needed, + -- so we make another allocator for secondary stack + -- allocation. else SS_Allocator := New_Copy_Tree (Heap_Allocator); - -- The heap allocator is marked Comes_From_Source - -- since it corresponds to an explicit user-written - -- allocator (that is, it will only be executed on - -- behalf of callers that call the function as - -- initialization for such an allocator). This - -- prevents errors when No_Implicit_Heap_Allocations - -- is in force. + -- The heap and pool allocators are marked + -- Comes_From_Source since they correspond to an + -- explicit user-written allocator (that is, it will + -- only be executed on behalf of callers that call the + -- function as initialization for such an + -- allocator). This prevents errors when + -- No_Implicit_Heap_Allocations is in force. Set_Comes_From_Source (Heap_Allocator, True); + Set_Comes_From_Source (Pool_Allocator, True); end if; -- The allocator is returned on the secondary stack. We @@ -5269,10 +5311,12 @@ -- Create an if statement to test the BIP_Alloc_Form -- formal and initialize the access object to either the - -- BIP_Object_Access formal (BIP_Alloc_Form = 0), the - -- result of allocating the object in the secondary stack - -- (BIP_Alloc_Form = 1), or else an allocator to create - -- the return object in the heap (BIP_Alloc_Form = 2). + -- BIP_Object_Access formal (BIP_Alloc_Form = + -- Caller_Allocation), the result of allocating the + -- object in the secondary stack (BIP_Alloc_Form = + -- 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 -- case of assigning the access object formal to the @@ -5320,15 +5364,34 @@ Make_Assignment_Statement (Loc, Name => 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 ( + Pool_Decl, 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))); + Alloc_Expr => Pool_Allocator))); -- If a separate initialization assignment was created -- earlier, append that following the assignment of the @@ -7592,7 +7655,7 @@ -- called as a dispatching operation and must be treated similarly -- 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); Add_Finalization_Master_Actual_To_Build_In_Place_Call @@ -7623,12 +7686,30 @@ -- operations. ??? else - -- Pass an allocation parameter indicating that the function should - -- allocate its result on the heap. + -- No user-defined pool; pass an allocation parameter indicating that + -- the function should allocate its result on the heap. - Add_Alloc_Form_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Global_Heap); + if No (Associated_Storage_Pool (Acc_Type)) then + Add_Unconstrained_Actuals_To_Build_In_Place_Call + (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 (Func_Call, Function_Id, Acc_Type); @@ -7796,7 +7877,7 @@ -- called as a dispatching operation and must be treated similarly -- 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); Add_Finalization_Master_Actual_To_Build_In_Place_Call @@ -7820,7 +7901,7 @@ -- Pass an allocation parameter indicating that the function should -- 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); Add_Finalization_Master_Actual_To_Build_In_Place_Call @@ -7898,7 +7979,7 @@ -- controlling result, because dispatching calls to the function needs -- 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); Add_Finalization_Master_Actual_To_Build_In_Place_Call @@ -8047,19 +8128,23 @@ -- has an unconstrained or tagged result type). 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, Function_Id, Alloc_Form_Exp => New_Reference_To (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)); -- Otherwise, if enclosing function has a constrained result subtype, -- then caller allocation will be used. 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); end if; @@ -8102,7 +8187,7 @@ -- called as a dispatching operation and must be treated similarly -- 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); -- In other unconstrained cases, pass an indication to do the allocation @@ -8111,7 +8196,7 @@ -- scope is established to ensure eventual cleanup of the result. else - 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); Index: exp_ch6.ads =================================================================== --- exp_ch6.ads (revision 179894) +++ exp_ch6.ads (working copy) @@ -88,16 +88,21 @@ type BIP_Formal_Kind is -- 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 -- declared. See Sem_Ch6.Create_Extra_Formals. (BIP_Alloc_Form, - -- Present if result subtype is unconstrained, or if the result type - -- is tagged. Indicates whether the return object is allocated by the - -- caller or callee, and if the callee, whether to use the secondary - -- stack or the heap. See Create_Extra_Formals. + -- Present if result subtype is unconstrained or tagged. Indicates + -- whether the return object is allocated by the caller or callee, and + -- if the callee, whether to use the secondary stack or the heap. See + -- 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, -- Present if result type needs finalization. Pointer to caller's -- finalization master. @@ -114,8 +119,7 @@ -- the return object, or null if BIP_Alloc_Form indicates allocated by -- callee. -- - -- ??? We also need to be able to pass in some way to access a user- - -- defined storage pool at some point. And perhaps a constrained flag. + -- ??? We might also need to be able to pass in a constrained flag. 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 Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 179902) +++ sem_ch6.adb (working copy) @@ -6482,6 +6482,15 @@ Add_Extra_Formal (E, Standard_Natural, 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; -- In the case of functions whose result type needs finalization,