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, 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 = null and Right.Reference = null then
  42          return True;
  43
  44       elsif Left.Reference /= null and Right.Reference /= null then
  45          return Left.Reference.Element.all = Right.Reference.Element.all;
  46
  47       else
  48          return False;
  49       end if;
  50    end "=";
  51
  52    ------------
  53    -- Adjust --
  54    ------------
  55
  56    overriding procedure Adjust (Container : in out Holder) is
  57    begin
  58       if Container.Reference /= null then
  59          Reference (Container.Reference);
  60       end if;
  61
  62       Container.Busy := 0;
  63    end Adjust;
  64
  65    ------------
  66    -- Assign --
  67    ------------
  68
  69    procedure Assign (Target : in out Holder; Source : Holder) is
  70    begin
  71       if Target.Busy /= 0 then
  72          raise Program_Error with "attempt to tamper with elements";
  73       end if;
  74
  75       if Target.Reference /= Source.Reference then
  76          if Target.Reference /= null then
  77             Unreference (Target.Reference);
  78          end if;
  79
  80          Target.Reference := Source.Reference;
  81
  82          if Source.Reference /= null then
  83             Reference (Target.Reference);
  84          end if;
  85       end if;
  86    end Assign;
  87
  88    -----------
  89    -- Clear --
  90    -----------
  91
  92    procedure Clear (Container : in out Holder) is
  93    begin
  94       if Container.Busy /= 0 then
  95          raise Program_Error with "attempt to tamper with elements";
  96       end if;
  97
  98       Unreference (Container.Reference);
  99       Container.Reference := null;
 100    end Clear;
 101
 102    ----------
 103    -- Copy --
 104    ----------
 105
 106    function Copy (Source : Holder) return Holder is
 107    begin
 108       if Source.Reference = null then
 109          return (AF.Controlled with null, 0);
 110       else
 111          Reference (Source.Reference);
 112
 113          return (AF.Controlled with Source.Reference, 0);
 114       end if;
 115    end Copy;
 116
 117    -------------
 118    -- Element --
 119    -------------
 120
 121    function Element (Container : Holder) return Element_Type is
 122    begin
 123       if Container.Reference = null then
 124          raise Constraint_Error with "container is empty";
 125       else
 126          return Container.Reference.Element.all;
 127       end if;
 128    end Element;
 129
 130    --------------
 131    -- Finalize --
 132    --------------
 133
 134    overriding procedure Finalize (Container : in out Holder) is
 135    begin
 136       if Container.Busy /= 0 then
 137          raise Program_Error with "attempt to tamper with elements";
 138       end if;
 139
 140       if Container.Reference /= null then
 141          Unreference (Container.Reference);
 142          Container.Reference := null;
 143       end if;
 144    end Finalize;
 145
 146    --------------
 147    -- Is_Empty --
 148    --------------
 149
 150    function Is_Empty (Container : Holder) return Boolean is
 151    begin
 152       return Container.Reference = null;
 153    end Is_Empty;
 154
 155    ----------
 156    -- Move --
 157    ----------
 158
 159    procedure Move (Target : in out Holder; Source : in out Holder) is
 160    begin
 161       if Target.Busy /= 0 then
 162          raise Program_Error with "attempt to tamper with elements";
 163       end if;
 164
 165       if Source.Busy /= 0 then
 166          raise Program_Error with "attempt to tamper with elements";
 167       end if;
 168
 169       if Target.Reference /= Source.Reference then
 170          if Target.Reference /= null then
 171             Unreference (Target.Reference);
 172          end if;
 173
 174          Target.Reference := Source.Reference;
 175          Source.Reference := null;
 176       end if;
 177    end Move;
 178
 179    -------------------
 180    -- Query_Element --
 181    -------------------
 182
 183    procedure Query_Element
 184      (Container : Holder;
 185       Process   : not null access procedure (Element : Element_Type))
 186    is
 187       B : Natural renames Container'Unrestricted_Access.Busy;
 188
 189    begin
 190       if Container.Reference = null then
 191          raise Constraint_Error with "container is empty";
 192       end if;
 193
 194       B := B + 1;
 195
 196       begin
 197          Process (Container.Reference.Element.all);
 198       exception
 199          when others =>
 200             B := B - 1;
 201             raise;
 202       end;
 203
 204       B := B - 1;
 205    end Query_Element;
 206
 207    ----------
 208    -- Read --
 209    ----------
 210
 211    procedure Read
 212      (Stream    : not null access Ada.Streams.Root_Stream_Type'Class;
 213       Container : out Holder)
 214    is
 215    begin
 216       Clear (Container);
 217
 218       if not Boolean'Input (Stream) then
 219          Container.Reference :=
 220             new Shared_Holder'
 221               (Counter => <>,
 222                Element => new Element_Type'(Element_Type'Input (Stream)));
 223       end if;
 224    end Read;
 225
 226    ---------------
 227    -- Reference --
 228    ---------------
 229
 230    procedure Reference (Item : not null Shared_Holder_Access) is
 231    begin
 232       System.Atomic_Counters.Increment (Item.Counter);
 233    end Reference;
 234
 235    ---------------------
 236    -- Replace_Element --
 237    ---------------------
 238
 239    procedure Replace_Element
 240      (Container : in out Holder;
 241       New_Item  : Element_Type)
 242    is
 243       --  Element allocator may need an accessibility check in case actual type
 244       --  is class-wide or has access discriminants (RM 4.8(10.1) and
 245       --  AI12-0035).
 246
 247       pragma Unsuppress (Accessibility_Check);
 248
 249    begin
 250       if Container.Busy /= 0 then
 251          raise Program_Error with "attempt to tamper with elements";
 252       end if;
 253
 254       if Container.Reference = null then
 255          --  Holder is empty, allocate new Shared_Holder.
 256
 257          Container.Reference :=
 258             new Shared_Holder'
 259               (Counter => <>,
 260                Element => new Element_Type'(New_Item));
 261
 262       elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then
 263          --  Shared_Holder can be reused.
 264
 265          Free (Container.Reference.Element);
 266          Container.Reference.Element := new Element_Type'(New_Item);
 267
 268       else
 269          Unreference (Container.Reference);
 270          Container.Reference :=
 271             new Shared_Holder'
 272               (Counter => <>,
 273                Element => new Element_Type'(New_Item));
 274       end if;
 275    end Replace_Element;
 276
 277    ---------------
 278    -- To_Holder --
 279    ---------------
 280
 281    function To_Holder (New_Item : Element_Type) return Holder is
 282       --  The element allocator may need an accessibility check in the case the
 283       --  actual type is class-wide or has access discriminants (RM 4.8(10.1)
 284       --  and AI12-0035).
 285
 286       pragma Unsuppress (Accessibility_Check);
 287
 288    begin
 289       return
 290         (AF.Controlled with
 291             new Shared_Holder'
 292               (Counter => <>,
 293                Element => new Element_Type'(New_Item)), 0);
 294    end To_Holder;
 295
 296    -----------------
 297    -- Unreference --
 298    -----------------
 299
 300    procedure Unreference (Item : not null Shared_Holder_Access) is
 301
 302       procedure Free is
 303         new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access);
 304
 305       Aux : Shared_Holder_Access := Item;
 306
 307    begin
 308       if System.Atomic_Counters.Decrement (Aux.Counter) then
 309          Free (Aux.Element);
 310          Free (Aux);
 311       end if;
 312    end Unreference;
 313
 314    --------------------
 315    -- Update_Element --
 316    --------------------
 317
 318    procedure Update_Element
 319      (Container : Holder;
 320       Process   : not null access procedure (Element : in out Element_Type))
 321    is
 322       B : Natural renames Container'Unrestricted_Access.Busy;
 323
 324    begin
 325       if Container.Reference = null then
 326          raise Constraint_Error with "container is empty";
 327       end if;
 328
 329       B := B + 1;
 330
 331       begin
 332          Process (Container.Reference.Element.all);
 333       exception
 334          when others =>
 335             B := B - 1;
 336             raise;
 337       end;
 338
 339       B := B - 1;
 340    end Update_Element;
 341
 342    -----------
 343    -- Write --
 344    -----------
 345
 346    procedure Write
 347      (Stream    : not null access Ada.Streams.Root_Stream_Type'Class;
 348       Container : Holder)
 349    is
 350    begin
 351       Boolean'Output (Stream, Container.Reference = null);
 352
 353       if Container.Reference /= null then
 354          Element_Type'Output (Stream, Container.Reference.Element.all);
 355       end if;
 356    end Write;
 357
 358 end Ada.Containers.Indefinite_Holders;