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