]>
Commit | Line | Data |
---|---|---|
0c5dba7f AC |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT LIBRARY COMPONENTS -- | |
4 | -- -- | |
5 | -- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 2013-2020, Free Software Foundation, Inc. -- |
0c5dba7f AC |
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 | ||
80363c2f | 28 | -- Note: special attention must be paid to the case of simultaneous access |
79904ebc | 29 | -- to internal shared objects and elements by different tasks. The Reference |
80363c2f AC |
30 | -- counter of internal shared object is the only component protected using |
31 | -- atomic operations; other components and elements can be modified only when | |
32 | -- reference counter is equal to one (so there are no other references to this | |
33 | -- internal shared object and element). | |
34 | ||
0c5dba7f AC |
35 | with Ada.Unchecked_Deallocation; |
36 | ||
37 | package body Ada.Containers.Indefinite_Holders is | |
38 | ||
39 | procedure Free is | |
40 | new Ada.Unchecked_Deallocation (Element_Type, Element_Access); | |
41 | ||
448a1eb3 AC |
42 | procedure Detach (Container : Holder); |
43 | -- Detach data from shared copy if necessary. This is necessary to prepare | |
44 | -- container to be modified. | |
45 | ||
0c5dba7f AC |
46 | --------- |
47 | -- "=" -- | |
48 | --------- | |
49 | ||
50 | function "=" (Left, Right : Holder) return Boolean is | |
51 | begin | |
ab476638 | 52 | if Left.Reference = Right.Reference then |
9ab5d86b RD |
53 | |
54 | -- Covers both null and not null but the same shared object cases | |
ab476638 | 55 | |
0c5dba7f AC |
56 | return True; |
57 | ||
58 | elsif Left.Reference /= null and Right.Reference /= null then | |
59 | return Left.Reference.Element.all = Right.Reference.Element.all; | |
9ab5d86b | 60 | |
0c5dba7f AC |
61 | else |
62 | return False; | |
63 | end if; | |
64 | end "="; | |
65 | ||
66 | ------------ | |
67 | -- Adjust -- | |
68 | ------------ | |
69 | ||
70 | overriding procedure Adjust (Container : in out Holder) is | |
71 | begin | |
72 | if Container.Reference /= null then | |
8942b30c | 73 | if Container.Busy = 0 then |
9ab5d86b RD |
74 | |
75 | -- Container is not locked, reuse existing internal shared object | |
8942b30c AC |
76 | |
77 | Reference (Container.Reference); | |
78 | else | |
79 | -- Otherwise, create copy of both internal shared object and | |
80 | -- element. | |
81 | ||
82 | Container.Reference := | |
83 | new Shared_Holder' | |
84 | (Counter => <>, | |
85 | Element => | |
86 | new Element_Type'(Container.Reference.Element.all)); | |
87 | end if; | |
0c5dba7f AC |
88 | end if; |
89 | ||
90 | Container.Busy := 0; | |
91 | end Adjust; | |
92 | ||
783da331 AC |
93 | overriding procedure Adjust (Control : in out Reference_Control_Type) is |
94 | begin | |
95 | if Control.Container /= null then | |
3a859cff | 96 | Reference (Control.Container.Reference); |
d6f824bf | 97 | Control.Container.Busy := Control.Container.Busy + 1; |
783da331 AC |
98 | end if; |
99 | end Adjust; | |
100 | ||
0c5dba7f AC |
101 | ------------ |
102 | -- Assign -- | |
103 | ------------ | |
104 | ||
105 | procedure Assign (Target : in out Holder; Source : Holder) is | |
106 | begin | |
107 | if Target.Busy /= 0 then | |
108 | raise Program_Error with "attempt to tamper with elements"; | |
109 | end if; | |
110 | ||
111 | if Target.Reference /= Source.Reference then | |
112 | if Target.Reference /= null then | |
113 | Unreference (Target.Reference); | |
114 | end if; | |
115 | ||
116 | Target.Reference := Source.Reference; | |
117 | ||
118 | if Source.Reference /= null then | |
119 | Reference (Target.Reference); | |
120 | end if; | |
121 | end if; | |
122 | end Assign; | |
123 | ||
124 | ----------- | |
125 | -- Clear -- | |
126 | ----------- | |
127 | ||
128 | procedure Clear (Container : in out Holder) is | |
129 | begin | |
130 | if Container.Busy /= 0 then | |
131 | raise Program_Error with "attempt to tamper with elements"; | |
132 | end if; | |
133 | ||
d50a26f2 AC |
134 | if Container.Reference /= null then |
135 | Unreference (Container.Reference); | |
136 | Container.Reference := null; | |
137 | end if; | |
0c5dba7f AC |
138 | end Clear; |
139 | ||
783da331 AC |
140 | ------------------------ |
141 | -- Constant_Reference -- | |
142 | ------------------------ | |
143 | ||
144 | function Constant_Reference | |
8942b30c | 145 | (Container : aliased Holder) return Constant_Reference_Type is |
783da331 | 146 | begin |
8942b30c AC |
147 | if Container.Reference = null then |
148 | raise Constraint_Error with "container is empty"; | |
8942b30c AC |
149 | end if; |
150 | ||
448a1eb3 AC |
151 | Detach (Container); |
152 | ||
8942b30c AC |
153 | declare |
154 | Ref : constant Constant_Reference_Type := | |
155 | (Element => Container.Reference.Element.all'Access, | |
156 | Control => (Controlled with Container'Unrestricted_Access)); | |
157 | begin | |
158 | Reference (Ref.Control.Container.Reference); | |
159 | Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; | |
160 | return Ref; | |
161 | end; | |
783da331 AC |
162 | end Constant_Reference; |
163 | ||
0c5dba7f AC |
164 | ---------- |
165 | -- Copy -- | |
166 | ---------- | |
167 | ||
168 | function Copy (Source : Holder) return Holder is | |
169 | begin | |
170 | if Source.Reference = null then | |
783da331 | 171 | return (Controlled with null, 0); |
9ab5d86b | 172 | |
8942b30c | 173 | elsif Source.Busy = 0 then |
9ab5d86b RD |
174 | |
175 | -- Container is not locked, reuse internal shared object | |
8942b30c | 176 | |
0c5dba7f AC |
177 | Reference (Source.Reference); |
178 | ||
783da331 | 179 | return (Controlled with Source.Reference, 0); |
9ab5d86b | 180 | |
8942b30c | 181 | else |
9ab5d86b | 182 | -- Otherwise, create copy of both internal shared object and element |
8942b30c AC |
183 | |
184 | return | |
185 | (Controlled with | |
9ab5d86b RD |
186 | new Shared_Holder' |
187 | (Counter => <>, | |
188 | Element => new Element_Type'(Source.Reference.Element.all)), | |
8942b30c | 189 | 0); |
0c5dba7f AC |
190 | end if; |
191 | end Copy; | |
192 | ||
448a1eb3 AC |
193 | ------------ |
194 | -- Detach -- | |
195 | ------------ | |
196 | ||
197 | procedure Detach (Container : Holder) is | |
198 | begin | |
199 | if Container.Busy = 0 | |
200 | and then not System.Atomic_Counters.Is_One | |
201 | (Container.Reference.Counter) | |
202 | then | |
203 | -- Container is not locked and internal shared object is used by | |
204 | -- other container, create copy of both internal shared object and | |
205 | -- element. | |
206 | ||
207 | declare | |
208 | Old : constant Shared_Holder_Access := Container.Reference; | |
209 | ||
210 | begin | |
211 | Container'Unrestricted_Access.Reference := | |
212 | new Shared_Holder' | |
213 | (Counter => <>, | |
214 | Element => | |
215 | new Element_Type'(Container.Reference.Element.all)); | |
216 | Unreference (Old); | |
217 | end; | |
218 | end if; | |
219 | end Detach; | |
220 | ||
0c5dba7f AC |
221 | ------------- |
222 | -- Element -- | |
223 | ------------- | |
224 | ||
225 | function Element (Container : Holder) return Element_Type is | |
226 | begin | |
227 | if Container.Reference = null then | |
228 | raise Constraint_Error with "container is empty"; | |
229 | else | |
230 | return Container.Reference.Element.all; | |
231 | end if; | |
232 | end Element; | |
233 | ||
234 | -------------- | |
235 | -- Finalize -- | |
236 | -------------- | |
237 | ||
238 | overriding procedure Finalize (Container : in out Holder) is | |
239 | begin | |
240 | if Container.Busy /= 0 then | |
241 | raise Program_Error with "attempt to tamper with elements"; | |
242 | end if; | |
243 | ||
244 | if Container.Reference /= null then | |
245 | Unreference (Container.Reference); | |
246 | Container.Reference := null; | |
247 | end if; | |
248 | end Finalize; | |
249 | ||
783da331 AC |
250 | overriding procedure Finalize (Control : in out Reference_Control_Type) is |
251 | begin | |
252 | if Control.Container /= null then | |
3a859cff ES |
253 | Unreference (Control.Container.Reference); |
254 | Control.Container.Busy := Control.Container.Busy - 1; | |
d6f824bf | 255 | Control.Container := null; |
783da331 | 256 | end if; |
783da331 AC |
257 | end Finalize; |
258 | ||
0c5dba7f AC |
259 | -------------- |
260 | -- Is_Empty -- | |
261 | -------------- | |
262 | ||
263 | function Is_Empty (Container : Holder) return Boolean is | |
264 | begin | |
265 | return Container.Reference = null; | |
266 | end Is_Empty; | |
267 | ||
268 | ---------- | |
269 | -- Move -- | |
270 | ---------- | |
271 | ||
272 | procedure Move (Target : in out Holder; Source : in out Holder) is | |
273 | begin | |
274 | if Target.Busy /= 0 then | |
275 | raise Program_Error with "attempt to tamper with elements"; | |
276 | end if; | |
277 | ||
278 | if Source.Busy /= 0 then | |
279 | raise Program_Error with "attempt to tamper with elements"; | |
280 | end if; | |
281 | ||
282 | if Target.Reference /= Source.Reference then | |
283 | if Target.Reference /= null then | |
284 | Unreference (Target.Reference); | |
285 | end if; | |
286 | ||
287 | Target.Reference := Source.Reference; | |
288 | Source.Reference := null; | |
289 | end if; | |
290 | end Move; | |
291 | ||
292 | ------------------- | |
293 | -- Query_Element -- | |
294 | ------------------- | |
295 | ||
296 | procedure Query_Element | |
297 | (Container : Holder; | |
298 | Process : not null access procedure (Element : Element_Type)) | |
299 | is | |
300 | B : Natural renames Container'Unrestricted_Access.Busy; | |
301 | ||
302 | begin | |
303 | if Container.Reference = null then | |
304 | raise Constraint_Error with "container is empty"; | |
305 | end if; | |
306 | ||
448a1eb3 AC |
307 | Detach (Container); |
308 | ||
0c5dba7f AC |
309 | B := B + 1; |
310 | ||
311 | begin | |
312 | Process (Container.Reference.Element.all); | |
313 | exception | |
314 | when others => | |
315 | B := B - 1; | |
316 | raise; | |
317 | end; | |
318 | ||
319 | B := B - 1; | |
320 | end Query_Element; | |
321 | ||
322 | ---------- | |
323 | -- Read -- | |
324 | ---------- | |
325 | ||
326 | procedure Read | |
327 | (Stream : not null access Ada.Streams.Root_Stream_Type'Class; | |
328 | Container : out Holder) | |
329 | is | |
330 | begin | |
331 | Clear (Container); | |
332 | ||
333 | if not Boolean'Input (Stream) then | |
334 | Container.Reference := | |
335 | new Shared_Holder' | |
336 | (Counter => <>, | |
337 | Element => new Element_Type'(Element_Type'Input (Stream))); | |
338 | end if; | |
339 | end Read; | |
340 | ||
783da331 AC |
341 | procedure Read |
342 | (Stream : not null access Root_Stream_Type'Class; | |
343 | Item : out Constant_Reference_Type) | |
344 | is | |
345 | begin | |
346 | raise Program_Error with "attempt to stream reference"; | |
347 | end Read; | |
348 | ||
349 | procedure Read | |
350 | (Stream : not null access Root_Stream_Type'Class; | |
351 | Item : out Reference_Type) | |
352 | is | |
353 | begin | |
354 | raise Program_Error with "attempt to stream reference"; | |
355 | end Read; | |
356 | ||
0c5dba7f AC |
357 | --------------- |
358 | -- Reference -- | |
359 | --------------- | |
360 | ||
361 | procedure Reference (Item : not null Shared_Holder_Access) is | |
362 | begin | |
363 | System.Atomic_Counters.Increment (Item.Counter); | |
364 | end Reference; | |
365 | ||
783da331 | 366 | function Reference |
9ab5d86b RD |
367 | (Container : aliased in out Holder) return Reference_Type |
368 | is | |
783da331 | 369 | begin |
8942b30c AC |
370 | if Container.Reference = null then |
371 | raise Constraint_Error with "container is empty"; | |
8942b30c AC |
372 | end if; |
373 | ||
448a1eb3 AC |
374 | Detach (Container); |
375 | ||
8942b30c AC |
376 | declare |
377 | Ref : constant Reference_Type := | |
378 | (Element => Container.Reference.Element.all'Access, | |
379 | Control => (Controlled with Container'Unrestricted_Access)); | |
380 | begin | |
381 | Reference (Ref.Control.Container.Reference); | |
382 | Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; | |
383 | return Ref; | |
384 | end; | |
783da331 AC |
385 | end Reference; |
386 | ||
0c5dba7f AC |
387 | --------------------- |
388 | -- Replace_Element -- | |
389 | --------------------- | |
390 | ||
391 | procedure Replace_Element | |
392 | (Container : in out Holder; | |
393 | New_Item : Element_Type) | |
394 | is | |
395 | -- Element allocator may need an accessibility check in case actual type | |
396 | -- is class-wide or has access discriminants (RM 4.8(10.1) and | |
397 | -- AI12-0035). | |
398 | ||
399 | pragma Unsuppress (Accessibility_Check); | |
400 | ||
401 | begin | |
402 | if Container.Busy /= 0 then | |
403 | raise Program_Error with "attempt to tamper with elements"; | |
404 | end if; | |
405 | ||
406 | if Container.Reference = null then | |
407 | -- Holder is empty, allocate new Shared_Holder. | |
408 | ||
409 | Container.Reference := | |
410 | new Shared_Holder' | |
411 | (Counter => <>, | |
412 | Element => new Element_Type'(New_Item)); | |
413 | ||
414 | elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then | |
415 | -- Shared_Holder can be reused. | |
416 | ||
417 | Free (Container.Reference.Element); | |
418 | Container.Reference.Element := new Element_Type'(New_Item); | |
419 | ||
420 | else | |
421 | Unreference (Container.Reference); | |
422 | Container.Reference := | |
423 | new Shared_Holder' | |
424 | (Counter => <>, | |
425 | Element => new Element_Type'(New_Item)); | |
426 | end if; | |
427 | end Replace_Element; | |
428 | ||
429 | --------------- | |
430 | -- To_Holder -- | |
431 | --------------- | |
432 | ||
433 | function To_Holder (New_Item : Element_Type) return Holder is | |
434 | -- The element allocator may need an accessibility check in the case the | |
435 | -- actual type is class-wide or has access discriminants (RM 4.8(10.1) | |
436 | -- and AI12-0035). | |
437 | ||
438 | pragma Unsuppress (Accessibility_Check); | |
439 | ||
440 | begin | |
441 | return | |
783da331 | 442 | (Controlled with |
0c5dba7f AC |
443 | new Shared_Holder' |
444 | (Counter => <>, | |
445 | Element => new Element_Type'(New_Item)), 0); | |
446 | end To_Holder; | |
447 | ||
448 | ----------------- | |
449 | -- Unreference -- | |
450 | ----------------- | |
451 | ||
452 | procedure Unreference (Item : not null Shared_Holder_Access) is | |
453 | ||
454 | procedure Free is | |
455 | new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access); | |
456 | ||
457 | Aux : Shared_Holder_Access := Item; | |
458 | ||
459 | begin | |
460 | if System.Atomic_Counters.Decrement (Aux.Counter) then | |
461 | Free (Aux.Element); | |
462 | Free (Aux); | |
463 | end if; | |
464 | end Unreference; | |
465 | ||
466 | -------------------- | |
467 | -- Update_Element -- | |
468 | -------------------- | |
469 | ||
470 | procedure Update_Element | |
d6f824bf | 471 | (Container : in out Holder; |
0c5dba7f AC |
472 | Process : not null access procedure (Element : in out Element_Type)) |
473 | is | |
d6f824bf | 474 | B : Natural renames Container.Busy; |
0c5dba7f AC |
475 | |
476 | begin | |
477 | if Container.Reference = null then | |
478 | raise Constraint_Error with "container is empty"; | |
479 | end if; | |
480 | ||
448a1eb3 AC |
481 | Detach (Container); |
482 | ||
0c5dba7f AC |
483 | B := B + 1; |
484 | ||
485 | begin | |
486 | Process (Container.Reference.Element.all); | |
487 | exception | |
488 | when others => | |
489 | B := B - 1; | |
490 | raise; | |
491 | end; | |
492 | ||
493 | B := B - 1; | |
494 | end Update_Element; | |
495 | ||
496 | ----------- | |
497 | -- Write -- | |
498 | ----------- | |
499 | ||
500 | procedure Write | |
501 | (Stream : not null access Ada.Streams.Root_Stream_Type'Class; | |
502 | Container : Holder) | |
503 | is | |
504 | begin | |
505 | Boolean'Output (Stream, Container.Reference = null); | |
506 | ||
507 | if Container.Reference /= null then | |
508 | Element_Type'Output (Stream, Container.Reference.Element.all); | |
509 | end if; | |
510 | end Write; | |
511 | ||
783da331 AC |
512 | procedure Write |
513 | (Stream : not null access Root_Stream_Type'Class; | |
514 | Item : Reference_Type) | |
515 | is | |
516 | begin | |
517 | raise Program_Error with "attempt to stream reference"; | |
518 | end Write; | |
519 | ||
520 | procedure Write | |
521 | (Stream : not null access Root_Stream_Type'Class; | |
522 | Item : Constant_Reference_Type) | |
523 | is | |
524 | begin | |
525 | raise Program_Error with "attempt to stream reference"; | |
526 | end Write; | |
527 | ||
0c5dba7f | 528 | end Ada.Containers.Indefinite_Holders; |