File : 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-2015, 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 --                                                                          --
  19 --                                                                          --
  20 --                                                                          --
  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;