From cb7584a41d9f565a90fc24c418b2c7f0233ba31e Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 27 Jun 2020 12:39:49 +0200 Subject: [PATCH] [Ada] Support of attributes Image, Put_Image, Val and Width for 128-bit types gcc/ada/ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-widint, s-widthi, s-widuns, s-widuns. (GNATRTL_128BIT_OBJS): Add s-imglllb, s-imgllli, s-imglllu, s-imglllw, s-valllli, s-vallllu, s-widllli, s-widlllu. * exp_imgv.adb (Expand_Image_Attribute): Deal with 128-bit types. (Expand_Value_Attribute): Likewise. (Expand_Width_Attribute): Likewise. * exp_put_image.adb (Build_Elementary_Put_Image_Call): Likewise. * krunch.adb (Krunch): Deal with s-img, s-val and s-wid prefixes. * rtsfind.ads (RTU_Id): Add System_Img_LLLI, System_Img_LLLU, System_Val_LLLI, System_Val_LLL, System_Wid_Int, System_Wid_LLLI, System_Wid_LLLU, System_Wid_Uns). (RE_Id): Add RE_Image_Long_Long_Long_Integer, RE_Image_Long_Long_Long_Unsigned, RE_Put_Image_Long_Long_Long_Integer, RE_Put_Image_Long_Long_Long_Unsigned, RE_Long_Long_Long_Unsigned, RE_Value_Long_Long_Long_Integer, RE_Value_Long_Long_Long_Unsigned, RE_Width_Integer, RE_Width_Long_Long_Long_Integer, RE_Width_Long_Long_Long_Unsigned, RE_Width_Unsigned, RE_Image_Long_Long_Long_Integer, RE_Image_Long_Long_Long_Unsigned, RE_Put_Image_Long_Long_Long_Integer, RE_Put_Image_Long_Long_Long_Unsigned, RE_Long_Long_Long_Unsigned, RE_Value_Long_Long_Long_Integer, RE_Value_Long_Long_Long_Unsigned, RE_Width_Integer, RE_Width_Long_Long_Long_Integer, RE_Width_Long_Long_Long_Unsigned, RE_Width_Unsigned. * libgnat/s-imageb.ads, libgnat/s-imageb.adb: New generic package. * libgnat/s-imagei.ads, libgnat/s-imagei.adb: Likewise. * libgnat/s-imageu.ads, libgnat/s-imageu.adb: Likewise. * libgnat/s-imagew.ads, libgnat/s-imagew.adb: Likewise. * libgnat/s-imgbiu.ads: Instantiate System.Image_B. * libgnat/s-imgbiu.adb: Add pragma No_Body. * libgnat/s-imgint.ads: Instantiate System.Image_I. * libgnat/s-imgint.adb: Add pragma No_Body. * libgnat/s-imgllb.ads: Instantiate System.Image_B. * libgnat/s-imgllb.adb: Add pragma No_Body0 * libgnat/s-imglli.ads: Instantiate System.Image_I. * libgnat/s-imglli.adb: Add pragma No_Body. * libgnat/s-imglllb.ads: Instantiate System.Image_B. * libgnat/s-imgllli.ads: Instantiate System.Image_I. * libgnat/s-imglllu.ads: Instantiate System.Image_U. * libgnat/s-imglllw.ads: Instantiate System.Image_W. * libgnat/s-imgllu.ads: Instantiate System.Image_U. * libgnat/s-imgllu.adb: Add pragma No_Body. * libgnat/s-imgllw.ads: Instantiate System.Image_W. * libgnat/s-imgllw.adb: Add pragma No_Body. * libgnat/s-imgrea.adb: Remove clauses for System.Unsigned_Types. * libgnat/s-imguns.ads: Instantiate System.Image_U. * libgnat/s-imguns.adb: Add pragma No_Body. * libgnat/s-imgwiu.ads: Instantiate System.Image_W. * libgnat/s-imgwiu.adb: Add pragma No_Body. * libgnat/s-putima.ads (Long_Long_Long_Unsigned): New subtype. (Put_Image_Long_Long_Long_Unsigned): New procedure. * libgnat/s-putima.adb (Small): Rename to Integer_Images. (Large): Rename to LL_Integer_Images. (LLL_Integer_Images): New instantiation. (Put_Image_Long_Long_Long_Integer): New renaming. (Put_Image_Long_Long_Long_Unsigned): Likewise. * libgnat/s-valint.ads: Instantiate System.Value_I. * libgnat/s-valint.adb: Add pragma No_Body. * libgnat/s-vallli.ads: Instantiate System.Value_I. * libgnat/s-vallli.adb: Add pragma No_Body. * libgnat/s-valllli.ads: Instantiate System.Value_I. * libgnat/s-vallllu.ads: Instantiate System.Value_U. * libgnat/s-valllu.ads: Instantiate System.Value_U. * libgnat/s-valllu.adb: Add pragma No_Body. * libgnat/s-valuei.ads, libgnat/s-valuei.adb: New generic package. * libgnat/s-valueu.ads, libgnat/s-valueu.adb: Likewise. * libgnat/s-valuns.ads: Instantiate System.Value_U. * libgnat/s-valuns.adb: Add pragma No_Body. * libgnat/s-widint.ads: Instantiate System.Width_I. * libgnat/s-widlli.ads: Likewise. * libgnat/s-widlli.adb: Add pragma No_Body. * libgnat/s-widllli.ads: Instantiate System.Width_I. * libgnat/s-widlllu.ads: Instantiate System.Width_U. * libgnat/s-widllu.ads: Likewise. * libgnat/s-widllu.adb: Add pragma No_Body. * libgnat/s-widthi.ads, libgnat/s-widthi.adb: New generic package. * libgnat/s-widthu.ads, libgnat/s-widthu.adb: Likewise. * libgnat/s-widuns.ads: Instantiate System.Width_U. --- gcc/ada/Makefile.rtl | 20 ++- gcc/ada/exp_imgv.adb | 54 ++++-- gcc/ada/exp_put_image.adb | 12 +- gcc/ada/krunch.adb | 3 + gcc/ada/libgnat/s-imageb.adb | 156 ++++++++++++++++ gcc/ada/libgnat/s-imageb.ads | 75 ++++++++ gcc/ada/libgnat/s-imagei.adb | 121 +++++++++++++ gcc/ada/libgnat/s-imagei.ads | 61 +++++++ gcc/ada/libgnat/s-imageu.adb | 79 +++++++++ gcc/ada/libgnat/s-imageu.ads | 62 +++++++ gcc/ada/libgnat/s-imagew.adb | 152 ++++++++++++++++ gcc/ada/libgnat/s-imagew.ads | 73 ++++++++ gcc/ada/libgnat/s-imgbiu.adb | 130 +------------- gcc/ada/libgnat/s-imgbiu.ads | 34 ++-- gcc/ada/libgnat/s-imgint.adb | 91 +--------- gcc/ada/libgnat/s-imgint.ads | 22 ++- gcc/ada/libgnat/s-imgllb.adb | 133 +------------- gcc/ada/libgnat/s-imgllb.ads | 34 ++-- gcc/ada/libgnat/s-imglli.adb | 91 +--------- gcc/ada/libgnat/s-imglli.ads | 22 ++- gcc/ada/libgnat/s-imglllb.ads | 63 +++++++ gcc/ada/libgnat/s-imgllli.ads | 55 ++++++ gcc/ada/libgnat/s-imglllu.ads | 58 ++++++ gcc/ada/libgnat/s-imglllw.ads | 61 +++++++ gcc/ada/libgnat/s-imgllu.adb | 53 +----- gcc/ada/libgnat/s-imgllu.ads | 29 ++- gcc/ada/libgnat/s-imgllw.adb | 112 +----------- gcc/ada/libgnat/s-imgllw.ads | 31 ++-- gcc/ada/libgnat/s-imgrea.adb | 7 +- gcc/ada/libgnat/s-imguns.adb | 53 +----- gcc/ada/libgnat/s-imguns.ads | 28 ++- gcc/ada/libgnat/s-imgwiu.adb | 125 +------------ gcc/ada/libgnat/s-imgwiu.ads | 33 ++-- gcc/ada/libgnat/s-putima.adb | 21 ++- gcc/ada/libgnat/s-putima.ads | 16 +- gcc/ada/libgnat/s-valint.adb | 90 +--------- gcc/ada/libgnat/s-valint.ads | 42 ++--- gcc/ada/libgnat/s-vallli.adb | 92 +--------- gcc/ada/libgnat/s-vallli.ads | 45 ++--- gcc/ada/libgnat/s-valllli.ads | 59 +++++++ gcc/ada/libgnat/s-vallllu.ads | 61 +++++++ gcc/ada/libgnat/s-valllu.adb | 302 +------------------------------ gcc/ada/libgnat/s-valllu.ads | 90 ++-------- gcc/ada/libgnat/s-valuei.adb | 116 ++++++++++++ gcc/ada/libgnat/s-valuei.ads | 84 +++++++++ gcc/ada/libgnat/s-valueu.adb | 324 ++++++++++++++++++++++++++++++++++ gcc/ada/libgnat/s-valueu.ads | 131 ++++++++++++++ gcc/ada/libgnat/s-valuns.adb | 297 +------------------------------ gcc/ada/libgnat/s-valuns.ads | 90 ++-------- gcc/ada/libgnat/s-widint.ads | 41 +++++ gcc/ada/libgnat/s-widlli.adb | 45 +---- gcc/ada/libgnat/s-widlli.ads | 14 +- gcc/ada/libgnat/s-widllli.ads | 42 +++++ gcc/ada/libgnat/s-widlllu.ads | 45 +++++ gcc/ada/libgnat/s-widllu.adb | 45 +---- gcc/ada/libgnat/s-widllu.ads | 15 +- gcc/ada/libgnat/s-widthi.adb | 62 +++++++ gcc/ada/libgnat/s-widthi.ads | 39 ++++ gcc/ada/libgnat/s-widthu.adb | 60 +++++++ gcc/ada/libgnat/s-widthu.ads | 39 ++++ gcc/ada/libgnat/s-widuns.ads | 44 +++++ gcc/ada/rtsfind.ads | 46 +++++ 62 files changed, 2516 insertions(+), 2014 deletions(-) create mode 100644 gcc/ada/libgnat/s-imageb.adb create mode 100644 gcc/ada/libgnat/s-imageb.ads create mode 100644 gcc/ada/libgnat/s-imagei.adb create mode 100644 gcc/ada/libgnat/s-imagei.ads create mode 100644 gcc/ada/libgnat/s-imageu.adb create mode 100644 gcc/ada/libgnat/s-imageu.ads create mode 100644 gcc/ada/libgnat/s-imagew.adb create mode 100644 gcc/ada/libgnat/s-imagew.ads create mode 100644 gcc/ada/libgnat/s-imglllb.ads create mode 100644 gcc/ada/libgnat/s-imgllli.ads create mode 100644 gcc/ada/libgnat/s-imglllu.ads create mode 100644 gcc/ada/libgnat/s-imglllw.ads create mode 100644 gcc/ada/libgnat/s-valllli.ads create mode 100644 gcc/ada/libgnat/s-vallllu.ads create mode 100644 gcc/ada/libgnat/s-valuei.adb create mode 100644 gcc/ada/libgnat/s-valuei.ads create mode 100644 gcc/ada/libgnat/s-valueu.adb create mode 100644 gcc/ada/libgnat/s-valueu.ads create mode 100644 gcc/ada/libgnat/s-widint.ads create mode 100644 gcc/ada/libgnat/s-widllli.ads create mode 100644 gcc/ada/libgnat/s-widlllu.ads create mode 100644 gcc/ada/libgnat/s-widthi.adb create mode 100644 gcc/ada/libgnat/s-widthi.ads create mode 100644 gcc/ada/libgnat/s-widthu.adb create mode 100644 gcc/ada/libgnat/s-widthu.ads create mode 100644 gcc/ada/libgnat/s-widuns.ads diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 6437a4dd3aa..61da47bb330 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -604,6 +604,10 @@ GNATRTL_NONTASKING_OBJS= \ s-geveop$(objext) \ s-gloloc$(objext) \ s-htable$(objext) \ + s-imageb$(objext) \ + s-imagei$(objext) \ + s-imageu$(objext) \ + s-imagew$(objext) \ s-imenne$(objext) \ s-imgbiu$(objext) \ s-imgboo$(objext) \ @@ -738,6 +742,8 @@ GNATRTL_NONTASKING_OBJS= \ s-vallli$(objext) \ s-valllu$(objext) \ s-valrea$(objext) \ + s-valuei$(objext) \ + s-valueu$(objext) \ s-valuns$(objext) \ s-valuti$(objext) \ s-valwch$(objext) \ @@ -752,8 +758,12 @@ GNATRTL_NONTASKING_OBJS= \ s-widboo$(objext) \ s-widcha$(objext) \ s-widenu$(objext) \ + s-widint$(objext) \ s-widlli$(objext) \ s-widllu$(objext) \ + s-widthi$(objext) \ + s-widthu$(objext) \ + s-widuns$(objext) \ s-widwch$(objext) \ s-wwdcha$(objext) \ s-wwdenu$(objext) \ @@ -883,6 +893,10 @@ GNATRTL_128BIT_OBJS = \ s-exnllli$(objext) \ s-expllli$(objext) \ s-explllu$(objext) \ + s-imglllb$(objext) \ + s-imgllli$(objext) \ + s-imglllu$(objext) \ + s-imglllw$(objext) \ s-pack65$(objext) \ s-pack66$(objext) \ s-pack67$(objext) \ @@ -945,7 +959,11 @@ GNATRTL_128BIT_OBJS = \ s-pack124$(objext) \ s-pack125$(objext) \ s-pack126$(objext) \ - s-pack127$(objext) + s-pack127$(objext) \ + s-valllli$(objext) \ + s-vallllu$(objext) \ + s-widllli$(objext) \ + s-widlllu$(objext) # Shared library version LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(GNAT_SRC)/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/')) diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index a3c73fa4f09..5850b5d2fe1 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -570,21 +570,27 @@ package body Exp_Imgv is Tent := Rtyp; elsif Is_Signed_Integer_Type (Rtyp) then - if Esize (Rtyp) <= Esize (Standard_Integer) then + if Esize (Rtyp) <= Standard_Integer_Size then Imid := RE_Image_Integer; Tent := Standard_Integer; - else + elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then Imid := RE_Image_Long_Long_Integer; Tent := Standard_Long_Long_Integer; + else + Imid := RE_Image_Long_Long_Long_Integer; + Tent := Standard_Long_Long_Long_Integer; end if; elsif Is_Modular_Integer_Type (Rtyp) then if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then Imid := RE_Image_Unsigned; Tent := RTE (RE_Unsigned); - else + elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then Imid := RE_Image_Long_Long_Unsigned; Tent := RTE (RE_Long_Long_Unsigned); + else + Imid := RE_Image_Long_Long_Long_Unsigned; + Tent := RTE (RE_Long_Long_Long_Unsigned); end if; elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then @@ -895,20 +901,22 @@ package body Exp_Imgv is Make_Integer_Literal (Loc, Intval => Int (Wide_Character_Encoding_Method))); - elsif Rtyp = Base_Type (Standard_Short_Short_Integer) - or else Rtyp = Base_Type (Standard_Short_Integer) - or else Rtyp = Base_Type (Standard_Integer) - then - Vid := RE_Value_Integer; - elsif Is_Signed_Integer_Type (Rtyp) then - Vid := RE_Value_Long_Long_Integer; + if Esize (Rtyp) <= Standard_Integer_Size then + Vid := RE_Value_Integer; + elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then + Vid := RE_Value_Long_Long_Integer; + else + Vid := RE_Value_Long_Long_Long_Integer; + end if; elsif Is_Modular_Integer_Type (Rtyp) then if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then Vid := RE_Value_Unsigned; - else + elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then Vid := RE_Value_Long_Long_Unsigned; + else + Vid := RE_Value_Long_Long_Long_Unsigned; end if; elsif Is_Decimal_Fixed_Point_Type (Rtyp) then @@ -1415,14 +1423,30 @@ package body Exp_Imgv is -- Signed integer types elsif Is_Signed_Integer_Type (Rtyp) then - XX := RE_Width_Long_Long_Integer; - YY := Standard_Long_Long_Integer; + if Esize (Rtyp) <= Standard_Integer_Size then + XX := RE_Width_Integer; + YY := Standard_Integer; + elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then + XX := RE_Width_Long_Long_Integer; + YY := Standard_Long_Long_Integer; + else + XX := RE_Width_Long_Long_Long_Integer; + YY := Standard_Long_Long_Long_Integer; + end if; -- Modular integer types elsif Is_Modular_Integer_Type (Rtyp) then - XX := RE_Width_Long_Long_Unsigned; - YY := RTE (RE_Long_Long_Unsigned); + if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then + XX := RE_Width_Unsigned; + YY := RTE (RE_Unsigned); + elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then + XX := RE_Width_Long_Long_Unsigned; + YY := RTE (RE_Long_Long_Unsigned); + else + XX := RE_Width_Long_Long_Long_Unsigned; + YY := RTE (RE_Long_Long_Long_Unsigned); + end if; -- Real types diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index 1933bd0597b..3fae3174ea1 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -300,17 +300,21 @@ package body Exp_Put_Image is if Is_Signed_Integer_Type (U_Type) then if P_Size <= Standard_Integer_Size then Lib_RE := RE_Put_Image_Integer; - else - pragma Assert (P_Size <= Standard_Long_Long_Integer_Size); + elsif P_Size <= Standard_Long_Long_Integer_Size then Lib_RE := RE_Put_Image_Long_Long_Integer; + else + pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size); + Lib_RE := RE_Put_Image_Long_Long_Long_Integer; end if; elsif Is_Modular_Integer_Type (U_Type) then if P_Size <= Standard_Integer_Size then -- Yes, Integer Lib_RE := RE_Put_Image_Unsigned; - else - pragma Assert (P_Size <= Standard_Long_Long_Integer_Size); + elsif P_Size <= Standard_Long_Long_Integer_Size then Lib_RE := RE_Put_Image_Long_Long_Unsigned; + else + pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size); + Lib_RE := RE_Put_Image_Long_Long_Long_Unsigned; end if; elsif Is_Access_Type (U_Type) then diff --git a/gcc/ada/krunch.adb b/gcc/ada/krunch.adb index 2b67849c068..ceeba11a38b 100644 --- a/gcc/ada/krunch.adb +++ b/gcc/ada/krunch.adb @@ -92,6 +92,9 @@ begin if Buffer (Curlen - 2 .. Curlen) = "128" or else Buffer (3 .. 9) = "exn_lll" or else Buffer (3 .. 9) = "exp_lll" + or else Buffer (3 .. 9) = "img_lll" + or else Buffer (3 .. 9) = "val_lll" + or else Buffer (3 .. 9) = "wid_lll" or else (Buffer (3 .. 6) = "pack" and then Curlen = 10) then if Buffer (3 .. 15) = "compare_array" then diff --git a/gcc/ada/libgnat/s-imageb.adb b/gcc/ada/libgnat/s-imageb.adb new file mode 100644 index 00000000000..72e8fb369e0 --- /dev/null +++ b/gcc/ada/libgnat/s-imageb.adb @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imageb.ads b/gcc/ada/libgnat/s-imageb.ads new file mode 100644 index 00000000000..109f5c7914e --- /dev/null +++ b/gcc/ada/libgnat/s-imageb.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb new file mode 100644 index 00000000000..c739dfb8af6 --- /dev/null +++ b/gcc/ada/libgnat/s-imagei.adb @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imagei.ads b/gcc/ada/libgnat/s-imagei.ads new file mode 100644 index 00000000000..2163af8c53b --- /dev/null +++ b/gcc/ada/libgnat/s-imagei.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imageu.adb b/gcc/ada/libgnat/s-imageu.adb new file mode 100644 index 00000000000..c995d554d17 --- /dev/null +++ b/gcc/ada/libgnat/s-imageu.adb @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imageu.ads b/gcc/ada/libgnat/s-imageu.ads new file mode 100644 index 00000000000..39e738a6ba9 --- /dev/null +++ b/gcc/ada/libgnat/s-imageu.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imagew.adb b/gcc/ada/libgnat/s-imagew.adb new file mode 100644 index 00000000000..dd3b96eb430 --- /dev/null +++ b/gcc/ada/libgnat/s-imagew.adb @@ -0,0 +1,152 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ W -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imagew.ads b/gcc/ada/libgnat/s-imagew.ads new file mode 100644 index 00000000000..14c0c603896 --- /dev/null +++ b/gcc/ada/libgnat/s-imagew.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ W -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imgbiu.adb b/gcc/ada/libgnat/s-imgbiu.adb index 7b765c09fa9..fbbbcecf4dc 100644 --- a/gcc/ada/libgnat/s-imgbiu.adb +++ b/gcc/ada/libgnat/s-imgbiu.adb @@ -29,130 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_BIU is - - ----------------------------- - -- Set_Image_Based_Integer -- - ----------------------------- - - procedure Set_Image_Based_Integer - (V : Integer; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Based_Unsigned (Unsigned (V), B, W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Based_Unsigned (Unsigned (-V), B, W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Based_Integer; - - ------------------------------ - -- Set_Image_Based_Unsigned -- - ------------------------------ - - procedure Set_Image_Based_Unsigned - (V : Unsigned; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - BU : constant Unsigned := Unsigned (B); - Hex : constant array - (Unsigned range 0 .. 15) of Character := "0123456789ABCDEF"; - - procedure Set_Digits (T : Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Unsigned) is - begin - if T >= BU then - Set_Digits (T / BU); - P := P + 1; - S (P) := Hex (T mod BU); - else - P := P + 1; - S (P) := Hex (T); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Based_Unsigned - - begin - - if B >= 10 then - P := P + 1; - S (P) := '1'; - end if; - - P := P + 1; - S (P) := Character'Val (Character'Pos ('0') + B mod 10); - - P := P + 1; - S (P) := '#'; - - Set_Digits (V); - - P := P + 1; - S (P) := '#'; - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := Start + W; - T := P; - - while F > Start loop - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - S (J) := ' '; - end loop; - end if; - - end Set_Image_Based_Unsigned; - -end System.Img_BIU; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgbiu.ads b/gcc/ada/libgnat/s-imgbiu.ads index 524e5823555..9cf24ae85ab 100644 --- a/gcc/ada/libgnat/s-imgbiu.ads +++ b/gcc/ada/libgnat/s-imgbiu.ads @@ -30,43 +30,33 @@ ------------------------------------------------------------------------------ -- Contains the routine for computing the image in based format of signed and --- unsigned integers whose size <= Integer'Size for use by Text_IO.Integer_IO --- and Text_IO.Modular_IO. +-- unsigned integers up to Integer for use by Text_IO.Integer_IO and +-- Text_IO.Modular_IO. +with System.Image_B; with System.Unsigned_Types; package System.Img_BIU is pragma Pure; + subtype Unsigned is Unsigned_Types.Unsigned; + + package Impl is new Image_B (Integer, Unsigned); + procedure Set_Image_Based_Integer (V : Integer; B : Natural; W : Integer; S : out String; - P : in out Natural); - -- Sets the signed image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes a leading minus sign if necessary, but no leading - -- spaces unless W is positive, in which case leading spaces are output if - -- necessary to ensure that the output string is no less than W characters - -- long. The caller promises that the buffer is large enough and no check - -- is made for this. Constraint_Error will not necessarily be raised if - -- this is violated, since it is perfectly valid to compile this unit with - -- checks off. + P : in out Natural) + renames Impl.Set_Image_Based_Integer; procedure Set_Image_Based_Unsigned - (V : System.Unsigned_Types.Unsigned; + (V : Unsigned; B : Natural; W : Integer; S : out String; - P : in out Natural); - -- Sets the unsigned image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes no leading spaces unless W is positive, in which case - -- leading spaces are output if necessary to ensure that the output string - -- is no less than W characters long. The caller promises that the buffer - -- is large enough and no check is made for this. Constraint_Error will not - -- necessarily be raised if this is violated, since it is perfectly valid - -- to compile this unit with checks off). + P : in out Natural) + renames Impl.Set_Image_Based_Unsigned; end System.Img_BIU; diff --git a/gcc/ada/libgnat/s-imgint.adb b/gcc/ada/libgnat/s-imgint.adb index 112d62bcc4c..acadd1c494d 100644 --- a/gcc/ada/libgnat/s-imgint.adb +++ b/gcc/ada/libgnat/s-imgint.adb @@ -29,91 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body System.Img_Int is +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. - subtype Non_Positive is Integer range Integer'First .. 0; - - procedure Set_Digits - (T : Non_Positive; - S : in out String; - P : in out Natural); - -- Set digits of absolute value of T, which is zero or negative. We work - -- with the negative of the value so that the largest negative number is - -- not a special case. - - ------------------- - -- Image_Integer -- - ------------------- - - procedure Image_Integer - (V : Integer; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - - begin - if V >= 0 then - S (1) := ' '; - P := 1; - else - P := 0; - end if; - - Set_Image_Integer (V, S, P); - end Image_Integer; - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits - (T : Non_Positive; - S : in out String; - P : in out Natural) - is - begin - if T <= -10 then - Set_Digits (T / 10, S, P); - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done since, as documented in the Set_Image_Integer - -- specification, the caller guarantees that S is long enough to - -- hold the result. - P := P + 1; - S (P) := Character'Val (48 - (T rem 10)); - else - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done since, as documented in the Set_Image_Integer - -- specification, the caller guarantees that S is long enough to - -- hold the result. - P := P + 1; - S (P) := Character'Val (48 - T); - end if; - end Set_Digits; - - ----------------------- - -- Set_Image_Integer -- - ----------------------- - - procedure Set_Image_Integer - (V : Integer; - S : in out String; - P : in out Natural) - is - begin - if V >= 0 then - Set_Digits (-V, S, P); - else - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done since, as documented in the specification, - -- the caller guarantees that S is long enough to hold the result. - P := P + 1; - S (P) := '-'; - Set_Digits (V, S, P); - end if; - end Set_Image_Integer; - -end System.Img_Int; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgint.ads b/gcc/ada/libgnat/s-imgint.ads index 6c2c675220b..08ce31db437 100644 --- a/gcc/ada/libgnat/s-imgint.ads +++ b/gcc/ada/libgnat/s-imgint.ads @@ -30,28 +30,26 @@ ------------------------------------------------------------------------------ -- This package contains the routines for supporting the Image attribute for --- signed integer types up to Size Integer'Size, and also for conversion --- operations required in Text_IO.Integer_IO for such types. +-- signed integer types up to Integer, and also for conversion operations +-- required in Text_IO.Integer_IO for such types. + +with System.Image_I; package System.Img_Int is pragma Pure; + package Impl is new Image_I (Integer); + procedure Image_Integer (V : Integer; S : in out String; - P : out Natural); - -- Computes Integer'Image (V) and stores the result in S (1 .. P) - -- setting the resulting value of P. The caller guarantees that S - -- is long enough to hold the result, and that S'First is 1. + P : out Natural) + renames Impl.Image_Integer; procedure Set_Image_Integer (V : Integer; S : in out String; - P : in out Natural); - -- Stores the image of V in S starting at S (P + 1), P is updated to point - -- to the last character stored. The value stored is identical to the value - -- of Integer'Image (V) except that no leading space is stored when V is - -- non-negative. The caller guarantees that S is long enough to hold the - -- result. S need not have a lower bound of 1. + P : in out Natural) + renames Impl.Set_Image_Integer; end System.Img_Int; diff --git a/gcc/ada/libgnat/s-imgllb.adb b/gcc/ada/libgnat/s-imgllb.adb index 30d6a3c8e8e..90ba5ce90b1 100644 --- a/gcc/ada/libgnat/s-imgllb.adb +++ b/gcc/ada/libgnat/s-imgllb.adb @@ -29,133 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_LLB is - - --------------------------------------- - -- Set_Image_Based_Long_Long_Integer -- - --------------------------------------- - - procedure Set_Image_Based_Long_Long_Integer - (V : Long_Long_Integer; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Based_Long_Long_Unsigned - (Long_Long_Unsigned (V), B, W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Based_Long_Long_Unsigned - (Long_Long_Unsigned (-V), B, W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Based_Long_Long_Integer; - - ---------------------------------------- - -- Set_Image_Based_Long_Long_Unsigned -- - ---------------------------------------- - - procedure Set_Image_Based_Long_Long_Unsigned - (V : Long_Long_Unsigned; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - BU : constant Long_Long_Unsigned := Long_Long_Unsigned (B); - Hex : constant array - (Long_Long_Unsigned range 0 .. 15) of Character := - "0123456789ABCDEF"; - - procedure Set_Digits (T : Long_Long_Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Long_Long_Unsigned) is - begin - if T >= BU then - Set_Digits (T / BU); - P := P + 1; - S (P) := Hex (T mod BU); - else - P := P + 1; - S (P) := Hex (T); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Based_Long_Long_Unsigned - - begin - - if B >= 10 then - P := P + 1; - S (P) := '1'; - end if; - - P := P + 1; - S (P) := Character'Val (Character'Pos ('0') + B mod 10); - - P := P + 1; - S (P) := '#'; - - Set_Digits (V); - - P := P + 1; - S (P) := '#'; - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := Start + W; - T := P; - - while F > Start loop - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - S (J) := ' '; - end loop; - end if; - - end Set_Image_Based_Long_Long_Unsigned; - -end System.Img_LLB; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgllb.ads b/gcc/ada/libgnat/s-imgllb.ads index 0232315d05b..bfaf2ee46f6 100644 --- a/gcc/ada/libgnat/s-imgllb.ads +++ b/gcc/ada/libgnat/s-imgllb.ads @@ -30,43 +30,33 @@ ------------------------------------------------------------------------------ -- Contains the routine for computing the image in based format of signed and --- unsigned integers whose size > Integer'Size for use by Text_IO.Integer_IO --- and Text_IO.Modular_IO. +-- unsigned integers larger than Integer for use by Text_IO.Integer_IO and +-- Text_IO.Modular_IO. +with System.Image_B; with System.Unsigned_Types; package System.Img_LLB is pragma Preelaborate; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + package Impl is new Image_B (Long_Long_Integer, Long_Long_Unsigned); + procedure Set_Image_Based_Long_Long_Integer (V : Long_Long_Integer; B : Natural; W : Integer; S : out String; - P : in out Natural); - -- Sets the signed image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes a leading minus sign if necessary, but no leading - -- spaces unless W is positive, in which case leading spaces are output if - -- necessary to ensure that the output string is no less than W characters - -- long. The caller promises that the buffer is large enough and no check - -- is made for this. Constraint_Error will not necessarily be raised if - -- this is violated, since it is perfectly valid to compile this unit with - -- checks off. + P : in out Natural) + renames Impl.Set_Image_Based_Integer; procedure Set_Image_Based_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; + (V : Long_Long_Unsigned; B : Natural; W : Integer; S : out String; - P : in out Natural); - -- Sets the unsigned image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes no leading spaces unless W is positive, in which case - -- leading spaces are output if necessary to ensure that the output string - -- is no less than W characters long. The caller promises that the buffer - -- is large enough and no check is made for this. Constraint_Error will not - -- necessarily be raised if this is violated, since it is perfectly valid - -- to compile this unit with checks off). + P : in out Natural) + renames Impl.Set_Image_Based_Unsigned; end System.Img_LLB; diff --git a/gcc/ada/libgnat/s-imglli.adb b/gcc/ada/libgnat/s-imglli.adb index 66332fe0fca..cdaeb7eba38 100644 --- a/gcc/ada/libgnat/s-imglli.adb +++ b/gcc/ada/libgnat/s-imglli.adb @@ -29,91 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body System.Img_LLI is +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. - subtype Non_Positive is Long_Long_Integer - range Long_Long_Integer'First .. 0; - - procedure Set_Digits - (T : Non_Positive; - S : in out String; - P : in out Natural); - -- Set digits of absolute value of T, which is zero or negative. We work - -- with the negative of the value so that the largest negative number is - -- not a special case. - - ----------------------------- - -- Image_Long_Long_Integer -- - ----------------------------- - - procedure Image_Long_Long_Integer - (V : Long_Long_Integer; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - - begin - if V >= 0 then - S (1) := ' '; - P := 1; - else - P := 0; - end if; - - Set_Image_Long_Long_Integer (V, S, P); - end Image_Long_Long_Integer; - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits - (T : Non_Positive; - S : in out String; - P : in out Natural) - is - begin - if T <= -10 then - Set_Digits (T / 10, S, P); - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done as documented in the Set_Image_Long_Long_Integer - -- specification: The caller guarantees that S is long enough to - -- hold the result. - P := P + 1; - S (P) := Character'Val (48 - (T rem 10)); - else - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done as documented in the Set_Image_Long_Long_Integer - -- specification: The caller guarantees that S is long enough to - -- hold the result. - P := P + 1; - S (P) := Character'Val (48 - T); - end if; - end Set_Digits; - - --------------------------------- - -- Set_Image_Long_Long_Integer -- - -------------------------------- - - procedure Set_Image_Long_Long_Integer - (V : Long_Long_Integer; - S : in out String; - P : in out Natural) is - begin - if V >= 0 then - Set_Digits (-V, S, P); - else - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done as documented in the specification: - -- The caller guarantees that S is long enough to hold the result. - P := P + 1; - S (P) := '-'; - Set_Digits (V, S, P); - end if; - end Set_Image_Long_Long_Integer; - -end System.Img_LLI; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads index b0d3cae93af..49defc5746d 100644 --- a/gcc/ada/libgnat/s-imglli.ads +++ b/gcc/ada/libgnat/s-imglli.ads @@ -30,28 +30,26 @@ ------------------------------------------------------------------------------ -- This package contains the routines for supporting the Image attribute for --- signed integer types larger than Size Integer'Size, and also for conversion --- operations required in Text_IO.Integer_IO for such types. +-- signed integer types larger Integer, and also for conversion operations +-- required in Text_IO.Integer_IO for such types. + +with System.Image_I; package System.Img_LLI is pragma Pure; + package Impl is new Image_I (Long_Long_Integer); + procedure Image_Long_Long_Integer (V : Long_Long_Integer; S : in out String; - P : out Natural); - -- Computes Long_Long_Integer'Image (V) and stores the result in - -- S (1 .. P) setting the resulting value of P. The caller guarantees - -- that S is long enough to hold the result, and that S'First is 1. + P : out Natural) + renames Impl.Image_Integer; procedure Set_Image_Long_Long_Integer (V : Long_Long_Integer; S : in out String; - P : in out Natural); - -- Stores the image of V in S starting at S (P + 1), P is updated to point - -- to the last character stored. The value stored is identical to the value - -- of Long_Long_Integer'Image (V) except that no leading space is stored - -- when V is non-negative. The caller guarantees that S is long enough to - -- hold the result. S need not have a lower bound of 1. + P : in out Natural) + renames Impl.Set_Image_Integer; end System.Img_LLI; diff --git a/gcc/ada/libgnat/s-imglllb.ads b/gcc/ada/libgnat/s-imglllb.ads new file mode 100644 index 00000000000..b2460376527 --- /dev/null +++ b/gcc/ada/libgnat/s-imglllb.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L L B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imgllli.ads b/gcc/ada/libgnat/s-imgllli.ads new file mode 100644 index 00000000000..c6d41f9cbf7 --- /dev/null +++ b/gcc/ada/libgnat/s-imgllli.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imglllu.ads b/gcc/ada/libgnat/s-imglllu.ads new file mode 100644 index 00000000000..8b6f16a2cf2 --- /dev/null +++ b/gcc/ada/libgnat/s-imglllu.ads @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L L U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imglllw.ads b/gcc/ada/libgnat/s-imglllw.ads new file mode 100644 index 00000000000..de33f186e26 --- /dev/null +++ b/gcc/ada/libgnat/s-imglllw.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L W -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imgllu.adb b/gcc/ada/libgnat/s-imgllu.adb index e2952ee0825..680b11b8e87 100644 --- a/gcc/ada/libgnat/s-imgllu.adb +++ b/gcc/ada/libgnat/s-imgllu.adb @@ -29,53 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_LLU is - - ------------------------------ - -- Image_Long_Long_Unsigned -- - ------------------------------ - - procedure Image_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - begin - S (1) := ' '; - P := 1; - Set_Image_Long_Long_Unsigned (V, S, P); - end Image_Long_Long_Unsigned; - - ---------------------------------- - -- Set_Image_Long_Long_Unsigned -- - ---------------------------------- - - procedure Set_Image_Long_Long_Unsigned - (V : Long_Long_Unsigned; - S : in out String; - P : in out Natural) - is - begin - if V >= 10 then - Set_Image_Long_Long_Unsigned (V / 10, S, P); - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done since, as documented in the specification, the - -- caller guarantees that S is long enough to hold the result. - P := P + 1; - S (P) := Character'Val (48 + (V rem 10)); - - else - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done since, as documented in the specification, the - -- caller guarantees that S is long enough to hold the result. - P := P + 1; - S (P) := Character'Val (48 + V); - end if; - end Set_Image_Long_Long_Unsigned; - -end System.Img_LLU; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgllu.ads b/gcc/ada/libgnat/s-imgllu.ads index d54bb33a609..dabc68d0a17 100644 --- a/gcc/ada/libgnat/s-imgllu.ads +++ b/gcc/ada/libgnat/s-imgllu.ads @@ -30,32 +30,29 @@ ------------------------------------------------------------------------------ -- This package contains the routines for supporting the Image attribute for --- unsigned (modular) integer types larger than Size Unsigned'Size, and also --- for conversion operations required in Text_IO.Modular_IO for such types. +-- modular integer types larger than Unsigned, and also for conversion +-- operations required in Text_IO.Modular_IO for such types. +with System.Image_U; with System.Unsigned_Types; package System.Img_LLU is pragma Pure; + 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; diff --git a/gcc/ada/libgnat/s-imgllw.adb b/gcc/ada/libgnat/s-imgllw.adb index cfd4fc23d81..5702a932643 100644 --- a/gcc/ada/libgnat/s-imgllw.adb +++ b/gcc/ada/libgnat/s-imgllw.adb @@ -29,112 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_LLW is - - --------------------------------------- - -- Set_Image_Width_Long_Long_Integer -- - --------------------------------------- - - procedure Set_Image_Width_Long_Long_Integer - (V : Long_Long_Integer; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Width_Long_Long_Unsigned - (Long_Long_Unsigned (V), W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Width_Long_Long_Unsigned - (Long_Long_Unsigned (-V), W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Width_Long_Long_Integer; - - ---------------------------------------- - -- Set_Image_Width_Long_Long_Unsigned -- - ---------------------------------------- - - procedure Set_Image_Width_Long_Long_Unsigned - (V : Long_Long_Unsigned; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - - procedure Set_Digits (T : Long_Long_Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Long_Long_Unsigned) is - begin - if T >= 10 then - Set_Digits (T / 10); - P := P + 1; - S (P) := Character'Val (T mod 10 + Character'Pos ('0')); - else - P := P + 1; - S (P) := Character'Val (T + Character'Pos ('0')); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Width_Long_Long_Unsigned - - begin - Set_Digits (V); - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := P + (W - (P - Start)); - T := P; - - while F > Start loop - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - S (J) := ' '; - end loop; - end if; - - end Set_Image_Width_Long_Long_Unsigned; - -end System.Img_LLW; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgllw.ads b/gcc/ada/libgnat/s-imgllw.ads index e6e5fb0a4ca..12986e5b37a 100644 --- a/gcc/ada/libgnat/s-imgllw.ads +++ b/gcc/ada/libgnat/s-imgllw.ads @@ -30,40 +30,31 @@ ------------------------------------------------------------------------------ -- Contains the routine for computing the image of signed and unsigned --- integers whose size > Integer'Size for use by Text_IO.Integer_IO, +-- integers larger than Integer for use by Text_IO.Integer_IO and -- Text_IO.Modular_IO. +with System.Image_W; with System.Unsigned_Types; package System.Img_LLW is pragma Pure; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + package Impl is new Image_W (Long_Long_Integer, Long_Long_Unsigned); + procedure Set_Image_Width_Long_Long_Integer (V : Long_Long_Integer; W : Integer; S : out String; - P : in out Natural); - -- Sets the signed image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes - -- a leading minus sign if necessary, but no leading spaces unless W is - -- positive, in which case leading spaces are output if necessary to ensure - -- that the output string is no less than W characters long. The caller - -- promises that the buffer is large enough and no check is made for this. - -- Constraint_Error will not necessarily be raised if this is violated, - -- since it is perfectly valid to compile this unit with checks off. + P : in out Natural) + renames Impl.Set_Image_Width_Integer; procedure Set_Image_Width_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; + (V : Long_Long_Unsigned; W : Integer; S : out String; - P : in out Natural); - -- Sets the unsigned image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes no - -- leading spaces unless W is positive, in which case leading spaces are - -- output if necessary to ensure that the output string is no less than - -- W characters long. The caller promises that the buffer is large enough - -- and no check is made for this. Constraint_Error will not necessarily be - -- raised if this is violated, since it is perfectly valid to compile this - -- unit with checks off. + P : in out Natural) + renames Impl.Set_Image_Width_Unsigned; end System.Img_LLW; diff --git a/gcc/ada/libgnat/s-imgrea.adb b/gcc/ada/libgnat/s-imgrea.adb index a37e8790c49..3c3ffe1594d 100644 --- a/gcc/ada/libgnat/s-imgrea.adb +++ b/gcc/ada/libgnat/s-imgrea.adb @@ -29,10 +29,9 @@ -- -- ------------------------------------------------------------------------------ -with System.Img_LLU; use System.Img_LLU; -with System.Img_Uns; use System.Img_Uns; -with System.Powten_Table; use System.Powten_Table; -with System.Unsigned_Types; use System.Unsigned_Types; +with System.Img_LLU; use System.Img_LLU; +with System.Img_Uns; use System.Img_Uns; +with System.Powten_Table; use System.Powten_Table; with System.Float_Control; package body System.Img_Real is diff --git a/gcc/ada/libgnat/s-imguns.adb b/gcc/ada/libgnat/s-imguns.adb index 02195e3c3d3..8db42b416ce 100644 --- a/gcc/ada/libgnat/s-imguns.adb +++ b/gcc/ada/libgnat/s-imguns.adb @@ -29,53 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_Uns is - - -------------------- - -- Image_Unsigned -- - -------------------- - - procedure Image_Unsigned - (V : System.Unsigned_Types.Unsigned; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - begin - S (1) := ' '; - P := 1; - Set_Image_Unsigned (V, S, P); - end Image_Unsigned; - - ------------------------ - -- Set_Image_Unsigned -- - ------------------------ - - procedure Set_Image_Unsigned - (V : Unsigned; - S : in out String; - P : in out Natural) - is - pragma Assert (S'First = 1); - begin - if V >= 10 then - Set_Image_Unsigned (V / 10, S, P); - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done since, as documented in the specification, - -- the caller guarantees that S is long enough to hold the result. - P := P + 1; - S (P) := Character'Val (48 + (V rem 10)); - else - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done since, as documented in the specification, - -- the caller guarantees that S is long enough to hold the result. - P := P + 1; - S (P) := Character'Val (48 + V); - end if; - end Set_Image_Unsigned; - -end System.Img_Uns; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imguns.ads b/gcc/ada/libgnat/s-imguns.ads index 86e6d9955f5..746fff125bb 100644 --- a/gcc/ada/libgnat/s-imguns.ads +++ b/gcc/ada/libgnat/s-imguns.ads @@ -30,31 +30,29 @@ ------------------------------------------------------------------------------ -- This package contains the routines for supporting the Image attribute for --- modular integer types up to size Unsigned'Size, and also for conversion --- operations required in Text_IO.Modular_IO for such types. +-- modular integer types up to Unsigned, and also for conversion operations +-- required in Text_IO.Modular_IO for such types. +with System.Image_U; with System.Unsigned_Types; package System.Img_Uns is pragma Pure; + subtype Unsigned is Unsigned_Types.Unsigned; + + package Impl is new Image_U (Unsigned); + procedure Image_Unsigned - (V : System.Unsigned_Types.Unsigned; + (V : Unsigned; S : in out String; - P : out Natural); - pragma Inline (Image_Unsigned); - -- Computes Unsigned'Image (V) and stores the result in S (1 .. P) setting - -- the resulting value of P. The caller guarantees that S is long enough to - -- hold the result, and that S'First is 1. + P : out Natural) + renames Impl.Image_Unsigned; procedure Set_Image_Unsigned - (V : System.Unsigned_Types.Unsigned; + (V : Unsigned; S : in out String; - P : in out Natural); - -- Stores the image of V in S starting at S (P + 1), P is updated to point - -- to the last character stored. The value stored is identical to the value - -- of Unsigned'Image (V) except that no leading space is stored. The caller - -- guarantees that S is long enough to hold the result. S need not have a - -- lower bound of 1. + P : in out Natural) + renames Impl.Set_Image_Unsigned; end System.Img_Uns; diff --git a/gcc/ada/libgnat/s-imgwiu.adb b/gcc/ada/libgnat/s-imgwiu.adb index 9ac9621e99c..9f04cce0c4e 100644 --- a/gcc/ada/libgnat/s-imgwiu.adb +++ b/gcc/ada/libgnat/s-imgwiu.adb @@ -29,125 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_WIU is - - ----------------------------- - -- Set_Image_Width_Integer -- - ----------------------------- - - procedure Set_Image_Width_Integer - (V : Integer; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Width_Unsigned (Unsigned (V), W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Width_Unsigned (Unsigned (-V), W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Width_Integer; - - ------------------------------ - -- Set_Image_Width_Unsigned -- - ------------------------------ - - procedure Set_Image_Width_Unsigned - (V : Unsigned; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - - procedure Set_Digits (T : Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Unsigned) is - begin - if T >= 10 then - Set_Digits (T / 10); - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done since, as documented in the specification, - -- the caller guarantees that S is long enough to hold the result. - P := P + 1; - S (P) := Character'Val (T mod 10 + Character'Pos ('0')); - else - pragma Assert (P >= (S'First - 1) and P < S'Last and - P < Natural'Last); - -- No check is done since, as documented in the specification, - -- the caller guarantees that S is long enough to hold the result. - P := P + 1; - S (P) := Character'Val (T + Character'Pos ('0')); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Width_Unsigned - - begin - Set_Digits (V); - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := P + (W - (P - Start)); - T := P; - - while F > Start loop - pragma Assert (T >= S'First and T <= S'Last and - F >= S'First and F <= S'Last); - -- No check is done since, as documented in the specification, - -- the caller guarantees that S is long enough to hold the result. - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - pragma Assert (J >= S'First and J <= S'Last); - -- No check is done since, as documented in the specification, - -- the caller guarantees that S is long enough to hold the result. - S (J) := ' '; - end loop; - end if; - - end Set_Image_Width_Unsigned; - -end System.Img_WIU; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgwiu.ads b/gcc/ada/libgnat/s-imgwiu.ads index 6d33599755b..89515e8155d 100644 --- a/gcc/ada/libgnat/s-imgwiu.ads +++ b/gcc/ada/libgnat/s-imgwiu.ads @@ -30,40 +30,31 @@ ------------------------------------------------------------------------------ -- Contains the routine for computing the image of signed and unsigned --- integers whose size <= Integer'Size for use by Text_IO.Integer_IO --- and Text_IO.Modular_IO. +-- integers up to Integer for use by Text_IO.Integer_IO and +-- Text_IO.Modular_IO. +with System.Image_W; with System.Unsigned_Types; package System.Img_WIU is pragma Pure; + subtype Unsigned is Unsigned_Types.Unsigned; + + package Impl is new Image_W (Integer, Unsigned); + procedure Set_Image_Width_Integer (V : Integer; W : Integer; S : out String; - P : in out Natural); - -- Sets the signed image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes - -- a leading minus sign if necessary, but no leading spaces unless W is - -- positive, in which case leading spaces are output if necessary to ensure - -- that the output string is no less than W characters long. The caller - -- promises that the buffer is large enough and no check is made for this. - -- Constraint_Error will not necessarily be raised if this is violated, - -- since it is perfectly valid to compile this unit with checks off. + P : in out Natural) + renames Impl.Set_Image_Width_Integer; procedure Set_Image_Width_Unsigned - (V : System.Unsigned_Types.Unsigned; + (V : Unsigned; W : Integer; S : out String; - P : in out Natural); - -- Sets the unsigned image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes no - -- leading spaces unless W is positive, in which case leading spaces are - -- output if necessary to ensure that the output string is no less than - -- W characters long. The caller promises that the buffer is large enough - -- and no check is made for this. Constraint_Error will not necessarily be - -- raised if this is violated, since it is perfectly valid to compile this - -- unit with checks off. + P : in out Natural) + renames Impl.Set_Image_Width_Unsigned; end System.Img_WIU; diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb index e4b9e670ddf..925c3b969f6 100644 --- a/gcc/ada/libgnat/s-putima.adb +++ b/gcc/ada/libgnat/s-putima.adb @@ -93,21 +93,30 @@ package body System.Put_Images is end Generic_Integer_Images; - package Small is new Generic_Integer_Images (Integer, Unsigned, Base => 10); - package Large is new Generic_Integer_Images + package Integer_Images is new Generic_Integer_Images + (Integer, Unsigned, Base => 10); + package LL_Integer_Images is new Generic_Integer_Images (Long_Long_Integer, Long_Long_Unsigned, Base => 10); + package LLL_Integer_Images is new Generic_Integer_Images + (Long_Long_Long_Integer, Long_Long_Long_Unsigned, Base => 10); procedure Put_Image_Integer (S : in out Sink'Class; X : Integer) - renames Small.Put_Image; + renames Integer_Images.Put_Image; procedure Put_Image_Long_Long_Integer (S : in out Sink'Class; X : Long_Long_Integer) - renames Large.Put_Image; + renames LL_Integer_Images.Put_Image; + procedure Put_Image_Long_Long_Long_Integer + (S : in out Sink'Class; X : Long_Long_Long_Integer) + renames LLL_Integer_Images.Put_Image; procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned) - renames Small.Put_Image; + renames Integer_Images.Put_Image; procedure Put_Image_Long_Long_Unsigned (S : in out Sink'Class; X : Long_Long_Unsigned) - renames Large.Put_Image; + renames LL_Integer_Images.Put_Image; + procedure Put_Image_Long_Long_Long_Unsigned + (S : in out Sink'Class; X : Long_Long_Long_Unsigned) + renames LLL_Integer_Images.Put_Image; type Signed_Address is range -2**(Standard'Address_Size - 1) .. 2**(Standard'Address_Size - 1) - 1; diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads index bf565079c96..1d2a11d3aa5 100644 --- a/gcc/ada/libgnat/s-putima.ads +++ b/gcc/ada/libgnat/s-putima.ads @@ -37,10 +37,11 @@ package System.Put_Images with Pure is -- This package contains subprograms that are called by the generated code -- for the 'Put_Image attribute. -- - -- For an integer type that fits in Integer, the actual parameter is + -- For a signed integer type that fits in Integer, the actual parameter is -- converted to Integer, and Put_Image_Integer is called. For larger types, - -- Put_Image_Long_Long_Integer is used. Other numeric types are treated - -- similarly. Access values are unchecked-converted to either Thin_Pointer + -- Put_Image_Long_Long_Integer or Put_Image_Long_Long_Long_Integer is used. + -- For a modular integer type, this is similar with Integer replaced with + -- Unsigned. Access values are unchecked-converted to either Thin_Pointer -- or Fat_Pointer, and Put_Image_Thin_Pointer or Put_Image_Fat_Pointer is -- called. The Before/Between/After procedures are called before printing -- the components of a composite type, between pairs of components, and @@ -54,13 +55,18 @@ package System.Put_Images with Pure is procedure Put_Image_Integer (S : in out Sink'Class; X : Integer); procedure Put_Image_Long_Long_Integer (S : in out Sink'Class; X : Long_Long_Integer); + procedure Put_Image_Long_Long_Long_Integer + (S : in out Sink'Class; X : Long_Long_Long_Integer); - subtype Unsigned is System.Unsigned_Types.Unsigned; - subtype Long_Long_Unsigned is System.Unsigned_Types.Long_Long_Unsigned; + subtype Unsigned is Unsigned_Types.Unsigned; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned); procedure Put_Image_Long_Long_Unsigned (S : in out Sink'Class; X : Long_Long_Unsigned); + procedure Put_Image_Long_Long_Long_Unsigned + (S : in out Sink'Class; X : Long_Long_Long_Unsigned); type Byte is new Character with Alignment => 1; type Byte_String is array (Positive range <>) of Byte with Alignment => 1; diff --git a/gcc/ada/libgnat/s-valint.adb b/gcc/ada/libgnat/s-valint.adb index c40d5588be0..983d2d1b8e5 100644 --- a/gcc/ada/libgnat/s-valint.adb +++ b/gcc/ada/libgnat/s-valint.adb @@ -29,90 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_Uns; use System.Val_Uns; -with System.Val_Util; use System.Val_Util; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Val_Int is - - ------------------ - -- Scan_Integer -- - ------------------ - - function Scan_Integer - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Integer - is - Uval : Unsigned; - -- Unsigned result - - Minus : Boolean := False; - -- Set to True if minus sign is present, otherwise to False - - Start : Positive; - -- Saves location of first non-blank (not used in this case) - - begin - Scan_Sign (Str, Ptr, Max, Minus, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - Bad_Value (Str); - end if; - - Uval := Scan_Raw_Unsigned (Str, Ptr, Max); - - -- Deal with overflow cases, and also with maximum negative number - - if Uval > Unsigned (Integer'Last) then - if Minus and then Uval = Unsigned (-(Integer'First)) then - return Integer'First; - else - Bad_Value (Str); - end if; - - -- Negative values - - elsif Minus then - return -(Integer (Uval)); - - -- Positive values - - else - return Integer (Uval); - end if; - end Scan_Integer; - - ------------------- - -- Value_Integer -- - ------------------- - - function Value_Integer (Str : String) return Integer is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Integer (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Integer; - P : aliased Integer := Str'First; - begin - V := Scan_Integer (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Integer; - -end System.Val_Int; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-valint.ads b/gcc/ada/libgnat/s-valint.ads index 79571da0c0a..8a3c55ecc95 100644 --- a/gcc/ada/libgnat/s-valint.ads +++ b/gcc/ada/libgnat/s-valint.ads @@ -32,42 +32,24 @@ -- This package contains routines for scanning signed Integer values for use -- in Text_IO.Integer_IO, and the Value attribute. +with System.Unsigned_Types; +with System.Val_Uns; +with System.Value_I; + package System.Val_Int is pragma Preelaborate; + subtype Unsigned is Unsigned_Types.Unsigned; + + package Impl is new Value_I (Integer, Unsigned, Val_Uns.Scan_Raw_Unsigned); + function Scan_Integer (Str : String; Ptr : not null access Integer; - Max : Integer) return Integer; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). There are three cases for the - -- return: - -- - -- If a valid integer is found after scanning past any initial spaces, then - -- Ptr.all is updated past the last character of the integer (but trailing - -- spaces are not scanned out). - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_Io.Get - -- - -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. + Max : Integer) return Integer + renames Impl.Scan_Integer; - function Value_Integer (Str : String) return Integer; - -- Used in computing X'Value (Str) where X is a signed integer type whose - -- base range does not exceed the base range of Integer. Str is the string - -- argument of the attribute. Constraint_Error is raised if the string is - -- malformed, or if the value is out of range. + function Value_Integer (Str : String) return Integer + renames Impl.Value_Integer; end System.Val_Int; diff --git a/gcc/ada/libgnat/s-vallli.adb b/gcc/ada/libgnat/s-vallli.adb index 43bb0a77d29..eadab12a949 100644 --- a/gcc/ada/libgnat/s-vallli.adb +++ b/gcc/ada/libgnat/s-vallli.adb @@ -29,92 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_LLU; use System.Val_LLU; -with System.Val_Util; use System.Val_Util; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Val_LLI is - - ---------------------------- - -- Scan_Long_Long_Integer -- - ---------------------------- - - function Scan_Long_Long_Integer - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Integer - is - Uval : Long_Long_Unsigned; - -- Unsigned result - - Minus : Boolean := False; - -- Set to True if minus sign is present, otherwise to False - - Start : Positive; - -- Saves location of first non-blank - - begin - Scan_Sign (Str, Ptr, Max, Minus, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - Bad_Value (Str); - end if; - - Uval := Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max); - - -- Deal with overflow cases, and also with maximum negative number - - if Uval > Long_Long_Unsigned (Long_Long_Integer'Last) then - if Minus - and then Uval = Long_Long_Unsigned (-(Long_Long_Integer'First)) - then - return Long_Long_Integer'First; - else - Bad_Value (Str); - end if; - - -- Negative values - - elsif Minus then - return -(Long_Long_Integer (Uval)); - - -- Positive values - - else - return Long_Long_Integer (Uval); - end if; - end Scan_Long_Long_Integer; - - ----------------------------- - -- Value_Long_Long_Integer -- - ----------------------------- - - function Value_Long_Long_Integer (Str : String) return Long_Long_Integer is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Long_Long_Integer (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Long_Long_Integer; - P : aliased Integer := Str'First; - begin - V := Scan_Long_Long_Integer (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Long_Long_Integer; - -end System.Val_LLI; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-vallli.ads b/gcc/ada/libgnat/s-vallli.ads index 0a51bbe0dd1..e53873e4cb6 100644 --- a/gcc/ada/libgnat/s-vallli.ads +++ b/gcc/ada/libgnat/s-vallli.ads @@ -32,42 +32,27 @@ -- This package contains routines for scanning signed Long_Long_Integer -- values for use in Text_IO.Integer_IO, and the Value attribute. +with System.Unsigned_Types; +with System.Val_LLU; +with System.Value_I; + package System.Val_LLI is pragma Preelaborate; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + package Impl is new + Value_I (Long_Long_Integer, + Long_Long_Unsigned, + Val_LLU.Scan_Raw_Long_Long_Unsigned); + function Scan_Long_Long_Integer (Str : String; Ptr : not null access Integer; - Max : Integer) return Long_Long_Integer; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). There are three cases for the - -- return: - -- - -- If a valid integer is found after scanning past any initial spaces, then - -- Ptr.all is updated past the last character of the integer (but trailing - -- spaces are not scanned out). - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_Io.Get - -- - -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. + Max : Integer) return Long_Long_Integer + renames Impl.Scan_Integer; - function Value_Long_Long_Integer (Str : String) return Long_Long_Integer; - -- Used in computing X'Value (Str) where X is a signed integer type whose - -- base range exceeds the base range of Integer. Str is the string argument - -- of the attribute. Constraint_Error is raised if the string is malformed, - -- or if the value is out of range. + function Value_Long_Long_Integer (Str : String) return Long_Long_Integer + renames Impl.Value_Integer; end System.Val_LLI; diff --git a/gcc/ada/libgnat/s-valllli.ads b/gcc/ada/libgnat/s-valllli.ads new file mode 100644 index 00000000000..9ab7161e057 --- /dev/null +++ b/gcc/ada/libgnat/s-valllli.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-vallllu.ads b/gcc/ada/libgnat/s-vallllu.ads new file mode 100644 index 00000000000..34ce28288f2 --- /dev/null +++ b/gcc/ada/libgnat/s-vallllu.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L L U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-valllu.adb b/gcc/ada/libgnat/s-valllu.adb index dca0aac145e..1afb6324c51 100644 --- a/gcc/ada/libgnat/s-valllu.adb +++ b/gcc/ada/libgnat/s-valllu.adb @@ -29,302 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_Util; use System.Val_Util; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Val_LLU is - - --------------------------------- - -- Scan_Raw_Long_Long_Unsigned -- - --------------------------------- - - function Scan_Raw_Long_Long_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Unsigned - is - P : Integer; - -- Local copy of the pointer - - Uval : Long_Long_Unsigned; - -- Accumulated unsigned integer result - - Expon : Integer; - -- Exponent value - - Overflow : Boolean := False; - -- Set True if overflow is detected at any point - - Base_Char : Character; - -- Base character (# or :) in based case - - Base : Long_Long_Unsigned := 10; - -- Base value (reset in based case) - - Digit : Long_Long_Unsigned; - -- Digit value - - begin - -- We do not tolerate strings with Str'Last = Positive'Last - - if Str'Last = Positive'Last then - raise Program_Error with - "string upper bound is Positive'Last, not supported"; - end if; - - P := Ptr.all; - Uval := Character'Pos (Str (P)) - Character'Pos ('0'); - P := P + 1; - - -- Scan out digits of what is either the number or the base. - -- In either case, we are definitely scanning out in base 10. - - declare - Umax : constant := (Long_Long_Unsigned'Last - 9) / 10; - -- Max value which cannot overflow on accumulating next digit - - Umax10 : constant := Long_Long_Unsigned'Last / 10; - -- Numbers bigger than Umax10 overflow if multiplied by 10 - - begin - -- Loop through decimal digits - loop - exit when P > Max; - - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - -- Non-digit encountered - - if Digit > 9 then - if Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, False); - else - exit; - end if; - - -- Accumulate result, checking for overflow - - else - if Uval <= Umax then - Uval := 10 * Uval + Digit; - - elsif Uval > Umax10 then - Overflow := True; - - else - Uval := 10 * Uval + Digit; - - if Uval < Umax10 then - Overflow := True; - end if; - end if; - - P := P + 1; - end if; - end loop; - end; - - Ptr.all := P; - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - if P < Max and then (Str (P) = '#' or else Str (P) = ':') then - Base_Char := Str (P); - P := P + 1; - Base := Uval; - Uval := 0; - - -- Check base value. Overflow is set True if we find a bad base, or - -- a digit that is out of range of the base. That way, we scan out - -- the numeral that is still syntactically correct, though illegal. - -- We use a safe base of 16 for this scan, to avoid zero divide. - - if Base not in 2 .. 16 then - Overflow := True; - Base := 16; - end if; - - -- Scan out based integer - - declare - Umax : constant Long_Long_Unsigned := - (Long_Long_Unsigned'Last - Base + 1) / Base; - -- Max value which cannot overflow on accumulating next digit - - UmaxB : constant Long_Long_Unsigned := - Long_Long_Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - -- Loop to scan out based integer value - - loop - -- We require a digit at this stage - - if Str (P) in '0' .. '9' then - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - elsif Str (P) in 'A' .. 'F' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('A') - 10); - - elsif Str (P) in 'a' .. 'f' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('a') - 10); - - -- If we don't have a digit, then this is not a based number - -- after all, so we use the value we scanned out as the base - -- (now in Base), and the pointer to the base character was - -- already stored in Ptr.all. - - else - Uval := Base; - exit; - end if; - - -- If digit is too large, just signal overflow and continue. - -- The idea here is to keep scanning as long as the input is - -- syntactically valid, even if we have detected overflow - - if Digit >= Base then - Overflow := True; - - -- Here we accumulate the value, checking overflow - - elsif Uval <= Umax then - Uval := Base * Uval + Digit; - - elsif Uval > UmaxB then - Overflow := True; - - else - Uval := Base * Uval + Digit; - - if Uval < UmaxB then - Overflow := True; - end if; - end if; - - -- If at end of string with no base char, not a based number - -- but we signal Constraint_Error and set the pointer past - -- the end of the field, since this is what the ACVC tests - -- seem to require, see CE3704N, line 204. - - P := P + 1; - - if P > Max then - Ptr.all := P; - Bad_Value (Str); - end if; - - -- If terminating base character, we are done with loop - - if Str (P) = Base_Char then - Ptr.all := P + 1; - exit; - - -- Deal with underscore - - elsif Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, True); - end if; - - end loop; - end; - end if; - - -- Come here with scanned unsigned value in Uval. The only remaining - -- required step is to deal with exponent if one is present. - - Expon := Scan_Exponent (Str, Ptr, Max); - - if Expon /= 0 and then Uval /= 0 then - - -- For non-zero value, scale by exponent value. No need to do this - -- efficiently, since use of exponent in integer literals is rare, - -- and in any case the exponent cannot be very large. - - declare - UmaxB : constant Long_Long_Unsigned := - Long_Long_Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - for J in 1 .. Expon loop - if Uval > UmaxB then - Overflow := True; - exit; - end if; - - Uval := Uval * Base; - end loop; - end; - end if; - - -- Return result, dealing with sign and overflow - - if Overflow then - Bad_Value (Str); - else - return Uval; - end if; - end Scan_Raw_Long_Long_Unsigned; - - ----------------------------- - -- Scan_Long_Long_Unsigned -- - ----------------------------- - - function Scan_Long_Long_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Unsigned - is - Start : Positive; - -- Save location of first non-blank character - - begin - Scan_Plus_Sign (Str, Ptr, Max, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - raise Constraint_Error; - end if; - - return Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max); - end Scan_Long_Long_Unsigned; - - ------------------------------ - -- Value_Long_Long_Unsigned -- - ------------------------------ - - function Value_Long_Long_Unsigned - (Str : String) return Long_Long_Unsigned - is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Long_Long_Unsigned (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Long_Long_Unsigned; - P : aliased Integer := Str'First; - begin - V := Scan_Long_Long_Unsigned (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Long_Long_Unsigned; - -end System.Val_LLU; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-valllu.ads b/gcc/ada/libgnat/s-valllu.ads index 51a31dda6b1..5c0300c8560 100644 --- a/gcc/ada/libgnat/s-valllu.ads +++ b/gcc/ada/libgnat/s-valllu.ads @@ -33,97 +33,29 @@ -- values for use in Text_IO.Modular_IO, and the Value attribute. with System.Unsigned_Types; +with System.Value_U; package System.Val_LLU is pragma Preelaborate; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + package Impl is new Value_U (Long_Long_Unsigned); + function Scan_Raw_Long_Long_Unsigned (Str : String; Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). Note: this does not scan - -- leading or trailing blanks, nor leading sign. - -- - -- There are three cases for the return: - -- - -- If a valid integer is found, then Ptr.all is updated past the last - -- character of the integer. - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_IO.Get. Note that the rules as stated in the RM would - -- seem to imply that for a case like: - -- - -- 8#12345670009# - -- - -- the pointer should be left at the first # having scanned out the longest - -- valid integer literal (8), but in fact in this case the pointer points - -- past the final # and Constraint_Error is raised. This is the behavior - -- expected for Text_IO and enforced by the ACATS tests. - -- - -- If a based literal is malformed in that a character other than a valid - -- hexadecimal digit is encountered during scanning out the digits after - -- the # (this includes the case of using the wrong terminator, : instead - -- of # or vice versa) there are two cases. If all the digits before the - -- non-digit are in range of the base, as in - -- - -- 8#100x00# - -- 8#100: - -- - -- then in this case, the "base" value before the initial # is returned as - -- the result, and the pointer points to the initial # character on return. - -- - -- If an out of range digit has been detected before the invalid character, - -- as in: - -- - -- 8#900x00# - -- 8#900: - -- - -- then the pointer is also left at the initial # character, but constraint - -- error is raised reflecting the encounter of an out of range digit. - -- - -- Finally if we have an unterminated fixed-point constant where the final - -- # or : character is missing, Constraint_Error is raised and the pointer - -- is left pointing past the last digit, as in: - -- - -- 8#22 - -- - -- This string results in a Constraint_Error with the pointer pointing - -- past the second 2. - -- - -- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - -- - -- Note: this routine should not be called with Str'Last = Positive'Last. - -- If this occurs Program_Error is raised with a message noting that this - -- case is not supported. Most such cases are eliminated by the caller. + Max : Integer) return Long_Long_Unsigned + renames Impl.Scan_Raw_Unsigned; function Scan_Long_Long_Unsigned (Str : String; Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned; - -- Same as Scan_Raw_Long_Long_Unsigned, except scans optional leading - -- blanks, and an optional leading plus sign. - -- - -- Note: if a minus sign is present, Constraint_Error will be raised. - -- Note: trailing blanks are not scanned. + Max : Integer) return Long_Long_Unsigned + renames Impl.Scan_Unsigned; function Value_Long_Long_Unsigned - (Str : String) return System.Unsigned_Types.Long_Long_Unsigned; - -- Used in computing X'Value (Str) where X is a modular integer type whose - -- modulus exceeds the range of System.Unsigned_Types.Unsigned. Str is the - -- string argument of the attribute. Constraint_Error is raised if the - -- string is malformed, or if the value is out of range. + (Str : String) return Long_Long_Unsigned + renames Impl.Value_Unsigned; end System.Val_LLU; diff --git a/gcc/ada/libgnat/s-valuei.adb b/gcc/ada/libgnat/s-valuei.adb new file mode 100644 index 00000000000..1bc8b32f853 --- /dev/null +++ b/gcc/ada/libgnat/s-valuei.adb @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-valuei.ads b/gcc/ada/libgnat/s-valuei.ads new file mode 100644 index 00000000000..13f4f8cf23b --- /dev/null +++ b/gcc/ada/libgnat/s-valuei.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb new file mode 100644 index 00000000000..75bef07fde1 --- /dev/null +++ b/gcc/ada/libgnat/s-valueu.adb @@ -0,0 +1,324 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-valueu.ads b/gcc/ada/libgnat/s-valueu.ads new file mode 100644 index 00000000000..ad8256c8ab2 --- /dev/null +++ b/gcc/ada/libgnat/s-valueu.ads @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-valuns.adb b/gcc/ada/libgnat/s-valuns.adb index 9f9e81ec6cd..b710a9b8a65 100644 --- a/gcc/ada/libgnat/s-valuns.adb +++ b/gcc/ada/libgnat/s-valuns.adb @@ -29,297 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_Util; use System.Val_Util; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Val_Uns is - - ----------------------- - -- Scan_Raw_Unsigned -- - ----------------------- - - function Scan_Raw_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Unsigned - is - P : Integer; - -- Local copy of the pointer - - Uval : Unsigned; - -- Accumulated unsigned integer result - - Expon : Integer; - -- Exponent value - - Overflow : Boolean := False; - -- Set True if overflow is detected at any point - - Base_Char : Character; - -- Base character (# or :) in based case - - Base : Unsigned := 10; - -- Base value (reset in based case) - - Digit : Unsigned; - -- Digit value - - begin - -- We do not tolerate strings with Str'Last = Positive'Last - - if Str'Last = Positive'Last then - raise Program_Error with - "string upper bound is Positive'Last, not supported"; - end if; - - P := Ptr.all; - Uval := Character'Pos (Str (P)) - Character'Pos ('0'); - P := P + 1; - - -- Scan out digits of what is either the number or the base. - -- In either case, we are definitely scanning out in base 10. - - declare - Umax : constant := (Unsigned'Last - 9) / 10; - -- Max value which cannot overflow on accumulating next digit - - Umax10 : constant := Unsigned'Last / 10; - -- Numbers bigger than Umax10 overflow if multiplied by 10 - - begin - -- Loop through decimal digits - loop - exit when P > Max; - - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - -- Non-digit encountered - - if Digit > 9 then - if Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, False); - else - exit; - end if; - - -- Accumulate result, checking for overflow - - else - if Uval <= Umax then - Uval := 10 * Uval + Digit; - - elsif Uval > Umax10 then - Overflow := True; - - else - Uval := 10 * Uval + Digit; - - if Uval < Umax10 then - Overflow := True; - end if; - end if; - - P := P + 1; - end if; - end loop; - end; - - Ptr.all := P; - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - if P < Max and then (Str (P) = '#' or else Str (P) = ':') then - Base_Char := Str (P); - P := P + 1; - Base := Uval; - Uval := 0; - - -- Check base value. Overflow is set True if we find a bad base, or - -- a digit that is out of range of the base. That way, we scan out - -- the numeral that is still syntactically correct, though illegal. - -- We use a safe base of 16 for this scan, to avoid zero divide. - - if Base not in 2 .. 16 then - Overflow := True; - Base := 16; - end if; - - -- Scan out based integer - - declare - Umax : constant Unsigned := (Unsigned'Last - Base + 1) / Base; - -- Max value which cannot overflow on accumulating next digit - - UmaxB : constant Unsigned := Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - -- Loop to scan out based integer value - - loop - -- We require a digit at this stage - - if Str (P) in '0' .. '9' then - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - elsif Str (P) in 'A' .. 'F' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('A') - 10); - - elsif Str (P) in 'a' .. 'f' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('a') - 10); - - -- If we don't have a digit, then this is not a based number - -- after all, so we use the value we scanned out as the base - -- (now in Base), and the pointer to the base character was - -- already stored in Ptr.all. - - else - Uval := Base; - exit; - end if; - - -- If digit is too large, just signal overflow and continue. - -- The idea here is to keep scanning as long as the input is - -- syntactically valid, even if we have detected overflow - - if Digit >= Base then - Overflow := True; - - -- Here we accumulate the value, checking overflow - - elsif Uval <= Umax then - Uval := Base * Uval + Digit; - - elsif Uval > UmaxB then - Overflow := True; - - else - Uval := Base * Uval + Digit; - - if Uval < UmaxB then - Overflow := True; - end if; - end if; - - -- If at end of string with no base char, not a based number - -- but we signal Constraint_Error and set the pointer past - -- the end of the field, since this is what the ACVC tests - -- seem to require, see CE3704N, line 204. - - P := P + 1; - - if P > Max then - Ptr.all := P; - Bad_Value (Str); - end if; - - -- If terminating base character, we are done with loop - - if Str (P) = Base_Char then - Ptr.all := P + 1; - exit; - - -- Deal with underscore - - elsif Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, True); - end if; - - end loop; - end; - end if; - - -- Come here with scanned unsigned value in Uval. The only remaining - -- required step is to deal with exponent if one is present. - - Expon := Scan_Exponent (Str, Ptr, Max); - - if Expon /= 0 and then Uval /= 0 then - - -- For non-zero value, scale by exponent value. No need to do this - -- efficiently, since use of exponent in integer literals is rare, - -- and in any case the exponent cannot be very large. - - declare - UmaxB : constant Unsigned := Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - for J in 1 .. Expon loop - if Uval > UmaxB then - Overflow := True; - exit; - end if; - - Uval := Uval * Base; - end loop; - end; - end if; - - -- Return result, dealing with sign and overflow - - if Overflow then - Bad_Value (Str); - else - return Uval; - end if; - end Scan_Raw_Unsigned; - - ------------------- - -- Scan_Unsigned -- - ------------------- - - function Scan_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Unsigned - is - Start : Positive; - -- Save location of first non-blank character - - begin - Scan_Plus_Sign (Str, Ptr, Max, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - Bad_Value (Str); - end if; - - return Scan_Raw_Unsigned (Str, Ptr, Max); - end Scan_Unsigned; - - -------------------- - -- Value_Unsigned -- - -------------------- - - function Value_Unsigned (Str : String) return Unsigned is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Unsigned (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Unsigned; - P : aliased Integer := Str'First; - begin - V := Scan_Unsigned (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Unsigned; - -end System.Val_Uns; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-valuns.ads b/gcc/ada/libgnat/s-valuns.ads index b965ba56cb1..84b7a7d08c4 100644 --- a/gcc/ada/libgnat/s-valuns.ads +++ b/gcc/ada/libgnat/s-valuns.ads @@ -33,97 +33,29 @@ -- values for use in Text_IO.Modular_IO, and the Value attribute. with System.Unsigned_Types; +with System.Value_U; package System.Val_Uns is pragma Preelaborate; + subtype Unsigned is Unsigned_Types.Unsigned; + + package Impl is new Value_U (Unsigned); + function Scan_Raw_Unsigned (Str : String; Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Unsigned; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). Note: this does not scan - -- leading or trailing blanks, nor leading sign. - -- - -- There are three cases for the return: - -- - -- If a valid integer is found, then Ptr.all is updated past the last - -- character of the integer. - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_IO.Get. Note that the rules as stated in the RM would - -- seem to imply that for a case like: - -- - -- 8#12345670009# - -- - -- the pointer should be left at the first # having scanned out the longest - -- valid integer literal (8), but in fact in this case the pointer points - -- past the final # and Constraint_Error is raised. This is the behavior - -- expected for Text_IO and enforced by the ACATS tests. - -- - -- If a based literal is malformed in that a character other than a valid - -- hexadecimal digit is encountered during scanning out the digits after - -- the # (this includes the case of using the wrong terminator, : instead - -- of # or vice versa) there are two cases. If all the digits before the - -- non-digit are in range of the base, as in - -- - -- 8#100x00# - -- 8#100: - -- - -- then in this case, the "base" value before the initial # is returned as - -- the result, and the pointer points to the initial # character on return. - -- - -- If an out of range digit has been detected before the invalid character, - -- as in: - -- - -- 8#900x00# - -- 8#900: - -- - -- then the pointer is also left at the initial # character, but constraint - -- error is raised reflecting the encounter of an out of range digit. - -- - -- Finally if we have an unterminated fixed-point constant where the final - -- # or : character is missing, Constraint_Error is raised and the pointer - -- is left pointing past the last digit, as in: - -- - -- 8#22 - -- - -- This string results in a Constraint_Error with the pointer pointing - -- past the second 2. - -- - -- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - -- - -- Note: this routine should not be called with Str'Last = Positive'Last. - -- If this occurs Program_Error is raised with a message noting that this - -- case is not supported. Most such cases are eliminated by the caller. + Max : Integer) return Unsigned + renames Impl.Scan_Raw_Unsigned; function Scan_Unsigned (Str : String; Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Unsigned; - -- Same as Scan_Raw_Unsigned, except scans optional leading - -- blanks, and an optional leading plus sign. - -- - -- Note: if a minus sign is present, Constraint_Error will be raised. - -- Note: trailing blanks are not scanned. + Max : Integer) return Unsigned + renames Impl.Scan_Unsigned; function Value_Unsigned - (Str : String) return System.Unsigned_Types.Unsigned; - -- Used in computing X'Value (Str) where X is a modular integer type whose - -- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str - -- is the string argument of the attribute. Constraint_Error is raised if - -- the string is malformed, or if the value is out of range. + (Str : String) return Unsigned + renames Impl.Value_Unsigned; end System.Val_Uns; diff --git a/gcc/ada/libgnat/s-widint.ads b/gcc/ada/libgnat/s-widint.ads new file mode 100644 index 00000000000..630627755e0 --- /dev/null +++ b/gcc/ada/libgnat/s-widint.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ I N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-widlli.adb b/gcc/ada/libgnat/s-widlli.adb index ff62186e745..65b1ab46178 100644 --- a/gcc/ada/libgnat/s-widlli.adb +++ b/gcc/ada/libgnat/s-widlli.adb @@ -29,45 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body System.Wid_LLI is +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. - ----------------------------- - -- Width_Long_Long_Integer -- - ----------------------------- - - function Width_Long_Long_Integer - (Lo, Hi : Long_Long_Integer) - return Natural - is - W : Natural; - T : Long_Long_Integer; - - begin - if Lo > Hi then - return 0; - - else - -- Minimum value is 2, one for sign, one for digit - - W := 2; - - -- Get max of absolute values, but avoid bomb if we have the maximum - -- negative number (note that First + 1 has same digits as First) - - T := Long_Long_Integer'Max ( - abs (Long_Long_Integer'Max (Lo, Long_Long_Integer'First + 1)), - abs (Long_Long_Integer'Max (Hi, Long_Long_Integer'First + 1))); - - -- Increase value if more digits required - - while T >= 10 loop - T := T / 10; - W := W + 1; - end loop; - - return W; - end if; - - end Width_Long_Long_Integer; - -end System.Wid_LLI; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-widlli.ads b/gcc/ada/libgnat/s-widlli.ads index 73e95bcaeb9..a67050ed0b8 100644 --- a/gcc/ada/libgnat/s-widlli.ads +++ b/gcc/ada/libgnat/s-widlli.ads @@ -29,17 +29,13 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routine used for Width attribute for all --- non-static signed integer subtypes. Note we only have one routine, --- since this seems a fairly marginal function. +-- Width attribute for signed integers larger than Integer + +with System.Width_I; package System.Wid_LLI is - pragma Pure; - function Width_Long_Long_Integer - (Lo, Hi : Long_Long_Integer) - return Natural; - -- Compute Width attribute for non-static type derived from a signed - -- Integer type. The arguments Lo, Hi are the bounds of the type. + function Width_Long_Long_Integer is new Width_I (Long_Long_Integer); + pragma Pure_Function (Width_Long_Long_Integer); end System.Wid_LLI; diff --git a/gcc/ada/libgnat/s-widllli.ads b/gcc/ada/libgnat/s-widllli.ads new file mode 100644 index 00000000000..80ab9d1e112 --- /dev/null +++ b/gcc/ada/libgnat/s-widllli.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-widlllu.ads b/gcc/ada/libgnat/s-widlllu.ads new file mode 100644 index 00000000000..6f84837593f --- /dev/null +++ b/gcc/ada/libgnat/s-widlllu.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L L U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-widllu.adb b/gcc/ada/libgnat/s-widllu.adb index 49ac43f7a23..840f0a02e73 100644 --- a/gcc/ada/libgnat/s-widllu.adb +++ b/gcc/ada/libgnat/s-widllu.adb @@ -29,45 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Wid_LLU is - - ------------------------------ - -- Width_Long_Long_Unsigned -- - ------------------------------ - - function Width_Long_Long_Unsigned - (Lo, Hi : Long_Long_Unsigned) - return Natural - is - W : Natural; - T : Long_Long_Unsigned; - - begin - if Lo > Hi then - return 0; - - else - -- Minimum value is 2, one for sign, one for digit - - W := 2; - - -- Get max of absolute values, but avoid bomb if we have the maximum - -- negative number (note that First + 1 has same digits as First) - - T := Long_Long_Unsigned'Max (Lo, Hi); - - -- Increase value if more digits required - - while T >= 10 loop - T := T / 10; - W := W + 1; - end loop; - - return W; - end if; - - end Width_Long_Long_Unsigned; - -end System.Wid_LLU; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-widllu.ads b/gcc/ada/libgnat/s-widllu.ads index fad814c0c4f..e77eb554af3 100644 --- a/gcc/ada/libgnat/s-widllu.ads +++ b/gcc/ada/libgnat/s-widllu.ads @@ -29,19 +29,16 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routine used for Width attribute for all --- non-static unsigned integer (modular integer) subtypes. Note we only --- have one routine, since this seems a fairly marginal function. +-- Width attribute for modular integers larger than Integer +with System.Width_U; with System.Unsigned_Types; package System.Wid_LLU is - pragma Pure; - function Width_Long_Long_Unsigned - (Lo, Hi : System.Unsigned_Types.Long_Long_Unsigned) - return Natural; - -- Compute Width attribute for non-static type derived from a modular - -- integer type. The arguments Lo, Hi are the bounds of the type. + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + function Width_Long_Long_Unsigned is new Width_U (Long_Long_Unsigned); + pragma Pure_Function (Width_Long_Long_Unsigned); end System.Wid_LLU; diff --git a/gcc/ada/libgnat/s-widthi.adb b/gcc/ada/libgnat/s-widthi.adb new file mode 100644 index 00000000000..dee60681a21 --- /dev/null +++ b/gcc/ada/libgnat/s-widthi.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D T H _ I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-widthi.ads b/gcc/ada/libgnat/s-widthi.ads new file mode 100644 index 00000000000..570ac202651 --- /dev/null +++ b/gcc/ada/libgnat/s-widthi.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D T H _ I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-widthu.adb b/gcc/ada/libgnat/s-widthu.adb new file mode 100644 index 00000000000..2469e30da51 --- /dev/null +++ b/gcc/ada/libgnat/s-widthu.adb @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D T H _ U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-widthu.ads b/gcc/ada/libgnat/s-widthu.ads new file mode 100644 index 00000000000..28617381bb8 --- /dev/null +++ b/gcc/ada/libgnat/s-widthu.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D T H _ U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-widuns.ads b/gcc/ada/libgnat/s-widuns.ads new file mode 100644 index 00000000000..d93d3e218da --- /dev/null +++ b/gcc/ada/libgnat/s-widuns.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ U N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 28c6aca8675..01f33a0e246 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -258,7 +258,9 @@ package Rtsfind is System_Img_Int, System_Img_LLD, System_Img_LLI, + System_Img_LLLI, System_Img_LLU, + System_Img_LLLU, System_Img_Name, System_Img_Real, System_Img_Uns, @@ -420,7 +422,9 @@ package Rtsfind is System_Val_Int, System_Val_LLD, System_Val_LLI, + System_Val_LLLI, System_Val_LLU, + System_Val_LLLU, System_Val_Name, System_Val_Real, System_Val_Uns, @@ -431,9 +435,13 @@ package Rtsfind is System_Wid_Bool, System_Wid_Char, System_Wid_Enum, + System_Wid_Int, System_Wid_LLI, + System_Wid_LLLI, System_Wid_LLU, + System_Wid_LLLU, System_Wid_Name, + System_Wid_Uns, System_Wid_WChar, System_WWd_Char, System_WWd_Enum, @@ -956,8 +964,12 @@ package Rtsfind is RE_Image_Long_Long_Integer, -- System.Img_LLI + RE_Image_Long_Long_Long_Integer, -- System.Img_LLLI + RE_Image_Long_Long_Unsigned, -- System.Img_LLU + RE_Image_Long_Long_Long_Unsigned, -- System.Img_LLLU + RE_Image_Ordinary_Fixed_Point, -- System.Img_Real RE_Image_Floating_Point, -- System.Img_Real @@ -1616,8 +1628,10 @@ package Rtsfind is RE_Put_Image_Integer, -- System.Put_Images RE_Put_Image_Long_Long_Integer, -- System.Put_Images + RE_Put_Image_Long_Long_Long_Integer, -- System.Put_Images RE_Put_Image_Unsigned, -- System.Put_Images RE_Put_Image_Long_Long_Unsigned, -- System.Put_Images + RE_Put_Image_Long_Long_Long_Unsigned, -- System.Put_Images RE_Put_Image_Thin_Pointer, -- System.Put_Images RE_Put_Image_Fat_Pointer, -- System.Put_Images RE_Put_Image_Access_Subp, -- System.Put_Images @@ -1965,6 +1979,7 @@ package Rtsfind is RE_Bits_4, -- System.Unsigned_Types RE_Float_Unsigned, -- System.Unsigned_Types RE_Long_Long_Unsigned, -- System.Unsigned_Types + RE_Long_Long_Long_Unsigned, -- System.Unsigned_Types RE_Packed_Byte, -- System.Unsigned_Types RE_Packed_Bytes1, -- System.Unsigned_Types RE_Packed_Bytes2, -- System.Unsigned_Types @@ -1990,8 +2005,12 @@ package Rtsfind is RE_Value_Long_Long_Integer, -- System.Val_LLI + RE_Value_Long_Long_Long_Integer, -- System.Val_LLLI + RE_Value_Long_Long_Unsigned, -- System.Val_LLU + RE_Value_Long_Long_Long_Unsigned, -- System.Val_LLLU + RE_Value_Real, -- System.Val_Real RE_Value_Unsigned, -- System.Val_Uns @@ -2032,10 +2051,18 @@ package Rtsfind is RE_Width_Enumeration_16, -- System.Wid_Enum RE_Width_Enumeration_32, -- System.Wid_Enum + RE_Width_Integer, -- System.Wid_Int + RE_Width_Long_Long_Integer, -- System.Wid_LLI + RE_Width_Long_Long_Long_Integer, -- System.Wid_LLLI + RE_Width_Long_Long_Unsigned, -- System.Wid_LLU + RE_Width_Long_Long_Long_Unsigned, -- System.Wid_LLLU + + RE_Width_Unsigned, -- System.Wid_Uns + RE_Width_Wide_Character, -- System.Wid_WChar RE_Width_Wide_Wide_Character, -- System.Wid_WChar @@ -2592,8 +2619,12 @@ package Rtsfind is RE_Image_Long_Long_Integer => System_Img_LLI, + RE_Image_Long_Long_Long_Integer => System_Img_LLLI, + RE_Image_Long_Long_Unsigned => System_Img_LLU, + RE_Image_Long_Long_Long_Unsigned => System_Img_LLLU, + RE_Image_Ordinary_Fixed_Point => System_Img_Real, RE_Image_Floating_Point => System_Img_Real, @@ -3372,8 +3403,10 @@ package Rtsfind is RE_Put_Image_Integer => System_Put_Images, RE_Put_Image_Long_Long_Integer => System_Put_Images, + RE_Put_Image_Long_Long_Long_Integer => System_Put_Images, RE_Put_Image_Unsigned => System_Put_Images, RE_Put_Image_Long_Long_Unsigned => System_Put_Images, + RE_Put_Image_Long_Long_Long_Unsigned => System_Put_Images, RE_Put_Image_Thin_Pointer => System_Put_Images, RE_Put_Image_Fat_Pointer => System_Put_Images, RE_Put_Image_Access_Subp => System_Put_Images, @@ -3601,6 +3634,7 @@ package Rtsfind is RE_Bits_4 => System_Unsigned_Types, RE_Float_Unsigned => System_Unsigned_Types, RE_Long_Long_Unsigned => System_Unsigned_Types, + RE_Long_Long_Long_Unsigned => System_Unsigned_Types, RE_Packed_Byte => System_Unsigned_Types, RE_Packed_Bytes1 => System_Unsigned_Types, RE_Packed_Bytes2 => System_Unsigned_Types, @@ -3626,8 +3660,12 @@ package Rtsfind is RE_Value_Long_Long_Integer => System_Val_LLI, + RE_Value_Long_Long_Long_Integer => System_Val_LLLI, + RE_Value_Long_Long_Unsigned => System_Val_LLU, + RE_Value_Long_Long_Long_Unsigned => System_Val_LLLU, + RE_Value_Real => System_Val_Real, RE_Value_Unsigned => System_Val_Uns, @@ -3669,10 +3707,18 @@ package Rtsfind is RE_Width_Enumeration_16 => System_Wid_Enum, RE_Width_Enumeration_32 => System_Wid_Enum, + RE_Width_Integer => System_Wid_Int, + RE_Width_Long_Long_Integer => System_Wid_LLI, + RE_Width_Long_Long_Long_Integer => System_Wid_LLLI, + RE_Width_Long_Long_Unsigned => System_Wid_LLU, + RE_Width_Long_Long_Long_Unsigned => System_Wid_LLLU, + + RE_Width_Unsigned => System_Wid_Uns, + RE_Width_Wide_Character => System_Wid_WChar, RE_Width_Wide_Wide_Character => System_Wid_WChar, -- 2.30.2