]>
Commit | Line | Data |
---|---|---|
110d0820 BD |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT RUN-TIME COMPONENTS -- | |
4 | -- -- | |
5 | -- ADA.STRINGS.TEXT_OUTPUT.BUFFERS -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
8d0d46f4 | 9 | -- Copyright (C) 2020-2021, Free Software Foundation, Inc. -- |
110d0820 BD |
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 | ||
110d0820 BD |
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 | ||
26349b6d BD |
38 | type Chunk_Access is access all Chunk; |
39 | ||
110d0820 BD |
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 | ||
26349b6d BD |
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 | ||
110d0820 BD |
58 | procedure Destroy (S : in out Buffer) is |
59 | procedure Free is new Unchecked_Deallocation (Chunk, Chunk_Access); | |
26349b6d | 60 | Cur : Chunk_Access := Chunk_Access (S.Initial_Chunk.Next); |
110d0820 BD |
61 | begin |
62 | while Cur /= null loop | |
63 | declare | |
26349b6d | 64 | Temp : constant Chunk_Access := Chunk_Access (Cur.Next); |
110d0820 BD |
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); | |
26349b6d BD |
78 | S.Cur_Chunk.Next := |
79 | Text_Output.Chunk_Access (Chunk_Access'(new Chunk (S.Chunk_Length))); | |
110d0820 | 80 | S.Cur_Chunk := S.Cur_Chunk.Next; |
76f9c7f4 | 81 | S.Num_Extra_Chunks := S.Num_Extra_Chunks + 1; |
110d0820 BD |
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; |