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