diff options
| author | Eric Botcazou <ebotcazou@adacore.com> | 2020-10-13 18:15:40 +0200 |
|---|---|---|
| committer | Pierre-Marie de Rodat <derodat@adacore.com> | 2020-11-26 03:40:00 -0500 |
| commit | 8d87bb8f56db177718bf0f07df462b85a90c1ef3 (patch) | |
| tree | 5ddfd280acc3b622ece98a581674aff7e1a04a91 /gcc/ada/libgnat | |
| parent | 0938e5145854954f5143e08d25fbad231c6cfa90 (diff) | |
| download | gcc-8d87bb8f56db177718bf0f07df462b85a90c1ef3.tar.gz | |
[Ada] Add support for 128-bit fixed-point types on 64-bit platforms
gcc/ada/
* Makefile.rtl (GNATRTL_NONTASKING_OBJS): Likewise.
(GNATRTL_128BIT_OBJS): Likewise.
(GNATRTL_128BIT_PAIRS): Add new 128-bit variants.
* cstand.adb (Create_Standard): Create Standard_Integer_128.
* doc/gnat_rm/implementation_defined_characteristics.rst: Document
new limits on 64-bit platforms in entry for 3.5.9(10).
* gnat_rm.texi: Regenerate.
* exp_attr.adb: Add with and use clauses for Urealp.
(Expand_N_Attribute_Reference) <Attribute_Fore>: Call new routines
for decimal fixed-point types and common ordinary fixed-point types.
* exp_ch4.adb (Real_Range_Check): Extend conversion trick to all
ordinary fixed-point types and use Small_Integer_Type_For.
* exp_fixd.adb: Add with and use clauses for Ttypes.
(Build_Divide): Add special case for 32-bit values and deal with
128-bit types.
(Build_Double_Divide): Deal with 128-bit types.
(Build_Double_Divide_Code): Likewise. Do not apply conversions
before calling Build_Multiply.
(Build_Multiply): Likewise. Add special case for 32-bit values.
(Build_Scaled_Divide): Deal with 128-bit types.
(Build_Scaled_Divide_Code): Likewise. Fix size computation. Do not
apply conversions before calling Build_Multiply.
(Do_Multiply_Fixed_Fixed): Minor tweak.
(Integer_Literal): Deal with 128-bit values.
* exp_imgv.adb (Has_Decimal_Small): Delete.
(Expand_Image_Attribute): Call new routines for common ordinary
fixed-point types.
(Expand_Value_Attribute): Likewise.
(Expand_Width_Attribute): Add new expansion for fixed-point types.
* freeze.adb (Freeze_Entity): Move error checks for ordinary
fixed-point types to...
(Freeze_Fixed_Point_Type): ...here. Deal with 128-bit types and
adjust limitations for 32-bnt and 64-bit types.
* rtsfind.ads (RTU_Id): Add entries for new System_Fore, System_Img,
and System_Val units and remove them for obsolete units.
(RE_Id): Add entries for Double_Divide128, Scaled_Divide128, the new
Fore, Image, Value routines and remove them for obsolete units.
(RE_Unit_Table): Likewise.
* sem_ch3.adb (Decimal_Fixed_Point_Type_Declaration): Deal with
128-bit types.
* stand.ads (Standard_Entity_Type): Add Standard_Integer_128.
* uintp.ads (Uint_31): New deferred constant.
(Uint_Minus_18): Likewise.
(Uint_Minus_31): Likewise.
(Uint_Minus_76): Likewise.
(Uint_Minus_127): Likewise.
* urealp.ads (Ureal_2_31): New function.
(Ureal_2_63): Likewise.
(Ureal_2_127): Likewise.
(Ureal_2_M_127): Likewise.
(Ureal_2_10_18): Likewise.
(Ureal_M_2_10_18): Likewise.
(Ureal_9_10_36): Likewise.
(Ureal_M_9_10_36): Likewise.
(Ureal_10_76): Likewise.
(Ureal_M_10_76): Likewise.
(Ureal_10_36): Delete.
(Ureal_M_10_36): Likewise.
* urealp.adb (UR_2_10_18): New variable.
(UR_9_10_36): Likewise.
(UR_10_76): Likewise.
(UR_M_2_10_18): Likewise.
(UR_M_9_10_36): Likewise.
(UR_M_10_76): Likewise.
(UR_2_31): Likewise.
(UR_2_63): Likewise.
(UR_2_127): Likewise.
(UR_2_M_127): Likewise.
(UR_10_36): Delete.
(UR_M_10_36): Likewise.
(Initialize): Initialize them.
(UR_Write): Do not use awkward Ada literal style.
(Ureal_2_10_18): New function.
(Ureal_9_10_36): Likewise.
(Ureal_10_76): Likewise.
(Ureal_2_31): Likewise.
(Ureal_2_63): Likewise.
(Ureal_2_127): Likewise.
(Ureal_2_M_127): Likewise.
(Ureal_M_2_10_18): Likewise.
(Ureal_M_9_10_36): Likewise.
(Ureal_10_76): Likewise.
(Ureal_M_10_76): Likewise.
(Ureal_10_36): Delete.
(Ureal_M_10_36): Likewise.
* libgnat/a-decima__128.ads: New file.
* libgnat/a-tideau.ads, libgnat/a-tideau.adb: Reimplement as
generic unit.
* libgnat/a-tideio.adb: Reimplement.
* libgnat/a-tideio__128.adb: New file.
* libgnat/a-tifiau.ads, libgnat/a-tifiau.adb: New generic unit.
* libgnat/a-tifiio.adb: Move bulk of implementation to s-imagef
and reimplement.
* libgnat/a-tifiio__128.adb: New file.
* libgnat/a-tiflau.adb (Get): Minor consistency fix.
(Gets): Likewise.
* libgnat/a-wtdeau.ads, libgnat/a-wtdeau.adb: Reimplement as
generic unit.
* libgnat/a-wtdeio.adb: Reimplement.
* libgnat/a-wtdeio__128.adb: New file.
* libgnat/a-wtfiau.ads, libgnat/a-wtfiau.adb: New generic unit.
* libgnat/a-wtfiio.adb: Reimplement.
* libgnat/a-wtfiio__128.adb: New file.
* libgnat/a-ztdeau.ads, libgnat/a-ztdeau.adb: Reimplement as
generic unit.
* libgnat/a-ztdeio.adb: Reimplement.
* libgnat/a-ztdeio__128.adb: New file.
* libgnat/a-ztfiau.ads, libgnat/a-ztfiau.adb: New generic unit.
* libgnat/a-ztfiio.adb: Reimplement.
* libgnat/a-ztfiio__128.adb: New file.
* libgnat/g-rannum.adb (Random_Decimal_Fixed): Use a subtype of the
appropiate size for the instantiation.
(Random_Ordinary_Fixed): Likewise.
* libgnat/s-arit32.ads, libgnat/s-arit32.adb: New support unit.
* libgnat/s-fode128.ads: New instantiation.
* libgnat/s-fode32.ads: Likewise.
* libgnat/s-fode64.ads: Likewise.
* libgnat/s-fofi128.ads: Likewise.
* libgnat/s-fofi32.ads: Likewise.
* libgnat/s-fofi64.ads: Likewise.
* libgnat/s-fore_d.ads, libgnat/s-fore_d.adb: New generic unit.
* libgnat/s-fore_f.ads, libgnat/s-fore_f.adb: Likewise.
* libgnat/s-fore.ads, libgnat/s-fore.adb: Rename into...
* libgnat/s-forrea.ads, libgnat/s-forrea.adb: ...this.
* libgnat/s-imaged.ads, libgnat/s-imaged.adb: New generic unit.
* libgnat/s-imagef.ads, libgnat/s-imagef.adb: Likewise, taken
from a-tifiio.adb.
* libgnat/s-imde128.ads: New instantiation.
* libgnat/s-imde32.ads: Likewise.
* libgnat/s-imde64.ads: Likewise.
* libgnat/s-imfi128.ads: Likewise.
* libgnat/s-imfi32.ads: Likewise.
* libgnat/s-imfi64.ads: Likewise.
* libgnat/s-imgdec.ads, libgnat/s-imgdec.adb: Delete.
* libgnat/s-imglld.ads, libgnat/s-imglld.adb: Likewise.
* libgnat/s-imgrea.adb (Set_Image_Real): Replace Sign local variable
with Minus local variable for the sake of consistency.
* libgnat/s-imguti.ads, libgnat/s-imguti.adb: New support unit.
* libgnat/s-vade128.ads: New instantiation.
* libgnat/s-vade32.ads: Likewise.
* libgnat/s-vade64.ads: Likewise.
* libgnat/s-vafi128.ads: Likewise.
* libgnat/s-vafi32.ads: Likewise.
* libgnat/s-vafi64.ads: Likewise.
* libgnat/s-valdec.ads, libgnat/s-valdec.adb: Delete.
* libgnat/s-vallld.ads, libgnat/s-vallld.adb: Likewise.
* libgnat/s-valued.ads, libgnat/s-valued.adb: New generic unit.
* libgnat/s-valuef.ads, libgnat/s-valuef.adb: Likewise.
* libgnat/s-valuei.adb: Minor rewording.
* libgnat/s-valrea.adb: Move bulk of implementation to...
* libgnat/s-valuer.ads, libgnat/s-valuer.adb: ...here. New
generic unit.
* libgnat/system-aix.ads (Max_Mantissa): Adjust.
* libgnat/system-darwin-arm.ads (Max_Mantissa): Likewise.
* libgnat/system-darwin-ppc.ads (Max_Mantissa): Likewise.
* libgnat/system-darwin-x86.ads (Max_Mantissa): Likewise.
* libgnat/system-djgpp.ads (Max_Mantissa): Likewise.
* libgnat/system-dragonfly-x86_64.ads (Max_Mantissa): Likewise.
* libgnat/system-freebsd.ads (Max_Mantissa): Likewise.
* libgnat/system-hpux-ia64.ads (Max_Mantissa): Likewise.
* libgnat/system-hpux.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-alpha.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-arm.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-hppa.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-ia64.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-m68k.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-mips.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-ppc.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-riscv.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-s390.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-sh4.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-sparc.ads (Max_Mantissa): Likewise.
* libgnat/system-linux-x86.ads (Max_Mantissa): Likewise.
* libgnat/system-lynxos178-ppc.ads (Max_Mantissa): Likewise.
* libgnat/system-lynxos178-x86.ads (Max_Mantissa): Likewise.
* libgnat/system-mingw.ads (Max_Mantissa): Likewise.
* libgnat/system-qnx-aarch64.ads (Max_Mantissa): Likewise.
* libgnat/system-rtems.ads (Max_Mantissa): Likewise.
* libgnat/system-solaris-sparc.ads (Max_Mantissa): Likewise.
* libgnat/system-solaris-x86.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-arm-rtp-smp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-arm-rtp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-arm.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-e500-kernel.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-e500-rtp-smp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-e500-rtp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-e500-vthread.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-ppc-kernel.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-ppc-ravenscar.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-ppc-rtp-smp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-ppc-rtp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-ppc-vthread.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-ppc.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-x86-kernel.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-x86-rtp-smp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-x86-rtp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-x86-vthread.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks-x86.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-aarch64-rtp-smp.ads (Max_Mantissa):
Likewise.
* libgnat/system-vxworks7-aarch64.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-arm-rtp-smp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-arm.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-e500-kernel.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-e500-rtp-smp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-e500-rtp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-ppc-kernel.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-ppc-rtp-smp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-ppc-rtp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-ppc64-kernel.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-ppc64-rtp-smp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-x86-kernel.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-x86-rtp-smp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-x86-rtp.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-x86_64-kernel.ads (Max_Mantissa): Likewise.
* libgnat/system-vxworks7-x86_64-rtp-smp.ads (Max_Mantissa): Likewise.
gcc/testsuite/
* gnat.dg/multfixed.adb: Robustify.
Diffstat (limited to 'gcc/ada/libgnat')
131 files changed, 6464 insertions, 1996 deletions
diff --git a/gcc/ada/libgnat/a-decima__128.ads b/gcc/ada/libgnat/a-decima__128.ads new file mode 100644 index 00000000000..b29b010bab1 --- /dev/null +++ b/gcc/ada/libgnat/a-decima__128.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D E C I M A L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the 128-bit version of this package + +package Ada.Decimal is + pragma Pure; + + -- The compiler makes a number of assumptions based on the following five + -- constants (e.g. there is an assumption that decimal values can always + -- be represented in 128-bit signed binary form), so code modifications are + -- required to increase these constants. + + Max_Scale : constant := +38; + Min_Scale : constant := -38; + + Min_Delta : constant := 1.0E-38; + Max_Delta : constant := 1.0E+38; + + Max_Decimal_Digits : constant := 38; + + generic + type Dividend_Type is delta <> digits <>; + type Divisor_Type is delta <> digits <>; + type Quotient_Type is delta <> digits <>; + type Remainder_Type is delta <> digits <>; + + procedure Divide + (Dividend : Dividend_Type; + Divisor : Divisor_Type; + Quotient : out Quotient_Type; + Remainder : out Remainder_Type); + +private + pragma Inline (Divide); + +end Ada.Decimal; diff --git a/gcc/ada/libgnat/a-tideau.adb b/gcc/ada/libgnat/a-tideau.adb index caf77e3d07a..5878234dde4 100644 --- a/gcc/ada/libgnat/a-tideau.adb +++ b/gcc/ada/libgnat/a-tideau.adb @@ -32,26 +32,21 @@ with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; with Ada.Text_IO.Float_Aux; use Ada.Text_IO.Float_Aux; -with System.Img_Dec; use System.Img_Dec; -with System.Img_LLD; use System.Img_LLD; -with System.Val_Dec; use System.Val_Dec; -with System.Val_LLD; use System.Val_LLD; - package body Ada.Text_IO.Decimal_Aux is - ------------- - -- Get_Dec -- - ------------- + --------- + -- Get -- + --------- - function Get_Dec + function Get (File : File_Type; Width : Field; - Scale : Integer) return Integer + Scale : Integer) return Int is Buf : String (1 .. Field'Last); Ptr : aliased Integer; Stop : Integer := 0; - Item : Integer; + Item : Int; begin if Width /= 0 then @@ -62,114 +57,42 @@ package body Ada.Text_IO.Decimal_Aux is Ptr := 1; end if; - Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); + Item := Scan (Buf, Ptr'Access, Stop, Scale); Check_End_Of_Field (Buf, Stop, Ptr, Width); return Item; - end Get_Dec; - - ------------- - -- Get_LLD -- - ------------- - - function Get_LLD - (File : File_Type; - Width : Field; - Scale : Integer) return Long_Long_Integer - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer; - Stop : Integer := 0; - Item : Long_Long_Integer; + end Get; - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - Ptr := 1; - end if; + ---------- + -- Gets -- + ---------- - Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - return Item; - end Get_LLD; - - -------------- - -- Gets_Dec -- - -------------- - - function Gets_Dec + function Gets (From : String; - Last : not null access Positive; - Scale : Integer) return Integer + Last : out Positive; + Scale : Integer) return Int is Pos : aliased Integer; - Item : Integer; + Item : Int; begin String_Skip (From, Pos); - Item := Scan_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; + Item := Scan (From, Pos'Access, From'Last, Scale); + Last := Pos - 1; return Item; exception when Constraint_Error => - Last.all := Pos - 1; + Last := Pos - 1; raise Data_Error; - end Gets_Dec; - - -------------- - -- Gets_LLD -- - -------------- - - function Gets_LLD - (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer - is - Pos : aliased Integer; - Item : Long_Long_Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; - return Item; - - exception - when Constraint_Error => - Last.all := Pos - 1; - raise Data_Error; - end Gets_LLD; - - ------------- - -- Put_Dec -- - ------------- + end Gets; - procedure Put_Dec - (File : File_Type; - Item : Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put_Dec; - - ------------- - -- Put_LLD -- - ------------- + --------- + -- Put -- + --------- - procedure Put_LLD + procedure Put (File : File_Type; - Item : Long_Long_Integer; + Item : Int; Fore : Field; Aft : Field; Exp : Field; @@ -179,83 +102,51 @@ package body Ada.Text_IO.Decimal_Aux is Ptr : Natural := 0; begin - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp); Put_Item (File, Buf (1 .. Ptr)); - end Put_LLD; + end Put; - -------------- - -- Puts_Dec -- - -------------- + ---------- + -- Puts -- + ---------- - procedure Puts_Dec + procedure Puts (To : out String; - Item : Integer; + Item : Int; Aft : Field; Exp : Field; Scale : Integer) is - Buf : String (1 .. Field'Last); + Buf : String (1 .. Positive'Max (Field'Last, To'Length)); Fore : Integer; Ptr : Natural := 0; begin - -- Compute Fore, allowing for Aft digits and the decimal dot + -- Compute Fore, allowing for the decimal dot and Aft digits - Fore := To'Length - Field'Max (1, Aft) - 1; + Fore := To'Length - 1 - Field'Max (1, Aft); - -- Allow for Exp and two more for E+ or E- if exponent present + -- Allow for Exp and one more for E if exponent present if Exp /= 0 then - Fore := Fore - 2 - Exp; + Fore := Fore - 1 - Field'Max (2, Exp); end if; -- Make sure we have enough room - if Fore < 1 then + if Fore < 1 + Boolean'Pos (Item < 0) then raise Layout_Error; end if; -- Do the conversion and check length of result - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - - if Ptr > To'Length then - raise Layout_Error; - else - To := Buf (1 .. Ptr); - end if; - end Puts_Dec; - - -------------- - -- Puts_LLD -- - -------------- - - procedure Puts_LLD - (To : out String; - Item : Long_Long_Integer; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Fore : Integer; - Ptr : Natural := 0; - - begin - Fore := - (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp); - - if Fore < 1 then - raise Layout_Error; - end if; - - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp); if Ptr > To'Length then raise Layout_Error; else To := Buf (1 .. Ptr); end if; - end Puts_LLD; + end Puts; end Ada.Text_IO.Decimal_Aux; diff --git a/gcc/ada/libgnat/a-tideau.ads b/gcc/ada/libgnat/a-tideau.ads index e7d7f44004f..522e3515186 100644 --- a/gcc/ada/libgnat/a-tideau.ads +++ b/gcc/ada/libgnat/a-tideau.ads @@ -29,62 +29,54 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routines for Ada.Text_IO.Decimal_IO that are --- shared among separate instantiations of this package. The routines in --- the package are identical semantically to those declared in Text_IO, --- except that default values have been supplied by the generic, and the --- Num parameter has been replaced by Integer or Long_Long_Integer, with --- an additional Scale parameter giving the value of Num'Scale. In addition --- the Get routines return the value rather than store it in an Out parameter. +-- This package contains the implementation for Ada.Text_IO.Decimal_IO. The +-- routines in this package are identical semantically to those in Decimal_IO, +-- except that the default parameters have been removed because they are +-- supplied explicitly by the calls from within these units, and there is an +-- additional Scale parameter giving the value of Num'Scale. In addition the +-- Get routines return the value rather than store it in an Out parameter. -private package Ada.Text_IO.Decimal_Aux is +private generic + type Int is range <>; - function Get_Dec - (File : File_Type; - Width : Field; - Scale : Integer) return Integer; + with function Scan + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Scale : Integer) return Int; - function Get_LLD - (File : File_Type; - Width : Field; - Scale : Integer) return Long_Long_Integer; + with procedure Set_Image + (V : Int; + S : in out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural); + +package Ada.Text_IO.Decimal_Aux is - procedure Put_Dec + function Get (File : File_Type; - Item : Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer); + Width : Field; + Scale : Integer) return Int; - procedure Put_LLD + procedure Put (File : File_Type; - Item : Long_Long_Integer; + Item : Int; Fore : Field; Aft : Field; Exp : Field; Scale : Integer); - function Gets_Dec - (From : String; - Last : not null access Positive; - Scale : Integer) return Integer; - - function Gets_LLD + function Gets (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer; - - procedure Puts_Dec - (To : out String; - Item : Integer; - Aft : Field; - Exp : Field; - Scale : Integer); + Last : out Positive; + Scale : Integer) return Int; - procedure Puts_LLD + procedure Puts (To : out String; - Item : Long_Long_Integer; + Item : Int; Aft : Field; Exp : Field; Scale : Integer); diff --git a/gcc/ada/libgnat/a-tideio.adb b/gcc/ada/libgnat/a-tideio.adb index 0624c2c778f..f71cf2df85f 100644 --- a/gcc/ada/libgnat/a-tideio.adb +++ b/gcc/ada/libgnat/a-tideio.adb @@ -29,11 +29,35 @@ -- -- ------------------------------------------------------------------------------ +with Interfaces; with Ada.Text_IO.Decimal_Aux; +with System.Img_Decimal_32; use System.Img_Decimal_32; +with System.Img_Decimal_64; use System.Img_Decimal_64; +with System.Val_Decimal_32; use System.Val_Decimal_32; +with System.Val_Decimal_64; use System.Val_Decimal_64; package body Ada.Text_IO.Decimal_IO is - package Aux renames Ada.Text_IO.Decimal_Aux; + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; + + package Aux32 is new + Ada.Text_IO.Decimal_Aux + (Int32, + Scan_Decimal32, + Set_Image_Decimal32); + + package Aux64 is new + Ada.Text_IO.Decimal_Aux + (Int64, + Scan_Decimal64, + Set_Image_Decimal64); + + Need64 : constant Boolean := Num'Size > 32; + -- Throughout this generic body, we distinguish between the case where type + -- Int32 is acceptable and where type Int64 is needed. This Boolean is used + -- to test for these cases and since it is a constant, only code for the + -- relevant case will be included in the instance. Scale : constant Integer := Num'Scale; @@ -49,10 +73,10 @@ package body Ada.Text_IO.Decimal_IO is pragma Unsuppress (Range_Check); begin - if Num'Size > Integer'Size then - Item := Num'Fixed_Value (Aux.Get_LLD (File, Width, Scale)); + if Need64 then + Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale)); else - Item := Num'Fixed_Value (Aux.Get_Dec (File, Width, Scale)); + Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale)); end if; exception @@ -75,12 +99,10 @@ package body Ada.Text_IO.Decimal_IO is pragma Unsuppress (Range_Check); begin - if Num'Size > Integer'Size then - Item := Num'Fixed_Value - (Aux.Gets_LLD (From, Last'Unrestricted_Access, Scale)); + if Need64 then + Item := Num'Fixed_Value (Aux64.Gets (From, Last, Scale)); else - Item := Num'Fixed_Value - (Aux.Gets_Dec (From, Last'Unrestricted_Access, Scale)); + Item := Num'Fixed_Value (Aux32.Gets (From, Last, Scale)); end if; exception @@ -99,13 +121,12 @@ package body Ada.Text_IO.Decimal_IO is Exp : Field := Default_Exp) is begin - if Num'Size > Integer'Size then - Aux.Put_LLD - (File, Long_Long_Integer'Integer_Value (Item), - Fore, Aft, Exp, Scale); + if Need64 then + Aux64.Put + (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale); else - Aux.Put_Dec - (File, Integer'Integer_Value (Item), Fore, Aft, Exp, Scale); + Aux32.Put + (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale); end if; end Put; @@ -126,11 +147,10 @@ package body Ada.Text_IO.Decimal_IO is Exp : Field := Default_Exp) is begin - if Num'Size > Integer'Size then - Aux.Puts_LLD - (To, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale); + if Need64 then + Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp, Scale); else - Aux.Puts_Dec (To, Integer'Integer_Value (Item), Aft, Exp, Scale); + Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp, Scale); end if; end Put; diff --git a/gcc/ada/libgnat/a-tideio__128.adb b/gcc/ada/libgnat/a-tideio__128.adb new file mode 100644 index 00000000000..a8cdf9f918e --- /dev/null +++ b/gcc/ada/libgnat/a-tideio__128.adb @@ -0,0 +1,177 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces; +with Ada.Text_IO.Decimal_Aux; +with System.Img_Decimal_32; use System.Img_Decimal_32; +with System.Img_Decimal_64; use System.Img_Decimal_64; +with System.Img_Decimal_128; use System.Img_Decimal_128; +with System.Val_Decimal_32; use System.Val_Decimal_32; +with System.Val_Decimal_64; use System.Val_Decimal_64; +with System.Val_Decimal_128; use System.Val_Decimal_128; + +package body Ada.Text_IO.Decimal_IO is + + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; + subtype Int128 is Interfaces.Integer_128; + + package Aux32 is new + Ada.Text_IO.Decimal_Aux + (Int32, + Scan_Decimal32, + Set_Image_Decimal32); + + package Aux64 is new + Ada.Text_IO.Decimal_Aux + (Int64, + Scan_Decimal64, + Set_Image_Decimal64); + + package Aux128 is new + Ada.Text_IO.Decimal_Aux + (Int128, + Scan_Decimal128, + Set_Image_Decimal128); + + Need64 : constant Boolean := Num'Size > 32; + Need128 : constant Boolean := Num'Size > 64; + -- Throughout this generic body, we distinguish between the case where type + -- Int32 is acceptable, where type Int64 is acceptable and where an Int128 + -- is needed. These boolean constants are used to test for these cases and + -- since it is a constant, only code for the relevant case will be included + -- in the instance. + + Scale : constant Integer := Num'Scale; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + + begin + if Need128 then + Item := Num'Fixed_Value (Aux128.Get (File, Width, Scale)); + elsif Need64 then + Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale)); + else + Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_In, Item, Width); + end Get; + + procedure Get + (From : String; + Item : out Num; + Last : out Positive) + is + pragma Unsuppress (Range_Check); + + begin + if Need128 then + Item := Num'Fixed_Value (Aux128.Gets (From, Last, Scale)); + elsif Need64 then + Item := Num'Fixed_Value (Aux64.Gets (From, Last, Scale)); + else + Item := Num'Fixed_Value (Aux32.Gets (From, Last, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if Need128 then + Aux128.Put + (File, Int128'Integer_Value (Item), Fore, Aft, Exp, Scale); + elsif Need64 then + Aux64.Put + (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale); + else + Aux32.Put + (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale); + end if; + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Out, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if Need128 then + Aux128.Puts (To, Int128'Integer_Value (Item), Aft, Exp, Scale); + elsif Need64 then + Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp, Scale); + else + Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp, Scale); + end if; + end Put; + +end Ada.Text_IO.Decimal_IO; diff --git a/gcc/ada/libgnat/a-tifiau.adb b/gcc/ada/libgnat/a-tifiau.adb new file mode 100644 index 00000000000..92595524feb --- /dev/null +++ b/gcc/ada/libgnat/a-tifiau.adb @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . F I X E D _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; +with Ada.Text_IO.Float_Aux; use Ada.Text_IO.Float_Aux; + +package body Ada.Text_IO.Fixed_Aux is + + --------- + -- Get -- + --------- + + function Get + (File : File_Type; + Width : Field; + Num : Int; + Den : Int) return Int + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Int; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan (Buf, Ptr'Access, Stop, Num, Den); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get; + + ---------- + -- Gets -- + ---------- + + function Gets + (From : String; + Last : out Positive; + Num : Int; + Den : Int) return Int + is + Pos : aliased Integer; + Item : Int; + + begin + String_Skip (From, Pos); + Item := Scan (From, Pos'Access, From'Last, Num, Den); + Last := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last := Pos - 1; + raise Data_Error; + end Gets; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Int; + Fore : Field; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + Item : Int; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural) + is + Buf : String (1 .. Positive'Max (Field'Last, To'Length)); + Fore : Integer; + Ptr : Natural := 0; + + begin + -- Compute Fore, allowing for the decimal dot and Aft digits + + Fore := To'Length - 1 - Field'Max (1, Aft); + + -- Allow for Exp and one more for E if exponent present + + if Exp /= 0 then + Fore := Fore - 1 - Field'Max (2, Exp); + end if; + + -- Make sure we have enough room + + if Fore < 1 + Boolean'Pos (Item < 0) then + raise Layout_Error; + end if; + + -- Do the conversion and check length of result + + Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts; + +end Ada.Text_IO.Fixed_Aux; diff --git a/gcc/ada/libgnat/a-tifiau.ads b/gcc/ada/libgnat/a-tifiau.ads new file mode 100644 index 00000000000..32701c51fc8 --- /dev/null +++ b/gcc/ada/libgnat/a-tifiau.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . F I X E D _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the implementation for Ada.Text_IO.Fixed_IO. The +-- routines in this package are identical semantically to those in Fixed_IO, +-- except that the default parameters have been removed because they are +-- supplied explicitly by the calls from within these units, and there are +-- additional Num and Den parameters giving the value of Num'Small, as well +-- as For0 and Aft0 giving some properties of Num'Small. In addition the Get +-- routines return the value rather than store it in an Out parameter. + +private generic + type Int is range <>; + + with function Scan + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Num : Int; + Den : Int) return Int; + + with procedure Set_Image + (V : Int; + S : in out String; + P : in out Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural); + +package Ada.Text_IO.Fixed_Aux is + + function Get + (File : File_Type; + Width : Field; + Num : Int; + Den : Int) return Int; + + procedure Put + (File : File_Type; + Item : Int; + Fore : Field; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural); + + function Gets + (From : String; + Last : out Positive; + Num : Int; + Den : Int) return Int; + + procedure Puts + (To : out String; + Item : Int; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural); + +end Ada.Text_IO.Fixed_Aux; diff --git a/gcc/ada/libgnat/a-tifiio.adb b/gcc/ada/libgnat/a-tifiio.adb index 2d0b47c2c61..67cb917d5eb 100644 --- a/gcc/ada/libgnat/a-tifiio.adb +++ b/gcc/ada/libgnat/a-tifiio.adb @@ -140,168 +140,70 @@ -- solution. The downside however may be a too limited set of acceptable -- fixed point types. -with Interfaces; use Interfaces; -with System.Arith_64; use System.Arith_64; -with System.Img_Real; use System.Img_Real; -with Ada.Text_IO; use Ada.Text_IO; +with Interfaces; +with Ada.Text_IO.Fixed_Aux; with Ada.Text_IO.Float_Aux; -with Ada.Text_IO.Generic_Aux; +with System.Img_Fixed_32; use System.Img_Fixed_32; +with System.Img_Fixed_64; use System.Img_Fixed_64; +with System.Val_Fixed_32; use System.Val_Fixed_32; +with System.Val_Fixed_64; use System.Val_Fixed_64; package body Ada.Text_IO.Fixed_IO is - -- Note: we still use the floating-point I/O routines for input of - -- ordinary fixed-point and output using exponent format. This will - -- result in inaccuracies for fixed point types with a small that is - -- not a power of two, and for types that require more precision than - -- is available in Long_Long_Float. + -- Note: we still use the floating-point I/O routines for types whose small + -- is not a sufficiently small integer or the reciprocal thereof. This will + -- result in inaccuracies for fixed point types that require more precision + -- than is available in Long_Long_Float. - package Aux renames Ada.Text_IO.Float_Aux; + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; - Extra_Layout_Space : constant Field := 5 + Num'Fore; - -- Extra space that may be needed for output of sign, decimal point, - -- exponent indication and mandatory decimals after and before the - -- decimal point. A string with length + package Aux32 is new + Ada.Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32); - -- Fore + Aft + Exp + Extra_Layout_Space - - -- is always long enough for formatting any fixed point number. - - -- Implementation of Put routines - - -- The following section describes a specific implementation choice for - -- performing base conversions needed for output of values of a fixed - -- point type T with small T'Small. The goal is to be able to output - -- all values of types with a precision of 64 bits and a delta of at - -- least 2.0**(-63), as these are current GNAT limitations already. - - -- The chosen algorithm uses fixed precision integer arithmetic for - -- reasons of simplicity and efficiency. It is important to understand - -- in what ways the most simple and accurate approach to fixed point I/O - -- is limiting, before considering more complicated schemes. - - -- Without loss of generality assume T has a range (-2.0**63) * T'Small - -- .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the - -- decimal point and T'Fore - 1 before. If T'Small is integer, or - -- 1.0 / T'Small is integer, let S = T'Small and E = 0. For other T'Small, - -- let S and E be integers such that S / 10**E best approximates T'Small - -- and S is in the range 10**17 .. 10**18 - 1. The extra decimal scaling - -- factor 10**E can be trivially handled during final output, by adjusting - -- the decimal point or exponent. - - -- The idea is to convert a value X * S of type T to a 64-bit integer value - -- Q equal to 10.0**D * (X * S) rounded to the nearest integer, using only - -- a scaled integer divide of the form - - -- Q := (X * Y) / Z, - - -- where the variables X, Y, Z are 64-bit integers, and both multiplication - -- and division are done using full intermediate precision. Then the final - -- decimal value to be output is - - -- Q * 10**(E-D) - - -- This value can be written to the output file or to the result string - -- according to the format described in RM A.3.10. The details of this - -- operation are omitted here. - - -- A 64-bit value can represent all integers with 18 decimal digits, but - -- not all with 19 decimal digits. If the total number of requested ouput - -- digits (Fore - 1) + Aft is greater than 18 then, for purposes of the - -- conversion, Aft is adjusted to 18 - (Fore - 1). In that case, trailing - -- zeros can complete the output after writing the first 18 significant - -- digits, or the technique described in the next section can be used. - - -- The final expression for D is - - -- D := Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1))); - - -- For Y and Z the following expressions can be derived: - - -- Q = X * S * (10.0**D) = (X * Y) / Z - - -- S * 10.0**D = Y / Z; - - -- If S is an integer greater than or equal to one, then Fore must be at - -- least 20 in order to print T'First, which is at most -2.0**63. This - -- means that D < 0, so use - - -- (1) Y = -S and Z = -10**(-D) - - -- If 1.0 / S is an integer greater than one, use - - -- (2) Y = -10**D and Z = -(1.0 / S), for D >= 0 - - -- or - - -- (3) Y = -1 and Z = -(1.0 / S) * 10**(-D), for D < 0 - - -- Negative values are used for nominator Y and denominator Z, so that S - -- can have a maximum value of 2.0**63 and a minimum of 2.0**(-63). - -- For Z in -1 .. -9, Fore will still be 20, and D will be negative, as - -- (-2.0**63) / -9 is greater than 10**18. In these cases there is room - -- in the denominator for the extra decimal scaling required, so case (3) - -- will not overflow. - - -- Extra Precision - - -- Using a scaled divide which truncates and returns a remainder R, - -- another K trailing digits can be calculated by computing the value - -- (R * (10.0**K)) / Z using another scaled divide. This procedure - -- can be repeated to compute an arbitrary number of digits in linear - -- time and storage. The last scaled divide should be rounded, with - -- a possible carry propagating to the more significant digits, to - -- ensure correct rounding of the unit in the last place. - - -- A variant of this technique is to limit the value of Q to 9 decimal - -- digits, since 32-bit integers can be much more efficient than 64-bit - -- integers to output. - - pragma Assert (System.Fine_Delta >= 2.0**(-63)); - pragma Assert (Num'Small in 2.0**(-80) .. 2.0**80); - pragma Assert (Num'Fore <= 37); - - Max_Digits : constant := 18; - -- Maximum number of decimal digits that can be represented in a - -- 64-bit signed number, see above - - -- The constants E0 .. E5 implement a binary search for the appropriate - -- power of ten to scale the small so that it has one digit before the - -- decimal point. - - subtype Int is Integer; - E0 : constant Int := -(25 * Boolean'Pos (Num'Small >= 1.0E1)); - E1 : constant Int := E0 + 13 * Boolean'Pos (Num'Small * 10.0**E0 < 1.0E-13); - E2 : constant Int := E1 + 6 * Boolean'Pos (Num'Small * 10.0**E1 < 1.0E-6); - E3 : constant Int := E2 + 3 * Boolean'Pos (Num'Small * 10.0**E2 < 1.0E-3); - E4 : constant Int := E3 + 2 * Boolean'Pos (Num'Small * 10.0**E3 < 1.0E-1); - E5 : constant Int := E4 + 1 * Boolean'Pos (Num'Small * 10.0**E4 < 1.0E-0); - - Scale : constant Integer := E5; - - pragma Assert (Num'Small * 10.0**Scale >= 1.0 - and then Num'Small * 10.0**Scale < 10.0); + package Aux64 is new + Ada.Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64); Exact : constant Boolean := (Float'Floor (Num'Small) = Float'Ceiling (Num'Small) - or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small) - or else Num'Small >= 10.0**Max_Digits) + or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)) and then Num'Small >= 2.0**(-63) and then Num'Small <= 2.0**63; - -- True iff a 64-bit numerator and denominator can be calculated such that - -- their ratio exactly represents the small of Num. - - procedure Put - (To : out String; - Last : out Natural; - Item : Num; - Fore : Integer; - Aft : Field; - Exp : Field); - -- Actual output function, used internally by all other Put routines. - -- The formal Fore is an Integer, not a Field, because the routine is - -- also called from the version of Put that performs I/O to a string, - -- where the starting position depends on the size of the String, and - -- bears no relation to the bounds of Field. + -- True if the exact algorithm implemented in Fixed_Aux can be used. The + -- condition is a Small which is either an integer or the reciprocal of an + -- integer with the appropriate magnitude. + + Need_64 : constant Boolean := + Num'Object_Size > 32 + or else Num'Small > 2.0**31 + or else Num'Small < 2.0**(-31); + -- Throughout this generic body, we distinguish between the case where type + -- Int32 is acceptable and where type Int64 is needed. This Boolean is used + -- to test for these cases and since it is a constant, only code for the + -- relevant case will be included in the instance. + + E : constant Natural := 31 + 32 * Boolean'Pos (Need_64); + -- T'Size - 1 for the selected Int{32,64} + + F0 : constant Natural := 0; + F1 : constant Natural := + F0 + 18 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+18); + F2 : constant Natural := + F1 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+9); + F3 : constant Natural := + F2 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+5); + F4 : constant Natural := + F3 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+3); + F5 : constant Natural := + F4 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+2); + F6 : constant Natural := + F5 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+1); + -- Binary search for the number of digits - 1 before the decimal point of + -- the product 2.0**E * Num'Small. + + For0 : constant Natural := 2 + F6; + -- Fore value for the fixed point type whose mantissa is Int{32,64} and + -- whose small is Num'Small. --------- -- Get -- @@ -313,8 +215,22 @@ package body Ada.Text_IO.Fixed_IO is Width : Field := 0) is pragma Unsuppress (Range_Check); + begin - Aux.Get (File, Long_Long_Float (Item), Width); + if not Exact then + Float_Aux.Get (File, Long_Long_Float (Item), Width); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Get (File, Width, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Get (File, Width, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; + exception when Constraint_Error => raise Data_Error; end Get; @@ -323,11 +239,8 @@ package body Ada.Text_IO.Fixed_IO is (Item : out Num; Width : Field := 0) is - pragma Unsuppress (Range_Check); begin - Aux.Get (Current_In, Long_Long_Float (Item), Width); - exception - when Constraint_Error => raise Data_Error; + Get (Current_Input, Item, Width); end Get; procedure Get @@ -336,8 +249,22 @@ package body Ada.Text_IO.Fixed_IO is Last : out Positive) is pragma Unsuppress (Range_Check); + begin - Aux.Gets (From, Long_Long_Float (Item), Last); + if not Exact then + Float_Aux.Gets (From, Long_Long_Float (Item), Last); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Gets (From, Last, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Gets (From, Last, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; + exception when Constraint_Error => raise Data_Error; end Get; @@ -353,11 +280,20 @@ package body Ada.Text_IO.Fixed_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) is - S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space); - Last : Natural; begin - Put (S, Last, Item, Fore, Aft, Exp); - Generic_Aux.Put_Item (File, S (1 .. Last)); + if not Exact then + Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + elsif Need_64 then + Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + end if; end Put; procedure Put @@ -366,11 +302,8 @@ package body Ada.Text_IO.Fixed_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) is - S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space); - Last : Natural; begin - Put (S, Last, Item, Fore, Aft, Exp); - Generic_Aux.Put_Item (Text_IO.Current_Out, S (1 .. Last)); + Put (Current_Out, Item, Fore, Aft, Exp); end Put; procedure Put @@ -379,332 +312,20 @@ package body Ada.Text_IO.Fixed_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) is - Fore : constant Integer := - To'Length - - 1 -- Decimal point - - Field'Max (1, Aft) -- Decimal part - - Boolean'Pos (Exp /= 0) -- Exponent indicator - - Exp; -- Exponent - - Last : Natural; - - begin - if Fore - Boolean'Pos (Item < 0.0) < 1 then - raise Layout_Error; - end if; - - Put (To, Last, Item, Fore, Aft, Exp); - - if Last /= To'Last then - raise Layout_Error; - end if; - end Put; - - procedure Put - (To : out String; - Last : out Natural; - Item : Num; - Fore : Integer; - Aft : Field; - Exp : Field) - is - subtype Digit is Int64 range 0 .. 9; - - X : constant Int64 := Int64'Integer_Value (Item); - A : constant Field := Field'Max (Aft, 1); - Neg : constant Boolean := (Item < 0.0); - Pos : Integer := 0; -- Next digit X has value X * 10.0**Pos; - - procedure Put_Character (C : Character); - pragma Inline (Put_Character); - -- Add C to the output string To, updating Last - - procedure Put_Digit (X : Digit); - -- Add digit X to the output string (going from left to right), updating - -- Last and Pos, and inserting the sign, leading zeros or a decimal - -- point when necessary. After outputting the first digit, Pos must not - -- be changed outside Put_Digit anymore. - - procedure Put_Int64 (X : Int64; Scale : Integer); - -- Output the decimal number abs X * 10**Scale - - procedure Put_Scaled - (X, Y, Z : Int64; - A : Field; - E : Integer); - -- Output the decimal number (X * Y / Z) * 10**E, producing A digits - -- after the decimal point and rounding the final digit. The value - -- X * Y / Z is computed with full precision, but must be in the - -- range of Int64. - - ------------------- - -- Put_Character -- - ------------------- - - procedure Put_Character (C : Character) is - begin - Last := Last + 1; - - -- Never put a character outside of string To. Exception Layout_Error - -- will be raised later if Last is greater than To'Last. - - if Last <= To'Last then - To (Last) := C; - end if; - end Put_Character; - - --------------- - -- Put_Digit -- - --------------- - - procedure Put_Digit (X : Digit) is - Digs : constant array (Digit) of Character := "0123456789"; - - begin - if Last = To'First - 1 then - if X /= 0 or else Pos <= 0 then - - -- Before outputting first digit, include leading space, - -- possible minus sign and, if the first digit is fractional, - -- decimal seperator and leading zeros. - - -- The Fore part has Pos + 1 + Boolean'Pos (Neg) characters, - -- if Pos >= 0 and otherwise has a single zero digit plus minus - -- sign if negative. Add leading space if necessary. - - for J in Integer'Max (0, Pos) + 2 + Boolean'Pos (Neg) .. Fore - loop - Put_Character (' '); - end loop; - - -- Output minus sign, if number is negative - - if Neg then - Put_Character ('-'); - end if; - - -- If starting with fractional digit, output leading zeros - - if Pos < 0 then - Put_Character ('0'); - Put_Character ('.'); - - for J in Pos .. -2 loop - Put_Character ('0'); - end loop; - end if; - - Put_Character (Digs (X)); - end if; - - else - -- This is not the first digit to be output, so the only - -- special handling is that for the decimal point - - if Pos = -1 then - Put_Character ('.'); - end if; - - Put_Character (Digs (X)); - end if; - - Pos := Pos - 1; - end Put_Digit; - - --------------- - -- Put_Int64 -- - --------------- - - procedure Put_Int64 (X : Int64; Scale : Integer) is - begin - if X = 0 then - return; - end if; - - if X not in -9 .. 9 then - Put_Int64 (X / 10, Scale + 1); - end if; - - -- Use Put_Digit to advance Pos. This fixes a case where the second - -- or later Scaled_Divide would omit leading zeroes, resulting in - -- too few digits produced and a Layout_Error as result. - - while Pos > Scale loop - Put_Digit (0); - end loop; - - -- If and only if more than one digit is output before the decimal - -- point, pos will be unequal to scale when outputting the first - -- digit. - - pragma Assert (Pos = Scale or else Last = To'First - 1); - - Pos := Scale; - - Put_Digit (abs (X rem 10)); - end Put_Int64; - - ---------------- - -- Put_Scaled -- - ---------------- - - procedure Put_Scaled - (X, Y, Z : Int64; - A : Field; - E : Integer) - is - pragma Assert (E >= -Max_Digits); - AA : constant Field := Integer'Max (E + A, 0); - N : constant Natural := (AA + Max_Digits - 1) / Max_Digits + 1; - - Q : array (0 .. N - 1) of Int64 := (others => 0); - -- Each element of Q has Max_Digits decimal digits, except the - -- last, which has AA rem Max_Digits. Only Q (Q'First) may have an - -- absolute value equal to or larger than 10**Max_Digits. Only the - -- absolute value of the elements is significant, not the sign. - - XX : Int64 := X; - YY : Int64 := Y; - - begin - for J in Q'Range loop - exit when XX = 0; - - if J > 0 then - YY := 10**(Integer'Min (Max_Digits, AA - (J - 1) * Max_Digits)); - end if; - - Scaled_Divide64 (XX, YY, Z, Q (J), R => XX, Round => False); - end loop; - - if -E > A then - pragma Assert (N = 1); - - Discard_Extra_Digits : declare - Factor : constant Int64 := 10**(-E - A); - - begin - -- The scaling factors were such that the first division - -- produced more digits than requested. So divide away extra - -- digits and compute new remainder for later rounding. - - if abs (Q (0) rem Factor) >= Factor / 2 then - Q (0) := abs (Q (0) / Factor) + 1; - else - Q (0) := Q (0) / Factor; - end if; - - XX := 0; - end Discard_Extra_Digits; - end if; - - -- At this point XX is a remainder and we need to determine if the - -- quotient in Q must be rounded away from zero. - - -- As XX is less than the divisor, it is safe to take its absolute - -- without chance of overflow. The check to see if XX is at least - -- half the absolute value of the divisor must be done carefully to - -- avoid overflow or lose precision. - - XX := abs XX; - - if XX >= 2**62 - or else (Z < 0 and then (-XX) * 2 <= Z) - or else (Z >= 0 and then XX * 2 >= Z) - then - -- OK, rounding is necessary. As the sign is not significant, - -- take advantage of the fact that an extra negative value will - -- always be available when propagating the carry. - - Q (Q'Last) := -abs Q (Q'Last) - 1; - - Propagate_Carry : - for J in reverse 1 .. Q'Last loop - if Q (J) = YY or else Q (J) = -YY then - Q (J) := 0; - Q (J - 1) := -abs Q (J - 1) - 1; - - else - exit Propagate_Carry; - end if; - end loop Propagate_Carry; - end if; - - for J in Q'First .. Q'Last - 1 loop - Put_Int64 (Q (J), E - J * Max_Digits); - end loop; - - Put_Int64 (Q (Q'Last), -A); - end Put_Scaled; - - -- Start of processing for Put - begin - Last := To'First - 1; - - if Exp /= 0 then - - -- With the Exp format, it is not known how many output digits to - -- generate, as leading zeros must be ignored. Computing too many - -- digits and then truncating the output will not give the closest - -- output, it is necessary to round at the correct digit. - - -- The general approach is as follows: as long as no digits have - -- been generated, compute the Aft next digits (without rounding). - -- Once a non-zero digit is generated, determine the exact number - -- of digits remaining and compute them with rounding. - - -- Since a large number of iterations might be necessary in case - -- of Aft = 1, the following optimization would be desirable. - - -- Count the number Z of leading zero bits in the integer - -- representation of X, and start with producing Aft + Z * 1000 / - -- 3322 digits in the first scaled division. - - -- However, the floating-point routines are still used now ??? - - System.Img_Real.Set_Image_Real (Long_Long_Float (Item), To, Last, - Fore, Aft, Exp); - return; - end if; - - if Exact then - declare - D : constant Integer := Integer'Min (A, Max_Digits - - (Num'Fore - 1)); - Y : constant Int64 := Int64'Min (Int64 (-Num'Small), -1) - * 10**Integer'Max (0, D); - Z : constant Int64 := Int64'Min (Int64 (-(1.0 / Num'Small)), -1) - * 10**Integer'Max (0, -D); - begin - Put_Scaled (X, Y, Z, A, -D); - end; - - else -- not Exact - declare - E : constant Integer := Max_Digits - 1 + Scale; - D : constant Integer := Scale - 1; - Y : constant Int64 := Int64 (-Num'Small * 10.0**E); - Z : constant Int64 := -10**Max_Digits; - begin - Put_Scaled (X, Y, Z, A, -D); - end; + if not Exact then + Float_Aux.Puts (To, Long_Long_Float (Item), Aft, Exp); + elsif Need_64 then + Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); end if; - - -- If only zero digits encountered, unit digit has not been output yet - - if Last < To'First then - Pos := 0; - - elsif Last > To'Last then - raise Layout_Error; -- Not enough room in the output variable - end if; - - -- Always output digits up to the first one after the decimal point - - while Pos >= -A loop - Put_Digit (0); - end loop; end Put; end Ada.Text_IO.Fixed_IO; diff --git a/gcc/ada/libgnat/a-tifiio__128.adb b/gcc/ada/libgnat/a-tifiio__128.adb new file mode 100644 index 00000000000..f164209c3b3 --- /dev/null +++ b/gcc/ada/libgnat/a-tifiio__128.adb @@ -0,0 +1,365 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . F I X E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Fixed point I/O +-- --------------- + +-- The following text documents implementation details of the fixed point +-- input/output routines in the GNAT runtime. The first part describes the +-- general properties of fixed point types as defined by the Ada standard, +-- including the Information Systems Annex. + +-- Subsequently these are reduced to implementation constraints and the impact +-- of these constraints on a few possible approaches to input/output is given. +-- Based on this analysis, a specific implementation is selected for use in +-- the GNAT runtime. Finally, the chosen algorithm is analyzed numerically in +-- order to provide user-level documentation on limits for range and precision +-- of fixed point types as well as accuracy of input/output conversions. + +-- ------------------------------------------- +-- - General Properties of Fixed Point Types - +-- ------------------------------------------- + +-- Operations on fixed point types, other than input/output, are not important +-- for the purpose of this document. Only the set of values that a fixed point +-- type can represent and the input/output operations are significant. + +-- Values +-- ------ + +-- The set of values of a fixed point type comprise the integral multiples of +-- a number called the small of the type. The small can be either a power of +-- two, a power of ten or (if the implementation allows) an arbitrary strictly +-- positive real value. + +-- Implementations need to support ordinary fixed point types with a precision +-- of at least 24 bits, and (in order to comply with the Information Systems +-- Annex) decimal fixed point types with at least 18 digits. For the rest, no +-- requirements exist for the minimal small and range that must be supported. + +-- Operations +-- ---------- + +-- 'Image and 'Wide_Image (see RM 3.5(34)) + +-- These attributes return a decimal real literal best approximating +-- the value (rounded away from zero if halfway between) with a +-- single leading character that is either a minus sign or a space, +-- one or more digits before the decimal point (with no redundant +-- leading zeros), a decimal point, and N digits after the decimal +-- point. For a subtype S, the value of N is S'Aft, the smallest +-- positive integer such that (10**N)*S'Delta is greater or equal to +-- one, see RM 3.5.10(5). + +-- For an arbitrary small, this means large number arithmetic needs +-- to be performed. + +-- Put (see RM A.10.9(22-26)) + +-- The requirements for Put add no extra constraints over the image +-- attributes, although it would be nice to be able to output more +-- than S'Aft digits after the decimal point for values of subtype S. + +-- 'Value and 'Wide_Value attribute (RM 3.5(40-55)) + +-- Since the input can be given in any base in the range 2..16, +-- accurate conversion to a fixed point number may require +-- arbitrary precision arithmetic if there is no limit on the +-- magnitude of the small of the fixed point type. + +-- Get (see RM A.10.9(12-21)) + +-- The requirements for Get are identical to those of the Value +-- attribute. + +-- ------------------------------ +-- - Implementation Constraints - +-- ------------------------------ + +-- The requirements listed above for the input/output operations lead to +-- significant complexity, if no constraints are put on supported smalls. + +-- Implementation Strategies +-- ------------------------- + +-- * Floating point arithmetic +-- * Arbitrary-precision integer arithmetic +-- * Fixed-precision integer arithmetic + +-- Although it seems convenient to convert fixed point numbers to floating +-- point and then print them, this leads to a number of restrictions. +-- The first one is precision. The widest floating-point type generally +-- available has 53 bits of mantissa. This means that Fine_Delta cannot +-- be less than 2.0**(-53). + +-- In GNAT, Fine_Delta is 2.0**(-63), and Duration for example is a 64-bit +-- type. This means that a floating-point type with 63 bits of mantissa needs +-- to be used, which is only generally available on the x86 architecture. It +-- would still be possible to use multi-precision floating point to perform +-- calculations using longer mantissas, but this is a much harder approach. + +-- The base conversions needed for input/output of (non-decimal) fixed point +-- types can be seen as pairs of integer multiplications and divisions. + +-- Arbitrary-precision integer arithmetic would be suitable for the job at +-- hand, but has the drawback that it is very heavy implementation-wise. +-- Especially in embedded systems, where fixed point types are often used, +-- it may not be desirable to require large amounts of storage and time +-- for fixed I/O operations. + +-- Fixed-precision integer arithmetic has the advantage of simplicity and +-- speed. For the most common fixed point types this would be a perfect +-- solution. The downside however may be a too limited set of acceptable +-- fixed point types. + +with Interfaces; +with Ada.Text_IO.Fixed_Aux; +with Ada.Text_IO.Float_Aux; +with System.Img_Fixed_32; use System.Img_Fixed_32; +with System.Img_Fixed_64; use System.Img_Fixed_64; +with System.Img_Fixed_128; use System.Img_Fixed_128; +with System.Val_Fixed_32; use System.Val_Fixed_32; +with System.Val_Fixed_64; use System.Val_Fixed_64; +with System.Val_Fixed_128; use System.Val_Fixed_128; + +package body Ada.Text_IO.Fixed_IO is + + -- Note: we still use the floating-point I/O routines for types whose small + -- is not a sufficiently small integer or the reciprocal thereof. This will + -- result in inaccuracies for fixed point types that require more precision + -- than is available in Long_Long_Float. + + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; + subtype Int128 is Interfaces.Integer_128; + + package Aux32 is new + Ada.Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32); + + package Aux64 is new + Ada.Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64); + + package Aux128 is new + Ada.Text_IO.Fixed_Aux (Int128, Scan_Fixed128, Set_Image_Fixed128); + + Exact : constant Boolean := + (Float'Floor (Num'Small) = Float'Ceiling (Num'Small) + or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)) + and then Num'Small >= 2.0**(-127) + and then Num'Small <= 2.0**127; + -- True if the exact algorithm implemented in Fixed_Aux can be used. The + -- condition is a Small which is either an integer or the reciprocal of an + -- integer with the appropriate magnitude. + + Need_64 : constant Boolean := + Num'Object_Size > 32 + or else Num'Small > 2.0**31 + or else Num'Small < 2.0**(-31); + Need_128 : constant Boolean := + Num'Object_Size > 64 + or else Num'Small > 2.0**63 + or else Num'Small < 2.0**(-63); + -- Throughout this generic body, we distinguish between the cases where + -- type Int32 is acceptable, where type Int64 is acceptable, and where + -- type Int128 is needed. These boolean constants are used to test for + -- these cases and since they are constant, only code for the relevant + -- case will be really included in the instance. + + E : constant Natural := + 31 + 32 * Boolean'Pos (Need_64) + 64 * Boolean'Pos (Need_128); + -- T'Size - 1 for the selected Int{32,64,128} + + F0 : constant Natural := 0; + F1 : constant Natural := + F0 + 38 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+38); + F2 : constant Natural := + F1 + 19 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+19); + F3 : constant Natural := + F2 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+9); + F4 : constant Natural := + F3 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+5); + F5 : constant Natural := + F4 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+3); + F6 : constant Natural := + F5 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+2); + F7 : constant Natural := + F6 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F6) >= 1.0E+1); + -- Binary search for the number of digits - 1 before the decimal point of + -- the product 2.0**E * Num'Small. + + For0 : constant Natural := 2 + F7; + -- Fore value for the fixed point type whose mantissa is Int{32,64,128} and + -- whose small is Num'Small. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + + begin + if not Exact then + Float_Aux.Get (File, Long_Long_Float (Item), Width); + elsif Need_128 then + Item := Num'Fixed_Value + (Aux128.Get (File, Width, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)))); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Get (File, Width, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Get (File, Width, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : String; + Item : out Num; + Last : out Positive) + is + pragma Unsuppress (Range_Check); + + begin + if not Exact then + Float_Aux.Gets (From, Long_Long_Float (Item), Last); + elsif Need_128 then + Item := Num'Fixed_Value + (Aux128.Gets (From, Last, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)))); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Gets (From, Last, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Gets (From, Last, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if not Exact then + Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + elsif Need_128 then + Aux128.Put (File, Int128'Integer_Value (Item), Fore, Aft, Exp, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + elsif Need_64 then + Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + end if; + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Out, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if not Exact then + Float_Aux.Puts (To, Long_Long_Float (Item), Aft, Exp); + elsif Need_128 then + Aux128.Puts (To, Int128'Integer_Value (Item), Aft, Exp, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + elsif Need_64 then + Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + end if; + end Put; + +end Ada.Text_IO.Fixed_IO; diff --git a/gcc/ada/libgnat/a-tiflau.adb b/gcc/ada/libgnat/a-tiflau.adb index 214b5c8f2c3..ddb52a5eebf 100644 --- a/gcc/ada/libgnat/a-tiflau.adb +++ b/gcc/ada/libgnat/a-tiflau.adb @@ -47,7 +47,7 @@ package body Ada.Text_IO.Float_Aux is is Buf : String (1 .. Field'Last); Stop : Integer := 0; - Ptr : aliased Integer := 1; + Ptr : aliased Integer; begin if Width /= 0 then @@ -55,10 +55,10 @@ package body Ada.Text_IO.Float_Aux is String_Skip (Buf, Ptr); else Load_Real (File, Buf, Stop); + Ptr := 1; end if; Item := Scan_Real (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get; @@ -79,8 +79,7 @@ package body Ada.Text_IO.Float_Aux is Last := Pos - 1; exception - when Constraint_Error => - raise Data_Error; + when Constraint_Error => raise Data_Error; end Gets; --------------- diff --git a/gcc/ada/libgnat/a-wtdeau.adb b/gcc/ada/libgnat/a-wtdeau.adb index 7bfc6133a27..268ba4da606 100644 --- a/gcc/ada/libgnat/a-wtdeau.adb +++ b/gcc/ada/libgnat/a-wtdeau.adb @@ -32,54 +32,21 @@ with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; with Ada.Wide_Text_IO.Float_Aux; use Ada.Wide_Text_IO.Float_Aux; -with System.Img_Dec; use System.Img_Dec; -with System.Img_LLD; use System.Img_LLD; -with System.Val_Dec; use System.Val_Dec; -with System.Val_LLD; use System.Val_LLD; - package body Ada.Wide_Text_IO.Decimal_Aux is - ------------- - -- Get_Dec -- - ------------- - - function Get_Dec - (File : File_Type; - Width : Field; - Scale : Integer) return Integer - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer; - Stop : Integer := 0; - Item : Integer; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - Ptr := 1; - end if; - - Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - return Item; - end Get_Dec; - - ------------- - -- Get_LLD -- - ------------- + --------- + -- Get -- + --------- - function Get_LLD + function Get (File : File_Type; Width : Field; - Scale : Integer) return Long_Long_Integer + Scale : Integer) return Int is Buf : String (1 .. Field'Last); Ptr : aliased Integer; Stop : Integer := 0; - Item : Long_Long_Integer; + Item : Int; begin if Width /= 0 then @@ -90,68 +57,42 @@ package body Ada.Wide_Text_IO.Decimal_Aux is Ptr := 1; end if; - Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); + Item := Scan (Buf, Ptr'Access, Stop, Scale); Check_End_Of_Field (Buf, Stop, Ptr, Width); return Item; - end Get_LLD; - - -------------- - -- Gets_Dec -- - -------------- - - function Gets_Dec - (From : String; - Last : not null access Positive; - Scale : Integer) return Integer - is - Pos : aliased Integer; - Item : Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; - return Item; + end Get; - exception - when Constraint_Error => - Last.all := Pos - 1; - raise Data_Error; - - end Gets_Dec; + ---------- + -- Gets -- + ---------- - -------------- - -- Gets_LLD -- - -------------- - - function Gets_LLD + function Gets (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer + Last : out Positive; + Scale : Integer) return Int is Pos : aliased Integer; - Item : Long_Long_Integer; + Item : Int; begin String_Skip (From, Pos); - Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; + Item := Scan (From, Pos'Access, From'Last, Scale); + Last := Pos - 1; return Item; exception when Constraint_Error => - Last.all := Pos - 1; + Last := Pos - 1; raise Data_Error; + end Gets; - end Gets_LLD; - - ------------- - -- Put_Dec -- - ------------- + --------- + -- Put -- + --------- - procedure Put_Dec + procedure Put (File : File_Type; - Item : Integer; + Item : Int; Fore : Field; Aft : Field; Exp : Field; @@ -161,105 +102,51 @@ package body Ada.Wide_Text_IO.Decimal_Aux is Ptr : Natural := 0; begin - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp); Put_Item (File, Buf (1 .. Ptr)); - end Put_Dec; + end Put; - ------------- - -- Put_LLD -- - ------------- + ---------- + -- Puts -- + ---------- - procedure Put_LLD - (File : File_Type; - Item : Long_Long_Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLD; - - -------------- - -- Puts_Dec -- - -------------- - - procedure Puts_Dec + procedure Puts (To : out String; - Item : Integer; + Item : Int; Aft : Field; Exp : Field; Scale : Integer) is - Buf : String (1 .. Field'Last); + Buf : String (1 .. Positive'Max (Field'Last, To'Length)); Fore : Integer; Ptr : Natural := 0; begin - -- Compute Fore, allowing for Aft digits and the decimal dot + -- Compute Fore, allowing for the decimal dot and Aft digits - Fore := To'Length - Field'Max (1, Aft) - 1; + Fore := To'Length - 1 - Field'Max (1, Aft); - -- Allow for Exp and two more for E+ or E- if exponent present + -- Allow for Exp and one more for E if exponent present if Exp /= 0 then - Fore := Fore - 2 - Exp; + Fore := Fore - 1 - Field'Max (2, Exp); end if; -- Make sure we have enough room - if Fore < 1 then + if Fore < 1 + Boolean'Pos (Item < 0) then raise Layout_Error; end if; -- Do the conversion and check length of result - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - - if Ptr > To'Length then - raise Layout_Error; - else - To := Buf (1 .. Ptr); - end if; - end Puts_Dec; - - -------------- - -- Puts_LLD -- - -------------- - - procedure Puts_LLD - (To : out String; - Item : Long_Long_Integer; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Fore : Integer; - Ptr : Natural := 0; - - begin - Fore := - (if Exp = 0 - then To'Length - 1 - Aft - else To'Length - 2 - Aft - Exp); - - if Fore < 1 then - raise Layout_Error; - end if; - - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp); if Ptr > To'Length then raise Layout_Error; else To := Buf (1 .. Ptr); end if; - end Puts_LLD; + end Puts; end Ada.Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/libgnat/a-wtdeau.ads b/gcc/ada/libgnat/a-wtdeau.ads index 0465455a373..5c0c4d6766a 100644 --- a/gcc/ada/libgnat/a-wtdeau.ads +++ b/gcc/ada/libgnat/a-wtdeau.ads @@ -29,63 +29,54 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routines for Ada.Wide_Text_IO.Decimal_IO --- that are shared among separate instantiations of this package. The --- routines in the package are identical semantically to those declared --- in Wide_Text_IO, except that default values have been supplied by the --- generic, and the Num parameter has been replaced by Integer or --- Long_Long_Integer, with an additional Scale parameter giving the --- value of Num'Scale. In addition the Get routines return the value --- rather than store it in an Out parameter. +-- This package contains the implementation for Ada.Wide_Text_IO.Decimal_IO. +-- Routines in this package are identical semantically to those in Decimal_IO, +-- except that the default parameters have been removed because they are +-- supplied explicitly by the calls from within these units, and there is an +-- additional Scale parameter giving the value of Num'Scale. In addition the +-- Get routines return the value rather than store it in an Out parameter. -private package Ada.Wide_Text_IO.Decimal_Aux is +private generic + type Int is range <>; - function Get_Dec - (File : File_Type; - Width : Field; - Scale : Integer) return Integer; + with function Scan + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Scale : Integer) return Int; - function Get_LLD - (File : File_Type; - Width : Field; - Scale : Integer) return Long_Long_Integer; + with procedure Set_Image + (V : Int; + S : in out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural); - function Gets_Dec - (From : String; - Last : not null access Positive; - Scale : Integer) return Integer; +package Ada.Wide_Text_IO.Decimal_Aux is - function Gets_LLD - (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer; - - procedure Put_Dec + function Get (File : File_Type; - Item : Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer); + Width : Field; + Scale : Integer) return Int; - procedure Put_LLD + procedure Put (File : File_Type; - Item : Long_Long_Integer; + Item : Int; Fore : Field; Aft : Field; Exp : Field; Scale : Integer); - procedure Puts_Dec - (To : out String; - Item : Integer; - Aft : Field; - Exp : Field; - Scale : Integer); + function Gets + (From : String; + Last : out Positive; + Scale : Integer) return Int; - procedure Puts_LLD + procedure Puts (To : out String; - Item : Long_Long_Integer; + Item : Int; Aft : Field; Exp : Field; Scale : Integer); diff --git a/gcc/ada/libgnat/a-wtdeio.adb b/gcc/ada/libgnat/a-wtdeio.adb index 5e328b231bc..b432cac6ce0 100644 --- a/gcc/ada/libgnat/a-wtdeio.adb +++ b/gcc/ada/libgnat/a-wtdeio.adb @@ -30,13 +30,35 @@ ------------------------------------------------------------------------------ with Ada.Wide_Text_IO.Decimal_Aux; - +with System.Img_Decimal_32; use System.Img_Decimal_32; +with System.Img_Decimal_64; use System.Img_Decimal_64; +with System.Val_Decimal_32; use System.Val_Decimal_32; +with System.Val_Decimal_64; use System.Val_Decimal_64; with System.WCh_Con; use System.WCh_Con; with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Text_IO.Decimal_IO is - package Aux renames Ada.Wide_Text_IO.Decimal_Aux; + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; + + package Aux32 is new + Ada.Wide_Text_IO.Decimal_Aux + (Int32, + Scan_Decimal32, + Set_Image_Decimal32); + + package Aux64 is new + Ada.Wide_Text_IO.Decimal_Aux + (Int64, + Scan_Decimal64, + Set_Image_Decimal64); + + Need64 : constant Boolean := Num'Size > 32; + -- Throughout this generic body, we distinguish between the case where type + -- Int32 is acceptable and where type Int64 is needed. This Boolean is used + -- to test for these cases and since it is a constant, only code for the + -- relevant case will be included in the instance. Scale : constant Integer := Num'Scale; @@ -49,12 +71,15 @@ package body Ada.Wide_Text_IO.Decimal_IO is Item : out Num; Width : Field := 0) is + pragma Unsuppress (Range_Check); + begin - if Num'Size > Integer'Size then - Item := Num'Fixed_Value (Aux.Get_LLD (File, Width, Scale)); + if Need64 then + Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale)); else - Item := Num'Fixed_Value (Aux.Get_Dec (File, Width, Scale)); + Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale)); end if; + exception when Constraint_Error => raise Data_Error; end Get; @@ -72,6 +97,8 @@ package body Ada.Wide_Text_IO.Decimal_IO is Item : out Num; Last : out Positive) is + pragma Unsuppress (Range_Check); + S : constant String := Wide_String_To_String (From, WCEM_Upper); -- String on which we do the actual conversion. Note that the method -- used for wide character encoding is irrelevant, since if there is @@ -79,16 +106,10 @@ package body Ada.Wide_Text_IO.Decimal_IO is -- Aux.Gets will raise Data_Error in any case. begin - if Num'Size > Integer'Size then - -- Item := Num'Fixed_Value - -- should write above, but gets assert error ??? - Item := Num - (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale)); + if Need64 then + Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale)); else - -- Item := Num'Fixed_Value - -- should write above, but gets assert error ??? - Item := Num - (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale)); + Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale)); end if; exception @@ -107,13 +128,12 @@ package body Ada.Wide_Text_IO.Decimal_IO is Exp : Field := Default_Exp) is begin - if Num'Size > Integer'Size then - Aux.Put_LLD - (File, Long_Long_Integer'Integer_Value (Item), - Fore, Aft, Exp, Scale); + if Need64 then + Aux64.Put + (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale); else - Aux.Put_Dec - (File, Integer'Integer_Value (Item), Fore, Aft, Exp, Scale); + Aux32.Put + (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale); end if; end Put; @@ -136,12 +156,10 @@ package body Ada.Wide_Text_IO.Decimal_IO is S : String (To'First .. To'Last); begin - if Num'Size > Integer'Size then - Aux.Puts_LLD - (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale); - + if Need64 then + Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale); else - Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale); + Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale); end if; for J in S'Range loop diff --git a/gcc/ada/libgnat/a-wtdeio__128.adb b/gcc/ada/libgnat/a-wtdeio__128.adb new file mode 100644 index 00000000000..6e23e083ecb --- /dev/null +++ b/gcc/ada/libgnat/a-wtdeio__128.adb @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Decimal_Aux; +with System.Img_Decimal_32; use System.Img_Decimal_32; +with System.Img_Decimal_64; use System.Img_Decimal_64; +with System.Img_Decimal_128; use System.Img_Decimal_128; +with System.Val_Decimal_32; use System.Val_Decimal_32; +with System.Val_Decimal_64; use System.Val_Decimal_64; +with System.Val_Decimal_128; use System.Val_Decimal_128; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Decimal_IO is + + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; + subtype Int128 is Interfaces.Integer_128; + + package Aux32 is new + Ada.Wide_Text_IO.Decimal_Aux + (Int32, + Scan_Decimal32, + Set_Image_Decimal32); + + package Aux64 is new + Ada.Wide_Text_IO.Decimal_Aux + (Int64, + Scan_Decimal64, + Set_Image_Decimal64); + + package Aux128 is new + Ada.Wide_Text_IO.Decimal_Aux + (Int128, + Scan_Decimal128, + Set_Image_Decimal128); + + Need64 : constant Boolean := Num'Size > 32; + Need128 : constant Boolean := Num'Size > 64; + -- Throughout this generic body, we distinguish between the case where type + -- Int32 is acceptable, where type Int64 is acceptable and where an Int128 + -- is needed. These boolean constants are used to test for these cases and + -- since it is a constant, only code for the relevant case will be included + -- in the instance. + + Scale : constant Integer := Num'Scale; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + + begin + if Need128 then + Item := Num'Fixed_Value (Aux128.Get (File, Width, Scale)); + elsif Need64 then + Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale)); + else + Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + pragma Unsuppress (Range_Check); + + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Need128 then + Item := Num'Fixed_Value (Aux128.Gets (S, Last, Scale)); + elsif Need64 then + Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale)); + else + Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if Need128 then + Aux128.Put + (File, Int128'Integer_Value (Item), Fore, Aft, Exp, Scale); + elsif Need64 then + Aux64.Put + (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale); + else + Aux32.Put + (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale); + end if; + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + if Need128 then + Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp, Scale); + elsif Need64 then + Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale); + else + Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale); + end if; + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/libgnat/a-wtfiau.adb b/gcc/ada/libgnat/a-wtfiau.adb new file mode 100644 index 00000000000..d4a153413af --- /dev/null +++ b/gcc/ada/libgnat/a-wtfiau.adb @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; +with Ada.Wide_Text_IO.Float_Aux; use Ada.Wide_Text_IO.Float_Aux; + +package body Ada.Wide_Text_IO.Fixed_Aux is + + --------- + -- Get -- + --------- + + function Get + (File : File_Type; + Width : Field; + Num : Int; + Den : Int) return Int + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Int; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan (Buf, Ptr'Access, Stop, Num, Den); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get; + + ---------- + -- Gets -- + ---------- + + function Gets + (From : String; + Last : out Positive; + Num : Int; + Den : Int) return Int + is + Pos : aliased Integer; + Item : Int; + + begin + String_Skip (From, Pos); + Item := Scan (From, Pos'Access, From'Last, Num, Den); + Last := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last := Pos - 1; + raise Data_Error; + end Gets; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Int; + Fore : Field; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + Item : Int; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural) + is + Buf : String (1 .. Positive'Max (Field'Last, To'Length)); + Fore : Integer; + Ptr : Natural := 0; + + begin + -- Compute Fore, allowing for the decimal dot and Aft digits + + Fore := To'Length - 1 - Field'Max (1, Aft); + + -- Allow for Exp and one more for E if exponent present + + if Exp /= 0 then + Fore := Fore - 1 - Field'Max (2, Exp); + end if; + + -- Make sure we have enough room + + if Fore < 1 + Boolean'Pos (Item < 0) then + raise Layout_Error; + end if; + + -- Do the conversion and check length of result + + Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts; + +end Ada.Wide_Text_IO.Fixed_Aux; diff --git a/gcc/ada/libgnat/a-wtfiau.ads b/gcc/ada/libgnat/a-wtfiau.ads new file mode 100644 index 00000000000..f487931d1f3 --- /dev/null +++ b/gcc/ada/libgnat/a-wtfiau.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the implementation for Ada.Wide_Text_IO.Fixed_IO. +-- Routines in this package are identical semantically to those in Fixed_IO, +-- except that the default parameters have been removed because they are +-- supplied explicitly by the calls from within these units, and there are +-- additional Num and Den parameters giving the value of Num'Small, as well +-- as For0 and Aft0 giving some properties of Num'Small. In addition the Get +-- routines return the value rather than store it in an Out parameter. + +private generic + type Int is range <>; + + with function Scan + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Num : Int; + Den : Int) return Int; + + with procedure Set_Image + (V : Int; + S : in out String; + P : in out Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural); + +package Ada.Wide_Text_IO.Fixed_Aux is + + function Get + (File : File_Type; + Width : Field; + Num : Int; + Den : Int) return Int; + + procedure Put + (File : File_Type; + Item : Int; + Fore : Field; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural); + + function Gets + (From : String; + Last : out Positive; + Num : Int; + Den : Int) return Int; + + procedure Puts + (To : out String; + Item : Int; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural); + +end Ada.Wide_Text_IO.Fixed_Aux; diff --git a/gcc/ada/libgnat/a-wtfiio.adb b/gcc/ada/libgnat/a-wtfiio.adb index 9f1e724f6a0..00990af87d2 100644 --- a/gcc/ada/libgnat/a-wtfiio.adb +++ b/gcc/ada/libgnat/a-wtfiio.adb @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O -- +-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O -- -- -- -- B o d y -- -- -- @@ -29,13 +29,72 @@ -- -- ------------------------------------------------------------------------------ +with Interfaces; +with Ada.Wide_Text_IO.Fixed_Aux; with Ada.Wide_Text_IO.Float_Aux; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; +with System.Img_Fixed_32; use System.Img_Fixed_32; +with System.Img_Fixed_64; use System.Img_Fixed_64; +with System.Val_Fixed_32; use System.Val_Fixed_32; +with System.Val_Fixed_64; use System.Val_Fixed_64; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Text_IO.Fixed_IO is - package Aux renames Ada.Wide_Text_IO.Float_Aux; + -- Note: we still use the floating-point I/O routines for types whose small + -- is not a sufficiently small integer or the reciprocal thereof. This will + -- result in inaccuracies for fixed point types that require more precision + -- than is available in Long_Long_Float. + + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; + + package Aux32 is new + Ada.Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32); + + package Aux64 is new + Ada.Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64); + + Exact : constant Boolean := + (Float'Floor (Num'Small) = Float'Ceiling (Num'Small) + or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)) + and then Num'Small >= 2.0**(-63) + and then Num'Small <= 2.0**63; + -- True if the exact algorithm implemented in Fixed_Aux can be used. The + -- condition is a Small which is either an integer or the reciprocal of an + -- integer with the appropriate magnitude. + + Need_64 : constant Boolean := + Num'Object_Size > 32 + or else Num'Small > 2.0**31 + or else Num'Small < 2.0**(-31); + -- Throughout this generic body, we distinguish between the case where type + -- Int32 is acceptable and where type Int64 is needed. This Boolean is used + -- to test for these cases and since it is a constant, only code for the + -- relevant case will be included in the instance. + + E : constant Natural := 31 + 32 * Boolean'Pos (Need_64); + -- T'Size - 1 for the selected Int{32,64} + + F0 : constant Natural := 0; + F1 : constant Natural := + F0 + 18 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+18); + F2 : constant Natural := + F1 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+9); + F3 : constant Natural := + F2 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+5); + F4 : constant Natural := + F3 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+3); + F5 : constant Natural := + F4 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+2); + F6 : constant Natural := + F5 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+1); + -- Binary search for the number of digits - 1 before the decimal point of + -- the product 2.0**E * Num'Small. + + For0 : constant Natural := 2 + F6; + -- Fore value for the fixed point type whose mantissa is Int{32,64} and + -- whose small is Num'Small. --------- -- Get -- @@ -46,8 +105,22 @@ package body Ada.Wide_Text_IO.Fixed_IO is Item : out Num; Width : Field := 0) is + pragma Unsuppress (Range_Check); + begin - Aux.Get (File, Long_Long_Float (Item), Width); + if not Exact then + Float_Aux.Get (File, Long_Long_Float (Item), Width); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Get (File, Width, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Get (File, Width, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; exception when Constraint_Error => raise Data_Error; @@ -66,6 +139,8 @@ package body Ada.Wide_Text_IO.Fixed_IO is Item : out Num; Last : out Positive) is + pragma Unsuppress (Range_Check); + S : constant String := Wide_String_To_String (From, WCEM_Upper); -- String on which we do the actual conversion. Note that the method -- used for wide character encoding is irrelevant, since if there is @@ -73,7 +148,19 @@ package body Ada.Wide_Text_IO.Fixed_IO is -- Aux.Gets will raise Data_Error in any case. begin - Aux.Gets (S, Long_Long_Float (Item), Last); + if not Exact then + Float_Aux.Gets (S, Long_Long_Float (Item), Last); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Gets (S, Last, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Gets (S, Last, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; exception when Constraint_Error => raise Data_Error; @@ -91,7 +178,19 @@ package body Ada.Wide_Text_IO.Fixed_IO is Exp : Field := Default_Exp) is begin - Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + if not Exact then + Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + elsif Need_64 then + Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + end if; end Put; procedure Put @@ -113,7 +212,19 @@ package body Ada.Wide_Text_IO.Fixed_IO is S : String (To'First .. To'Last); begin - Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + if not Exact then + Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + elsif Need_64 then + Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + end if; for J in S'Range loop To (J) := Wide_Character'Val (Character'Pos (S (J))); diff --git a/gcc/ada/libgnat/a-wtfiio__128.adb b/gcc/ada/libgnat/a-wtfiio__128.adb new file mode 100644 index 00000000000..7607d5cccf7 --- /dev/null +++ b/gcc/ada/libgnat/a-wtfiio__128.adb @@ -0,0 +1,267 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces; +with Ada.Wide_Text_IO.Fixed_Aux; +with Ada.Wide_Text_IO.Float_Aux; +with System.Img_Fixed_32; use System.Img_Fixed_32; +with System.Img_Fixed_64; use System.Img_Fixed_64; +with System.Img_Fixed_128; use System.Img_Fixed_128; +with System.Val_Fixed_32; use System.Val_Fixed_32; +with System.Val_Fixed_64; use System.Val_Fixed_64; +with System.Val_Fixed_128; use System.Val_Fixed_128; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Fixed_IO is + + -- Note: we still use the floating-point I/O routines for types whose small + -- is not a sufficiently small integer or the reciprocal thereof. This will + -- result in inaccuracies for fixed point types that require more precision + -- than is available in Long_Long_Float. + + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; + subtype Int128 is Interfaces.Integer_128; + + package Aux32 is new + Ada.Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32); + + package Aux64 is new + Ada.Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64); + + package Aux128 is new + Ada.Wide_Text_IO.Fixed_Aux (Int128, Scan_Fixed128, Set_Image_Fixed128); + + Exact : constant Boolean := + (Float'Floor (Num'Small) = Float'Ceiling (Num'Small) + or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)) + and then Num'Small >= 2.0**(-127) + and then Num'Small <= 2.0**127; + -- True if the exact algorithm implemented in Fixed_Aux can be used. The + -- condition is a Small which is either an integer or the reciprocal of an + -- integer with the appropriate magnitude. + + Need_64 : constant Boolean := + Num'Object_Size > 32 + or else Num'Small > 2.0**31 + or else Num'Small < 2.0**(-31); + Need_128 : constant Boolean := + Num'Object_Size > 64 + or else Num'Small > 2.0**63 + or else Num'Small < 2.0**(-63); + -- Throughout this generic body, we distinguish between the cases where + -- type Int32 is acceptable, where type Int64 is acceptable, and where + -- type Int128 is needed. These boolean constants are used to test for + -- these cases and since they are constant, only code for the relevant + -- case will be really included in the instance. + + E : constant Natural := + 31 + 32 * Boolean'Pos (Need_64) + 64 * Boolean'Pos (Need_128); + -- T'Size - 1 for the selected Int{32,64,128} + + F0 : constant Natural := 0; + F1 : constant Natural := + F0 + 38 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+38); + F2 : constant Natural := + F1 + 19 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+19); + F3 : constant Natural := + F2 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+9); + F4 : constant Natural := + F3 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+5); + F5 : constant Natural := + F4 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+3); + F6 : constant Natural := + F5 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+2); + F7 : constant Natural := + F6 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F6) >= 1.0E+1); + -- Binary search for the number of digits - 1 before the decimal point of + -- the product 2.0**E * Num'Small. + + For0 : constant Natural := 2 + F7; + -- Fore value for the fixed point type whose mantissa is Int{32,64,128} and + -- whose small is Num'Small. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + + begin + if not Exact then + Float_Aux.Get (File, Long_Long_Float (Item), Width); + elsif Need_128 then + Item := Num'Fixed_Value + (Aux128.Get (File, Width, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)))); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Get (File, Width, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Get (File, Width, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + pragma Unsuppress (Range_Check); + + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if not Exact then + Float_Aux.Gets (S, Long_Long_Float (Item), Last); + elsif Need_128 then + Item := Num'Fixed_Value + (Aux128.Gets (S, Last, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)))); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Gets (S, Last, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Gets (S, Last, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if not Exact then + Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + elsif Need_128 then + Aux128.Put (File, Int128'Integer_Value (Item), Fore, Aft, Exp, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + elsif Need_64 then + Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + end if; + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + if not Exact then + Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + elsif Need_128 then + Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + elsif Need_64 then + Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + end if; + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/libgnat/a-ztdeau.adb b/gcc/ada/libgnat/a-ztdeau.adb index 3daff0f7f5e..6c2af9f2ce1 100644 --- a/gcc/ada/libgnat/a-ztdeau.adb +++ b/gcc/ada/libgnat/a-ztdeau.adb @@ -32,54 +32,21 @@ with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; with Ada.Wide_Wide_Text_IO.Float_Aux; use Ada.Wide_Wide_Text_IO.Float_Aux; -with System.Img_Dec; use System.Img_Dec; -with System.Img_LLD; use System.Img_LLD; -with System.Val_Dec; use System.Val_Dec; -with System.Val_LLD; use System.Val_LLD; - package body Ada.Wide_Wide_Text_IO.Decimal_Aux is - ------------- - -- Get_Dec -- - ------------- - - function Get_Dec - (File : File_Type; - Width : Field; - Scale : Integer) return Integer - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer; - Stop : Integer := 0; - Item : Integer; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - Ptr := 1; - end if; - - Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - return Item; - end Get_Dec; - - ------------- - -- Get_LLD -- - ------------- + --------- + -- Get -- + --------- - function Get_LLD + function Get (File : File_Type; Width : Field; - Scale : Integer) return Long_Long_Integer + Scale : Integer) return Int is Buf : String (1 .. Field'Last); Ptr : aliased Integer; Stop : Integer := 0; - Item : Long_Long_Integer; + Item : Int; begin if Width /= 0 then @@ -90,68 +57,42 @@ package body Ada.Wide_Wide_Text_IO.Decimal_Aux is Ptr := 1; end if; - Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); + Item := Scan (Buf, Ptr'Access, Stop, Scale); Check_End_Of_Field (Buf, Stop, Ptr, Width); return Item; - end Get_LLD; - - -------------- - -- Gets_Dec -- - -------------- - - function Gets_Dec - (From : String; - Last : not null access Positive; - Scale : Integer) return Integer - is - Pos : aliased Integer; - Item : Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; - return Item; + end Get; - exception - when Constraint_Error => - Last.all := Pos - 1; - raise Data_Error; - - end Gets_Dec; + ---------- + -- Gets -- + ---------- - -------------- - -- Gets_LLD -- - -------------- - - function Gets_LLD + function Gets (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer + Last : out Positive; + Scale : Integer) return Int is Pos : aliased Integer; - Item : Long_Long_Integer; + Item : Int; begin String_Skip (From, Pos); - Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; + Item := Scan (From, Pos'Access, From'Last, Scale); + Last := Pos - 1; return Item; exception when Constraint_Error => - Last.all := Pos - 1; + Last := Pos - 1; raise Data_Error; + end Gets; - end Gets_LLD; - - ------------- - -- Put_Dec -- - ------------- + --------- + -- Put -- + --------- - procedure Put_Dec + procedure Put (File : File_Type; - Item : Integer; + Item : Int; Fore : Field; Aft : Field; Exp : Field; @@ -161,103 +102,51 @@ package body Ada.Wide_Wide_Text_IO.Decimal_Aux is Ptr : Natural := 0; begin - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp); Put_Item (File, Buf (1 .. Ptr)); - end Put_Dec; + end Put; - ------------- - -- Put_LLD -- - ------------- + ---------- + -- Puts -- + ---------- - procedure Put_LLD - (File : File_Type; - Item : Long_Long_Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLD; - - -------------- - -- Puts_Dec -- - -------------- - - procedure Puts_Dec + procedure Puts (To : out String; - Item : Integer; + Item : Int; Aft : Field; Exp : Field; Scale : Integer) is - Buf : String (1 .. Field'Last); + Buf : String (1 .. Positive'Max (Field'Last, To'Length)); Fore : Integer; Ptr : Natural := 0; begin - -- Compute Fore, allowing for Aft digits and the decimal dot + -- Compute Fore, allowing for the decimal dot and Aft digits - Fore := To'Length - Field'Max (1, Aft) - 1; + Fore := To'Length - 1 - Field'Max (1, Aft); - -- Allow for Exp and two more for E+ or E- if exponent present + -- Allow for Exp and one more for E if exponent present if Exp /= 0 then - Fore := Fore - 2 - Exp; + Fore := Fore - 1 - Field'Max (2, Exp); end if; -- Make sure we have enough room - if Fore < 1 then + if Fore < 1 + Boolean'Pos (Item < 0) then raise Layout_Error; end if; -- Do the conversion and check length of result - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - - if Ptr > To'Length then - raise Layout_Error; - else - To := Buf (1 .. Ptr); - end if; - end Puts_Dec; - - -------------- - -- Puts_LLD -- - -------------- - - procedure Puts_LLD - (To : out String; - Item : Long_Long_Integer; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Fore : Integer; - Ptr : Natural := 0; - - begin - Fore := - (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp); - - if Fore < 1 then - raise Layout_Error; - end if; - - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp); if Ptr > To'Length then raise Layout_Error; else To := Buf (1 .. Ptr); end if; - end Puts_LLD; + end Puts; end Ada.Wide_Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/libgnat/a-ztdeau.ads b/gcc/ada/libgnat/a-ztdeau.ads index b493b80b193..962f4792110 100644 --- a/gcc/ada/libgnat/a-ztdeau.ads +++ b/gcc/ada/libgnat/a-ztdeau.ads @@ -29,63 +29,54 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routines for Ada.Wide_Wide_Text_IO.Decimal_IO --- that are shared among separate instantiations of this package. The --- routines in the package are identical semantically to those declared --- in Wide_Wide_Text_IO, except that default values have been supplied by the --- generic, and the Num parameter has been replaced by Integer or --- Long_Long_Integer, with an additional Scale parameter giving the --- value of Num'Scale. In addition the Get routines return the value --- rather than store it in an Out parameter. +-- This package contains implementation for Ada.Wide_Wide_Text_IO.Decimal_IO +-- Routines in this package are identical semantically to those in Decimal_IO, +-- except that the default parameters have been removed because they are +-- supplied explicitly by the calls from within these units, and there is an +-- additional Scale parameter giving the value of Num'Scale. In addition the +-- Get routines return the value rather than store it in an Out parameter. -private package Ada.Wide_Wide_Text_IO.Decimal_Aux is +private generic + type Int is range <>; - function Get_Dec - (File : File_Type; - Width : Field; - Scale : Integer) return Integer; + with function Scan + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Scale : Integer) return Int; - function Get_LLD - (File : File_Type; - Width : Field; - Scale : Integer) return Long_Long_Integer; + with procedure Set_Image + (V : Int; + S : in out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural); - function Gets_Dec - (From : String; - Last : not null access Positive; - Scale : Integer) return Integer; +package Ada.Wide_Wide_Text_IO.Decimal_Aux is - function Gets_LLD - (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer; - - procedure Put_Dec + function Get (File : File_Type; - Item : Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer); + Width : Field; + Scale : Integer) return Int; - procedure Put_LLD + procedure Put (File : File_Type; - Item : Long_Long_Integer; + Item : Int; Fore : Field; Aft : Field; Exp : Field; Scale : Integer); - procedure Puts_Dec - (To : out String; - Item : Integer; - Aft : Field; - Exp : Field; - Scale : Integer); + function Gets + (From : String; + Last : out Positive; + Scale : Integer) return Int; - procedure Puts_LLD + procedure Puts (To : out String; - Item : Long_Long_Integer; + Item : Int; Aft : Field; Exp : Field; Scale : Integer); diff --git a/gcc/ada/libgnat/a-ztdeio.adb b/gcc/ada/libgnat/a-ztdeio.adb index 4cc27380ae4..cd269149734 100644 --- a/gcc/ada/libgnat/a-ztdeio.adb +++ b/gcc/ada/libgnat/a-ztdeio.adb @@ -30,13 +30,35 @@ ------------------------------------------------------------------------------ with Ada.Wide_Wide_Text_IO.Decimal_Aux; - +with System.Img_Decimal_32; use System.Img_Decimal_32; +with System.Img_Decimal_64; use System.Img_Decimal_64; +with System.Val_Decimal_32; use System.Val_Decimal_32; +with System.Val_Decimal_64; use System.Val_Decimal_64; with System.WCh_Con; use System.WCh_Con; with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Wide_Text_IO.Decimal_IO is - package Aux renames Ada.Wide_Wide_Text_IO.Decimal_Aux; + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; + + package Aux32 is new + Ada.Wide_Wide_Text_IO.Decimal_Aux + (Int32, + Scan_Decimal32, + Set_Image_Decimal32); + + package Aux64 is new + Ada.Wide_Wide_Text_IO.Decimal_Aux + (Int64, + Scan_Decimal64, + Set_Image_Decimal64); + + Need64 : constant Boolean := Num'Size > 32; + -- Throughout this generic body, we distinguish between the case where type + -- Int32 is acceptable and where type Int64 is needed. This Boolean is used + -- to test for these cases and since it is a constant, only code for the + -- relevant case will be included in the instance. Scale : constant Integer := Num'Scale; @@ -49,12 +71,15 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is Item : out Num; Width : Field := 0) is + pragma Unsuppress (Range_Check); + begin - if Num'Size > Integer'Size then - Item := Num'Fixed_Value (Aux.Get_LLD (File, Width, Scale)); + if Need64 then + Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale)); else - Item := Num'Fixed_Value (Aux.Get_Dec (File, Width, Scale)); + Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale)); end if; + exception when Constraint_Error => raise Data_Error; end Get; @@ -72,6 +97,8 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is Item : out Num; Last : out Positive) is + pragma Unsuppress (Range_Check); + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); -- String on which we do the actual conversion. Note that the method -- used for wide character encoding is irrelevant, since if there is @@ -79,16 +106,10 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is -- Aux.Gets will raise Data_Error in any case. begin - if Num'Size > Integer'Size then - -- Item := Num'Fixed_Value - -- should write above, but gets assert error ??? - Item := Num - (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale)); + if Need64 then + Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale)); else - -- Item := Num'Fixed_Value - -- should write above, but gets assert error ??? - Item := Num - (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale)); + Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale)); end if; exception @@ -107,18 +128,12 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is Exp : Field := Default_Exp) is begin - if Num'Size > Integer'Size then - Aux.Put_LLD --- (File, Long_Long_Integer'Integer_Value (Item), --- ??? - (File, Long_Long_Integer (Item), - Fore, Aft, Exp, Scale); + if Need64 then + Aux64.Put + (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale); else - Aux.Put_Dec --- (File, Integer'Integer_Value (Item), Fore, Aft, Exp, Scale); --- ??? - (File, Integer (Item), Fore, Aft, Exp, Scale); - + Aux32.Put + (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale); end if; end Put; @@ -141,16 +156,10 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is S : String (To'First .. To'Last); begin - if Num'Size > Integer'Size then --- Aux.Puts_LLD --- (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale); --- ??? - Aux.Puts_LLD - (S, Long_Long_Integer (Item), Aft, Exp, Scale); + if Need64 then + Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale); else --- Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale); --- ??? - Aux.Puts_Dec (S, Integer (Item), Aft, Exp, Scale); + Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale); end if; for J in S'Range loop diff --git a/gcc/ada/libgnat/a-ztdeio__128.adb b/gcc/ada/libgnat/a-ztdeio__128.adb new file mode 100644 index 00000000000..e160a01c85d --- /dev/null +++ b/gcc/ada/libgnat/a-ztdeio__128.adb @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Decimal_Aux; +with System.Img_Decimal_32; use System.Img_Decimal_32; +with System.Img_Decimal_64; use System.Img_Decimal_64; +with System.Img_Decimal_128; use System.Img_Decimal_128; +with System.Val_Decimal_32; use System.Val_Decimal_32; +with System.Val_Decimal_64; use System.Val_Decimal_64; +with System.Val_Decimal_128; use System.Val_Decimal_128; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Decimal_IO is + + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; + subtype Int128 is Interfaces.Integer_128; + + package Aux32 is new + Ada.Wide_Wide_Text_IO.Decimal_Aux + (Int32, + Scan_Decimal32, + Set_Image_Decimal32); + + package Aux64 is new + Ada.Wide_Wide_Text_IO.Decimal_Aux + (Int64, + Scan_Decimal64, + Set_Image_Decimal64); + + package Aux128 is new + Ada.Wide_Wide_Text_IO.Decimal_Aux + (Int128, + Scan_Decimal128, + Set_Image_Decimal128); + + Need64 : constant Boolean := Num'Size > 32; + Need128 : constant Boolean := Num'Size > 64; + -- Throughout this generic body, we distinguish between the case where type + -- Int32 is acceptable, where type Int64 is acceptable and where an Int128 + -- is needed. These boolean constants are used to test for these cases and + -- since it is a constant, only code for the relevant case will be included + -- in the instance. + + Scale : constant Integer := Num'Scale; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + + begin + if Need128 then + Item := Num'Fixed_Value (Aux128.Get (File, Width, Scale)); + elsif Need64 then + Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale)); + else + Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + pragma Unsuppress (Range_Check); + + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Need128 then + Item := Num'Fixed_Value (Aux128.Gets (S, Last, Scale)); + elsif Need64 then + Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale)); + else + Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if Need128 then + Aux128.Put + (File, Int128'Integer_Value (Item), Fore, Aft, Exp, Scale); + elsif Need64 then + Aux64.Put + (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale); + else + Aux32.Put + (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale); + end if; + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + if Need128 then + Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp, Scale); + elsif Need64 then + Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale); + else + Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/libgnat/a-ztfiau.adb b/gcc/ada/libgnat/a-ztfiau.adb new file mode 100644 index 00000000000..f26a16a41ae --- /dev/null +++ b/gcc/ada/libgnat/a-ztfiau.adb @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; +with Ada.Wide_Wide_Text_IO.Float_Aux; use Ada.Wide_Wide_Text_IO.Float_Aux; + +package body Ada.Wide_Wide_Text_IO.Fixed_Aux is + + --------- + -- Get -- + --------- + + function Get + (File : File_Type; + Width : Field; + Num : Int; + Den : Int) return Int + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Int; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan (Buf, Ptr'Access, Stop, Num, Den); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get; + + ---------- + -- Gets -- + ---------- + + function Gets + (From : String; + Last : out Positive; + Num : Int; + Den : Int) return Int + is + Pos : aliased Integer; + Item : Int; + + begin + String_Skip (From, Pos); + Item := Scan (From, Pos'Access, From'Last, Num, Den); + Last := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last := Pos - 1; + raise Data_Error; + end Gets; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Int; + Fore : Field; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + Item : Int; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural) + is + Buf : String (1 .. Positive'Max (Field'Last, To'Length)); + Fore : Integer; + Ptr : Natural := 0; + + begin + -- Compute Fore, allowing for the decimal dot and Aft digits + + Fore := To'Length - 1 - Field'Max (1, Aft); + + -- Allow for Exp and one more for E if exponent present + + if Exp /= 0 then + Fore := Fore - 1 - Field'Max (2, Exp); + end if; + + -- Make sure we have enough room + + if Fore < 1 + Boolean'Pos (Item < 0) then + raise Layout_Error; + end if; + + -- Do the conversion and check length of result + + Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts; + +end Ada.Wide_Wide_Text_IO.Fixed_Aux; diff --git a/gcc/ada/libgnat/a-ztfiau.ads b/gcc/ada/libgnat/a-ztfiau.ads new file mode 100644 index 00000000000..aac4e426481 --- /dev/null +++ b/gcc/ada/libgnat/a-ztfiau.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the implementation for Ada.Wide_Wide_Text_IO.Fixed_IO +-- Routines in this package are identical semantically to those in Fixed_IO, +-- except that the default parameters have been removed because they are +-- supplied explicitly by the calls from within these units, and there are +-- additional Num and Den parameters giving the value of Num'Small, as well +-- as For0 and Aft0 giving some properties of Num'Small. In addition the Get +-- routines return the value rather than store it in an Out parameter. + +private generic + type Int is range <>; + + with function Scan + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Num : Int; + Den : Int) return Int; + + with procedure Set_Image + (V : Int; + S : in out String; + P : in out Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural); + +package Ada.Wide_Wide_Text_IO.Fixed_Aux is + + function Get + (File : File_Type; + Width : Field; + Num : Int; + Den : Int) return Int; + + procedure Put + (File : File_Type; + Item : Int; + Fore : Field; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural); + + function Gets + (From : String; + Last : out Positive; + Num : Int; + Den : Int) return Int; + + procedure Puts + (To : out String; + Item : Int; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural); + +end Ada.Wide_Wide_Text_IO.Fixed_Aux; diff --git a/gcc/ada/libgnat/a-ztfiio.adb b/gcc/ada/libgnat/a-ztfiio.adb index bfe24ac3edc..16e552d9733 100644 --- a/gcc/ada/libgnat/a-ztfiio.adb +++ b/gcc/ada/libgnat/a-ztfiio.adb @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O -- -- -- -- B o d y -- -- -- @@ -29,13 +29,72 @@ -- -- ------------------------------------------------------------------------------ +with Interfaces; +with Ada.Wide_Wide_Text_IO.Fixed_Aux; with Ada.Wide_Wide_Text_IO.Float_Aux; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; +with System.Img_Fixed_32; use System.Img_Fixed_32; +with System.Img_Fixed_64; use System.Img_Fixed_64; +with System.Val_Fixed_32; use System.Val_Fixed_32; +with System.Val_Fixed_64; use System.Val_Fixed_64; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Wide_Text_IO.Fixed_IO is - package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; + -- Note: we still use the floating-point I/O routines for types whose small + -- is not a sufficiently small integer or the reciprocal thereof. This will + -- result in inaccuracies for fixed point types that require more precision + -- than is available in Long_Long_Float. + + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; + + package Aux32 is new + Ada.Wide_Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32); + + package Aux64 is new + Ada.Wide_Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64); + + Exact : constant Boolean := + (Float'Floor (Num'Small) = Float'Ceiling (Num'Small) + or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)) + and then Num'Small >= 2.0**(-63) + and then Num'Small <= 2.0**63; + -- True if the exact algorithm implemented in Fixed_Aux can be used. The + -- condition is a Small which is either an integer or the reciprocal of an + -- integer with the appropriate magnitude. + + Need_64 : constant Boolean := + Num'Object_Size > 32 + or else Num'Small > 2.0**31 + or else Num'Small < 2.0**(-31); + -- Throughout this generic body, we distinguish between the case where type + -- Int32 is acceptable and where type Int64 is needed. This Boolean is used + -- to test for these cases and since it is a constant, only code for the + -- relevant case will be included in the instance. + + E : constant Natural := 31 + 32 * Boolean'Pos (Need_64); + -- T'Size - 1 for the selected Int{32,64} + + F0 : constant Natural := 0; + F1 : constant Natural := + F0 + 18 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+18); + F2 : constant Natural := + F1 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+9); + F3 : constant Natural := + F2 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+5); + F4 : constant Natural := + F3 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+3); + F5 : constant Natural := + F4 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+2); + F6 : constant Natural := + F5 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+1); + -- Binary search for the number of digits - 1 before the decimal point of + -- the product 2.0**E * Num'Small. + + For0 : constant Natural := 2 + F6; + -- Fore value for the fixed point type whose mantissa is Int{32,64} and + -- whose small is Num'Small. --------- -- Get -- @@ -46,8 +105,22 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is Item : out Num; Width : Field := 0) is + pragma Unsuppress (Range_Check); + begin - Aux.Get (File, Long_Long_Float (Item), Width); + if not Exact then + Float_Aux.Get (File, Long_Long_Float (Item), Width); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Get (File, Width, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Get (File, Width, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; exception when Constraint_Error => raise Data_Error; @@ -66,6 +139,8 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is Item : out Num; Last : out Positive) is + pragma Unsuppress (Range_Check); + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); -- String on which we do the actual conversion. Note that the method -- used for wide character encoding is irrelevant, since if there is @@ -73,7 +148,19 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is -- Aux.Gets will raise Data_Error in any case. begin - Aux.Gets (S, Long_Long_Float (Item), Last); + if not Exact then + Float_Aux.Gets (S, Long_Long_Float (Item), Last); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Gets (S, Last, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Gets (S, Last, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; exception when Constraint_Error => raise Data_Error; @@ -91,7 +178,19 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is Exp : Field := Default_Exp) is begin - Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + if not Exact then + Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + elsif Need_64 then + Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + end if; end Put; procedure Put @@ -113,7 +212,19 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is S : String (To'First .. To'Last); begin - Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + if not Exact then + Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + elsif Need_64 then + Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + end if; for J in S'Range loop To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); diff --git a/gcc/ada/libgnat/a-ztfiio__128.adb b/gcc/ada/libgnat/a-ztfiio__128.adb new file mode 100644 index 00000000000..02ad61372ef --- /dev/null +++ b/gcc/ada/libgnat/a-ztfiio__128.adb @@ -0,0 +1,269 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces; +with Ada.Wide_Wide_Text_IO.Fixed_Aux; +with Ada.Wide_Wide_Text_IO.Float_Aux; +with System.Img_Fixed_32; use System.Img_Fixed_32; +with System.Img_Fixed_64; use System.Img_Fixed_64; +with System.Img_Fixed_128; use System.Img_Fixed_128; +with System.Val_Fixed_32; use System.Val_Fixed_32; +with System.Val_Fixed_64; use System.Val_Fixed_64; +with System.Val_Fixed_128; use System.Val_Fixed_128; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Fixed_IO is + + -- Note: we still use the floating-point I/O routines for types whose small + -- is not a sufficiently small integer or the reciprocal thereof. This will + -- result in inaccuracies for fixed point types that require more precision + -- than is available in Long_Long_Float. + + subtype Int32 is Interfaces.Integer_32; + subtype Int64 is Interfaces.Integer_64; + subtype Int128 is Interfaces.Integer_128; + + package Aux32 is new + Ada.Wide_Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32); + + package Aux64 is new + Ada.Wide_Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64); + + package Aux128 is new + Ada.Wide_Wide_Text_IO.Fixed_Aux + (Int128, Scan_Fixed128, Set_Image_Fixed128); + + Exact : constant Boolean := + (Float'Floor (Num'Small) = Float'Ceiling (Num'Small) + or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)) + and then Num'Small >= 2.0**(-127) + and then Num'Small <= 2.0**127; + -- True if the exact algorithm implemented in Fixed_Aux can be used. The + -- condition is a Small which is either an integer or the reciprocal of an + -- integer with the appropriate magnitude. + + Need_64 : constant Boolean := + Num'Object_Size > 32 + or else Num'Small > 2.0**31 + or else Num'Small < 2.0**(-31); + Need_128 : constant Boolean := + Num'Object_Size > 64 + or else Num'Small > 2.0**63 + or else Num'Small < 2.0**(-63); + -- Throughout this generic body, we distinguish between the cases where + -- type Int32 is acceptable, where type Int64 is acceptable, and where + -- type Int128 is needed. These boolean constants are used to test for + -- these cases and since they are constant, only code for the relevant + -- case will be really included in the instance. + + E : constant Natural := + 31 + 32 * Boolean'Pos (Need_64) + 64 * Boolean'Pos (Need_128); + -- T'Size - 1 for the selected Int{32,64,128} + + F0 : constant Natural := 0; + F1 : constant Natural := + F0 + 38 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+38); + F2 : constant Natural := + F1 + 19 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+19); + F3 : constant Natural := + F2 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+9); + F4 : constant Natural := + F3 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+5); + F5 : constant Natural := + F4 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+3); + F6 : constant Natural := + F5 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+2); + F7 : constant Natural := + F6 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F6) >= 1.0E+1); + -- Binary search for the number of digits - 1 before the decimal point of + -- the product 2.0**E * Num'Small. + + For0 : constant Natural := 2 + F7; + -- Fore value for the fixed point type whose mantissa is Int{32,64,128} and + -- whose small is Num'Small. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + + begin + if not Exact then + Float_Aux.Get (File, Long_Long_Float (Item), Width); + elsif Need_128 then + Item := Num'Fixed_Value + (Aux128.Get (File, Width, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)))); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Get (File, Width, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Get (File, Width, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + pragma Unsuppress (Range_Check); + + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if not Exact then + Float_Aux.Gets (S, Long_Long_Float (Item), Last); + elsif Need_128 then + Item := Num'Fixed_Value + (Aux128.Gets (S, Last, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)))); + elsif Need_64 then + Item := Num'Fixed_Value + (Aux64.Gets (S, Last, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)))); + else + Item := Num'Fixed_Value + (Aux32.Gets (S, Last, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)))); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if not Exact then + Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + elsif Need_128 then + Aux128.Put (File, Int128'Integer_Value (Item), Fore, Aft, Exp, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + elsif Need_64 then + Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + end if; + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + if not Exact then + Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + elsif Need_128 then + Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp, + Int128 (-Float'Ceiling (Num'Small)), + Int128 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + elsif Need_64 then + Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, + Int64 (-Float'Ceiling (Num'Small)), + Int64 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + else + Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, + Int32 (-Float'Ceiling (Num'Small)), + Int32 (-Float'Ceiling (1.0 / Num'Small)), + For0, Num'Aft); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/libgnat/g-rannum.adb b/gcc/ada/libgnat/g-rannum.adb index 3895cdd0548..9c6693b79a6 100644 --- a/gcc/ada/libgnat/g-rannum.adb +++ b/gcc/ada/libgnat/g-rannum.adb @@ -100,12 +100,37 @@ is Min : Result_Subtype := Default_Min; Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype is - subtype IntV is Integer_64 range - Integer_64'Integer_Value (Min) .. - Integer_64'Integer_Value (Max); - function R is new Random_Discrete (Integer_64, IntV'First); begin - return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); + if Result_Subtype'Base'Size > 64 then + declare + subtype IntV is Integer_128 range + Integer_128'Integer_Value (Min) .. + Integer_128'Integer_Value (Max); + function R is new Random_Discrete (Integer_128, IntV'First); + begin + return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); + end; + + elsif Result_Subtype'Base'Size > 32 then + declare + subtype IntV is Integer_64 range + Integer_64'Integer_Value (Min) .. + Integer_64'Integer_Value (Max); + function R is new Random_Discrete (Integer_64, IntV'First); + begin + return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); + end; + + else + declare + subtype IntV is Integer_32 range + Integer_32'Integer_Value (Min) .. + Integer_32'Integer_Value (Max); + function R is new Random_Discrete (Integer_32, IntV'First); + begin + return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); + end; + end if; end Random_Decimal_Fixed; --------------------------- @@ -117,12 +142,37 @@ is Min : Result_Subtype := Default_Min; Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype is - subtype IntV is Integer_64 range - Integer_64'Integer_Value (Min) .. - Integer_64'Integer_Value (Max); - function R is new Random_Discrete (Integer_64, IntV'First); begin - return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); + if Result_Subtype'Base'Size > 64 then + declare + subtype IntV is Integer_128 range + Integer_128'Integer_Value (Min) .. + Integer_128'Integer_Value (Max); + function R is new Random_Discrete (Integer_128, IntV'First); + begin + return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); + end; + + elsif Result_Subtype'Base'Size > 32 then + declare + subtype IntV is Integer_64 range + Integer_64'Integer_Value (Min) .. + Integer_64'Integer_Value (Max); + function R is new Random_Discrete (Integer_64, IntV'First); + begin + return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); + end; + + else + declare + subtype IntV is Integer_32 range + Integer_32'Integer_Value (Min) .. + Integer_32'Integer_Value (Max); + function R is new Random_Discrete (Integer_32, IntV'First); + begin + return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); + end; + end if; end Random_Ordinary_Fixed; ------------ diff --git a/gcc/ada/libgnat/s-arit32.adb b/gcc/ada/libgnat/s-arit32.adb new file mode 100644 index 00000000000..742f2e123cf --- /dev/null +++ b/gcc/ada/libgnat/s-arit32.adb @@ -0,0 +1,182 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ 3 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body System.Arith_32 is + + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + + subtype Uns32 is Interfaces.Unsigned_32; + subtype Uns64 is Interfaces.Unsigned_64; + + use Interfaces; + + function To_Int is new Ada.Unchecked_Conversion (Uns32, Int32); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function "abs" (X : Int32) return Uns32 is + (if X = Int32'First + then 2**31 + else Uns32 (Int32'(abs X))); + -- Convert absolute value of X to unsigned. Note that we can't just use + -- the expression of the Else since it overflows for X = Int32'First. + + function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32))); + -- High order half of 64-bit value + + function To_Neg_Int (A : Uns32) return Int32; + -- Convert to negative integer equivalent. If the input is in the range + -- 0 .. 2**31, then the corresponding nonpositive signed integer (obtained + -- by negating the given value) is returned, otherwise constraint error is + -- raised. + + function To_Pos_Int (A : Uns32) return Int32; + -- Convert to positive integer equivalent. If the input is in the range + -- 0 .. 2**31 - 1, then the corresponding nonnegative signed integer is + -- returned, otherwise constraint error is raised. + + procedure Raise_Error; + pragma No_Return (Raise_Error); + -- Raise constraint error with appropriate message + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error is + begin + raise Constraint_Error with "32-bit arithmetic overflow"; + end Raise_Error; + + ------------------- + -- Scaled_Divide -- + ------------------- + + procedure Scaled_Divide32 + (X, Y, Z : Int32; + Q, R : out Int32; + Round : Boolean) + is + Xu : constant Uns32 := abs X; + Yu : constant Uns32 := abs Y; + Zu : constant Uns32 := abs Z; + + D : Uns64; + -- The dividend + + Qu : Uns32; + Ru : Uns32; + -- Unsigned quotient and remainder + + begin + -- First do the 64-bit multiplication + + D := Uns64 (Xu) * Uns64 (Yu); + + -- If dividend is too large, raise error + + if Hi (D) >= Zu then + Raise_Error; + + -- Then do the 64-bit division + + else + Qu := Uns32 (D / Uns64 (Zu)); + Ru := Uns32 (D rem Uns64 (Zu)); + end if; + + -- Deal with rounding case + + if Round and then Ru > (Zu - Uns32'(1)) / Uns32'(2) then + + -- Protect against wrapping around when rounding, by signaling + -- an overflow when the quotient is too large. + + if Qu = Uns32'Last then + Raise_Error; + end if; + + Qu := Qu + Uns32'(1); + end if; + + -- Set final signs (RM 4.5.5(27-30)) + + -- Case of dividend (X * Y) sign positive + + if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then + R := To_Pos_Int (Ru); + Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); + + -- Case of dividend (X * Y) sign negative + + else + R := To_Neg_Int (Ru); + Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); + end if; + end Scaled_Divide32; + + ---------------- + -- To_Neg_Int -- + ---------------- + + function To_Neg_Int (A : Uns32) return Int32 is + R : constant Int32 := + (if A = 2**31 then Int32'First else -To_Int (A)); + -- Note that we can't just use the expression of the Else, because it + -- overflows for A = 2**31. + begin + if R <= 0 then + return R; + else + Raise_Error; + end if; + end To_Neg_Int; + + ---------------- + -- To_Pos_Int -- + ---------------- + + function To_Pos_Int (A : Uns32) return Int32 is + R : constant Int32 := To_Int (A); + begin + if R >= 0 then + return R; + else + Raise_Error; + end if; + end To_Pos_Int; + +end System.Arith_32; diff --git a/gcc/ada/libgnat/s-arit32.ads b/gcc/ada/libgnat/s-arit32.ads new file mode 100644 index 00000000000..565685561ab --- /dev/null +++ b/gcc/ada/libgnat/s-arit32.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit provides software routines for doing arithmetic on 32-bit +-- signed integer values in cases where either overflow checking is +-- required, or intermediate results are longer than 32 bits. + +with Interfaces; + +package System.Arith_32 is + pragma Pure; + + subtype Int32 is Interfaces.Integer_32; + + procedure Scaled_Divide32 + (X, Y, Z : Int32; + Q, R : out Int32; + Round : Boolean); + -- Performs the division of (X * Y) / Z, storing the quotient in Q + -- and the remainder in R. Constraint_Error is raised if Z is zero, + -- or if the quotient does not fit in 32 bits. Round indicates if + -- the result should be rounded. If Round is False, then Q, R are + -- the normal quotient and remainder from a truncating division. + -- If Round is True, then Q is the rounded quotient. The remainder + -- R is not affected by the setting of the Round flag. + +end System.Arith_32; diff --git a/gcc/ada/libgnat/s-fode128.ads b/gcc/ada/libgnat/s-fode128.ads new file mode 100644 index 00000000000..200a020640b --- /dev/null +++ b/gcc/ada/libgnat/s-fode128.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E _ D E C I M A L _ 1 2 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for the 'Fore attribute for decimal +-- fixed point types up to 128-bit mantissa. + +with Interfaces; +with System.Fore_D; + +package System.Fore_Decimal_128 is + pragma Pure; + + subtype Int128 is Interfaces.Integer_128; + + package Impl is new Fore_D (Int128); + + function Fore_Decimal128 (Lo, Hi : Int128; Scale : Integer) return Natural + renames Impl.Fore_Decimal; + +end System.Fore_Decimal_128; diff --git a/gcc/ada/libgnat/s-fode32.ads b/gcc/ada/libgnat/s-fode32.ads new file mode 100644 index 00000000000..15c07a41e38 --- /dev/null +++ b/gcc/ada/libgnat/s-fode32.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E _ D E C I M A L _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for the 'Fore attribute for decimal +-- fixed point types up to 32-bit mantissa. + +with Interfaces; +with System.Fore_D; + +package System.Fore_Decimal_32 is + pragma Pure; + + subtype Int32 is Interfaces.Integer_32; + + package Impl is new Fore_D (Int32); + + function Fore_Decimal32 (Lo, Hi : Int32; Scale : Integer) return Natural + renames Impl.Fore_Decimal; + +end System.Fore_Decimal_32; diff --git a/gcc/ada/libgnat/s-fode64.ads b/gcc/ada/libgnat/s-fode64.ads new file mode 100644 index 00000000000..7e98185d1ba --- /dev/null +++ b/gcc/ada/libgnat/s-fode64.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E _ D E C I M A L _ 6 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for the 'Fore attribute for decimal +-- fixed point types up to 64-bit mantissa. + +with Interfaces; +with System.Fore_D; + +package System.Fore_Decimal_64 is + pragma Pure; + + subtype Int64 is Interfaces.Integer_64; + + package Impl is new Fore_D (Int64); + + function Fore_Decimal64 (Lo, Hi : Int64; Scale : Integer) return Natural + renames Impl.Fore_Decimal; + +end System.Fore_Decimal_64; diff --git a/gcc/ada/libgnat/s-fofi128.ads b/gcc/ada/libgnat/s-fofi128.ads new file mode 100644 index 00000000000..d580ec82a2a --- /dev/null +++ b/gcc/ada/libgnat/s-fofi128.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O F I _ 1 2 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for the 'Fore attribute for ordinary +-- fixed point types up to 128-bit small and mantissa. + +with Interfaces; +with System.Arith_128; +with System.Fore_F; + +package System.Fore_Fixed_128 is + pragma Pure; + + subtype Int128 is Interfaces.Integer_128; + + package Impl is new Fore_F (Int128, Arith_128.Scaled_Divide128); + + function Fore_Fixed128 (Lo, Hi, Num, Den : Int128) return Natural + renames Impl.Fore_Fixed; + +end System.Fore_Fixed_128; diff --git a/gcc/ada/libgnat/s-fofi32.ads b/gcc/ada/libgnat/s-fofi32.ads new file mode 100644 index 00000000000..5e48f555dea --- /dev/null +++ b/gcc/ada/libgnat/s-fofi32.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E _ F I X E D _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for the 'Fore attribute for ordinary +-- fixed point types up to 32-bit small and mantissa. + +with Interfaces; +with System.Arith_32; +with System.Fore_F; + +package System.Fore_Fixed_32 is + pragma Pure; + + subtype Int32 is Interfaces.Integer_32; + + package Impl is new Fore_F (Int32, Arith_32.Scaled_Divide32); + + function Fore_Fixed32 (Lo, Hi, Num, Den : Int32) return Natural + renames Impl.Fore_Fixed; + +end System.Fore_Fixed_32; diff --git a/gcc/ada/libgnat/s-fofi64.ads b/gcc/ada/libgnat/s-fofi64.ads new file mode 100644 index 00000000000..588fac48428 --- /dev/null +++ b/gcc/ada/libgnat/s-fofi64.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E _ F I X E D _ 6 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for the 'Fore attribute for ordinary +-- fixed point types up to 64-bit small and mantissa. + +with Interfaces; +with System.Arith_64; +with System.Fore_F; + +package System.Fore_Fixed_64 is + pragma Pure; + + subtype Int64 is Interfaces.Integer_64; + + package Impl is new Fore_F (Int64, Arith_64.Scaled_Divide64); + + function Fore_Fixed64 (Lo, Hi, Num, Den : Int64) return Natural + renames Impl.Fore_Fixed; + +end System.Fore_Fixed_64; diff --git a/gcc/ada/libgnat/s-fore_d.adb b/gcc/ada/libgnat/s-fore_d.adb new file mode 100644 index 00000000000..1141c67fcd3 --- /dev/null +++ b/gcc/ada/libgnat/s-fore_d.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E _ D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Fore_D is + + ------------------ + -- Fore_Decimal -- + ------------------ + + function Fore_Decimal (Lo, Hi : Int; Scale : Integer) return Natural is + + function Negative_Abs (Val : Int) return Int is + (if Val <= 0 then Val else -Val); + -- Return the opposite of the absolute value of Val + + T : Int := Int'Min (Negative_Abs (Lo), Negative_Abs (Hi)); + F : Natural; + + begin + -- Initial value of 2 allows for sign and mandatory single digit + + F := 2; + + -- Loop to increase Fore as needed to include full range of values + + while T <= -10 loop + T := T / 10; + F := F + 1; + end loop; + + return Natural'Max (F - Scale, 2); + end Fore_Decimal; + +end System.Fore_D; diff --git a/gcc/ada/libgnat/s-fore_d.ads b/gcc/ada/libgnat/s-fore_d.ads new file mode 100644 index 00000000000..25e3449ecc1 --- /dev/null +++ b/gcc/ada/libgnat/s-fore_d.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E _ D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for the Fore attribute of decimal +-- fixed point types. + +generic + + type Int is range <>; + +package System.Fore_D is + pragma Pure; + + function Fore_Decimal (Lo, Hi : Int; Scale : Integer) return Natural; + -- Compute Fore attribute value for a decimal fixed point type. The + -- parameters are the low and high bounds (in units of delta) and the + -- scale. + +end System.Fore_D; diff --git a/gcc/ada/libgnat/s-fore_f.adb b/gcc/ada/libgnat/s-fore_f.adb new file mode 100644 index 00000000000..b63d8d4b5b0 --- /dev/null +++ b/gcc/ada/libgnat/s-fore_f.adb @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E _ F -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Fore_F is + + Maxdigs : constant Natural := Int'Width - 2; + -- Maximum number of decimal digits that can be represented in an Int. + -- The "-2" accounts for the sign and one extra digit, since we need the + -- maximum number of 9's that can be represented, e.g. for the 64-bit case, + -- Integer_64'Width is 20 since the maximum value is approximately 9.2E+18 + -- and has 19 digits, but the maximum number of 9's that can be represented + -- in Integer_64 is only 18. + + -- The prerequisite of the implementation is that the scaled divide does + -- not overflow, which means that the absolute value of the bounds of + -- the subtype must be smaller than 10**Maxdigs * 2**(Int'Size - 1). + -- Otherwise Constraint_Error is raised by the scaled divide operation. + + ---------------- + -- Fore_Fixed -- + ---------------- + + function Fore_Fixed (Lo, Hi, Num, Den : Int) return Natural is + pragma Assert (Num < 0 and then Den < 0); + -- Accept only negative numbers to allow -2**(Int'Size - 1) + + function Negative_Abs (Val : Int) return Int is + (if Val <= 0 then Val else -Val); + -- Return the opposite of the absolute value of Val + + T : Int := Int'Min (Negative_Abs (Lo), Negative_Abs (Hi)); + F : Natural; + + begin + -- Initial value of 2 allows for sign and mandatory single digit + + F := 2; + + -- If the Small is 1, then no scaling is needed + + if Num = -1 and then Den = -1 then + null; + + -- The easy case is when the Small is the reciprocal of an integer + + elsif Num = -1 then + T := T / Den; + + -- If the Small is an integer, compute Q and R such that + + -- T * Small = Q * 10**Maxdigs - R + + -- then reason on Q if it is non-zero or else on R. + + else pragma Assert (Den = -1); + declare + Q, R : Int; + + begin + Scaled_Divide (T, Num, -10**Maxdigs, Q, R, Round => False); + + if Q /= 0 then + T := Q; + F := F + Maxdigs; + else + T := R; + end if; + end; + end if; + + -- Loop to increase Fore as needed to include full range of values + + while T <= -10 or else T >= 10 loop + T := T / 10; + F := F + 1; + end loop; + + return F; + end Fore_Fixed; + +end System.Fore_F; diff --git a/gcc/ada/libgnat/s-fore_f.ads b/gcc/ada/libgnat/s-fore_f.ads new file mode 100644 index 00000000000..15fcb72fddb --- /dev/null +++ b/gcc/ada/libgnat/s-fore_f.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E _ F -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for the Fore attribute of ordinary +-- fixed point types whose Small is an integer or its reciprocal. + +generic + + type Int is range <>; + + with procedure Scaled_Divide + (X, Y, Z : Int; + Q, R : out Int; + Round : Boolean); + +package System.Fore_F is + pragma Pure; + + function Fore_Fixed (Lo, Hi, Num, Den : Int) return Natural; + -- Compute Fore attribute value for an ordinary fixed point type with small + -- Num/Den. The parameters are the low and high bounds (in units of small). + +end System.Fore_F; diff --git a/gcc/ada/libgnat/s-fore.adb b/gcc/ada/libgnat/s-forrea.adb index 2a4aa81b69d..cb74dc60c59 100644 --- a/gcc/ada/libgnat/s-fore.adb +++ b/gcc/ada/libgnat/s-forrea.adb @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- S Y S T E M . F O R E -- +-- S Y S T E M . F O R E _ R E A L -- -- -- -- B o d y -- -- -- @@ -29,28 +29,29 @@ -- -- ------------------------------------------------------------------------------ -package body System.Fore is +package body System.Fore_Real is - ---------- - -- Fore -- - ---------- + --------------- + -- Fore_Real -- + --------------- - function Fore (Lo, Hi : Long_Long_Float) return Natural is + function Fore_Real (Lo, Hi : Long_Long_Float) return Natural is T : Long_Long_Float := Long_Long_Float'Max (abs Lo, abs Hi); - R : Natural; + F : Natural; begin -- Initial value of 2 allows for sign and mandatory single digit - R := 2; + F := 2; -- Loop to increase Fore as needed to include full range of values while T >= 10.0 loop T := T / 10.0; - R := R + 1; + F := F + 1; end loop; - return R; - end Fore; -end System.Fore; + return F; + end Fore_Real; + +end System.Fore_Real; diff --git a/gcc/ada/libgnat/s-fore.ads b/gcc/ada/libgnat/s-forrea.ads index 7d78952e0df..6b0a211c091 100644 --- a/gcc/ada/libgnat/s-fore.ads +++ b/gcc/ada/libgnat/s-forrea.ads @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- S Y S T E M . F O R E -- +-- S Y S T E M . F O R E _ R E A L -- -- -- -- S p e c -- -- -- @@ -29,13 +29,14 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routine used for the 'Fore attribute +-- This package contains the routine used for the Fore attribute of ordinary +-- fixed point types whose Small is neither an integer nor its reciprocal. -package System.Fore is +package System.Fore_Real is pragma Pure; - function Fore (Lo, Hi : Long_Long_Float) return Natural; - -- Compute Fore attribute value for a fixed-point type. The parameters - -- are the low and high bounds values, converted to Long_Long_Float. + function Fore_Real (Lo, Hi : Long_Long_Float) return Natural; + -- Compute Fore attribute value for a fixed point type. The parameters + -- are the low and high bounds, converted to Long_Long_Float. -end System.Fore; +end System.Fore_Real; diff --git a/gcc/ada/libgnat/s-imglld.adb b/gcc/ada/libgnat/s-imaged.adb index c70f409eed7..726b9d80561 100644 --- a/gcc/ada/libgnat/s-imglld.adb +++ b/gcc/ada/libgnat/s-imaged.adb @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- S Y S T E M . I M G _ L L D -- +-- S Y S T E M . I M A G E _ D -- -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,16 +29,16 @@ -- -- ------------------------------------------------------------------------------ -with System.Img_Dec; use System.Img_Dec; +with System.Img_Util; use System.Img_Util; -package body System.Img_LLD is +package body System.Image_D is - ----------------------------- - -- Image_Long_Long_Decimal -- - ---------------------------- + ------------------- + -- Image_Decimal -- + ------------------- - procedure Image_Long_Long_Decimal - (V : Long_Long_Integer; + procedure Image_Decimal + (V : Int; S : in out String; P : out Natural; Scale : Integer) @@ -55,16 +55,15 @@ package body System.Img_LLD is P := 0; end if; - Set_Image_Long_Long_Decimal - (V, S, P, Scale, 1, Integer'Max (1, Scale), 0); - end Image_Long_Long_Decimal; + Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0); + end Image_Decimal; - --------------------------------- - -- Set_Image_Long_Long_Decimal -- - --------------------------------- + ----------------------- + -- Set_Image_Decimal -- + ----------------------- - procedure Set_Image_Long_Long_Decimal - (V : Long_Long_Integer; + procedure Set_Image_Decimal + (V : Int; S : in out String; P : in out Natural; Scale : Integer; @@ -72,11 +71,11 @@ package body System.Img_LLD is Aft : Natural; Exp : Natural) is - Digs : String := Long_Long_Integer'Image (V); + Digs : String := Int'Image (V); -- Sign and digits of decimal value begin Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp); - end Set_Image_Long_Long_Decimal; + end Set_Image_Decimal; -end System.Img_LLD; +end System.Image_D; diff --git a/gcc/ada/libgnat/s-imglld.ads b/gcc/ada/libgnat/s-imaged.ads index fdb25b4648b..5c3f82a8594 100644 --- a/gcc/ada/libgnat/s-imglld.ads +++ b/gcc/ada/libgnat/s-imaged.ads @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- S Y S T E M . I M G _ L L D -- +-- S Y S T E M . I M A G E _ D -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,26 +29,31 @@ -- -- ------------------------------------------------------------------------------ --- Image for decimal fixed types where the size of the corresponding integer --- type does exceeds Integer'Size (also used for Text_IO.Decimal_IO output) +-- This package contains the routines for supporting the Image attribute for +-- decimal fixed point types, and also for conversion operations required in +-- Text_IO.Decimal_IO for such types. -package System.Img_LLD is +generic + + type Int is range <>; + +package System.Image_D is pragma Pure; - procedure Image_Long_Long_Decimal - (V : Long_Long_Integer; + procedure Image_Decimal + (V : Int; S : in out String; P : out Natural; Scale : Integer); -- Computes fixed_type'Image (V), where V is the integer value (in units of - -- delta) of a decimal type whose Scale is as given and store the result in - -- S (P + 1 .. L), updating P to the value of L. The image is given by the + -- delta) of a decimal type whose Scale is as given and stores the result + -- S (1 .. P), updating P to the value of L. The image is given by the -- rules in RM 3.5(34) for fixed-point type image functions. The caller - -- guarantees that S is long enough to hold the result. S need not have a - -- lower bound of 1. + -- guarantees that S is long enough to hold the result and has a lower + -- bound of 1. - procedure Set_Image_Long_Long_Decimal - (V : Long_Long_Integer; + procedure Set_Image_Decimal + (V : Int; S : in out String; P : in out Natural; Scale : Integer; @@ -56,12 +61,12 @@ package System.Img_LLD is Aft : Natural; Exp : Natural); -- Sets the image of V, where V is the integer value (in units of delta) - -- of a decimal type with the given Scale, starting at S (P + 1), updating - -- P to point to the last character stored, the caller promises that the - -- buffer is large enough and no check is made for this. Constraint_Error + -- of a decimal type with the specified Scale, starting at S (P + 1) and + -- updating P to point to the last character stored, the caller promises + -- that the buffer is large enough and no check is made. Constraint_Error -- will not necessarily be raised if this requirement is violated, since -- it is perfectly valid to compile this unit with checks off. The Fore, -- Aft and Exp values can be set to any valid values for the case of use - -- by Text_IO.Decimal_IO. Note that there is no leading space stored. + -- by Text_IO.Decimal_IO. -end System.Img_LLD; +end System.Image_D; diff --git a/gcc/ada/libgnat/s-imagef.adb b/gcc/ada/libgnat/s-imagef.adb new file mode 100644 index 00000000000..2328474149f --- /dev/null +++ b/gcc/ada/libgnat/s-imagef.adb @@ -0,0 +1,287 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ F -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Image_I; +with System.Img_Util; use System.Img_Util; + +package body System.Image_F is + + package Image_I is new System.Image_I (Int); + + procedure Set_Image_Integer + (V : Int; + S : in out String; + P : in out Natural) + renames Image_I.Set_Image_Integer; + + -- The following section describes a specific implementation choice for + -- performing base conversions needed for output of values of a fixed + -- point type T with small T'Small. The goal is to be able to output + -- all values of fixed point types with a precision of 64 bits and a + -- small in the range 2.0**(-63) .. 2.0**63. The reasoning can easily + -- be adapted to fixed point types with a precision of 32 or 128 bits. + + -- The chosen algorithm uses fixed precision integer arithmetic for + -- reasons of simplicity and efficiency. It is important to understand + -- in what ways the most simple and accurate approach to fixed point I/O + -- is limiting, before considering more complicated schemes. + + -- Without loss of generality assume T has a range (-2.0**63) * T'Small + -- .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the + -- decimal point and T'Fore - 1 before. If T'Small is integer, or + -- 1.0 / T'Small is integer, let S = T'Small. + + -- The idea is to convert a value X * S of type T to a 64-bit integer value + -- Q equal to 10.0**D * (X * S) rounded to the nearest integer, using only + -- a scaled integer divide of the form + + -- Q = (X * Y) / Z, + + -- where the variables X, Y, Z are 64-bit integers, and both multiplication + -- and division are done using full intermediate precision. Then the final + -- decimal value to be output is + + -- Q * 10**(-D) + + -- This value can be written to the output file or to the result string + -- according to the format described in RM A.3.10. The details of this + -- operation are omitted here. + + -- A 64-bit value can represent all integers with 18 decimal digits, but + -- not all with 19 decimal digits. If the total number of requested ouput + -- digits (Fore - 1) + Aft is greater than 18 then, for purposes of the + -- conversion, Aft is adjusted to 18 - (Fore - 1). In that case, trailing + -- zeros can complete the output after writing the first 18 significant + -- digits, or the technique described in the next section can be used. + -- In addition, D cannot be smaller than -18, in order for 10.0**(-D) to + -- fit in a 64-bit integer. + + -- The final expression for D is + + -- D = Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1))); + + -- For Y and Z the following expressions can be derived: + + -- Q = X * S * (10.0**D) = (X * Y) / Z + + -- If S is an integer greater than or equal to one, then Fore must be at + -- least 20 in order to print T'First, which is at most -2.0**63. This + -- means that D < 0, so use + + -- (1) Y = -S and Z = -10**(-D) + + -- If 1.0 / S is an integer greater than one, use + + -- (2) Y = -10**D and Z = -(1.0 / S), for D >= 0 + + -- or + + -- (3) Y = -1 and Z = -(1.0 / S) * 10**(-D), for D < 0 + + -- Negative values are used for nominator Y and denominator Z, so that S + -- can have a maximum value of 2.0**63 and a minimum of 2.0**(-63). For + -- -(1.0 / S) in -1 .. -9, Fore will still be 20, and D will be negative, + -- as (-2.0**63) / -9 is greater than 10**18. In these cases there is room + -- in the denominator for the extra decimal scaling required, so case (3) + -- will not overflow. + + -- Using a scaled divide which truncates and returns a remainder R, + -- another K trailing digits can be calculated by computing the value + -- (R * (10.0**K)) / Z using another scaled divide. This procedure + -- can be repeated to compute an arbitrary number of digits in linear + -- time and storage. The last scaled divide should be rounded, with + -- a possible carry propagating to the more significant digits, to + -- ensure correct rounding of the unit in the last place. + + Maxdigs : constant Natural := Int'Width - 2; + -- Maximum number of decimal digits that can be represented in an Int. + -- The "-2" accounts for the sign and one extra digit, since we need the + -- maximum number of 9's that can be represented, e.g. for the 64-bit case, + -- Integer_64'Width is 20 since the maximum value is approximately 9.2E+18 + -- and has 19 digits, but the maximum number of 9's that can be represented + -- in Integer_64 is only 18. + + -- The prerequisite of the implementation is that the first scaled divide + -- does not overflow, which means that the absolute value of the input X + -- must always be smaller than 10**Maxdigs * 2**(Int'Size - 1). Otherwise + -- Constraint_Error is raised by the scaled divide operation. + + ----------------- + -- Image_Fixed -- + ----------------- + + procedure Image_Fixed + (V : Int; + S : in out String; + P : out Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural) + is + pragma Assert (S'First = 1); + + begin + -- Add space at start for non-negative numbers + + if V >= 0 then + S (1) := ' '; + P := 1; + else + P := 0; + end if; + + Set_Image_Fixed (V, S, P, Num, Den, For0, Aft0, 1, Aft0, 0); + end Image_Fixed; + + --------------------- + -- Set_Image_Fixed -- + --------------------- + + procedure Set_Image_Fixed + (V : Int; + S : in out String; + P : in out Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural) + is + pragma Assert (Num < 0 and then Den < 0); + -- Accept only negative numbers to allow -2**(Int'Size - 1) + + pragma Assert (Num = -1 or else Den = -1); + -- Accept only integer or reciprocal of integer to control the + -- magnitude of the arithmetic operations below. + + A : constant Natural := + Boolean'Pos (Exp > 0) * Aft0 + Natural'Max (Aft, 1) + 1; + -- Number of digits after the decimal point to be computed. If Exp is + -- positive, we need to compute Aft decimal digits after the first non + -- zero digit and we are guaranteed there is at least one in the first + -- Aft0 digits (unless V is zero). In both cases, we compute one more + -- digit than requested so that Set_Decimal_Digits can round at Aft. + + D : constant Integer := + Integer'Max (-Maxdigs, Integer'Min (A, Maxdigs - (For0 - 1))); + Y : constant Int := Num * 10**Integer'Max (0, D); + Z : constant Int := Den * 10**Integer'Max (0, -D); + -- See the description of the algorithm above + + AF : constant Natural := A - D; + -- Number of remaining digits to be computed after the first round. It + -- is larger than A if the first round does not compute all the digits + -- before the decimal point, i.e. (For0 - 1) larger than Maxdigs. + + N : constant Natural := 1 + (AF + Maxdigs - 1) / Maxdigs; + -- Number of rounds of scaled divide to be performed + + Q : Int; + -- Quotient of the scaled divide in this round. Only the first round + -- may yield more than Maxdigs digits. The sign is not significant. + + Buf : String (1 .. Maxdigs); + Len : Natural; + -- Buffer for the image of the quotient + + Digs : String (1 .. N * Maxdigs + 1); + Ndigs : Natural := 0; + -- Concatenated image of the successive quotients + + Scale : Integer := 0; + -- Exponent such that the result is Digs (1 .. NDigs) * 10**(-Scale) + + XX : Int := V; + YY : Int := Y; + -- First two operands of the scaled divide + + begin + -- Set the first character like Image, either minus or space + + Digs (1) := (if V < 0 then '-' else ' '); + Ndigs := 1; + + for J in 1 .. N loop + exit when XX = 0; + + Scaled_Divide (XX, YY, Z, Q, R => XX, Round => False); + + if J = 1 then + if Q /= 0 then + Set_Image_Integer (abs Q, Digs, Ndigs); + end if; + + Scale := Scale + D; + + -- Prepare for next round, if any + + YY := 10**Maxdigs; + + else + Len := 0; + Set_Image_Integer (abs Q, Buf, Len); + + if Ndigs = 1 then + Digs (2 .. Len + 1) := Buf (1 .. Len); + Ndigs := Len + 1; + + else + -- Pad the output with zeroes up to Maxdigs + + for K in 1 .. Maxdigs - Len loop + Digs (Ndigs + K) := '0'; + end loop; + + for K in 1 .. Len loop + Digs (Ndigs + Maxdigs - Len + K) := Buf (K); + end loop; + + Ndigs := Ndigs + Maxdigs; + end if; + + Scale := Scale + Maxdigs; + end if; + end loop; + + -- If no digit was output, this is zero + + if Ndigs = 1 then + Digs (1 .. 2) := " 0"; + Ndigs := 2; + end if; + + Set_Decimal_Digits (Digs, Ndigs, S, P, Scale, Fore, Aft, Exp); + end Set_Image_Fixed; + +end System.Image_F; diff --git a/gcc/ada/libgnat/s-imgdec.ads b/gcc/ada/libgnat/s-imagef.ads index d45a05fa43c..bd1fb15814b 100644 --- a/gcc/ada/libgnat/s-imgdec.ads +++ b/gcc/ada/libgnat/s-imagef.ads @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- S Y S T E M . I M G _ D E C -- +-- S Y S T E M . I M A G E _ F -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,55 +29,61 @@ -- -- ------------------------------------------------------------------------------ --- Image for decimal fixed types where the size of the corresponding integer --- type does not exceed Integer'Size (also used for Text_IO.Decimal_IO output) +-- This package contains the routines for supporting the Image attribute for +-- ordinary fixed point types whose Small is an integer or its reciprocal, +-- and also for conversion operations required in Text_IO.Fixed_IO for such +-- types. -package System.Img_Dec is +generic + + type Int is range <>; + + with procedure Scaled_Divide + (X, Y, Z : Int; + Q, R : out Int; + Round : Boolean); + +package System.Image_F is pragma Pure; - procedure Image_Decimal - (V : Integer; - S : in out String; - P : out Natural; - Scale : Integer); + procedure Image_Fixed + (V : Int; + S : in out String; + P : out Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural); -- Computes fixed_type'Image (V), where V is the integer value (in units of - -- delta) of a decimal type whose Scale is as given and stores the result - -- S (1 .. P), updating P to the value of L. The image is given by the - -- rules in RM 3.5(34) for fixed-point type image functions. The caller - -- guarantees that S is long enough to hold the result. S need not have a - -- lower bound of 1. + -- small) of an ordinary fixed point type with small Num/Den, and stores + -- the result in S (1 .. P), updating P on return. The result is computed + -- according to the rules for image for fixed-point types (RM 3.5(34)). + -- For0 and Aft0 are the values of the Fore and Aft attributes for the + -- fixed point type whose mantissa type is Int and whose small is Num/Den. + -- This function is used only for fixed point whose Small is an integer or + -- its reciprocal (see package System.Img_Real for the handling of other + -- ordinary fixed-point types). The caller guarantees that S is long enough + -- to hold the result and has a lower bound of 1. - procedure Set_Image_Decimal - (V : Integer; - S : in out String; - P : in out Natural; - Scale : Integer; - Fore : Natural; - Aft : Natural; - Exp : Natural); - -- Sets the image of V, where V is the integer value (in units of delta) - -- of a decimal type with the given Scale, starting at S (P + 1), updating - -- P to point to the last character stored, the caller promises that the - -- buffer is large enough and no check is made for this. Constraint_Error + procedure Set_Image_Fixed + (V : Int; + S : in out String; + P : in out Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural); + -- Sets the image of V, where V is the integer value (in units of small) + -- of a fixed point type with small Num/Den, starting at S (P + 1) and + -- updating P to point to the last character stored, the caller promises + -- that the buffer is large enough and no check is made. Constraint_Error -- will not necessarily be raised if this requirement is violated, since - -- it is perfectly valid to compile this unit with checks off. The Fore, - -- Aft and Exp values can be set to any valid values for the case of use - -- by Text_IO.Decimal_IO. Note that there is no leading space stored. - - procedure Set_Decimal_Digits - (Digs : in out String; - NDigs : Natural; - S : out String; - P : in out Natural; - Scale : Integer; - Fore : Natural; - Aft : Natural; - Exp : Natural); - -- This procedure has the same semantics as Set_Image_Decimal, except that - -- the value in Digs (1 .. NDigs) is given as a string of decimal digits - -- preceded by either a minus sign or a space (i.e. the integer image of - -- the value in units of delta). The call may destroy the value in Digs, - -- which is why Digs is in-out (this happens if rounding is required). - -- Set_Decimal_Digits is shared by all the decimal image routines. + -- it is perfectly valid to compile this unit with checks off. For0 and + -- Aft0 are the values of the Fore and Aft attributes for the fixed point + -- type whose mantissa type is Int and whose small is Num/Den. The Fore, + -- Aft and Exp can be set to any valid values for use by Text_IO.Fixed_IO. -end System.Img_Dec; +end System.Image_F; diff --git a/gcc/ada/libgnat/s-imde128.ads b/gcc/ada/libgnat/s-imde128.ads new file mode 100644 index 00000000000..cffd0c04c32 --- /dev/null +++ b/gcc/ada/libgnat/s-imde128.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ D E C I M A L _ 1 2 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- decimal fixed point types up to 128-bit mantissa, and also for conversion +-- operations required in Text_IO.Decimal_IO for them. + +with Interfaces; +with System.Image_D; + +package System.Img_Decimal_128 is + pragma Pure; + + subtype Int128 is Interfaces.Integer_128; + + package Impl is new Image_D (Int128); + + procedure Image_Decimal128 + (V : Int128; + S : in out String; + P : out Natural; + Scale : Integer) + renames Impl.Image_Decimal; + + procedure Set_Image_Decimal128 + (V : Int128; + S : in out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural) + renames Impl.Set_Image_Decimal; + +end System.Img_Decimal_128; diff --git a/gcc/ada/libgnat/s-imde32.ads b/gcc/ada/libgnat/s-imde32.ads new file mode 100644 index 00000000000..bf19e9cbbcd --- /dev/null +++ b/gcc/ada/libgnat/s-imde32.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ D E C I M A L _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- decimal fixed point types up to 32-bit mantissa, and also for conversion +-- operations required in Text_IO.Decimal_IO for such types. + +with Interfaces; +with System.Image_D; + +package System.Img_Decimal_32 is + pragma Pure; + + subtype Int32 is Interfaces.Integer_32; + + package Impl is new Image_D (Int32); + + procedure Image_Decimal32 + (V : Int32; + S : in out String; + P : out Natural; + Scale : Integer) + renames Impl.Image_Decimal; + + procedure Set_Image_Decimal32 + (V : Int32; + S : in out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural) + renames Impl.Set_Image_Decimal; + +end System.Img_Decimal_32; diff --git a/gcc/ada/libgnat/s-imde64.ads b/gcc/ada/libgnat/s-imde64.ads new file mode 100644 index 00000000000..dfc8403ff01 --- /dev/null +++ b/gcc/ada/libgnat/s-imde64.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ D E C I M A L _ 6 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- decimal fixed point types up to 64-bit mantissa, and also for conversion +-- operations required in Text_IO.Decimal_IO for such types. + +with Interfaces; +with System.Image_D; + +package System.Img_Decimal_64 is + pragma Pure; + + subtype Int64 is Interfaces.Integer_64; + + package Impl is new Image_D (Int64); + + procedure Image_Decimal64 + (V : Int64; + S : in out String; + P : out Natural; + Scale : Integer) + renames Impl.Image_Decimal; + + procedure Set_Image_Decimal64 + (V : Int64; + S : in out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural) + renames Impl.Set_Image_Decimal; + +end System.Img_Decimal_64; diff --git a/gcc/ada/libgnat/s-imfi128.ads b/gcc/ada/libgnat/s-imfi128.ads new file mode 100644 index 00000000000..24fdf974c7e --- /dev/null +++ b/gcc/ada/libgnat/s-imfi128.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ F I X E D _ 1 2 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- ordinary fixed point types up to 128-bit small and mantissa. + +with Interfaces; +with System.Arith_128; +with System.Image_F; + +package System.Img_Fixed_128 is + pragma Pure; + + subtype Int128 is Interfaces.Integer_128; + + package Impl is new Image_F (Int128, Arith_128.Scaled_Divide128); + + procedure Image_Fixed128 + (V : Int128; + S : in out String; + P : out Natural; + Num : Int128; + Den : Int128; + For0 : Natural; + Aft0 : Natural) + renames Impl.Image_Fixed; + + procedure Set_Image_Fixed128 + (V : Int128; + S : in out String; + P : in out Natural; + Num : Int128; + Den : Int128; + For0 : Natural; + Aft0 : Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural) + renames Impl.Set_Image_Fixed; + +end System.Img_Fixed_128; diff --git a/gcc/ada/libgnat/s-imfi32.ads b/gcc/ada/libgnat/s-imfi32.ads new file mode 100644 index 00000000000..8c425dfa33f --- /dev/null +++ b/gcc/ada/libgnat/s-imfi32.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ F I X E D _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- ordinary fixed point types up to 32-bit small and mantissa. + +with Interfaces; +with System.Arith_32; +with System.Image_F; + +package System.Img_Fixed_32 is + pragma Pure; + + subtype Int32 is Interfaces.Integer_32; + + package Impl is new Image_F (Int32, Arith_32.Scaled_Divide32); + + procedure Image_Fixed32 + (V : Int32; + S : in out String; + P : out Natural; + Num : Int32; + Den : Int32; + For0 : Natural; + Aft0 : Natural) + renames Impl.Image_Fixed; + + procedure Set_Image_Fixed32 + (V : Int32; + S : in out String; + P : in out Natural; + Num : Int32; + Den : Int32; + For0 : Natural; + Aft0 : Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural) + renames Impl.Set_Image_Fixed; + +end System.Img_Fixed_32; diff --git a/gcc/ada/libgnat/s-imfi64.ads b/gcc/ada/libgnat/s-imfi64.ads new file mode 100644 index 00000000000..9045bf6d9b8 --- /dev/null +++ b/gcc/ada/libgnat/s-imfi64.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ F I X E D _ 6 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- ordinary fixed point types up to 64-bit small and mantissa. + +with Interfaces; +with System.Arith_64; +with System.Image_F; + +package System.Img_Fixed_64 is + pragma Pure; + + subtype Int64 is Interfaces.Integer_64; + + package Impl is new Image_F (Int64, Arith_64.Scaled_Divide64); + + procedure Image_Fixed64 + (V : Int64; + S : in out String; + P : out Natural; + Num : Int64; + Den : Int64; + For0 : Natural; + Aft0 : Natural) + renames Impl.Image_Fixed; + + procedure Set_Image_Fixed64 + (V : Int64; + S : in out String; + P : in out Natural; + Num : Int64; + Den : Int64; + For0 : Natural; + Aft0 : Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural) + renames Impl.Set_Image_Fixed; + +end System.Img_Fixed_64; diff --git a/gcc/ada/libgnat/s-imgrea.adb b/gcc/ada/libgnat/s-imgrea.adb index 45d0ae59b7b..03d30bdf9d7 100644 --- a/gcc/ada/libgnat/s-imgrea.adb +++ b/gcc/ada/libgnat/s-imgrea.adb @@ -47,10 +47,10 @@ package body System.Img_Real is -- in very high precision floating-point output. -- Note that in the following, the "-2" accounts for the sign and one - -- extra digits, since we need the maximum number of 9's that can be - -- supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width - -- is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits, - -- but the maximum number of 9's that can be supported is 19. + -- extra digit, since we need the maximum number of 9's that can be + -- represented, e.g. for the 64-bit case, Long_Long_Unsigned'Width is + -- 21, since the maximum value (approx 1.8E+19) has 20 digits, but the + -- maximum number of 9's that can be represented is only 19. Maxdigs : constant := Natural'Min @@ -58,7 +58,6 @@ package body System.Img_Real is Unsdigs : constant := Unsigned'Width - 2; -- Number of digits that can be converted using type Unsigned - -- See above for the explanation of the -2. Maxscaling : constant := 5000; -- Max decimal scaling required during conversion of floating-point @@ -88,11 +87,8 @@ package body System.Img_Real is -- Decide whether a blank should be prepended before the call to -- Set_Image_Real. We generate a blank for positive values, and -- also for positive zeroes. For negative zeroes, we generate a - -- space only if Signed_Zeroes is True (the RM only permits the - -- output of -0.0 on targets where this is the case). We can of - -- course still see a -0.0 on a target where Signed_Zeroes is - -- False (since this attribute refers to the proper handling of - -- negative zeroes, not to their existence). We do not generate + -- blank only if Signed_Zeros is False (the RM only permits the + -- output of -0.0 when Signed_Zeros is True). We do not generate -- a blank for positive infinity, since we output an explicit +. if (not Is_Negative (V) and then V <= Long_Long_Float'Last) @@ -150,7 +146,7 @@ package body System.Img_Real is Exp : Natural) is NFrac : constant Natural := Natural'Max (Aft, 1); - Sign : Character; + Minus : Boolean; X : Long_Long_Float; Scale : Integer; Expon : Integer; @@ -419,7 +415,7 @@ package body System.Img_Real is procedure Set_Blanks_And_Sign (N : Integer) is begin - if Sign = '-' then + if Minus then for J in 1 .. N - 1 loop Set (' '); end loop; @@ -483,10 +479,10 @@ package body System.Img_Real is -- Start of processing for Set_Image_Real begin - -- We call the floating-point processor reset routine so that we can - -- be sure the floating-point processor is properly set for conversion - -- calls. This is notably need on Windows, where calls to the operating - -- system randomly reset the processor into 64-bit mode. + -- We call the floating-point processor reset routine so we can be sure + -- that the processor is properly set for conversions. This is notably + -- needed on Windows, where calls to the operating system randomly reset + -- the processor into 64-bit mode. System.Float_Control.Reset; @@ -539,21 +535,21 @@ package body System.Img_Real is if V > 0.0 then X := V; - Sign := '+'; + Minus := False; -- Negative values elsif V < 0.0 then X := -V; - Sign := '-'; + Minus := True; -- Zero values elsif V = 0.0 then if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then - Sign := '-'; + Minus := True; else - Sign := '+'; + Minus := False; end if; Set_Blanks_And_Sign (Fore - 1); @@ -578,7 +574,7 @@ package body System.Img_Real is raise Constraint_Error; end if; - -- X and Sign are set here, and X is known to be a valid, + -- X and Minus are set here, and X is known to be a valid, -- non-zero floating-point number. -- Case of non-zero value with Exp = 0 diff --git a/gcc/ada/libgnat/s-imgdec.adb b/gcc/ada/libgnat/s-imguti.adb index 840dadbdd1f..571fb675cc1 100644 --- a/gcc/ada/libgnat/s-imgdec.adb +++ b/gcc/ada/libgnat/s-imguti.adb @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- S Y S T E M . I M G _ D E C -- +-- S Y S T E M . I M G _ U T I L -- -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,34 +29,9 @@ -- -- ------------------------------------------------------------------------------ -with System.Img_Int; use System.Img_Int; +with System.Img_Uns; use System.Img_Uns; -package body System.Img_Dec is - - ------------------- - -- Image_Decimal -- - ------------------- - - procedure Image_Decimal - (V : Integer; - S : in out String; - P : out Natural; - Scale : Integer) - is - pragma Assert (S'First = 1); - - begin - -- Add space at start for non-negative numbers - - if V >= 0 then - S (1) := ' '; - P := 1; - else - P := 0; - end if; - - Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0); - end Image_Decimal; +package body System.Img_Util is ------------------------ -- Set_Decimal_Digits -- @@ -121,8 +96,8 @@ package body System.Img_Dec is procedure Set_Blanks_And_Sign (N : Integer); -- Sets leading blanks and minus sign if needed. N is the number of -- positions to be filled (a minus sign is output even if N is zero - -- or negative, For a positive value, if N is non-positive, then - -- a leading blank is filled. + -- or negative, but for a positive value, if N is non-positive, then + -- the call has no effect). procedure Set_Digits (S, E : Natural); pragma Inline (Set_Digits); @@ -219,9 +194,6 @@ package body System.Img_Dec is -- Constraint_Error will not necessarily be raised if this -- requirement is violated, since it is perfectly valid to compile -- this unit with checks off. - -- - -- Due to codepeer limitation, codepeer should be used with switch: - -- -no-propagation system.img_dec.set_decimal_digits.set P := P + 1; S (P) := C; end Set; @@ -231,20 +203,16 @@ package body System.Img_Dec is ------------------------- procedure Set_Blanks_And_Sign (N : Integer) is - W : Integer := N; - begin if Minus then - W := W - 1; - - for J in 1 .. W loop + for J in 1 .. N - 1 loop Set (' '); end loop; Set ('-'); else - for J in 1 .. W loop + for J in 1 .. N loop Set (' '); end loop; end if; @@ -305,15 +273,16 @@ package body System.Img_Dec is -- exponent of +0. Expon := (if Zero then 0 else Digits_Before_Point - 1); + Set ('E'); ND := 0; if Expon >= 0 then Set ('+'); - Set_Image_Integer (Expon, Digs, ND); + Set_Image_Unsigned (Unsigned (Expon), Digs, ND); else Set ('-'); - Set_Image_Integer (-Expon, Digs, ND); + Set_Image_Unsigned (Unsigned (-Expon), Digs, ND); end if; Set_Zeroes (Exp - ND - 1); @@ -431,24 +400,4 @@ package body System.Img_Dec is end if; end Set_Decimal_Digits; - ----------------------- - -- Set_Image_Decimal -- - ----------------------- - - procedure Set_Image_Decimal - (V : Integer; - S : in out String; - P : in out Natural; - Scale : Integer; - Fore : Natural; - Aft : Natural; - Exp : Natural) - is - Digs : String := Integer'Image (V); - -- Sign and digits of decimal value - - begin - Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp); - end Set_Image_Decimal; - -end System.Img_Dec; +end System.Img_Util; diff --git a/gcc/ada/libgnat/s-imguti.ads b/gcc/ada/libgnat/s-imguti.ads new file mode 100644 index 00000000000..f980bb7d5e1 --- /dev/null +++ b/gcc/ada/libgnat/s-imguti.ads @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ U T I L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides some common utilities used by the s-imgxxx files + +package System.Img_Util is + pragma Pure; + + procedure Set_Decimal_Digits + (Digs : in out String; + NDigs : Natural; + S : out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural); + -- Sets the image of Digs (1 .. NDigs), which is a string of decimal digits + -- preceded by either a minus sign or a space, i.e. the integer image of + -- the value in units of delta of a decimal fixed point type with the given + -- Scale, starting at S (P + 1), updating P to point to the last character + -- stored, the caller promises that the buffer is large enough and no check + -- is made for this. Constraint_Error will not necessarily be raised if the + -- requirement is violated since it is perfectly valid to compile this unit + -- with checks off. The Fore, Aft and Exp values can be set to any valid + -- values for the case of use by Text_IO.Decimal_IO. Note that there is no + -- leading space stored. The call may destroy the value in Digs, which is + -- why Digs is in-out (this happens if rounding is required). + +end System.Img_Util; diff --git a/gcc/ada/libgnat/s-valdec.adb b/gcc/ada/libgnat/s-vade128.ads index 99fffafce3d..8edc7424e09 100644 --- a/gcc/ada/libgnat/s-valdec.adb +++ b/gcc/ada/libgnat/s-vade128.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- S Y S T E M . V A L _ D E C -- +-- S Y S T E M . V A L _ D E C I M A L _ 1 2 8 -- -- -- --- B o d y -- +-- S p e c -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,40 +29,32 @@ -- -- ------------------------------------------------------------------------------ -with System.Val_Real; use System.Val_Real; +-- This package contains routines for scanning values for decimal fixed point +-- types up to 128-bit mantissa, for use in Text_IO.Decimal_IO, and the Value +-- attribute for such decimal types. -package body System.Val_Dec is +with Interfaces; +with System.Arith_128; +with System.Value_D; - ------------------ - -- Scan_Decimal -- - ------------------ +package System.Val_Decimal_128 is + pragma Preelaborate; - -- For decimal types where Size < Integer'Size, it is fine to use - -- the floating-point circuit, since it certainly has sufficient - -- precision for any reasonable hardware, and we just don't support - -- things on junk hardware. + subtype Int128 is Interfaces.Integer_128; + subtype Uns128 is Interfaces.Unsigned_128; - function Scan_Decimal + package Impl is new Value_D (Int128, Uns128, Arith_128.Scaled_Divide128); + + function Scan_Decimal128 (Str : String; Ptr : not null access Integer; Max : Integer; - Scale : Integer) return Integer - is - Val : Long_Long_Float; - begin - Val := Scan_Real (Str, Ptr, Max); - return Integer (Val * 10.0 ** Scale); - end Scan_Decimal; - - ------------------- - -- Value_Decimal -- - ------------------- + Scale : Integer) return Int128 + renames Impl.Scan_Decimal; - -- Again, we use the real circuit for this purpose - - function Value_Decimal (Str : String; Scale : Integer) return Integer is - begin - return Integer (Value_Real (Str) * 10.0 ** Scale); - end Value_Decimal; + function Value_Decimal128 + (Str : String; + Scale : Integer) return Int128 + renames Impl.Value_Decimal; -end System.Val_Dec; +end System.Val_Decimal_128; diff --git a/gcc/ada/libgnat/s-vade32.ads b/gcc/ada/libgnat/s-vade32.ads new file mode 100644 index 00000000000..b86ae52db18 --- /dev/null +++ b/gcc/ada/libgnat/s-vade32.ads @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ D E C I M A L _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning values for decimal fixed point +-- types up to 32-bit mantissa, for use in Text_IO.Decimal_IO, and the Value +-- attribute for such decimal types. + +with Interfaces; +with System.Arith_32; +with System.Value_D; + +package System.Val_Decimal_32 is + pragma Preelaborate; + + subtype Int32 is Interfaces.Integer_32; + subtype Uns32 is Interfaces.Unsigned_32; + + package Impl is new Value_D (Int32, Uns32, Arith_32.Scaled_Divide32); + + function Scan_Decimal32 + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Scale : Integer) return Int32 + renames Impl.Scan_Decimal; + + function Value_Decimal32 (Str : String; Scale : Integer) return Int32 + renames Impl.Value_Decimal; + +end System.Val_Decimal_32; diff --git a/gcc/ada/libgnat/s-vallld.adb b/gcc/ada/libgnat/s-vade64.ads index 4efa969218f..d3a5b4f9718 100644 --- a/gcc/ada/libgnat/s-vallld.adb +++ b/gcc/ada/libgnat/s-vade64.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- S Y S T E M . V A L _ L L D -- +-- S Y S T E M . V A L _ D E C I M A L _ 6 4 -- -- -- --- B o d y -- +-- S p e c -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,42 +29,32 @@ -- -- ------------------------------------------------------------------------------ -with System.Val_Real; use System.Val_Real; +-- This package contains routines for scanning values for decimal fixed point +-- types up to 64-bit mantissa, for use in Text_IO.Decimal_IO, and the Value +-- attribute for such decimal types. -package body System.Val_LLD is +with Interfaces; +with System.Arith_64; +with System.Value_D; - ---------------------------- - -- Scan_Long_Long_Decimal -- - ---------------------------- +package System.Val_Decimal_64 is + pragma Preelaborate; - -- We use the floating-point circuit for now, this will be OK on a PC, - -- but definitely does NOT have the required precision if the longest - -- float type is IEEE double. This must be fixed in the future ??? + subtype Int64 is Interfaces.Integer_64; + subtype Uns64 is Interfaces.Unsigned_64; - function Scan_Long_Long_Decimal + package Impl is new Value_D (Int64, Uns64, Arith_64.Scaled_Divide64); + + function Scan_Decimal64 (Str : String; Ptr : not null access Integer; Max : Integer; - Scale : Integer) return Long_Long_Integer - is - Val : Long_Long_Float; - begin - Val := Scan_Real (Str, Ptr, Max); - return Long_Long_Integer (Val * 10.0 ** Scale); - end Scan_Long_Long_Decimal; - - ----------------------------- - -- Value_Long_Long_Decimal -- - ----------------------------- - - -- Again we cheat and use floating-point ??? + Scale : Integer) return Int64 + renames Impl.Scan_Decimal; - function Value_Long_Long_Decimal + function Value_Decimal64 (Str : String; - Scale : Integer) return Long_Long_Integer - is - begin - return Long_Long_Integer (Value_Real (Str) * 10.0 ** Scale); - end Value_Long_Long_Decimal; + Scale : Integer) return Int64 + renames Impl.Value_Decimal; -end System.Val_LLD; +end System.Val_Decimal_64; diff --git a/gcc/ada/libgnat/s-vafi128.ads b/gcc/ada/libgnat/s-vafi128.ads new file mode 100644 index 00000000000..03fbe8049f7 --- /dev/null +++ b/gcc/ada/libgnat/s-vafi128.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ F I X E D _ 1 2 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning values for ordinary fixed point +-- types up to 128-bit small and mantissa, for use in Text_IO.Decimal_IO, and +-- the Value attribute for such decimal types. + +with Interfaces; +with System.Arith_128; +with System.Value_F; + +package System.Val_Fixed_128 is + pragma Preelaborate; + + subtype Int128 is Interfaces.Integer_128; + subtype Uns128 is Interfaces.Unsigned_128; + + package Impl is new Value_F (Int128, Uns128, Arith_128.Scaled_Divide128); + + function Scan_Fixed128 + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Num : Int128; + Den : Int128) return Int128 + renames Impl.Scan_Fixed; + + function Value_Fixed128 + (Str : String; Num : Int128; Den : Int128) return Int128 + renames Impl.Value_Fixed; + +end System.Val_Fixed_128; diff --git a/gcc/ada/libgnat/s-vafi32.ads b/gcc/ada/libgnat/s-vafi32.ads new file mode 100644 index 00000000000..6235a827010 --- /dev/null +++ b/gcc/ada/libgnat/s-vafi32.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ F I X E D _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning values for decimal fixed point +-- types up to 32-bit small and mantissa, for use in Text_IO.Decimal_IO, and +-- the Value attribute for such decimal types. + +with Interfaces; +with System.Arith_32; +with System.Value_F; + +package System.Val_Fixed_32 is + pragma Preelaborate; + + subtype Int32 is Interfaces.Integer_32; + subtype Uns32 is Interfaces.Unsigned_32; + + package Impl is new Value_F (Int32, Uns32, Arith_32.Scaled_Divide32); + + function Scan_Fixed32 + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Num : Int32; + Den : Int32) return Int32 + renames Impl.Scan_Fixed; + + function Value_Fixed32 + (Str : String; Num : Int32; Den : Int32) return Int32 + renames Impl.Value_Fixed; + +end System.Val_Fixed_32; diff --git a/gcc/ada/libgnat/s-vafi64.ads b/gcc/ada/libgnat/s-vafi64.ads new file mode 100644 index 00000000000..9f98df47ed3 --- /dev/null +++ b/gcc/ada/libgnat/s-vafi64.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ F I X E D _ 6 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning values for decimal fixed point +-- types up to 64-bit small and mantissa, for use in Text_IO.Decimal_IO, and +-- the Value attribute for such decimal types. + +with Interfaces; +with System.Arith_64; +with System.Value_F; + +package System.Val_Fixed_64 is + pragma Preelaborate; + + subtype Int64 is Interfaces.Integer_64; + subtype Uns64 is Interfaces.Unsigned_64; + + package Impl is new Value_F (Int64, Uns64, Arith_64.Scaled_Divide64); + + function Scan_Fixed64 + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Num : Int64; + Den : Int64) return Int64 + renames Impl.Scan_Fixed; + + function Value_Fixed64 + (Str : String; Num : Int64; Den : Int64) return Int64 + renames Impl.Value_Fixed; + +end System.Val_Fixed_64; diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb index 1a47dc2f49f..693b261657d 100644 --- a/gcc/ada/libgnat/s-valrea.adb +++ b/gcc/ada/libgnat/s-valrea.adb @@ -29,282 +29,58 @@ -- -- ------------------------------------------------------------------------------ -with System.Val_Util; use System.Val_Util; with System.Float_Control; +with System.Unsigned_Types; use System.Unsigned_Types; +with System.Val_Util; use System.Val_Util; +with System.Value_R; package body System.Val_Real is - procedure Scan_Integral_Digits - (Str : String; - Index : in out Integer; - Max : Integer; - Value : out Long_Long_Integer; - Scale : out Integer; - Base_Violation : in out Boolean; - Base : Long_Long_Integer := 10; - Base_Specified : Boolean := False); - -- Scan the integral part of a real (i.e: before decimal separator) - -- - -- The string parsed is Str (Index .. Max), and after the call Index will - -- point to the first non parsed character. - -- - -- For each digit parsed either value := value * base + digit, or scale - -- is incremented by 1. - -- - -- Base_Violation will be set to True a digit found is not part of the Base - - procedure Scan_Decimal_Digits - (Str : String; - Index : in out Integer; - Max : Integer; - Value : in out Long_Long_Integer; - Scale : in out Integer; - Base_Violation : in out Boolean; - Base : Long_Long_Integer := 10; - Base_Specified : Boolean := False); - -- Scan the decimal part of a real (i.e: after decimal separator) - -- - -- The string parsed is Str (Index .. Max), and after the call Index will - -- point to the first non parsed character. - -- - -- For each digit parsed value = value * base + digit and scale is - -- decremented by 1. If precision limit is reached remaining digits are - -- still parsed but ignored. - -- - -- Base_Violation will be set to True a digit found is not part of the Base - - subtype Char_As_Digit is Long_Long_Integer range -2 .. 15; - subtype Valid_Digit is Char_As_Digit range 0 .. Char_As_Digit'Last; - Underscore : constant Char_As_Digit := -2; - E_Digit : constant Char_As_Digit := 14; - - function As_Digit (C : Character) return Char_As_Digit; - -- Given a character return the digit it represent. If the character is - -- not a digit then a negative value is returned, -2 for underscore and - -- -1 for any other character. - - Precision_Limit : constant Long_Long_Integer := - 2 ** (Long_Long_Float'Machine_Mantissa - 1) - 1; - -- This is an upper bound for the number of bits used to represent the - -- mantissa. Beyond that number, any digits parsed are useless. - - -------------- - -- As_Digit -- - -------------- - - function As_Digit (C : Character) return Char_As_Digit is - begin - case C is - when '0' .. '9' => - return Character'Pos (C) - Character'Pos ('0'); - when 'a' .. 'f' => - return Character'Pos (C) - (Character'Pos ('a') - 10); - when 'A' .. 'F' => - return Character'Pos (C) - (Character'Pos ('A') - 10); - when '_' => - return Underscore; - when others => - return -1; - end case; - end As_Digit; - - ------------------------- - -- Scan_Decimal_Digits -- - ------------------------- - - procedure Scan_Decimal_Digits - (Str : String; - Index : in out Integer; - Max : Integer; - Value : in out Long_Long_Integer; - Scale : in out Integer; - Base_Violation : in out Boolean; - Base : Long_Long_Integer := 10; - Base_Specified : Boolean := False) - + package Impl is new Value_R (Long_Long_Unsigned, Floating => True); + + function Integer_to_Real + (Str : String; + Val : Long_Long_Unsigned; + Base : Unsigned; + Scale : Integer; + Minus : Boolean) return Long_Long_Float; + -- Convert the real value from integer to real representation + + --------------------- + -- Integer_to_Real -- + --------------------- + + function Integer_to_Real + (Str : String; + Val : Long_Long_Unsigned; + Base : Unsigned; + Scale : Integer; + Minus : Boolean) return Long_Long_Float is - Precision_Limit_Reached : Boolean := False; - -- Set to True if addition of a digit will cause Value to be superior - -- to Precision_Limit. - - Digit : Char_As_Digit; - -- The current digit. + pragma Unsuppress (Range_Check); - Trailing_Zeros : Natural := 0; - -- Number of trailing zeros at a given point. + R_Val : Long_Long_Float; begin - pragma Assert (Base in 2 .. 16); - - -- If initial Scale is not 0 then it means that Precision_Limit was - -- reached during integral part scanning. - if Scale > 0 then - Precision_Limit_Reached := True; - end if; - - -- The function precondition is that the first character is a valid - -- digit. - Digit := As_Digit (Str (Index)); - - loop - -- Check if base is correct. If the base is not specified the digit - -- E or e cannot be considered as a base violation as it can be used - -- for exponentiation. - if Digit >= Base then - if Base_Specified then - Base_Violation := True; - elsif Digit = E_Digit then - return; - else - Base_Violation := True; - end if; - end if; - - -- If precision limit has been reached just ignore any remaining - -- digits for the computation of Value and Scale. The scanning - -- should continue only to assess the validity of the string - if not Precision_Limit_Reached then - if Digit = 0 then - -- Trailing '0' digits are ignored unless a non-zero digit is - -- found. - Trailing_Zeros := Trailing_Zeros + 1; - else - - -- Handle accumulated zeros. - for J in 1 .. Trailing_Zeros loop - if Value > Precision_Limit / Base then - Precision_Limit_Reached := True; - exit; - else - Value := Value * Base; - Scale := Scale - 1; - end if; - end loop; - - -- Reset trailing zero counter - Trailing_Zeros := 0; - - -- Handle current non zero digit - if Value > (Precision_Limit - Digit) / Base then - Precision_Limit_Reached := True; - else - Value := Value * Base + Digit; - Scale := Scale - 1; - end if; - end if; - end if; + -- We call the floating-point processor reset routine so we can be sure + -- that the processor is properly set for conversions. This is notably + -- needed on Windows, where calls to the operating system randomly reset + -- the processor into 64-bit mode. - -- Check next character - Index := Index + 1; - - if Index > Max then - return; - end if; - - Digit := As_Digit (Str (Index)); - - if Digit < 0 then - if Digit = Underscore and Index + 1 <= Max then - -- Underscore is only allowed if followed by a digit - Digit := As_Digit (Str (Index + 1)); - if Digit in Valid_Digit then - Index := Index + 1; - else - return; - end if; - else - -- Neither a valid underscore nor a digit. - return; - end if; - end if; - end loop; - end Scan_Decimal_Digits; - - -------------------------- - -- Scan_Integral_Digits -- - -------------------------- - - procedure Scan_Integral_Digits - (Str : String; - Index : in out Integer; - Max : Integer; - Value : out Long_Long_Integer; - Scale : out Integer; - Base_Violation : in out Boolean; - Base : Long_Long_Integer := 10; - Base_Specified : Boolean := False) - is - Precision_Limit_Reached : Boolean := False; - -- Set to True if addition of a digit will cause Value to be superior - -- to Precision_Limit. - - Digit : Char_As_Digit; - -- The current digit - begin - - -- Initialize Scale and Value - Value := 0; - Scale := 0; - - -- The function precondition is that the first character is a valid - -- digit. - Digit := As_Digit (Str (Index)); - - loop - -- Check if base is correct. If the base is not specified the digit - -- E or e cannot be considered as a base violation as it can be used - -- for exponentiation. - if Digit >= Base then - if Base_Specified then - Base_Violation := True; - elsif Digit = E_Digit then - return; - else - Base_Violation := True; - end if; - end if; - - if Precision_Limit_Reached then - -- Precision limit has been reached so just update the exponent - Scale := Scale + 1; - else - pragma Assert (Base /= 0); + System.Float_Control.Reset; - if Value > (Precision_Limit - Digit) / Base then - -- Updating Value will overflow so ignore this digit and any - -- following ones. Only update the scale - Precision_Limit_Reached := True; - Scale := Scale + 1; - else - Value := Value * Base + Digit; - end if; - end if; + -- Compute the final value - -- Look for the next character - Index := Index + 1; - if Index > Max then - return; - end if; + R_Val := Long_Long_Float (Val) * Long_Long_Float (Base) ** Scale; - Digit := As_Digit (Str (Index)); + -- Finally deal with initial minus sign, note that this processing is + -- done even if Uval is zero, so that -0.0 is correctly interpreted. - if Digit not in Valid_Digit then - -- Next character is not a digit. In that case stop scanning - -- unless the next chracter is an underscore followed by a digit. - if Digit = Underscore and Index + 1 <= Max then - Digit := As_Digit (Str (Index + 1)); - if Digit in Valid_Digit then - Index := Index + 1; - else - return; - end if; - else - return; - end if; - end if; - end loop; + return (if Minus then -R_Val else R_Val); - end Scan_Integral_Digits; + exception + when Constraint_Error => Bad_Value (Str); + end Integer_to_Real; --------------- -- Scan_Real -- @@ -315,197 +91,17 @@ package body System.Val_Real is Ptr : not null access Integer; Max : Integer) return Long_Long_Float - is - Start : Positive; - -- Position of starting non-blank character - + Base : Unsigned; + Scale : Integer; + Extra : Unsigned; Minus : Boolean; - -- Set to True if minus sign is present, otherwise to False - - Index : Integer; - -- Local copy of string pointer - - Int_Value : Long_Long_Integer := -1; - -- Mantissa as an Integer - - Int_Scale : Integer := 0; - -- Exponent value - - Base_Violation : Boolean := False; - -- If True some digits where not in the base. The float is still scan - -- till the end even if an error will be raised. - - Uval : Long_Long_Float := 0.0; - -- Contain the final value at the end of the function - - After_Point : Boolean := False; - -- True if a decimal should be parsed - - Base : Long_Long_Integer := 10; - -- Current base (default: 10) - - Base_Char : Character := ASCII.NUL; - -- Character used to set the base. If Nul this means that default - -- base is used. + Val : Long_Long_Unsigned; 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; - - -- We call the floating-point processor reset routine so that we can - -- be sure the floating-point processor is properly set for conversion - -- calls. This is notably need on Windows, where calls to the operating - -- system randomly reset the processor into 64-bit mode. - - System.Float_Control.Reset; - - -- Scan the optional sign - Scan_Sign (Str, Ptr, Max, Minus, Start); - Index := Ptr.all; - Ptr.all := Start; - - -- First character can be either a decimal digit or a dot. - if Str (Index) in '0' .. '9' then - pragma Annotate - (CodePeer, Intentional, - "test always true", "defensive code below"); - - -- If this is a digit it can indicates either the float decimal - -- part or the base to use - Scan_Integral_Digits - (Str, - Index, - Max => Max, - Value => Int_Value, - Scale => Int_Scale, - Base_Violation => Base_Violation, - Base => 10); - elsif Str (Index) = '.' and then - -- A dot is only allowed if followed by a digit. - Index < Max and then - Str (Index + 1) in '0' .. '9' - then - -- Initial point, allowed only if followed by digit (RM 3.5(47)) - After_Point := True; - Index := Index + 1; - Int_Value := 0; - else - Bad_Value (Str); - end if; - - -- Check if the first number encountered is a base - if Index < Max and then - (Str (Index) = '#' or else Str (Index) = ':') - then - Base_Char := Str (Index); - Base := Int_Value; - - -- Reset Int_Value to indicate that parsing of integral value should - -- be done - Int_Value := -1; - if Base < 2 or else Base > 16 then - Base_Violation := True; - Base := 16; - end if; - - Index := Index + 1; - - if Str (Index) = '.' and then - Index < Max and then - As_Digit (Str (Index + 1)) in Valid_Digit - then - After_Point := True; - Index := Index + 1; - Int_Value := 0; - end if; - end if; - - -- Does scanning of integral part needed - if Int_Value < 0 then - if Index > Max or else As_Digit (Str (Index)) not in Valid_Digit then - Bad_Value (Str); - end if; - - Scan_Integral_Digits - (Str, - Index, - Max => Max, - Value => Int_Value, - Scale => Int_Scale, - Base_Violation => Base_Violation, - Base => Base, - Base_Specified => Base_Char /= ASCII.NUL); - end if; - - -- Do we have a dot ? - if not After_Point and then - Index <= Max and then - Str (Index) = '.' - then - -- At this stage if After_Point was not set, this means that an - -- integral part has been found. Thus the dot is valid even if not - -- followed by a digit. - if Index < Max and then As_Digit (Str (Index + 1)) in Valid_Digit then - After_Point := True; - end if; - - Index := Index + 1; - end if; - - if After_Point then - -- Parse decimal part - Scan_Decimal_Digits - (Str, - Index, - Max => Max, - Value => Int_Value, - Scale => Int_Scale, - Base_Violation => Base_Violation, - Base => Base, - Base_Specified => Base_Char /= ASCII.NUL); - end if; - - -- If an explicit base was specified ensure that the delimiter is found - if Base_Char /= ASCII.NUL then - if Index > Max or else Str (Index) /= Base_Char then - Bad_Value (Str); - else - Index := Index + 1; - end if; - end if; - - -- Compute the final value - Uval := Long_Long_Float (Int_Value); - - -- Update pointer and scan exponent. - Ptr.all := Index; - - Int_Scale := Int_Scale + Scan_Exponent (Str, - Ptr, - Max, - Real => True); - - Uval := Uval * Long_Long_Float (Base) ** Int_Scale; - - -- Here is where we check for a bad based number - if Base_Violation then - Bad_Value (Str); - - -- If OK, then deal with initial minus sign, note that this processing - -- is done even if Uval is zero, so that -0.0 is correctly interpreted. - else - if Minus then - return -Uval; - else - return Uval; - end if; - end if; + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scale, Extra, Minus); + return Integer_to_Real (Str, Val, Base, Scale, Minus); end Scan_Real; ---------------- @@ -513,30 +109,16 @@ package body System.Val_Real is ---------------- function Value_Real (Str : String) return Long_Long_Float 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_Real (NT (Str)); - end; + Base : Unsigned; + Scale : Integer; + Extra : Unsigned; + Minus : Boolean; + Val : Long_Long_Unsigned; - -- Normal case where Str'Last < Positive'Last + begin + Val := Impl.Value_Raw_Real (Str, Base, Scale, Extra, Minus); - else - declare - V : Long_Long_Float; - P : aliased Integer := Str'First; - begin - V := Scan_Real (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; + return Integer_to_Real (Str, Val, Base, Scale, Minus); end Value_Real; end System.Val_Real; diff --git a/gcc/ada/libgnat/s-valued.adb b/gcc/ada/libgnat/s-valued.adb new file mode 100644 index 00000000000..5fa8a99648c --- /dev/null +++ b/gcc/ada/libgnat/s-valued.adb @@ -0,0 +1,257 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; +with System.Val_Util; use System.Val_Util; +with System.Value_R; + +package body System.Value_D is + + package Impl is new Value_R (Uns, Floating => False); + + function Integer_to_Decimal + (Str : String; + Val : Uns; + Base : Unsigned; + ScaleB : Integer; + Minus : Boolean; + Scale : Integer) return Int; + -- Convert the real value from integer to decimal representation + + ------------------------ + -- Integer_to_Decimal -- + ------------------------ + + function Integer_to_Decimal + (Str : String; + Val : Uns; + Base : Unsigned; + ScaleB : Integer; + Minus : Boolean; + Scale : Integer) return Int + is + function Safe_Expont + (Base : Int; + Exp : in out Natural; + Factor : Int) return Int; + -- Return (Base ** Exp) * Factor if the computation does not overflow, + -- or else the number of the form (Base ** K) * Factor with the largest + -- magnitude if the former computation overflows. In both cases, Exp is + -- updated to contain the remaining power in the computation. Note that + -- Factor is expected to be positive in this context. + + function Unsigned_To_Signed (Val : Uns) return Int; + -- Convert an integer value from unsigned to signed representation + + ----------------- + -- Safe_Expont -- + ----------------- + + function Safe_Expont + (Base : Int; + Exp : in out Natural; + Factor : Int) return Int + is + pragma Assert (Base /= 0 and then Factor > 0); + + Max : constant Int := Int'Last / Base; + + Result : Int := Factor; + + begin + while Exp > 0 and then Result <= Max loop + Result := Result * Base; + Exp := Exp - 1; + end loop; + + return Result; + end Safe_Expont; + + ------------------------ + -- Unsigned_To_Signed -- + ------------------------ + + function Unsigned_To_Signed (Val : Uns) return Int is + begin + -- Deal with overflow cases, and also with largest negative number + + if Val > Uns (Int'Last) then + if Minus and then Val = Uns (-(Int'First)) then + return Int'First; + else + Bad_Value (Str); + end if; + + -- Negative values + + elsif Minus then + return -(Int (Val)); + + -- Positive values + + else + return Int (Val); + end if; + end Unsigned_To_Signed; + + begin + -- If the base of the value is 10 or its scaling factor is zero, then + -- add the scales (they are defined in the opposite sense) and apply + -- the result to the value, checking for overflow in the process. + + if Base = 10 or else ScaleB = 0 then + declare + S : Integer := ScaleB + Scale; + V : Uns := Val; + + begin + while S < 0 loop + V := V / 10; + S := S + 1; + end loop; + + while S > 0 loop + if V <= Uns'Last / 10 then + V := V * 10; + S := S - 1; + else + Bad_Value (Str); + end if; + end loop; + + return Unsigned_To_Signed (V); + end; + + -- If the base of the value is not 10, use a scaled divide operation + -- to compute Val * (Base ** ScaleB) * (10 ** Scale). + + else + declare + B : constant Int := Int (Base); + S : constant Integer := ScaleB; + + V : Uns := Val; + + Y, Z, Q, R : Int; + + begin + -- If S is too negative, then drop trailing digits + + if S < 0 then + declare + LS : Integer := -S; + + begin + Y := 10 ** Integer'Max (0, Scale); + Z := Safe_Expont (B, LS, 10 ** Integer'Max (0, -Scale)); + + for J in 1 .. LS loop + V := V / Uns (B); + end loop; + end; + + -- If S is too positive, then scale V up, which may then overflow + + elsif S > 0 then + declare + LS : Integer := S; + + begin + Y := Safe_Expont (B, LS, 10 ** Integer'Max (0, Scale)); + Z := 10 ** Integer'Max (0, -Scale); + + for J in 1 .. LS loop + if V <= Uns'Last / Uns (B) then + V := V * Uns (B); + else + Bad_Value (Str); + end if; + end loop; + end; + + -- The case S equal to zero should have been handled earlier + + else + raise Program_Error; + end if; + + -- Perform a scale divide operation with rounding to match 'Image + + Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q, R, Round => True); + + return Q; + end; + end if; + + exception + when Constraint_Error => Bad_Value (Str); + end Integer_to_Decimal; + + ------------------ + -- Scan_Decimal -- + ------------------ + + function Scan_Decimal + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Scale : Integer) return Int + is + Base : Unsigned; + ScaleB : Integer; + Extra : Unsigned; + Minus : Boolean; + Val : Uns; + + begin + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus); + + return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); + end Scan_Decimal; + + ------------------- + -- Value_Decimal -- + ------------------- + + function Value_Decimal (Str : String; Scale : Integer) return Int is + Base : Unsigned; + ScaleB : Integer; + Extra : Unsigned; + Minus : Boolean; + Val : Uns; + + begin + Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus); + + return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); + end Value_Decimal; + +end System.Value_D; diff --git a/gcc/ada/libgnat/s-valdec.ads b/gcc/ada/libgnat/s-valued.ads index 05fab9834e7..e27e1714c17 100644 --- a/gcc/ada/libgnat/s-valdec.ads +++ b/gcc/ada/libgnat/s-valued.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- S Y S T E M . V A L _ D E C -- +-- S Y S T E M . V A L U E _ D -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,18 +29,29 @@ -- -- ------------------------------------------------------------------------------ --- This package contains routines for scanning decimal values where the size --- of the type is no greater than Standard.Integer'Size, for use in Text_IO. --- Decimal_IO, and the Value attribute for such decimal types. +-- This package contains the routines for supporting the Value attribute for +-- decimal fixed point types, and also for conversion operations required in +-- Text_IO.Decimal_IO for such types. -package System.Val_Dec is +generic + + type Int is range <>; + + type Uns is mod <>; + + with procedure Scaled_Divide + (X, Y, Z : Int; + Q, R : out Int; + Round : Boolean); + +package System.Value_D is pragma Preelaborate; function Scan_Decimal (Str : String; Ptr : not null access Integer; Max : Integer; - Scale : Integer) return Integer; + Scale : Integer) return Int; -- This function scans the string starting at Str (Ptr.all) for a valid -- real literal according to the syntax described in (RM 3.5(43)). The -- substring scanned extends no further than Str (Max). There are three @@ -49,8 +60,8 @@ package System.Val_Dec is -- If a valid real literal is found after scanning past any initial spaces, -- then Ptr.all is updated past the last character of the literal (but -- trailing spaces are not scanned out). The value returned is the value - -- Integer'Integer_Value (decimal-literal-value), using the given Scale - -- to determine this value. + -- Int'Integer_Value (decimal-literal-value), using the given Scale to + -- determine this value. -- -- If no valid real literal is found, then Ptr.all points either to an -- initial non-digit character, or to Max + 1 if the field is all spaces @@ -68,13 +79,12 @@ package System.Val_Dec is -- special case of an all-blank string, and Ptr is unchanged, and hence -- is greater than Max as required in this case. - function Value_Decimal (Str : String; Scale : Integer) return Integer; - -- Used in computing X'Value (Str) where X is a decimal fixed-point type - -- whose size does not exceed Standard.Integer'Size. 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 of Integer (not the - -- range of the fixed-point type, that check must be done by the caller. - -- Otherwise the value returned is the value Integer'Integer_Value + function Value_Decimal (Str : String; Scale : Integer) return Int; + -- Used in computing X'Value (Str) where X is a decimal fixed-point type. + -- 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 of Int (not + -- the range of the fixed-point type, which must be done by the caller). + -- Otherwise the value returned is the value Int'Integer_Value -- (decimal-literal-value), using Scale to determine this value. -end System.Val_Dec; +end System.Value_D; diff --git a/gcc/ada/libgnat/s-valuef.adb b/gcc/ada/libgnat/s-valuef.adb new file mode 100644 index 00000000000..f3ed5fa972c --- /dev/null +++ b/gcc/ada/libgnat/s-valuef.adb @@ -0,0 +1,332 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ F -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; +with System.Val_Util; use System.Val_Util; +with System.Value_R; + +package body System.Value_F is + + package Impl is new Value_R (Uns, Floating => False); + + function Integer_To_Fixed + (Str : String; + Val : Uns; + Base : Unsigned; + ScaleB : Integer; + Extra : Unsigned; + Minus : Boolean; + Num : Int; + Den : Int) return Int; + -- Convert the real value from integer to fixed point representation + + -- The goal is to compute Val * (Base ** ScaleB) / (Num / Den) with correct + -- rounding for all decimal values output by Typ'Image, that is to say up + -- to Typ'Aft decimal digits. Unlike for the output, the RM does not say + -- what the rounding must be for the input, but a reasonable exegesis of + -- the intent is that Typ'Value o Typ'Image should be the identity, which + -- is made possible because 'Aft is defined such that 'Image is injective. + + -- For a type with a mantissa of M bits including the sign, the number N1 + -- of decimal digits required to represent all the numbers is given by: + + -- N1 = ceil ((M - 1) * log 2 / log 10) [N1 = 10/19/39 for M = 32/64/128] + + -- but this mantissa can represent any set of contiguous numbers with only + -- N2 different decimal digits where: + + -- N2 = floor ((M - 1) * log 2 / log 10) [N2 = 9/18/38 for M = 32/64/128] + + -- Of course N1 = N2 + 1 holds, which means both that Val may not contain + -- enough significant bits to represent all the values of the type and that + -- 1 extra decimal digit contains the information for the missing bits. + + -- Therefore the actual computation to be performed is + + -- V = (Val * Base + Extra) * (Base ** (ScaleB - 1)) / (Num / Den) + + -- using two steps of scaled divide if Extra is non-zero + + -- (1) Val * ((Base ** ScaleB) * Den) = Q1 * Num + R1 + + -- (2) Extra * ((Base ** ScaleB) * Den) = Q2 * (-Base) + R2 + + -- which yields after dividing (1) by Num and (2) by Num * Base and summing + + -- V = Q1 + (R1 - Q2) / Num + R2 / (Num * Base) + + -- but we get rid of the third term by using a rounding divide for (2). + + ---------------------- + -- Integer_To_Fixed -- + ---------------------- + + function Integer_To_Fixed + (Str : String; + Val : Uns; + Base : Unsigned; + ScaleB : Integer; + Extra : Unsigned; + Minus : Boolean; + Num : Int; + Den : Int) return Int + is + pragma Assert (Base in 2 .. 16); + + pragma Assert (Extra < Base); + -- Accept only one extra digit after those used for Val + + pragma Assert (Num < 0 and then Den < 0); + -- Accept only negative numbers to allow -2**(Int'Size - 1) + + function Safe_Expont + (Base : Int; + Exp : in out Natural; + Factor : Int) return Int; + -- Return (Base ** Exp) * Factor if the computation does not overflow, + -- or else the number of the form (Base ** K) * Factor with the largest + -- magnitude if the former computation overflows. In both cases, Exp is + -- updated to contain the remaining power in the computation. Note that + -- Factor is expected to be negative in this context. + + function Unsigned_To_Signed (Val : Uns) return Int; + -- Convert an integer value from unsigned to signed representation + + ----------------- + -- Safe_Expont -- + ----------------- + + function Safe_Expont + (Base : Int; + Exp : in out Natural; + Factor : Int) return Int + is + pragma Assert (Base /= 0 and then Factor < 0); + + Min : constant Int := Int'First / Base; + + Result : Int := Factor; + + begin + while Exp > 0 and then Result >= Min loop + Result := Result * Base; + Exp := Exp - 1; + end loop; + + return Result; + end Safe_Expont; + + ------------------------ + -- Unsigned_To_Signed -- + ------------------------ + + function Unsigned_To_Signed (Val : Uns) return Int is + begin + -- Deal with overflow cases, and also with largest negative number + + if Val > Uns (Int'Last) then + if Minus and then Val = Uns (-(Int'First)) then + return Int'First; + else + Bad_Value (Str); + end if; + + -- Negative values + + elsif Minus then + return -(Int (Val)); + + -- Positive values + + else + return Int (Val); + end if; + end Unsigned_To_Signed; + + -- Local variables + + B : constant Int := Int (Base); + + V : Uns := Val; + S : Integer := ScaleB; + E : Uns := Uns (Extra); + N : Int := Num; + D : Int := Den; + + Y, Z, Q1, R1, Q2, R2 : Int; + + begin + -- We will use a scaled divide operation for which we must control the + -- magnitude of operands so that an overflow exception is not unduly + -- raised during the computation. The only real concern is the exponent + -- ScaleB so first try to reduce its magnitude in an exact manner. + + while S < 0 and then (D rem B) = 0 loop + D := D / B; + S := S + 1; + end loop; + + while S > 0 and then (N rem B) = 0 loop + N := N / B; + S := S - 1; + end loop; + + -- If S is still too negative, then drop trailing digits, but preserve + -- the last dropped digit. + + if S < 0 then + declare + LS : Integer := -S; + + begin + Y := D; + Z := Safe_Expont (B, LS, N); + + for J in 1 .. LS loop + E := V rem Uns (B); + V := V / Uns (B); + end loop; + end; + + -- If S is still too positive, then scale V up, which may then overflow + + elsif S > 0 then + declare + LS : Integer := S; + + begin + Y := Safe_Expont (B, LS, D); + Z := N; + + for J in 1 .. LS loop + if V <= Uns'Last / Uns (B) then + V := V * Uns (B); + else + Bad_Value (Str); + end if; + end loop; + end; + + -- If S is zero, then proceed directly + + else + Y := D; + Z := N; + end if; + + -- Perform a scaled divide operation with final rounding to match Image + -- using two steps if there is an extra digit available. The second and + -- third operands are always negative so the sign of the quotient is the + -- sign of the first operand and the sign of the remainder the opposite. + + if E /= 0 then + Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q1, R1, Round => False); + Scaled_Divide (Unsigned_To_Signed (E), Y, -B, Q2, R2, Round => True); + + -- Avoid an overflow during the subtraction. Note that Q2 is smaller + -- than Y and R1 smaller than Z in magnitude, so it is safe to take + -- their absolute value. + + if abs Q2 >= 2 ** (Int'Size - 2) + or else abs R1 >= 2 ** (Int'Size - 2) + then + declare + Bit : constant Int := Q2 rem 2; + + begin + Q2 := (Q2 - Bit) / 2; + R1 := (R1 - Bit) / 2; + Y := -2; + end; + + else + Y := -1; + end if; + + Scaled_Divide (Q2 - R1, Y, Z, Q2, R2, Round => True); + + return Q1 + Q2; + + else + Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q1, R1, Round => True); + + return Q1; + end if; + + exception + when Constraint_Error => Bad_Value (Str); + end Integer_To_Fixed; + + ---------------- + -- Scan_Fixed -- + ---------------- + + function Scan_Fixed + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Num : Int; + Den : Int) return Int + is + Base : Unsigned; + ScaleB : Integer; + Extra : Unsigned; + Minus : Boolean; + Val : Uns; + + begin + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus); + + return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den); + end Scan_Fixed; + + ----------------- + -- Value_Fixed -- + ----------------- + + function Value_Fixed + (Str : String; + Num : Int; + Den : Int) return Int + is + Base : Unsigned; + ScaleB : Integer; + Extra : Unsigned; + Minus : Boolean; + Val : Uns; + + begin + Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus); + + return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den); + end Value_Fixed; + +end System.Value_F; diff --git a/gcc/ada/libgnat/s-vallld.ads b/gcc/ada/libgnat/s-valuef.ads index 652362d4905..fac8c236c4f 100644 --- a/gcc/ada/libgnat/s-vallld.ads +++ b/gcc/ada/libgnat/s-valuef.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- S Y S T E M . V A L _ L L D -- +-- S Y S T E M . V A L U E _ F -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,18 +29,30 @@ -- -- ------------------------------------------------------------------------------ --- This package contains routines for scanning decimal values where the size --- of the type is greater than Standard.Integer'Size, for use in Text_IO. --- Decimal_IO, and the Value attribute for such decimal types. +-- This package contains the routines for supporting the Value attribute for +-- ordinary fixed point types, and also for conversion operations required in +-- Text_IO.Fixed_IO for such types. -package System.Val_LLD is +generic + + type Int is range <>; + + type Uns is mod <>; + + with procedure Scaled_Divide + (X, Y, Z : Int; + Q, R : out Int; + Round : Boolean); + +package System.Value_F is pragma Preelaborate; - function Scan_Long_Long_Decimal - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Scale : Integer) return Long_Long_Integer; + function Scan_Fixed + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Num : Int; + Den : Int) return Int; -- This function scans the string starting at Str (Ptr.all) for a valid -- real literal according to the syntax described in (RM 3.5(43)). The -- substring scanned extends no further than Str (Max). There are three @@ -49,8 +61,8 @@ package System.Val_LLD is -- If a valid real literal is found after scanning past any initial spaces, -- then Ptr.all is updated past the last character of the literal (but -- trailing spaces are not scanned out). The value returned is the value - -- Long_Long_Integer'Integer_Value (decimal-literal-value), using the given - -- Scale to determine this value. + -- Int'Integer_Value (decimal-literal-value), using the given Num/Den to + -- determine this value. -- -- If no valid real literal is found, then Ptr.all points either to an -- initial non-digit character, or to Max + 1 if the field is all spaces @@ -68,14 +80,15 @@ package System.Val_LLD is -- special case of an all-blank string, and Ptr is unchanged, and hence -- is greater than Max as required in this case. - function Value_Long_Long_Decimal - (Str : String; - Scale : Integer) return Long_Long_Integer; - -- Used in computing X'Value (Str) where X is a decimal types whose size - -- exceeds Standard.Integer'Size. 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, otherwise the value returned is the - -- value Long_Long_Integer'Integer_Value (decimal-literal-value), using - -- the given Scale to determine this value. + function Value_Fixed + (Str : String; + Num : Int; + Den : Int) return Int; + -- Used in computing X'Value (Str) where X is an ordinary fixed-point type. + -- 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 of Int (not + -- the range of the fixed-point type, which must be done by the caller). + -- Otherwise the value returned is the value Int'Integer_Value + -- (decimal-literal-value), using Small Num/Den to determine this value. -end System.Val_LLD; +end System.Value_F; diff --git a/gcc/ada/libgnat/s-valuei.adb b/gcc/ada/libgnat/s-valuei.adb index 1bc8b32f853..ac5a7761c65 100644 --- a/gcc/ada/libgnat/s-valuei.adb +++ b/gcc/ada/libgnat/s-valuei.adb @@ -61,7 +61,7 @@ package body System.Value_I is Uval := Scan_Raw_Unsigned (Str, Ptr, Max); - -- Deal with overflow cases, and also with maximum negative number + -- Deal with overflow cases, and also with largest negative number if Uval > Uns (Int'Last) then if Minus and then Uval = Uns (-(Int'First)) then diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb new file mode 100644 index 00000000000..a91fbb86869 --- /dev/null +++ b/gcc/ada/libgnat/s-valuer.adb @@ -0,0 +1,582 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Val_Util; use System.Val_Util; + +package body System.Value_R is + + F_Limit : constant Uns := 2 ** (Long_Long_Float'Machine_Mantissa - 1); + I_Limit : constant Uns := 2 ** (Uns'Size - 1); + -- Absolute value of largest representable signed integer + + Precision_Limit : constant Uns := (if Floating then F_Limit else I_Limit); + -- Limit beyond which additional digits are dropped + + subtype Char_As_Digit is Unsigned range 0 .. 17; + subtype Valid_Digit is Char_As_Digit range 0 .. 15; + E_Digit : constant Char_As_Digit := 14; + Underscore : constant Char_As_Digit := 16; + Not_A_Digit : constant Char_As_Digit := 17; + + function As_Digit (C : Character) return Char_As_Digit; + -- Given a character return the digit it represents + + procedure Scan_Decimal_Digits + (Str : String; + Index : in out Integer; + Max : Integer; + Value : in out Uns; + Scale : in out Integer; + Extra : in out Char_As_Digit; + Base_Violation : in out Boolean; + Base : Unsigned; + Base_Specified : Boolean); + -- Scan the decimal part of a real (i.e. after decimal separator) + -- + -- The string parsed is Str (Index .. Max) and after the call Index will + -- point to the first non-parsed character. + -- + -- For each digit parsed, Value = Value * Base + Digit and Scale is + -- decremented by 1. If precision limit is reached, remaining digits are + -- still parsed but ignored, except for the first which is stored in Extra. + -- + -- Base_Violation is set to True if a digit found is not part of the Base + -- + -- If Base_Specified is set, then the base was specified in the real + + procedure Scan_Integral_Digits + (Str : String; + Index : in out Integer; + Max : Integer; + Value : out Uns; + Scale : out Integer; + Extra : out Char_As_Digit; + Base_Violation : in out Boolean; + Base : Unsigned; + Base_Specified : Boolean); + -- Scan the integral part of a real (i.e. before decimal separator) + -- + -- The string parsed is Str (Index .. Max) and after the call Index will + -- point to the first non-parsed character. + -- + -- For each digit parsed, either Value := Value * Base + Digit or Scale + -- is incremented by 1 if precision limit is reached, in which case the + -- remaining digits are still parsed but ignored, except for the first + -- which is stored in Extra. + -- + -- Base_Violation is set to True if a digit found is not part of the Base + -- + -- If Base_Specified is set, then the base was specified in the real + + -------------- + -- As_Digit -- + -------------- + + function As_Digit (C : Character) return Char_As_Digit is + begin + case C is + when '0' .. '9' => + return Character'Pos (C) - Character'Pos ('0'); + when 'a' .. 'f' => + return Character'Pos (C) - (Character'Pos ('a') - 10); + when 'A' .. 'F' => + return Character'Pos (C) - (Character'Pos ('A') - 10); + when '_' => + return Underscore; + when others => + return Not_A_Digit; + end case; + end As_Digit; + + ------------------------- + -- Scan_Decimal_Digits -- + ------------------------- + + procedure Scan_Decimal_Digits + (Str : String; + Index : in out Integer; + Max : Integer; + Value : in out Uns; + Scale : in out Integer; + Extra : in out Char_As_Digit; + Base_Violation : in out Boolean; + Base : Unsigned; + Base_Specified : Boolean) + + is + pragma Assert (Base in 2 .. 16); + + Umax : constant Uns := (Precision_Limit - Uns (Base) + 1) / Uns (Base); + -- Max value which cannot overflow on accumulating next digit + + UmaxB : constant Uns := Precision_Limit / Uns (Base); + -- Numbers bigger than UmaxB overflow if multiplied by base + + Precision_Limit_Reached : Boolean := False; + -- Set to True if addition of a digit will cause Value to be superior + -- to Precision_Limit. + + Digit : Char_As_Digit; + -- The current digit + + Temp : Uns; + -- Temporary + + Trailing_Zeros : Natural := 0; + -- Number of trailing zeros at a given point + + begin + -- If initial Scale is not 0 then it means that Precision_Limit was + -- reached during scanning of the integral part. + + if Scale > 0 then + Precision_Limit_Reached := True; + else + Extra := 0; + end if; + + -- The function precondition is that the first character is a valid + -- digit. + + Digit := As_Digit (Str (Index)); + + loop + -- Check if base is correct. If the base is not specified, the digit + -- E or e cannot be considered as a base violation as it can be used + -- for exponentiation. + + if Digit >= Base then + if Base_Specified then + Base_Violation := True; + elsif Digit = E_Digit then + return; + else + Base_Violation := True; + end if; + end if; + + -- If precision limit has been reached, just ignore any remaining + -- digits for the computation of Value and Scale, but store the + -- first in Extra. The scanning should continue only to assess the + -- validity of the string. + + if not Precision_Limit_Reached then + + -- Trailing '0' digits are ignored until a non-zero digit is found + + if Digit = 0 then + Trailing_Zeros := Trailing_Zeros + 1; + + else + -- Handle accumulated zeros. + + for J in 1 .. Trailing_Zeros loop + if Value <= UmaxB then + Value := Value * Uns (Base); + Scale := Scale - 1; + + else + Precision_Limit_Reached := True; + exit; + end if; + end loop; + + -- Reset trailing zero counter + + Trailing_Zeros := 0; + + -- Handle current non zero digit + + Temp := Value * Uns (Base) + Uns (Digit); + + if Value <= Umax + or else (Value <= UmaxB and then Temp <= Precision_Limit) + then + Value := Temp; + Scale := Scale - 1; + + else + Extra := Digit; + Precision_Limit_Reached := True; + end if; + end if; + end if; + + -- Check next character + + Index := Index + 1; + + if Index > Max then + return; + end if; + + Digit := As_Digit (Str (Index)); + + if Digit not in Valid_Digit then + + -- Underscore is only allowed if followed by a digit + + if Digit = Underscore and Index + 1 <= Max then + + Digit := As_Digit (Str (Index + 1)); + if Digit in Valid_Digit then + Index := Index + 1; + else + return; + end if; + + -- Neither a valid underscore nor a digit + + else + return; + end if; + end if; + end loop; + end Scan_Decimal_Digits; + + -------------------------- + -- Scan_Integral_Digits -- + -------------------------- + + procedure Scan_Integral_Digits + (Str : String; + Index : in out Integer; + Max : Integer; + Value : out Uns; + Scale : out Integer; + Extra : out Char_As_Digit; + Base_Violation : in out Boolean; + Base : Unsigned; + Base_Specified : Boolean) + is + pragma Assert (Base in 2 .. 16); + + Umax : constant Uns := (Precision_Limit - Uns (Base) + 1) / Uns (Base); + -- Max value which cannot overflow on accumulating next digit + + UmaxB : constant Uns := Precision_Limit / Uns (Base); + -- Numbers bigger than UmaxB overflow if multiplied by base + + Precision_Limit_Reached : Boolean := False; + -- Set to True if addition of a digit will cause Value to be superior + -- to Precision_Limit. + + Digit : Char_As_Digit; + -- The current digit + + Temp : Uns; + -- Temporary + + begin + -- Initialize Value, Scale and Extra + + Value := 0; + Scale := 0; + Extra := 0; + + -- The function precondition is that the first character is a valid + -- digit. + + Digit := As_Digit (Str (Index)); + + loop + -- Check if base is correct. If the base is not specified, the digit + -- E or e cannot be considered as a base violation as it can be used + -- for exponentiation. + + if Digit >= Base then + if Base_Specified then + Base_Violation := True; + elsif Digit = E_Digit then + return; + else + Base_Violation := True; + end if; + end if; + + -- If precision limit has been reached, just ignore any remaining + -- digits for the computation of Value, but update Scale and store + -- the first in Extra. The scanning should continue only to assess + -- the validity of the string. + + if Precision_Limit_Reached then + Scale := Scale + 1; + + else + Temp := Value * Uns (Base) + Uns (Digit); + + if Value <= Umax + or else (Value <= UmaxB and then Temp <= Precision_Limit) + then + Value := Temp; + + else + Extra := Digit; + Precision_Limit_Reached := True; + Scale := Scale + 1; + end if; + end if; + + -- Look for the next character + + Index := Index + 1; + if Index > Max then + return; + end if; + + Digit := As_Digit (Str (Index)); + + if Digit not in Valid_Digit then + + -- Next character is not a digit. In that case stop scanning + -- unless the next chracter is an underscore followed by a digit. + + if Digit = Underscore and Index + 1 <= Max then + Digit := As_Digit (Str (Index + 1)); + if Digit in Valid_Digit then + Index := Index + 1; + else + return; + end if; + else + return; + end if; + end if; + end loop; + + end Scan_Integral_Digits; + + ------------------- + -- Scan_Raw_Real -- + ------------------- + + function Scan_Raw_Real + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Base : out Unsigned; + Scale : out Integer; + Extra : out Unsigned; + Minus : out Boolean) return Uns + is + After_Point : Boolean; + -- True if a decimal should be parsed + + Base_Char : Character := ASCII.NUL; + -- Character used to set the base. If Nul this means that default + -- base is used. + + Base_Violation : Boolean := False; + -- If True some digits where not in the base. The real is still scanned + -- till the end even if an error will be raised. + + Index : Integer; + -- Local copy of string pointer + + Start : Positive; + -- Position of starting non-blank character + + Value : Uns; + -- Mantissa as an Integer + + begin + -- The default base is 10 + + Base := 10; + + -- 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; + + -- Scan the optional sign + + Scan_Sign (Str, Ptr, Max, Minus, Start); + Index := Ptr.all; + Ptr.all := Start; + + -- First character can be either a decimal digit or a dot + + if Str (Index) in '0' .. '9' then + After_Point := False; + + pragma Annotate + (CodePeer, Intentional, "test always true", "defensive code below"); + + -- If this is a digit it can indicates either the float decimal + -- part or the base to use. + + Scan_Integral_Digits + (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), + Base_Violation, Base, Base_Specified => False); + + -- A dot is allowed only if followed by a digit (RM 3.5(47)) + + elsif Str (Index) = '.' + and then Index < Max + and then Str (Index + 1) in '0' .. '9' + then + After_Point := True; + Index := Index + 1; + Value := 0; + Scale := 0; + Extra := 0; + + else + Bad_Value (Str); + end if; + + -- Check if the first number encountered is a base + + if Index < Max + and then (Str (Index) = '#' or else Str (Index) = ':') + then + Base_Char := Str (Index); + Base := Unsigned (Value); + + if Base < 2 or else Base > 16 then + Base_Violation := True; + Base := 16; + end if; + + Index := Index + 1; + + if Str (Index) = '.' + and then Index < Max + and then As_Digit (Str (Index + 1)) in Valid_Digit + then + After_Point := True; + Index := Index + 1; + Value := 0; + end if; + end if; + + -- Scan the integral part if still necessary + + if Base_Char /= ASCII.NUL and then not After_Point then + if Index > Max or else As_Digit (Str (Index)) not in Valid_Digit then + Bad_Value (Str); + end if; + + Scan_Integral_Digits + (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), + Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL); + end if; + + -- Do we have a dot? + + if not After_Point and then Index <= Max and then Str (Index) = '.' then + + -- At this stage if After_Point was not set, this means that an + -- integral part has been found. Thus the dot is valid even if not + -- followed by a digit. + + if Index < Max and then As_Digit (Str (Index + 1)) in Valid_Digit then + After_Point := True; + end if; + + Index := Index + 1; + end if; + + -- Scan the decimal part + + if After_Point then + Scan_Decimal_Digits + (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), + Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL); + end if; + + -- If an explicit base was specified ensure that the delimiter is found + + if Base_Char /= ASCII.NUL then + if Index > Max or else Str (Index) /= Base_Char then + Bad_Value (Str); + else + Index := Index + 1; + end if; + end if; + + -- Update pointer and scan exponent + + Ptr.all := Index; + Scale := Scale + Scan_Exponent (Str, Ptr, Max, Real => True); + + -- Here is where we check for a bad based number + + if Base_Violation then + Bad_Value (Str); + else + return Value; + end if; + + end Scan_Raw_Real; + + -------------------- + -- Value_Raw_Real -- + -------------------- + + function Value_Raw_Real + (Str : String; + Base : out Unsigned; + Scale : out Integer; + Extra : out Unsigned; + Minus : out Boolean) 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_Raw_Real (NT (Str), Base, Scale, Extra, Minus); + end; + + -- Normal case where Str'Last < Positive'Last + + else + declare + V : Uns; + P : aliased Integer := Str'First; + begin + V := Scan_Raw_Real + (Str, P'Access, Str'Last, Base, Scale, Extra, Minus); + Scan_Trailing_Blanks (Str, P); + return V; + end; + end if; + end Value_Raw_Real; + +end System.Value_R; diff --git a/gcc/ada/libgnat/s-valuer.ads b/gcc/ada/libgnat/s-valuer.ads new file mode 100644 index 00000000000..8d2f3fde11a --- /dev/null +++ b/gcc/ada/libgnat/s-valuer.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning real values for use in +-- Text_IO.Decimal_IO, Fixed_IO, Float_IO and the Value attribute. + +with System.Unsigned_Types; use System.Unsigned_Types; + +generic + + type Uns is mod <>; + + Floating : Boolean; + +package System.Value_R is + pragma Preelaborate; + + function Scan_Raw_Real + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Base : out Unsigned; + Scale : out Integer; + Extra : out Unsigned; + Minus : out Boolean) return Uns; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- real literal 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 real is found after scanning past any initial spaces, then + -- Ptr.all is updated past the last character of the real (but trailing + -- spaces are not scanned out) and the Base, Scale, Extra and Minus out + -- parameters are set; if Val is the result of the call, then the real + -- represented by the literal is equal to + -- + -- (Val * Base + Extra) * (Base ** (Scale - 1)) + -- + -- with the negative sign if Minus is true. + -- + -- If no valid real is found, then Ptr.all points either to an initial + -- non-blank character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid real 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 real literal, + -- 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. + -- + -- 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 Value_Raw_Real + (Str : String; + Base : out Unsigned; + Scale : out Integer; + Extra : out Unsigned; + Minus : out Boolean) return Uns; + -- Used in computing X'Value (Str) where X is a real type. Str is the + -- string argument of the attribute. Constraint_Error is raised if the + -- string is malformed. + +end System.Value_R; diff --git a/gcc/ada/libgnat/system-aix.ads b/gcc/ada/libgnat/system-aix.ads index 5bf603d775f..e346759c0fe 100644 --- a/gcc/ada/libgnat/system-aix.ads +++ b/gcc/ada/libgnat/system-aix.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-darwin-arm.ads b/gcc/ada/libgnat/system-darwin-arm.ads index 70e02a12452..e1af6825068 100644 --- a/gcc/ada/libgnat/system-darwin-arm.ads +++ b/gcc/ada/libgnat/system-darwin-arm.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-darwin-ppc.ads b/gcc/ada/libgnat/system-darwin-ppc.ads index 4947c6cdc25..0b746cc2a9f 100644 --- a/gcc/ada/libgnat/system-darwin-ppc.ads +++ b/gcc/ada/libgnat/system-darwin-ppc.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-darwin-x86.ads b/gcc/ada/libgnat/system-darwin-x86.ads index 828b310671d..e27379e0ee0 100644 --- a/gcc/ada/libgnat/system-darwin-x86.ads +++ b/gcc/ada/libgnat/system-darwin-x86.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-djgpp.ads b/gcc/ada/libgnat/system-djgpp.ads index 68fdb49698a..35d9381fd64 100644 --- a/gcc/ada/libgnat/system-djgpp.ads +++ b/gcc/ada/libgnat/system-djgpp.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-dragonfly-x86_64.ads b/gcc/ada/libgnat/system-dragonfly-x86_64.ads index 6bfb5c49293..80da5afb02e 100644 --- a/gcc/ada/libgnat/system-dragonfly-x86_64.ads +++ b/gcc/ada/libgnat/system-dragonfly-x86_64.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-freebsd.ads b/gcc/ada/libgnat/system-freebsd.ads index d4fe60ea0ad..e8765b82786 100644 --- a/gcc/ada/libgnat/system-freebsd.ads +++ b/gcc/ada/libgnat/system-freebsd.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-hpux-ia64.ads b/gcc/ada/libgnat/system-hpux-ia64.ads index f11edc61652..12252db584d 100644 --- a/gcc/ada/libgnat/system-hpux-ia64.ads +++ b/gcc/ada/libgnat/system-hpux-ia64.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-hpux.ads b/gcc/ada/libgnat/system-hpux.ads index ddf6a82e8bf..71a1668b532 100644 --- a/gcc/ada/libgnat/system-hpux.ads +++ b/gcc/ada/libgnat/system-hpux.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-linux-alpha.ads b/gcc/ada/libgnat/system-linux-alpha.ads index eebe93a0d9f..d639630eec0 100644 --- a/gcc/ada/libgnat/system-linux-alpha.ads +++ b/gcc/ada/libgnat/system-linux-alpha.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 1024.0; diff --git a/gcc/ada/libgnat/system-linux-arm.ads b/gcc/ada/libgnat/system-linux-arm.ads index 4d09d9e2de5..6831aad74ec 100644 --- a/gcc/ada/libgnat/system-linux-arm.ads +++ b/gcc/ada/libgnat/system-linux-arm.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-linux-hppa.ads b/gcc/ada/libgnat/system-linux-hppa.ads index 6bc95413a37..669289db3a7 100644 --- a/gcc/ada/libgnat/system-linux-hppa.ads +++ b/gcc/ada/libgnat/system-linux-hppa.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-linux-ia64.ads b/gcc/ada/libgnat/system-linux-ia64.ads index ae9b49a90be..1dca30c64f0 100644 --- a/gcc/ada/libgnat/system-linux-ia64.ads +++ b/gcc/ada/libgnat/system-linux-ia64.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-linux-m68k.ads b/gcc/ada/libgnat/system-linux-m68k.ads index 3fbd78197b9..6a98466714c 100644 --- a/gcc/ada/libgnat/system-linux-m68k.ads +++ b/gcc/ada/libgnat/system-linux-m68k.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-linux-mips.ads b/gcc/ada/libgnat/system-linux-mips.ads index d760db815b7..8476f900e37 100644 --- a/gcc/ada/libgnat/system-linux-mips.ads +++ b/gcc/ada/libgnat/system-linux-mips.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-linux-ppc.ads b/gcc/ada/libgnat/system-linux-ppc.ads index 0f393707873..9785c9a7d06 100644 --- a/gcc/ada/libgnat/system-linux-ppc.ads +++ b/gcc/ada/libgnat/system-linux-ppc.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-linux-riscv.ads b/gcc/ada/libgnat/system-linux-riscv.ads index 91eddf29dc5..a298bcd0a4a 100644 --- a/gcc/ada/libgnat/system-linux-riscv.ads +++ b/gcc/ada/libgnat/system-linux-riscv.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-linux-s390.ads b/gcc/ada/libgnat/system-linux-s390.ads index 374b938b006..3d80ce7748b 100644 --- a/gcc/ada/libgnat/system-linux-s390.ads +++ b/gcc/ada/libgnat/system-linux-s390.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-linux-sh4.ads b/gcc/ada/libgnat/system-linux-sh4.ads index cd811defb55..6227bdb9f05 100644 --- a/gcc/ada/libgnat/system-linux-sh4.ads +++ b/gcc/ada/libgnat/system-linux-sh4.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-linux-sparc.ads b/gcc/ada/libgnat/system-linux-sparc.ads index e74214bb53c..0549a8510d0 100644 --- a/gcc/ada/libgnat/system-linux-sparc.ads +++ b/gcc/ada/libgnat/system-linux-sparc.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-linux-x86.ads b/gcc/ada/libgnat/system-linux-x86.ads index eb8b5dd68c9..5b2b77fd08f 100644 --- a/gcc/ada/libgnat/system-linux-x86.ads +++ b/gcc/ada/libgnat/system-linux-x86.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-lynxos178-ppc.ads b/gcc/ada/libgnat/system-lynxos178-ppc.ads index cf516e164ac..70de803a73d 100644 --- a/gcc/ada/libgnat/system-lynxos178-ppc.ads +++ b/gcc/ada/libgnat/system-lynxos178-ppc.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-lynxos178-x86.ads b/gcc/ada/libgnat/system-lynxos178-x86.ads index c1514722d81..b14f48b2082 100644 --- a/gcc/ada/libgnat/system-lynxos178-x86.ads +++ b/gcc/ada/libgnat/system-lynxos178-x86.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-mingw.ads b/gcc/ada/libgnat/system-mingw.ads index cf960da4066..c05dee7e61c 100644 --- a/gcc/ada/libgnat/system-mingw.ads +++ b/gcc/ada/libgnat/system-mingw.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-qnx-aarch64.ads b/gcc/ada/libgnat/system-qnx-aarch64.ads index 37b8fd124af..f3316c32366 100644 --- a/gcc/ada/libgnat/system-qnx-aarch64.ads +++ b/gcc/ada/libgnat/system-qnx-aarch64.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.000_001; diff --git a/gcc/ada/libgnat/system-rtems.ads b/gcc/ada/libgnat/system-rtems.ads index 099c234ee6e..8907d9e16e3 100644 --- a/gcc/ada/libgnat/system-rtems.ads +++ b/gcc/ada/libgnat/system-rtems.ads @@ -61,7 +61,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-solaris-sparc.ads b/gcc/ada/libgnat/system-solaris-sparc.ads index 0e1ce016d83..f211eeda8dd 100644 --- a/gcc/ada/libgnat/system-solaris-sparc.ads +++ b/gcc/ada/libgnat/system-solaris-sparc.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-solaris-x86.ads b/gcc/ada/libgnat/system-solaris-x86.ads index 010ce5b3029..82fe6568add 100644 --- a/gcc/ada/libgnat/system-solaris-x86.ads +++ b/gcc/ada/libgnat/system-solaris-x86.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 0.01; diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads index 91806e50835..7412611ceb5 100644 --- a/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp.ads index de139747e07..697f35196b5 100644 --- a/gcc/ada/libgnat/system-vxworks-arm-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks-arm-rtp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-arm.ads b/gcc/ada/libgnat/system-vxworks-arm.ads index fac4e7252e8..5f767b229fe 100644 --- a/gcc/ada/libgnat/system-vxworks-arm.ads +++ b/gcc/ada/libgnat/system-vxworks-arm.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-e500-kernel.ads b/gcc/ada/libgnat/system-vxworks-e500-kernel.ads index cf89c2dc0a8..2d64186eb70 100644 --- a/gcc/ada/libgnat/system-vxworks-e500-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks-e500-kernel.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads index 862f3f676d3..46cd6e718a4 100644 --- a/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp.ads index a3baecb2d39..c232fe018e7 100644 --- a/gcc/ada/libgnat/system-vxworks-e500-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks-e500-rtp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-e500-vthread.ads b/gcc/ada/libgnat/system-vxworks-e500-vthread.ads index fc92958f5d8..929a6421c02 100644 --- a/gcc/ada/libgnat/system-vxworks-e500-vthread.ads +++ b/gcc/ada/libgnat/system-vxworks-e500-vthread.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads index 383c82078ff..63cebb7d8d7 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads b/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads index 53a1f9e5f6f..4347a018312 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads @@ -82,7 +82,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads index aa994131420..469c0f3e588 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads index acb20c48d17..8fba1b0f944 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads b/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads index aca420e72ac..a4f4eb2eb86 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-ppc.ads b/gcc/ada/libgnat/system-vxworks-ppc.ads index 99644ee7f2c..67d936a7a1c 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks-x86-kernel.ads index 3781020fdcc..e4d03446d8e 100644 --- a/gcc/ada/libgnat/system-vxworks-x86-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks-x86-kernel.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads index 374041c21f9..f2a41425c0e 100644 --- a/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp.ads index cff7291619b..d597600a194 100644 --- a/gcc/ada/libgnat/system-vxworks-x86-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks-x86-rtp.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-x86-vthread.ads b/gcc/ada/libgnat/system-vxworks-x86-vthread.ads index 1867196eda5..a1eb8f0f6c7 100644 --- a/gcc/ada/libgnat/system-vxworks-x86-vthread.ads +++ b/gcc/ada/libgnat/system-vxworks-x86-vthread.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks-x86.ads b/gcc/ada/libgnat/system-vxworks-x86.ads index c82a61f29fe..226a3dc8dc7 100644 --- a/gcc/ada/libgnat/system-vxworks-x86.ads +++ b/gcc/ada/libgnat/system-vxworks-x86.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads index 37bf607d600..e2ed214288f 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64.ads b/gcc/ada/libgnat/system-vxworks7-aarch64.ads index c3865008ced..ef1211b3658 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads index 7e2db7ab4f8..2b4c64eba4e 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-arm.ads b/gcc/ada/libgnat/system-vxworks7-arm.ads index fac4e7252e8..5f767b229fe 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads b/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads index e03264ec3f1..4182a1fd87c 100644 --- a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads index a9b33178e6c..d4a303b03b7 100644 --- a/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads b/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads index 3e963d0c80c..c7acf958c2c 100644 --- a/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads index 93b327195ad..71d06b453b5 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads index e5d984b25ea..387961426f3 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads index e96d3037fc4..b5393cd1f53 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads index 90499f63999..94f69eeeabb 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads index 49b22b63ebf..bafa41d3d82 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads @@ -59,7 +59,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads index d7b35dd46de..ae0c39fb0cd 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads index 293ede87417..4681bbaf627 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads index caf458fae15..6b176d1dea1 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads index a5f00ff9a5e..eadf5ee1b84 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads index 05e69e5ab09..a97b80a9290 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads @@ -57,7 +57,7 @@ package System is Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; - Max_Mantissa : constant := 63; + Max_Mantissa : constant := Standard'Max_Integer_Size - 1; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); Tick : constant := 1.0 / 60.0; |