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) \
s-vallli$(objext) \
s-valllu$(objext) \
s-valrea$(objext) \
+ s-valuei$(objext) \
+ s-valueu$(objext) \
s-valuns$(objext) \
s-valuti$(objext) \
s-valwch$(objext) \
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) \
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) \
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/'))
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
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
-- 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
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
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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- --
------------------------------------------------------------------------------
-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;
------------------------------------------------------------------------------
-- 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;
-- --
------------------------------------------------------------------------------
-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;
------------------------------------------------------------------------------
-- 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;
-- --
------------------------------------------------------------------------------
-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;
------------------------------------------------------------------------------
-- 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;
-- --
------------------------------------------------------------------------------
-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;
------------------------------------------------------------------------------
-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- --
------------------------------------------------------------------------------
-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;
------------------------------------------------------------------------------
-- 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;
+ subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
+
+ package Impl is new Image_U (Long_Long_Unsigned);
+
procedure Image_Long_Long_Unsigned
- (V : System.Unsigned_Types.Long_Long_Unsigned;
+ (V : Long_Long_Unsigned;
S : in out String;
- P : out Natural);
- pragma Inline (Image_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.
+ 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;
-- --
------------------------------------------------------------------------------
-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;
------------------------------------------------------------------------------
-- 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;
-- --
------------------------------------------------------------------------------
-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
-- --
------------------------------------------------------------------------------
-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;
------------------------------------------------------------------------------
-- 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;
-- --
------------------------------------------------------------------------------
-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;
------------------------------------------------------------------------------
-- 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;
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;
-- 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
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;
-- --
------------------------------------------------------------------------------
-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;
-- 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;
-- --
------------------------------------------------------------------------------
-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;
-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- --
------------------------------------------------------------------------------
-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;
-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- --
------------------------------------------------------------------------------
-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;
-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- --
------------------------------------------------------------------------------
-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;
-- --
------------------------------------------------------------------------------
--- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- --
------------------------------------------------------------------------------
-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;
-- --
------------------------------------------------------------------------------
--- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
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,
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,
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,
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
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
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
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
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
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,
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,
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,
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,
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,
projects / gcc.git / commitdiff