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