1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
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 --
9 -- Copyright (C) 2012-2023, Free Software Foundation, Inc. --
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. --
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. --
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 ------------------------------------------------------------------------------
28 with Ada
.Unchecked_Deallocation
;
29 with System
.Put_Images
;
31 package body Ada
.Containers
.Indefinite_Holders
is
34 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
40 function "=" (Left
, Right
: Holder
) return Boolean is
42 if Left
.Element
= null and Right
.Element
= null then
44 elsif Left
.Element
/= null and Right
.Element
/= null then
45 return Left
.Element
.all = Right
.Element
.all;
55 overriding
procedure Adjust
(Container
: in out Holder
) is
57 if Container
.Element
/= null then
58 Container
.Element
:= new Element_Type
'(Container.Element.all);
64 overriding procedure Adjust (Control : in out Reference_Control_Type) is
66 if Control.Container /= null then
68 B : Natural renames Control.Container.Busy;
79 procedure Assign (Target : in out Holder; Source : Holder) is
81 if Target.Busy /= 0 then
82 raise Program_Error with "attempt to tamper with elements";
85 if Target.Element /= Source.Element then
86 Free (Target.Element);
88 if Source.Element /= null then
89 Target.Element := new Element_Type'(Source
.Element
.all);
98 procedure Clear
(Container
: in out Holder
) is
100 if Container
.Busy
/= 0 then
101 raise Program_Error
with "attempt to tamper with elements";
104 Free
(Container
.Element
);
107 ------------------------
108 -- Constant_Reference --
109 ------------------------
111 function Constant_Reference
112 (Container
: aliased Holder
) return Constant_Reference_Type
114 Ref
: constant Constant_Reference_Type
:=
115 (Element
=> Container
.Element
.all'Access,
116 Control
=> (Controlled
with Container
'Unrestricted_Access));
117 B
: Natural renames Ref
.Control
.Container
.Busy
;
121 end Constant_Reference
;
127 function Copy
(Source
: Holder
) return Holder
is
129 if Source
.Element
= null then
130 return (Controlled
with null, 0);
132 return (Controlled
with new Element_Type
'(Source.Element.all), 0);
140 function Element (Container : Holder) return Element_Type is
142 if Container.Element = null then
143 raise Constraint_Error with "container is empty";
145 return Container.Element.all;
153 overriding procedure Finalize (Container : in out Holder) is
155 if Container.Busy /= 0 then
156 raise Program_Error with "attempt to tamper with elements";
159 Free (Container.Element);
162 overriding procedure Finalize (Control : in out Reference_Control_Type) is
164 if Control.Container /= null then
166 B : Natural renames Control.Container.Busy;
172 Control.Container := null;
179 function Is_Empty (Container : Holder) return Boolean is
181 return Container.Element = null;
188 procedure Move (Target : in out Holder; Source : in out Holder) is
190 if Target.Busy /= 0 then
191 raise Program_Error with "attempt to tamper with elements";
194 if Source.Busy /= 0 then
195 raise Program_Error with "attempt to tamper with elements";
198 if Target.Element /= Source.Element then
199 Free (Target.Element);
200 Target.Element := Source.Element;
201 Source.Element := null;
209 procedure Query_Element
211 Process : not null access procedure (Element : Element_Type))
213 B : Natural renames Container'Unrestricted_Access.Busy;
216 if Container.Element = null then
217 raise Constraint_Error with "container is empty";
223 Process (Container.Element.all);
238 (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder)
240 use System.Put_Images;
243 if not Is_Empty (V) then
244 Element_Type'Put_Image (S, Element (V));
254 (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
255 Container : out Holder)
260 if not Boolean'Input (Stream) then
261 Container.Element := new Element_Type'(Element_Type
'Input (Stream
));
266 (Stream
: not null access Root_Stream_Type
'Class;
267 Item
: out Constant_Reference_Type
)
270 raise Program_Error
with "attempt to stream reference";
274 (Stream
: not null access Root_Stream_Type
'Class;
275 Item
: out Reference_Type
)
278 raise Program_Error
with "attempt to stream reference";
286 (Container
: aliased in out Holder
) return Reference_Type
288 Ref
: constant Reference_Type
:=
289 (Element
=> Container
.Element
.all'Access,
290 Control
=> (Controlled
with Container
'Unrestricted_Access));
292 Container
.Busy
:= Container
.Busy
+ 1;
296 ---------------------
297 -- Replace_Element --
298 ---------------------
300 procedure Replace_Element
301 (Container
: in out Holder
;
302 New_Item
: Element_Type
)
305 if Container
.Busy
/= 0 then
306 raise Program_Error
with "attempt to tamper with elements";
310 X
: Element_Access
:= Container
.Element
;
312 -- Element allocator may need an accessibility check in case actual
313 -- type is class-wide or has access discriminants (RM 4.8(10.1) and
316 pragma Unsuppress
(Accessibility_Check
);
319 Container
.Element
:= new Element_Type
'(New_Item);
328 procedure Swap (Left, Right : in out Holder) is
330 if Left.Busy /= 0 then
331 raise Program_Error with "attempt to tamper with elements";
334 if Right.Busy /= 0 then
335 raise Program_Error with "attempt to tamper with elements";
338 if Left.Element /= Right.Element then
340 Tmp : constant Element_Access := Left.Element;
342 Left.Element := Right.Element;
343 Right.Element := Tmp;
352 function To_Holder (New_Item : Element_Type) return Holder is
354 -- The element allocator may need an accessibility check in the case the
355 -- actual type is class-wide or has access discriminants (RM 4.8(10.1)
358 pragma Unsuppress (Accessibility_Check);
361 return (Controlled with new Element_Type'(New_Item
), 0);
368 procedure Update_Element
369 (Container
: in out Holder
;
370 Process
: not null access procedure (Element
: in out Element_Type
))
372 B
: Natural renames Container
.Busy
;
375 if Container
.Element
= null then
376 raise Constraint_Error
with "container is empty";
382 Process
(Container
.Element
.all);
397 (Stream
: not null access Ada
.Streams
.Root_Stream_Type
'Class;
401 Boolean'Output (Stream
, Container
.Element
= null);
403 if Container
.Element
/= null then
404 Element_Type
'Output (Stream
, Container
.Element
.all);
409 (Stream
: not null access Root_Stream_Type
'Class;
410 Item
: Reference_Type
)
413 raise Program_Error
with "attempt to stream reference";
417 (Stream
: not null access Root_Stream_Type
'Class;
418 Item
: Constant_Reference_Type
)
421 raise Program_Error
with "attempt to stream reference";
424 end Ada
.Containers
.Indefinite_Holders
;