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