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, 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
;
30 package body Ada
.Containers
.Indefinite_Holders
is
33 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
39 function "=" (Left
, Right
: Holder
) return Boolean is
41 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;
56 overriding
procedure Adjust
(Container
: in out Holder
) is
58 if Container
.Element
/= null then
59 Container
.Element
:= new Element_Type
'(Container.Element.all);
69 procedure Assign (Target : in out Holder; Source : Holder) is
71 if Target.Busy /= 0 then
72 raise Program_Error with "attempt to tamper with elements";
75 if Target.Element /= Source.Element then
76 Free (Target.Element);
78 if Source.Element /= null then
79 Target.Element := new Element_Type'(Source
.Element
.all);
88 procedure Clear
(Container
: in out Holder
) is
90 if Container
.Busy
/= 0 then
91 raise Program_Error
with "attempt to tamper with elements";
94 Free
(Container
.Element
);
101 function Copy
(Source
: Holder
) return Holder
is
103 if Source
.Element
= null then
104 return (AF
.Controlled
with null, 0);
106 return (AF
.Controlled
with new Element_Type
'(Source.Element.all), 0);
114 function Element (Container : Holder) return Element_Type is
116 if Container.Element = null then
117 raise Constraint_Error with "container is empty";
119 return Container.Element.all;
127 overriding procedure Finalize (Container : in out Holder) is
129 if Container.Busy /= 0 then
130 raise Program_Error with "attempt to tamper with elements";
133 Free (Container.Element);
140 function Is_Empty (Container : Holder) return Boolean is
142 return Container.Element = null;
149 procedure Move (Target : in out Holder; Source : in out Holder) is
151 if Target.Busy /= 0 then
152 raise Program_Error with "attempt to tamper with elements";
155 if Source.Busy /= 0 then
156 raise Program_Error with "attempt to tamper with elements";
159 if Target.Element /= Source.Element then
160 Free (Target.Element);
161 Target.Element := Source.Element;
162 Source.Element := null;
170 procedure Query_Element
172 Process : not null access procedure (Element : Element_Type))
174 B : Natural renames Container'Unrestricted_Access.Busy;
177 if Container.Element = null then
178 raise Constraint_Error with "container is empty";
184 Process (Container.Element.all);
199 (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
200 Container : out Holder)
205 if not Boolean'Input (Stream) then
206 Container.Element := new Element_Type'(Element_Type
'Input (Stream
));
210 ---------------------
211 -- Replace_Element --
212 ---------------------
214 procedure Replace_Element
215 (Container
: in out Holder
;
216 New_Item
: Element_Type
)
219 if Container
.Busy
/= 0 then
220 raise Program_Error
with "attempt to tamper with elements";
224 X
: Element_Access
:= Container
.Element
;
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
230 pragma Unsuppress
(Accessibility_Check
);
233 Container
.Element
:= new Element_Type
'(New_Item);
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)
247 pragma Unsuppress (Accessibility_Check);
250 return (AF.Controlled with new Element_Type'(New_Item
), 0);
257 procedure Update_Element
259 Process
: not null access procedure (Element
: in out Element_Type
))
261 B
: Natural renames Container
'Unrestricted_Access.Busy
;
264 if Container
.Element
= null then
265 raise Constraint_Error
with "container is empty";
271 Process
(Container
.Element
.all);
286 (Stream
: not null access Ada
.Streams
.Root_Stream_Type
'Class;
290 Boolean'Output (Stream
, Container
.Element
= null);
292 if Container
.Element
/= null then
293 Element_Type
'Output (Stream
, Container
.Element
.all);
297 end Ada
.Containers
.Indefinite_Holders
;