gcc/ada/libgnat/a-stoubu.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                      ADA.STRINGS.TEXT_OUTPUT.BUFFERS                     --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2020-2021, 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 Unchecked_Deallocation;
  33 with Ada.Strings.UTF_Encoding.Strings;
  34 with Ada.Strings.UTF_Encoding.Wide_Strings;
  35 with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
  36 package body Ada.Strings.Text_Output.Buffers is
  37
  38    type Chunk_Access is access all Chunk;
  39
  40    function New_Buffer
  41      (Indent_Amount : Natural := Default_Indent_Amount;
  42       Chunk_Length : Positive := Default_Chunk_Length) return Buffer
  43    is
  44    begin
  45       return Result : Buffer (Chunk_Length) do
  46          Result.Indent_Amount := Indent_Amount;
  47          Result.Cur_Chunk := Result.Initial_Chunk'Unchecked_Access;
  48       end return;
  49    end New_Buffer;
  50
  51    --  We need type conversions of Chunk_Access values in the following two
  52    --  procedures, because the one in Text_Output has Storage_Size => 0,
  53    --  because Text_Output is Pure. We do not run afoul of 13.11.2(16/3),
  54    --  which requires the allocation and deallocation to have the same pool,
  55    --  because the allocation in Full_Method and the deallocation in Destroy
  56    --  use the same access type, and therefore the same pool.
  57
  58    procedure Destroy (S : in out Buffer) is
  59       procedure Free is new Unchecked_Deallocation (Chunk, Chunk_Access);
  60       Cur : Chunk_Access := Chunk_Access (S.Initial_Chunk.Next);
  61    begin
  62       while Cur /= null loop
  63          declare
  64             Temp : constant Chunk_Access := Chunk_Access (Cur.Next);
  65          begin
  66             Free (Cur);
  67             Cur := Temp;
  68          end;
  69       end loop;
  70
  71       S.Cur_Chunk := null;
  72    end Destroy;
  73
  74    overriding procedure Full_Method (S : in out Buffer) is
  75    begin
  76       pragma Assert (S.Cur_Chunk.Next = null);
  77       pragma Assert (S.Last = S.Cur_Chunk.Chars'Length);
  78       S.Cur_Chunk.Next :=
  79         Text_Output.Chunk_Access (Chunk_Access'(new Chunk (S.Chunk_Length)));
  80       S.Cur_Chunk := S.Cur_Chunk.Next;
  81       S.Num_Extra_Chunks := @ + 1;
  82       S.Last := 0;
  83    end Full_Method;
  84
  85    function UTF_8_Length (S : Buffer'Class) return Natural is
  86    begin
  87       return S.Num_Extra_Chunks * S.Chunk_Length + S.Last;
  88    end UTF_8_Length;
  89
  90    procedure Get_UTF_8
  91      (S : Buffer'Class; Result : out UTF_8_Lines)
  92    is
  93       Cur : access constant Chunk := S.Initial_Chunk'Access;
  94       First : Positive := 1;
  95    begin
  96       loop
  97          if Cur.Next = null then
  98             pragma Assert (Result'Last = First + S.Last - 1);
  99             Result (First .. Result'Last) := Cur.Chars (1 .. S.Last);
 100             exit;
 101          end if;
 102
 103          pragma Assert (S.Chunk_Length = Cur.Chars'Length);
 104          Result (First .. First + S.Chunk_Length - 1) := Cur.Chars;
 105          First := First + S.Chunk_Length;
 106          Cur := Cur.Next;
 107       end loop;
 108    end Get_UTF_8;
 109
 110    function Get_UTF_8 (S : Buffer'Class) return UTF_8_Lines is
 111    begin
 112       return Result : String (1 .. UTF_8_Length (S)) do
 113          Get_UTF_8 (S, Result);
 114       end return;
 115    end Get_UTF_8;
 116
 117    function Get (S : Buffer'Class) return String is
 118    begin
 119       --  If all characters are 7 bits, we don't need to decode;
 120       --  this is an optimization.
 121
 122       --  Otherwise, if all are 8 bits, we need to decode to get Latin-1.
 123       --  Otherwise, the result is implementation defined, so we return a
 124       --  String encoded as UTF-8. (Note that the AI says "if any character
 125       --  in the sequence is not defined in Character, the result is
 126       --  implementation-defined", so we are not obliged to decode ANY
 127       --  Latin-1 characters if ANY character is bigger than 8 bits.
 128
 129       if S.All_7_Bits then
 130          return Get_UTF_8 (S);
 131       elsif S.All_8_Bits then
 132          return UTF_Encoding.Strings.Decode (Get_UTF_8 (S));
 133       else
 134          return Get_UTF_8 (S);
 135       end if;
 136    end Get;
 137
 138    function Wide_Get (S : Buffer'Class) return Wide_String is
 139    begin
 140       return UTF_Encoding.Wide_Strings.Decode (Get_UTF_8 (S));
 141    end Wide_Get;
 142
 143    function Wide_Wide_Get (S : Buffer'Class) return Wide_Wide_String is
 144    begin
 145       return UTF_Encoding.Wide_Wide_Strings.Decode (Get_UTF_8 (S));
 146    end Wide_Wide_Get;
 147
 148 end Ada.Strings.Text_Output.Buffers;