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