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    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
 540 end Ada.Containers.Indefinite_Holders;