* gcc.dg/compat/struct-layout-1_generate.c (dg_options): New. Moved
[official-gcc.git] / gcc / ada / a-chtgke.adb
blob614a9b9d2d38843910d24c903d3afcf5ff6bc99f
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2008, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- This unit was originally developed by Matthew J Heaney. --
30 ------------------------------------------------------------------------------
32 package body Ada.Containers.Hash_Tables.Generic_Keys is
34 --------------------------
35 -- Delete_Key_Sans_Free --
36 --------------------------
38 procedure Delete_Key_Sans_Free
39 (HT : in out Hash_Table_Type;
40 Key : Key_Type;
41 X : out Node_Access)
43 Indx : Hash_Type;
44 Prev : Node_Access;
46 begin
47 if HT.Length = 0 then
48 X := null;
49 return;
50 end if;
52 Indx := Index (HT, Key);
53 X := HT.Buckets (Indx);
55 if X = null then
56 return;
57 end if;
59 if Equivalent_Keys (Key, X) then
60 if HT.Busy > 0 then
61 raise Program_Error with
62 "attempt to tamper with elements (container is busy)";
63 end if;
64 HT.Buckets (Indx) := Next (X);
65 HT.Length := HT.Length - 1;
66 return;
67 end if;
69 loop
70 Prev := X;
71 X := Next (Prev);
73 if X = null then
74 return;
75 end if;
77 if Equivalent_Keys (Key, X) then
78 if HT.Busy > 0 then
79 raise Program_Error with
80 "attempt to tamper with elements (container is busy)";
81 end if;
82 Set_Next (Node => Prev, Next => Next (X));
83 HT.Length := HT.Length - 1;
84 return;
85 end if;
86 end loop;
87 end Delete_Key_Sans_Free;
89 ----------
90 -- Find --
91 ----------
93 function Find
94 (HT : Hash_Table_Type;
95 Key : Key_Type) return Node_Access is
97 Indx : Hash_Type;
98 Node : Node_Access;
100 begin
101 if HT.Length = 0 then
102 return null;
103 end if;
105 Indx := Index (HT, Key);
107 Node := HT.Buckets (Indx);
108 while Node /= null loop
109 if Equivalent_Keys (Key, Node) then
110 return Node;
111 end if;
112 Node := Next (Node);
113 end loop;
115 return null;
116 end Find;
118 --------------------------------
119 -- Generic_Conditional_Insert --
120 --------------------------------
122 procedure Generic_Conditional_Insert
123 (HT : in out Hash_Table_Type;
124 Key : Key_Type;
125 Node : out Node_Access;
126 Inserted : out Boolean)
128 Indx : constant Hash_Type := Index (HT, Key);
129 B : Node_Access renames HT.Buckets (Indx);
131 begin
132 if B = null then
133 if HT.Busy > 0 then
134 raise Program_Error with
135 "attempt to tamper with elements (container is busy)";
136 end if;
138 if HT.Length = Count_Type'Last then
139 raise Constraint_Error;
140 end if;
142 Node := New_Node (Next => null);
143 Inserted := True;
145 B := Node;
146 HT.Length := HT.Length + 1;
148 return;
149 end if;
151 Node := B;
152 loop
153 if Equivalent_Keys (Key, Node) then
154 Inserted := False;
155 return;
156 end if;
158 Node := Next (Node);
160 exit when Node = null;
161 end loop;
163 if HT.Busy > 0 then
164 raise Program_Error with
165 "attempt to tamper with elements (container is busy)";
166 end if;
168 if HT.Length = Count_Type'Last then
169 raise Constraint_Error;
170 end if;
172 Node := New_Node (Next => B);
173 Inserted := True;
175 B := Node;
176 HT.Length := HT.Length + 1;
177 end Generic_Conditional_Insert;
179 -----------
180 -- Index --
181 -----------
183 function Index
184 (HT : Hash_Table_Type;
185 Key : Key_Type) return Hash_Type is
186 begin
187 return Hash (Key) mod HT.Buckets'Length;
188 end Index;
190 -----------------------------
191 -- Generic_Replace_Element --
192 -----------------------------
194 procedure Generic_Replace_Element
195 (HT : in out Hash_Table_Type;
196 Node : Node_Access;
197 Key : Key_Type)
199 pragma Assert (HT.Length > 0);
200 pragma Assert (Node /= null);
202 Old_Hash : constant Hash_Type := Hash (Node);
203 Old_Indx : constant Hash_Type := Old_Hash mod HT.Buckets'Length;
205 New_Hash : constant Hash_Type := Hash (Key);
206 New_Indx : constant Hash_Type := New_Hash mod HT.Buckets'Length;
208 New_Bucket : Node_Access renames HT.Buckets (New_Indx);
209 N, M : Node_Access;
211 begin
212 if Equivalent_Keys (Key, Node) then
213 pragma Assert (New_Hash = Old_Hash);
215 if HT.Lock > 0 then
216 raise Program_Error with
217 "attempt to tamper with cursors (container is locked)";
218 end if;
220 -- We can change a node's key to Key (that's what Assign is for), but
221 -- only if Key is not already in the hash table. (In a unique-key
222 -- hash table as this one a key is mapped to exactly one node only.)
223 -- The exception is when Key is mapped to Node, in which case the
224 -- change is allowed.
226 Assign (Node, Key);
227 pragma Assert (Hash (Node) = New_Hash);
228 pragma Assert (Equivalent_Keys (Key, Node));
229 return;
230 end if;
232 -- Key is not equivalent to Node, so we now have to determine if it's
233 -- equivalent to some other node in the hash table. This is the case
234 -- irrespective of whether Key is in the same or a different bucket from
235 -- Node.
237 N := New_Bucket;
238 while N /= null loop
239 if Equivalent_Keys (Key, N) then
240 pragma Assert (N /= Node);
241 raise Program_Error with
242 "attempt to replace existing element";
243 end if;
245 N := Next (N);
246 end loop;
248 -- We have determined that Key is not already in the hash table, so
249 -- the change is tentatively allowed. We now perform the standard
250 -- checks to determine whether the hash table is locked (because you
251 -- cannot change an element while it's in use by Query_Element or
252 -- Update_Element), or if the container is busy (because moving a
253 -- node to a different bucket would interfere with iteration).
255 if Old_Indx = New_Indx then
256 -- The node is already in the bucket implied by Key. In this case
257 -- we merely change its value without moving it.
259 if HT.Lock > 0 then
260 raise Program_Error with
261 "attempt to tamper with cursors (container is locked)";
262 end if;
264 Assign (Node, Key);
265 pragma Assert (Hash (Node) = New_Hash);
266 pragma Assert (Equivalent_Keys (Key, Node));
267 return;
268 end if;
270 -- The node is a bucket different from the bucket implied by Key
272 if HT.Busy > 0 then
273 raise Program_Error with
274 "attempt to tamper with elements (container is busy)";
275 end if;
277 -- Do the assignment first, before moving the node, so that if Assign
278 -- propagates an exception, then the hash table will not have been
279 -- modified (except for any possible side-effect Assign had on Node).
281 Assign (Node, Key);
282 pragma Assert (Hash (Node) = New_Hash);
283 pragma Assert (Equivalent_Keys (Key, Node));
285 -- Now we can safely remove the node from its current bucket
287 N := HT.Buckets (Old_Indx);
288 pragma Assert (N /= null);
290 if N = Node then
291 HT.Buckets (Old_Indx) := Next (Node);
293 else
294 pragma Assert (HT.Length > 1);
296 loop
297 M := Next (N);
298 pragma Assert (M /= null);
300 if M = Node then
301 Set_Next (Node => N, Next => Next (Node));
302 exit;
303 end if;
305 N := M;
306 end loop;
307 end if;
309 -- Now we link the node into its new bucket (corresponding to Key)
311 Set_Next (Node => Node, Next => New_Bucket);
312 New_Bucket := Node;
313 end Generic_Replace_Element;
315 end Ada.Containers.Hash_Tables.Generic_Keys;