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