comparison gcc/testsuite/gnat.dg/subpools1.adb @ 19:2b5abeee2509 default tip

update gcc11
author anatofuz
date Mon, 25 May 2020 07:50:57 +0900
parents
children
comparison
equal deleted inserted replaced
18:1830386684a0 19:2b5abeee2509
1 -- { dg-do compile }
2
3 with System.Storage_Elements;
4 with System.Storage_Pools.Subpools;
5
6 procedure 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
80 begin
81 null;
82 end;