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