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