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) 2012, 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.Element = null and Right.Element = null then
42         return True;
43
44      elsif Left.Element /= null and Right.Element /= null then
45         return Left.Element.all = Right.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.Element /= null then
59         Container.Element := new Element_Type'(Container.Element.all);
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.Element /= Source.Element then
76         Free (Target.Element);
77
78         if Source.Element /= null then
79            Target.Element := new Element_Type'(Source.Element.all);
80         end if;
81      end if;
82   end Assign;
83
84   -----------
85   -- Clear --
86   -----------
87
88   procedure Clear (Container : in out Holder) is
89   begin
90      if Container.Busy /= 0 then
91         raise Program_Error with "attempt to tamper with elements";
92      end if;
93
94      Free (Container.Element);
95   end Clear;
96
97   ----------
98   -- Copy --
99   ----------
100
101   function Copy (Source : Holder) return Holder is
102   begin
103      if Source.Element = null then
104         return (AF.Controlled with null, 0);
105      else
106         return (AF.Controlled with new Element_Type'(Source.Element.all), 0);
107      end if;
108   end Copy;
109
110   -------------
111   -- Element --
112   -------------
113
114   function Element (Container : Holder) return Element_Type is
115   begin
116      if Container.Element = null then
117         raise Constraint_Error with "container is empty";
118      else
119         return Container.Element.all;
120      end if;
121   end Element;
122
123   --------------
124   -- Finalize --
125   --------------
126
127   overriding procedure Finalize (Container : in out Holder) is
128   begin
129      if Container.Busy /= 0 then
130         raise Program_Error with "attempt to tamper with elements";
131      end if;
132
133      Free (Container.Element);
134   end Finalize;
135
136   --------------
137   -- Is_Empty --
138   --------------
139
140   function Is_Empty (Container : Holder) return Boolean is
141   begin
142      return Container.Element = null;
143   end Is_Empty;
144
145   ----------
146   -- Move --
147   ----------
148
149   procedure Move (Target : in out Holder; Source : in out Holder) is
150   begin
151      if Target.Busy /= 0 then
152         raise Program_Error with "attempt to tamper with elements";
153      end if;
154
155      if Source.Busy /= 0 then
156         raise Program_Error with "attempt to tamper with elements";
157      end if;
158
159      if Target.Element /= Source.Element then
160         Free (Target.Element);
161         Target.Element := Source.Element;
162         Source.Element := null;
163      end if;
164   end Move;
165
166   -------------------
167   -- Query_Element --
168   -------------------
169
170   procedure Query_Element
171     (Container : Holder;
172      Process   : not null access procedure (Element : Element_Type))
173   is
174      B : Natural renames Container'Unrestricted_Access.Busy;
175
176   begin
177      if Container.Element = null then
178         raise Constraint_Error with "container is empty";
179      end if;
180
181      B := B + 1;
182
183      begin
184         Process (Container.Element.all);
185      exception
186         when others =>
187            B := B - 1;
188            raise;
189      end;
190
191      B := B - 1;
192   end Query_Element;
193
194   ----------
195   -- Read --
196   ----------
197
198   procedure Read
199     (Stream    : not null access Ada.Streams.Root_Stream_Type'Class;
200      Container : out Holder)
201   is
202   begin
203      Clear (Container);
204
205      if not Boolean'Input (Stream) then
206         Container.Element := new Element_Type'(Element_Type'Input (Stream));
207      end if;
208   end Read;
209
210   ---------------------
211   -- Replace_Element --
212   ---------------------
213
214   procedure Replace_Element
215     (Container : in out Holder;
216      New_Item  : Element_Type)
217   is
218   begin
219      if Container.Busy /= 0 then
220         raise Program_Error with "attempt to tamper with elements";
221      end if;
222
223      declare
224         X : Element_Access := Container.Element;
225
226         --  Element allocator may need an accessibility check in case actual
227         --  type is class-wide or has access discriminants (RM 4.8(10.1) and
228         --  AI12-0035).
229
230         pragma Unsuppress (Accessibility_Check);
231
232      begin
233         Container.Element := new Element_Type'(New_Item);
234         Free (X);
235      end;
236   end Replace_Element;
237
238   ---------------
239   -- To_Holder --
240   ---------------
241
242   function To_Holder (New_Item : Element_Type) return Holder is
243      --  The element allocator may need an accessibility check in the case the
244      --  actual type is class-wide or has access discriminants (RM 4.8(10.1)
245      --  and AI12-0035).
246
247      pragma Unsuppress (Accessibility_Check);
248
249   begin
250      return (AF.Controlled with new Element_Type'(New_Item), 0);
251   end To_Holder;
252
253   --------------------
254   -- Update_Element --
255   --------------------
256
257   procedure Update_Element
258     (Container : Holder;
259      Process   : not null access procedure (Element : in out Element_Type))
260   is
261      B : Natural renames Container'Unrestricted_Access.Busy;
262
263   begin
264      if Container.Element = null then
265         raise Constraint_Error with "container is empty";
266      end if;
267
268      B := B + 1;
269
270      begin
271         Process (Container.Element.all);
272      exception
273         when others =>
274            B := B - 1;
275            raise;
276      end;
277
278      B := B - 1;
279   end Update_Element;
280
281   -----------
282   -- Write --
283   -----------
284
285   procedure Write
286     (Stream    : not null access Ada.Streams.Root_Stream_Type'Class;
287      Container : Holder)
288   is
289   begin
290      Boolean'Output (Stream, Container.Element = null);
291
292      if Container.Element /= null then
293         Element_Type'Output (Stream, Container.Element.all);
294      end if;
295   end Write;
296
297end Ada.Containers.Indefinite_Holders;
298