gcc/ada/a-coinho-shared.adb

   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
  35 with Ada.Unchecked_Deallocation;
  36
  37 package 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
 542 end Ada.Containers.Indefinite_Holders;