gcc/ada/libgnat/a-stbuun.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                    ADA.STRINGS.TEXT_BUFFERS.UNBOUNDED                    --
   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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Characters.Handling;
  33 with Ada.Unchecked_Deallocation;
  34 with Ada.Strings.UTF_Encoding.Conversions;
  35 with Ada.Strings.UTF_Encoding.Strings;
  36 with Ada.Strings.UTF_Encoding.Wide_Strings;
  37 with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
  38 package body Ada.Strings.Text_Buffers.Unbounded is
  39
  40    function Get (Buffer : in out Buffer_Type) return String is
  41    --  If all characters are 7 bits, we don't need to decode;
  42    --  this is an optimization.
  43    --  Otherwise, if all are 8 bits, we need to decode to get Latin-1.
  44    --  Otherwise, the result is implementation defined, so we return a
  45    --  String encoded as UTF-8. Note that the RM says "if any character
  46    --  in the sequence is not defined in Character, the result is
  47    --  implementation-defined", so we are not obliged to decode ANY
  48    --  Latin-1 characters if ANY character is bigger than 8 bits.
  49    begin
  50       if Buffer.All_8_Bits and not Buffer.All_7_Bits then
  51          return UTF_Encoding.Strings.Decode (Get_UTF_8 (Buffer));
  52       else
  53          return Get_UTF_8 (Buffer);
  54       end if;
  55    end Get;
  56
  57    function Wide_Get (Buffer : in out Buffer_Type) return Wide_String is
  58    begin
  59       return UTF_Encoding.Wide_Strings.Decode (Get_UTF_8 (Buffer));
  60    end Wide_Get;
  61
  62    function Wide_Wide_Get (Buffer : in out Buffer_Type) return Wide_Wide_String
  63    is
  64    begin
  65       return UTF_Encoding.Wide_Wide_Strings.Decode (Get_UTF_8 (Buffer));
  66    end Wide_Wide_Get;
  67
  68    function Get_UTF_8
  69      (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_8_String
  70    is
  71    begin
  72       return Result : UTF_Encoding.UTF_8_String (1 .. Buffer.UTF_8_Length) do
  73          declare
  74             Target_First : Positive := 1;
  75             Ptr : Chunk_Access := Buffer.List.First_Chunk'Unchecked_Access;
  76             Target_Last  : Positive;
  77          begin
  78             while Ptr /= null loop
  79                Target_Last := Target_First + Ptr.Chars'Length - 1;
  80                if Target_Last <= Result'Last then
  81                   --  all of chunk is assigned to Result
  82                   Result (Target_First .. Target_Last) := Ptr.Chars;
  83                   Target_First := Target_First + Ptr.Chars'Length;
  84                else
  85                   --  only part of (last) chunk is assigned to Result
  86                   declare
  87                      Final_Target : UTF_Encoding.UTF_8_String renames
  88                        Result (Target_First .. Result'Last);
  89                   begin
  90                      Final_Target := Ptr.Chars (1 .. Final_Target'Length);
  91                   end;
  92                   pragma Assert (Ptr.Next = null);
  93                   Target_First := Integer'Last;
  94                end if;
  95
  96                Ptr := Ptr.Next;
  97             end loop;
  98          end;
  99
 100          --  Reset buffer to default initial value.
 101          declare
 102             Defaulted : Buffer_Type;
 103
 104             --  If this aggregate becomes illegal due to new field, don't
 105             --  forget to add corresponding assignment statement below.
 106             Dummy : array (1 .. 0) of Buffer_Type :=
 107               [others =>
 108                  (Indentation               => <>,
 109                   Indent_Pending            => <>,
 110                   UTF_8_Length              => <>,
 111                   UTF_8_Column              => <>,
 112                   All_7_Bits                => <>,
 113                   All_8_Bits                => <>,
 114                   Trim_Leading_White_Spaces => <>,
 115                   List                      => <>,
 116                   Last_Used                 => <>)];
 117          begin
 118             Buffer.Indentation    := Defaulted.Indentation;
 119             Buffer.Indent_Pending := Defaulted.Indent_Pending;
 120             Buffer.UTF_8_Length   := Defaulted.UTF_8_Length;
 121             Buffer.UTF_8_Column   := Defaulted.UTF_8_Column;
 122             Buffer.All_7_Bits     := Defaulted.All_7_Bits;
 123             Buffer.All_8_Bits     := Defaulted.All_8_Bits;
 124             Buffer.Last_Used      := Defaulted.Last_Used;
 125             Finalize (Buffer.List); -- free any allocated chunks
 126          end;
 127       end return;
 128    end Get_UTF_8;
 129
 130    function Wide_Get_UTF_16
 131      (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_16_Wide_String
 132    is
 133    begin
 134       return
 135         UTF_Encoding.Conversions.Convert
 136           (Get_UTF_8 (Buffer), Input_Scheme => UTF_Encoding.UTF_8);
 137    end Wide_Get_UTF_16;
 138
 139    procedure Put_UTF_8_Implementation
 140      (Buffer : in out Root_Buffer_Type'Class;
 141       Item   : UTF_Encoding.UTF_8_String)
 142    is
 143       procedure Buffer_Type_Implementation (Buffer : in out Buffer_Type);
 144       --  View the passed-in Buffer parameter as being of type Buffer_Type,
 145       --  not of type Root_Buffer_Type'Class.
 146
 147       procedure Buffer_Type_Implementation (Buffer : in out Buffer_Type) is
 148       begin
 149          for Char of Item loop
 150
 151             --  The Trim_Leading_Space flag, which can be set prior to calling
 152             --  any of the Put operations, which will cause white space
 153             --  characters to be discarded by any Put operation until a
 154             --  non-white-space character is encountered, at which point
 155             --  the flag will be reset.
 156
 157             if not Buffer.Trim_Leading_White_Spaces
 158               or else not Characters.Handling.Is_Space (Char)
 159             then
 160                Buffer.All_7_Bits := @ and then Character'Pos (Char) < 128;
 161                Buffer.Trim_Leading_White_Spaces := False;
 162
 163                if Buffer.Last_Used = Buffer.List.Current_Chunk.Length then
 164                   --  Current chunk is full; allocate a new one with doubled
 165                   --  size
 166
 167                   declare
 168                      Cc     : Chunk renames Buffer.List.Current_Chunk.all;
 169                      Max    : constant Positive := Integer'Last / 2;
 170                      Length : constant Natural  :=
 171                                 Integer'Min (Max, 2 * Cc.Length);
 172                   begin
 173                      pragma Assert (Cc.Next = null);
 174                      Cc.Next                   := new Chunk (Length => Length);
 175                      Buffer.List.Current_Chunk := Cc.Next;
 176                      Buffer.Last_Used          := 0;
 177                   end;
 178                end if;
 179
 180                Buffer.UTF_8_Length                                := @ + 1;
 181                Buffer.UTF_8_Column                                := @ + 1;
 182                Buffer.Last_Used                                   := @ + 1;
 183                Buffer.List.Current_Chunk.Chars (Buffer.Last_Used) := Char;
 184             end if;
 185          end loop;
 186       end Buffer_Type_Implementation;
 187    begin
 188       Buffer_Type_Implementation (Buffer_Type (Buffer));
 189    end Put_UTF_8_Implementation;
 190
 191    procedure Initialize (List : in out Managed_Chunk_List) is
 192    begin
 193       List.Current_Chunk := List.First_Chunk'Unchecked_Access;
 194    end Initialize;
 195
 196    procedure Finalize (List : in out Managed_Chunk_List) is
 197       procedure Free is new Ada.Unchecked_Deallocation (Chunk, Chunk_Access);
 198       Ptr : Chunk_Access := List.First_Chunk.Next;
 199    begin
 200       while Ptr /= null loop
 201          declare
 202             Old_Ptr : Chunk_Access := Ptr;
 203          begin
 204             Ptr := Ptr.Next;
 205             Free (Old_Ptr);
 206          end;
 207       end loop;
 208
 209       List.First_Chunk.Next := null;
 210       Initialize (List);
 211    end Finalize;
 212
 213 end Ada.Strings.Text_Buffers.Unbounded;