------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- ADA.STRINGS.TEXT_OUTPUT.UTILS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2020, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; package body Ada.Strings.Text_Output.Utils is procedure Put_Octet (S : in out Sink'Class; Item : Character) with Inline; -- Send a single octet to the current Chunk procedure Adjust_Column (S : in out Sink'Class) with Inline; -- Adjust the column for a non-NL character. procedure Put_UTF_8_Outline (S : in out Sink'Class; Item : UTF_8); -- Out-of-line portion of Put_UTF_8. This exists solely to make Put_UTF_8 -- small enough to reasonably inline it. procedure Full (S : in out Sink'Class) is begin pragma Assert (S.Last = S.Chunk_Length); Full_Method (S); pragma Assert (S.Last = 0); end Full; procedure Flush (S : in out Sink'Class) is begin Flush_Method (S); end Flush; procedure Put_Octet (S : in out Sink'Class; Item : Character) is begin S.Last := @ + 1; S.Cur_Chunk.Chars (S.Last) := Item; pragma Assert (S.Chunk_Length = S.Cur_Chunk.Chars'Length); if S.Last = S.Chunk_Length then Full (S); end if; end Put_Octet; procedure Adjust_Column (S : in out Sink'Class) is begin -- If we're in the first column, indent. This is handled here, rather -- than when we see NL, because we don't want spaces in a blank line. -- The character we're about to put is not NL; NL is handled in -- New_Line. So after indenting, we simply increment the Column. if S.Column = 1 then Tab_To_Column (S, S.Indentation + 1); end if; S.Column := @ + 1; end Adjust_Column; procedure Put_7bit (S : in out Sink'Class; Item : Character_7) is begin Adjust_Column (S); Put_Octet (S, Item); end Put_7bit; procedure Put_7bit_NL (S : in out Sink'Class; Item : Character_7) is begin if Item = NL then New_Line (S); else Put_7bit (S, Item); end if; end Put_7bit_NL; procedure Put_Character (S : in out Sink'Class; Item : Character) is begin if Character'Pos (Item) < 2**7 then Put_7bit_NL (S, Item); else Put_Wide_Wide_Character (S, To_Wide_Wide (Item)); end if; end Put_Character; procedure Put_Wide_Character (S : in out Sink'Class; Item : Wide_Character) is begin if Wide_Character'Pos (Item) < 2**7 then Put_7bit_NL (S, From_Wide (Item)); else Put_Wide_Wide_Character (S, To_Wide_Wide (Item)); end if; end Put_Wide_Character; procedure Put_Wide_Wide_Character (S : in out Sink'Class; Item : Wide_Wide_Character) is begin if Wide_Wide_Character'Pos (Item) < 2**7 then Put_7bit_NL (S, From_Wide_Wide (Item)); else S.All_7_Bits := False; if Wide_Wide_Character'Pos (Item) >= 2**8 then S.All_8_Bits := False; end if; declare Temp : constant UTF_8_Lines := UTF_Encoding.Wide_Wide_Strings.Encode ((1 => Item)); begin for X of Temp loop pragma Assert (X /= NL); Adjust_Column (S); Put_Octet (S, X); end loop; end; end if; end Put_Wide_Wide_Character; procedure Put_UTF_8_Outline (S : in out Sink'Class; Item : UTF_8) is begin if S.Last + Item'Length = S.Chunk_Length then -- Item fits exactly in current chunk S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item; S.Last := S.Last + Item'Length; S.Column := S.Column + Item'Length; Full (S); -- ???Seems like maybe we shouldn't call Full until we have MORE -- characters. But then we can't pass Chunk_Length => 1 to -- Create_File to get unbuffered output. else -- We get here only if Item doesn't fit in the current chunk, which -- should be fairly rare. We split Item into Left and Right, where -- Left exactly fills the current chunk, and recurse on Left and -- Right. Right will fit into the next chunk unless it's very long, -- so another level of recursion will be extremely rare. declare Left_Length : constant Natural := S.Chunk_Length - S.Last; Right_First : constant Natural := Item'First + Left_Length; Left : UTF_8 renames Item (Item'First .. Right_First - 1); Right : UTF_8 renames Item (Right_First .. Item'Last); pragma Assert (Left & Right = Item); begin Put_UTF_8 (S, Left); -- This will call Full. Put_UTF_8 (S, Right); -- This might call Full, but probably not. end; end if; end Put_UTF_8_Outline; procedure Put_UTF_8 (S : in out Sink'Class; Item : UTF_8) is begin Adjust_Column (S); if S.Last + Item'Length < S.Chunk_Length then -- Item fits in current chunk S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item; S.Last := S.Last + Item'Length; S.Column := S.Column + Item'Length; else Put_UTF_8_Outline (S, Item); end if; end Put_UTF_8; procedure Put_UTF_8_Lines (S : in out Sink'Class; Item : UTF_8_Lines) is Line_Start, Index : Integer := Item'First; -- Needs to be Integer, because Item'First might be negative for empty -- Items. begin while Index <= Item'Last loop if Item (Index) = NL then if Index > Line_Start then Put_UTF_8 (S, Item (Line_Start .. Index - 1)); end if; New_Line (S); Line_Start := Index + 1; end if; Index := @ + 1; end loop; if Index > Line_Start then Put_UTF_8 (S, Item (Line_Start .. Index - 1)); end if; end Put_UTF_8_Lines; procedure Put_String (S : in out Sink'Class; Item : String) is begin for X of Item loop Put_Character (S, X); end loop; end Put_String; procedure Put_Wide_String (S : in out Sink'Class; Item : Wide_String) is begin for X of Item loop Put_Wide_Character (S, X); end loop; end Put_Wide_String; procedure Put_Wide_Wide_String (S : in out Sink'Class; Item : Wide_Wide_String) is begin for X of Item loop Put_Wide_Wide_Character (S, X); end loop; end Put_Wide_Wide_String; procedure New_Line (S : in out Sink'Class) is begin S.Column := 1; Put_Octet (S, NL); end New_Line; function Column (S : Sink'Class) return Positive is (S.Column); procedure Tab_To_Column (S : in out Sink'Class; Column : Positive) is begin if S.Column < Column then for X in 1 .. Column - S.Column loop Put_Octet (S, ' '); end loop; S.Column := Column; end if; end Tab_To_Column; procedure Set_Indentation (S : in out Sink'Class; Amount : Natural) is begin S.Indentation := Amount; end Set_Indentation; function Indentation (S : Sink'Class) return Natural is (S.Indentation); procedure Indent (S : in out Sink'Class; Amount : Optional_Indentation := Default) is By : constant Natural := (if Amount = Default then S.Indent_Amount else Amount); begin Set_Indentation (S, Indentation (S) + By); end Indent; procedure Outdent (S : in out Sink'Class; Amount : Optional_Indentation := Default) is By : constant Natural := (if Amount = Default then S.Indent_Amount else Amount); begin Set_Indentation (S, Indentation (S) - By); end Outdent; end Ada.Strings.Text_Output.Utils;