Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/s-pooloc.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 ------------------------------------------------------------------------------ | |
2 -- -- | |
3 -- GNAT COMPILER COMPONENTS -- | |
4 -- -- | |
5 -- S Y S T E M . P O O L _ L O C A L -- | |
6 -- -- | |
7 -- B o d y -- | |
8 -- -- | |
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- | |
10 -- -- | |
11 -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 -- terms of the GNU General Public License as published by the Free Soft- -- | |
13 -- ware Foundation; either version 3, or (at your option) any later ver- -- | |
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 -- or FITNESS FOR A PARTICULAR PURPOSE. -- | |
17 -- -- | |
18 -- As a special exception under Section 7 of GPL version 3, you are granted -- | |
19 -- additional permissions described in the GCC Runtime Library Exception, -- | |
20 -- version 3.1, as published by the Free Software Foundation. -- | |
21 -- -- | |
22 -- You should have received a copy of the GNU General Public License and -- | |
23 -- a copy of the GCC Runtime Library Exception along with this program; -- | |
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- | |
25 -- <http://www.gnu.org/licenses/>. -- | |
26 -- -- | |
27 -- GNAT was originally developed by the GNAT team at New York University. -- | |
28 -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
29 -- -- | |
30 ------------------------------------------------------------------------------ | |
31 | |
32 with System.Memory; | |
33 | |
34 with Ada.Unchecked_Conversion; | |
35 | |
36 package body System.Pool_Local is | |
37 | |
38 package SSE renames System.Storage_Elements; | |
39 use type SSE.Storage_Offset; | |
40 | |
41 Pointer_Size : constant SSE.Storage_Offset := Address'Size / Storage_Unit; | |
42 Pointers_Size : constant SSE.Storage_Offset := 2 * Pointer_Size; | |
43 | |
44 type Acc_Address is access all Address; | |
45 function To_Acc_Address is | |
46 new Ada.Unchecked_Conversion (Address, Acc_Address); | |
47 | |
48 ----------------------- | |
49 -- Local Subprograms -- | |
50 ----------------------- | |
51 | |
52 function Next (A : Address) return Acc_Address; | |
53 pragma Inline (Next); | |
54 -- Given an address of a block, return an access to the next block | |
55 | |
56 function Prev (A : Address) return Acc_Address; | |
57 pragma Inline (Prev); | |
58 -- Given an address of a block, return an access to the previous block | |
59 | |
60 -------------- | |
61 -- Allocate -- | |
62 -------------- | |
63 | |
64 procedure Allocate | |
65 (Pool : in out Unbounded_Reclaim_Pool; | |
66 Address : out System.Address; | |
67 Storage_Size : SSE.Storage_Count; | |
68 Alignment : SSE.Storage_Count) | |
69 is | |
70 pragma Warnings (Off, Alignment); | |
71 | |
72 Allocated : constant System.Address := | |
73 Memory.Alloc | |
74 (Memory.size_t (Storage_Size + Pointers_Size)); | |
75 | |
76 begin | |
77 -- The call to Alloc returns an address whose alignment is compatible | |
78 -- with the worst case alignment requirement for the machine; thus the | |
79 -- Alignment argument can be safely ignored. | |
80 | |
81 if Allocated = Null_Address then | |
82 raise Storage_Error; | |
83 else | |
84 Address := Allocated + Pointers_Size; | |
85 Next (Allocated).all := Pool.First; | |
86 Prev (Allocated).all := Null_Address; | |
87 | |
88 if Pool.First /= Null_Address then | |
89 Prev (Pool.First).all := Allocated; | |
90 end if; | |
91 | |
92 Pool.First := Allocated; | |
93 end if; | |
94 end Allocate; | |
95 | |
96 ---------------- | |
97 -- Deallocate -- | |
98 ---------------- | |
99 | |
100 procedure Deallocate | |
101 (Pool : in out Unbounded_Reclaim_Pool; | |
102 Address : System.Address; | |
103 Storage_Size : SSE.Storage_Count; | |
104 Alignment : SSE.Storage_Count) | |
105 is | |
106 pragma Warnings (Off, Storage_Size); | |
107 pragma Warnings (Off, Alignment); | |
108 | |
109 Allocated : constant System.Address := Address - Pointers_Size; | |
110 | |
111 begin | |
112 if Prev (Allocated).all = Null_Address then | |
113 Pool.First := Next (Allocated).all; | |
114 | |
115 -- Comment needed | |
116 | |
117 if Pool.First /= Null_Address then | |
118 Prev (Pool.First).all := Null_Address; | |
119 end if; | |
120 else | |
121 Next (Prev (Allocated).all).all := Next (Allocated).all; | |
122 end if; | |
123 | |
124 if Next (Allocated).all /= Null_Address then | |
125 Prev (Next (Allocated).all).all := Prev (Allocated).all; | |
126 end if; | |
127 | |
128 Memory.Free (Allocated); | |
129 end Deallocate; | |
130 | |
131 -------------- | |
132 -- Finalize -- | |
133 -------------- | |
134 | |
135 procedure Finalize (Pool : in out Unbounded_Reclaim_Pool) is | |
136 N : System.Address := Pool.First; | |
137 Allocated : System.Address; | |
138 | |
139 begin | |
140 while N /= Null_Address loop | |
141 Allocated := N; | |
142 N := Next (N).all; | |
143 Memory.Free (Allocated); | |
144 end loop; | |
145 end Finalize; | |
146 | |
147 ---------- | |
148 -- Next -- | |
149 ---------- | |
150 | |
151 function Next (A : Address) return Acc_Address is | |
152 begin | |
153 return To_Acc_Address (A); | |
154 end Next; | |
155 | |
156 ---------- | |
157 -- Prev -- | |
158 ---------- | |
159 | |
160 function Prev (A : Address) return Acc_Address is | |
161 begin | |
162 return To_Acc_Address (A + Pointer_Size); | |
163 end Prev; | |
164 | |
165 end System.Pool_Local; |