1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- ADA.STRINGS.TEXT_OUTPUT.UTILS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2020, 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.Strings.UTF_Encoding.Wide_Wide_Strings; 33 34package body Ada.Strings.Text_Output.Utils is 35 36 procedure Put_Octet (S : in out Sink'Class; Item : Character) with Inline; 37 -- Send a single octet to the current Chunk 38 39 procedure Adjust_Column (S : in out Sink'Class) with Inline; 40 -- Adjust the column for a non-NL character. 41 42 procedure Put_UTF_8_Outline (S : in out Sink'Class; Item : UTF_8); 43 -- Out-of-line portion of Put_UTF_8. This exists solely to make Put_UTF_8 44 -- small enough to reasonably inline it. 45 46 procedure Full (S : in out Sink'Class) is 47 begin 48 pragma Assert (S.Last = S.Chunk_Length); 49 Full_Method (S); 50 pragma Assert (S.Last = 0); 51 end Full; 52 53 procedure Flush (S : in out Sink'Class) is 54 begin 55 Flush_Method (S); 56 end Flush; 57 58 procedure Put_Octet (S : in out Sink'Class; Item : Character) is 59 begin 60 S.Last := @ + 1; 61 S.Cur_Chunk.Chars (S.Last) := Item; 62 pragma Assert (S.Chunk_Length = S.Cur_Chunk.Chars'Length); 63 if S.Last = S.Chunk_Length then 64 Full (S); 65 end if; 66 end Put_Octet; 67 68 procedure Adjust_Column (S : in out Sink'Class) is 69 begin 70 -- If we're in the first column, indent. This is handled here, rather 71 -- than when we see NL, because we don't want spaces in a blank line. 72 -- The character we're about to put is not NL; NL is handled in 73 -- New_Line. So after indenting, we simply increment the Column. 74 75 if S.Column = 1 then 76 Tab_To_Column (S, S.Indentation + 1); 77 end if; 78 S.Column := @ + 1; 79 end Adjust_Column; 80 81 procedure Put_7bit (S : in out Sink'Class; Item : Character_7) is 82 begin 83 Adjust_Column (S); 84 Put_Octet (S, Item); 85 end Put_7bit; 86 87 procedure Put_7bit_NL (S : in out Sink'Class; Item : Character_7) is 88 begin 89 if Item = NL then 90 New_Line (S); 91 else 92 Put_7bit (S, Item); 93 end if; 94 end Put_7bit_NL; 95 96 procedure Put_Character (S : in out Sink'Class; Item : Character) is 97 begin 98 if Character'Pos (Item) < 2**7 then 99 Put_7bit_NL (S, Item); 100 else 101 Put_Wide_Wide_Character (S, To_Wide_Wide (Item)); 102 end if; 103 end Put_Character; 104 105 procedure Put_Wide_Character 106 (S : in out Sink'Class; Item : Wide_Character) is 107 begin 108 if Wide_Character'Pos (Item) < 2**7 then 109 Put_7bit_NL (S, From_Wide (Item)); 110 else 111 Put_Wide_Wide_Character (S, To_Wide_Wide (Item)); 112 end if; 113 end Put_Wide_Character; 114 115 procedure Put_Wide_Wide_Character 116 (S : in out Sink'Class; Item : Wide_Wide_Character) is 117 begin 118 if Wide_Wide_Character'Pos (Item) < 2**7 then 119 Put_7bit_NL (S, From_Wide_Wide (Item)); 120 else 121 S.All_7_Bits := False; 122 if Wide_Wide_Character'Pos (Item) >= 2**8 then 123 S.All_8_Bits := False; 124 end if; 125 declare 126 Temp : constant UTF_8_Lines := 127 UTF_Encoding.Wide_Wide_Strings.Encode ((1 => Item)); 128 begin 129 for X of Temp loop 130 pragma Assert (X /= NL); 131 Adjust_Column (S); 132 Put_Octet (S, X); 133 end loop; 134 end; 135 end if; 136 end Put_Wide_Wide_Character; 137 138 procedure Put_UTF_8_Outline (S : in out Sink'Class; Item : UTF_8) is 139 begin 140 if S.Last + Item'Length = S.Chunk_Length then 141 -- Item fits exactly in current chunk 142 143 S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item; 144 S.Last := S.Last + Item'Length; 145 S.Column := S.Column + Item'Length; 146 Full (S); 147 -- ???Seems like maybe we shouldn't call Full until we have MORE 148 -- characters. But then we can't pass Chunk_Length => 1 to 149 -- Create_File to get unbuffered output. 150 else 151 -- We get here only if Item doesn't fit in the current chunk, which 152 -- should be fairly rare. We split Item into Left and Right, where 153 -- Left exactly fills the current chunk, and recurse on Left and 154 -- Right. Right will fit into the next chunk unless it's very long, 155 -- so another level of recursion will be extremely rare. 156 157 declare 158 Left_Length : constant Natural := S.Chunk_Length - S.Last; 159 Right_First : constant Natural := Item'First + Left_Length; 160 Left : UTF_8 renames Item (Item'First .. Right_First - 1); 161 Right : UTF_8 renames Item (Right_First .. Item'Last); 162 pragma Assert (Left & Right = Item); 163 begin 164 Put_UTF_8 (S, Left); -- This will call Full. 165 Put_UTF_8 (S, Right); -- This might call Full, but probably not. 166 end; 167 end if; 168 end Put_UTF_8_Outline; 169 170 procedure Put_UTF_8 (S : in out Sink'Class; Item : UTF_8) is 171 begin 172 Adjust_Column (S); 173 174 if S.Last + Item'Length < S.Chunk_Length then 175 -- Item fits in current chunk 176 177 S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item; 178 S.Last := S.Last + Item'Length; 179 S.Column := S.Column + Item'Length; 180 else 181 Put_UTF_8_Outline (S, Item); 182 end if; 183 end Put_UTF_8; 184 185 procedure Put_UTF_8_Lines (S : in out Sink'Class; Item : UTF_8_Lines) is 186 Line_Start, Index : Integer := Item'First; 187 -- Needs to be Integer, because Item'First might be negative for empty 188 -- Items. 189 begin 190 while Index <= Item'Last loop 191 if Item (Index) = NL then 192 if Index > Line_Start then 193 Put_UTF_8 (S, Item (Line_Start .. Index - 1)); 194 end if; 195 New_Line (S); 196 Line_Start := Index + 1; 197 end if; 198 199 Index := @ + 1; 200 end loop; 201 202 if Index > Line_Start then 203 Put_UTF_8 (S, Item (Line_Start .. Index - 1)); 204 end if; 205 end Put_UTF_8_Lines; 206 207 procedure Put_String (S : in out Sink'Class; Item : String) is 208 begin 209 for X of Item loop 210 Put_Character (S, X); 211 end loop; 212 end Put_String; 213 214 procedure Put_Wide_String (S : in out Sink'Class; Item : Wide_String) is 215 begin 216 for X of Item loop 217 Put_Wide_Character (S, X); 218 end loop; 219 end Put_Wide_String; 220 221 procedure Put_Wide_Wide_String 222 (S : in out Sink'Class; Item : Wide_Wide_String) is 223 begin 224 for X of Item loop 225 Put_Wide_Wide_Character (S, X); 226 end loop; 227 end Put_Wide_Wide_String; 228 229 procedure New_Line (S : in out Sink'Class) is 230 begin 231 S.Column := 1; 232 Put_Octet (S, NL); 233 end New_Line; 234 235 function Column (S : Sink'Class) return Positive is (S.Column); 236 237 procedure Tab_To_Column (S : in out Sink'Class; Column : Positive) is 238 begin 239 if S.Column < Column then 240 for X in 1 .. Column - S.Column loop 241 Put_Octet (S, ' '); 242 end loop; 243 S.Column := Column; 244 end if; 245 end Tab_To_Column; 246 247 procedure Set_Indentation (S : in out Sink'Class; Amount : Natural) is 248 begin 249 S.Indentation := Amount; 250 end Set_Indentation; 251 252 function Indentation (S : Sink'Class) return Natural is (S.Indentation); 253 254 procedure Indent 255 (S : in out Sink'Class; Amount : Optional_Indentation := Default) 256 is 257 By : constant Natural := 258 (if Amount = Default then S.Indent_Amount else Amount); 259 begin 260 Set_Indentation (S, Indentation (S) + By); 261 end Indent; 262 263 procedure Outdent 264 (S : in out Sink'Class; Amount : Optional_Indentation := Default) 265 is 266 By : constant Natural := 267 (if Amount = Default then S.Indent_Amount else Amount); 268 begin 269 Set_Indentation (S, Indentation (S) - By); 270 end Outdent; 271 272end Ada.Strings.Text_Output.Utils; 273