[Ada] Support for user-defined storage pools in limited function returns

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  <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.

[Ada] Support for user-defined storage pools in limited function returns

Commit Message

Patch