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-2016, 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    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
 528 end Ada.Containers.Indefinite_Holders;