1-- { dg-do compile } 2 3with System.Storage_Elements; 4with System.Storage_Pools.Subpools; 5 6procedure Subpools1 is 7 8 use System.Storage_Pools.Subpools; 9 10 package Local_Pools is 11 12 use System.Storage_Elements; 13 14 type Local_Pool is new Root_Storage_Pool_With_Subpools with null record; 15 16 overriding 17 function Create_Subpool (Pool: in out Local_Pool) 18 return not null Subpool_Handle; 19 20 overriding 21 procedure Allocate_From_Subpool 22 (Pool : in out Local_Pool; 23 Storage_Address : out System.Address; 24 Size_In_Storage_Elements: in Storage_Count; 25 Alignment : in Storage_Count; 26 Subpool : in not null Subpool_Handle); 27 28 overriding 29 procedure Deallocate_Subpool 30 (Pool : in out Local_Pool; 31 Subpool: in out Subpool_Handle) is null; 32 33 end Local_Pools; 34 35 package body Local_Pools is 36 37 type Local_Subpool is new Root_Subpool with null record; 38 39 Dummy_Subpool: aliased Local_Subpool; 40 41 overriding 42 function Create_Subpool (Pool: in out Local_Pool) 43 return not null Subpool_Handle 44 is 45 begin 46 return Result: not null Subpool_Handle 47 := Dummy_Subpool'Unchecked_Access 48 do 49 Set_Pool_Of_Subpool (Result, Pool); 50 end return; 51 end; 52 53 overriding 54 procedure Allocate_From_Subpool 55 (Pool : in out Local_Pool; 56 Storage_Address : out System.Address; 57 Size_In_Storage_Elements: in Storage_Count; 58 Alignment : in Storage_Count; 59 Subpool : in not null Subpool_Handle) 60 is 61 type Storage_Array_Access is access Storage_Array; 62 63 New_Alloc: Storage_Array_Access 64 := new Storage_Array (1 .. Size_In_Storage_Elements + Alignment); 65 begin 66 for SE of New_Alloc.all loop 67 Storage_Address := SE'Address; 68 exit when Storage_Address mod Alignment = 0; 69 end loop; 70 end; 71 72 end Local_Pools; 73 74 A_Pool: Local_Pools.Local_Pool; 75 76 type Integer_Access is access Integer with Storage_Pool => A_Pool; 77 78 X: Integer_Access := new Integer; 79 80begin 81 null; 82end; 83