gcc/ada/libgnat/a-ststun.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --         A D A . S T R E A M S . S T O R A G E . U N B O U N D E D        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2020-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
  29 with Ada.Unchecked_Deallocation;
  30
  31 package body Ada.Streams.Storage.Unbounded is
  32
  33    procedure Free is new Ada.Unchecked_Deallocation
  34      (Elements_Type, Elements_Access);
  35
  36    --------------
  37    -- Finalize --
  38    --------------
  39
  40    overriding procedure Finalize (X : in out Controlled_Elements_Access) is
  41    begin
  42       if X.A /= Empty_Elements'Access then
  43          Free (X.A);
  44       end if;
  45    end Finalize;
  46
  47    ----------
  48    -- Read --
  49    ----------
  50
  51    overriding procedure Read
  52      (Stream : in out Stream_Type; Item : out Stream_Element_Array;
  53       Last   :    out Stream_Element_Offset)
  54    is
  55       EA : Stream_Element_Array renames
  56         Stream.Elements.A.EA (1 .. Element_Count (Stream));
  57    begin
  58       if Item'Length = 0 then
  59          Last := Item'First - 1;
  60
  61       --  If the entire content of the stream fits in Item, then copy it and
  62       --  clear the stream. This is likely the usual case.
  63
  64       elsif Element_Count (Stream) <= Item'Length then
  65          Last := Item'First + Element_Count (Stream) - 1;
  66          Item (Item'First .. Last) := EA;
  67          Clear (Stream);
  68
  69       --  Otherwise, copy as much into Item as will fit. Then slide the
  70       --  remaining part of the stream down, and compute the new Count.
  71       --  We expect this to be the unusual case, so the cost of copying
  72       --  the remaining part probably doesn't matter.
  73
  74       else
  75          Last := Item'Last;
  76
  77          declare
  78             New_Count : constant Stream_Element_Count :=
  79               Element_Count (Stream) - Item'Length;
  80          begin
  81             Item := EA (1 .. Item'Length);
  82             EA (1 .. New_Count) :=
  83               EA (Element_Count (Stream) - New_Count + 1 ..
  84                   Element_Count (Stream));
  85             Stream.Count := New_Count;
  86          end;
  87       end if;
  88    end Read;
  89
  90    -----------
  91    -- Write --
  92    -----------
  93
  94    overriding procedure Write
  95      (Stream : in out Stream_Type; Item : Stream_Element_Array)
  96    is
  97       New_Count : constant Stream_Element_Count :=
  98         Element_Count (Stream) + Item'Length;
  99    begin
 100       --  Check whether we need to grow the array. If so, then if the Stream is
 101       --  empty, allocate a goodly amount. Otherwise double the length, for
 102       --  amortized efficiency. In any case, we need to make sure it's at least
 103       --  big enough for New_Count.
 104
 105       if New_Count > Stream.Elements.A.Last then
 106          declare
 107             New_Last : Stream_Element_Index :=
 108               (if Stream.Elements.A.Last = 0 then 2**10 -- goodly amount
 109                else Stream.Elements.A.Last * 2);
 110             Old_Elements : Elements_Access := Stream.Elements.A;
 111          begin
 112             if New_Last < New_Count then
 113                New_Last := New_Count;
 114             end if;
 115
 116             Stream.Elements.A := new Elements_Type (Last => New_Last);
 117
 118             if Old_Elements /= Empty_Elements'Access then
 119                Stream.Elements.A.EA (Old_Elements.EA'Range) := Old_Elements.EA;
 120                Free (Old_Elements);
 121             end if;
 122          end;
 123       end if;
 124
 125       Stream.Elements.A.EA (Element_Count (Stream) + 1 .. New_Count) := Item;
 126       Stream.Count := New_Count;
 127    end Write;
 128
 129    -------------------
 130    -- Element_Count --
 131    -------------------
 132
 133    overriding function Element_Count
 134      (Stream : Stream_Type) return Stream_Element_Count
 135    is
 136    begin
 137       return Stream.Count;
 138    end Element_Count;
 139
 140    -----------
 141    -- Clear --
 142    -----------
 143
 144    overriding procedure Clear (Stream : in out Stream_Type) is
 145    begin
 146       Stream.Count := 0;
 147       --  We don't free Stream.Elements here, because we want to reuse it if
 148       --  there are more Write calls.
 149    end Clear;
 150
 151 end Ada.Streams.Storage.Unbounded;