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