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