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