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