------------------------------------------------------------------------------
-- --
-- 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 --
-- <http://www.gnu.org/licenses/>. --
-- --
-- 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;