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-2018, 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 28-- Note: special attention must be paid to the case of simultaneous access 29-- to internal shared objects and elements by different tasks. The Reference 30-- counter of internal shared object is the only component protected using 31-- atomic operations; other components and elements can be modified only when 32-- reference counter is equal to one (so there are no other references to this 33-- internal shared object and element). 34 35with Ada.Unchecked_Deallocation; 36 37package body Ada.Containers.Indefinite_Holders is 38 39 procedure Free is 40 new Ada.Unchecked_Deallocation (Element_Type, Element_Access); 41 42 procedure Detach (Container : Holder); 43 -- Detach data from shared copy if necessary. This is necessary to prepare 44 -- container to be modified. 45 46 --------- 47 -- "=" -- 48 --------- 49 50 function "=" (Left, Right : Holder) return Boolean is 51 begin 52 if Left.Reference = Right.Reference then 53 54 -- Covers both null and not null but the same shared object cases 55 56 return True; 57 58 elsif Left.Reference /= null and Right.Reference /= null then 59 return Left.Reference.Element.all = Right.Reference.Element.all; 60 61 else 62 return False; 63 end if; 64 end "="; 65 66 ------------ 67 -- Adjust -- 68 ------------ 69 70 overriding procedure Adjust (Container : in out Holder) is 71 begin 72 if Container.Reference /= null then 73 if Container.Busy = 0 then 74 75 -- Container is not locked, reuse existing internal shared object 76 77 Reference (Container.Reference); 78 else 79 -- Otherwise, create copy of both internal shared object and 80 -- element. 81 82 Container.Reference := 83 new Shared_Holder' 84 (Counter => <>, 85 Element => 86 new Element_Type'(Container.Reference.Element.all)); 87 end if; 88 end if; 89 90 Container.Busy := 0; 91 end Adjust; 92 93 overriding procedure Adjust (Control : in out Reference_Control_Type) is 94 begin 95 if Control.Container /= null then 96 Reference (Control.Container.Reference); 97 Control.Container.Busy := Control.Container.Busy + 1; 98 end if; 99 end Adjust; 100 101 ------------ 102 -- Assign -- 103 ------------ 104 105 procedure Assign (Target : in out Holder; Source : Holder) is 106 begin 107 if Target.Busy /= 0 then 108 raise Program_Error with "attempt to tamper with elements"; 109 end if; 110 111 if Target.Reference /= Source.Reference then 112 if Target.Reference /= null then 113 Unreference (Target.Reference); 114 end if; 115 116 Target.Reference := Source.Reference; 117 118 if Source.Reference /= null then 119 Reference (Target.Reference); 120 end if; 121 end if; 122 end Assign; 123 124 ----------- 125 -- Clear -- 126 ----------- 127 128 procedure Clear (Container : in out Holder) is 129 begin 130 if Container.Busy /= 0 then 131 raise Program_Error with "attempt to tamper with elements"; 132 end if; 133 134 if Container.Reference /= null then 135 Unreference (Container.Reference); 136 Container.Reference := null; 137 end if; 138 end Clear; 139 140 ------------------------ 141 -- Constant_Reference -- 142 ------------------------ 143 144 function Constant_Reference 145 (Container : aliased Holder) return Constant_Reference_Type is 146 begin 147 if Container.Reference = null then 148 raise Constraint_Error with "container is empty"; 149 end if; 150 151 Detach (Container); 152 153 declare 154 Ref : constant Constant_Reference_Type := 155 (Element => Container.Reference.Element.all'Access, 156 Control => (Controlled with Container'Unrestricted_Access)); 157 begin 158 Reference (Ref.Control.Container.Reference); 159 Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; 160 return Ref; 161 end; 162 end Constant_Reference; 163 164 ---------- 165 -- Copy -- 166 ---------- 167 168 function Copy (Source : Holder) return Holder is 169 begin 170 if Source.Reference = null then 171 return (Controlled with null, 0); 172 173 elsif Source.Busy = 0 then 174 175 -- Container is not locked, reuse internal shared object 176 177 Reference (Source.Reference); 178 179 return (Controlled with Source.Reference, 0); 180 181 else 182 -- Otherwise, create copy of both internal shared object and element 183 184 return 185 (Controlled with 186 new Shared_Holder' 187 (Counter => <>, 188 Element => new Element_Type'(Source.Reference.Element.all)), 189 0); 190 end if; 191 end Copy; 192 193 ------------ 194 -- Detach -- 195 ------------ 196 197 procedure Detach (Container : Holder) is 198 begin 199 if Container.Busy = 0 200 and then not System.Atomic_Counters.Is_One 201 (Container.Reference.Counter) 202 then 203 -- Container is not locked and internal shared object is used by 204 -- other container, create copy of both internal shared object and 205 -- element. 206 207 declare 208 Old : constant Shared_Holder_Access := Container.Reference; 209 210 begin 211 Container'Unrestricted_Access.Reference := 212 new Shared_Holder' 213 (Counter => <>, 214 Element => 215 new Element_Type'(Container.Reference.Element.all)); 216 Unreference (Old); 217 end; 218 end if; 219 end Detach; 220 221 ------------- 222 -- Element -- 223 ------------- 224 225 function Element (Container : Holder) return Element_Type is 226 begin 227 if Container.Reference = null then 228 raise Constraint_Error with "container is empty"; 229 else 230 return Container.Reference.Element.all; 231 end if; 232 end Element; 233 234 -------------- 235 -- Finalize -- 236 -------------- 237 238 overriding procedure Finalize (Container : in out Holder) is 239 begin 240 if Container.Busy /= 0 then 241 raise Program_Error with "attempt to tamper with elements"; 242 end if; 243 244 if Container.Reference /= null then 245 Unreference (Container.Reference); 246 Container.Reference := null; 247 end if; 248 end Finalize; 249 250 overriding procedure Finalize (Control : in out Reference_Control_Type) is 251 begin 252 if Control.Container /= null then 253 Unreference (Control.Container.Reference); 254 Control.Container.Busy := Control.Container.Busy - 1; 255 Control.Container := null; 256 end if; 257 end Finalize; 258 259 -------------- 260 -- Is_Empty -- 261 -------------- 262 263 function Is_Empty (Container : Holder) return Boolean is 264 begin 265 return Container.Reference = null; 266 end Is_Empty; 267 268 ---------- 269 -- Move -- 270 ---------- 271 272 procedure Move (Target : in out Holder; Source : in out Holder) is 273 begin 274 if Target.Busy /= 0 then 275 raise Program_Error with "attempt to tamper with elements"; 276 end if; 277 278 if Source.Busy /= 0 then 279 raise Program_Error with "attempt to tamper with elements"; 280 end if; 281 282 if Target.Reference /= Source.Reference then 283 if Target.Reference /= null then 284 Unreference (Target.Reference); 285 end if; 286 287 Target.Reference := Source.Reference; 288 Source.Reference := null; 289 end if; 290 end Move; 291 292 ------------------- 293 -- Query_Element -- 294 ------------------- 295 296 procedure Query_Element 297 (Container : Holder; 298 Process : not null access procedure (Element : Element_Type)) 299 is 300 B : Natural renames Container'Unrestricted_Access.Busy; 301 302 begin 303 if Container.Reference = null then 304 raise Constraint_Error with "container is empty"; 305 end if; 306 307 Detach (Container); 308 309 B := B + 1; 310 311 begin 312 Process (Container.Reference.Element.all); 313 exception 314 when others => 315 B := B - 1; 316 raise; 317 end; 318 319 B := B - 1; 320 end Query_Element; 321 322 ---------- 323 -- Read -- 324 ---------- 325 326 procedure Read 327 (Stream : not null access Ada.Streams.Root_Stream_Type'Class; 328 Container : out Holder) 329 is 330 begin 331 Clear (Container); 332 333 if not Boolean'Input (Stream) then 334 Container.Reference := 335 new Shared_Holder' 336 (Counter => <>, 337 Element => new Element_Type'(Element_Type'Input (Stream))); 338 end if; 339 end Read; 340 341 procedure Read 342 (Stream : not null access Root_Stream_Type'Class; 343 Item : out Constant_Reference_Type) 344 is 345 begin 346 raise Program_Error with "attempt to stream reference"; 347 end Read; 348 349 procedure Read 350 (Stream : not null access Root_Stream_Type'Class; 351 Item : out Reference_Type) 352 is 353 begin 354 raise Program_Error with "attempt to stream reference"; 355 end Read; 356 357 --------------- 358 -- Reference -- 359 --------------- 360 361 procedure Reference (Item : not null Shared_Holder_Access) is 362 begin 363 System.Atomic_Counters.Increment (Item.Counter); 364 end Reference; 365 366 function Reference 367 (Container : aliased in out Holder) return Reference_Type 368 is 369 begin 370 if Container.Reference = null then 371 raise Constraint_Error with "container is empty"; 372 end if; 373 374 Detach (Container); 375 376 declare 377 Ref : constant Reference_Type := 378 (Element => Container.Reference.Element.all'Access, 379 Control => (Controlled with Container'Unrestricted_Access)); 380 begin 381 Reference (Ref.Control.Container.Reference); 382 Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; 383 return Ref; 384 end; 385 end Reference; 386 387 --------------------- 388 -- Replace_Element -- 389 --------------------- 390 391 procedure Replace_Element 392 (Container : in out Holder; 393 New_Item : Element_Type) 394 is 395 -- Element allocator may need an accessibility check in case actual type 396 -- is class-wide or has access discriminants (RM 4.8(10.1) and 397 -- AI12-0035). 398 399 pragma Unsuppress (Accessibility_Check); 400 401 begin 402 if Container.Busy /= 0 then 403 raise Program_Error with "attempt to tamper with elements"; 404 end if; 405 406 if Container.Reference = null then 407 -- Holder is empty, allocate new Shared_Holder. 408 409 Container.Reference := 410 new Shared_Holder' 411 (Counter => <>, 412 Element => new Element_Type'(New_Item)); 413 414 elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then 415 -- Shared_Holder can be reused. 416 417 Free (Container.Reference.Element); 418 Container.Reference.Element := new Element_Type'(New_Item); 419 420 else 421 Unreference (Container.Reference); 422 Container.Reference := 423 new Shared_Holder' 424 (Counter => <>, 425 Element => new Element_Type'(New_Item)); 426 end if; 427 end Replace_Element; 428 429 --------------- 430 -- To_Holder -- 431 --------------- 432 433 function To_Holder (New_Item : Element_Type) return Holder is 434 -- The element allocator may need an accessibility check in the case the 435 -- actual type is class-wide or has access discriminants (RM 4.8(10.1) 436 -- and AI12-0035). 437 438 pragma Unsuppress (Accessibility_Check); 439 440 begin 441 return 442 (Controlled with 443 new Shared_Holder' 444 (Counter => <>, 445 Element => new Element_Type'(New_Item)), 0); 446 end To_Holder; 447 448 ----------------- 449 -- Unreference -- 450 ----------------- 451 452 procedure Unreference (Item : not null Shared_Holder_Access) is 453 454 procedure Free is 455 new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access); 456 457 Aux : Shared_Holder_Access := Item; 458 459 begin 460 if System.Atomic_Counters.Decrement (Aux.Counter) then 461 Free (Aux.Element); 462 Free (Aux); 463 end if; 464 end Unreference; 465 466 -------------------- 467 -- Update_Element -- 468 -------------------- 469 470 procedure Update_Element 471 (Container : in out Holder; 472 Process : not null access procedure (Element : in out Element_Type)) 473 is 474 B : Natural renames Container.Busy; 475 476 begin 477 if Container.Reference = null then 478 raise Constraint_Error with "container is empty"; 479 end if; 480 481 Detach (Container); 482 483 B := B + 1; 484 485 begin 486 Process (Container.Reference.Element.all); 487 exception 488 when others => 489 B := B - 1; 490 raise; 491 end; 492 493 B := B - 1; 494 end Update_Element; 495 496 ----------- 497 -- Write -- 498 ----------- 499 500 procedure Write 501 (Stream : not null access Ada.Streams.Root_Stream_Type'Class; 502 Container : Holder) 503 is 504 begin 505 Boolean'Output (Stream, Container.Reference = null); 506 507 if Container.Reference /= null then 508 Element_Type'Output (Stream, Container.Reference.Element.all); 509 end if; 510 end Write; 511 512 procedure Write 513 (Stream : not null access Root_Stream_Type'Class; 514 Item : Reference_Type) 515 is 516 begin 517 raise Program_Error with "attempt to stream reference"; 518 end Write; 519 520 procedure Write 521 (Stream : not null access Root_Stream_Type'Class; 522 Item : Constant_Reference_Type) 523 is 524 begin 525 raise Program_Error with "attempt to stream reference"; 526 end Write; 527 528end Ada.Containers.Indefinite_Holders; 529