diff options
| author | Bob Duff <duff@adacore.com> | 2020-01-28 15:06:41 -0500 |
|---|---|---|
| committer | Pierre-Marie de Rodat <derodat@adacore.com> | 2020-06-04 05:11:15 -0400 |
| commit | 110d0820bfcb421b8c680409cf5c65aa2a0b4b8e (patch) | |
| tree | b7f7f5be5a1a3d29e95cf08be19feded42995b7c /gcc/ada/libgnat | |
| parent | a3fbeceef46546fd47ed370474feed347c86713f (diff) | |
| download | gcc-110d0820bfcb421b8c680409cf5c65aa2a0b4b8e.zip gcc-110d0820bfcb421b8c680409cf5c65aa2a0b4b8e.tar.gz gcc-110d0820bfcb421b8c680409cf5c65aa2a0b4b8e.tar.bz2 | |
[Ada] Put_Image attribute
2020-06-04 Bob Duff <duff@adacore.com>
gcc/ada/
* libgnat/a-stobbu.adb, libgnat/a-stobbu.ads,
libgnat/a-stobfi.adb, libgnat/a-stobfi.ads,
libgnat/a-stoubu.adb, libgnat/a-stoubu.ads,
libgnat/a-stoufi.adb, libgnat/a-stoufi.ads,
libgnat/a-stoufo.adb, libgnat/a-stoufo.ads,
libgnat/a-stouut.adb, libgnat/a-stouut.ads,
libgnat/a-stteou.ads, libgnat/s-putaim.adb,
libgnat/s-putaim.ads, libgnat/s-putima.adb, libgnat/s-putima.ads
(Ada.Strings.Text_Output and children, System.Put_Images): New
runtime support for Put_Image.
* gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add
exp_put_image.o.
* exp_put_image.adb, exp_put_image.ads: New compiler package
that generates calls to runtime routines that implement
Put_Image.
* Makefile.rtl: Add object files for Ada.Strings.Text_Output and
children and System.Put_Images.
* aspects.adb: Simplify initialization of Canonical_Aspect.
* aspects.ads: Improve documentation. Add Aspect_Put_Image.
* exp_attr.adb: Add support for Put_Image, by calling routines
in Exp_Put_Image.
* sem_util.adb (Is_Predefined_Dispatching_Operation): Return
True for new TSS_Put_Image operation.
* exp_ch3.adb: For tagged types, build a dispatching
TSS_Put_Image operation by calling routines in Exp_Put_Image.
* exp_disp.adb, exp_disp.ads: Make TSS_Put_Image be number 10,
adjusting other operations' numbers after 10. We choose 10
because that's the last number shared by all runtimes.
* exp_strm.adb: Use named notation as appropriate.
* exp_cg.adb, exp_tss.ads: Add TSS_Put_Image.
* libgnat/a-tags.ads: Modify Max_Predef_Prims for the new
TSS_Put_Image.
* impunit.adb: Add new runtime packages.
* rtsfind.adb, rtsfind.ads: Add support for
Ada.Strings.Text_Output, Ada.Strings.Text_Output.Utils, and
System.Put_Images.
* sem_attr.adb: Error checking for Put_Image calls.
* sem_ch12.adb (Valid_Default_Attribute): Support for passing
Put_Image as a generic formal parameter.
* sem_ch13.adb: Analysis of Put_Image aspect. Turn it into a
Put_Image attribute definition clause.
* sem_ch8.adb (Analyze_Subprogram_Renaming): Support for
renaming of the Put_Image attribute.
* snames.adb-tmpl: Fix comments.
* snames.ads-tmpl (Name_Put_Image): New Name_Id.
(Attribute_Put_Image): New Attribute_Id.
* tbuild.adb, tbuild.ads (Make_Increment): New utility.
Diffstat (limited to 'gcc/ada/libgnat')
| -rw-r--r-- | gcc/ada/libgnat/a-stobbu.adb | 55 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stobbu.ads | 36 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stobfi.adb | 120 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stobfi.ads | 68 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stoubu.adb | 140 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stoubu.ads | 75 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stoufi.adb | 125 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stoufi.ads | 74 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stoufo.adb | 139 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stoufo.ads | 74 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stouut.adb | 261 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stouut.ads | 108 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stteou.ads | 192 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-tags.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-putaim.adb | 52 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-putaim.ads | 48 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-putima.adb | 220 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-putima.ads | 93 |
18 files changed, 1888 insertions, 7 deletions
diff --git a/gcc/ada/libgnat/a-stobbu.adb b/gcc/ada/libgnat/a-stobbu.adb new file mode 100644 index 0000000..64f2b6d --- /dev/null +++ b/gcc/ada/libgnat/a-stobbu.adb @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BIT_BUCKETS -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +package body Ada.Strings.Text_Output.Bit_Buckets is + + type Bit_Bucket_Type is new Sink with null record; + overriding procedure Full_Method (S : in out Bit_Bucket_Type); + overriding procedure Flush_Method (S : in out Bit_Bucket_Type); + + The_Bit_Bucket : aliased Bit_Bucket_Type + (Chunk_Length => Default_Chunk_Length); + function Bit_Bucket return Sink_Access is (The_Bit_Bucket'Access); + + overriding procedure Full_Method (S : in out Bit_Bucket_Type) + renames Flush_Method; + + overriding procedure Flush_Method (S : in out Bit_Bucket_Type) is + begin + S.Last := 0; + end Flush_Method; + +begin + The_Bit_Bucket.Indent_Amount := 0; + The_Bit_Bucket.Cur_Chunk := The_Bit_Bucket.Initial_Chunk'Access; +end Ada.Strings.Text_Output.Bit_Buckets; diff --git a/gcc/ada/libgnat/a-stobbu.ads b/gcc/ada/libgnat/a-stobbu.ads new file mode 100644 index 0000000..d2b1011 --- /dev/null +++ b/gcc/ada/libgnat/a-stobbu.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BIT_BUCKETS -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +package Ada.Strings.Text_Output.Bit_Buckets is + function Bit_Bucket return Sink_Access; +end Ada.Strings.Text_Output.Bit_Buckets; diff --git a/gcc/ada/libgnat/a-stobfi.adb b/gcc/ada/libgnat/a-stobfi.adb new file mode 100644 index 0000000..91edf3f --- /dev/null +++ b/gcc/ada/libgnat/a-stobfi.adb @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BASIC_FILES -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils; +package body Ada.Strings.Text_Output.Basic_Files is + use type OS.File_Descriptor; + + function Create_From_FD + (FD : OS.File_Descriptor; + Indent_Amount : Natural; + Chunk_Length : Positive) return File; + -- Create a file from an OS file descriptor + + function Create_From_FD + (FD : OS.File_Descriptor; + Indent_Amount : Natural; + Chunk_Length : Positive) return File + is + begin + if FD = OS.Invalid_FD then + raise Program_Error with OS.Errno_Message; + end if; + return Result : File (Chunk_Length) do + Result.Indent_Amount := Indent_Amount; + Result.Cur_Chunk := Result.Initial_Chunk'Unchecked_Access; + Result.FD := FD; + end return; + end Create_From_FD; + + function Create_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File + is + begin + return Create_From_FD + (OS.Create_File (Name, Fmode => OS.Text), + Indent_Amount, Chunk_Length); + end Create_File; + + function Create_New_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File + is + begin + return Create_From_FD + (OS.Create_New_File (Name, Fmode => OS.Text), + Indent_Amount, Chunk_Length); + end Create_New_File; + + procedure Close (S : in out File'Class) is + Status : Boolean; + begin + Flush (S); + + if S.FD not in OS.Standout | OS.Standerr then -- Don't close these + OS.Close (S.FD, Status); + if not Status then + raise Program_Error with OS.Errno_Message; + end if; + end if; + end Close; + + overriding procedure Full_Method (S : in out File) renames Flush_Method; + + overriding procedure Flush_Method (S : in out File) is + pragma Assert (S.Cur_Chunk = S.Initial_Chunk'Unchecked_Access); + Res : constant Integer := + OS.Write (S.FD, S.Cur_Chunk.Chars'Address, S.Last); + begin + if Res /= S.Last then + raise Program_Error with OS.Errno_Message; + end if; + S.Last := 0; + end Flush_Method; + + The_Stdout : aliased File := + Create_From_FD (OS.Standout, + Indent_Amount => Default_Indent_Amount, + Chunk_Length => Default_Chunk_Length); + The_Stderr : aliased File := + Create_From_FD (OS.Standerr, + Indent_Amount => Default_Indent_Amount, + Chunk_Length => Default_Chunk_Length); + + function Standard_Output return Sink_Access is (The_Stdout'Access); + function Standard_Error return Sink_Access is (The_Stderr'Access); + +end Ada.Strings.Text_Output.Basic_Files; diff --git a/gcc/ada/libgnat/a-stobfi.ads b/gcc/ada/libgnat/a-stobfi.ads new file mode 100644 index 0000000..a2892f0 --- /dev/null +++ b/gcc/ada/libgnat/a-stobfi.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BASIC_FILES -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +private with GNAT.OS_Lib; +package Ada.Strings.Text_Output.Basic_Files is + -- Normally, you should use Ada.Strings.Text_Output.Files, which + -- automatically Closes files via finalization. If you don't want to use + -- finalization, use this package instead. You must then Close the file by + -- hand. The semantics is otherwise the same as Files. + + function Standard_Output return Sink_Access; + function Standard_Error return Sink_Access; + + type File (<>) is new Sink with private; + + function Create_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File; + function Create_New_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File; + + procedure Close (S : in out File'Class); + +private + + package OS renames GNAT.OS_Lib; + + type File is new Sink with record + FD : OS.File_Descriptor := OS.Invalid_FD; + end record; + + overriding procedure Full_Method (S : in out File); + overriding procedure Flush_Method (S : in out File); + +end Ada.Strings.Text_Output.Basic_Files; diff --git a/gcc/ada/libgnat/a-stoubu.adb b/gcc/ada/libgnat/a-stoubu.adb new file mode 100644 index 0000000..f563ea5 --- /dev/null +++ b/gcc/ada/libgnat/a-stoubu.adb @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BUFFERS -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +with Unchecked_Deallocation; +with Ada.Strings.UTF_Encoding.Strings; +with Ada.Strings.UTF_Encoding.Wide_Strings; +with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; +package body Ada.Strings.Text_Output.Buffers is + + function New_Buffer + (Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return Buffer + is + begin + return Result : Buffer (Chunk_Length) do + Result.Indent_Amount := Indent_Amount; + Result.Cur_Chunk := Result.Initial_Chunk'Unchecked_Access; + end return; + end New_Buffer; + + procedure Destroy (S : in out Buffer) is + procedure Free is new Unchecked_Deallocation (Chunk, Chunk_Access); + Cur : Chunk_Access := S.Initial_Chunk.Next; + begin + while Cur /= null loop + declare + Temp : constant Chunk_Access := Cur.Next; + begin + Free (Cur); + Cur := Temp; + end; + end loop; + + S.Cur_Chunk := null; + end Destroy; + + overriding procedure Full_Method (S : in out Buffer) is + begin + pragma Assert (S.Cur_Chunk.Next = null); + pragma Assert (S.Last = S.Cur_Chunk.Chars'Length); + S.Cur_Chunk.Next := new Chunk (S.Chunk_Length); + S.Cur_Chunk := S.Cur_Chunk.Next; + S.Num_Extra_Chunks := @ + 1; + S.Last := 0; + end Full_Method; + + function UTF_8_Length (S : Buffer'Class) return Natural is + begin + return S.Num_Extra_Chunks * S.Chunk_Length + S.Last; + end UTF_8_Length; + + procedure Get_UTF_8 + (S : Buffer'Class; Result : out UTF_8_Lines) + is + Cur : access constant Chunk := S.Initial_Chunk'Access; + First : Positive := 1; + begin + loop + if Cur.Next = null then + pragma Assert (Result'Last = First + S.Last - 1); + Result (First .. Result'Last) := Cur.Chars (1 .. S.Last); + exit; + end if; + + pragma Assert (S.Chunk_Length = Cur.Chars'Length); + Result (First .. First + S.Chunk_Length - 1) := Cur.Chars; + First := First + S.Chunk_Length; + Cur := Cur.Next; + end loop; + end Get_UTF_8; + + function Get_UTF_8 (S : Buffer'Class) return UTF_8_Lines is + begin + return Result : String (1 .. UTF_8_Length (S)) do + Get_UTF_8 (S, Result); + end return; + end Get_UTF_8; + + function Get (S : Buffer'Class) return String is + begin + -- If all characters are 7 bits, we don't need to decode; + -- this is an optimization. + + -- Otherwise, if all are 8 bits, we need to decode to get Latin-1. + -- Otherwise, the result is implementation defined, so we return a + -- String encoded as UTF-8. (Note that the AI says "if any character + -- in the sequence is not defined in Character, the result is + -- implementation-defined", so we are not obliged to decode ANY + -- Latin-1 characters if ANY character is bigger than 8 bits. + + if S.All_7_Bits then + return Get_UTF_8 (S); + elsif S.All_8_Bits then + return UTF_Encoding.Strings.Decode (Get_UTF_8 (S)); + else + return Get_UTF_8 (S); + end if; + end Get; + + function Wide_Get (S : Buffer'Class) return Wide_String is + begin + return UTF_Encoding.Wide_Strings.Decode (Get_UTF_8 (S)); + end Wide_Get; + + function Wide_Wide_Get (S : Buffer'Class) return Wide_Wide_String is + begin + return UTF_Encoding.Wide_Wide_Strings.Decode (Get_UTF_8 (S)); + end Wide_Wide_Get; + +end Ada.Strings.Text_Output.Buffers; diff --git a/gcc/ada/libgnat/a-stoubu.ads b/gcc/ada/libgnat/a-stoubu.ads new file mode 100644 index 0000000..519e473 --- /dev/null +++ b/gcc/ada/libgnat/a-stoubu.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BUFFERS -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +package Ada.Strings.Text_Output.Buffers is + + type Buffer (<>) is new Sink with private; + + function New_Buffer + (Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return Buffer; + + procedure Destroy (S : in out Buffer); + -- Reclaim any heap-allocated data, and render the Buffer unusable. + -- It would make sense to do this via finalization, but we wish to + -- avoid controlled types in the generated code for 'Image. + + function Get_UTF_8 (S : Buffer'Class) return UTF_8_Lines; + -- Get the characters in S, encoded as UTF-8. + + function UTF_8_Length (S : Buffer'Class) return Natural; + procedure Get_UTF_8 + (S : Buffer'Class; Result : out UTF_8_Lines) with + Pre => Result'First = 1 and Result'Last = UTF_8_Length (S); + -- This is a procedure version of the Get_UTF_8 function, for + -- efficiency. The Result String must be the exact right length. + + function Get (S : Buffer'Class) return String; + function Wide_Get (S : Buffer'Class) return Wide_String; + function Wide_Wide_Get (S : Buffer'Class) return Wide_Wide_String; + -- Get the characters in S, decoded as [[Wide_]Wide_]String. + -- There is no need for procedure versions of these, because + -- they are intended primarily to implement the [[Wide_]Wide_]Image + -- attribute, which is already a function. + +private + type Chunk_Count is new Natural; + type Buffer is new Sink with record + Num_Extra_Chunks : Natural := 0; + -- Number of chunks in the linked list, not including Initial_Chunk. + end record; + + overriding procedure Full_Method (S : in out Buffer); + overriding procedure Flush_Method (S : in out Buffer) is null; + +end Ada.Strings.Text_Output.Buffers; diff --git a/gcc/ada/libgnat/a-stoufi.adb b/gcc/ada/libgnat/a-stoufi.adb new file mode 100644 index 0000000..90c03da --- /dev/null +++ b/gcc/ada/libgnat/a-stoufi.adb @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.FILES -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils; +package body Ada.Strings.Text_Output.Files is + use type OS.File_Descriptor; + + function Create_From_FD + (FD : OS.File_Descriptor; + Indent_Amount : Natural; + Chunk_Length : Positive) return File; + -- Create a file from an OS file descriptor + + function Create_From_FD + (FD : OS.File_Descriptor; + Indent_Amount : Natural; + Chunk_Length : Positive) return File + is + begin + if FD = OS.Invalid_FD then + raise Program_Error with OS.Errno_Message; + end if; + return Result : File (Chunk_Length) do + Result.Indent_Amount := Indent_Amount; + Result.Cur_Chunk := Result.Initial_Chunk'Unchecked_Access; + Result.FD := FD; + end return; + end Create_From_FD; + + function Create_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File + is + begin + return Create_From_FD + (OS.Create_File (Name, Fmode => OS.Text), + Indent_Amount, Chunk_Length); + end Create_File; + + function Create_New_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File + is + begin + return Create_From_FD + (OS.Create_New_File (Name, Fmode => OS.Text), + Indent_Amount, Chunk_Length); + end Create_New_File; + + overriding procedure Finalize (Ref : in out Self_Ref) is + begin + Close (Ref.Self.all); + end Finalize; + + procedure Close (S : in out File'Class) is + Status : Boolean; + begin + Flush (S); + + if S.FD not in OS.Standout | OS.Standerr then -- Don't close these + OS.Close (S.FD, Status); + if not Status then + raise Program_Error with OS.Errno_Message; + end if; + end if; + end Close; + + overriding procedure Full_Method (S : in out File) renames Flush_Method; + + overriding procedure Flush_Method (S : in out File) is + pragma Assert (S.Cur_Chunk = S.Initial_Chunk'Unchecked_Access); + Res : constant Integer := + OS.Write (S.FD, S.Cur_Chunk.Chars'Address, S.Last); + begin + if Res /= S.Last then + raise Program_Error with OS.Errno_Message; + end if; + S.Last := 0; + end Flush_Method; + + The_Stdout : aliased File := + Create_From_FD (OS.Standout, + Indent_Amount => Default_Indent_Amount, + Chunk_Length => Default_Chunk_Length); + The_Stderr : aliased File := + Create_From_FD (OS.Standerr, + Indent_Amount => Default_Indent_Amount, + Chunk_Length => Default_Chunk_Length); + + function Standard_Output return Sink_Access is (The_Stdout'Access); + function Standard_Error return Sink_Access is (The_Stderr'Access); + +end Ada.Strings.Text_Output.Files; diff --git a/gcc/ada/libgnat/a-stoufi.ads b/gcc/ada/libgnat/a-stoufi.ads new file mode 100644 index 0000000..a94124b --- /dev/null +++ b/gcc/ada/libgnat/a-stoufi.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.FILES -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +private with GNAT.OS_Lib; +private with Ada.Finalization; +package Ada.Strings.Text_Output.Files is + -- This package supports a Sink type that sends output to a file. The file + -- is automatically closed when finalized. + + function Standard_Output return Sink_Access; + function Standard_Error return Sink_Access; + + type File (<>) is new Sink with private; + + function Create_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File; + function Create_New_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File; + -- Create a file. Create_New_File raises an exception if the file already + -- exists; Create_File overwrites. + + procedure Close (S : in out File'Class); + +private + + package OS renames GNAT.OS_Lib; + + type Self_Ref (Self : access File) is new Finalization.Limited_Controlled + with null record; + overriding procedure Finalize (Ref : in out Self_Ref); + + type File is new Sink with record + FD : OS.File_Descriptor := OS.Invalid_FD; + Ref : Self_Ref (File'Access); + end record; + + overriding procedure Full_Method (S : in out File); + overriding procedure Flush_Method (S : in out File); + +end Ada.Strings.Text_Output.Files; diff --git a/gcc/ada/libgnat/a-stoufo.adb b/gcc/ada/libgnat/a-stoufo.adb new file mode 100644 index 0000000..0cbcd56 --- /dev/null +++ b/gcc/ada/libgnat/a-stoufo.adb @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.FORMATTING -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +with Ada.Strings.Text_Output.Files; +with Ada.Strings.Text_Output.Buffers; use Ada.Strings.Text_Output.Buffers; +with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils; +package body Ada.Strings.Text_Output.Formatting is + + procedure Put + (S : in out Sink'Class; T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := "") + is + J : Positive := T'First; + Used : array (1 .. 6) of Boolean := (others => False); + begin + while J <= T'Last loop + if T (J) = '\' then + J := J + 1; + case T (J) is + when 'n' => + New_Line (S); + when '\' => + Put_7bit (S, '\'); + when 'i' => + Indent (S); + when 'o' => + Outdent (S); + when 'I' => + Indent (S, 1); + when 'O' => + Outdent (S, 1); + + when '1' => + Used (1) := True; + Put_UTF_8 (S, X1); + when '2' => + Used (2) := True; + Put_UTF_8 (S, X2); + when '3' => + Used (3) := True; + Put_UTF_8 (S, X3); + when '4' => + Used (4) := True; + Put_UTF_8 (S, X4); + when '5' => + Used (5) := True; + Put_UTF_8 (S, X5); + when '6' => + Used (6) := True; + Put_UTF_8 (S, X6); + + when others => + raise Program_Error; + end case; + else + Put_7bit (S, T (J)); + end if; + + J := J + 1; + end loop; + + if not Used (1) then + pragma Assert (X1 = ""); + end if; + if not Used (2) then + pragma Assert (X2 = ""); + end if; + if not Used (3) then + pragma Assert (X3 = ""); + end if; + if not Used (4) then + pragma Assert (X4 = ""); + end if; + if not Used (5) then + pragma Assert (X5 = ""); + end if; + if not Used (6) then + pragma Assert (X6 = ""); + end if; + + Flush (S); + end Put; + + procedure Put + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := "") is + begin + Put (Files.Standard_Output.all, T, X1, X2, X3, X4, X5, X6); + end Put; + + procedure Err + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := "") is + begin + Put (Files.Standard_Error.all, T, X1, X2, X3, X4, X5, X6); + end Err; + + function Format + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := "") + return UTF_8_Lines + is + Buf : Buffer := New_Buffer; + begin + Put (Buf, T, X1, X2, X3, X4, X5, X6); + return Get_UTF_8 (Buf); + end Format; + +end Ada.Strings.Text_Output.Formatting; diff --git a/gcc/ada/libgnat/a-stoufo.ads b/gcc/ada/libgnat/a-stoufo.ads new file mode 100644 index 0000000..3636ae6 --- /dev/null +++ b/gcc/ada/libgnat/a-stoufo.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.FORMATTING -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +package Ada.Strings.Text_Output.Formatting is + + -- Template-based output, based loosely on C's printf family. Unlike + -- printf, it is type safe. We don't support myriad formatting options; the + -- caller is expected to call 'Image, or other functions that might have + -- various formatting capabilities. + -- + -- Each of the following calls Flush + + type Template is new UTF_8; + procedure Put + (S : in out Sink'Class; T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := ""); + -- Prints the template as is, except for the following escape sequences: + -- "\n" is end of line. + -- "\i" indents by the default amount, and "\o" outdents. + -- "\I" indents by one space, and "\O" outdents. + -- "\1" is replaced with X1, and similarly for 2, 3, .... + -- "\\" is "\". + + -- Note that the template is not type UTF_8, to avoid this sort of thing: + -- + -- https://xkcd.com/327/ + + procedure Put + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := ""); + -- Sends to standard output + + procedure Err + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := ""); + -- Sends to standard error + + function Format + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := "") + return UTF_8_Lines; + -- Returns a UTF-8-encoded String + +end Ada.Strings.Text_Output.Formatting; diff --git a/gcc/ada/libgnat/a-stouut.adb b/gcc/ada/libgnat/a-stouut.adb new file mode 100644 index 0000000..9d5d163 --- /dev/null +++ b/gcc/ada/libgnat/a-stouut.adb @@ -0,0 +1,261 @@ +------------------------------------------------------------------------------ +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +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 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 (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; + elsif 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; + 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; + + 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); + S.Column := 1; + 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; diff --git a/gcc/ada/libgnat/a-stouut.ads b/gcc/ada/libgnat/a-stouut.ads new file mode 100644 index 0000000..c02885e --- /dev/null +++ b/gcc/ada/libgnat/a-stouut.ads @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.UTILS -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +package Ada.Strings.Text_Output.Utils is + + -- This package provides utility functions on Sink'Class. These are + -- intended for use by Put_Image attributes, both the default versions + -- generated by the compiler, and user-defined ones. + + procedure Full (S : in out Sink'Class) with Inline; + -- Must be called when the current chunk is full. Dispatches to + -- Full_Method. + + procedure Flush (S : in out Sink'Class) with Inline; + -- Dispatches to Flush_Method + + -- Full_Method and Flush_Method should be called only via Full and Flush + + procedure Put_Character (S : in out Sink'Class; Item : Character); + procedure Put_Wide_Character (S : in out Sink'Class; Item : Wide_Character); + procedure Put_Wide_Wide_Character + (S : in out Sink'Class; Item : Wide_Wide_Character); + procedure Put_String (S : in out Sink'Class; Item : String); + procedure Put_Wide_String (S : in out Sink'Class; Item : Wide_String); + procedure Put_Wide_Wide_String + (S : in out Sink'Class; Item : Wide_Wide_String); + -- Encode characters or strings as UTF-8, and send them to S. + + subtype Character_7 is + Character range Character'Val (0) .. Character'Val (2**7 - 1); + -- 7-bit character. These are the same in both Latin-1 and UTF-8. + + procedure Put_7bit (S : in out Sink'Class; Item : Character_7) + with Inline, Pre => Item /= NL; + procedure Put_7bit_NL (S : in out Sink'Class; Item : Character_7) + with Inline; + -- Put a 7-bit character, and adjust the Column. For Put_7bit_NL, Item can + -- be NL. + + procedure Put_UTF_8 (S : in out Sink'Class; Item : UTF_8) with Inline; + procedure Put_UTF_8_Lines (S : in out Sink'Class; Item : UTF_8_Lines); + -- Send data that is already UTF-8 encoded (including 7-bit ASCII) to + -- S. These are more efficient than Put_String. + + procedure New_Line (S : in out Sink'Class) with Inline; + -- Puts the new-line character. + + function Column (S : Sink'Class) return Positive with Inline; + -- Current output column. The Column is initially 1, and is incremented for + -- each 7-bit character output, except for the new-line character, which + -- sets Column back to 1. The next character to be output will go in this + -- column. + + procedure Tab_To_Column (S : in out Sink'Class; Column : Positive); + -- Put spaces until we're at or past Column. + + procedure Set_Indentation (S : in out Sink'Class; Amount : Natural) + with Inline; + function Indentation (S : Sink'Class) return Natural with Inline; + -- Indentation is initially 0. Set_Indentation sets it, and Indentation + -- returns it. This number of space characters are put at the start of + -- each nonempty line. + + subtype Optional_Indentation is Integer range -1 .. Natural'Last; + Default : constant Optional_Indentation := -1; + + procedure Indent + (S : in out Sink'Class; Amount : Optional_Indentation := Default) + with Inline; + procedure Outdent + (S : in out Sink'Class; Amount : Optional_Indentation := Default) + with Inline; + -- Increase/decrease Indentation by Amount. If Amount = Default, the amount + -- specified by the Indent_Amount parameter of the sink creation function + -- is used. The sink creation functions are New_Buffer, Create_File, and + -- Create_New_File. + +end Ada.Strings.Text_Output.Utils; diff --git a/gcc/ada/libgnat/a-stteou.ads b/gcc/ada/libgnat/a-stteou.ads new file mode 100644 index 0000000..1240f4a --- /dev/null +++ b/gcc/ada/libgnat/a-stteou.ads @@ -0,0 +1,192 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +with Ada.Strings.UTF_Encoding; +with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; +package Ada.Strings.Text_Output is + + -- This package provides a "Sink" abstraction, to which characters of type + -- Character, Wide_Character, and Wide_Wide_Character can be sent. This + -- type is used by the Put_Image attribute. In particular, T'Put_Image has + -- the following parameter types: + -- + -- procedure T'Put_Image (S : in out Sink'Class; V : T); + -- + -- The default generated code for Put_Image of a composite type will + -- typically call Put_Image on the components. + -- + -- This is not a fully general abstraction that can be arbitrarily + -- extended. It is designed with particular extensions in mind, and these + -- extensions are declared in child packages of this package, because they + -- depend on implementation details in the private part of this + -- package. The primary extensions of Sink are: + -- + -- Buffer. The characters sent to a Buffer are stored in memory, and can + -- be retrieved via Get functions. This is intended for the + -- implementation of the 'Image attribute. The compiler will generate a + -- T'Image function that declares a local Buffer, sends characters to + -- it, and then returns a call to Get, Destroying the Buffer on return. + -- + -- function T'Image (V : T) return String is + -- Buf : Buffer := New_Buffer (...); + -- begin + -- T'Put_Image (Buf, V); + -- return Result : constant String := Get (Buf) do + -- Destroy (Buf); + -- end return; + -- end T'Image; + -- ????Perhaps Buffer should be controlled; if you don't like + -- controlled types, call Put_Image directly. + -- + -- File. The characters are sent to a file, possibly opened by file + -- name, or possibly standard output or standard error. 'Put_Image + -- can be called directly on a File, thus avoiding any heap allocation. + + type Sink (<>) is abstract tagged limited private; + type Sink_Access is access all Sink'Class with Storage_Size => 0; + -- Sink is a character sink; you can send characters to a Sink. + -- UTF-8 encoding is used. + + procedure Full_Method (S : in out Sink) is abstract; + procedure Flush_Method (S : in out Sink) is abstract; + -- There is an internal buffer to store the characters. Full_Method is + -- called when the buffer is full, and Flush_Method may be called to flush + -- the buffer. For Buffer, Full_Method allocates more space for more + -- characters, and Flush_Method does nothing. For File, Full_Method and + -- Flush_Method do the same thing: write the characters to the file, and + -- empty the internal buffer. + -- + -- These are the only dispatching subprograms on Sink. This is for + -- efficiency; we don't dispatch on every write to the Sink, but only when + -- the internal buffer is full (or upon client request). + -- + -- Full_Method and Flush_Method must make the current chunk empty. + -- + -- Additional operations operating on Sink'Class are declared in the Utils + -- child, including Full and Flush, which call the above. + + function To_Wide (C : Character) return Wide_Character is + (Wide_Character'Val (Character'Pos (C))); + function To_Wide_Wide (C : Character) return Wide_Wide_Character is + (Wide_Wide_Character'Val (Character'Pos (C))); + function To_Wide_Wide (C : Wide_Character) return Wide_Wide_Character is + (Wide_Wide_Character'Val (Wide_Character'Pos (C))); + -- Conversions [Wide_]Character --> [Wide_]Wide_Character. + -- These cannot fail. + + function From_Wide (C : Wide_Character) return Character is + (Character'Val (Wide_Character'Pos (C))); + function From_Wide_Wide (C : Wide_Wide_Character) return Character is + (Character'Val (Wide_Wide_Character'Pos (C))); + function From_Wide_Wide (C : Wide_Wide_Character) return Wide_Character is + (Wide_Character'Val (Wide_Wide_Character'Pos (C))); + -- Conversions [Wide_]Wide_Character --> [Wide_]Character. + -- These fail if the character is out of range. + + function NL return Character is (ASCII.LF) with Inline; + function Wide_NL return Wide_Character is (To_Wide (Character'(NL))) + with Inline; + function Wide_Wide_NL return Wide_Wide_Character is + (To_Wide_Wide (Character'(NL))) with Inline; + -- Character representing new line. There is no support for CR/LF line + -- endings. + + -- We have two subtypes of String that are encoded in UTF-8. UTF_8 cannot + -- contain newline characters; UTF_8_Lines can. Sending UTF_8 data to a + -- Sink is more efficient, because end-of-line processing is not needed. + -- Both of these are more efficient than [[Wide_]Wide_]String, because no + -- encoding is needed. + + subtype UTF_8_Lines is UTF_Encoding.UTF_8_String with + Predicate => + UTF_Encoding.Wide_Wide_Strings.Encode + (UTF_Encoding.Wide_Wide_Strings.Decode (UTF_8_Lines)) = UTF_8_Lines; + + subtype UTF_8 is UTF_8_Lines with + Predicate => (for all C of UTF_8 => C /= NL); + + Default_Indent_Amount : constant Natural := 4; + + Default_Chunk_Length : constant Positive := 500; + -- Experiment shows this value to be reasonably efficient; decreasing it + -- slows things down, but increasing it doesn't gain much. + +private + type String_Access is access all String; + + -- For Buffer, the "internal buffer" mentioned above is implemented as a + -- linked list of chunks. When the current chunk is full, we allocate a new + -- one. For File, there is only one chunk. When it is full, we send the + -- data to the file, and empty it. + + type Chunk; + type Chunk_Access is access all Chunk; + type Chunk (Length : Positive) is limited record + Next : Chunk_Access := null; + Chars : UTF_8_Lines (1 .. Length); + end record; + + type Sink (Chunk_Length : Positive) is abstract tagged limited record + Indent_Amount : Natural; + Column : Positive := 1; + Indentation : Natural := 0; + + All_7_Bits : Boolean := True; + -- For optimization of Text_Output.Buffers.Get (cf). + -- True if all characters seen so far fit in 7 bits. + -- 7-bit characters are represented the same in Character + -- and in UTF-8, so they don't need translation. + + All_8_Bits : Boolean := True; + -- True if all characters seen so far fit in 8 bits. + -- This is needed in Text_Output.Buffers.Get to distinguish + -- the case where all characters are Latin-1 (so it should + -- decode) from the case where some characters are bigger than + -- 8 bits (so the result is implementation defined). + + Cur_Chunk : Chunk_Access; + -- Points to the chunk we are currently sending characters to. + -- We want to say: + -- Cur_Chunk : Chunk_Access := Initial_Chunk'Access; + -- but that's illegal, so we have some horsing around to do. + + Last : Natural := 0; + -- Last-used character in Cur_Chunk.all. + + Initial_Chunk : aliased Chunk (Length => Chunk_Length); + -- For Buffer, this is the first chunk. Subsequent chunks are allocated + -- on the heap. For File, this is the only chunk, and there is no heap + -- allocation. + end record; + +end Ada.Strings.Text_Output; diff --git a/gcc/ada/libgnat/a-tags.ads b/gcc/ada/libgnat/a-tags.ads index cb174be..5c83701 100644 --- a/gcc/ada/libgnat/a-tags.ads +++ b/gcc/ada/libgnat/a-tags.ads @@ -588,7 +588,7 @@ private procedure Unregister_Tag (T : Tag); -- Remove a particular tag from the external tag hash table - Max_Predef_Prims : constant Positive := 15; + Max_Predef_Prims : constant Positive := 16; -- Number of reserved slots for the following predefined ada primitives: -- -- 1. Size @@ -600,12 +600,13 @@ private -- 7. assignment -- 8. deep adjust -- 9. deep finalize - -- 10. async select - -- 11. conditional select - -- 12. prim_op kind - -- 13. task_id - -- 14. dispatching requeue - -- 15. timed select + -- 10. Put_Image + -- 11. async select + -- 12. conditional select + -- 13. prim_op kind + -- 14. task_id + -- 15. dispatching requeue + -- 16. timed select -- -- The compiler checks that the value here is correct diff --git a/gcc/ada/libgnat/s-putaim.adb b/gcc/ada/libgnat/s-putaim.adb new file mode 100644 index 0000000..ed8cfe4 --- /dev/null +++ b/gcc/ada/libgnat/s-putaim.adb @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.PUT_TASK_IMAGES -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; +with Unchecked_Conversion; +with Ada.Strings.Text_Output.Utils; +use Ada.Strings.Text_Output; +use Ada.Strings.Text_Output.Utils; + +package body System.Put_Task_Images is + + procedure Put_Image_Protected (S : in out Sink'Class) is + begin + Put_UTF_8 (S, "(protected object)"); + end Put_Image_Protected; + + procedure Put_Image_Task + (S : in out Sink'Class; Id : Ada.Task_Identification.Task_Id) + is + begin + Put_UTF_8 (S, "(task " & Ada.Task_Identification.Image (Id) & ")"); + end Put_Image_Task; + +end System.Put_Task_Images; diff --git a/gcc/ada/libgnat/s-putaim.ads b/gcc/ada/libgnat/s-putaim.ads new file mode 100644 index 0000000..c06b751 --- /dev/null +++ b/gcc/ada/libgnat/s-putaim.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.PUT_TASK_IMAGES -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; +with Ada.Strings.Text_Output; +with Ada.Task_Identification; +package System.Put_Task_Images is + + -- This package contains subprograms that are called by the generated code + -- for the 'Put_Image attribute for protected and task types. This is + -- separate from System.Put_Images to avoid dragging the tasking runtimes + -- into nontasking programs. + + subtype Sink is Ada.Strings.Text_Output.Sink; + + procedure Put_Image_Protected (S : in out Sink'Class); + procedure Put_Image_Task + (S : in out Sink'Class; Id : Ada.Task_Identification.Task_Id); + +end System.Put_Task_Images; diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb new file mode 100644 index 0000000..cad693f --- /dev/null +++ b/gcc/ada/libgnat/s-putima.adb @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.PUT_IMAGES -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; +with Unchecked_Conversion; +with Ada.Strings.Text_Output.Utils; +use Ada.Strings.Text_Output; +use Ada.Strings.Text_Output.Utils; + +package body System.Put_Images is + + generic + type Integer_Type is range <>; + type Unsigned_Type is mod <>; + Base : Unsigned_Type; + package Generic_Integer_Images is + pragma Assert (Integer_Type'Size = Unsigned_Type'Size); + pragma Assert (Base in 2 .. 36); + procedure Put_Image (S : in out Sink'Class; X : Integer_Type); + procedure Put_Image (S : in out Sink'Class; X : Unsigned_Type); + end Generic_Integer_Images; + + package body Generic_Integer_Images is + + A : constant := Character'Pos ('a'); + Z : constant := Character'Pos ('0'); + subtype Digit is Unsigned_Type range 0 .. Base - 1; + function Digit_To_Character (X : Digit) return Character is + (Character'Val (if X < 10 then X + Z else X + A - 10)); + + procedure Put_Digits (S : in out Sink'Class; X : Unsigned_Type); + -- Put just the digits of X, without any leading minus sign or space. + + procedure Put_Digits (S : in out Sink'Class; X : Unsigned_Type) is + begin + if X >= Base then + Put_Digits (S, X / Base); -- recurse + Put_7bit (S, Digit_To_Character (X mod Base)); + else + Put_7bit (S, Digit_To_Character (X)); + end if; + end Put_Digits; + + procedure Put_Image (S : in out Sink'Class; X : Integer_Type) is + begin + -- Put the space or the minus sign, then pass the absolute value to + -- Put_Digits. + + if X >= 0 then + Put_7bit (S, ' '); + Put_Digits (S, Unsigned_Type (X)); + else + Put_7bit (S, '-'); + Put_Digits (S, -Unsigned_Type'Mod (X)); + -- Convert to Unsigned_Type before negating, to avoid overflow + -- on Integer_Type'First. + end if; + end Put_Image; + + procedure Put_Image (S : in out Sink'Class; X : Unsigned_Type) is + begin + Put_7bit (S, ' '); + Put_Digits (S, X); + end Put_Image; + + end Generic_Integer_Images; + + package Small is new Generic_Integer_Images (Integer, Unsigned, Base => 10); + package Large is new Generic_Integer_Images + (Long_Long_Integer, Long_Long_Unsigned, Base => 10); + + procedure Put_Image_Integer (S : in out Sink'Class; X : Integer) + renames Small.Put_Image; + procedure Put_Image_Long_Long_Integer + (S : in out Sink'Class; X : Long_Long_Integer) + renames Large.Put_Image; + + procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned) + renames Small.Put_Image; + procedure Put_Image_Long_Long_Unsigned + (S : in out Sink'Class; X : Long_Long_Unsigned) + renames Large.Put_Image; + + type Signed_Address is range + -2**(Standard'Address_Size - 1) .. 2**(Standard'Address_Size - 1) - 1; + type Unsigned_Address is mod 2**Standard'Address_Size; + package Hex is new Generic_Integer_Images + (Signed_Address, Unsigned_Address, Base => 16); + + generic + type Designated (<>) is private; + type Pointer is access all Designated; + procedure Put_Image_Pointer (S : in out Sink'Class; X : Pointer); + + procedure Put_Image_Pointer (S : in out Sink'Class; X : Pointer) is + function Cast is new Unchecked_Conversion + (System.Address, Unsigned_Address); + begin + if X = null then + Put_UTF_8 (S, "null"); + else + Put_UTF_8 (S, "(access "); + Hex.Put_Image (S, Cast (X.all'Address)); + Put_UTF_8 (S, ")"); + end if; + end Put_Image_Pointer; + + procedure Thin_Instance is new Put_Image_Pointer (Byte, Thin_Pointer); + procedure Put_Image_Thin_Pointer + (S : in out Sink'Class; X : Thin_Pointer) renames Thin_Instance; + procedure Fat_Instance is new Put_Image_Pointer (Byte_String, Fat_Pointer); + procedure Put_Image_Fat_Pointer + (S : in out Sink'Class; X : Fat_Pointer) renames Fat_Instance; + + procedure Put_Image_String (S : in out Sink'Class; X : String) is + begin + -- ????We should double double quotes, and maybe do something nice with + -- control characters. + Put_UTF_8 (S, """"); + Put_String (S, X); + Put_UTF_8 (S, """"); + end Put_Image_String; + + procedure Put_Image_Wide_String (S : in out Sink'Class; X : Wide_String) is + begin + Put_UTF_8 (S, """"); + Put_Wide_String (S, X); + Put_UTF_8 (S, """"); + end Put_Image_Wide_String; + + procedure Put_Image_Wide_Wide_String + (S : in out Sink'Class; X : Wide_Wide_String) is + begin + Put_UTF_8 (S, """"); + Put_Wide_Wide_String (S, X); + Put_UTF_8 (S, """"); + end Put_Image_Wide_Wide_String; + + procedure Array_Before (S : in out Sink'Class) is + begin + New_Line (S); + Put_7bit (S, '['); + Indent (S, 1); + end Array_Before; + + procedure Array_Between (S : in out Sink'Class) is + begin + Put_7bit (S, ','); + New_Line (S); + end Array_Between; + + procedure Array_After (S : in out Sink'Class) is + begin + Outdent (S, 1); + Put_7bit (S, ']'); + end Array_After; + + procedure Simple_Array_Between (S : in out Sink'Class) is + begin + Put_7bit (S, ','); + if Column (S) > 60 then + New_Line (S); + else + Put_7bit (S, ' '); + end if; + end Simple_Array_Between; + + procedure Record_Before (S : in out Sink'Class) is + begin + New_Line (S); + Put_7bit (S, '('); + Indent (S, 1); + end Record_Before; + + procedure Record_Between (S : in out Sink'Class) is + begin + Put_7bit (S, ','); + New_Line (S); + end Record_Between; + + procedure Record_After (S : in out Sink'Class) is + begin + Outdent (S, 1); + Put_7bit (S, ')'); + end Record_After; + + procedure Put_Image_Unknown (S : in out Sink'Class) is + begin + Put_UTF_8 (S, "{unknown image}"); + end Put_Image_Unknown; + +end System.Put_Images; diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads new file mode 100644 index 0000000..0cfe217 --- /dev/null +++ b/gcc/ada/libgnat/s-putima.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.PUT_IMAGES -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; +with Ada.Strings.Text_Output; +with System.Unsigned_Types; +package System.Put_Images is + + -- This package contains subprograms that are called by the generated code + -- for the 'Put_Image attribute. + -- + -- For an integer type that fits in Integer, the actual parameter is + -- converted to Integer, and Put_Image_Integer is called. For larger types, + -- Put_Image_Long_Long_Integer is used. Other numeric types are treated + -- similarly. Access values are unchecked-converted to either Thin_Pointer + -- or Fat_Pointer, and Put_Image_Thin_Pointer or Put_Image_Fat_Pointer is + -- called. The Before/Between/After procedures are called before printing + -- the components of a composite type, between pairs of components, and + -- after them. See Exp_Put_Image in the compiler for details of these + -- calls. + + subtype Sink is Ada.Strings.Text_Output.Sink; + + procedure Put_Image_Integer (S : in out Sink'Class; X : Integer); + procedure Put_Image_Long_Long_Integer + (S : in out Sink'Class; X : Long_Long_Integer); + + subtype Unsigned is System.Unsigned_Types.Unsigned; + subtype Long_Long_Unsigned is System.Unsigned_Types.Long_Long_Unsigned; + + procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned); + procedure Put_Image_Long_Long_Unsigned + (S : in out Sink'Class; X : Long_Long_Unsigned); + + type Byte is new Character with Alignment => 1; + type Byte_String is array (Positive range <>) of Byte with Alignment => 1; + type Thin_Pointer is access all Byte; + type Fat_Pointer is access all Byte_String; + procedure Put_Image_Thin_Pointer (S : in out Sink'Class; X : Thin_Pointer); + procedure Put_Image_Fat_Pointer (S : in out Sink'Class; X : Fat_Pointer); + -- Print "null", or the address of the designated object as an unsigned + -- hexadecimal integer. + + procedure Put_Image_String (S : in out Sink'Class; X : String); + procedure Put_Image_Wide_String (S : in out Sink'Class; X : Wide_String); + procedure Put_Image_Wide_Wide_String + (S : in out Sink'Class; X : Wide_Wide_String); + + procedure Array_Before (S : in out Sink'Class); + procedure Array_Between (S : in out Sink'Class); + procedure Array_After (S : in out Sink'Class); + + procedure Simple_Array_Between (S : in out Sink'Class); + -- For "simple" arrays, where we don't want a newline between every + -- component. + + procedure Record_Before (S : in out Sink'Class); + procedure Record_Between (S : in out Sink'Class); + procedure Record_After (S : in out Sink'Class); + + procedure Put_Image_Unknown (S : in out Sink'Class); + -- For Put_Image of types that don't have the attribute, such as type + -- Sink. Prints a canned string. + +end System.Put_Images; |