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