procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Support of attributes Image, Put_Image, Val and Width for 128-bit types

Browse source 
gcc/ada/

	* Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-widint,
	s-widthi, s-widuns, s-widuns.
	(GNATRTL_128BIT_OBJS): Add s-imglllb, s-imgllli, s-imglllu, s-imglllw,
	s-valllli, s-vallllu, s-widllli, s-widlllu.
	* exp_imgv.adb (Expand_Image_Attribute): Deal with 128-bit types.
	(Expand_Value_Attribute): Likewise.
	(Expand_Width_Attribute): Likewise.
	* exp_put_image.adb (Build_Elementary_Put_Image_Call): Likewise.
	* krunch.adb (Krunch): Deal with s-img, s-val and s-wid prefixes.
	* rtsfind.ads (RTU_Id): Add System_Img_LLLI, System_Img_LLLU,
	System_Val_LLLI, System_Val_LLL, System_Wid_Int, System_Wid_LLLI,
	System_Wid_LLLU, System_Wid_Uns).
	(RE_Id): Add RE_Image_Long_Long_Long_Integer,
	RE_Image_Long_Long_Long_Unsigned,
	RE_Put_Image_Long_Long_Long_Integer,
	RE_Put_Image_Long_Long_Long_Unsigned,
	RE_Long_Long_Long_Unsigned, RE_Value_Long_Long_Long_Integer,
	RE_Value_Long_Long_Long_Unsigned, RE_Width_Integer,
	RE_Width_Long_Long_Long_Integer, RE_Width_Long_Long_Long_Unsigned,
	RE_Width_Unsigned, RE_Image_Long_Long_Long_Integer,
	RE_Image_Long_Long_Long_Unsigned, RE_Put_Image_Long_Long_Long_Integer,
	RE_Put_Image_Long_Long_Long_Unsigned, RE_Long_Long_Long_Unsigned,
	RE_Value_Long_Long_Long_Integer, RE_Value_Long_Long_Long_Unsigned,
	RE_Width_Integer, RE_Width_Long_Long_Long_Integer,
	RE_Width_Long_Long_Long_Unsigned, RE_Width_Unsigned.
	* libgnat/s-imageb.ads, libgnat/s-imageb.adb: New generic
	package.
	* libgnat/s-imagei.ads, libgnat/s-imagei.adb: Likewise.
	* libgnat/s-imageu.ads, libgnat/s-imageu.adb: Likewise.
	* libgnat/s-imagew.ads, libgnat/s-imagew.adb: Likewise.
	* libgnat/s-imgbiu.ads: Instantiate System.Image_B.
	* libgnat/s-imgbiu.adb: Add pragma No_Body.
	* libgnat/s-imgint.ads: Instantiate System.Image_I.
	* libgnat/s-imgint.adb: Add pragma No_Body.
	* libgnat/s-imgllb.ads: Instantiate System.Image_B.
	* libgnat/s-imgllb.adb: Add pragma No_Body0
	* libgnat/s-imglli.ads: Instantiate System.Image_I.
	* libgnat/s-imglli.adb: Add pragma No_Body.
	* libgnat/s-imglllb.ads: Instantiate System.Image_B.
	* libgnat/s-imgllli.ads: Instantiate System.Image_I.
	* libgnat/s-imglllu.ads: Instantiate System.Image_U.
	* libgnat/s-imglllw.ads: Instantiate System.Image_W.
	* libgnat/s-imgllu.ads: Instantiate System.Image_U.
	* libgnat/s-imgllu.adb: Add pragma No_Body.
	* libgnat/s-imgllw.ads: Instantiate System.Image_W.
	* libgnat/s-imgllw.adb: Add pragma No_Body.
	* libgnat/s-imgrea.adb: Remove clauses for System.Unsigned_Types.
	* libgnat/s-imguns.ads: Instantiate System.Image_U.
	* libgnat/s-imguns.adb: Add pragma No_Body.
	* libgnat/s-imgwiu.ads: Instantiate System.Image_W.
	* libgnat/s-imgwiu.adb: Add pragma No_Body.
	* libgnat/s-putima.ads (Long_Long_Long_Unsigned): New subtype.
	(Put_Image_Long_Long_Long_Unsigned): New procedure.
	* libgnat/s-putima.adb (Small): Rename to Integer_Images.
	(Large): Rename to LL_Integer_Images.
	(LLL_Integer_Images): New instantiation.
	(Put_Image_Long_Long_Long_Integer): New renaming.
	(Put_Image_Long_Long_Long_Unsigned): Likewise.
	* libgnat/s-valint.ads: Instantiate System.Value_I.
	* libgnat/s-valint.adb: Add pragma No_Body.
	* libgnat/s-vallli.ads: Instantiate System.Value_I.
	* libgnat/s-vallli.adb: Add pragma No_Body.
	* libgnat/s-valllli.ads: Instantiate System.Value_I.
	* libgnat/s-vallllu.ads: Instantiate System.Value_U.
	* libgnat/s-valllu.ads: Instantiate System.Value_U.
	* libgnat/s-valllu.adb: Add pragma No_Body.
	* libgnat/s-valuei.ads, libgnat/s-valuei.adb: New generic
	package.
	* libgnat/s-valueu.ads, libgnat/s-valueu.adb: Likewise.
	* libgnat/s-valuns.ads: Instantiate System.Value_U.
	* libgnat/s-valuns.adb: Add pragma No_Body.
	* libgnat/s-widint.ads: Instantiate System.Width_I.
	* libgnat/s-widlli.ads: Likewise.
	* libgnat/s-widlli.adb: Add pragma No_Body.
	* libgnat/s-widllli.ads: Instantiate System.Width_I.
	* libgnat/s-widlllu.ads: Instantiate System.Width_U.
	* libgnat/s-widllu.ads: Likewise.
	* libgnat/s-widllu.adb: Add pragma No_Body.
	* libgnat/s-widthi.ads, libgnat/s-widthi.adb: New generic
	package.
	* libgnat/s-widthu.ads, libgnat/s-widthu.adb: Likewise.
	* libgnat/s-widuns.ads: Instantiate System.Width_U.
This commit is contained in:
Eric Botcazou 2020-06-27 12:39:49 +02:00 • committed by Pierre-Marie de Rodat
parent a219511d1d
commit cb7584a41d
62 changed files with 2517 additions and 2015 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
gcc/ada/Makefile.rtl
View file

@ -604,6 +604,10 @@ GNATRTL_NONTASKING_OBJS= \
s-geveop$(objext) \
s-gloloc$(objext) \
s-htable$(objext) \
s-imageb$(objext) \
s-imagei$(objext) \
s-imageu$(objext) \
s-imagew$(objext) \
s-imenne$(objext) \
s-imgbiu$(objext) \
s-imgboo$(objext) \
@ -738,6 +742,8 @@ GNATRTL_NONTASKING_OBJS= \
s-vallli$(objext) \
s-valllu$(objext) \
s-valrea$(objext) \
s-valuei$(objext) \
s-valueu$(objext) \
s-valuns$(objext) \
s-valuti$(objext) \
s-valwch$(objext) \
@ -752,8 +758,12 @@ GNATRTL_NONTASKING_OBJS= \
s-widboo$(objext) \
s-widcha$(objext) \
s-widenu$(objext) \
s-widint$(objext) \
s-widlli$(objext) \
s-widllu$(objext) \
s-widthi$(objext) \
s-widthu$(objext) \
s-widuns$(objext) \
s-widwch$(objext) \
s-wwdcha$(objext) \
s-wwdenu$(objext) \
@ -883,6 +893,10 @@ GNATRTL_128BIT_OBJS = \
s-exnllli$(objext) \
s-expllli$(objext) \
s-explllu$(objext) \
s-imglllb$(objext) \
s-imgllli$(objext) \
s-imglllu$(objext) \
s-imglllw$(objext) \
s-pack65$(objext) \
s-pack66$(objext) \
s-pack67$(objext) \
@ -945,7 +959,11 @@ GNATRTL_128BIT_OBJS = \
s-pack124$(objext) \
s-pack125$(objext) \
s-pack126$(objext) \
s-pack127$(objext)
s-pack127$(objext) \
s-valllli$(objext) \
s-vallllu$(objext) \
s-widllli$(objext) \
s-widlllu$(objext)
# Shared library version
LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(GNAT_SRC)/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/'))

54
gcc/ada/exp_imgv.adb
View file

@ -570,21 +570,27 @@ package body Exp_Imgv is
Tent := Rtyp;
elsif Is_Signed_Integer_Type (Rtyp) then
if Esize (Rtyp) <= Esize (Standard_Integer) then
if Esize (Rtyp) <= Standard_Integer_Size then
Imid := RE_Image_Integer;
Tent := Standard_Integer;
else
elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
Imid := RE_Image_Long_Long_Integer;
Tent := Standard_Long_Long_Integer;
else
Imid := RE_Image_Long_Long_Long_Integer;
Tent := Standard_Long_Long_Long_Integer;
end if;
elsif Is_Modular_Integer_Type (Rtyp) then
if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
Imid := RE_Image_Unsigned;
Tent := RTE (RE_Unsigned);
else
elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then
Imid := RE_Image_Long_Long_Unsigned;
Tent := RTE (RE_Long_Long_Unsigned);
else
Imid := RE_Image_Long_Long_Long_Unsigned;
Tent := RTE (RE_Long_Long_Long_Unsigned);
end if;
elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then
@ -895,20 +901,22 @@ package body Exp_Imgv is
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)));
elsif Rtyp = Base_Type (Standard_Short_Short_Integer)
or else Rtyp = Base_Type (Standard_Short_Integer)
or else Rtyp = Base_Type (Standard_Integer)
then
Vid := RE_Value_Integer;
elsif Is_Signed_Integer_Type (Rtyp) then
Vid := RE_Value_Long_Long_Integer;
if Esize (Rtyp) <= Standard_Integer_Size then
Vid := RE_Value_Integer;
elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
Vid := RE_Value_Long_Long_Integer;
else
Vid := RE_Value_Long_Long_Long_Integer;
end if;
elsif Is_Modular_Integer_Type (Rtyp) then
if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
Vid := RE_Value_Unsigned;
else
elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then
Vid := RE_Value_Long_Long_Unsigned;
else
Vid := RE_Value_Long_Long_Long_Unsigned;
end if;
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
@ -1415,14 +1423,30 @@ package body Exp_Imgv is
-- Signed integer types
elsif Is_Signed_Integer_Type (Rtyp) then
XX := RE_Width_Long_Long_Integer;
YY := Standard_Long_Long_Integer;
if Esize (Rtyp) <= Standard_Integer_Size then
XX := RE_Width_Integer;
YY := Standard_Integer;
elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
XX := RE_Width_Long_Long_Integer;
YY := Standard_Long_Long_Integer;
else
XX := RE_Width_Long_Long_Long_Integer;
YY := Standard_Long_Long_Long_Integer;
end if;
-- Modular integer types
elsif Is_Modular_Integer_Type (Rtyp) then
XX := RE_Width_Long_Long_Unsigned;
YY := RTE (RE_Long_Long_Unsigned);
if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
XX := RE_Width_Unsigned;
YY := RTE (RE_Unsigned);
elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then
XX := RE_Width_Long_Long_Unsigned;
YY := RTE (RE_Long_Long_Unsigned);
else
XX := RE_Width_Long_Long_Long_Unsigned;
YY := RTE (RE_Long_Long_Long_Unsigned);
end if;
-- Real types

12
gcc/ada/exp_put_image.adb
View file

@ -300,17 +300,21 @@ package body Exp_Put_Image is
if Is_Signed_Integer_Type (U_Type) then
if P_Size <= Standard_Integer_Size then
Lib_RE := RE_Put_Image_Integer;
else
pragma Assert (P_Size <= Standard_Long_Long_Integer_Size);
elsif P_Size <= Standard_Long_Long_Integer_Size then
Lib_RE := RE_Put_Image_Long_Long_Integer;
else
pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size);
Lib_RE := RE_Put_Image_Long_Long_Long_Integer;
end if;
elsif Is_Modular_Integer_Type (U_Type) then
if P_Size <= Standard_Integer_Size then -- Yes, Integer
Lib_RE := RE_Put_Image_Unsigned;
else
pragma Assert (P_Size <= Standard_Long_Long_Integer_Size);
elsif P_Size <= Standard_Long_Long_Integer_Size then
Lib_RE := RE_Put_Image_Long_Long_Unsigned;
else
pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size);
Lib_RE := RE_Put_Image_Long_Long_Long_Unsigned;
end if;
elsif Is_Access_Type (U_Type) then

3
gcc/ada/krunch.adb
View file

@ -92,6 +92,9 @@ begin
if Buffer (Curlen - 2 .. Curlen) = "128"
or else Buffer (3 .. 9) = "exn_lll"
or else Buffer (3 .. 9) = "exp_lll"
or else Buffer (3 .. 9) = "img_lll"
or else Buffer (3 .. 9) = "val_lll"
or else Buffer (3 .. 9) = "wid_lll"
or else (Buffer (3 .. 6) = "pack" and then Curlen = 10)
then
if Buffer (3 .. 15) = "compare_array" then

156
gcc/ada/libgnat/s-imageb.adb Normal file
View file

@ -0,0 +1,156 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M A G E _ B --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
package body System.Image_B is
-----------------------------
-- Set_Image_Based_Integer --
-----------------------------
procedure Set_Image_Based_Integer
(V : Int;
B : Natural;
W : Integer;
S : out String;
P : in out Natural)
is
Start : Natural;
begin
-- Positive case can just use the unsigned circuit directly
if V >= 0 then
Set_Image_Based_Unsigned (Uns (V), B, W, S, P);
-- Negative case has to set a minus sign. Note also that we have to be
-- careful not to generate overflow with the largest negative number.
else
P := P + 1;
S (P) := ' ';
Start := P;
declare
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
begin
Set_Image_Based_Unsigned (Uns (-V), B, W - 1, S, P);
end;
-- Set minus sign in last leading blank location. Because of the
-- code above, there must be at least one such location.
while S (Start + 1) = ' ' loop
Start := Start + 1;
end loop;
S (Start) := '-';
end if;
end Set_Image_Based_Integer;
------------------------------
-- Set_Image_Based_Unsigned --
------------------------------
procedure Set_Image_Based_Unsigned
(V : Uns;
B : Natural;
W : Integer;
S : out String;
P : in out Natural)
is
Start : constant Natural := P;
F, T : Natural;
BU : constant Uns := Uns (B);
Hex : constant array
(Uns range 0 .. 15) of Character := "0123456789ABCDEF";
procedure Set_Digits (T : Uns);
-- Set digits of absolute value of T
----------------
-- Set_Digits --
----------------
procedure Set_Digits (T : Uns) is
begin
if T >= BU then
Set_Digits (T / BU);
P := P + 1;
S (P) := Hex (T mod BU);
else
P := P + 1;
S (P) := Hex (T);
end if;
end Set_Digits;
-- Start of processing for Set_Image_Based_Unsigned
begin
if B >= 10 then
P := P + 1;
S (P) := '1';
end if;
P := P + 1;
S (P) := Character'Val (Character'Pos ('0') + B mod 10);
P := P + 1;
S (P) := '#';
Set_Digits (V);
P := P + 1;
S (P) := '#';
-- Add leading spaces if required by width parameter
if P - Start < W then
F := P;
P := Start + W;
T := P;
while F > Start loop
S (T) := S (F);
T := T - 1;
F := F - 1;
end loop;
for J in Start + 1 .. T loop
S (J) := ' ';
end loop;
end if;
end Set_Image_Based_Unsigned;
end System.Image_B;

75
gcc/ada/libgnat/s-imageb.ads Normal file
View file

@ -0,0 +1,75 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M A G E _ B --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- Contains the routine for computing the image in based format of signed and
-- unsigned integers for use by Text_IO.Integer_IO and Text_IO.Modular_IO.
generic
type Int is range <>;
type Uns is mod <>;
package System.Image_B is
pragma Pure;
procedure Set_Image_Based_Integer
(V : Int;
B : Natural;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the signed image of V in based format, using base value B (2..16)
-- starting at S (P + 1), updating P to point to the last character stored.
-- The image includes a leading minus sign if necessary, but no leading
-- spaces unless W is positive, in which case leading spaces are output if
-- necessary to ensure that the output string is no less than W characters
-- long. The caller promises that the buffer is large enough and no check
-- is made for this. Constraint_Error will not necessarily be raised if
-- this is violated, since it is perfectly valid to compile this unit with
-- checks off.
procedure Set_Image_Based_Unsigned
(V : Uns;
B : Natural;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the unsigned image of V in based format, using base value B (2..16)
-- starting at S (P + 1), updating P to point to the last character stored.
-- The image includes no leading spaces unless W is positive, in which case
-- leading spaces are output if necessary to ensure that the output string
-- is no less than W characters long. The caller promises that the buffer
-- is large enough and no check is made for this. Constraint_Error will not
-- necessarily be raised if this is violated, since it is perfectly valid
-- to compile this unit with checks off).
end System.Image_B;

121
gcc/ada/libgnat/s-imagei.adb Normal file
View file

@ -0,0 +1,121 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M A G E _ I --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
package body System.Image_I is
subtype Non_Positive is Int range Int'First .. 0;
procedure Set_Digits
(T : Non_Positive;
S : in out String;
P : in out Natural);
-- Set digits of absolute value of T, which is zero or negative. We work
-- with the negative of the value so that the largest negative number is
-- not a special case.
-------------------
-- Image_Integer --
-------------------
procedure Image_Integer
(V : Int;
S : in out String;
P : out Natural)
is
pragma Assert (S'First = 1);
begin
if V >= 0 then
S (1) := ' ';
P := 1;
else
P := 0;
end if;
Set_Image_Integer (V, S, P);
end Image_Integer;
----------------
-- Set_Digits --
----------------
procedure Set_Digits
(T : Non_Positive;
S : in out String;
P : in out Natural)
is
begin
if T <= -10 then
Set_Digits (T / 10, S, P);
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the Set_Image_Integer
-- specification, the caller guarantees that S is long enough to
-- hold the result.
P := P + 1;
S (P) := Character'Val (48 - (T rem 10));
else
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the Set_Image_Integer
-- specification, the caller guarantees that S is long enough to
-- hold the result.
P := P + 1;
S (P) := Character'Val (48 - T);
end if;
end Set_Digits;
-----------------------
-- Set_Image_Integer --
-----------------------
procedure Set_Image_Integer
(V : Int;
S : in out String;
P : in out Natural)
is
begin
if V >= 0 then
Set_Digits (-V, S, P);
else
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := '-';
Set_Digits (V, S, P);
end if;
end Set_Image_Integer;
end System.Image_I;

61
gcc/ada/libgnat/s-imagei.ads Normal file
View file

@ -0,0 +1,61 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M A G E _ I --
-- --
-- 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 supporting the Image attribute for
-- signed integer types, and also for conversion operations required in
-- Text_IO.Integer_IO for such types.
generic
type Int is range <>;
package System.Image_I is
pragma Pure;
procedure Image_Integer
(V : Int;
S : in out String;
P : out Natural);
-- Computes Int'Image (V) and stores the result in S (1 .. P)
-- setting the resulting value of P. The caller guarantees that S
-- is long enough to hold the result, and that S'First is 1.
procedure Set_Image_Integer
(V : Int;
S : in out String;
P : in out Natural);
-- Stores the image of V in S starting at S (P + 1), P is updated to point
-- to the last character stored. The value stored is identical to the value
-- of Int'Image (V) except that no leading space is stored when V is
-- non-negative. The caller guarantees that S is long enough to hold the
-- result. S need not have a lower bound of 1.
end System.Image_I;

79
gcc/ada/libgnat/s-imageu.adb Normal file
View file

@ -0,0 +1,79 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M A G E _ U --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
package body System.Image_U is
--------------------
-- Image_Unsigned --
--------------------
procedure Image_Unsigned
(V : Uns;
S : in out String;
P : out Natural)
is
pragma Assert (S'First = 1);
begin
S (1) := ' ';
P := 1;
Set_Image_Unsigned (V, S, P);
end Image_Unsigned;
------------------------
-- Set_Image_Unsigned --
------------------------
procedure Set_Image_Unsigned
(V : Uns;
S : in out String;
P : in out Natural)
is
begin
if V >= 10 then
Set_Image_Unsigned (V / 10, S, P);
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := Character'Val (48 + (V rem 10));
else
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := Character'Val (48 + V);
end if;
end Set_Image_Unsigned;
end System.Image_U;

62
gcc/ada/libgnat/s-imageu.ads Normal file
View file

@ -0,0 +1,62 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M A G E _ U --
-- --
-- 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 supporting the Image attribute for
-- modular integer types, and also for conversion operations required in
-- Text_IO.Modular_IO for such types.
generic
type Uns is mod <>;
package System.Image_U is
pragma Pure;
procedure Image_Unsigned
(V : Uns;
S : in out String;
P : out Natural);
pragma Inline (Image_Unsigned);
-- Computes Uns'Image (V) and stores the result in S (1 .. P) setting
-- the resulting value of P. The caller guarantees that S is long enough to
-- hold the result, and that S'First is 1.
procedure Set_Image_Unsigned
(V : Uns;
S : in out String;
P : in out Natural);
-- Stores the image of V in S starting at S (P + 1), P is updated to point
-- to the last character stored. The value stored is identical to the value
-- of Uns'Image (V) except that no leading space is stored. The caller
-- guarantees that S is long enough to hold the result. S need not have a
-- lower bound of 1.
end System.Image_U;

152
gcc/ada/libgnat/s-imagew.adb Normal file
View file

@ -0,0 +1,152 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M A G E _ W --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
package body System.Image_W is
-----------------------------
-- Set_Image_Width_Integer --
-----------------------------
procedure Set_Image_Width_Integer
(V : Int;
W : Integer;
S : out String;
P : in out Natural)
is
Start : Natural;
begin
-- Positive case can just use the unsigned circuit directly
if V >= 0 then
Set_Image_Width_Unsigned (Uns (V), W, S, P);
-- Negative case has to set a minus sign. Note also that we have to be
-- careful not to generate overflow with the largest negative number.
else
P := P + 1;
S (P) := ' ';
Start := P;
declare
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
begin
Set_Image_Width_Unsigned (Uns (-V), W - 1, S, P);
end;
-- Set minus sign in last leading blank location. Because of the
-- code above, there must be at least one such location.
while S (Start + 1) = ' ' loop
Start := Start + 1;
end loop;
S (Start) := '-';
end if;
end Set_Image_Width_Integer;
------------------------------
-- Set_Image_Width_Unsigned --
------------------------------
procedure Set_Image_Width_Unsigned
(V : Uns;
W : Integer;
S : out String;
P : in out Natural)
is
Start : constant Natural := P;
F, T : Natural;
procedure Set_Digits (T : Uns);
-- Set digits of absolute value of T
----------------
-- Set_Digits --
----------------
procedure Set_Digits (T : Uns) is
begin
if T >= 10 then
Set_Digits (T / 10);
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := Character'Val (T mod 10 + Character'Pos ('0'));
else
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := Character'Val (T + Character'Pos ('0'));
end if;
end Set_Digits;
-- Start of processing for Set_Image_Width_Unsigned
begin
Set_Digits (V);
-- Add leading spaces if required by width parameter
if P - Start < W then
F := P;
P := P + (W - (P - Start));
T := P;
while F > Start loop
pragma Assert (T >= S'First and T <= S'Last and
F >= S'First and F <= S'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
S (T) := S (F);
T := T - 1;
F := F - 1;
end loop;
for J in Start + 1 .. T loop
pragma Assert (J >= S'First and J <= S'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
S (J) := ' ';
end loop;
end if;
end Set_Image_Width_Unsigned;
end System.Image_W;

73
gcc/ada/libgnat/s-imagew.ads Normal file
View file

@ -0,0 +1,73 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M A G E _ W --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- Contains the routine for computing the image of signed and unsigned
-- integers up to Integer for use by Text_IO.Integer_IO and
-- Text_IO.Modular_IO.
generic
type Int is range <>;
type Uns is mod <>;
package System.Image_W is
pragma Pure;
procedure Set_Image_Width_Integer
(V : Int;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the signed image of V in decimal format, starting at S (P + 1),
-- updating P to point to the last character stored. The image includes
-- a leading minus sign if necessary, but no leading spaces unless W is
-- positive, in which case leading spaces are output if necessary to ensure
-- that the output string is no less than W characters long. The caller
-- promises that the buffer is large enough and no check is made for this.
-- Constraint_Error will not necessarily be raised if this is violated,
-- since it is perfectly valid to compile this unit with checks off.
procedure Set_Image_Width_Unsigned
(V : Uns;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the unsigned image of V in decimal format, starting at S (P + 1),
-- updating P to point to the last character stored. The image includes no
-- leading spaces unless W is positive, in which case leading spaces are
-- output if necessary to ensure that the output string is no less than
-- W characters long. The caller promises that the buffer is large enough
-- and no check is made for this. Constraint_Error will not necessarily be
-- raised if this is violated, since it is perfectly valid to compile this
-- unit with checks off.
end System.Image_W;

130
gcc/ada/libgnat/s-imgbiu.adb
View file

@ -29,130 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Img_BIU is
-----------------------------
-- Set_Image_Based_Integer --
-----------------------------
procedure Set_Image_Based_Integer
(V : Integer;
B : Natural;
W : Integer;
S : out String;
P : in out Natural)
is
Start : Natural;
begin
-- Positive case can just use the unsigned circuit directly
if V >= 0 then
Set_Image_Based_Unsigned (Unsigned (V), B, W, S, P);
-- Negative case has to set a minus sign. Note also that we have to be
-- careful not to generate overflow with the largest negative number.
else
P := P + 1;
S (P) := ' ';
Start := P;
declare
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
begin
Set_Image_Based_Unsigned (Unsigned (-V), B, W - 1, S, P);
end;
-- Set minus sign in last leading blank location. Because of the
-- code above, there must be at least one such location.
while S (Start + 1) = ' ' loop
Start := Start + 1;
end loop;
S (Start) := '-';
end if;
end Set_Image_Based_Integer;
------------------------------
-- Set_Image_Based_Unsigned --
------------------------------
procedure Set_Image_Based_Unsigned
(V : Unsigned;
B : Natural;
W : Integer;
S : out String;
P : in out Natural)
is
Start : constant Natural := P;
F, T : Natural;
BU : constant Unsigned := Unsigned (B);
Hex : constant array
(Unsigned range 0 .. 15) of Character := "0123456789ABCDEF";
procedure Set_Digits (T : Unsigned);
-- Set digits of absolute value of T
----------------
-- Set_Digits --
----------------
procedure Set_Digits (T : Unsigned) is
begin
if T >= BU then
Set_Digits (T / BU);
P := P + 1;
S (P) := Hex (T mod BU);
else
P := P + 1;
S (P) := Hex (T);
end if;
end Set_Digits;
-- Start of processing for Set_Image_Based_Unsigned
begin
if B >= 10 then
P := P + 1;
S (P) := '1';
end if;
P := P + 1;
S (P) := Character'Val (Character'Pos ('0') + B mod 10);
P := P + 1;
S (P) := '#';
Set_Digits (V);
P := P + 1;
S (P) := '#';
-- Add leading spaces if required by width parameter
if P - Start < W then
F := P;
P := Start + W;
T := P;
while F > Start loop
S (T) := S (F);
T := T - 1;
F := F - 1;
end loop;
for J in Start + 1 .. T loop
S (J) := ' ';
end loop;
end if;
end Set_Image_Based_Unsigned;
end System.Img_BIU;
pragma No_Body;

34
gcc/ada/libgnat/s-imgbiu.ads
View file

@ -30,43 +30,33 @@
------------------------------------------------------------------------------
-- Contains the routine for computing the image in based format of signed and
-- unsigned integers whose size <= Integer'Size for use by Text_IO.Integer_IO
-- and Text_IO.Modular_IO.
-- unsigned integers up to Integer for use by Text_IO.Integer_IO and
-- Text_IO.Modular_IO.
with System.Image_B;
with System.Unsigned_Types;
package System.Img_BIU is
pragma Pure;
subtype Unsigned is Unsigned_Types.Unsigned;
package Impl is new Image_B (Integer, Unsigned);
procedure Set_Image_Based_Integer
(V : Integer;
B : Natural;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the signed image of V in based format, using base value B (2..16)
-- starting at S (P + 1), updating P to point to the last character stored.
-- The image includes a leading minus sign if necessary, but no leading
-- spaces unless W is positive, in which case leading spaces are output if
-- necessary to ensure that the output string is no less than W characters
-- long. The caller promises that the buffer is large enough and no check
-- is made for this. Constraint_Error will not necessarily be raised if
-- this is violated, since it is perfectly valid to compile this unit with
-- checks off.
P : in out Natural)
renames Impl.Set_Image_Based_Integer;
procedure Set_Image_Based_Unsigned
(V : System.Unsigned_Types.Unsigned;
(V : Unsigned;
B : Natural;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the unsigned image of V in based format, using base value B (2..16)
-- starting at S (P + 1), updating P to point to the last character stored.
-- The image includes no leading spaces unless W is positive, in which case
-- leading spaces are output if necessary to ensure that the output string
-- is no less than W characters long. The caller promises that the buffer
-- is large enough and no check is made for this. Constraint_Error will not
-- necessarily be raised if this is violated, since it is perfectly valid
-- to compile this unit with checks off).
P : in out Natural)
renames Impl.Set_Image_Based_Unsigned;
end System.Img_BIU;

91
gcc/ada/libgnat/s-imgint.adb
View file

@ -29,91 +29,8 @@
-- --
------------------------------------------------------------------------------
package body System.Img_Int is
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
subtype Non_Positive is Integer range Integer'First .. 0;
procedure Set_Digits
(T : Non_Positive;
S : in out String;
P : in out Natural);
-- Set digits of absolute value of T, which is zero or negative. We work
-- with the negative of the value so that the largest negative number is
-- not a special case.
-------------------
-- Image_Integer --
-------------------
procedure Image_Integer
(V : Integer;
S : in out String;
P : out Natural)
is
pragma Assert (S'First = 1);
begin
if V >= 0 then
S (1) := ' ';
P := 1;
else
P := 0;
end if;
Set_Image_Integer (V, S, P);
end Image_Integer;
----------------
-- Set_Digits --
----------------
procedure Set_Digits
(T : Non_Positive;
S : in out String;
P : in out Natural)
is
begin
if T <= -10 then
Set_Digits (T / 10, S, P);
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the Set_Image_Integer
-- specification, the caller guarantees that S is long enough to
-- hold the result.
P := P + 1;
S (P) := Character'Val (48 - (T rem 10));
else
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the Set_Image_Integer
-- specification, the caller guarantees that S is long enough to
-- hold the result.
P := P + 1;
S (P) := Character'Val (48 - T);
end if;
end Set_Digits;
-----------------------
-- Set_Image_Integer --
-----------------------
procedure Set_Image_Integer
(V : Integer;
S : in out String;
P : in out Natural)
is
begin
if V >= 0 then
Set_Digits (-V, S, P);
else
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := '-';
Set_Digits (V, S, P);
end if;
end Set_Image_Integer;
end System.Img_Int;
pragma No_Body;

22
gcc/ada/libgnat/s-imgint.ads
View file

@ -30,28 +30,26 @@
------------------------------------------------------------------------------
-- This package contains the routines for supporting the Image attribute for
-- signed integer types up to Size Integer'Size, and also for conversion
-- operations required in Text_IO.Integer_IO for such types.
-- signed integer types up to Integer, and also for conversion operations
-- required in Text_IO.Integer_IO for such types.
with System.Image_I;
package System.Img_Int is
pragma Pure;
package Impl is new Image_I (Integer);
procedure Image_Integer
(V : Integer;
S : in out String;
P : out Natural);
-- Computes Integer'Image (V) and stores the result in S (1 .. P)
-- setting the resulting value of P. The caller guarantees that S
-- is long enough to hold the result, and that S'First is 1.
P : out Natural)
renames Impl.Image_Integer;
procedure Set_Image_Integer
(V : Integer;
S : in out String;
P : in out Natural);
-- Stores the image of V in S starting at S (P + 1), P is updated to point
-- to the last character stored. The value stored is identical to the value
-- of Integer'Image (V) except that no leading space is stored when V is
-- non-negative. The caller guarantees that S is long enough to hold the
-- result. S need not have a lower bound of 1.
P : in out Natural)
renames Impl.Set_Image_Integer;
end System.Img_Int;

133
gcc/ada/libgnat/s-imgllb.adb
View file

@ -29,133 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Img_LLB is
---------------------------------------
-- Set_Image_Based_Long_Long_Integer --
---------------------------------------
procedure Set_Image_Based_Long_Long_Integer
(V : Long_Long_Integer;
B : Natural;
W : Integer;
S : out String;
P : in out Natural)
is
Start : Natural;
begin
-- Positive case can just use the unsigned circuit directly
if V >= 0 then
Set_Image_Based_Long_Long_Unsigned
(Long_Long_Unsigned (V), B, W, S, P);
-- Negative case has to set a minus sign. Note also that we have to be
-- careful not to generate overflow with the largest negative number.
else
P := P + 1;
S (P) := ' ';
Start := P;
declare
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
begin
Set_Image_Based_Long_Long_Unsigned
(Long_Long_Unsigned (-V), B, W - 1, S, P);
end;
-- Set minus sign in last leading blank location. Because of the
-- code above, there must be at least one such location.
while S (Start + 1) = ' ' loop
Start := Start + 1;
end loop;
S (Start) := '-';
end if;
end Set_Image_Based_Long_Long_Integer;
----------------------------------------
-- Set_Image_Based_Long_Long_Unsigned --
----------------------------------------
procedure Set_Image_Based_Long_Long_Unsigned
(V : Long_Long_Unsigned;
B : Natural;
W : Integer;
S : out String;
P : in out Natural)
is
Start : constant Natural := P;
F, T : Natural;
BU : constant Long_Long_Unsigned := Long_Long_Unsigned (B);
Hex : constant array
(Long_Long_Unsigned range 0 .. 15) of Character :=
"0123456789ABCDEF";
procedure Set_Digits (T : Long_Long_Unsigned);
-- Set digits of absolute value of T
----------------
-- Set_Digits --
----------------
procedure Set_Digits (T : Long_Long_Unsigned) is
begin
if T >= BU then
Set_Digits (T / BU);
P := P + 1;
S (P) := Hex (T mod BU);
else
P := P + 1;
S (P) := Hex (T);
end if;
end Set_Digits;
-- Start of processing for Set_Image_Based_Long_Long_Unsigned
begin
if B >= 10 then
P := P + 1;
S (P) := '1';
end if;
P := P + 1;
S (P) := Character'Val (Character'Pos ('0') + B mod 10);
P := P + 1;
S (P) := '#';
Set_Digits (V);
P := P + 1;
S (P) := '#';
-- Add leading spaces if required by width parameter
if P - Start < W then
F := P;
P := Start + W;
T := P;
while F > Start loop
S (T) := S (F);
T := T - 1;
F := F - 1;
end loop;
for J in Start + 1 .. T loop
S (J) := ' ';
end loop;
end if;
end Set_Image_Based_Long_Long_Unsigned;
end System.Img_LLB;
pragma No_Body;

34
gcc/ada/libgnat/s-imgllb.ads
View file

@ -30,43 +30,33 @@
------------------------------------------------------------------------------
-- Contains the routine for computing the image in based format of signed and
-- unsigned integers whose size > Integer'Size for use by Text_IO.Integer_IO
-- and Text_IO.Modular_IO.
-- unsigned integers larger than Integer for use by Text_IO.Integer_IO and
-- Text_IO.Modular_IO.
with System.Image_B;
with System.Unsigned_Types;
package System.Img_LLB is
pragma Preelaborate;
subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
package Impl is new Image_B (Long_Long_Integer, Long_Long_Unsigned);
procedure Set_Image_Based_Long_Long_Integer
(V : Long_Long_Integer;
B : Natural;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the signed image of V in based format, using base value B (2..16)
-- starting at S (P + 1), updating P to point to the last character stored.
-- The image includes a leading minus sign if necessary, but no leading
-- spaces unless W is positive, in which case leading spaces are output if
-- necessary to ensure that the output string is no less than W characters
-- long. The caller promises that the buffer is large enough and no check
-- is made for this. Constraint_Error will not necessarily be raised if
-- this is violated, since it is perfectly valid to compile this unit with
-- checks off.
P : in out Natural)
renames Impl.Set_Image_Based_Integer;
procedure Set_Image_Based_Long_Long_Unsigned
(V : System.Unsigned_Types.Long_Long_Unsigned;
(V : Long_Long_Unsigned;
B : Natural;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the unsigned image of V in based format, using base value B (2..16)
-- starting at S (P + 1), updating P to point to the last character stored.
-- The image includes no leading spaces unless W is positive, in which case
-- leading spaces are output if necessary to ensure that the output string
-- is no less than W characters long. The caller promises that the buffer
-- is large enough and no check is made for this. Constraint_Error will not
-- necessarily be raised if this is violated, since it is perfectly valid
-- to compile this unit with checks off).
P : in out Natural)
renames Impl.Set_Image_Based_Unsigned;
end System.Img_LLB;

91
gcc/ada/libgnat/s-imglli.adb
View file

@ -29,91 +29,8 @@
-- --
------------------------------------------------------------------------------
package body System.Img_LLI is
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
subtype Non_Positive is Long_Long_Integer
range Long_Long_Integer'First .. 0;
procedure Set_Digits
(T : Non_Positive;
S : in out String;
P : in out Natural);
-- Set digits of absolute value of T, which is zero or negative. We work
-- with the negative of the value so that the largest negative number is
-- not a special case.
-----------------------------
-- Image_Long_Long_Integer --
-----------------------------
procedure Image_Long_Long_Integer
(V : Long_Long_Integer;
S : in out String;
P : out Natural)
is
pragma Assert (S'First = 1);
begin
if V >= 0 then
S (1) := ' ';
P := 1;
else
P := 0;
end if;
Set_Image_Long_Long_Integer (V, S, P);
end Image_Long_Long_Integer;
----------------
-- Set_Digits --
----------------
procedure Set_Digits
(T : Non_Positive;
S : in out String;
P : in out Natural)
is
begin
if T <= -10 then
Set_Digits (T / 10, S, P);
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done as documented in the Set_Image_Long_Long_Integer
-- specification: The caller guarantees that S is long enough to
-- hold the result.
P := P + 1;
S (P) := Character'Val (48 - (T rem 10));
else
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done as documented in the Set_Image_Long_Long_Integer
-- specification: The caller guarantees that S is long enough to
-- hold the result.
P := P + 1;
S (P) := Character'Val (48 - T);
end if;
end Set_Digits;
---------------------------------
-- Set_Image_Long_Long_Integer --
--------------------------------
procedure Set_Image_Long_Long_Integer
(V : Long_Long_Integer;
S : in out String;
P : in out Natural) is
begin
if V >= 0 then
Set_Digits (-V, S, P);
else
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done as documented in the specification:
-- The caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := '-';
Set_Digits (V, S, P);
end if;
end Set_Image_Long_Long_Integer;
end System.Img_LLI;
pragma No_Body;

22
gcc/ada/libgnat/s-imglli.ads
View file

@ -30,28 +30,26 @@
------------------------------------------------------------------------------
-- This package contains the routines for supporting the Image attribute for
-- signed integer types larger than Size Integer'Size, and also for conversion
-- operations required in Text_IO.Integer_IO for such types.
-- signed integer types larger Integer, and also for conversion operations
-- required in Text_IO.Integer_IO for such types.
with System.Image_I;
package System.Img_LLI is
pragma Pure;
package Impl is new Image_I (Long_Long_Integer);
procedure Image_Long_Long_Integer
(V : Long_Long_Integer;
S : in out String;
P : out Natural);
-- Computes Long_Long_Integer'Image (V) and stores the result in
-- S (1 .. P) setting the resulting value of P. The caller guarantees
-- that S is long enough to hold the result, and that S'First is 1.
P : out Natural)
renames Impl.Image_Integer;
procedure Set_Image_Long_Long_Integer
(V : Long_Long_Integer;
S : in out String;
P : in out Natural);
-- Stores the image of V in S starting at S (P + 1), P is updated to point
-- to the last character stored. The value stored is identical to the value
-- of Long_Long_Integer'Image (V) except that no leading space is stored
-- when V is non-negative. The caller guarantees that S is long enough to
-- hold the result. S need not have a lower bound of 1.
P : in out Natural)
renames Impl.Set_Image_Integer;
end System.Img_LLI;

63
gcc/ada/libgnat/s-imglllb.ads Normal file
View file

@ -0,0 +1,63 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ L L L B --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- Contains the routine for computing the image in based format of signed and
-- unsigned integers larger than Long_Long_Integer for use by
-- Text_IO.Integer_IO and Text_IO.Modular_IO.
with System.Image_B;
with System.Unsigned_Types;
package System.Img_LLLB is
pragma Preelaborate;
subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
package Impl is
new Image_B (Long_Long_Long_Integer, Long_Long_Long_Unsigned);
procedure Set_Image_Based_Long_Long_Long_Integer
(V : Long_Long_Long_Integer;
B : Natural;
W : Integer;
S : out String;
P : in out Natural)
renames Impl.Set_Image_Based_Integer;
procedure Set_Image_Based_Long_Long_Long_Unsigned
(V : Long_Long_Long_Unsigned;
B : Natural;
W : Integer;
S : out String;
P : in out Natural)
renames Impl.Set_Image_Based_Unsigned;
end System.Img_LLLB;

55
gcc/ada/libgnat/s-imgllli.ads Normal file
View file

@ -0,0 +1,55 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ L L L I --
-- --
-- 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 supporting the Image attribute for
-- signed integer types larger than Long_Long_Integer, and also for conversion
-- operations required in Text_IO.Integer_IO for such types.
with System.Image_I;
package System.Img_LLLI is
pragma Pure;
package Impl is new Image_I (Long_Long_Long_Integer);
procedure Image_Long_Long_Long_Integer
(V : Long_Long_Long_Integer;
S : in out String;
P : out Natural)
renames Impl.Image_Integer;
procedure Set_Image_Long_Long_Long_Integer
(V : Long_Long_Long_Integer;
S : in out String;
P : in out Natural)
renames Impl.Set_Image_Integer;
end System.Img_LLLI;

58
gcc/ada/libgnat/s-imglllu.ads Normal file
View file

@ -0,0 +1,58 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ L L L U --
-- --
-- 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 supporting the Image attribute for
-- modular integer types larger than Long_Long_Unsigned, and also for
-- conversion operations required in Text_IO.Modular_IO for such types.
with System.Image_U;
with System.Unsigned_Types;
package System.Img_LLLU is
pragma Pure;
subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
package Impl is new Image_U (Long_Long_Long_Unsigned);
procedure Image_Long_Long_Long_Unsigned
(V : Long_Long_Long_Unsigned;
S : in out String;
P : out Natural)
renames Impl.Image_Unsigned;
procedure Set_Image_Long_Long_Long_Unsigned
(V : Long_Long_Long_Unsigned;
S : in out String;
P : in out Natural)
renames Impl.Set_Image_Unsigned;
end System.Img_LLLU;

61
gcc/ada/libgnat/s-imglllw.ads Normal file
View file

@ -0,0 +1,61 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ L L W --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- Contains the routine for computing the image of signed and unsigned
-- integers larger than Integer for use by Text_IO.Integer_IO and
-- Text_IO.Modular_IO.
with System.Image_W;
with System.Unsigned_Types;
package System.Img_LLLW is
pragma Pure;
subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
package Impl is
new Image_W (Long_Long_Long_Integer, Long_Long_Long_Unsigned);
procedure Set_Image_Width_Long_Long_Long_Integer
(V : Long_Long_Long_Integer;
W : Integer;
S : out String;
P : in out Natural)
renames Impl.Set_Image_Width_Integer;
procedure Set_Image_Width_Long_Long_Long_Unsigned
(V : Long_Long_Long_Unsigned;
W : Integer;
S : out String;
P : in out Natural)
renames Impl.Set_Image_Width_Unsigned;
end System.Img_LLLW;

53
gcc/ada/libgnat/s-imgllu.adb
View file

@ -29,53 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Img_LLU is
------------------------------
-- Image_Long_Long_Unsigned --
------------------------------
procedure Image_Long_Long_Unsigned
(V : System.Unsigned_Types.Long_Long_Unsigned;
S : in out String;
P : out Natural)
is
pragma Assert (S'First = 1);
begin
S (1) := ' ';
P := 1;
Set_Image_Long_Long_Unsigned (V, S, P);
end Image_Long_Long_Unsigned;
----------------------------------
-- Set_Image_Long_Long_Unsigned --
----------------------------------
procedure Set_Image_Long_Long_Unsigned
(V : Long_Long_Unsigned;
S : in out String;
P : in out Natural)
is
begin
if V >= 10 then
Set_Image_Long_Long_Unsigned (V / 10, S, P);
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification, the
-- caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := Character'Val (48 + (V rem 10));
else
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification, the
-- caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := Character'Val (48 + V);
end if;
end Set_Image_Long_Long_Unsigned;
end System.Img_LLU;
pragma No_Body;

31
gcc/ada/libgnat/s-imgllu.ads
View file

@ -30,32 +30,29 @@
------------------------------------------------------------------------------
-- This package contains the routines for supporting the Image attribute for
-- unsigned (modular) integer types larger than Size Unsigned'Size, and also
-- for conversion operations required in Text_IO.Modular_IO for such types.
-- modular integer types larger than Unsigned, and also for conversion
-- operations required in Text_IO.Modular_IO for such types.
with System.Image_U;
with System.Unsigned_Types;
package System.Img_LLU is
pragma Pure;
procedure Image_Long_Long_Unsigned
(V : System.Unsigned_Types.Long_Long_Unsigned;
S : in out String;
P : out Natural);
pragma Inline (Image_Long_Long_Unsigned);
subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
-- Computes Long_Long_Unsigned'Image (V) and stores the result in
-- S (1 .. P) setting the resulting value of P. The caller guarantees
-- that S is long enough to hold the result, and that S'First is 1.
package Impl is new Image_U (Long_Long_Unsigned);
procedure Image_Long_Long_Unsigned
(V : Long_Long_Unsigned;
S : in out String;
P : out Natural)
renames Impl.Image_Unsigned;
procedure Set_Image_Long_Long_Unsigned
(V : System.Unsigned_Types.Long_Long_Unsigned;
(V : Long_Long_Unsigned;
S : in out String;
P : in out Natural);
-- Stores the image of V in S starting at S (P + 1), P is updated to point
-- to the last character stored. The value stored is identical to the value
-- of Long_Long_Unsigned'Image (V) except that no leading space is stored.
-- The caller guarantees that S is long enough to hold the result. S need
-- not have a lower bound of 1.
P : in out Natural)
renames Impl.Set_Image_Unsigned;
end System.Img_LLU;

112
gcc/ada/libgnat/s-imgllw.adb
View file

@ -29,112 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Img_LLW is
---------------------------------------
-- Set_Image_Width_Long_Long_Integer --
---------------------------------------
procedure Set_Image_Width_Long_Long_Integer
(V : Long_Long_Integer;
W : Integer;
S : out String;
P : in out Natural)
is
Start : Natural;
begin
-- Positive case can just use the unsigned circuit directly
if V >= 0 then
Set_Image_Width_Long_Long_Unsigned
(Long_Long_Unsigned (V), W, S, P);
-- Negative case has to set a minus sign. Note also that we have to be
-- careful not to generate overflow with the largest negative number.
else
P := P + 1;
S (P) := ' ';
Start := P;
declare
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
begin
Set_Image_Width_Long_Long_Unsigned
(Long_Long_Unsigned (-V), W - 1, S, P);
end;
-- Set minus sign in last leading blank location. Because of the
-- code above, there must be at least one such location.
while S (Start + 1) = ' ' loop
Start := Start + 1;
end loop;
S (Start) := '-';
end if;
end Set_Image_Width_Long_Long_Integer;
----------------------------------------
-- Set_Image_Width_Long_Long_Unsigned --
----------------------------------------
procedure Set_Image_Width_Long_Long_Unsigned
(V : Long_Long_Unsigned;
W : Integer;
S : out String;
P : in out Natural)
is
Start : constant Natural := P;
F, T : Natural;
procedure Set_Digits (T : Long_Long_Unsigned);
-- Set digits of absolute value of T
----------------
-- Set_Digits --
----------------
procedure Set_Digits (T : Long_Long_Unsigned) is
begin
if T >= 10 then
Set_Digits (T / 10);
P := P + 1;
S (P) := Character'Val (T mod 10 + Character'Pos ('0'));
else
P := P + 1;
S (P) := Character'Val (T + Character'Pos ('0'));
end if;
end Set_Digits;
-- Start of processing for Set_Image_Width_Long_Long_Unsigned
begin
Set_Digits (V);
-- Add leading spaces if required by width parameter
if P - Start < W then
F := P;
P := P + (W - (P - Start));
T := P;
while F > Start loop
S (T) := S (F);
T := T - 1;
F := F - 1;
end loop;
for J in Start + 1 .. T loop
S (J) := ' ';
end loop;
end if;
end Set_Image_Width_Long_Long_Unsigned;
end System.Img_LLW;
pragma No_Body;

31
gcc/ada/libgnat/s-imgllw.ads
View file

@ -30,40 +30,31 @@
------------------------------------------------------------------------------
-- Contains the routine for computing the image of signed and unsigned
-- integers whose size > Integer'Size for use by Text_IO.Integer_IO,
-- integers larger than Integer for use by Text_IO.Integer_IO and
-- Text_IO.Modular_IO.
with System.Image_W;
with System.Unsigned_Types;
package System.Img_LLW is
pragma Pure;
subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
package Impl is new Image_W (Long_Long_Integer, Long_Long_Unsigned);
procedure Set_Image_Width_Long_Long_Integer
(V : Long_Long_Integer;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the signed image of V in decimal format, starting at S (P + 1),
-- updating P to point to the last character stored. The image includes
-- a leading minus sign if necessary, but no leading spaces unless W is
-- positive, in which case leading spaces are output if necessary to ensure
-- that the output string is no less than W characters long. The caller
-- promises that the buffer is large enough and no check is made for this.
-- Constraint_Error will not necessarily be raised if this is violated,
-- since it is perfectly valid to compile this unit with checks off.
P : in out Natural)
renames Impl.Set_Image_Width_Integer;
procedure Set_Image_Width_Long_Long_Unsigned
(V : System.Unsigned_Types.Long_Long_Unsigned;
(V : Long_Long_Unsigned;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the unsigned image of V in decimal format, starting at S (P + 1),
-- updating P to point to the last character stored. The image includes no
-- leading spaces unless W is positive, in which case leading spaces are
-- output if necessary to ensure that the output string is no less than
-- W characters long. The caller promises that the buffer is large enough
-- and no check is made for this. Constraint_Error will not necessarily be
-- raised if this is violated, since it is perfectly valid to compile this
-- unit with checks off.
P : in out Natural)
renames Impl.Set_Image_Width_Unsigned;
end System.Img_LLW;

7
gcc/ada/libgnat/s-imgrea.adb
View file

@ -29,10 +29,9 @@
-- --
------------------------------------------------------------------------------
with System.Img_LLU; use System.Img_LLU;
with System.Img_Uns; use System.Img_Uns;
with System.Powten_Table; use System.Powten_Table;
with System.Unsigned_Types; use System.Unsigned_Types;
with System.Img_LLU; use System.Img_LLU;
with System.Img_Uns; use System.Img_Uns;
with System.Powten_Table; use System.Powten_Table;
with System.Float_Control;
package body System.Img_Real is

53
gcc/ada/libgnat/s-imguns.adb
View file

@ -29,53 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Img_Uns is
--------------------
-- Image_Unsigned --
--------------------
procedure Image_Unsigned
(V : System.Unsigned_Types.Unsigned;
S : in out String;
P : out Natural)
is
pragma Assert (S'First = 1);
begin
S (1) := ' ';
P := 1;
Set_Image_Unsigned (V, S, P);
end Image_Unsigned;
------------------------
-- Set_Image_Unsigned --
------------------------
procedure Set_Image_Unsigned
(V : Unsigned;
S : in out String;
P : in out Natural)
is
pragma Assert (S'First = 1);
begin
if V >= 10 then
Set_Image_Unsigned (V / 10, S, P);
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := Character'Val (48 + (V rem 10));
else
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := Character'Val (48 + V);
end if;
end Set_Image_Unsigned;
end System.Img_Uns;
pragma No_Body;

28
gcc/ada/libgnat/s-imguns.ads
View file

@ -30,31 +30,29 @@
------------------------------------------------------------------------------
-- This package contains the routines for supporting the Image attribute for
-- modular integer types up to size Unsigned'Size, and also for conversion
-- operations required in Text_IO.Modular_IO for such types.
-- modular integer types up to Unsigned, and also for conversion operations
-- required in Text_IO.Modular_IO for such types.
with System.Image_U;
with System.Unsigned_Types;
package System.Img_Uns is
pragma Pure;
subtype Unsigned is Unsigned_Types.Unsigned;
package Impl is new Image_U (Unsigned);
procedure Image_Unsigned
(V : System.Unsigned_Types.Unsigned;
(V : Unsigned;
S : in out String;
P : out Natural);
pragma Inline (Image_Unsigned);
-- Computes Unsigned'Image (V) and stores the result in S (1 .. P) setting
-- the resulting value of P. The caller guarantees that S is long enough to
-- hold the result, and that S'First is 1.
P : out Natural)
renames Impl.Image_Unsigned;
procedure Set_Image_Unsigned
(V : System.Unsigned_Types.Unsigned;
(V : Unsigned;
S : in out String;
P : in out Natural);
-- Stores the image of V in S starting at S (P + 1), P is updated to point
-- to the last character stored. The value stored is identical to the value
-- of Unsigned'Image (V) except that no leading space is stored. The caller
-- guarantees that S is long enough to hold the result. S need not have a
-- lower bound of 1.
P : in out Natural)
renames Impl.Set_Image_Unsigned;
end System.Img_Uns;

125
gcc/ada/libgnat/s-imgwiu.adb
View file

@ -29,125 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Img_WIU is
-----------------------------
-- Set_Image_Width_Integer --
-----------------------------
procedure Set_Image_Width_Integer
(V : Integer;
W : Integer;
S : out String;
P : in out Natural)
is
Start : Natural;
begin
-- Positive case can just use the unsigned circuit directly
if V >= 0 then
Set_Image_Width_Unsigned (Unsigned (V), W, S, P);
-- Negative case has to set a minus sign. Note also that we have to be
-- careful not to generate overflow with the largest negative number.
else
P := P + 1;
S (P) := ' ';
Start := P;
declare
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
begin
Set_Image_Width_Unsigned (Unsigned (-V), W - 1, S, P);
end;
-- Set minus sign in last leading blank location. Because of the
-- code above, there must be at least one such location.
while S (Start + 1) = ' ' loop
Start := Start + 1;
end loop;
S (Start) := '-';
end if;
end Set_Image_Width_Integer;
------------------------------
-- Set_Image_Width_Unsigned --
------------------------------
procedure Set_Image_Width_Unsigned
(V : Unsigned;
W : Integer;
S : out String;
P : in out Natural)
is
Start : constant Natural := P;
F, T : Natural;
procedure Set_Digits (T : Unsigned);
-- Set digits of absolute value of T
----------------
-- Set_Digits --
----------------
procedure Set_Digits (T : Unsigned) is
begin
if T >= 10 then
Set_Digits (T / 10);
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := Character'Val (T mod 10 + Character'Pos ('0'));
else
pragma Assert (P >= (S'First - 1) and P < S'Last and
P < Natural'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
P := P + 1;
S (P) := Character'Val (T + Character'Pos ('0'));
end if;
end Set_Digits;
-- Start of processing for Set_Image_Width_Unsigned
begin
Set_Digits (V);
-- Add leading spaces if required by width parameter
if P - Start < W then
F := P;
P := P + (W - (P - Start));
T := P;
while F > Start loop
pragma Assert (T >= S'First and T <= S'Last and
F >= S'First and F <= S'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
S (T) := S (F);
T := T - 1;
F := F - 1;
end loop;
for J in Start + 1 .. T loop
pragma Assert (J >= S'First and J <= S'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
S (J) := ' ';
end loop;
end if;
end Set_Image_Width_Unsigned;
end System.Img_WIU;
pragma No_Body;

33
gcc/ada/libgnat/s-imgwiu.ads
View file

@ -30,40 +30,31 @@
------------------------------------------------------------------------------
-- Contains the routine for computing the image of signed and unsigned
-- integers whose size <= Integer'Size for use by Text_IO.Integer_IO
-- and Text_IO.Modular_IO.
-- integers up to Integer for use by Text_IO.Integer_IO and
-- Text_IO.Modular_IO.
with System.Image_W;
with System.Unsigned_Types;
package System.Img_WIU is
pragma Pure;
subtype Unsigned is Unsigned_Types.Unsigned;
package Impl is new Image_W (Integer, Unsigned);
procedure Set_Image_Width_Integer
(V : Integer;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the signed image of V in decimal format, starting at S (P + 1),
-- updating P to point to the last character stored. The image includes
-- a leading minus sign if necessary, but no leading spaces unless W is
-- positive, in which case leading spaces are output if necessary to ensure
-- that the output string is no less than W characters long. The caller
-- promises that the buffer is large enough and no check is made for this.
-- Constraint_Error will not necessarily be raised if this is violated,
-- since it is perfectly valid to compile this unit with checks off.
P : in out Natural)
renames Impl.Set_Image_Width_Integer;
procedure Set_Image_Width_Unsigned
(V : System.Unsigned_Types.Unsigned;
(V : Unsigned;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the unsigned image of V in decimal format, starting at S (P + 1),
-- updating P to point to the last character stored. The image includes no
-- leading spaces unless W is positive, in which case leading spaces are
-- output if necessary to ensure that the output string is no less than
-- W characters long. The caller promises that the buffer is large enough
-- and no check is made for this. Constraint_Error will not necessarily be
-- raised if this is violated, since it is perfectly valid to compile this
-- unit with checks off.
P : in out Natural)
renames Impl.Set_Image_Width_Unsigned;
end System.Img_WIU;

21
gcc/ada/libgnat/s-putima.adb
View file

@ -93,21 +93,30 @@ package body System.Put_Images is
end Generic_Integer_Images;
package Small is new Generic_Integer_Images (Integer, Unsigned, Base => 10);
package Large is new Generic_Integer_Images
package Integer_Images is new Generic_Integer_Images
(Integer, Unsigned, Base => 10);
package LL_Integer_Images is new Generic_Integer_Images
(Long_Long_Integer, Long_Long_Unsigned, Base => 10);
package LLL_Integer_Images is new Generic_Integer_Images
(Long_Long_Long_Integer, Long_Long_Long_Unsigned, Base => 10);
procedure Put_Image_Integer (S : in out Sink'Class; X : Integer)
renames Small.Put_Image;
renames Integer_Images.Put_Image;
procedure Put_Image_Long_Long_Integer
(S : in out Sink'Class; X : Long_Long_Integer)
renames Large.Put_Image;
renames LL_Integer_Images.Put_Image;
procedure Put_Image_Long_Long_Long_Integer
(S : in out Sink'Class; X : Long_Long_Long_Integer)
renames LLL_Integer_Images.Put_Image;
procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned)
renames Small.Put_Image;
renames Integer_Images.Put_Image;
procedure Put_Image_Long_Long_Unsigned
(S : in out Sink'Class; X : Long_Long_Unsigned)
renames Large.Put_Image;
renames LL_Integer_Images.Put_Image;
procedure Put_Image_Long_Long_Long_Unsigned
(S : in out Sink'Class; X : Long_Long_Long_Unsigned)
renames LLL_Integer_Images.Put_Image;
type Signed_Address is range
-2**(Standard'Address_Size - 1) .. 2**(Standard'Address_Size - 1) - 1;

16
gcc/ada/libgnat/s-putima.ads
View file

@ -37,10 +37,11 @@ package System.Put_Images with Pure is
-- This package contains subprograms that are called by the generated code
-- for the 'Put_Image attribute.
--
-- For an integer type that fits in Integer, the actual parameter is
-- For a signed integer type that fits in Integer, the actual parameter is
-- converted to Integer, and Put_Image_Integer is called. For larger types,
-- Put_Image_Long_Long_Integer is used. Other numeric types are treated
-- similarly. Access values are unchecked-converted to either Thin_Pointer
-- Put_Image_Long_Long_Integer or Put_Image_Long_Long_Long_Integer is used.
-- For a modular integer type, this is similar with Integer replaced with
-- Unsigned. Access values are unchecked-converted to either Thin_Pointer
-- or Fat_Pointer, and Put_Image_Thin_Pointer or Put_Image_Fat_Pointer is
-- called. The Before/Between/After procedures are called before printing
-- the components of a composite type, between pairs of components, and
@ -54,13 +55,18 @@ package System.Put_Images with Pure is
procedure Put_Image_Integer (S : in out Sink'Class; X : Integer);
procedure Put_Image_Long_Long_Integer
(S : in out Sink'Class; X : Long_Long_Integer);
procedure Put_Image_Long_Long_Long_Integer
(S : in out Sink'Class; X : Long_Long_Long_Integer);
subtype Unsigned is System.Unsigned_Types.Unsigned;
subtype Long_Long_Unsigned is System.Unsigned_Types.Long_Long_Unsigned;
subtype Unsigned is Unsigned_Types.Unsigned;
subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned);
procedure Put_Image_Long_Long_Unsigned
(S : in out Sink'Class; X : Long_Long_Unsigned);
procedure Put_Image_Long_Long_Long_Unsigned
(S : in out Sink'Class; X : Long_Long_Long_Unsigned);
type Byte is new Character with Alignment => 1;
type Byte_String is array (Positive range <>) of Byte with Alignment => 1;

90
gcc/ada/libgnat/s-valint.adb
View file

@ -29,90 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
with System.Val_Uns; use System.Val_Uns;
with System.Val_Util; use System.Val_Util;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Val_Int is
------------------
-- Scan_Integer --
------------------
function Scan_Integer
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Integer
is
Uval : Unsigned;
-- Unsigned result
Minus : Boolean := False;
-- Set to True if minus sign is present, otherwise to False
Start : Positive;
-- Saves location of first non-blank (not used in this case)
begin
Scan_Sign (Str, Ptr, Max, Minus, Start);
if Str (Ptr.all) not in '0' .. '9' then
Ptr.all := Start;
Bad_Value (Str);
end if;
Uval := Scan_Raw_Unsigned (Str, Ptr, Max);
-- Deal with overflow cases, and also with maximum negative number
if Uval > Unsigned (Integer'Last) then
if Minus and then Uval = Unsigned (-(Integer'First)) then
return Integer'First;
else
Bad_Value (Str);
end if;
-- Negative values
elsif Minus then
return -(Integer (Uval));
-- Positive values
else
return Integer (Uval);
end if;
end Scan_Integer;
-------------------
-- Value_Integer --
-------------------
function Value_Integer (Str : String) return Integer is
begin
-- We have to special case Str'Last = Positive'Last because the normal
-- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
-- deal with this by converting to a subtype which fixes the bounds.
if Str'Last = Positive'Last then
declare
subtype NT is String (1 .. Str'Length);
begin
return Value_Integer (NT (Str));
end;
-- Normal case where Str'Last < Positive'Last
else
declare
V : Integer;
P : aliased Integer := Str'First;
begin
V := Scan_Integer (Str, P'Access, Str'Last);
Scan_Trailing_Blanks (Str, P);
return V;
end;
end if;
end Value_Integer;
end System.Val_Int;
pragma No_Body;

42
gcc/ada/libgnat/s-valint.ads
View file

@ -32,42 +32,24 @@
-- This package contains routines for scanning signed Integer values for use
-- in Text_IO.Integer_IO, and the Value attribute.
with System.Unsigned_Types;
with System.Val_Uns;
with System.Value_I;
package System.Val_Int is
pragma Preelaborate;
subtype Unsigned is Unsigned_Types.Unsigned;
package Impl is new Value_I (Integer, Unsigned, Val_Uns.Scan_Raw_Unsigned);
function Scan_Integer
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Integer;
-- This function scans the string starting at Str (Ptr.all) for a valid
-- integer according to the syntax described in (RM 3.5(43)). The substring
-- scanned extends no further than Str (Max). There are three cases for the
-- return:
--
-- If a valid integer is found after scanning past any initial spaces, then
-- Ptr.all is updated past the last character of the integer (but trailing
-- spaces are not scanned out).
--
-- If no valid integer is found, then Ptr.all points either to an initial
-- non-digit character, or to Max + 1 if the field is all spaces and the
-- exception Constraint_Error is raised.
--
-- If a syntactically valid integer is scanned, but the value is out of
-- range, or, in the based case, the base value is out of range or there
-- is an out of range digit, then Ptr.all points past the integer, and
-- Constraint_Error is raised.
--
-- Note: these rules correspond to the requirements for leaving the pointer
-- positioned in Text_Io.Get
--
-- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
Max : Integer) return Integer
renames Impl.Scan_Integer;
function Value_Integer (Str : String) return Integer;
-- Used in computing X'Value (Str) where X is a signed integer type whose
-- base range does not exceed the base range of Integer. Str is the string
-- argument of the attribute. Constraint_Error is raised if the string is
-- malformed, or if the value is out of range.
function Value_Integer (Str : String) return Integer
renames Impl.Value_Integer;
end System.Val_Int;

92
gcc/ada/libgnat/s-vallli.adb
View file

@ -29,92 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
with System.Val_LLU; use System.Val_LLU;
with System.Val_Util; use System.Val_Util;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Val_LLI is
----------------------------
-- Scan_Long_Long_Integer --
----------------------------
function Scan_Long_Long_Integer
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Long_Long_Integer
is
Uval : Long_Long_Unsigned;
-- Unsigned result
Minus : Boolean := False;
-- Set to True if minus sign is present, otherwise to False
Start : Positive;
-- Saves location of first non-blank
begin
Scan_Sign (Str, Ptr, Max, Minus, Start);
if Str (Ptr.all) not in '0' .. '9' then
Ptr.all := Start;
Bad_Value (Str);
end if;
Uval := Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max);
-- Deal with overflow cases, and also with maximum negative number
if Uval > Long_Long_Unsigned (Long_Long_Integer'Last) then
if Minus
and then Uval = Long_Long_Unsigned (-(Long_Long_Integer'First))
then
return Long_Long_Integer'First;
else
Bad_Value (Str);
end if;
-- Negative values
elsif Minus then
return -(Long_Long_Integer (Uval));
-- Positive values
else
return Long_Long_Integer (Uval);
end if;
end Scan_Long_Long_Integer;
-----------------------------
-- Value_Long_Long_Integer --
-----------------------------
function Value_Long_Long_Integer (Str : String) return Long_Long_Integer is
begin
-- We have to special case Str'Last = Positive'Last because the normal
-- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
-- deal with this by converting to a subtype which fixes the bounds.
if Str'Last = Positive'Last then
declare
subtype NT is String (1 .. Str'Length);
begin
return Value_Long_Long_Integer (NT (Str));
end;
-- Normal case where Str'Last < Positive'Last
else
declare
V : Long_Long_Integer;
P : aliased Integer := Str'First;
begin
V := Scan_Long_Long_Integer (Str, P'Access, Str'Last);
Scan_Trailing_Blanks (Str, P);
return V;
end;
end if;
end Value_Long_Long_Integer;
end System.Val_LLI;
pragma No_Body;

45
gcc/ada/libgnat/s-vallli.ads
View file

@ -32,42 +32,27 @@
-- This package contains routines for scanning signed Long_Long_Integer
-- values for use in Text_IO.Integer_IO, and the Value attribute.
with System.Unsigned_Types;
with System.Val_LLU;
with System.Value_I;
package System.Val_LLI is
pragma Preelaborate;
subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
package Impl is new
Value_I (Long_Long_Integer,
Long_Long_Unsigned,
Val_LLU.Scan_Raw_Long_Long_Unsigned);
function Scan_Long_Long_Integer
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Long_Long_Integer;
-- This function scans the string starting at Str (Ptr.all) for a valid
-- integer according to the syntax described in (RM 3.5(43)). The substring
-- scanned extends no further than Str (Max). There are three cases for the
-- return:
--
-- If a valid integer is found after scanning past any initial spaces, then
-- Ptr.all is updated past the last character of the integer (but trailing
-- spaces are not scanned out).
--
-- If no valid integer is found, then Ptr.all points either to an initial
-- non-digit character, or to Max + 1 if the field is all spaces and the
-- exception Constraint_Error is raised.
--
-- If a syntactically valid integer is scanned, but the value is out of
-- range, or, in the based case, the base value is out of range or there
-- is an out of range digit, then Ptr.all points past the integer, and
-- Constraint_Error is raised.
--
-- Note: these rules correspond to the requirements for leaving the pointer
-- positioned in Text_Io.Get
--
-- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
Max : Integer) return Long_Long_Integer
renames Impl.Scan_Integer;
function Value_Long_Long_Integer (Str : String) return Long_Long_Integer;
-- Used in computing X'Value (Str) where X is a signed integer type whose
-- base range exceeds the base range of Integer. Str is the string argument
-- of the attribute. Constraint_Error is raised if the string is malformed,
-- or if the value is out of range.
function Value_Long_Long_Integer (Str : String) return Long_Long_Integer
renames Impl.Value_Integer;
end System.Val_LLI;

59
gcc/ada/libgnat/s-valllli.ads Normal file
View file

@ -0,0 +1,59 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . V A L _ L L L I --
-- --
-- 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 routines for scanning signed Long_Long_Long_Integer
-- values for use in Text_IO.Integer_IO, and the Value attribute.
with System.Unsigned_Types;
with System.Val_LLLU;
with System.Value_I;
package System.Val_LLLI is
pragma Preelaborate;
subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
package Impl is new
Value_I (Long_Long_Long_Integer,
Long_Long_Long_Unsigned,
Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned);
function Scan_Long_Long_Long_Integer
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Long_Long_Long_Integer
renames Impl.Scan_Integer;
function Value_Long_Long_Long_Integer
(Str : String) return Long_Long_Long_Integer
renames Impl.Value_Integer;
end System.Val_LLLI;

61
gcc/ada/libgnat/s-vallllu.ads Normal file
View file

@ -0,0 +1,61 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . V A L _ L L L U --
-- --
-- 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 routines for scanning modular Long_Long_Unsigned
-- values for use in Text_IO.Modular_IO, and the Value attribute.
with System.Unsigned_Types;
with System.Value_U;
package System.Val_LLLU is
pragma Preelaborate;
subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
package Impl is new Value_U (Long_Long_Long_Unsigned);
function Scan_Raw_Long_Long_Long_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Long_Long_Long_Unsigned
renames Impl.Scan_Raw_Unsigned;
function Scan_Long_Long_Long_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Long_Long_Long_Unsigned
renames Impl.Scan_Unsigned;
function Value_Long_Long_Long_Unsigned
(Str : String) return Long_Long_Long_Unsigned
renames Impl.Value_Unsigned;
end System.Val_LLLU;

302
gcc/ada/libgnat/s-valllu.adb
View file

@ -29,302 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
with System.Val_Util; use System.Val_Util;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Val_LLU is
---------------------------------
-- Scan_Raw_Long_Long_Unsigned --
---------------------------------
function Scan_Raw_Long_Long_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Long_Long_Unsigned
is
P : Integer;
-- Local copy of the pointer
Uval : Long_Long_Unsigned;
-- Accumulated unsigned integer result
Expon : Integer;
-- Exponent value
Overflow : Boolean := False;
-- Set True if overflow is detected at any point
Base_Char : Character;
-- Base character (# or :) in based case
Base : Long_Long_Unsigned := 10;
-- Base value (reset in based case)
Digit : Long_Long_Unsigned;
-- Digit value
begin
-- We do not tolerate strings with Str'Last = Positive'Last
if Str'Last = Positive'Last then
raise Program_Error with
"string upper bound is Positive'Last, not supported";
end if;
P := Ptr.all;
Uval := Character'Pos (Str (P)) - Character'Pos ('0');
P := P + 1;
-- Scan out digits of what is either the number or the base.
-- In either case, we are definitely scanning out in base 10.
declare
Umax : constant := (Long_Long_Unsigned'Last - 9) / 10;
-- Max value which cannot overflow on accumulating next digit
Umax10 : constant := Long_Long_Unsigned'Last / 10;
-- Numbers bigger than Umax10 overflow if multiplied by 10
begin
-- Loop through decimal digits
loop
exit when P > Max;
Digit := Character'Pos (Str (P)) - Character'Pos ('0');
-- Non-digit encountered
if Digit > 9 then
if Str (P) = '_' then
Scan_Underscore (Str, P, Ptr, Max, False);
else
exit;
end if;
-- Accumulate result, checking for overflow
else
if Uval <= Umax then
Uval := 10 * Uval + Digit;
elsif Uval > Umax10 then
Overflow := True;
else
Uval := 10 * Uval + Digit;
if Uval < Umax10 then
Overflow := True;
end if;
end if;
P := P + 1;
end if;
end loop;
end;
Ptr.all := P;
-- Deal with based case. We recognize either the standard '#' or the
-- allowed alternative replacement ':' (see RM J.2(3)).
if P < Max and then (Str (P) = '#' or else Str (P) = ':') then
Base_Char := Str (P);
P := P + 1;
Base := Uval;
Uval := 0;
-- Check base value. Overflow is set True if we find a bad base, or
-- a digit that is out of range of the base. That way, we scan out
-- the numeral that is still syntactically correct, though illegal.
-- We use a safe base of 16 for this scan, to avoid zero divide.
if Base not in 2 .. 16 then
Overflow := True;
Base := 16;
end if;
-- Scan out based integer
declare
Umax : constant Long_Long_Unsigned :=
(Long_Long_Unsigned'Last - Base + 1) / Base;
-- Max value which cannot overflow on accumulating next digit
UmaxB : constant Long_Long_Unsigned :=
Long_Long_Unsigned'Last / Base;
-- Numbers bigger than UmaxB overflow if multiplied by base
begin
-- Loop to scan out based integer value
loop
-- We require a digit at this stage
if Str (P) in '0' .. '9' then
Digit := Character'Pos (Str (P)) - Character'Pos ('0');
elsif Str (P) in 'A' .. 'F' then
Digit :=
Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
elsif Str (P) in 'a' .. 'f' then
Digit :=
Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
-- If we don't have a digit, then this is not a based number
-- after all, so we use the value we scanned out as the base
-- (now in Base), and the pointer to the base character was
-- already stored in Ptr.all.
else
Uval := Base;
exit;
end if;
-- If digit is too large, just signal overflow and continue.
-- The idea here is to keep scanning as long as the input is
-- syntactically valid, even if we have detected overflow
if Digit >= Base then
Overflow := True;
-- Here we accumulate the value, checking overflow
elsif Uval <= Umax then
Uval := Base * Uval + Digit;
elsif Uval > UmaxB then
Overflow := True;
else
Uval := Base * Uval + Digit;
if Uval < UmaxB then
Overflow := True;
end if;
end if;
-- If at end of string with no base char, not a based number
-- but we signal Constraint_Error and set the pointer past
-- the end of the field, since this is what the ACVC tests
-- seem to require, see CE3704N, line 204.
P := P + 1;
if P > Max then
Ptr.all := P;
Bad_Value (Str);
end if;
-- If terminating base character, we are done with loop
if Str (P) = Base_Char then
Ptr.all := P + 1;
exit;
-- Deal with underscore
elsif Str (P) = '_' then
Scan_Underscore (Str, P, Ptr, Max, True);
end if;
end loop;
end;
end if;
-- Come here with scanned unsigned value in Uval. The only remaining
-- required step is to deal with exponent if one is present.
Expon := Scan_Exponent (Str, Ptr, Max);
if Expon /= 0 and then Uval /= 0 then
-- For non-zero value, scale by exponent value. No need to do this
-- efficiently, since use of exponent in integer literals is rare,
-- and in any case the exponent cannot be very large.
declare
UmaxB : constant Long_Long_Unsigned :=
Long_Long_Unsigned'Last / Base;
-- Numbers bigger than UmaxB overflow if multiplied by base
begin
for J in 1 .. Expon loop
if Uval > UmaxB then
Overflow := True;
exit;
end if;
Uval := Uval * Base;
end loop;
end;
end if;
-- Return result, dealing with sign and overflow
if Overflow then
Bad_Value (Str);
else
return Uval;
end if;
end Scan_Raw_Long_Long_Unsigned;
-----------------------------
-- Scan_Long_Long_Unsigned --
-----------------------------
function Scan_Long_Long_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Long_Long_Unsigned
is
Start : Positive;
-- Save location of first non-blank character
begin
Scan_Plus_Sign (Str, Ptr, Max, Start);
if Str (Ptr.all) not in '0' .. '9' then
Ptr.all := Start;
raise Constraint_Error;
end if;
return Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max);
end Scan_Long_Long_Unsigned;
------------------------------
-- Value_Long_Long_Unsigned --
------------------------------
function Value_Long_Long_Unsigned
(Str : String) return Long_Long_Unsigned
is
begin
-- We have to special case Str'Last = Positive'Last because the normal
-- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
-- deal with this by converting to a subtype which fixes the bounds.
if Str'Last = Positive'Last then
declare
subtype NT is String (1 .. Str'Length);
begin
return Value_Long_Long_Unsigned (NT (Str));
end;
-- Normal case where Str'Last < Positive'Last
else
declare
V : Long_Long_Unsigned;
P : aliased Integer := Str'First;
begin
V := Scan_Long_Long_Unsigned (Str, P'Access, Str'Last);
Scan_Trailing_Blanks (Str, P);
return V;
end;
end if;
end Value_Long_Long_Unsigned;
end System.Val_LLU;
pragma No_Body;

90
gcc/ada/libgnat/s-valllu.ads
View file

@ -33,97 +33,29 @@
-- values for use in Text_IO.Modular_IO, and the Value attribute.
with System.Unsigned_Types;
with System.Value_U;
package System.Val_LLU is
pragma Preelaborate;
subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
package Impl is new Value_U (Long_Long_Unsigned);
function Scan_Raw_Long_Long_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned;
-- This function scans the string starting at Str (Ptr.all) for a valid
-- integer according to the syntax described in (RM 3.5(43)). The substring
-- scanned extends no further than Str (Max). Note: this does not scan
-- leading or trailing blanks, nor leading sign.
--
-- There are three cases for the return:
--
-- If a valid integer is found, then Ptr.all is updated past the last
-- character of the integer.
--
-- If no valid integer is found, then Ptr.all points either to an initial
-- non-digit character, or to Max + 1 if the field is all spaces and the
-- exception Constraint_Error is raised.
--
-- If a syntactically valid integer is scanned, but the value is out of
-- range, or, in the based case, the base value is out of range or there
-- is an out of range digit, then Ptr.all points past the integer, and
-- Constraint_Error is raised.
--
-- Note: these rules correspond to the requirements for leaving the pointer
-- positioned in Text_IO.Get. Note that the rules as stated in the RM would
-- seem to imply that for a case like:
--
-- 8#12345670009#
--
-- the pointer should be left at the first # having scanned out the longest
-- valid integer literal (8), but in fact in this case the pointer points
-- past the final # and Constraint_Error is raised. This is the behavior
-- expected for Text_IO and enforced by the ACATS tests.
--
-- If a based literal is malformed in that a character other than a valid
-- hexadecimal digit is encountered during scanning out the digits after
-- the # (this includes the case of using the wrong terminator, : instead
-- of # or vice versa) there are two cases. If all the digits before the
-- non-digit are in range of the base, as in
--
-- 8#100x00#
-- 8#100:
--
-- then in this case, the "base" value before the initial # is returned as
-- the result, and the pointer points to the initial # character on return.
--
-- If an out of range digit has been detected before the invalid character,
-- as in:
--
-- 8#900x00#
-- 8#900:
--
-- then the pointer is also left at the initial # character, but constraint
-- error is raised reflecting the encounter of an out of range digit.
--
-- Finally if we have an unterminated fixed-point constant where the final
-- # or : character is missing, Constraint_Error is raised and the pointer
-- is left pointing past the last digit, as in:
--
-- 8#22
--
-- This string results in a Constraint_Error with the pointer pointing
-- past the second 2.
--
-- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
--
-- Note: this routine should not be called with Str'Last = Positive'Last.
-- If this occurs Program_Error is raised with a message noting that this
-- case is not supported. Most such cases are eliminated by the caller.
Max : Integer) return Long_Long_Unsigned
renames Impl.Scan_Raw_Unsigned;
function Scan_Long_Long_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned;
-- Same as Scan_Raw_Long_Long_Unsigned, except scans optional leading
-- blanks, and an optional leading plus sign.
--
-- Note: if a minus sign is present, Constraint_Error will be raised.
-- Note: trailing blanks are not scanned.
Max : Integer) return Long_Long_Unsigned
renames Impl.Scan_Unsigned;
function Value_Long_Long_Unsigned
(Str : String) return System.Unsigned_Types.Long_Long_Unsigned;
-- Used in computing X'Value (Str) where X is a modular integer type whose
-- modulus exceeds the range of System.Unsigned_Types.Unsigned. Str is the
-- string argument of the attribute. Constraint_Error is raised if the
-- string is malformed, or if the value is out of range.
(Str : String) return Long_Long_Unsigned
renames Impl.Value_Unsigned;
end System.Val_LLU;

116
gcc/ada/libgnat/s-valuei.adb Normal file
View file

@ -0,0 +1,116 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . V A L U E _ I --
-- --
-- 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 System.Val_Util; use System.Val_Util;
package body System.Value_I is
------------------
-- Scan_Integer --
------------------
function Scan_Integer
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Int
is
Uval : Uns;
-- Unsigned result
Minus : Boolean := False;
-- Set to True if minus sign is present, otherwise to False
Start : Positive;
-- Saves location of first non-blank (not used in this case)
begin
Scan_Sign (Str, Ptr, Max, Minus, Start);
if Str (Ptr.all) not in '0' .. '9' then
Ptr.all := Start;
Bad_Value (Str);
end if;
Uval := Scan_Raw_Unsigned (Str, Ptr, Max);
-- Deal with overflow cases, and also with maximum negative number
if Uval > Uns (Int'Last) then
if Minus and then Uval = Uns (-(Int'First)) then
return Int'First;
else
Bad_Value (Str);
end if;
-- Negative values
elsif Minus then
return -(Int (Uval));
-- Positive values
else
return Int (Uval);
end if;
end Scan_Integer;
-------------------
-- Value_Integer --
-------------------
function Value_Integer (Str : String) return Int is
begin
-- We have to special case Str'Last = Positive'Last because the normal
-- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
-- deal with this by converting to a subtype which fixes the bounds.
if Str'Last = Positive'Last then
declare
subtype NT is String (1 .. Str'Length);
begin
return Value_Integer (NT (Str));
end;
-- Normal case where Str'Last < Positive'Last
else
declare
V : Int;
P : aliased Integer := Str'First;
begin
V := Scan_Integer (Str, P'Access, Str'Last);
Scan_Trailing_Blanks (Str, P);
return V;
end;
end if;
end Value_Integer;
end System.Value_I;

84
gcc/ada/libgnat/s-valuei.ads Normal file
View file

@ -0,0 +1,84 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . V A L U E _ I --
-- --
-- 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 routines for scanning signed integer values for use
-- in Text_IO.Integer_IO, and the Value attribute.
generic
type Int is range <>;
type Uns is mod <>;
with function Scan_Raw_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Uns;
package System.Value_I is
pragma Preelaborate;
function Scan_Integer
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Int;
-- This function scans the string starting at Str (Ptr.all) for a valid
-- integer according to the syntax described in (RM 3.5(43)). The substring
-- scanned extends no further than Str (Max). There are three cases for the
-- return:
--
-- If a valid integer is found after scanning past any initial spaces, then
-- Ptr.all is updated past the last character of the integer (but trailing
-- spaces are not scanned out).
--
-- If no valid integer is found, then Ptr.all points either to an initial
-- non-digit character, or to Max + 1 if the field is all spaces and the
-- exception Constraint_Error is raised.
--
-- If a syntactically valid integer is scanned, but the value is out of
-- range, or, in the based case, the base value is out of range or there
-- is an out of range digit, then Ptr.all points past the integer, and
-- Constraint_Error is raised.
--
-- Note: these rules correspond to the requirements for leaving the pointer
-- positioned in Text_Io.Get
--
-- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
function Value_Integer (Str : String) return Int;
-- Used in computing X'Value (Str) where X is a signed integer type whose
-- base range does not exceed the base range of Integer. Str is the string
-- argument of the attribute. Constraint_Error is raised if the string is
-- malformed, or if the value is out of range.
end System.Value_I;

324
gcc/ada/libgnat/s-valueu.adb Normal file
View file

@ -0,0 +1,324 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . V A L U E _ U --
-- --
-- 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 System.Val_Util; use System.Val_Util;
package body System.Value_U is
-----------------------
-- Scan_Raw_Unsigned --
-----------------------
function Scan_Raw_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Uns
is
P : Integer;
-- Local copy of the pointer
Uval : Uns;
-- Accumulated unsigned integer result
Expon : Integer;
-- Exponent value
Overflow : Boolean := False;
-- Set True if overflow is detected at any point
Base_Char : Character;
-- Base character (# or :) in based case
Base : Uns := 10;
-- Base value (reset in based case)
Digit : Uns;
-- Digit value
begin
-- We do not tolerate strings with Str'Last = Positive'Last
if Str'Last = Positive'Last then
raise Program_Error with
"string upper bound is Positive'Last, not supported";
end if;
P := Ptr.all;
Uval := Character'Pos (Str (P)) - Character'Pos ('0');
P := P + 1;
-- Scan out digits of what is either the number or the base.
-- In either case, we are definitely scanning out in base 10.
declare
Umax : constant Uns := (Uns'Last - 9) / 10;
-- Max value which cannot overflow on accumulating next digit
Umax10 : constant Uns := Uns'Last / 10;
-- Numbers bigger than Umax10 overflow if multiplied by 10
begin
-- Loop through decimal digits
loop
exit when P > Max;
Digit := Character'Pos (Str (P)) - Character'Pos ('0');
-- Non-digit encountered
if Digit > 9 then
if Str (P) = '_' then
Scan_Underscore (Str, P, Ptr, Max, False);
else
exit;
end if;
-- Accumulate result, checking for overflow
else
if Uval <= Umax then
Uval := 10 * Uval + Digit;
elsif Uval > Umax10 then
Overflow := True;
else
Uval := 10 * Uval + Digit;
if Uval < Umax10 then
Overflow := True;
end if;
end if;
P := P + 1;
end if;
end loop;
end;
Ptr.all := P;
-- Deal with based case. We recognize either the standard '#' or the
-- allowed alternative replacement ':' (see RM J.2(3)).
if P < Max and then (Str (P) = '#' or else Str (P) = ':') then
Base_Char := Str (P);
P := P + 1;
Base := Uval;
Uval := 0;
-- Check base value. Overflow is set True if we find a bad base, or
-- a digit that is out of range of the base. That way, we scan out
-- the numeral that is still syntactically correct, though illegal.
-- We use a safe base of 16 for this scan, to avoid zero divide.
if Base not in 2 .. 16 then
Overflow := True;
Base := 16;
end if;
-- Scan out based integer
declare
Umax : constant Uns := (Uns'Last - Base + 1) / Base;
-- Max value which cannot overflow on accumulating next digit
UmaxB : constant Uns := Uns'Last / Base;
-- Numbers bigger than UmaxB overflow if multiplied by base
begin
-- Loop to scan out based integer value
loop
-- We require a digit at this stage
if Str (P) in '0' .. '9' then
Digit := Character'Pos (Str (P)) - Character'Pos ('0');
elsif Str (P) in 'A' .. 'F' then
Digit :=
Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
elsif Str (P) in 'a' .. 'f' then
Digit :=
Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
-- If we don't have a digit, then this is not a based number
-- after all, so we use the value we scanned out as the base
-- (now in Base), and the pointer to the base character was
-- already stored in Ptr.all.
else
Uval := Base;
exit;
end if;
-- If digit is too large, just signal overflow and continue.
-- The idea here is to keep scanning as long as the input is
-- syntactically valid, even if we have detected overflow
if Digit >= Base then
Overflow := True;
-- Here we accumulate the value, checking overflow
elsif Uval <= Umax then
Uval := Base * Uval + Digit;
elsif Uval > UmaxB then
Overflow := True;
else
Uval := Base * Uval + Digit;
if Uval < UmaxB then
Overflow := True;
end if;
end if;
-- If at end of string with no base char, not a based number
-- but we signal Constraint_Error and set the pointer past
-- the end of the field, since this is what the ACVC tests
-- seem to require, see CE3704N, line 204.
P := P + 1;
if P > Max then
Ptr.all := P;
Bad_Value (Str);
end if;
-- If terminating base character, we are done with loop
if Str (P) = Base_Char then
Ptr.all := P + 1;
exit;
-- Deal with underscore
elsif Str (P) = '_' then
Scan_Underscore (Str, P, Ptr, Max, True);
end if;
end loop;
end;
end if;
-- Come here with scanned unsigned value in Uval. The only remaining
-- required step is to deal with exponent if one is present.
Expon := Scan_Exponent (Str, Ptr, Max);
if Expon /= 0 and then Uval /= 0 then
-- For non-zero value, scale by exponent value. No need to do this
-- efficiently, since use of exponent in integer literals is rare,
-- and in any case the exponent cannot be very large.
declare
UmaxB : constant Uns := Uns'Last / Base;
-- Numbers bigger than UmaxB overflow if multiplied by base
begin
for J in 1 .. Expon loop
if Uval > UmaxB then
Overflow := True;
exit;
end if;
Uval := Uval * Base;
end loop;
end;
end if;
-- Return result, dealing with sign and overflow
if Overflow then
Bad_Value (Str);
else
return Uval;
end if;
end Scan_Raw_Unsigned;
-------------------
-- Scan_Unsigned --
-------------------
function Scan_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Uns
is
Start : Positive;
-- Save location of first non-blank character
begin
Scan_Plus_Sign (Str, Ptr, Max, Start);
if Str (Ptr.all) not in '0' .. '9' then
Ptr.all := Start;
Bad_Value (Str);
end if;
return Scan_Raw_Unsigned (Str, Ptr, Max);
end Scan_Unsigned;
--------------------
-- Value_Unsigned --
--------------------
function Value_Unsigned (Str : String) return Uns is
begin
-- We have to special case Str'Last = Positive'Last because the normal
-- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
-- deal with this by converting to a subtype which fixes the bounds.
if Str'Last = Positive'Last then
declare
subtype NT is String (1 .. Str'Length);
begin
return Value_Unsigned (NT (Str));
end;
-- Normal case where Str'Last < Positive'Last
else
declare
V : Uns;
P : aliased Integer := Str'First;
begin
V := Scan_Unsigned (Str, P'Access, Str'Last);
Scan_Trailing_Blanks (Str, P);
return V;
end;
end if;
end Value_Unsigned;
end System.Value_U;

131
gcc/ada/libgnat/s-valueu.ads Normal file
View file

@ -0,0 +1,131 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . V A L U E _ U --
-- --
-- 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 routines for scanning modular Unsigned
-- values for use in Text_IO.Modular_IO, and the Value attribute.
generic
type Uns is mod <>;
package System.Value_U is
pragma Preelaborate;
function Scan_Raw_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Uns;
-- This function scans the string starting at Str (Ptr.all) for a valid
-- integer according to the syntax described in (RM 3.5(43)). The substring
-- scanned extends no further than Str (Max). Note: this does not scan
-- leading or trailing blanks, nor leading sign.
--
-- There are three cases for the return:
--
-- If a valid integer is found, then Ptr.all is updated past the last
-- character of the integer.
--
-- If no valid integer is found, then Ptr.all points either to an initial
-- non-digit character, or to Max + 1 if the field is all spaces and the
-- exception Constraint_Error is raised.
--
-- If a syntactically valid integer is scanned, but the value is out of
-- range, or, in the based case, the base value is out of range or there
-- is an out of range digit, then Ptr.all points past the integer, and
-- Constraint_Error is raised.
--
-- Note: these rules correspond to the requirements for leaving the pointer
-- positioned in Text_IO.Get. Note that the rules as stated in the RM would
-- seem to imply that for a case like:
--
-- 8#12345670009#
--
-- the pointer should be left at the first # having scanned out the longest
-- valid integer literal (8), but in fact in this case the pointer points
-- past the final # and Constraint_Error is raised. This is the behavior
-- expected for Text_IO and enforced by the ACATS tests.
--
-- If a based literal is malformed in that a character other than a valid
-- hexadecimal digit is encountered during scanning out the digits after
-- the # (this includes the case of using the wrong terminator, : instead
-- of # or vice versa) there are two cases. If all the digits before the
-- non-digit are in range of the base, as in
--
-- 8#100x00#
-- 8#100:
--
-- then in this case, the "base" value before the initial # is returned as
-- the result, and the pointer points to the initial # character on return.
--
-- If an out of range digit has been detected before the invalid character,
-- as in:
--
-- 8#900x00#
-- 8#900:
--
-- then the pointer is also left at the initial # character, but constraint
-- error is raised reflecting the encounter of an out of range digit.
--
-- Finally if we have an unterminated fixed-point constant where the final
-- # or : character is missing, Constraint_Error is raised and the pointer
-- is left pointing past the last digit, as in:
--
-- 8#22
--
-- This string results in a Constraint_Error with the pointer pointing
-- past the second 2.
--
-- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
--
-- Note: this routine should not be called with Str'Last = Positive'Last.
-- If this occurs Program_Error is raised with a message noting that this
-- case is not supported. Most such cases are eliminated by the caller.
function Scan_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Uns;
-- Same as Scan_Raw_Unsigned, except scans optional leading
-- blanks, and an optional leading plus sign.
--
-- Note: if a minus sign is present, Constraint_Error will be raised.
-- Note: trailing blanks are not scanned.
function Value_Unsigned
(Str : String) return Uns;
-- Used in computing X'Value (Str) where X is a modular integer type whose
-- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str
-- is the string argument of the attribute. Constraint_Error is raised if
-- the string is malformed, or if the value is out of range.
end System.Value_U;

297
gcc/ada/libgnat/s-valuns.adb
View file

@ -29,297 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
with System.Val_Util; use System.Val_Util;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Val_Uns is
-----------------------
-- Scan_Raw_Unsigned --
-----------------------
function Scan_Raw_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Unsigned
is
P : Integer;
-- Local copy of the pointer
Uval : Unsigned;
-- Accumulated unsigned integer result
Expon : Integer;
-- Exponent value
Overflow : Boolean := False;
-- Set True if overflow is detected at any point
Base_Char : Character;
-- Base character (# or :) in based case
Base : Unsigned := 10;
-- Base value (reset in based case)
Digit : Unsigned;
-- Digit value
begin
-- We do not tolerate strings with Str'Last = Positive'Last
if Str'Last = Positive'Last then
raise Program_Error with
"string upper bound is Positive'Last, not supported";
end if;
P := Ptr.all;
Uval := Character'Pos (Str (P)) - Character'Pos ('0');
P := P + 1;
-- Scan out digits of what is either the number or the base.
-- In either case, we are definitely scanning out in base 10.
declare
Umax : constant := (Unsigned'Last - 9) / 10;
-- Max value which cannot overflow on accumulating next digit
Umax10 : constant := Unsigned'Last / 10;
-- Numbers bigger than Umax10 overflow if multiplied by 10
begin
-- Loop through decimal digits
loop
exit when P > Max;
Digit := Character'Pos (Str (P)) - Character'Pos ('0');
-- Non-digit encountered
if Digit > 9 then
if Str (P) = '_' then
Scan_Underscore (Str, P, Ptr, Max, False);
else
exit;
end if;
-- Accumulate result, checking for overflow
else
if Uval <= Umax then
Uval := 10 * Uval + Digit;
elsif Uval > Umax10 then
Overflow := True;
else
Uval := 10 * Uval + Digit;
if Uval < Umax10 then
Overflow := True;
end if;
end if;
P := P + 1;
end if;
end loop;
end;
Ptr.all := P;
-- Deal with based case. We recognize either the standard '#' or the
-- allowed alternative replacement ':' (see RM J.2(3)).
if P < Max and then (Str (P) = '#' or else Str (P) = ':') then
Base_Char := Str (P);
P := P + 1;
Base := Uval;
Uval := 0;
-- Check base value. Overflow is set True if we find a bad base, or
-- a digit that is out of range of the base. That way, we scan out
-- the numeral that is still syntactically correct, though illegal.
-- We use a safe base of 16 for this scan, to avoid zero divide.
if Base not in 2 .. 16 then
Overflow := True;
Base := 16;
end if;
-- Scan out based integer
declare
Umax : constant Unsigned := (Unsigned'Last - Base + 1) / Base;
-- Max value which cannot overflow on accumulating next digit
UmaxB : constant Unsigned := Unsigned'Last / Base;
-- Numbers bigger than UmaxB overflow if multiplied by base
begin
-- Loop to scan out based integer value
loop
-- We require a digit at this stage
if Str (P) in '0' .. '9' then
Digit := Character'Pos (Str (P)) - Character'Pos ('0');
elsif Str (P) in 'A' .. 'F' then
Digit :=
Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
elsif Str (P) in 'a' .. 'f' then
Digit :=
Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
-- If we don't have a digit, then this is not a based number
-- after all, so we use the value we scanned out as the base
-- (now in Base), and the pointer to the base character was
-- already stored in Ptr.all.
else
Uval := Base;
exit;
end if;
-- If digit is too large, just signal overflow and continue.
-- The idea here is to keep scanning as long as the input is
-- syntactically valid, even if we have detected overflow
if Digit >= Base then
Overflow := True;
-- Here we accumulate the value, checking overflow
elsif Uval <= Umax then
Uval := Base * Uval + Digit;
elsif Uval > UmaxB then
Overflow := True;
else
Uval := Base * Uval + Digit;
if Uval < UmaxB then
Overflow := True;
end if;
end if;
-- If at end of string with no base char, not a based number
-- but we signal Constraint_Error and set the pointer past
-- the end of the field, since this is what the ACVC tests
-- seem to require, see CE3704N, line 204.
P := P + 1;
if P > Max then
Ptr.all := P;
Bad_Value (Str);
end if;
-- If terminating base character, we are done with loop
if Str (P) = Base_Char then
Ptr.all := P + 1;
exit;
-- Deal with underscore
elsif Str (P) = '_' then
Scan_Underscore (Str, P, Ptr, Max, True);
end if;
end loop;
end;
end if;
-- Come here with scanned unsigned value in Uval. The only remaining
-- required step is to deal with exponent if one is present.
Expon := Scan_Exponent (Str, Ptr, Max);
if Expon /= 0 and then Uval /= 0 then
-- For non-zero value, scale by exponent value. No need to do this
-- efficiently, since use of exponent in integer literals is rare,
-- and in any case the exponent cannot be very large.
declare
UmaxB : constant Unsigned := Unsigned'Last / Base;
-- Numbers bigger than UmaxB overflow if multiplied by base
begin
for J in 1 .. Expon loop
if Uval > UmaxB then
Overflow := True;
exit;
end if;
Uval := Uval * Base;
end loop;
end;
end if;
-- Return result, dealing with sign and overflow
if Overflow then
Bad_Value (Str);
else
return Uval;
end if;
end Scan_Raw_Unsigned;
-------------------
-- Scan_Unsigned --
-------------------
function Scan_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return Unsigned
is
Start : Positive;
-- Save location of first non-blank character
begin
Scan_Plus_Sign (Str, Ptr, Max, Start);
if Str (Ptr.all) not in '0' .. '9' then
Ptr.all := Start;
Bad_Value (Str);
end if;
return Scan_Raw_Unsigned (Str, Ptr, Max);
end Scan_Unsigned;
--------------------
-- Value_Unsigned --
--------------------
function Value_Unsigned (Str : String) return Unsigned is
begin
-- We have to special case Str'Last = Positive'Last because the normal
-- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
-- deal with this by converting to a subtype which fixes the bounds.
if Str'Last = Positive'Last then
declare
subtype NT is String (1 .. Str'Length);
begin
return Value_Unsigned (NT (Str));
end;
-- Normal case where Str'Last < Positive'Last
else
declare
V : Unsigned;
P : aliased Integer := Str'First;
begin
V := Scan_Unsigned (Str, P'Access, Str'Last);
Scan_Trailing_Blanks (Str, P);
return V;
end;
end if;
end Value_Unsigned;
end System.Val_Uns;
pragma No_Body;

90
gcc/ada/libgnat/s-valuns.ads
View file

@ -33,97 +33,29 @@
-- values for use in Text_IO.Modular_IO, and the Value attribute.
with System.Unsigned_Types;
with System.Value_U;
package System.Val_Uns is
pragma Preelaborate;
subtype Unsigned is Unsigned_Types.Unsigned;
package Impl is new Value_U (Unsigned);
function Scan_Raw_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return System.Unsigned_Types.Unsigned;
-- This function scans the string starting at Str (Ptr.all) for a valid
-- integer according to the syntax described in (RM 3.5(43)). The substring
-- scanned extends no further than Str (Max). Note: this does not scan
-- leading or trailing blanks, nor leading sign.
--
-- There are three cases for the return:
--
-- If a valid integer is found, then Ptr.all is updated past the last
-- character of the integer.
--
-- If no valid integer is found, then Ptr.all points either to an initial
-- non-digit character, or to Max + 1 if the field is all spaces and the
-- exception Constraint_Error is raised.
--
-- If a syntactically valid integer is scanned, but the value is out of
-- range, or, in the based case, the base value is out of range or there
-- is an out of range digit, then Ptr.all points past the integer, and
-- Constraint_Error is raised.
--
-- Note: these rules correspond to the requirements for leaving the pointer
-- positioned in Text_IO.Get. Note that the rules as stated in the RM would
-- seem to imply that for a case like:
--
-- 8#12345670009#
--
-- the pointer should be left at the first # having scanned out the longest
-- valid integer literal (8), but in fact in this case the pointer points
-- past the final # and Constraint_Error is raised. This is the behavior
-- expected for Text_IO and enforced by the ACATS tests.
--
-- If a based literal is malformed in that a character other than a valid
-- hexadecimal digit is encountered during scanning out the digits after
-- the # (this includes the case of using the wrong terminator, : instead
-- of # or vice versa) there are two cases. If all the digits before the
-- non-digit are in range of the base, as in
--
-- 8#100x00#
-- 8#100:
--
-- then in this case, the "base" value before the initial # is returned as
-- the result, and the pointer points to the initial # character on return.
--
-- If an out of range digit has been detected before the invalid character,
-- as in:
--
-- 8#900x00#
-- 8#900:
--
-- then the pointer is also left at the initial # character, but constraint
-- error is raised reflecting the encounter of an out of range digit.
--
-- Finally if we have an unterminated fixed-point constant where the final
-- # or : character is missing, Constraint_Error is raised and the pointer
-- is left pointing past the last digit, as in:
--
-- 8#22
--
-- This string results in a Constraint_Error with the pointer pointing
-- past the second 2.
--
-- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
--
-- Note: this routine should not be called with Str'Last = Positive'Last.
-- If this occurs Program_Error is raised with a message noting that this
-- case is not supported. Most such cases are eliminated by the caller.
Max : Integer) return Unsigned
renames Impl.Scan_Raw_Unsigned;
function Scan_Unsigned
(Str : String;
Ptr : not null access Integer;
Max : Integer) return System.Unsigned_Types.Unsigned;
-- Same as Scan_Raw_Unsigned, except scans optional leading
-- blanks, and an optional leading plus sign.
--
-- Note: if a minus sign is present, Constraint_Error will be raised.
-- Note: trailing blanks are not scanned.
Max : Integer) return Unsigned
renames Impl.Scan_Unsigned;
function Value_Unsigned
(Str : String) return System.Unsigned_Types.Unsigned;
-- Used in computing X'Value (Str) where X is a modular integer type whose
-- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str
-- is the string argument of the attribute. Constraint_Error is raised if
-- the string is malformed, or if the value is out of range.
(Str : String) return Unsigned
renames Impl.Value_Unsigned;
end System.Val_Uns;

41
gcc/ada/libgnat/s-widint.ads Normal file
View file

@ -0,0 +1,41 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D _ I N T --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- Width attribute for signed integers up to Integer
with System.Width_I;
package System.Wid_Int is
function Width_Integer is new Width_I (Integer);
pragma Pure_Function (Width_Integer);
end System.Wid_Int;

45
gcc/ada/libgnat/s-widlli.adb
View file

@ -29,45 +29,8 @@
-- --
------------------------------------------------------------------------------
package body System.Wid_LLI is
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
-----------------------------
-- Width_Long_Long_Integer --
-----------------------------
function Width_Long_Long_Integer
(Lo, Hi : Long_Long_Integer)
return Natural
is
W : Natural;
T : Long_Long_Integer;
begin
if Lo > Hi then
return 0;
else
-- Minimum value is 2, one for sign, one for digit
W := 2;
-- Get max of absolute values, but avoid bomb if we have the maximum
-- negative number (note that First + 1 has same digits as First)
T := Long_Long_Integer'Max (
abs (Long_Long_Integer'Max (Lo, Long_Long_Integer'First + 1)),
abs (Long_Long_Integer'Max (Hi, Long_Long_Integer'First + 1)));
-- Increase value if more digits required
while T >= 10 loop
T := T / 10;
W := W + 1;
end loop;
return W;
end if;
end Width_Long_Long_Integer;
end System.Wid_LLI;
pragma No_Body;

14
gcc/ada/libgnat/s-widlli.ads
View file

@ -29,17 +29,13 @@
-- --
------------------------------------------------------------------------------
-- This package contains the routine used for Width attribute for all
-- non-static signed integer subtypes. Note we only have one routine,
-- since this seems a fairly marginal function.
-- Width attribute for signed integers larger than Integer
with System.Width_I;
package System.Wid_LLI is
pragma Pure;
function Width_Long_Long_Integer
(Lo, Hi : Long_Long_Integer)
return Natural;
-- Compute Width attribute for non-static type derived from a signed
-- Integer type. The arguments Lo, Hi are the bounds of the type.
function Width_Long_Long_Integer is new Width_I (Long_Long_Integer);
pragma Pure_Function (Width_Long_Long_Integer);
end System.Wid_LLI;

42
gcc/ada/libgnat/s-widllli.ads Normal file
View file

@ -0,0 +1,42 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D _ L L L I --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- Width attribute for signed integers larger than Long_Long_Integer
with System.Width_I;
package System.Wid_LLLI is
function Width_Long_Long_Long_Integer is
new Width_I (Long_Long_Long_Integer);
pragma Pure_Function (Width_Long_Long_Long_Integer);
end System.Wid_LLLI;

45
gcc/ada/libgnat/s-widlllu.ads Normal file
View file

@ -0,0 +1,45 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D _ L L L U --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- Width attribute for modular integers larger than Long_Long_Integer
with System.Width_U;
with System.Unsigned_Types;
package System.Wid_LLLU is
subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
function Width_Long_Long_Long_Unsigned is
new Width_U (Long_Long_Long_Unsigned);
pragma Pure_Function (Width_Long_Long_Long_Unsigned);
end System.Wid_LLLU;

45
gcc/ada/libgnat/s-widllu.adb
View file

@ -29,45 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Wid_LLU is
------------------------------
-- Width_Long_Long_Unsigned --
------------------------------
function Width_Long_Long_Unsigned
(Lo, Hi : Long_Long_Unsigned)
return Natural
is
W : Natural;
T : Long_Long_Unsigned;
begin
if Lo > Hi then
return 0;
else
-- Minimum value is 2, one for sign, one for digit
W := 2;
-- Get max of absolute values, but avoid bomb if we have the maximum
-- negative number (note that First + 1 has same digits as First)
T := Long_Long_Unsigned'Max (Lo, Hi);
-- Increase value if more digits required
while T >= 10 loop
T := T / 10;
W := W + 1;
end loop;
return W;
end if;
end Width_Long_Long_Unsigned;
end System.Wid_LLU;
pragma No_Body;

15
gcc/ada/libgnat/s-widllu.ads
View file

@ -29,19 +29,16 @@
-- --
------------------------------------------------------------------------------
-- This package contains the routine used for Width attribute for all
-- non-static unsigned integer (modular integer) subtypes. Note we only
-- have one routine, since this seems a fairly marginal function.
-- Width attribute for modular integers larger than Integer
with System.Width_U;
with System.Unsigned_Types;
package System.Wid_LLU is
pragma Pure;
function Width_Long_Long_Unsigned
(Lo, Hi : System.Unsigned_Types.Long_Long_Unsigned)
return Natural;
-- Compute Width attribute for non-static type derived from a modular
-- integer type. The arguments Lo, Hi are the bounds of the type.
subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
function Width_Long_Long_Unsigned is new Width_U (Long_Long_Unsigned);
pragma Pure_Function (Width_Long_Long_Unsigned);
end System.Wid_LLU;

62
gcc/ada/libgnat/s-widthi.adb Normal file
View file

@ -0,0 +1,62 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D T H _ I --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
function System.Width_I (Lo, Hi : Int) return Natural is
W : Natural;
T : Int;
begin
if Lo > Hi then
return 0;
else
-- Minimum value is 2, one for sign, one for digit
W := 2;
-- Get max of absolute values, but avoid bomb if we have the maximum
-- negative number (note that First + 1 has same digits as First)
T := Int'Max (
abs (Int'Max (Lo, Int'First + 1)),
abs (Int'Max (Hi, Int'First + 1)));
-- Increase value if more digits required
while T >= 10 loop
T := T / 10;
W := W + 1;
end loop;
return W;
end if;
end System.Width_I;

39
gcc/ada/libgnat/s-widthi.ads Normal file
View file

@ -0,0 +1,39 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D T H _ I --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- Compute Width attribute for non-static type derived from a signed integer
-- type. The arguments Lo, Hi are the bounds of the type.
generic
type Int is range <>;
function System.Width_I (Lo, Hi : Int) return Natural;

60
gcc/ada/libgnat/s-widthu.adb Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D T H _ U --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
function System.Width_U (Lo, Hi : Uns) return Natural is
W : Natural;
T : Uns;
begin
if Lo > Hi then
return 0;
else
-- Minimum value is 2, one for sign, one for digit
W := 2;
-- Get max of absolute values, but avoid bomb if we have the maximum
-- negative number (note that First + 1 has same digits as First)
T := Uns'Max (Lo, Hi);
-- Increase value if more digits required
while T >= 10 loop
T := T / 10;
W := W + 1;
end loop;
return W;
end if;
end System.Width_U;

39
gcc/ada/libgnat/s-widthu.ads Normal file
View file

@ -0,0 +1,39 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D T H _ U --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- Compute Width attribute for non-static type derived from a modular integer
-- type. The arguments Lo, Hi are the bounds of the type.
generic
type Uns is mod <>;
function System.Width_U (Lo, Hi : Uns) return Natural;

44
gcc/ada/libgnat/s-widuns.ads Normal file
View file

@ -0,0 +1,44 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D _ U N S --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- Width attribute for modular integers up to Integer
with System.Width_U;
with System.Unsigned_Types;
package System.Wid_Uns is
subtype Unsigned is Unsigned_Types.Unsigned;
function Width_Unsigned is new Width_U (Unsigned);
pragma Pure_Function (Width_Unsigned);
end System.Wid_Uns;

46
gcc/ada/rtsfind.ads
View file

@ -258,7 +258,9 @@ package Rtsfind is
System_Img_Int,
System_Img_LLD,
System_Img_LLI,
System_Img_LLLI,
System_Img_LLU,
System_Img_LLLU,
System_Img_Name,
System_Img_Real,
System_Img_Uns,
@ -420,7 +422,9 @@ package Rtsfind is
System_Val_Int,
System_Val_LLD,
System_Val_LLI,
System_Val_LLLI,
System_Val_LLU,
System_Val_LLLU,
System_Val_Name,
System_Val_Real,
System_Val_Uns,
@ -431,9 +435,13 @@ package Rtsfind is
System_Wid_Bool,
System_Wid_Char,
System_Wid_Enum,
System_Wid_Int,
System_Wid_LLI,
System_Wid_LLLI,
System_Wid_LLU,
System_Wid_LLLU,
System_Wid_Name,
System_Wid_Uns,
System_Wid_WChar,
System_WWd_Char,
System_WWd_Enum,
@ -956,8 +964,12 @@ package Rtsfind is
RE_Image_Long_Long_Integer, -- System.Img_LLI
RE_Image_Long_Long_Long_Integer, -- System.Img_LLLI
RE_Image_Long_Long_Unsigned, -- System.Img_LLU
RE_Image_Long_Long_Long_Unsigned, -- System.Img_LLLU
RE_Image_Ordinary_Fixed_Point, -- System.Img_Real
RE_Image_Floating_Point, -- System.Img_Real
@ -1616,8 +1628,10 @@ package Rtsfind is
RE_Put_Image_Integer, -- System.Put_Images
RE_Put_Image_Long_Long_Integer, -- System.Put_Images
RE_Put_Image_Long_Long_Long_Integer, -- System.Put_Images
RE_Put_Image_Unsigned, -- System.Put_Images
RE_Put_Image_Long_Long_Unsigned, -- System.Put_Images
RE_Put_Image_Long_Long_Long_Unsigned, -- System.Put_Images
RE_Put_Image_Thin_Pointer, -- System.Put_Images
RE_Put_Image_Fat_Pointer, -- System.Put_Images
RE_Put_Image_Access_Subp, -- System.Put_Images
@ -1965,6 +1979,7 @@ package Rtsfind is
RE_Bits_4, -- System.Unsigned_Types
RE_Float_Unsigned, -- System.Unsigned_Types
RE_Long_Long_Unsigned, -- System.Unsigned_Types
RE_Long_Long_Long_Unsigned, -- System.Unsigned_Types
RE_Packed_Byte, -- System.Unsigned_Types
RE_Packed_Bytes1, -- System.Unsigned_Types
RE_Packed_Bytes2, -- System.Unsigned_Types
@ -1990,8 +2005,12 @@ package Rtsfind is
RE_Value_Long_Long_Integer, -- System.Val_LLI
RE_Value_Long_Long_Long_Integer, -- System.Val_LLLI
RE_Value_Long_Long_Unsigned, -- System.Val_LLU
RE_Value_Long_Long_Long_Unsigned, -- System.Val_LLLU
RE_Value_Real, -- System.Val_Real
RE_Value_Unsigned, -- System.Val_Uns
@ -2032,10 +2051,18 @@ package Rtsfind is
RE_Width_Enumeration_16, -- System.Wid_Enum
RE_Width_Enumeration_32, -- System.Wid_Enum
RE_Width_Integer, -- System.Wid_Int
RE_Width_Long_Long_Integer, -- System.Wid_LLI
RE_Width_Long_Long_Long_Integer, -- System.Wid_LLLI
RE_Width_Long_Long_Unsigned, -- System.Wid_LLU
RE_Width_Long_Long_Long_Unsigned, -- System.Wid_LLLU
RE_Width_Unsigned, -- System.Wid_Uns
RE_Width_Wide_Character, -- System.Wid_WChar
RE_Width_Wide_Wide_Character, -- System.Wid_WChar
@ -2592,8 +2619,12 @@ package Rtsfind is
RE_Image_Long_Long_Integer => System_Img_LLI,
RE_Image_Long_Long_Long_Integer => System_Img_LLLI,
RE_Image_Long_Long_Unsigned => System_Img_LLU,
RE_Image_Long_Long_Long_Unsigned => System_Img_LLLU,
RE_Image_Ordinary_Fixed_Point => System_Img_Real,
RE_Image_Floating_Point => System_Img_Real,
@ -3372,8 +3403,10 @@ package Rtsfind is
RE_Put_Image_Integer => System_Put_Images,
RE_Put_Image_Long_Long_Integer => System_Put_Images,
RE_Put_Image_Long_Long_Long_Integer => System_Put_Images,
RE_Put_Image_Unsigned => System_Put_Images,
RE_Put_Image_Long_Long_Unsigned => System_Put_Images,
RE_Put_Image_Long_Long_Long_Unsigned => System_Put_Images,
RE_Put_Image_Thin_Pointer => System_Put_Images,
RE_Put_Image_Fat_Pointer => System_Put_Images,
RE_Put_Image_Access_Subp => System_Put_Images,
@ -3601,6 +3634,7 @@ package Rtsfind is
RE_Bits_4 => System_Unsigned_Types,
RE_Float_Unsigned => System_Unsigned_Types,
RE_Long_Long_Unsigned => System_Unsigned_Types,
RE_Long_Long_Long_Unsigned => System_Unsigned_Types,
RE_Packed_Byte => System_Unsigned_Types,
RE_Packed_Bytes1 => System_Unsigned_Types,
RE_Packed_Bytes2 => System_Unsigned_Types,
@ -3626,8 +3660,12 @@ package Rtsfind is
RE_Value_Long_Long_Integer => System_Val_LLI,
RE_Value_Long_Long_Long_Integer => System_Val_LLLI,
RE_Value_Long_Long_Unsigned => System_Val_LLU,
RE_Value_Long_Long_Long_Unsigned => System_Val_LLLU,
RE_Value_Real => System_Val_Real,
RE_Value_Unsigned => System_Val_Uns,
@ -3669,10 +3707,18 @@ package Rtsfind is
RE_Width_Enumeration_16 => System_Wid_Enum,
RE_Width_Enumeration_32 => System_Wid_Enum,
RE_Width_Integer => System_Wid_Int,
RE_Width_Long_Long_Integer => System_Wid_LLI,
RE_Width_Long_Long_Long_Integer => System_Wid_LLLI,
RE_Width_Long_Long_Unsigned => System_Wid_LLU,
RE_Width_Long_Long_Long_Unsigned => System_Wid_LLLU,
RE_Width_Unsigned => System_Wid_Uns,
RE_Width_Wide_Character => System_Wid_WChar,
RE_Width_Wide_Wide_Character => System_Wid_WChar,