a-llitio$(objext) \
a-lliwti$(objext) \
a-llizti$(objext) \
+ a-llltio$(objext) \
+ a-lllwti$(objext) \
+ a-lllzti$(objext) \
a-locale$(objext) \
a-nbnbin$(objext) \
a-nbnbre$(objext) \
a-tigeau$(objext) \
a-tiinau$(objext) \
a-tiinio$(objext) \
- a-timoau$(objext) \
a-timoio$(objext) \
a-tiocst$(objext) \
a-tirsfi$(objext) \
a-wtgeau$(objext) \
a-wtinau$(objext) \
a-wtinio$(objext) \
- a-wtmoau$(objext) \
a-wtmoio$(objext) \
a-wttest$(objext) \
a-wwboio$(objext) \
a-ztgeau$(objext) \
a-ztinau$(objext) \
a-ztinio$(objext) \
- a-ztmoau$(objext) \
a-ztmoio$(objext) \
a-zttest$(objext) \
a-zzboio$(objext) \
TRASYM_DWARF_MINGW_OBJS = $(TRASYM_DWARF_COMMON_OBJS)
GNATRTL_128BIT_PAIRS = \
+ a-tiinio.adb<libgnat/a-tiinio__128.adb \
+ a-timoio.adb<libgnat/a-timoio__128.adb \
+ a-wtinio.adb<libgnat/a-wtinio__128.adb \
+ a-wtmoio.adb<libgnat/a-wtmoio__128.adb \
+ a-ztinio.adb<libgnat/a-ztinio__128.adb \
+ a-ztmoio.adb<libgnat/a-ztmoio__128.adb \
s-scaval.ads<libgnat/s-scaval__128.ads \
s-scaval.adb<libgnat/s-scaval__128.adb
("a-llfwti", T), -- Ada.Long_Long_Float_Wide_Text_IO
("a-llitio", T), -- Ada.Long_Long_Integer_Text_IO
("a-lliwti", F), -- Ada.Long_Long_Integer_Wide_Text_IO
+ ("a-llltio", T), -- Ada.Long_Long_Long_Integer_Text_IO
+ ("a-lllwti", F), -- Ada.Long_Long_Long_Integer_Wide_Text_IO
("a-nlcefu", F), -- Ada.Long_Complex_Elementary_Functions
("a-nlcoty", T), -- Ada.Numerics.Long_Complex_Types
("a-nlelfu", T), -- Ada.Numerics.Long_Elementary_Functions
("a-llctio", T), -- Ada.Long_Long_Complex_Text_IO
("a-llfzti", T), -- Ada.Long_Long_Float_Wide_Wide_Text_IO
("a-llizti", T), -- Ada.Long_Long_Integer_Wide_Wide_Text_IO
+ ("a-lllzti", T), -- Ada.Long_Long_Long_Integer_Wide_Wide_Text_IO
("a-nlcoar", T), -- Ada.Numerics.Long_Complex_Arrays
("a-nllcar", T), -- Ada.Numerics.Long_Long_Complex_Arrays
("a-nllrar", T), -- Ada.Numerics.Long_Long_Real_Arrays
Curlen := Len - 17;
Krlen := 8;
+ elsif Len >= 27
+ and then Buffer (1 .. 27) = "ada-long_long_long_integer_"
+ then
+ Startloc := 3;
+ Buffer (2 .. Len - 2) := Buffer (4 .. Len);
+ Buffer (18 .. Len - 10) := Buffer (26 .. Len - 2);
+ Curlen := Len - 10;
+ Krlen := 8;
+
elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then
Startloc := 3;
Buffer (2 .. Len - 2) := Buffer (4 .. Len);
-- we replace the prefix ada.wide_wide_text_io- by a-zt- and then
-- the normal crunching rules are applied.
+-- An additional trick is used for Ada.Long_Long_Long_Integer_*_IO, where
+-- the Integer word is dropped.
+
-- The units implementing the support of 128-bit types are crunched to 9 and
-- System.Compare_Array_* is replaced with System.CA_* before crunching.
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . L O N G _ L O N G _ L O N G _ I N T E G E R _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Text_IO;
+
+package Ada.Long_Long_Long_Integer_Text_IO is
+ new Ada.Text_IO.Integer_IO (Long_Long_Long_Integer);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Text_IO;
+
+package Ada.Long_Long_Long_Integer_Wide_Text_IO is
+ new Ada.Wide_Text_IO.Integer_IO (Long_Long_Long_Integer);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO;
+
+package Ada.Long_Long_Long_Integer_Wide_Wide_Text_IO is
+ new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Long_Long_Integer);
Load_Extended_Digits (File, Buf, Ptr, Junk);
end Load_Extended_Digits;
+ ------------------
+ -- Load_Integer --
+ ------------------
+
+ procedure Load_Integer
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Hash_Loc : Natural;
+ Loaded : Boolean;
+
+ begin
+ Load_Skip (File);
+
+ -- Note: it is a bit strange to allow a minus sign here, but it seems
+ -- consistent with the general behavior expected by the ACVC tests
+ -- which is to scan past junk and then signal data error, see ACVC
+ -- test CE3704F, case (6), which is for signed integer exponents,
+ -- which seems a similar case.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ if Loaded then
+
+ -- Deal with based literal. We recognize either the standard '#' or
+ -- the allowed alternative replacement ':' (see RM J.2(3)).
+
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+ Hash_Loc := Ptr;
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, Buf (Hash_Loc));
+ end if;
+
+ -- Deal with exponent
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+
+ -- Note: it is strange to allow a minus sign, since the syntax
+ -- does not, but that is what ACVC test CE3704F, case (6) wants
+ -- for the signed case, and there seems no good reason to treat
+ -- exponents differently for the signed and unsigned cases.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end Load_Integer;
+
---------------
-- Load_Skip --
---------------
Ptr : in out Integer);
-- Same as above, but no indication if character is loaded
+ procedure Load_Integer
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- Loads a possibly signed integer literal value
+
function Nextc (File : File_Type) return Integer;
-- Like Getc, but includes a call to Ungetc, so that the file
-- pointer is not moved by the call.
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- A D A . T E X T _ I O . I N T E G E R _ A U X --
+-- A D A . T E X T _ I O . I N T E G E R _ A U X --
-- --
-- B o d y --
-- --
with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
-with System.Img_BIU; use System.Img_BIU;
-with System.Img_Int; use System.Img_Int;
-with System.Img_LLB; use System.Img_LLB;
-with System.Img_LLI; use System.Img_LLI;
-with System.Img_LLW; use System.Img_LLW;
-with System.Img_WIU; use System.Img_WIU;
-with System.Val_Int; use System.Val_Int;
-with System.Val_LLI; use System.Val_LLI;
-
package body Ada.Text_IO.Integer_Aux is
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Load_Integer
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural);
- -- This is an auxiliary routine that is used to load a possibly signed
- -- integer literal value from the input file into Buf, starting at Ptr + 1.
- -- On return, Ptr is set to the last character stored.
-
- -------------
- -- Get_Int --
- -------------
-
- procedure Get_Int
- (File : File_Type;
- Item : out Integer;
- Width : Field)
- is
- Buf : String (1 .. Field'Last);
- Ptr : aliased Integer := 1;
- Stop : Integer := 0;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Integer (File, Buf, Stop);
- end if;
-
- Item := Scan_Integer (Buf, Ptr'Access, Stop);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_Int;
+ ---------
+ -- Get --
+ ---------
- -------------
- -- Get_LLI --
- -------------
-
- procedure Get_LLI
+ procedure Get
(File : File_Type;
- Item : out Long_Long_Integer;
+ Item : out Num;
Width : Field)
is
Buf : String (1 .. Field'Last);
Load_Integer (File, Buf, Stop);
end if;
- Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop);
+ Item := Scan (Buf, Ptr'Access, Stop);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_LLI;
+ end Get;
- --------------
- -- Gets_Int --
- --------------
+ ----------
+ -- Gets --
+ ----------
- procedure Gets_Int
+ procedure Gets
(From : String;
- Item : out Integer;
+ Item : out Num;
Last : out Positive)
is
Pos : aliased Integer;
begin
String_Skip (From, Pos);
- Item := Scan_Integer (From, Pos'Access, From'Last);
+ Item := Scan (From, Pos'Access, From'Last);
Last := Pos - 1;
exception
when Constraint_Error =>
raise Data_Error;
- end Gets_Int;
-
- --------------
- -- Gets_LLI --
- --------------
-
- procedure Gets_LLI
- (From : String;
- Item : out Long_Long_Integer;
- Last : out Positive)
- is
- Pos : aliased Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last);
- Last := Pos - 1;
-
- exception
- when Constraint_Error =>
- raise Data_Error;
- end Gets_LLI;
-
- ------------------
- -- Load_Integer --
- ------------------
-
- procedure Load_Integer
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural)
- is
- Hash_Loc : Natural;
- Loaded : Boolean;
-
- begin
- Load_Skip (File);
- Load (File, Buf, Ptr, '+', '-');
-
- Load_Digits (File, Buf, Ptr, Loaded);
-
- if Loaded then
-
- -- Deal with based literal. We recognize either the standard '#' or
- -- the allowed alternative replacement ':' (see RM J.2(3)).
+ end Gets;
- Load (File, Buf, Ptr, '#', ':', Loaded);
+ ---------
+ -- Put --
+ ---------
- if Loaded then
- Hash_Loc := Ptr;
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, Buf (Hash_Loc));
- end if;
-
- -- Deal with exponent
-
- Load (File, Buf, Ptr, 'E', 'e', Loaded);
-
- if Loaded then
-
- -- Note: it is strange to allow a minus sign, since the syntax
- -- does not, but that is what ACVC test CE3704F, case (6) wants.
-
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr);
- end if;
- end if;
- end Load_Integer;
-
- -------------
- -- Put_Int --
- -------------
-
- procedure Put_Int
- (File : File_Type;
- Item : Integer;
- Width : Field;
- Base : Number_Base)
- is
- Buf : String (1 .. Integer'Max (Field'Last, Width));
- Ptr : Natural := 0;
-
- begin
- if Base = 10 and then Width = 0 then
- Set_Image_Integer (Item, Buf, Ptr);
- elsif Base = 10 then
- Set_Image_Width_Integer (Item, Width, Buf, Ptr);
- else
- Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr);
- end if;
-
- Put_Item (File, Buf (1 .. Ptr));
- end Put_Int;
-
- -------------
- -- Put_LLI --
- -------------
-
- procedure Put_LLI
+ procedure Put
(File : File_Type;
- Item : Long_Long_Integer;
+ Item : Num;
Width : Field;
Base : Number_Base)
is
begin
if Base = 10 and then Width = 0 then
- Set_Image_Long_Long_Integer (Item, Buf, Ptr);
+ Set_Image (Item, Buf, Ptr);
elsif Base = 10 then
- Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr);
+ Set_Image_Width (Item, Width, Buf, Ptr);
else
- Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr);
+ Set_Image_Based (Item, Base, Width, Buf, Ptr);
end if;
Put_Item (File, Buf (1 .. Ptr));
- end Put_LLI;
-
- --------------
- -- Puts_Int --
- --------------
-
- procedure Puts_Int
- (To : out String;
- Item : Integer;
- Base : Number_Base)
- is
- Buf : String (1 .. Integer'Max (Field'Last, To'Length));
- Ptr : Natural := 0;
-
- begin
- if Base = 10 then
- Set_Image_Width_Integer (Item, To'Length, Buf, Ptr);
- else
- Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr);
- end if;
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
- end if;
- end Puts_Int;
+ end Put;
- --------------
- -- Puts_LLI --
- --------------
+ ----------
+ -- Puts --
+ ----------
- procedure Puts_LLI
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Num;
Base : Number_Base)
is
Buf : String (1 .. Integer'Max (Field'Last, To'Length));
begin
if Base = 10 then
- Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr);
+ Set_Image_Width (Item, To'Length, Buf, Ptr);
else
- Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr);
+ Set_Image_Based (Item, Base, To'Length, Buf, Ptr);
end if;
if Ptr > To'Length then
else
To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
end if;
- end Puts_LLI;
+ end Puts;
end Ada.Text_IO.Integer_Aux;
-- --
------------------------------------------------------------------------------
--- This package contains the routines for Ada.Text_IO.Integer_IO that are
--- shared among separate instantiations of this package. The routines in
--- this package are identical semantically to those in Integer_IO itself,
--- except that the generic parameter Num has been replaced by Integer or
--- Long_Long_Integer, and the default parameters have been removed because
--- they are supplied explicitly by the calls from within the generic template.
+-- This package contains the implementation for Ada.Text_IO.Integer_IO and
+-- Ada.Text_IO.Modular_IO. The routines in this package are identical
+-- semantically to those in Integer_IO and Modular_IO themselves, except that
+-- the default parameters have been removed because they are supplied
+-- explicitly by the calls from within these units.
-private package Ada.Text_IO.Integer_Aux is
+private generic
+ type Num is (<>);
- procedure Get_Int
- (File : File_Type;
- Item : out Integer;
- Width : Field);
+ with function Scan
+ (Str : String; Ptr : not null access Integer; Max : Integer) return Num;
+ with procedure Set_Image
+ (V : Num; S : in out String; P : in out Natural);
+ with procedure Set_Image_Width
+ (V : Num; W : Integer; S : out String; P : in out Natural);
+ with procedure Set_Image_Based
+ (V : Num; B : Natural; W : Integer; S : out String; P : in out Natural);
+
+package Ada.Text_IO.Integer_Aux is
- procedure Get_LLI
+ procedure Get
(File : File_Type;
- Item : out Long_Long_Integer;
+ Item : out Num;
Width : Field);
- procedure Put_Int
- (File : File_Type;
- Item : Integer;
- Width : Field;
- Base : Number_Base);
+ procedure Gets
+ (From : String;
+ Item : out Num;
+ Last : out Positive);
- procedure Put_LLI
+ procedure Put
(File : File_Type;
- Item : Long_Long_Integer;
+ Item : Num;
Width : Field;
Base : Number_Base);
- procedure Gets_Int
- (From : String;
- Item : out Integer;
- Last : out Positive);
-
- procedure Gets_LLI
- (From : String;
- Item : out Long_Long_Integer;
- Last : out Positive);
-
- procedure Puts_Int
- (To : out String;
- Item : Integer;
- Base : Number_Base);
-
- procedure Puts_LLI
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Num;
Base : Number_Base);
end Ada.Text_IO.Integer_Aux;
------------------------------------------------------------------------------
with Ada.Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Int; use System.Img_Int;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLI; use System.Img_LLI;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Int; use System.Val_Int;
+with System.Val_LLI; use System.Val_LLI;
package body Ada.Text_IO.Integer_IO is
- package Aux renames Ada.Text_IO.Integer_Aux;
+ package Aux_Int is new
+ Ada.Text_IO.Integer_Aux
+ (Integer,
+ Scan_Integer,
+ Set_Image_Integer,
+ Set_Image_Width_Integer,
+ Set_Image_Based_Integer);
+
+ package Aux_LLI is new
+ Ada.Text_IO.Integer_Aux
+ (Long_Long_Integer,
+ Scan_Long_Long_Integer,
+ Set_Image_Long_Long_Integer,
+ Set_Image_Width_Long_Long_Integer,
+ Set_Image_Based_Long_Long_Integer);
Need_LLI : constant Boolean := Num'Base'Size > Integer'Size;
-- Throughout this generic body, we distinguish between the case where type
begin
if Need_LLI then
- Aux.Get_LLI (File, Long_Long_Integer (Item), Width);
+ Aux_LLI.Get (File, Long_Long_Integer (Item), Width);
else
- Aux.Get_Int (File, Integer (Item), Width);
+ Aux_Int.Get (File, Integer (Item), Width);
end if;
exception
(Item : out Num;
Width : Field := 0)
is
- -- We depend on a range check to get Data_Error
-
- pragma Unsuppress (Range_Check);
- pragma Unsuppress (Overflow_Check);
-
begin
- if Need_LLI then
- Aux.Get_LLI (Current_In, Long_Long_Integer (Item), Width);
- else
- Aux.Get_Int (Current_In, Integer (Item), Width);
- end if;
-
- exception
- when Constraint_Error => raise Data_Error;
+ Get (Current_In, Item, Width);
end Get;
procedure Get
begin
if Need_LLI then
- Aux.Gets_LLI (From, Long_Long_Integer (Item), Last);
+ Aux_LLI.Gets (From, Long_Long_Integer (Item), Last);
else
- Aux.Gets_Int (From, Integer (Item), Last);
+ Aux_Int.Gets (From, Integer (Item), Last);
end if;
exception
is
begin
if Need_LLI then
- Aux.Put_LLI (File, Long_Long_Integer (Item), Width, Base);
+ Aux_LLI.Put (File, Long_Long_Integer (Item), Width, Base);
else
- Aux.Put_Int (File, Integer (Item), Width, Base);
+ Aux_Int.Put (File, Integer (Item), Width, Base);
end if;
end Put;
Base : Number_Base := Default_Base)
is
begin
- if Need_LLI then
- Aux.Put_LLI (Current_Out, Long_Long_Integer (Item), Width, Base);
- else
- Aux.Put_Int (Current_Out, Integer (Item), Width, Base);
- end if;
+ Put (Current_Out, Item, Width, Base);
end Put;
procedure Put
is
begin
if Need_LLI then
- Aux.Puts_LLI (To, Long_Long_Integer (Item), Base);
+ Aux_LLI.Puts (To, Long_Long_Integer (Item), Base);
else
- Aux.Puts_Int (To, Integer (Item), Base);
+ Aux_Int.Puts (To, Integer (Item), Base);
end if;
end Put;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . I N T E G E R _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-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.Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Int; use System.Img_Int;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLI; use System.Img_LLI;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_LLLB; use System.Img_LLLB;
+with System.Img_LLLI; use System.Img_LLLI;
+with System.Img_LLLW; use System.Img_LLLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Int; use System.Val_Int;
+with System.Val_LLI; use System.Val_LLI;
+with System.Val_LLLI; use System.Val_LLLI;
+
+package body Ada.Text_IO.Integer_IO is
+
+ package Aux_Int is new
+ Ada.Text_IO.Integer_Aux
+ (Integer,
+ Scan_Integer,
+ Set_Image_Integer,
+ Set_Image_Width_Integer,
+ Set_Image_Based_Integer);
+
+ package Aux_LLI is new
+ Ada.Text_IO.Integer_Aux
+ (Long_Long_Integer,
+ Scan_Long_Long_Integer,
+ Set_Image_Long_Long_Integer,
+ Set_Image_Width_Long_Long_Integer,
+ Set_Image_Based_Long_Long_Integer);
+
+ package Aux_LLLI is new
+ Ada.Text_IO.Integer_Aux
+ (Long_Long_Long_Integer,
+ Scan_Long_Long_Long_Integer,
+ Set_Image_Long_Long_Long_Integer,
+ Set_Image_Width_Long_Long_Long_Integer,
+ Set_Image_Based_Long_Long_Long_Integer);
+
+ Need_LLI : constant Boolean := Num'Base'Size > Integer'Size;
+ Need_LLLI : constant Boolean := Num'Base'Size > Long_Long_Integer'Size;
+ -- Throughout this generic body, we distinguish between cases where type
+ -- Integer is acceptable, where type Long_Long_Integer is acceptable and
+ -- where type Long_Long_Long_Integer is needed. These boolean constants
+ -- are used to test for these cases and since they are constant, only code
+ -- for the relevant case will be included in the instance.
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Get (File, Long_Long_Long_Integer (Item), Width);
+ elsif Need_LLI then
+ Aux_LLI.Get (File, Long_Long_Integer (Item), Width);
+ else
+ Aux_Int.Get (File, Integer (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_In, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Gets (From, Long_Long_Long_Integer (Item), Last);
+ elsif Need_LLI then
+ Aux_LLI.Gets (From, Long_Long_Integer (Item), Last);
+ else
+ Aux_Int.Gets (From, Integer (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Put (File, Long_Long_Long_Integer (Item), Width, Base);
+ elsif Need_LLI then
+ Aux_LLI.Put (File, Long_Long_Integer (Item), Width, Base);
+ else
+ Aux_Int.Put (File, Integer (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ Put (Current_Out, Item, Width, Base);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : Num;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Puts (To, Long_Long_Long_Integer (Item), Base);
+ elsif Need_LLI then
+ Aux_LLI.Puts (To, Long_Long_Integer (Item), Base);
+ else
+ Aux_Int.Puts (To, Integer (Item), Base);
+ end if;
+ end Put;
+
+end Ada.Text_IO.Integer_IO;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . T E X T _ I O . M O D U L A R _ A U X --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-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.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
-
-with System.Img_BIU; use System.Img_BIU;
-with System.Img_Uns; use System.Img_Uns;
-with System.Img_LLB; use System.Img_LLB;
-with System.Img_LLU; use System.Img_LLU;
-with System.Img_LLW; use System.Img_LLW;
-with System.Img_WIU; use System.Img_WIU;
-with System.Val_Uns; use System.Val_Uns;
-with System.Val_LLU; use System.Val_LLU;
-
-package body Ada.Text_IO.Modular_Aux is
-
- use System.Unsigned_Types;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Load_Modular
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural);
- -- This is an auxiliary routine that is used to load an possibly signed
- -- modular literal value from the input file into Buf, starting at Ptr + 1.
- -- Ptr is left set to the last character stored.
-
- -------------
- -- Get_LLU --
- -------------
-
- procedure Get_LLU
- (File : File_Type;
- Item : out Long_Long_Unsigned;
- Width : Field)
- is
- Buf : String (1 .. Field'Last);
- Stop : Integer := 0;
- Ptr : aliased Integer := 1;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Modular (File, Buf, Stop);
- end if;
-
- Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_LLU;
-
- -------------
- -- Get_Uns --
- -------------
-
- procedure Get_Uns
- (File : File_Type;
- Item : out Unsigned;
- Width : Field)
- is
- Buf : String (1 .. Field'Last);
- Stop : Integer := 0;
- Ptr : aliased Integer := 1;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Modular (File, Buf, Stop);
- end if;
-
- Item := Scan_Unsigned (Buf, Ptr'Access, Stop);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_Uns;
-
- --------------
- -- Gets_LLU --
- --------------
-
- procedure Gets_LLU
- (From : String;
- Item : out Long_Long_Unsigned;
- Last : out Positive)
- is
- Pos : aliased Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last);
- Last := Pos - 1;
-
- exception
- when Constraint_Error =>
- raise Data_Error;
- end Gets_LLU;
-
- --------------
- -- Gets_Uns --
- --------------
-
- procedure Gets_Uns
- (From : String;
- Item : out Unsigned;
- Last : out Positive)
- is
- Pos : aliased Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Unsigned (From, Pos'Access, From'Last);
- Last := Pos - 1;
-
- exception
- when Constraint_Error =>
- raise Data_Error;
- end Gets_Uns;
-
- ------------------
- -- Load_Modular --
- ------------------
-
- procedure Load_Modular
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural)
- is
- Hash_Loc : Natural;
- Loaded : Boolean;
-
- begin
- Load_Skip (File);
-
- -- Note: it is a bit strange to allow a minus sign here, but it seems
- -- consistent with the general behavior expected by the ACVC tests
- -- which is to scan past junk and then signal data error, see ACVC
- -- test CE3704F, case (6), which is for signed integer exponents,
- -- which seems a similar case.
-
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr, Loaded);
-
- if Loaded then
-
- -- Deal with based case. We recognize either the standard '#' or the
- -- allowed alternative replacement ':' (see RM J.2(3)).
-
- Load (File, Buf, Ptr, '#', ':', Loaded);
-
- if Loaded then
- Hash_Loc := Ptr;
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, Buf (Hash_Loc));
- end if;
-
- Load (File, Buf, Ptr, 'E', 'e', Loaded);
-
- if Loaded then
-
- -- Note: it is strange to allow a minus sign, since the syntax
- -- does not, but that is what ACVC test CE3704F, case (6) wants
- -- for the signed case, and there seems no good reason to treat
- -- exponents differently for the signed and unsigned cases.
-
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr);
- end if;
- end if;
- end Load_Modular;
-
- -------------
- -- Put_LLU --
- -------------
-
- procedure Put_LLU
- (File : File_Type;
- Item : Long_Long_Unsigned;
- Width : Field;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 and then Width = 0 then
- Set_Image_Long_Long_Unsigned (Item, Buf, Ptr);
- elsif Base = 10 then
- Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr);
- else
- Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr);
- end if;
-
- Put_Item (File, Buf (1 .. Ptr));
- end Put_LLU;
-
- -------------
- -- Put_Uns --
- -------------
-
- procedure Put_Uns
- (File : File_Type;
- Item : Unsigned;
- Width : Field;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 and then Width = 0 then
- Set_Image_Unsigned (Item, Buf, Ptr);
- elsif Base = 10 then
- Set_Image_Width_Unsigned (Item, Width, Buf, Ptr);
- else
- Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr);
- end if;
-
- Put_Item (File, Buf (1 .. Ptr));
- end Put_Uns;
-
- --------------
- -- Puts_LLU --
- --------------
-
- procedure Puts_LLU
- (To : out String;
- Item : Long_Long_Unsigned;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 then
- Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr);
- else
- Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr);
- end if;
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
- end if;
- end Puts_LLU;
-
- --------------
- -- Puts_Uns --
- --------------
-
- procedure Puts_Uns
- (To : out String;
- Item : Unsigned;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 then
- Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr);
- else
- Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr);
- end if;
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
- end if;
- end Puts_Uns;
-
-end Ada.Text_IO.Modular_Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . T E X T _ I O . M O D U L A R _ A U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-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. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the routines for Ada.Text_IO.Modular_IO that are
--- shared among separate instantiations of this package. The routines in
--- this package are identical semantically to those in Modular_IO itself,
--- except that the generic parameter Num has been replaced by Unsigned or
--- Long_Long_Unsigned, and the default parameters have been removed because
--- they are supplied explicitly by the calls from within the generic template.
-
-with System.Unsigned_Types;
-
-private package Ada.Text_IO.Modular_Aux is
-
- package U renames System.Unsigned_Types;
-
- procedure Get_Uns
- (File : File_Type;
- Item : out U.Unsigned;
- Width : Field);
-
- procedure Get_LLU
- (File : File_Type;
- Item : out U.Long_Long_Unsigned;
- Width : Field);
-
- procedure Put_Uns
- (File : File_Type;
- Item : U.Unsigned;
- Width : Field;
- Base : Number_Base);
-
- procedure Put_LLU
- (File : File_Type;
- Item : U.Long_Long_Unsigned;
- Width : Field;
- Base : Number_Base);
-
- procedure Gets_Uns
- (From : String;
- Item : out U.Unsigned;
- Last : out Positive);
-
- procedure Gets_LLU
- (From : String;
- Item : out U.Long_Long_Unsigned;
- Last : out Positive);
-
- procedure Puts_Uns
- (To : out String;
- Item : U.Unsigned;
- Base : Number_Base);
-
- procedure Puts_LLU
- (To : out String;
- Item : U.Long_Long_Unsigned;
- Base : Number_Base);
-
-end Ada.Text_IO.Modular_Aux;
-- --
------------------------------------------------------------------------------
-with Ada.Text_IO.Modular_Aux;
-
-with System.Unsigned_Types; use System.Unsigned_Types;
+with Ada.Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Uns; use System.Img_Uns;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLU; use System.Img_LLU;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Uns; use System.Val_Uns;
+with System.Val_LLU; use System.Val_LLU;
package body Ada.Text_IO.Modular_IO is
- package Aux renames Ada.Text_IO.Modular_Aux;
+ package Aux_Uns is new
+ Ada.Text_IO.Integer_Aux
+ (Unsigned,
+ Scan_Unsigned,
+ Set_Image_Unsigned,
+ Set_Image_Width_Unsigned,
+ Set_Image_Based_Unsigned);
+
+ package Aux_LLU is new
+ Ada.Text_IO.Integer_Aux
+ (Long_Long_Unsigned,
+ Scan_Long_Long_Unsigned,
+ Set_Image_Long_Long_Unsigned,
+ Set_Image_Width_Long_Long_Unsigned,
+ Set_Image_Based_Long_Long_Unsigned);
+
+ Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Unsigned is acceptable, and where a Long_Long_Unsigned is needed. This
+ -- Boolean is used to test for these cases and since it is a constant, only
+ -- code for the relevant case will be included in the instance.
---------
-- Get --
Item : out Num;
Width : Field := 0)
is
+ -- We depend on a range check to get Data_Error
+
pragma Unsuppress (Range_Check);
begin
- if Num'Size > Unsigned'Size then
- Aux.Get_LLU (File, Long_Long_Unsigned (Item), Width);
+ if Need_LLU then
+ Aux_LLU.Get (File, Long_Long_Unsigned (Item), Width);
else
- Aux.Get_Uns (File, Unsigned (Item), Width);
+ Aux_Uns.Get (File, Unsigned (Item), Width);
end if;
exception
(Item : out Num;
Width : Field := 0)
is
- pragma Unsuppress (Range_Check);
-
begin
- if Num'Size > Unsigned'Size then
- Aux.Get_LLU (Current_In, Long_Long_Unsigned (Item), Width);
- else
- Aux.Get_Uns (Current_In, Unsigned (Item), Width);
- end if;
-
- exception
- when Constraint_Error => raise Data_Error;
+ Get (Current_In, Item, Width);
end Get;
procedure Get
Item : out Num;
Last : out Positive)
is
+ -- We depend on a range check to get Data_Error
+
pragma Unsuppress (Range_Check);
begin
- if Num'Size > Unsigned'Size then
- Aux.Gets_LLU (From, Long_Long_Unsigned (Item), Last);
+ if Need_LLU then
+ Aux_LLU.Gets (From, Long_Long_Unsigned (Item), Last);
else
- Aux.Gets_Uns (From, Unsigned (Item), Last);
+ Aux_Uns.Gets (From, Unsigned (Item), Last);
end if;
exception
Base : Number_Base := Default_Base)
is
begin
- if Num'Size > Unsigned'Size then
- Aux.Put_LLU (File, Long_Long_Unsigned (Item), Width, Base);
+ if Need_LLU then
+ Aux_LLU.Put (File, Long_Long_Unsigned (Item), Width, Base);
else
- Aux.Put_Uns (File, Unsigned (Item), Width, Base);
+ Aux_Uns.Put (File, Unsigned (Item), Width, Base);
end if;
end Put;
Base : Number_Base := Default_Base)
is
begin
- if Num'Size > Unsigned'Size then
- Aux.Put_LLU (Current_Out, Long_Long_Unsigned (Item), Width, Base);
- else
- Aux.Put_Uns (Current_Out, Unsigned (Item), Width, Base);
- end if;
+ Put (Current_Out, Item, Width, Base);
end Put;
procedure Put
Base : Number_Base := Default_Base)
is
begin
- if Num'Size > Unsigned'Size then
- Aux.Puts_LLU (To, Long_Long_Unsigned (Item), Base);
+ if Need_LLU then
+ Aux_LLU.Puts (To, Long_Long_Unsigned (Item), Base);
else
- Aux.Puts_Uns (To, Unsigned (Item), Base);
+ Aux_Uns.Puts (To, Unsigned (Item), Base);
end if;
end Put;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . M O D U L A R _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-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.Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Uns; use System.Img_Uns;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLU; use System.Img_LLU;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_LLLB; use System.Img_LLLB;
+with System.Img_LLLU; use System.Img_LLLU;
+with System.Img_LLLW; use System.Img_LLLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Uns; use System.Val_Uns;
+with System.Val_LLU; use System.Val_LLU;
+with System.Val_LLLU; use System.Val_LLLU;
+
+package body Ada.Text_IO.Modular_IO is
+
+ package Aux_Uns is new
+ Ada.Text_IO.Integer_Aux
+ (Unsigned,
+ Scan_Unsigned,
+ Set_Image_Unsigned,
+ Set_Image_Width_Unsigned,
+ Set_Image_Based_Unsigned);
+
+ package Aux_LLU is new
+ Ada.Text_IO.Integer_Aux
+ (Long_Long_Unsigned,
+ Scan_Long_Long_Unsigned,
+ Set_Image_Long_Long_Unsigned,
+ Set_Image_Width_Long_Long_Unsigned,
+ Set_Image_Based_Long_Long_Unsigned);
+
+ package Aux_LLLU is new
+ Ada.Text_IO.Integer_Aux
+ (Long_Long_Long_Unsigned,
+ Scan_Long_Long_Long_Unsigned,
+ Set_Image_Long_Long_Long_Unsigned,
+ Set_Image_Width_Long_Long_Long_Unsigned,
+ Set_Image_Based_Long_Long_Long_Unsigned);
+
+ Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size;
+ Need_LLLU : constant Boolean := Num'Base'Size > Long_Long_Unsigned'Size;
+ -- Throughout this generic body, we distinguish between cases where type
+ -- Unsigned is acceptable, where type Long_Long_Unsigned is acceptable and
+ -- where type Long_Long_Long_Unsigned is needed. These boolean constants
+ -- are used to test for these cases and since they are constant, only code
+ -- for the relevant case will be included in the instance.
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Get (File, Long_Long_Long_Unsigned (Item), Width);
+ elsif Need_LLU then
+ Aux_LLU.Get (File, Long_Long_Unsigned (Item), Width);
+ else
+ Aux_Uns.Get (File, Unsigned (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_In, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Gets (From, Long_Long_Long_Unsigned (Item), Last);
+ elsif Need_LLU then
+ Aux_LLU.Gets (From, Long_Long_Unsigned (Item), Last);
+ else
+ Aux_Uns.Gets (From, Unsigned (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Put (File, Long_Long_Long_Unsigned (Item), Width, Base);
+ elsif Need_LLU then
+ Aux_LLU.Put (File, Long_Long_Unsigned (Item), Width, Base);
+ else
+ Aux_Uns.Put (File, Unsigned (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ Put (Current_Out, Item, Width, Base);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : Num;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Puts (To, Long_Long_Long_Unsigned (Item), Base);
+ elsif Need_LLU then
+ Aux_LLU.Puts (To, Long_Long_Unsigned (Item), Base);
+ else
+ Aux_Uns.Puts (To, Unsigned (Item), Base);
+ end if;
+ end Put;
+
+end Ada.Text_IO.Modular_IO;
Load_Extended_Digits (File, Buf, Ptr, Junk);
end Load_Extended_Digits;
+ ------------------
+ -- Load_Integer --
+ ------------------
+
+ procedure Load_Integer
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Hash_Loc : Natural;
+ Loaded : Boolean;
+
+ begin
+ Load_Skip (File);
+
+ -- Note: it is a bit strange to allow a minus sign here, but it seems
+ -- consistent with the general behavior expected by the ACVC tests
+ -- which is to scan past junk and then signal data error, see ACVC
+ -- test CE3704F, case (6), which is for signed integer exponents,
+ -- which seems a similar case.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ if Loaded then
+
+ -- Deal with based literal. We recognize either the standard '#' or
+ -- the allowed alternative replacement ':' (see RM J.2(3)).
+
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+ Hash_Loc := Ptr;
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, Buf (Hash_Loc));
+ end if;
+
+ -- Deal with exponent
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+
+ -- Note: it is strange to allow a minus sign, since the syntax
+ -- does not, but that is what ACVC test CE3704F, case (6) wants
+ -- for the signed case, and there seems no good reason to treat
+ -- exponents differently for the signed and unsigned cases.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end Load_Integer;
+
---------------
-- Load_Skip --
---------------
Ptr : in out Integer);
-- Same as above, but no indication if character is loaded
+ procedure Load_Integer
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- Loads a possibly signed integer literal value
+
procedure Put_Item (File : File_Type; Str : String);
-- This routine is like Wide_Text_IO.Put, except that it checks for
-- overflow of bounded lines, as described in (RM A.10.6(8)). It is used
procedure String_Skip (Str : String; Ptr : out Integer);
-- Used in the Get from string procedures to skip leading blanks in the
-- string. Ptr is set to the index of the first non-blank. If the string
- -- is all blanks, then the excption End_Error is raised, Note that blank
+ -- is all blanks, then the exception End_Error is raised, Note that blank
-- is defined as a space or horizontal tab (RM A.10.6(5)).
procedure Ungetc (ch : Integer; File : File_Type);
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- A D A . W I D E _ T E X T _ I O . I N T E G E R _ A U X --
+-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ A U X --
-- --
-- B o d y --
-- --
with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
-with System.Img_BIU; use System.Img_BIU;
-with System.Img_Int; use System.Img_Int;
-with System.Img_LLB; use System.Img_LLB;
-with System.Img_LLI; use System.Img_LLI;
-with System.Img_LLW; use System.Img_LLW;
-with System.Img_WIU; use System.Img_WIU;
-with System.Val_Int; use System.Val_Int;
-with System.Val_LLI; use System.Val_LLI;
-
package body Ada.Wide_Text_IO.Integer_Aux is
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Load_Integer
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural);
- -- This is an auxiliary routine that is used to load an possibly signed
- -- integer literal value from the input file into Buf, starting at Ptr + 1.
- -- On return, Ptr is set to the last character stored.
-
- -------------
- -- Get_Int --
- -------------
-
- procedure Get_Int
- (File : File_Type;
- Item : out Integer;
- Width : Field)
- is
- Buf : String (1 .. Field'Last);
- Ptr : aliased Integer := 1;
- Stop : Integer := 0;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Integer (File, Buf, Stop);
- end if;
-
- Item := Scan_Integer (Buf, Ptr'Access, Stop);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_Int;
-
- -------------
- -- Get_LLI --
- -------------
+ ---------
+ -- Get --
+ ---------
- procedure Get_LLI
+ procedure Get
(File : File_Type;
- Item : out Long_Long_Integer;
+ Item : out Num;
Width : Field)
is
Buf : String (1 .. Field'Last);
Load_Integer (File, Buf, Stop);
end if;
- Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop);
+ Item := Scan (Buf, Ptr'Access, Stop);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_LLI;
+ end Get;
- --------------
- -- Gets_Int --
- --------------
+ ----------
+ -- Gets --
+ ----------
- procedure Gets_Int
+ procedure Gets
(From : String;
- Item : out Integer;
+ Item : out Num;
Last : out Positive)
is
Pos : aliased Integer;
begin
String_Skip (From, Pos);
- Item := Scan_Integer (From, Pos'Access, From'Last);
+ Item := Scan (From, Pos'Access, From'Last);
Last := Pos - 1;
exception
when Constraint_Error =>
raise Data_Error;
- end Gets_Int;
-
- --------------
- -- Gets_LLI --
- --------------
-
- procedure Gets_LLI
- (From : String;
- Item : out Long_Long_Integer;
- Last : out Positive)
- is
- Pos : aliased Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last);
- Last := Pos - 1;
-
- exception
- when Constraint_Error =>
- raise Data_Error;
- end Gets_LLI;
-
- ------------------
- -- Load_Integer --
- ------------------
-
- procedure Load_Integer
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural)
- is
- Hash_Loc : Natural;
- Loaded : Boolean;
-
- begin
- Load_Skip (File);
- Load (File, Buf, Ptr, '+', '-');
-
- Load_Digits (File, Buf, Ptr, Loaded);
+ end Gets;
- if Loaded then
+ ---------
+ -- Put --
+ ---------
- -- Deal with based case. We recognize either the standard '#' or the
- -- allowed alternative replacement ':' (see RM J.2(3)).
-
- Load (File, Buf, Ptr, '#', ':', Loaded);
-
- if Loaded then
- Hash_Loc := Ptr;
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, Buf (Hash_Loc));
- end if;
-
- Load (File, Buf, Ptr, 'E', 'e', Loaded);
-
- if Loaded then
-
- -- Note: it is strange to allow a minus sign, since the syntax
- -- does not, but that is what ACVC test CE3704F, case (6) wants.
-
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr);
- end if;
- end if;
- end Load_Integer;
-
- -------------
- -- Put_Int --
- -------------
-
- procedure Put_Int
+ procedure Put
(File : File_Type;
- Item : Integer;
+ Item : Num;
Width : Field;
Base : Number_Base)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Integer'Max (Field'Last, Width));
Ptr : Natural := 0;
begin
if Base = 10 and then Width = 0 then
- Set_Image_Integer (Item, Buf, Ptr);
+ Set_Image (Item, Buf, Ptr);
elsif Base = 10 then
- Set_Image_Width_Integer (Item, Width, Buf, Ptr);
+ Set_Image_Width (Item, Width, Buf, Ptr);
else
- Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr);
+ Set_Image_Based (Item, Base, Width, Buf, Ptr);
end if;
Put_Item (File, Buf (1 .. Ptr));
- end Put_Int;
-
- -------------
- -- Put_LLI --
- -------------
-
- procedure Put_LLI
- (File : File_Type;
- Item : Long_Long_Integer;
- Width : Field;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 and then Width = 0 then
- Set_Image_Long_Long_Integer (Item, Buf, Ptr);
- elsif Base = 10 then
- Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr);
- else
- Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr);
- end if;
-
- Put_Item (File, Buf (1 .. Ptr));
- end Put_LLI;
-
- --------------
- -- Puts_Int --
- --------------
-
- procedure Puts_Int
- (To : out String;
- Item : Integer;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 then
- Set_Image_Width_Integer (Item, To'Length, Buf, Ptr);
- else
- Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr);
- end if;
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
- end if;
- end Puts_Int;
+ end Put;
- --------------
- -- Puts_LLI --
- --------------
+ ----------
+ -- Puts --
+ ----------
- procedure Puts_LLI
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Num;
Base : Number_Base)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Integer'Max (Field'Last, To'Length));
Ptr : Natural := 0;
begin
if Base = 10 then
- Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr);
+ Set_Image_Width (Item, To'Length, Buf, Ptr);
else
- Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr);
+ Set_Image_Based (Item, Base, To'Length, Buf, Ptr);
end if;
if Ptr > To'Length then
else
To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
end if;
- end Puts_LLI;
+ end Puts;
end Ada.Wide_Text_IO.Integer_Aux;
-- --
------------------------------------------------------------------------------
--- This package contains the routines for Ada.Wide_Text_IO.Integer_IO that
--- are shared among separate instantiations of this package. The routines
--- in this package are identical semantically to those in Integer_IO itself,
--- except that the generic parameter Num has been replaced by Integer or
--- Long_Long_Integer, and the default parameters have been removed because
--- they are supplied explicitly by the calls from within the generic template.
+-- This package contains the implementation for Ada.Wide_Text_IO.Integer_IO
+-- and Ada.Wide_Text_IO.Modular_IO. The routines in this package are identical
+-- semantically to those in Integer_IO and Modular_IO themselves, except that
+-- the default parameters have been removed because they are supplied
+-- explicitly by the calls from within these units.
-private package Ada.Wide_Text_IO.Integer_Aux is
+private generic
+ type Num is (<>);
- procedure Get_Int
- (File : File_Type;
- Item : out Integer;
- Width : Field);
+ with function Scan
+ (Str : String; Ptr : not null access Integer; Max : Integer) return Num;
+ with procedure Set_Image
+ (V : Num; S : in out String; P : in out Natural);
+ with procedure Set_Image_Width
+ (V : Num; W : Integer; S : out String; P : in out Natural);
+ with procedure Set_Image_Based
+ (V : Num; B : Natural; W : Integer; S : out String; P : in out Natural);
- procedure Get_LLI
+package Ada.Wide_Text_IO.Integer_Aux is
+
+ procedure Get
(File : File_Type;
- Item : out Long_Long_Integer;
+ Item : out Num;
Width : Field);
- procedure Gets_Int
+ procedure Gets
(From : String;
- Item : out Integer;
+ Item : out Num;
Last : out Positive);
- procedure Gets_LLI
- (From : String;
- Item : out Long_Long_Integer;
- Last : out Positive);
-
- procedure Put_Int
+ procedure Put
(File : File_Type;
- Item : Integer;
+ Item : Num;
Width : Field;
Base : Number_Base);
- procedure Put_LLI
- (File : File_Type;
- Item : Long_Long_Integer;
- Width : Field;
- Base : Number_Base);
-
- procedure Puts_Int
- (To : out String;
- Item : Integer;
- Base : Number_Base);
-
- procedure Puts_LLI
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Num;
Base : Number_Base);
end Ada.Wide_Text_IO.Integer_Aux;
------------------------------------------------------------------------------
with Ada.Wide_Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Int; use System.Img_Int;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLI; use System.Img_LLI;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Int; use System.Val_Int;
+with System.Val_LLI; use System.Val_LLI;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Text_IO.Integer_IO is
+ package Aux_Int is new
+ Ada.Wide_Text_IO.Integer_Aux
+ (Integer,
+ Scan_Integer,
+ Set_Image_Integer,
+ Set_Image_Width_Integer,
+ Set_Image_Based_Integer);
+
+ package Aux_LLI is new
+ Ada.Wide_Text_IO.Integer_Aux
+ (Long_Long_Integer,
+ Scan_Long_Long_Integer,
+ Set_Image_Long_Long_Integer,
+ Set_Image_Width_Long_Long_Integer,
+ Set_Image_Based_Long_Long_Integer);
+
Need_LLI : constant Boolean := Num'Base'Size > Integer'Size;
-- Throughout this generic body, we distinguish between the case where type
-- Integer is acceptable, and where a Long_Long_Integer is needed. This
subtype TFT is Ada.Wide_Text_IO.File_Type;
-- File type required for calls to routines in Aux
- package Aux renames Ada.Wide_Text_IO.Integer_Aux;
-
---------
-- Get --
---------
Item : out Num;
Width : Field := 0)
is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
begin
if Need_LLI then
- Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width);
+ Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width);
else
- Aux.Get_Int (TFT (File), Integer (Item), Width);
+ Aux_Int.Get (TFT (File), Integer (Item), Width);
end if;
exception
Item : out Num;
Last : out Positive)
is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
S : constant String := Wide_String_To_String (From, WCEM_Upper);
-- String on which we do the actual conversion. Note that the method
-- used for wide character encoding is irrelevant, since if there is
begin
if Need_LLI then
- Aux.Gets_LLI (S, Long_Long_Integer (Item), Last);
+ Aux_LLI.Gets (S, Long_Long_Integer (Item), Last);
else
- Aux.Gets_Int (S, Integer (Item), Last);
+ Aux_Int.Gets (S, Integer (Item), Last);
end if;
exception
is
begin
if Need_LLI then
- Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base);
+ Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base);
else
- Aux.Put_Int (TFT (File), Integer (Item), Width, Base);
+ Aux_Int.Put (TFT (File), Integer (Item), Width, Base);
end if;
end Put;
begin
if Need_LLI then
- Aux.Puts_LLI (S, Long_Long_Integer (Item), Base);
+ Aux_LLI.Puts (S, Long_Long_Integer (Item), Base);
else
- Aux.Puts_Int (S, Integer (Item), Base);
+ Aux_Int.Puts (S, Integer (Item), Base);
end if;
for J in S'Range loop
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-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.Wide_Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Int; use System.Img_Int;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLI; use System.Img_LLI;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_LLLB; use System.Img_LLLB;
+with System.Img_LLLI; use System.Img_LLLI;
+with System.Img_LLLW; use System.Img_LLLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Int; use System.Val_Int;
+with System.Val_LLI; use System.Val_LLI;
+with System.Val_LLLI; use System.Val_LLLI;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Text_IO.Integer_IO is
+
+ package Aux_Int is new
+ Ada.Wide_Text_IO.Integer_Aux
+ (Integer,
+ Scan_Integer,
+ Set_Image_Integer,
+ Set_Image_Width_Integer,
+ Set_Image_Based_Integer);
+
+ package Aux_LLI is new
+ Ada.Wide_Text_IO.Integer_Aux
+ (Long_Long_Integer,
+ Scan_Long_Long_Integer,
+ Set_Image_Long_Long_Integer,
+ Set_Image_Width_Long_Long_Integer,
+ Set_Image_Based_Long_Long_Integer);
+
+ package Aux_LLLI is new
+ Ada.Wide_Text_IO.Integer_Aux
+ (Long_Long_Long_Integer,
+ Scan_Long_Long_Long_Integer,
+ Set_Image_Long_Long_Long_Integer,
+ Set_Image_Width_Long_Long_Long_Integer,
+ Set_Image_Based_Long_Long_Long_Integer);
+
+ Need_LLI : constant Boolean := Num'Base'Size > Integer'Size;
+ Need_LLLI : constant Boolean := Num'Base'Size > Long_Long_Integer'Size;
+ -- Throughout this generic body, we distinguish between cases where type
+ -- Integer is acceptable, where type Long_Long_Integer is acceptable and
+ -- where type Long_Long_Long_Integer is needed. These boolean constants
+ -- are used to test for these cases and since they are constant, only code
+ -- for the relevant case will be included in the instance.
+
+ subtype TFT is Ada.Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Get (TFT (File), Long_Long_Long_Integer (Item), Width);
+ elsif Need_LLI then
+ Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width);
+ else
+ Aux_Int.Get (TFT (File), Integer (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Gets (S, Long_Long_Long_Integer (Item), Last);
+ elsif Need_LLI then
+ Aux_LLI.Gets (S, Long_Long_Integer (Item), Last);
+ else
+ Aux_Int.Gets (S, Integer (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Put (TFT (File), Long_Long_Long_Integer (Item), Width, Base);
+ elsif Need_LLI then
+ Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base);
+ else
+ Aux_Int.Put (TFT (File), Integer (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ Put (Current_Output, Item, Width, Base);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : Num;
+ Base : Number_Base := Default_Base)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Puts (S, Long_Long_Long_Integer (Item), Base);
+ elsif Need_LLI then
+ Aux_LLI.Puts (S, Long_Long_Integer (Item), Base);
+ else
+ Aux_Int.Puts (S, Integer (Item), Base);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Integer_IO;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . W I D E _ T E X T _ I O . M O D U L A R _ A U X --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-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.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
-
-with System.Img_BIU; use System.Img_BIU;
-with System.Img_Uns; use System.Img_Uns;
-with System.Img_LLB; use System.Img_LLB;
-with System.Img_LLU; use System.Img_LLU;
-with System.Img_LLW; use System.Img_LLW;
-with System.Img_WIU; use System.Img_WIU;
-with System.Val_Uns; use System.Val_Uns;
-with System.Val_LLU; use System.Val_LLU;
-
-package body Ada.Wide_Text_IO.Modular_Aux is
-
- use System.Unsigned_Types;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Load_Modular
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural);
- -- This is an auxiliary routine that is used to load an possibly signed
- -- modular literal value from the input file into Buf, starting at Ptr + 1.
- -- Ptr is left set to the last character stored.
-
- -------------
- -- Get_LLU --
- -------------
-
- procedure Get_LLU
- (File : File_Type;
- Item : out Long_Long_Unsigned;
- Width : Field)
- is
- Buf : String (1 .. Field'Last);
- Stop : Integer := 0;
- Ptr : aliased Integer := 1;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Modular (File, Buf, Stop);
- end if;
-
- Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_LLU;
-
- -------------
- -- Get_Uns --
- -------------
-
- procedure Get_Uns
- (File : File_Type;
- Item : out Unsigned;
- Width : Field)
- is
- Buf : String (1 .. Field'Last);
- Stop : Integer := 0;
- Ptr : aliased Integer := 1;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Modular (File, Buf, Stop);
- end if;
-
- Item := Scan_Unsigned (Buf, Ptr'Access, Stop);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_Uns;
-
- --------------
- -- Gets_LLU --
- --------------
-
- procedure Gets_LLU
- (From : String;
- Item : out Long_Long_Unsigned;
- Last : out Positive)
- is
- Pos : aliased Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last);
- Last := Pos - 1;
-
- exception
- when Constraint_Error =>
- raise Data_Error;
- end Gets_LLU;
-
- --------------
- -- Gets_Uns --
- --------------
-
- procedure Gets_Uns
- (From : String;
- Item : out Unsigned;
- Last : out Positive)
- is
- Pos : aliased Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Unsigned (From, Pos'Access, From'Last);
- Last := Pos - 1;
-
- exception
- when Constraint_Error =>
- raise Data_Error;
- end Gets_Uns;
-
- ------------------
- -- Load_Modular --
- ------------------
-
- procedure Load_Modular
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural)
- is
- Hash_Loc : Natural;
- Loaded : Boolean;
-
- begin
- Load_Skip (File);
-
- -- Note: it is a bit strange to allow a minus sign here, but it seems
- -- consistent with the general behavior expected by the ACVC tests
- -- which is to scan past junk and then signal data error, see ACVC
- -- test CE3704F, case (6), which is for signed integer exponents,
- -- which seems a similar case.
-
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr, Loaded);
-
- if Loaded then
-
- -- Deal with based case. We recognize either the standard '#' or the
- -- allowed alternative replacement ':' (see RM J.2(3)).
-
- Load (File, Buf, Ptr, '#', ':', Loaded);
-
- if Loaded then
- Hash_Loc := Ptr;
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, Buf (Hash_Loc));
- end if;
-
- Load (File, Buf, Ptr, 'E', 'e', Loaded);
-
- if Loaded then
-
- -- Note: it is strange to allow a minus sign, since the syntax
- -- does not, but that is what ACVC test CE3704F, case (6) wants
- -- for the signed case, and there seems no good reason to treat
- -- exponents differently for the signed and unsigned cases.
-
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr);
- end if;
- end if;
- end Load_Modular;
-
- -------------
- -- Put_LLU --
- -------------
-
- procedure Put_LLU
- (File : File_Type;
- Item : Long_Long_Unsigned;
- Width : Field;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 and then Width = 0 then
- Set_Image_Long_Long_Unsigned (Item, Buf, Ptr);
- elsif Base = 10 then
- Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr);
- else
- Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr);
- end if;
-
- Put_Item (File, Buf (1 .. Ptr));
- end Put_LLU;
-
- -------------
- -- Put_Uns --
- -------------
-
- procedure Put_Uns
- (File : File_Type;
- Item : Unsigned;
- Width : Field;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 and then Width = 0 then
- Set_Image_Unsigned (Item, Buf, Ptr);
- elsif Base = 10 then
- Set_Image_Width_Unsigned (Item, Width, Buf, Ptr);
- else
- Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr);
- end if;
-
- Put_Item (File, Buf (1 .. Ptr));
- end Put_Uns;
-
- --------------
- -- Puts_LLU --
- --------------
-
- procedure Puts_LLU
- (To : out String;
- Item : Long_Long_Unsigned;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 then
- Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr);
- else
- Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr);
- end if;
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
- end if;
- end Puts_LLU;
-
- --------------
- -- Puts_Uns --
- --------------
-
- procedure Puts_Uns
- (To : out String;
- Item : Unsigned;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 then
- Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr);
- else
- Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr);
- end if;
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
- end if;
- end Puts_Uns;
-
-end Ada.Wide_Text_IO.Modular_Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . W I D E _ T E X T _ I O . M O D U L A R _ A U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-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. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the routines for Ada.Wide_Text_IO.Modular_IO that
--- are shared among separate instantiations of this package. The routines
--- in this package are identical semantically to those in Modular_IO itself,
--- except that the generic parameter Num has been replaced by Unsigned or
--- Long_Long_Unsigned, and the default parameters have been removed because
--- they are supplied explicitly by the calls from within the generic template.
-
-with System.Unsigned_Types;
-
-private package Ada.Wide_Text_IO.Modular_Aux is
-
- package U renames System.Unsigned_Types;
-
- procedure Get_Uns
- (File : File_Type;
- Item : out U.Unsigned;
- Width : Field);
-
- procedure Get_LLU
- (File : File_Type;
- Item : out U.Long_Long_Unsigned;
- Width : Field);
-
- procedure Gets_Uns
- (From : String;
- Item : out U.Unsigned;
- Last : out Positive);
-
- procedure Gets_LLU
- (From : String;
- Item : out U.Long_Long_Unsigned;
- Last : out Positive);
-
- procedure Put_Uns
- (File : File_Type;
- Item : U.Unsigned;
- Width : Field;
- Base : Number_Base);
-
- procedure Put_LLU
- (File : File_Type;
- Item : U.Long_Long_Unsigned;
- Width : Field;
- Base : Number_Base);
-
- procedure Puts_Uns
- (To : out String;
- Item : U.Unsigned;
- Base : Number_Base);
-
- procedure Puts_LLU
- (To : out String;
- Item : U.Long_Long_Unsigned;
- Base : Number_Base);
-
-end Ada.Wide_Text_IO.Modular_Aux;
-- --
------------------------------------------------------------------------------
-with Ada.Wide_Text_IO.Modular_Aux;
-
-with System.Unsigned_Types; use System.Unsigned_Types;
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_WtS; use System.WCh_WtS;
+with Ada.Wide_Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Uns; use System.Img_Uns;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLU; use System.Img_LLU;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Uns; use System.Val_Uns;
+with System.Val_LLU; use System.Val_LLU;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Text_IO.Modular_IO is
+ package Aux_Uns is new
+ Ada.Wide_Text_IO.Integer_Aux
+ (Unsigned,
+ Scan_Unsigned,
+ Set_Image_Unsigned,
+ Set_Image_Width_Unsigned,
+ Set_Image_Based_Unsigned);
+
+ package Aux_LLU is new
+ Ada.Wide_Text_IO.Integer_Aux
+ (Long_Long_Unsigned,
+ Scan_Long_Long_Unsigned,
+ Set_Image_Long_Long_Unsigned,
+ Set_Image_Width_Long_Long_Unsigned,
+ Set_Image_Based_Long_Long_Unsigned);
+
+ Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Unsigned is acceptable, and where a Long_Long_Unsigned is needed. This
+ -- Boolean is used to test for these cases and since it is a constant, only
+ -- code for the relevant case will be included in the instance.
+
subtype TFT is Ada.Wide_Text_IO.File_Type;
-- File type required for calls to routines in Aux
- package Aux renames Ada.Wide_Text_IO.Modular_Aux;
-
---------
-- Get --
---------
Item : out Num;
Width : Field := 0)
is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+
begin
- if Num'Size > Unsigned'Size then
- Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width);
+ if Need_LLU then
+ Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width);
else
- Aux.Get_Uns (TFT (File), Unsigned (Item), Width);
+ Aux_Uns.Get (TFT (File), Unsigned (Item), Width);
end if;
exception
Item : out Num;
Last : out Positive)
is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+
S : constant String := Wide_String_To_String (From, WCEM_Upper);
-- String on which we do the actual conversion. Note that the method
-- used for wide character encoding is irrelevant, since if there is
-- Aux.Gets will raise Data_Error in any case.
begin
- if Num'Size > Unsigned'Size then
- Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last);
+ if Need_LLU then
+ Aux_LLU.Gets (S, Long_Long_Unsigned (Item), Last);
else
- Aux.Gets_Uns (S, Unsigned (Item), Last);
+ Aux_Uns.Gets (S, Unsigned (Item), Last);
end if;
exception
Base : Number_Base := Default_Base)
is
begin
- if Num'Size > Unsigned'Size then
- Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base);
+ if Need_LLU then
+ Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base);
else
- Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base);
+ Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base);
end if;
end Put;
S : String (To'First .. To'Last);
begin
- if Num'Size > Unsigned'Size then
- Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base);
+ if Need_LLU then
+ Aux_LLU.Puts (S, Long_Long_Unsigned (Item), Base);
else
- Aux.Puts_Uns (S, Unsigned (Item), Base);
+ Aux_Uns.Puts (S, Unsigned (Item), Base);
end if;
for J in S'Range loop
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . M O D U L A R _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-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.Wide_Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Uns; use System.Img_Uns;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLU; use System.Img_LLU;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_LLLB; use System.Img_LLLB;
+with System.Img_LLLU; use System.Img_LLLU;
+with System.Img_LLLW; use System.Img_LLLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Uns; use System.Val_Uns;
+with System.Val_LLU; use System.Val_LLU;
+with System.Val_LLLU; use System.Val_LLLU;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Text_IO.Modular_IO is
+
+ package Aux_Uns is new
+ Ada.Wide_Text_IO.Integer_Aux
+ (Unsigned,
+ Scan_Unsigned,
+ Set_Image_Unsigned,
+ Set_Image_Width_Unsigned,
+ Set_Image_Based_Unsigned);
+
+ package Aux_LLU is new
+ Ada.Wide_Text_IO.Integer_Aux
+ (Long_Long_Unsigned,
+ Scan_Long_Long_Unsigned,
+ Set_Image_Long_Long_Unsigned,
+ Set_Image_Width_Long_Long_Unsigned,
+ Set_Image_Based_Long_Long_Unsigned);
+
+ package Aux_LLLU is new
+ Ada.Wide_Text_IO.Integer_Aux
+ (Long_Long_Long_Unsigned,
+ Scan_Long_Long_Long_Unsigned,
+ Set_Image_Long_Long_Long_Unsigned,
+ Set_Image_Width_Long_Long_Long_Unsigned,
+ Set_Image_Based_Long_Long_Long_Unsigned);
+
+ Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size;
+ Need_LLLU : constant Boolean := Num'Base'Size > Long_Long_Unsigned'Size;
+ -- Throughout this generic body, we distinguish between cases where type
+ -- Unsigned is acceptable, where type Long_Long_Unsigned is acceptable and
+ -- where type Long_Long_Long_Unsigned is needed. These boolean constants
+ -- are used to test for these cases and since they are constant, only code
+ -- for the relevant case will be included in the instance.
+
+ subtype TFT is Ada.Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Get (File, Long_Long_Long_Unsigned (Item), Width);
+ elsif Need_LLU then
+ Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width);
+ else
+ Aux_Uns.Get (TFT (File), Unsigned (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Gets (S, Long_Long_Long_Unsigned (Item), Last);
+ elsif Need_LLU then
+ Aux_LLU.Gets (S, Long_Long_Unsigned (Item), Last);
+ else
+ Aux_Uns.Gets (S, Unsigned (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Put (File, Long_Long_Long_Unsigned (Item), Width, Base);
+ elsif Need_LLU then
+ Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base);
+ else
+ Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ Put (Current_Output, Item, Width, Base);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : Num;
+ Base : Number_Base := Default_Base)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Puts (S, Long_Long_Long_Unsigned (Item), Base);
+ elsif Need_LLU then
+ Aux_LLU.Puts (S, Long_Long_Unsigned (Item), Base);
+ else
+ Aux_Uns.Puts (S, Unsigned (Item), Base);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Modular_IO;
Load_Extended_Digits (File, Buf, Ptr, Junk);
end Load_Extended_Digits;
+ ------------------
+ -- Load_Integer --
+ ------------------
+
+ procedure Load_Integer
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Hash_Loc : Natural;
+ Loaded : Boolean;
+
+ begin
+ Load_Skip (File);
+
+ -- Note: it is a bit strange to allow a minus sign here, but it seems
+ -- consistent with the general behavior expected by the ACVC tests
+ -- which is to scan past junk and then signal data error, see ACVC
+ -- test CE3704F, case (6), which is for signed integer exponents,
+ -- which seems a similar case.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ if Loaded then
+
+ -- Deal with based literal. We recognize either the standard '#' or
+ -- the allowed alternative replacement ':' (see RM J.2(3)).
+
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+ Hash_Loc := Ptr;
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, Buf (Hash_Loc));
+ end if;
+
+ -- Deal with exponent
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+
+ -- Note: it is strange to allow a minus sign, since the syntax
+ -- does not, but that is what ACVC test CE3704F, case (6) wants
+ -- for the signed case, and there seems no good reason to treat
+ -- exponents differently for the signed and unsigned cases.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end Load_Integer;
+
---------------
-- Load_Skip --
---------------
Ptr : in out Integer);
-- Same as above, but no indication if character is loaded
+ procedure Load_Integer
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- Loads a possibly signed integer literal value
+
procedure Put_Item (File : File_Type; Str : String);
-- This routine is like Wide_Wide_Text_IO.Put, except that it checks for
-- overflow of bounded lines, as described in (RM A.10.6(8)). It is used
procedure String_Skip (Str : String; Ptr : out Integer);
-- Used in the Get from string procedures to skip leading blanks in the
-- string. Ptr is set to the index of the first non-blank. If the string
- -- is all blanks, then the excption End_Error is raised, Note that blank
+ -- is all blanks, then the exception End_Error is raised, Note that blank
-- is defined as a space or horizontal tab (RM A.10.6(5)).
procedure Ungetc (ch : Integer; File : File_Type);
with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
-with System.Img_BIU; use System.Img_BIU;
-with System.Img_Int; use System.Img_Int;
-with System.Img_LLB; use System.Img_LLB;
-with System.Img_LLI; use System.Img_LLI;
-with System.Img_LLW; use System.Img_LLW;
-with System.Img_WIU; use System.Img_WIU;
-with System.Val_Int; use System.Val_Int;
-with System.Val_LLI; use System.Val_LLI;
-
package body Ada.Wide_Wide_Text_IO.Integer_Aux is
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Load_Integer
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural);
- -- This is an auxiliary routine that is used to load an possibly signed
- -- integer literal value from the input file into Buf, starting at Ptr + 1.
- -- On return, Ptr is set to the last character stored.
-
- -------------
- -- Get_Int --
- -------------
-
- procedure Get_Int
- (File : File_Type;
- Item : out Integer;
- Width : Field)
- is
- Buf : String (1 .. Field'Last);
- Ptr : aliased Integer := 1;
- Stop : Integer := 0;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Integer (File, Buf, Stop);
- end if;
-
- Item := Scan_Integer (Buf, Ptr'Access, Stop);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_Int;
-
- -------------
- -- Get_LLI --
- -------------
+ ---------
+ -- Get --
+ ---------
- procedure Get_LLI
+ procedure Get
(File : File_Type;
- Item : out Long_Long_Integer;
+ Item : out Num;
Width : Field)
is
Buf : String (1 .. Field'Last);
Load_Integer (File, Buf, Stop);
end if;
- Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop);
+ Item := Scan (Buf, Ptr'Access, Stop);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_LLI;
+ end Get;
- --------------
- -- Gets_Int --
- --------------
+ ----------
+ -- Gets --
+ ----------
- procedure Gets_Int
+ procedure Gets
(From : String;
- Item : out Integer;
+ Item : out Num;
Last : out Positive)
is
Pos : aliased Integer;
begin
String_Skip (From, Pos);
- Item := Scan_Integer (From, Pos'Access, From'Last);
+ Item := Scan (From, Pos'Access, From'Last);
Last := Pos - 1;
exception
when Constraint_Error =>
raise Data_Error;
- end Gets_Int;
-
- --------------
- -- Gets_LLI --
- --------------
-
- procedure Gets_LLI
- (From : String;
- Item : out Long_Long_Integer;
- Last : out Positive)
- is
- Pos : aliased Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last);
- Last := Pos - 1;
-
- exception
- when Constraint_Error =>
- raise Data_Error;
- end Gets_LLI;
-
- ------------------
- -- Load_Integer --
- ------------------
-
- procedure Load_Integer
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural)
- is
- Hash_Loc : Natural;
- Loaded : Boolean;
-
- begin
- Load_Skip (File);
- Load (File, Buf, Ptr, '+', '-');
-
- Load_Digits (File, Buf, Ptr, Loaded);
+ end Gets;
- if Loaded then
+ ---------
+ -- Put --
+ ---------
- -- Deal with based case. We recognize either the standard '#' or the
- -- allowed alternative replacement ':' (see RM J.2(3)).
-
- Load (File, Buf, Ptr, '#', ':', Loaded);
-
- if Loaded then
- Hash_Loc := Ptr;
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, Buf (Hash_Loc));
- end if;
-
- Load (File, Buf, Ptr, 'E', 'e', Loaded);
-
- if Loaded then
-
- -- Note: it is strange to allow a minus sign, since the syntax
- -- does not, but that is what ACVC test CE3704F, case (6) wants.
-
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr);
- end if;
- end if;
- end Load_Integer;
-
- -------------
- -- Put_Int --
- -------------
-
- procedure Put_Int
+ procedure Put
(File : File_Type;
- Item : Integer;
+ Item : Num;
Width : Field;
Base : Number_Base)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Integer'Max (Field'Last, Width));
Ptr : Natural := 0;
begin
if Base = 10 and then Width = 0 then
- Set_Image_Integer (Item, Buf, Ptr);
+ Set_Image (Item, Buf, Ptr);
elsif Base = 10 then
- Set_Image_Width_Integer (Item, Width, Buf, Ptr);
+ Set_Image_Width (Item, Width, Buf, Ptr);
else
- Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr);
+ Set_Image_Based (Item, Base, Width, Buf, Ptr);
end if;
Put_Item (File, Buf (1 .. Ptr));
- end Put_Int;
-
- -------------
- -- Put_LLI --
- -------------
-
- procedure Put_LLI
- (File : File_Type;
- Item : Long_Long_Integer;
- Width : Field;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 and then Width = 0 then
- Set_Image_Long_Long_Integer (Item, Buf, Ptr);
- elsif Base = 10 then
- Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr);
- else
- Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr);
- end if;
-
- Put_Item (File, Buf (1 .. Ptr));
- end Put_LLI;
-
- --------------
- -- Puts_Int --
- --------------
-
- procedure Puts_Int
- (To : out String;
- Item : Integer;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 then
- Set_Image_Width_Integer (Item, To'Length, Buf, Ptr);
- else
- Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr);
- end if;
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
- end if;
- end Puts_Int;
+ end Put;
- --------------
- -- Puts_LLI --
- --------------
+ ----------
+ -- Puts --
+ ----------
- procedure Puts_LLI
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Num;
Base : Number_Base)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Integer'Max (Field'Last, To'Length));
Ptr : Natural := 0;
begin
if Base = 10 then
- Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr);
+ Set_Image_Width (Item, To'Length, Buf, Ptr);
else
- Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr);
+ Set_Image_Based (Item, Base, To'Length, Buf, Ptr);
end if;
if Ptr > To'Length then
else
To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
end if;
- end Puts_LLI;
+ end Puts;
end Ada.Wide_Wide_Text_IO.Integer_Aux;
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X --
-- --
-- S p e c --
-- --
-- --
------------------------------------------------------------------------------
--- This package contains the routines for Ada.Wide_Wide_Text_IO.Integer_IO
--- that are shared among separate instantiations of this package. The routines
--- in this package are identical semantically to those in Integer_IO itself,
--- except that the generic parameter Num has been replaced by Integer or
--- Long_Long_Integer, and the default parameters have been removed because
--- they are supplied explicitly by the calls from within the generic template.
+-- This package contains implementation for Ada.Wide_Wide.Text_IO.Integer_IO
+-- and Ada.Wide_Wide_Text_IO.Modular_IO. The routines in this package are
+-- identical semantically to those in Integer_IO and Modular_IO themselves,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units.
-private package Ada.Wide_Wide_Text_IO.Integer_Aux is
+private generic
+ type Num is (<>);
- procedure Get_Int
- (File : File_Type;
- Item : out Integer;
- Width : Field);
+ with function Scan
+ (Str : String; Ptr : not null access Integer; Max : Integer) return Num;
+ with procedure Set_Image
+ (V : Num; S : in out String; P : in out Natural);
+ with procedure Set_Image_Width
+ (V : Num; W : Integer; S : out String; P : in out Natural);
+ with procedure Set_Image_Based
+ (V : Num; B : Natural; W : Integer; S : out String; P : in out Natural);
- procedure Get_LLI
+package Ada.Wide_Wide_Text_IO.Integer_Aux is
+
+ procedure Get
(File : File_Type;
- Item : out Long_Long_Integer;
+ Item : out Num;
Width : Field);
- procedure Gets_Int
+ procedure Gets
(From : String;
- Item : out Integer;
+ Item : out Num;
Last : out Positive);
- procedure Gets_LLI
- (From : String;
- Item : out Long_Long_Integer;
- Last : out Positive);
-
- procedure Put_Int
+ procedure Put
(File : File_Type;
- Item : Integer;
+ Item : Num;
Width : Field;
Base : Number_Base);
- procedure Put_LLI
- (File : File_Type;
- Item : Long_Long_Integer;
- Width : Field;
- Base : Number_Base);
-
- procedure Puts_Int
- (To : out String;
- Item : Integer;
- Base : Number_Base);
-
- procedure Puts_LLI
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Num;
Base : Number_Base);
end Ada.Wide_Wide_Text_IO.Integer_Aux;
------------------------------------------------------------------------------
with Ada.Wide_Wide_Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Int; use System.Img_Int;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLI; use System.Img_LLI;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Int; use System.Val_Int;
+with System.Val_LLI; use System.Val_LLI;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Wide_Text_IO.Integer_IO is
+ package Aux_Int is new
+ Ada.Wide_Wide_Text_IO.Integer_Aux
+ (Integer,
+ Scan_Integer,
+ Set_Image_Integer,
+ Set_Image_Width_Integer,
+ Set_Image_Based_Integer);
+
+ package Aux_LLI is new
+ Ada.Wide_Wide_Text_IO.Integer_Aux
+ (Long_Long_Integer,
+ Scan_Long_Long_Integer,
+ Set_Image_Long_Long_Integer,
+ Set_Image_Width_Long_Long_Integer,
+ Set_Image_Based_Long_Long_Integer);
+
Need_LLI : constant Boolean := Num'Base'Size > Integer'Size;
-- Throughout this generic body, we distinguish between the case where type
-- Integer is acceptable, and where a Long_Long_Integer is needed. This
subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
-- File type required for calls to routines in Aux
- package Aux renames Ada.Wide_Wide_Text_IO.Integer_Aux;
-
---------
-- Get --
---------
Item : out Num;
Width : Field := 0)
is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
begin
if Need_LLI then
- Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width);
+ Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width);
else
- Aux.Get_Int (TFT (File), Integer (Item), Width);
+ Aux_Int.Get (TFT (File), Integer (Item), Width);
end if;
exception
Item : out Num;
Last : out Positive)
is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
-- String on which we do the actual conversion. Note that the method
-- used for wide character encoding is irrelevant, since if there is
begin
if Need_LLI then
- Aux.Gets_LLI (S, Long_Long_Integer (Item), Last);
+ Aux_LLI.Gets (S, Long_Long_Integer (Item), Last);
else
- Aux.Gets_Int (S, Integer (Item), Last);
+ Aux_Int.Gets (S, Integer (Item), Last);
end if;
exception
is
begin
if Need_LLI then
- Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base);
+ Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base);
else
- Aux.Put_Int (TFT (File), Integer (Item), Width, Base);
+ Aux_Int.Put (TFT (File), Integer (Item), Width, Base);
end if;
end Put;
begin
if Need_LLI then
- Aux.Puts_LLI (S, Long_Long_Integer (Item), Base);
+ Aux_LLI.Puts (S, Long_Long_Integer (Item), Base);
else
- Aux.Puts_Int (S, Integer (Item), Base);
+ Aux_Int.Puts (S, Integer (Item), Base);
end if;
for J in S'Range loop
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-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.Wide_Wide_Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Int; use System.Img_Int;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLI; use System.Img_LLI;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_LLLB; use System.Img_LLLB;
+with System.Img_LLLI; use System.Img_LLLI;
+with System.Img_LLLW; use System.Img_LLLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Int; use System.Val_Int;
+with System.Val_LLI; use System.Val_LLI;
+with System.Val_LLLI; use System.Val_LLLI;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Wide_Text_IO.Integer_IO is
+
+ package Aux_Int is new
+ Ada.Wide_Wide_Text_IO.Integer_Aux
+ (Integer,
+ Scan_Integer,
+ Set_Image_Integer,
+ Set_Image_Width_Integer,
+ Set_Image_Based_Integer);
+
+ package Aux_LLI is new
+ Ada.Wide_Wide_Text_IO.Integer_Aux
+ (Long_Long_Integer,
+ Scan_Long_Long_Integer,
+ Set_Image_Long_Long_Integer,
+ Set_Image_Width_Long_Long_Integer,
+ Set_Image_Based_Long_Long_Integer);
+
+ package Aux_LLLI is new
+ Ada.Wide_Wide_Text_IO.Integer_Aux
+ (Long_Long_Long_Integer,
+ Scan_Long_Long_Long_Integer,
+ Set_Image_Long_Long_Long_Integer,
+ Set_Image_Width_Long_Long_Long_Integer,
+ Set_Image_Based_Long_Long_Long_Integer);
+
+ Need_LLI : constant Boolean := Num'Base'Size > Integer'Size;
+ Need_LLLI : constant Boolean := Num'Base'Size > Long_Long_Integer'Size;
+ -- Throughout this generic body, we distinguish between cases where type
+ -- Integer is acceptable, where type Long_Long_Integer is acceptable and
+ -- where type Long_Long_Long_Integer is needed. These boolean constants
+ -- are used to test for these cases and since they are constant, only code
+ -- for the relevant case will be included in the instance.
+
+ subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Get (TFT (File), Long_Long_Long_Integer (Item), Width);
+ elsif Need_LLI then
+ Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width);
+ else
+ Aux_Int.Get (TFT (File), Integer (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Gets (S, Long_Long_Long_Integer (Item), Last);
+ elsif Need_LLI then
+ Aux_LLI.Gets (S, Long_Long_Integer (Item), Last);
+ else
+ Aux_Int.Gets (S, Integer (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Put (TFT (File), Long_Long_Long_Integer (Item), Width, Base);
+ elsif Need_LLI then
+ Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base);
+ else
+ Aux_Int.Put (TFT (File), Integer (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ Put (Current_Output, Item, Width, Base);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Base : Number_Base := Default_Base)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Need_LLLI then
+ Aux_LLLI.Puts (S, Long_Long_Long_Integer (Item), Base);
+ elsif Need_LLI then
+ Aux_LLI.Puts (S, Long_Long_Integer (Item), Base);
+ else
+ Aux_Int.Puts (S, Integer (Item), Base);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Integer_IO;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-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.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
-
-with System.Img_BIU; use System.Img_BIU;
-with System.Img_Uns; use System.Img_Uns;
-with System.Img_LLB; use System.Img_LLB;
-with System.Img_LLU; use System.Img_LLU;
-with System.Img_LLW; use System.Img_LLW;
-with System.Img_WIU; use System.Img_WIU;
-with System.Val_Uns; use System.Val_Uns;
-with System.Val_LLU; use System.Val_LLU;
-
-package body Ada.Wide_Wide_Text_IO.Modular_Aux is
-
- use System.Unsigned_Types;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Load_Modular
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural);
- -- This is an auxiliary routine that is used to load an possibly signed
- -- modular literal value from the input file into Buf, starting at Ptr + 1.
- -- Ptr is left set to the last character stored.
-
- -------------
- -- Get_LLU --
- -------------
-
- procedure Get_LLU
- (File : File_Type;
- Item : out Long_Long_Unsigned;
- Width : Field)
- is
- Buf : String (1 .. Field'Last);
- Stop : Integer := 0;
- Ptr : aliased Integer := 1;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Modular (File, Buf, Stop);
- end if;
-
- Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_LLU;
-
- -------------
- -- Get_Uns --
- -------------
-
- procedure Get_Uns
- (File : File_Type;
- Item : out Unsigned;
- Width : Field)
- is
- Buf : String (1 .. Field'Last);
- Stop : Integer := 0;
- Ptr : aliased Integer := 1;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Modular (File, Buf, Stop);
- end if;
-
- Item := Scan_Unsigned (Buf, Ptr'Access, Stop);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- end Get_Uns;
-
- --------------
- -- Gets_LLU --
- --------------
-
- procedure Gets_LLU
- (From : String;
- Item : out Long_Long_Unsigned;
- Last : out Positive)
- is
- Pos : aliased Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last);
- Last := Pos - 1;
-
- exception
- when Constraint_Error =>
- raise Data_Error;
- end Gets_LLU;
-
- --------------
- -- Gets_Uns --
- --------------
-
- procedure Gets_Uns
- (From : String;
- Item : out Unsigned;
- Last : out Positive)
- is
- Pos : aliased Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Unsigned (From, Pos'Access, From'Last);
- Last := Pos - 1;
-
- exception
- when Constraint_Error =>
- raise Data_Error;
- end Gets_Uns;
-
- ------------------
- -- Load_Modular --
- ------------------
-
- procedure Load_Modular
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural)
- is
- Hash_Loc : Natural;
- Loaded : Boolean;
-
- begin
- Load_Skip (File);
-
- -- Note: it is a bit strange to allow a minus sign here, but it seems
- -- consistent with the general behavior expected by the ACVC tests
- -- which is to scan past junk and then signal data error, see ACVC
- -- test CE3704F, case (6), which is for signed integer exponents,
- -- which seems a similar case.
-
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr, Loaded);
-
- if Loaded then
-
- -- Deal with based case. We recognize either the standard '#' or the
- -- allowed alternative replacement ':' (see RM J.2(3)).
-
- Load (File, Buf, Ptr, '#', ':', Loaded);
-
- if Loaded then
- Hash_Loc := Ptr;
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, Buf (Hash_Loc));
- end if;
-
- Load (File, Buf, Ptr, 'E', 'e', Loaded);
-
- if Loaded then
-
- -- Note: it is strange to allow a minus sign, since the syntax
- -- does not, but that is what ACVC test CE3704F, case (6) wants
- -- for the signed case, and there seems no good reason to treat
- -- exponents differently for the signed and unsigned cases.
-
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr);
- end if;
- end if;
- end Load_Modular;
-
- -------------
- -- Put_LLU --
- -------------
-
- procedure Put_LLU
- (File : File_Type;
- Item : Long_Long_Unsigned;
- Width : Field;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 and then Width = 0 then
- Set_Image_Long_Long_Unsigned (Item, Buf, Ptr);
- elsif Base = 10 then
- Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr);
- else
- Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr);
- end if;
-
- Put_Item (File, Buf (1 .. Ptr));
- end Put_LLU;
-
- -------------
- -- Put_Uns --
- -------------
-
- procedure Put_Uns
- (File : File_Type;
- Item : Unsigned;
- Width : Field;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 and then Width = 0 then
- Set_Image_Unsigned (Item, Buf, Ptr);
- elsif Base = 10 then
- Set_Image_Width_Unsigned (Item, Width, Buf, Ptr);
- else
- Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr);
- end if;
-
- Put_Item (File, Buf (1 .. Ptr));
- end Put_Uns;
-
- --------------
- -- Puts_LLU --
- --------------
-
- procedure Puts_LLU
- (To : out String;
- Item : Long_Long_Unsigned;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 then
- Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr);
- else
- Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr);
- end if;
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
- end if;
- end Puts_LLU;
-
- --------------
- -- Puts_Uns --
- --------------
-
- procedure Puts_Uns
- (To : out String;
- Item : Unsigned;
- Base : Number_Base)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- if Base = 10 then
- Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr);
- else
- Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr);
- end if;
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
- end if;
- end Puts_Uns;
-
-end Ada.Wide_Wide_Text_IO.Modular_Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-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. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the routines for Ada.Wide_Wide_Text_IO.Modular_IO
--- that are shared among separate instantiations of this package. The
--- routines in this package are identical semantically to those in Modular_IO
--- itself, except that the generic parameter Num has been replaced by
--- Unsigned or Long_Long_Unsigned, and the default parameters have been
--- removed because they are supplied explicitly by the calls from within the
--- generic template.
-
-with System.Unsigned_Types;
-
-private package Ada.Wide_Wide_Text_IO.Modular_Aux is
-
- package U renames System.Unsigned_Types;
-
- procedure Get_Uns
- (File : File_Type;
- Item : out U.Unsigned;
- Width : Field);
-
- procedure Get_LLU
- (File : File_Type;
- Item : out U.Long_Long_Unsigned;
- Width : Field);
-
- procedure Gets_Uns
- (From : String;
- Item : out U.Unsigned;
- Last : out Positive);
-
- procedure Gets_LLU
- (From : String;
- Item : out U.Long_Long_Unsigned;
- Last : out Positive);
-
- procedure Put_Uns
- (File : File_Type;
- Item : U.Unsigned;
- Width : Field;
- Base : Number_Base);
-
- procedure Put_LLU
- (File : File_Type;
- Item : U.Long_Long_Unsigned;
- Width : Field;
- Base : Number_Base);
-
- procedure Puts_Uns
- (To : out String;
- Item : U.Unsigned;
- Base : Number_Base);
-
- procedure Puts_LLU
- (To : out String;
- Item : U.Long_Long_Unsigned;
- Base : Number_Base);
-
-end Ada.Wide_Wide_Text_IO.Modular_Aux;
-- --
------------------------------------------------------------------------------
-with Ada.Wide_Wide_Text_IO.Modular_Aux;
-
-with System.Unsigned_Types; use System.Unsigned_Types;
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_WtS; use System.WCh_WtS;
+with Ada.Wide_Wide_Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Uns; use System.Img_Uns;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLU; use System.Img_LLU;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Uns; use System.Val_Uns;
+with System.Val_LLU; use System.Val_LLU;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Wide_Text_IO.Modular_IO is
+ package Aux_Uns is new
+ Ada.Wide_Wide_Text_IO.Integer_Aux
+ (Unsigned,
+ Scan_Unsigned,
+ Set_Image_Unsigned,
+ Set_Image_Width_Unsigned,
+ Set_Image_Based_Unsigned);
+
+ package Aux_LLU is new
+ Ada.Wide_Wide_Text_IO.Integer_Aux
+ (Long_Long_Unsigned,
+ Scan_Long_Long_Unsigned,
+ Set_Image_Long_Long_Unsigned,
+ Set_Image_Width_Long_Long_Unsigned,
+ Set_Image_Based_Long_Long_Unsigned);
+
+ Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Unsigned is acceptable, and where a Long_Long_Unsigned is needed. This
+ -- Boolean is used to test for these cases and since it is a constant, only
+ -- code for the relevant case will be included in the instance.
+
subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
-- File type required for calls to routines in Aux
- package Aux renames Ada.Wide_Wide_Text_IO.Modular_Aux;
-
---------
-- Get --
---------
Item : out Num;
Width : Field := 0)
is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+
begin
- if Num'Size > Unsigned'Size then
- Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width);
+ if Need_LLU then
+ Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width);
else
- Aux.Get_Uns (TFT (File), Unsigned (Item), Width);
+ Aux_Uns.Get (TFT (File), Unsigned (Item), Width);
end if;
exception
Item : out Num;
Last : out Positive)
is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+
S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
-- String on which we do the actual conversion. Note that the method
-- used for wide character encoding is irrelevant, since if there is
-- Aux.Gets will raise Data_Error in any case.
begin
- if Num'Size > Unsigned'Size then
- Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last);
+ if Need_LLU then
+ Aux_LLU.Gets (S, Long_Long_Unsigned (Item), Last);
else
- Aux.Gets_Uns (S, Unsigned (Item), Last);
+ Aux_Uns.Gets (S, Unsigned (Item), Last);
end if;
exception
Base : Number_Base := Default_Base)
is
begin
- if Num'Size > Unsigned'Size then
- Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base);
+ if Need_LLU then
+ Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base);
else
- Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base);
+ Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base);
end if;
end Put;
S : String (To'First .. To'Last);
begin
- if Num'Size > Unsigned'Size then
- Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base);
+ if Need_LLU then
+ Aux_LLU.Puts (S, Long_Long_Unsigned (Item), Base);
else
- Aux.Puts_Uns (S, Unsigned (Item), Base);
+ Aux_Uns.Puts (S, Unsigned (Item), Base);
end if;
for J in S'Range loop
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-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.Wide_Wide_Text_IO.Integer_Aux;
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Uns; use System.Img_Uns;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLU; use System.Img_LLU;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_LLLB; use System.Img_LLLB;
+with System.Img_LLLU; use System.Img_LLLU;
+with System.Img_LLLW; use System.Img_LLLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Uns; use System.Val_Uns;
+with System.Val_LLU; use System.Val_LLU;
+with System.Val_LLLU; use System.Val_LLLU;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Wide_Text_IO.Modular_IO is
+
+ package Aux_Uns is new
+ Ada.Wide_Wide_Text_IO.Integer_Aux
+ (Unsigned,
+ Scan_Unsigned,
+ Set_Image_Unsigned,
+ Set_Image_Width_Unsigned,
+ Set_Image_Based_Unsigned);
+
+ package Aux_LLU is new
+ Ada.Wide_Wide_Text_IO.Integer_Aux
+ (Long_Long_Unsigned,
+ Scan_Long_Long_Unsigned,
+ Set_Image_Long_Long_Unsigned,
+ Set_Image_Width_Long_Long_Unsigned,
+ Set_Image_Based_Long_Long_Unsigned);
+
+ package Aux_LLLU is new
+ Ada.Wide_Wide_Text_IO.Integer_Aux
+ (Long_Long_Long_Unsigned,
+ Scan_Long_Long_Long_Unsigned,
+ Set_Image_Long_Long_Long_Unsigned,
+ Set_Image_Width_Long_Long_Long_Unsigned,
+ Set_Image_Based_Long_Long_Long_Unsigned);
+
+ Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size;
+ Need_LLLU : constant Boolean := Num'Base'Size > Long_Long_Unsigned'Size;
+ -- Throughout this generic body, we distinguish between cases where type
+ -- Unsigned is acceptable, where type Long_Long_Unsigned is acceptable and
+ -- where type Long_Long_Long_Unsigned is needed. These boolean constants
+ -- are used to test for these cases and since they are constant, only code
+ -- for the relevant case will be included in the instance.
+
+ subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Get (File, Long_Long_Long_Unsigned (Item), Width);
+ elsif Need_LLU then
+ Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width);
+ else
+ Aux_Uns.Get (TFT (File), Unsigned (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Gets (S, Long_Long_Long_Unsigned (Item), Last);
+ elsif Need_LLU then
+ Aux_LLU.Gets (S, Long_Long_Unsigned (Item), Last);
+ else
+ Aux_Uns.Gets (S, Unsigned (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Put (File, Long_Long_Long_Unsigned (Item), Width, Base);
+ elsif Need_LLU then
+ Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base);
+ else
+ Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ Put (Current_Output, Item, Width, Base);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Base : Number_Base := Default_Base)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Need_LLLU then
+ Aux_LLLU.Puts (S, Long_Long_Long_Unsigned (Item), Base);
+ elsif Need_LLU then
+ Aux_LLU.Puts (S, Long_Long_Unsigned (Item), Base);
+ else
+ Aux_Uns.Puts (S, Unsigned (Item), Base);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Modular_IO;
projects / gcc.git / commitdiff