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