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, 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
28with Ada.Unchecked_Deallocation;
29
30package body Ada.Containers.Indefinite_Holders is
31
32   procedure Free is
33     new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
34
35   ---------
36   -- "=" --
37   ---------
38
39   function "=" (Left, Right : Holder) return Boolean is
40   begin
41      if Left.Reference = null and Right.Reference = null then
42         return True;
43
44      elsif Left.Reference /= null and Right.Reference /= null then
45         return Left.Reference.Element.all = Right.Reference.Element.all;
46
47      else
48         return False;
49      end if;
50   end "=";
51
52   ------------
53   -- Adjust --
54   ------------
55
56   overriding procedure Adjust (Container : in out Holder) is
57   begin
58      if Container.Reference /= null then
59         Reference (Container.Reference);
60      end if;
61
62      Container.Busy := 0;
63   end Adjust;
64
65   ------------
66   -- Assign --
67   ------------
68
69   procedure Assign (Target : in out Holder; Source : Holder) is
70   begin
71      if Target.Busy /= 0 then
72         raise Program_Error with "attempt to tamper with elements";
73      end if;
74
75      if Target.Reference /= Source.Reference then
76         if Target.Reference /= null then
77            Unreference (Target.Reference);
78         end if;
79
80         Target.Reference := Source.Reference;
81
82         if Source.Reference /= null then
83            Reference (Target.Reference);
84         end if;
85      end if;
86   end Assign;
87
88   -----------
89   -- Clear --
90   -----------
91
92   procedure Clear (Container : in out Holder) is
93   begin
94      if Container.Busy /= 0 then
95         raise Program_Error with "attempt to tamper with elements";
96      end if;
97
98      Unreference (Container.Reference);
99      Container.Reference := null;
100   end Clear;
101
102   ----------
103   -- Copy --
104   ----------
105
106   function Copy (Source : Holder) return Holder is
107   begin
108      if Source.Reference = null then
109         return (AF.Controlled with null, 0);
110      else
111         Reference (Source.Reference);
112
113         return (AF.Controlled with Source.Reference, 0);
114      end if;
115   end Copy;
116
117   -------------
118   -- Element --
119   -------------
120
121   function Element (Container : Holder) return Element_Type is
122   begin
123      if Container.Reference = null then
124         raise Constraint_Error with "container is empty";
125      else
126         return Container.Reference.Element.all;
127      end if;
128   end Element;
129
130   --------------
131   -- Finalize --
132   --------------
133
134   overriding procedure Finalize (Container : in out Holder) is
135   begin
136      if Container.Busy /= 0 then
137         raise Program_Error with "attempt to tamper with elements";
138      end if;
139
140      if Container.Reference /= null then
141         Unreference (Container.Reference);
142         Container.Reference := null;
143      end if;
144   end Finalize;
145
146   --------------
147   -- Is_Empty --
148   --------------
149
150   function Is_Empty (Container : Holder) return Boolean is
151   begin
152      return Container.Reference = null;
153   end Is_Empty;
154
155   ----------
156   -- Move --
157   ----------
158
159   procedure Move (Target : in out Holder; Source : in out Holder) is
160   begin
161      if Target.Busy /= 0 then
162         raise Program_Error with "attempt to tamper with elements";
163      end if;
164
165      if Source.Busy /= 0 then
166         raise Program_Error with "attempt to tamper with elements";
167      end if;
168
169      if Target.Reference /= Source.Reference then
170         if Target.Reference /= null then
171            Unreference (Target.Reference);
172         end if;
173
174         Target.Reference := Source.Reference;
175         Source.Reference := null;
176      end if;
177   end Move;
178
179   -------------------
180   -- Query_Element --
181   -------------------
182
183   procedure Query_Element
184     (Container : Holder;
185      Process   : not null access procedure (Element : Element_Type))
186   is
187      B : Natural renames Container'Unrestricted_Access.Busy;
188
189   begin
190      if Container.Reference = null then
191         raise Constraint_Error with "container is empty";
192      end if;
193
194      B := B + 1;
195
196      begin
197         Process (Container.Reference.Element.all);
198      exception
199         when others =>
200            B := B - 1;
201            raise;
202      end;
203
204      B := B - 1;
205   end Query_Element;
206
207   ----------
208   -- Read --
209   ----------
210
211   procedure Read
212     (Stream    : not null access Ada.Streams.Root_Stream_Type'Class;
213      Container : out Holder)
214   is
215   begin
216      Clear (Container);
217
218      if not Boolean'Input (Stream) then
219         Container.Reference :=
220            new Shared_Holder'
221              (Counter => <>,
222               Element => new Element_Type'(Element_Type'Input (Stream)));
223      end if;
224   end Read;
225
226   ---------------
227   -- Reference --
228   ---------------
229
230   procedure Reference (Item : not null Shared_Holder_Access) is
231   begin
232      System.Atomic_Counters.Increment (Item.Counter);
233   end Reference;
234
235   ---------------------
236   -- Replace_Element --
237   ---------------------
238
239   procedure Replace_Element
240     (Container : in out Holder;
241      New_Item  : Element_Type)
242   is
243      --  Element allocator may need an accessibility check in case actual type
244      --  is class-wide or has access discriminants (RM 4.8(10.1) and
245      --  AI12-0035).
246
247      pragma Unsuppress (Accessibility_Check);
248
249   begin
250      if Container.Busy /= 0 then
251         raise Program_Error with "attempt to tamper with elements";
252      end if;
253
254      if Container.Reference = null then
255         --  Holder is empty, allocate new Shared_Holder.
256
257         Container.Reference :=
258            new Shared_Holder'
259              (Counter => <>,
260               Element => new Element_Type'(New_Item));
261
262      elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then
263         --  Shared_Holder can be reused.
264
265         Free (Container.Reference.Element);
266         Container.Reference.Element := new Element_Type'(New_Item);
267
268      else
269         Unreference (Container.Reference);
270         Container.Reference :=
271            new Shared_Holder'
272              (Counter => <>,
273               Element => new Element_Type'(New_Item));
274      end if;
275   end Replace_Element;
276
277   ---------------
278   -- To_Holder --
279   ---------------
280
281   function To_Holder (New_Item : Element_Type) return Holder is
282      --  The element allocator may need an accessibility check in the case the
283      --  actual type is class-wide or has access discriminants (RM 4.8(10.1)
284      --  and AI12-0035).
285
286      pragma Unsuppress (Accessibility_Check);
287
288   begin
289      return
290        (AF.Controlled with
291            new Shared_Holder'
292              (Counter => <>,
293               Element => new Element_Type'(New_Item)), 0);
294   end To_Holder;
295
296   -----------------
297   -- Unreference --
298   -----------------
299
300   procedure Unreference (Item : not null Shared_Holder_Access) is
301
302      procedure Free is
303        new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access);
304
305      Aux : Shared_Holder_Access := Item;
306
307   begin
308      if System.Atomic_Counters.Decrement (Aux.Counter) then
309         Free (Aux.Element);
310         Free (Aux);
311      end if;
312   end Unreference;
313
314   --------------------
315   -- Update_Element --
316   --------------------
317
318   procedure Update_Element
319     (Container : Holder;
320      Process   : not null access procedure (Element : in out Element_Type))
321   is
322      B : Natural renames Container'Unrestricted_Access.Busy;
323
324   begin
325      if Container.Reference = null then
326         raise Constraint_Error with "container is empty";
327      end if;
328
329      B := B + 1;
330
331      begin
332         Process (Container.Reference.Element.all);
333      exception
334         when others =>
335            B := B - 1;
336            raise;
337      end;
338
339      B := B - 1;
340   end Update_Element;
341
342   -----------
343   -- Write --
344   -----------
345
346   procedure Write
347     (Stream    : not null access Ada.Streams.Root_Stream_Type'Class;
348      Container : Holder)
349   is
350   begin
351      Boolean'Output (Stream, Container.Reference = null);
352
353      if Container.Reference /= null then
354         Element_Type'Output (Stream, Container.Reference.Element.all);
355      end if;
356   end Write;
357
358end Ada.Containers.Indefinite_Holders;
359