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 | |
| 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.
147 files changed, 7391 insertions, 2350 deletions
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 4774e91fbfc..97792b43e51 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -344,6 +344,7 @@ GNATRTL_NONTASKING_OBJS= \ a-tideio$(objext) \ a-tienau$(objext) \ a-tienio$(objext) \ + a-tifiau$(objext) \ a-tifiio$(objext) \ a-tiflau$(objext) \ a-tiflio$(objext) \ @@ -371,6 +372,7 @@ GNATRTL_NONTASKING_OBJS= \ a-wtedit$(objext) \ a-wtenau$(objext) \ a-wtenio$(objext) \ + a-wtfiau$(objext) \ a-wtfiio$(objext) \ a-wtflau$(objext) \ a-wtflio$(objext) \ @@ -394,6 +396,7 @@ GNATRTL_NONTASKING_OBJS= \ a-ztenau$(objext) \ a-ztenio$(objext) \ a-ztexio$(objext) \ + a-ztfiau$(objext) \ a-ztfiio$(objext) \ a-ztflau$(objext) \ a-ztflio$(objext) \ @@ -520,6 +523,7 @@ GNATRTL_NONTASKING_OBJS= \ s-aomoar$(objext) \ s-aotase$(objext) \ s-aridou$(objext) \ + s-arit32$(objext) \ s-arit64$(objext) \ s-assert$(objext) \ s-atacco$(objext) \ @@ -599,30 +603,41 @@ GNATRTL_NONTASKING_OBJS= \ s-finmas$(objext) \ s-finroo$(objext) \ s-flocon$(objext) \ - s-fore$(objext) \ + s-fode32$(objext) \ + s-fode64$(objext) \ + s-fofi32$(objext) \ + s-fofi64$(objext) \ + s-fore_d$(objext) \ + s-fore_f$(objext) \ + s-forrea$(objext) \ s-gearop$(objext) \ s-genbig$(objext) \ s-geveop$(objext) \ s-gloloc$(objext) \ s-htable$(objext) \ s-imageb$(objext) \ + s-imaged$(objext) \ + s-imagef$(objext) \ s-imagei$(objext) \ s-imageu$(objext) \ s-imagew$(objext) \ + s-imde32$(objext) \ + s-imde64$(objext) \ s-imenne$(objext) \ + s-imfi32$(objext) \ + s-imfi64$(objext) \ s-imgbiu$(objext) \ s-imgboo$(objext) \ s-imgcha$(objext) \ - s-imgdec$(objext) \ s-imgenu$(objext) \ s-imgint$(objext) \ s-imgllb$(objext) \ - s-imglld$(objext) \ s-imglli$(objext) \ s-imgllu$(objext) \ s-imgllw$(objext) \ s-imgrea$(objext) \ s-imguns$(objext) \ + s-imguti$(objext) \ s-imgwch$(objext) \ s-imgwiu$(objext) \ s-io$(objext) \ @@ -736,14 +751,19 @@ GNATRTL_NONTASKING_OBJS= \ s-utf_32$(objext) \ s-valboo$(objext) \ s-valcha$(objext) \ - s-valdec$(objext) \ + s-vade32$(objext) \ + s-vade64$(objext) \ + s-vafi32$(objext) \ + s-vafi64$(objext) \ s-valenu$(objext) \ s-valint$(objext) \ - s-vallld$(objext) \ s-vallli$(objext) \ s-valllu$(objext) \ s-valrea$(objext) \ + s-valued$(objext) \ + s-valuef$(objext) \ s-valuei$(objext) \ + s-valuer$(objext) \ s-valueu$(objext) \ s-valuns$(objext) \ s-valuti$(objext) \ @@ -885,10 +905,17 @@ TRASYM_DWARF_UNIX_OBJS = $(TRASYM_DWARF_COMMON_OBJS) s-mmauni$(objext) TRASYM_DWARF_MINGW_OBJS = $(TRASYM_DWARF_COMMON_OBJS) GNATRTL_128BIT_PAIRS = \ + a-decima.ads<libgnat/a-decima__128.ads \ + a-tideio.adb<libgnat/a-tideio__128.adb \ + a-tifiio.adb<libgnat/a-tifiio__128.adb \ a-tiinio.adb<libgnat/a-tiinio__128.adb \ a-timoio.adb<libgnat/a-timoio__128.adb \ + a-wtdeio.adb<libgnat/a-wtdeio__128.adb \ + a-wtfiio.adb<libgnat/a-wtfiio__128.adb \ a-wtinio.adb<libgnat/a-wtinio__128.adb \ a-wtmoio.adb<libgnat/a-wtmoio__128.adb \ + a-ztdeio.adb<libgnat/a-ztdeio__128.adb \ + a-ztfiio.adb<libgnat/a-ztfiio__128.adb \ a-ztinio.adb<libgnat/a-ztinio__128.adb \ a-ztmoio.adb<libgnat/a-ztmoio__128.adb \ i-cexten.ads<libgnat/i-cexten__128.ads \ @@ -903,6 +930,10 @@ GNATRTL_128BIT_OBJS = \ s-exnllli$(objext) \ s-expllli$(objext) \ s-explllu$(objext) \ + s-fode128$(objext) \ + s-fofi128$(objext) \ + s-imde128$(objext) \ + s-imfi128$(objext) \ s-imglllb$(objext) \ s-imgllli$(objext) \ s-imglllu$(objext) \ @@ -970,6 +1001,8 @@ GNATRTL_128BIT_OBJS = \ s-pack125$(objext) \ s-pack126$(objext) \ s-pack127$(objext) \ + s-vade128$(objext) \ + s-vafi128$(objext) \ s-valllli$(objext) \ s-vallllu$(objext) \ s-widllli$(objext) \ diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index fa335c101b7..36634c79680 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1326,6 +1326,12 @@ package body CStand is Set_Scope (Standard_Integer_64, Standard_Standard); Build_Signed_Integer_Type (Standard_Integer_64, 64); + Standard_Integer_128 := New_Standard_Entity ("integer_128"); + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Integer_128); + Set_Scope (Standard_Integer_128, Standard_Standard); + Build_Signed_Integer_Type (Standard_Integer_128, 128); + -- Standard_*_Unsigned subtypes are not user visible, but they are -- used internally. They are unsigned types with the same length as -- the correspondingly named signed integer types. diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst index 14516e7d523..7dc28c26891 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst @@ -153,16 +153,26 @@ The small is the largest power of two that does not exceed the delta. "What combinations of small, range, and digits are supported for fixed point types. See 3.5.9(10)." -For an ordinary fixed point type, the small must lie in 2.0**(-80) .. 2.0**80 -and the range in -10.0**36 .. 10.0**36; any combination is permitted that -does not result in a mantissa larger than 63 bits. However, if the mantissa -is larger than 53 bits on machines where Long_Long_Float is 64 bits (true -of all architectures except x86), then the output from Text_IO may be -accurate to only 53 bits, rather than the full mantissa. This is because -floating-point conversions may be used to convert fixed point. - -For a decimal fixed point type, the small must lie in 10.0**(-18) .. 10.0**18 -and the digits in 1 .. 18. +For an ordinary fixed point type, on 32-bit platforms, the small must lie in +2.0**(-80) .. 2.0**80 and the range in -9.0E+36 .. 9.0E+36; any combination +is permitted that does not result in a mantissa larger than 63 bits. + +On 64-bit platforms, the small must lie in 2.0**(-127) .. 2.0**127 and the +range in -1.0E+76 .. 1.0E+76; any combination is permitted that does not +result in a mantissa larger than 63 bits, and any combination is permitted +that results in a mantissa between 64 and 127 bits if the small is either +an integer or the reciprocal of an integer. + +If the small is either an integer or the reciprocal of an integer, which +is the case if no ``small`` clause is provided, then the operations of the +fixed point type are entirely implemented by means of integer instructions. +In the other cases, some operations, in particular input and output, may be +implemented by means of floating-point instructions and may be affected by +accuracy issues on architectures other than x86. + +For a decimal fixed point type, on 32-bit platforms, the small must lie in +1.0E-18 .. 1.0E+18 and the digits in 1 .. 18. On 64-bit platforms, the +small must lie in 1.0E-38 .. 1.0E+38 and the digits in 1 .. 38. * "The result of ``Tags.Expanded_Name`` for types declared diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 436de74f557..ad47f48651f 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -67,6 +67,7 @@ with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; with Uname; use Uname; +with Urealp; use Urealp; with Validsw; use Validsw; package body Exp_Attr is @@ -3615,31 +3616,124 @@ package body Exp_Attr is -- expands into - -- Result_Type (System.Fore (Universal_Real (Type'First)), - -- Universal_Real (Type'Last)) + -- System.Fore_xx (ftyp (Typ'First), ftyp (Typ'Last) [,pm]) + + -- For decimal fixed-point types + -- xx = Decimal{32,64,128} + -- ftyp = Integer_{32,64,128} + -- pm = Typ'Scale + + -- For the most common ordinary fixed-point types + -- xx = Fixed{32,64,128} + -- ftyp = Integer_{32,64,128} + -- pm = Typ'Small + -- 1.0 / Typ'Small + + -- For other ordinary fixed-point types + -- xx = Real + -- ftyp = Universal_Real + -- pm = none -- Note that we know that the type is a nonstatic subtype, or Fore would - -- have itself been computed dynamically in Eval_Attribute. + -- have been computed statically in Eval_Attribute. when Attribute_Fore => - Rewrite (N, - Convert_To (Typ, - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Fore), Loc), + declare + Arg_List : List_Id; + Fid : RE_Id; + Ftyp : Entity_Id; - Parameter_Associations => New_List ( - Convert_To (Universal_Real, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), - Attribute_Name => Name_First)), + begin + if Is_Decimal_Fixed_Point_Type (Ptyp) then + if Esize (Ptyp) <= 32 then + Fid := RE_Fore_Decimal32; + Ftyp := RTE (RE_Integer_32); + elsif Esize (Ptyp) <= 64 then + Fid := RE_Fore_Decimal64; + Ftyp := RTE (RE_Integer_64); + else + Fid := RE_Fore_Decimal128; + Ftyp := RTE (RE_Integer_128); + end if; - Convert_To (Universal_Real, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), - Attribute_Name => Name_Last)))))); + else + declare + Num : constant Uint := Norm_Num (Small_Value (Ptyp)); + Den : constant Uint := Norm_Den (Small_Value (Ptyp)); + Max : constant Uint := UI_Max (Num, Den); + Min : constant Uint := UI_Min (Num, Den); + Siz : constant Uint := Esize (Ptyp); - Analyze_And_Resolve (N, Typ); + begin + if Siz <= 32 + and then Min = Uint_1 + and then Max <= Uint_2 ** 31 + then + Fid := RE_Fore_Fixed32; + Ftyp := RTE (RE_Integer_32); + elsif Siz <= 64 + and then Min = Uint_1 + and then Max <= Uint_2 ** 63 + then + Fid := RE_Fore_Fixed64; + Ftyp := RTE (RE_Integer_64); + elsif System_Max_Integer_Size = 128 + and then Min = Uint_1 + and then Max <= Uint_2 ** 127 + then + Fid := RE_Fore_Fixed128; + Ftyp := RTE (RE_Integer_128); + else + Fid := RE_Fore_Real; + Ftyp := Universal_Real; + end if; + end; + end if; + + Arg_List := New_List ( + Convert_To (Ftyp, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_First))); + + Append_To (Arg_List, + Convert_To (Ftyp, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Last))); + + -- For decimal, append Scale and also set to do literal conversion + + if Is_Decimal_Fixed_Point_Type (Ptyp) then + Set_Conversion_OK (First (Arg_List)); + Set_Conversion_OK (Next (First (Arg_List))); + + Append_To (Arg_List, + Make_Integer_Literal (Loc, Scale_Value (Ptyp))); + + -- For ordinary fixed-point types, append Num, Den parameters + -- and also set to do literal conversion + + elsif Fid /= RE_Fore_Real then + Set_Conversion_OK (First (Arg_List)); + Set_Conversion_OK (Next (First (Arg_List))); + + Append_To (Arg_List, + Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Ptyp)))); + + Append_To (Arg_List, + Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Ptyp)))); + end if; + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (Fid), Loc), + Parameter_Associations => Arg_List))); + + Analyze_And_Resolve (N, Typ); + end; -------------- -- Fraction -- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e0a62be1c48..74b8f27eaea 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -11879,33 +11879,20 @@ package body Exp_Ch4 is -- which used to fail when Fix_Val was a bound of the type and -- the 'Small was not a representable number. -- This transformation requires an integer type large enough to - -- accommodate a fixed-point value. This will not be the case - -- in systems where Duration is larger than Long_Integer. + -- accommodate a fixed-point value. if Is_Ordinary_Fixed_Point_Type (Target_Type) and then Is_Floating_Point_Type (Etype (Expr)) - and then RM_Size (Btyp) <= RM_Size (Standard_Long_Integer) + and then RM_Size (Btyp) <= System_Max_Integer_Size and then Nkind (Lo) = N_Real_Literal and then Nkind (Hi) = N_Real_Literal then declare Expr_Id : constant Entity_Id := Make_Temporary (Loc, 'T', Conv); - Int_Type : Entity_Id; + Int_Typ : constant Entity_Id := + Small_Integer_Type_For (RM_Size (Btyp), False); begin - -- Find an integer type of the appropriate size to perform an - -- unchecked conversion to the target fixed-point type. - - if RM_Size (Btyp) > RM_Size (Standard_Integer) then - Int_Type := Standard_Long_Integer; - - elsif RM_Size (Btyp) > RM_Size (Standard_Short_Integer) then - Int_Type := Standard_Integer; - - else - Int_Type := Standard_Short_Integer; - end if; - -- Generate a temporary with the integer value. Required in the -- CCG compiler to ensure that run-time checks reference this -- integer expression (instead of the resulting fixed-point @@ -11915,23 +11902,23 @@ package body Exp_Ch4 is Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Expr_Id, - Object_Definition => New_Occurrence_Of (Int_Type, Loc), + Object_Definition => New_Occurrence_Of (Int_Typ, Loc), Constant_Present => True, Expression => - Convert_To (Int_Type, Expression (Conv)))); + Convert_To (Int_Typ, Expression (Conv)))); -- Create integer objects for range checking of result. Lo_Arg := Unchecked_Convert_To - (Int_Type, New_Occurrence_Of (Expr_Id, Loc)); + (Int_Typ, New_Occurrence_Of (Expr_Id, Loc)); Lo_Val := Make_Integer_Literal (Loc, Corresponding_Integer_Value (Lo)); Hi_Arg := Unchecked_Convert_To - (Int_Type, New_Occurrence_Of (Expr_Id, Loc)); + (Int_Typ, New_Occurrence_Of (Expr_Id, Loc)); Hi_Val := Make_Integer_Literal (Loc, Corresponding_Integer_Value (Hi)); diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 42cf626831d..d6819699c0c 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -40,6 +40,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; +with Ttypes; use Ttypes; with Uintp; use Uintp; with Urealp; use Urealp; @@ -116,9 +117,8 @@ package body Exp_Fixd is -- case the types need not be the same, and Build_Multiply chooses a type -- long enough to hold the product (i.e. twice the size of the longer of -- the two operand types), and both operands are converted to this type. - -- The Etype of the result is also set to this value. However, the result - -- can never overflow Integer_64, so this is the largest type that is ever - -- generated. On return, the resulting node is analyzed and has Etype set. + -- The Etype of the result is also set to this value. On return, the + -- resulting node is analyzed and has Etype set. function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id; -- Builds an N_Op_Rem node from the given left and right operand @@ -194,12 +194,13 @@ package body Exp_Fixd is V : Uint; Negative : Boolean := False) return Node_Id; -- Given a non-negative universal integer value, build a typed integer - -- literal node, using the smallest applicable standard integer type. If - -- and only if Negative is true a negative literal is built. If V exceeds - -- 2**63-1, the largest value allowed for perfect result set scaling - -- factors (see RM G.2.3(22)), then Empty is returned. The node N provides - -- the Sloc value for the constructed literal. The Etype of the resulting - -- literal is correctly set, and it is marked as analyzed. + -- literal node, using the smallest applicable standard integer type. + -- If Negative is true, then a negative literal is built. If V exceeds + -- 2**(System_Max_Integer_Size - 1) - 1, the largest value allowed for + -- perfect result set scaling factors (see RM G.2.3(22)), then Empty is + -- returned. The node N provides the Sloc value for the constructed + -- literal. The Etype of the resulting literal is correctly set, and it + -- is marked as analyzed. function Real_Literal (N : Node_Id; V : Ureal) return Node_Id; -- Build a real literal node from the given value, the Etype of the @@ -347,11 +348,12 @@ package body Exp_Fixd is return L; end if; + -- Otherwise we need to figure out the correct result type size -- First figure out the effective sizes of the operands. Normally -- the effective size of an operand is the RM_Size of the operand. -- But a special case arises with operands whose size is known at -- compile time. In this case, we can use the actual value of the - -- operand to get its size if it would fit signed in 8 or 16 bits. + -- operand to get its size if it would fit in signed 8/16/32 bits. Left_Size := UI_To_Int (RM_Size (Left_Type)); @@ -359,10 +361,12 @@ package body Exp_Fixd is declare Val : constant Uint := Expr_Value (L); begin - if Val < Int'(2 ** 7) then + if Val < Uint_2 ** 7 then Left_Size := 8; - elsif Val < Int'(2 ** 15) then + elsif Val < Uint_2 ** 15 then Left_Size := 16; + elsif Val < Uint_2 ** 31 then + Left_Size := 32; end if; end; end if; @@ -394,8 +398,11 @@ package body Exp_Fixd is elsif Rsize <= 32 then Result_Type := Standard_Integer_32; - else + elsif Rsize <= 64 or else System_Max_Integer_Size < 128 then Result_Type := Standard_Integer_64; + + else + Result_Type := Standard_Integer_128; end if; Rnode := @@ -446,18 +453,17 @@ package body Exp_Fixd is Expr : Node_Id; begin - -- If denominator fits in 64 bits, we can build the operations directly - -- without causing any intermediate overflow, so that's what we do. + -- If the denominator fits in Max_Integer_Size bits, we can build the + -- operations directly without causing any intermediate overflow. - if Nat'Max (Y_Size, Z_Size) <= 32 then - return - Build_Divide (N, X, Build_Multiply (N, Y, Z)); + if 2 * Nat'Max (Y_Size, Z_Size) <= System_Max_Integer_Size then + return Build_Divide (N, X, Build_Multiply (N, Y, Z)); -- Otherwise we use the runtime routine - -- [Qnn : Interfaces.Integer_64, - -- Rnn : Interfaces.Integer_64; - -- Double_Divide (X, Y, Z, Qnn, Rnn, Round); + -- [Qnn : Interfaces.Integer_{64|128}; + -- Rnn : Interfaces.Integer_{64|128}; + -- Double_Divide{64|128} (X, Y, Z, Qnn, Rnn, Round); -- Qnn] else @@ -489,18 +495,18 @@ package body Exp_Fixd is -- Build_Double_Divide_Code -- ------------------------------ - -- If the denominator can be computed in 64-bits, we build + -- If the denominator can be computed in Max_Integer_Size bits, we build -- [Nnn : constant typ := typ (X); -- Dnn : constant typ := typ (Y) * typ (Z) -- Qnn : constant typ := Nnn / Dnn; - -- Rnn : constant typ := Nnn / Dnn; + -- Rnn : constant typ := Nnn rem Dnn; - -- If the numerator cannot be computed in 64 bits, we build + -- If the denominator cannot be computed in Max_Integer_Size bits, we build - -- [Qnn : typ; - -- Rnn : typ; - -- Double_Divide (X, Y, Z, Qnn, Rnn, Round);] + -- [Qnn : Interfaces.Integer_{64|128}; + -- Rnn : Interfaces.Integer_{64|128}; + -- Double_Divide{64|128} (X, Y, Z, Qnn, Rnn, Round);] procedure Build_Double_Divide_Code (N : Node_Id; @@ -514,6 +520,7 @@ package body Exp_Fixd is Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y))); Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z))); + QR_Id : RE_Id; QR_Siz : Nat; QR_Typ : Entity_Id; @@ -524,22 +531,36 @@ package body Exp_Fixd is Rnd : Entity_Id; begin - -- Find type that will allow computation of numerator + -- Find type that will allow computation of denominator QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size)); if QR_Siz <= 16 then QR_Typ := Standard_Integer_16; + QR_Id := RE_Null; + elsif QR_Siz <= 32 then QR_Typ := Standard_Integer_32; + QR_Id := RE_Null; + elsif QR_Siz <= 64 then QR_Typ := Standard_Integer_64; + QR_Id := RE_Null; + + elsif QR_Siz <= 128 and then System_Max_Integer_Size = 128 then + QR_Typ := Standard_Integer_128; + QR_Id := RE_Null; - -- For more than 64, bits, we use the 64-bit integer defined in + -- For more than Max_Integer_Size bits, we use the integer defined in -- Interfaces, so that it can be handled by the runtime routine. - else + elsif System_Max_Integer_Size < 128 then QR_Typ := RTE (RE_Integer_64); + QR_Id := RE_Double_Divide64; + + else + QR_Typ := RTE (RE_Integer_128); + QR_Id := RE_Double_Divide128; end if; -- Define quotient and remainder, and set their Etypes, so @@ -551,9 +572,9 @@ package body Exp_Fixd is Set_Etype (Qnn, QR_Typ); Set_Etype (Rnn, QR_Typ); - -- Case that we can compute the denominator in 64 bits + -- Case that we can compute the denominator in Max_Integer_Size bits - if QR_Siz <= 64 then + if QR_Siz <= System_Max_Integer_Size then -- Create temporaries for numerator and denominator and set Etypes, -- so that New_Occurrence_Of picks them up for Build_xxx calls. @@ -569,16 +590,13 @@ package body Exp_Fixd is Defining_Identifier => Nnn, Object_Definition => New_Occurrence_Of (QR_Typ, Loc), Constant_Present => True, - Expression => Build_Conversion (N, QR_Typ, X)), + Expression => Build_Conversion (N, QR_Typ, X)), Make_Object_Declaration (Loc, Defining_Identifier => Dnn, Object_Definition => New_Occurrence_Of (QR_Typ, Loc), Constant_Present => True, - Expression => - Build_Multiply (N, - Build_Conversion (N, QR_Typ, Y), - Build_Conversion (N, QR_Typ, Z)))); + Expression => Build_Multiply (N, Y, Z))); Quo := Build_Divide (N, @@ -604,8 +622,8 @@ package body Exp_Fixd is New_Occurrence_Of (Nnn, Loc), New_Occurrence_Of (Dnn, Loc)))); - -- Case where denominator does not fit in 64 bits, so we have to - -- call the runtime routine to compute the quotient and remainder + -- Case where denominator does not fit in Max_Integer_Size bits, we have + -- to call the runtime routine to compute the quotient and remainder. else Rnd := Boolean_Literals (Rounded_Result_Set (N)); @@ -620,7 +638,7 @@ package body Exp_Fixd is Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Double_Divide64), Loc), + Name => New_Occurrence_Of (RTE (QR_Id), Loc), Parameter_Associations => New_List ( Build_Conversion (N, QR_Typ, X), Build_Conversion (N, QR_Typ, Y), @@ -674,7 +692,7 @@ package body Exp_Fixd is -- the effective size of an operand is the RM_Size of the operand. -- But a special case arises with operands whose size is known at -- compile time. In this case, we can use the actual value of the - -- operand to get its size if it would fit signed in 8 or 16 bits. + -- operand to get its size if it would fit in signed 8/16/32 bits. Left_Size := UI_To_Int (RM_Size (Left_Type)); @@ -682,10 +700,12 @@ package body Exp_Fixd is declare Val : constant Uint := Expr_Value (L); begin - if Val < Int'(2 ** 7) then + if Val < Uint_2 ** 7 then Left_Size := 8; - elsif Val < Int'(2 ** 15) then + elsif Val < Uint_2 ** 15 then Left_Size := 16; + elsif Val < Uint_2 ** 31 then + Left_Size := 32; end if; end; end if; @@ -718,8 +738,11 @@ package body Exp_Fixd is elsif Rsize <= 32 then Result_Type := Standard_Integer_32; - else + elsif Rsize <= 64 or else System_Max_Integer_Size < 128 then Result_Type := Standard_Integer_64; + + else + Result_Type := Standard_Integer_128; end if; Rnode := @@ -810,18 +833,17 @@ package body Exp_Fixd is Expr : Node_Id; begin - -- If numerator fits in 64 bits, we can build the operations directly - -- without causing any intermediate overflow, so that's what we do. + -- If the numerator fits in Max_Integer_Size bits, we can build the + -- operations directly without causing any intermediate overflow. - if Nat'Max (X_Size, Y_Size) <= 32 then - return - Build_Divide (N, Build_Multiply (N, X, Y), Z); + if 2 * Nat'Max (X_Size, Y_Size) <= System_Max_Integer_Size then + return Build_Divide (N, Build_Multiply (N, X, Y), Z); -- Otherwise we use the runtime routine - -- [Qnn : Integer_64, - -- Rnn : Integer_64; - -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round); + -- [Qnn : Integer_{64|128}, + -- Rnn : Integer_{64|128}; + -- Scaled_Divide{64|128} (X, Y, Z, Qnn, Rnn, Round); -- Qnn] else @@ -850,18 +872,18 @@ package body Exp_Fixd is -- Build_Scaled_Divide_Code -- ------------------------------ - -- If the numerator can be computed in 64-bits, we build + -- If the numerator can be computed in Max_Integer_Size bits, we build -- [Nnn : constant typ := typ (X) * typ (Y); -- Dnn : constant typ := typ (Z) -- Qnn : constant typ := Nnn / Dnn; - -- Rnn : constant typ := Nnn / Dnn; + -- Rnn : constant typ := Nnn rem Dnn; - -- If the numerator cannot be computed in 64 bits, we build + -- If the numerator cannot be computed in Max_Integer_Size bits, we build - -- [Qnn : Interfaces.Integer_64; - -- Rnn : Interfaces.Integer_64; - -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round);] + -- [Qnn : Interfaces.Integer_{64|128}; + -- Rnn : Interfaces.Integer_{64|128}; + -- Scaled_Divide_{64|128} (X, Y, Z, Qnn, Rnn, Round);] procedure Build_Scaled_Divide_Code (N : Node_Id; @@ -875,6 +897,7 @@ package body Exp_Fixd is Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y))); Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z))); + QR_Id : RE_Id; QR_Siz : Nat; QR_Typ : Entity_Id; @@ -887,20 +910,34 @@ package body Exp_Fixd is begin -- Find type that will allow computation of numerator - QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size)); + QR_Siz := Nat'Max (2 * Nat'Max (X_Size, Y_Size), Z_Size); if QR_Siz <= 16 then QR_Typ := Standard_Integer_16; + QR_Id := RE_Null; + elsif QR_Siz <= 32 then QR_Typ := Standard_Integer_32; + QR_Id := RE_Null; + elsif QR_Siz <= 64 then QR_Typ := Standard_Integer_64; + QR_Id := RE_Null; - -- For more than 64, bits, we use the 64-bit integer defined in + elsif QR_Siz <= 128 and then System_Max_Integer_Size = 128 then + QR_Typ := Standard_Integer_128; + QR_Id := RE_Null; + + -- For more than Max_Integer_Size bits, we use the integer defined in -- Interfaces, so that it can be handled by the runtime routine. - else + elsif System_Max_Integer_Size < 128 then QR_Typ := RTE (RE_Integer_64); + QR_Id := RE_Scaled_Divide64; + + else + QR_Typ := RTE (RE_Integer_128); + QR_Id := RE_Scaled_Divide128; end if; -- Define quotient and remainder, and set their Etypes, so @@ -912,9 +949,9 @@ package body Exp_Fixd is Set_Etype (Qnn, QR_Typ); Set_Etype (Rnn, QR_Typ); - -- Case that we can compute the numerator in 64 bits + -- Case that we can compute the numerator in Max_Integer_Size bits - if QR_Siz <= 64 then + if QR_Siz <= System_Max_Integer_Size then Nnn := Make_Temporary (Loc, 'N'); Dnn := Make_Temporary (Loc, 'D'); @@ -928,16 +965,13 @@ package body Exp_Fixd is Defining_Identifier => Nnn, Object_Definition => New_Occurrence_Of (QR_Typ, Loc), Constant_Present => True, - Expression => - Build_Multiply (N, - Build_Conversion (N, QR_Typ, X), - Build_Conversion (N, QR_Typ, Y))), + Expression => Build_Multiply (N, X, Y)), Make_Object_Declaration (Loc, Defining_Identifier => Dnn, Object_Definition => New_Occurrence_Of (QR_Typ, Loc), Constant_Present => True, - Expression => Build_Conversion (N, QR_Typ, Z))); + Expression => Build_Conversion (N, QR_Typ, Z))); Quo := Build_Divide (N, @@ -961,8 +995,8 @@ package body Exp_Fixd is New_Occurrence_Of (Nnn, Loc), New_Occurrence_Of (Dnn, Loc)))); - -- Case where numerator does not fit in 64 bits, so we have to - -- call the runtime routine to compute the quotient and remainder + -- Case where numerator does not fit in Max_Integer_Size bits, we have + -- to call the runtime routine to compute the quotient and remainder. else Rnd := Boolean_Literals (Rounded_Result_Set (N)); @@ -977,7 +1011,7 @@ package body Exp_Fixd is Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Scaled_Divide64), Loc), + Name => New_Occurrence_Of (RTE (QR_Id), Loc), Parameter_Associations => New_List ( Build_Conversion (N, QR_Typ, X), Build_Conversion (N, QR_Typ, Y), @@ -1374,8 +1408,7 @@ package body Exp_Fixd is if Present (Lit_Int) then Set_Result (N, - Build_Multiply (N, Build_Multiply (N, Left, Right), - Lit_Int)); + Build_Multiply (N, Build_Multiply (N, Left, Right), Lit_Int)); return; end if; @@ -2380,6 +2413,9 @@ package body Exp_Fixd is elsif V < Uint_2 ** 63 then T := Standard_Integer_64; + elsif V < Uint_2 ** 127 and then System_Max_Integer_Size = 128 then + T := Standard_Integer_128; + else return Empty; end if; diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 40cb51462b8..d5db5b3f017 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -49,11 +49,6 @@ with Urealp; use Urealp; package body Exp_Imgv is - function Has_Decimal_Small (E : Entity_Id) return Boolean; - -- Applies to all entities. True for a Decimal_Fixed_Point_Type, or an - -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten. - -- Shouldn't this be in einfo.adb or sem_aux.adb??? - procedure Rewrite_Object_Image (N : Node_Id; Pref : Entity_Id; @@ -219,21 +214,13 @@ package body Exp_Imgv is -- xx = Boolean -- tv = Boolean (Expr) - -- For signed integer types with size <= Integer'Size - -- xx = Integer - -- tv = Integer (Expr) - - -- For other signed integer types - -- xx = Long_Long_Integer - -- tv = Long_Long_Integer (Expr) - - -- For modular types with modulus <= System.Unsigned_Types.Unsigned - -- xx = Unsigned - -- tv = System.Unsigned_Types.Unsigned (Expr) + -- For signed integer types + -- xx = [Long_Long_[Long_]]Integer + -- tv = [Long_Long_[Long_]]Integer (Expr) - -- For other modular integer types - -- xx = Long_Long_Unsigned - -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr) + -- For modular types + -- xx = [Long_Long_[Long_]]Unsigned + -- tv = System.Unsigned_Types.[Long_Long_[Long_]]Unsigned (Expr) -- For types whose root type is Wide_Character -- xx = Wide_Character @@ -249,21 +236,24 @@ package body Exp_Imgv is -- tv = Long_Long_Float (Expr) -- pm = typ'Digits (typ = subtype of expression) - -- For ordinary fixed-point types + -- For decimal fixed-point types + -- xx = Decimal{32,64,128} + -- tv = Integer_{32,64,128} (Expr)? [convert with no scaling] + -- pm = typ'Scale (typ = subtype of expression) + + -- For the most common ordinary fixed-point types + -- xx = Fixed{32,64,128} + -- tv = Integer_{32,64,128} (Expr) [convert with no scaling] + -- pm = typ'Small (typ = subtype of expression) + -- 1.0 / typ'Small + -- (Integer_{32,64,128} x typ'Small)'Fore + -- typ'Aft + + -- For other ordinary fixed-point types -- xx = Ordinary_Fixed_Point -- tv = Long_Long_Float (Expr) -- pm = typ'Aft (typ = subtype of expression) - -- For decimal fixed-point types with size = Integer'Size - -- xx = Decimal - -- tv = Integer (Expr) - -- pm = typ'Scale (typ = subtype of expression) - - -- For decimal fixed-point types with size > Integer'Size - -- xx = Long_Long_Decimal - -- tv = Long_Long_Integer?(Expr) [convert with no scaling] - -- pm = typ'Scale (typ = subtype of expression) - -- For enumeration types other than those declared in package Standard -- or System, Snn, Pnn, are expanded as above, but the call looks like: @@ -593,18 +583,50 @@ package body Exp_Imgv is Tent := RTE (RE_Long_Long_Long_Unsigned); end if; - elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then - if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then - Imid := RE_Image_Decimal; - Tent := Standard_Integer; + elsif Is_Decimal_Fixed_Point_Type (Rtyp) then + if Esize (Rtyp) <= 32 then + Imid := RE_Image_Decimal32; + Tent := RTE (RE_Integer_32); + elsif Esize (Rtyp) <= 64 then + Imid := RE_Image_Decimal64; + Tent := RTE (RE_Integer_64); else - Imid := RE_Image_Long_Long_Decimal; - Tent := Standard_Long_Long_Integer; + Imid := RE_Image_Decimal128; + Tent := RTE (RE_Integer_128); end if; elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then - Imid := RE_Image_Ordinary_Fixed_Point; - Tent := Standard_Long_Long_Float; + declare + Num : constant Uint := Norm_Num (Small_Value (Rtyp)); + Den : constant Uint := Norm_Den (Small_Value (Rtyp)); + Max : constant Uint := UI_Max (Num, Den); + Min : constant Uint := UI_Min (Num, Den); + Siz : constant Uint := Esize (Rtyp); + + begin + if Siz <= 32 + and then Min = Uint_1 + and then Max <= Uint_2 ** 31 + then + Imid := RE_Image_Fixed32; + Tent := RTE (RE_Integer_32); + elsif Siz <= 64 + and then Min = Uint_1 + and then Max <= Uint_2 ** 63 + then + Imid := RE_Image_Fixed64; + Tent := RTE (RE_Integer_64); + elsif System_Max_Integer_Size = 128 + and then Min = Uint_1 + and then Max <= Uint_2 ** 127 + then + Imid := RE_Image_Fixed128; + Tent := RTE (RE_Integer_128); + else + Imid := RE_Image_Ordinary_Fixed_Point; + Tent := Standard_Long_Long_Float; + end if; + end; elsif Is_Floating_Point_Type (Rtyp) then Imid := RE_Image_Floating_Point; @@ -746,29 +768,45 @@ package body Exp_Imgv is Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_Digits)); - -- For ordinary fixed-point types, append Aft parameter + -- For decimal, append Scale and also set to do literal conversion - elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then - Append_To (Arg_List, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), - Attribute_Name => Name_Aft)); + elsif Is_Decimal_Fixed_Point_Type (Rtyp) then + Set_Conversion_OK (First (Arg_List)); + + Append_To (Arg_List, Make_Integer_Literal (Loc, Scale_Value (Ptyp))); - if Has_Decimal_Small (Rtyp) then + -- For ordinary fixed-point types, append Num, Den, Fore, Aft parameters + -- and also set to do literal conversion. + + elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then + if Imid /= RE_Image_Ordinary_Fixed_Point then Set_Conversion_OK (First (Arg_List)); - Set_Etype (First (Arg_List), Tent); - end if; - -- For decimal, append Scale and also set to do literal conversion + Append_To (Arg_List, + Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Ptyp)))); - elsif Is_Decimal_Fixed_Point_Type (Rtyp) then - Append_To (Arg_List, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), - Attribute_Name => Name_Scale)); + Append_To (Arg_List, + Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Ptyp)))); - Set_Conversion_OK (First (Arg_List)); - Set_Etype (First (Arg_List), Tent); + -- We want to compute the Fore value for the fixed point type + -- whose mantissa type is Tent and whose small is typ'Small. + + declare + T : Ureal := Uint_2 ** (Esize (Tent) - 1) * Small_Value (Ptyp); + F : Nat := 2; + + begin + while T >= Ureal_10 loop + F := F + 1; + T := T / Ureal_10; + end loop; + + Append_To (Arg_List, + Make_Integer_Literal (Loc, UI_From_Int (F))); + end; + end if; + + Append_To (Arg_List, Make_Integer_Literal (Loc, Aft_Value (Ptyp))); -- For Wide_Character, append Ada 2005 indication @@ -827,35 +865,29 @@ package body Exp_Imgv is -- For types whose root type is Boolean -- xx = Boolean - -- For signed integer types with size <= Integer'Size - -- xx = Integer - - -- For other signed integer types - -- xx = Long_Long_Integer - - -- For modular types with modulus <= System.Unsigned_Types.Unsigned - -- xx = Unsigned + -- For signed integer types + -- xx = [Long_Long_[Long_]]Integer - -- For other modular integer types - -- xx = Long_Long_Unsigned + -- For modular types + -- xx = [Long_Long_[Long_]]Unsigned - -- For floating-point types and ordinary fixed-point types + -- For floating-point types -- xx = Real - -- For Wide_[Wide_]Character types, typ'Value (X) expands into: + -- For decimal fixed-point types, typ'Value (X) expands into - -- btyp (Value_xx (X, EM)) + -- btyp?(Value_Decimal{32,64,128} (X, typ'Scale)); - -- where btyp is the base type of the prefix, and EM is the encoding method + -- For the most common ordinary fixed-point types - -- For decimal types with size <= Integer'Size, typ'Value (X) - -- expands into + -- btyp?(Value_Fixed{32,64,128} (X, S, 1.0 / S)); + -- where S = typ'Small - -- btyp?(Value_Decimal (X, typ'Scale)); + -- For Wide_[Wide_]Character types, typ'Value (X) expands into: - -- For all other decimal types, typ'Value (X) expands into + -- btyp (Value_xx (X, EM)) - -- btyp?(Value_Long_Long_Decimal (X, typ'Scale)) + -- where btyp is the base type of the prefix, and EM is the encoding method -- For enumeration types other than those derived from types Boolean, -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to: @@ -923,16 +955,15 @@ package body Exp_Imgv is end if; elsif Is_Decimal_Fixed_Point_Type (Rtyp) then - if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then - Vid := RE_Value_Decimal; + if Esize (Rtyp) <= 32 and then abs (Scale_Value (Rtyp)) <= 9 then + Vid := RE_Value_Decimal32; + elsif Esize (Rtyp) <= 64 and then abs (Scale_Value (Rtyp)) <= 18 then + Vid := RE_Value_Decimal64; else - Vid := RE_Value_Long_Long_Decimal; + Vid := RE_Value_Decimal128; end if; - Append_To (Args, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Scale)); + Append_To (Args, Make_Integer_Literal (Loc, Scale_Value (Rtyp))); Rewrite (N, OK_Convert_To (Btyp, @@ -944,7 +975,54 @@ package body Exp_Imgv is Analyze_And_Resolve (N, Btyp); return; - elsif Is_Real_Type (Rtyp) then + elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then + declare + Num : constant Uint := Norm_Num (Small_Value (Rtyp)); + Den : constant Uint := Norm_Den (Small_Value (Rtyp)); + Max : constant Uint := UI_Max (Num, Den); + Min : constant Uint := UI_Min (Num, Den); + Siz : constant Uint := Esize (Rtyp); + + begin + if Siz <= 32 + and then Min = Uint_1 + and then Max <= Uint_2 ** 31 + then + Vid := RE_Value_Fixed32; + elsif Siz <= 64 + and then Min = Uint_1 + and then Max <= Uint_2 ** 63 + then + Vid := RE_Value_Fixed64; + elsif System_Max_Integer_Size = 128 + and then Min = Uint_1 + and then Max <= Uint_2 ** 127 + then + Vid := RE_Value_Fixed128; + else + Vid := RE_Value_Real; + end if; + + if Vid /= RE_Value_Real then + Append_To (Args, + Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Rtyp)))); + + Append_To (Args, + Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Rtyp)))); + + Rewrite (N, + OK_Convert_To (Btyp, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Vid), Loc), + Parameter_Associations => Args))); + + Set_Etype (N, Btyp); + Analyze_And_Resolve (N, Btyp); + return; + end if; + end; + + elsif Is_Floating_Point_Type (Rtyp) then Vid := RE_Value_Real; -- Only other possibility is user-defined enumeration type @@ -1286,12 +1364,12 @@ package body Exp_Imgv is -- yy = Boolean -- For signed integer types - -- xx = Width_Long_Long_Integer - -- yy = Long_Long_Integer + -- xx = Width_[Long_Long_[Long_]]Integer + -- yy = [Long_Long_[Long_]]Integer -- For modular integer types - -- xx = Width_Long_Long_Unsigned - -- yy = Long_Long_Unsigned + -- xx = Width_[Long_Long_[Long_]]Unsigned + -- yy = [Long_Long_[Long_]]Unsigned -- For types derived from Wide_Character, typ'Width expands into @@ -1329,7 +1407,11 @@ package body Exp_Imgv is -- Wide_Wide_Character (typ'First), -- Wide_Wide_Character (typ'Last)); - -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into + -- For fixed point types, typ'Width and typ'Wide_[Wide_]Width expand into + + -- if Ptyp'First > Ptyp'Last then 0 else Ptyp'Fore + 1 + Ptyp'Aft end if + + -- and for floating point types, they expand into -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if @@ -1451,9 +1533,41 @@ package body Exp_Imgv is YY := RTE (RE_Long_Long_Long_Unsigned); end if; - -- Real types + -- Fixed point types - elsif Is_Real_Type (Rtyp) then + elsif Is_Fixed_Point_Type (Rtyp) then + Rewrite (N, + Make_If_Expression (Loc, + Expressions => New_List ( + + Make_Op_Gt (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Last)), + + Make_Integer_Literal (Loc, 0), + + Make_Op_Add (Loc, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Fore), + + Make_Op_Add (Loc, + Make_Integer_Literal (Loc, 1), + Make_Integer_Literal (Loc, Aft_Value (Ptyp))))))); + + Analyze_And_Resolve (N, Typ); + return; + + -- Floating point types + + elsif Is_Floating_Point_Type (Rtyp) then Rewrite (N, Make_If_Expression (Loc, Expressions => New_List ( @@ -1680,18 +1794,6 @@ package body Exp_Imgv is Analyze_And_Resolve (N, Typ); end Expand_Width_Attribute; - ----------------------- - -- Has_Decimal_Small -- - ----------------------- - - function Has_Decimal_Small (E : Entity_Id) return Boolean is - begin - return Is_Decimal_Fixed_Point_Type (E) - or else - (Is_Ordinary_Fixed_Point_Type (E) - and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1); - end Has_Decimal_Small; - -------------------------- -- Rewrite_Object_Image -- -------------------------- diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8183252e1e3..ce86fac5615 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6339,35 +6339,6 @@ package body Freeze is if Is_Fixed_Point_Type (E) then Freeze_Fixed_Point_Type (E); - -- Some error checks required for ordinary fixed-point type. Defer - -- these till the freeze-point since we need the small and range - -- values. We only do these checks for base types - - if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then - if Small_Value (E) < Ureal_2_M_80 then - Error_Msg_Name_1 := Name_Small; - Error_Msg_N - ("`&''%` too small, minimum allowed is 2.0'*'*(-80)", E); - - elsif Small_Value (E) > Ureal_2_80 then - Error_Msg_Name_1 := Name_Small; - Error_Msg_N - ("`&''%` too large, maximum allowed is 2.0'*'*80", E); - end if; - - if Expr_Value_R (Type_Low_Bound (E)) < Ureal_M_10_36 then - Error_Msg_Name_1 := Name_First; - Error_Msg_N - ("`&''%` too small, minimum allowed is -10.0'*'*36", E); - end if; - - if Expr_Value_R (Type_High_Bound (E)) > Ureal_10_36 then - Error_Msg_Name_1 := Name_Last; - Error_Msg_N - ("`&''%` too large, maximum allowed is 10.0'*'*36", E); - end if; - end if; - elsif Is_Enumeration_Type (E) then Freeze_Enumeration_Type (E); @@ -8123,6 +8094,12 @@ package body Freeze is -- Returns size of type with given bounds. Also leaves these -- bounds set as the current bounds of the Typ. + function Larger (A, B : Ureal) return Boolean; + -- Returns true if A > B with a margin of Typ'Small + + function Smaller (A, B : Ureal) return Boolean; + -- Returns true if A < B with a margin of Typ'Small + ----------- -- Fsize -- ----------- @@ -8134,6 +8111,24 @@ package body Freeze is return Minimum_Size (Typ); end Fsize; + ------------ + -- Larger -- + ------------ + + function Larger (A, B : Ureal) return Boolean is + begin + return A > B and then A - Small > B; + end Larger; + + ------------- + -- Smaller -- + ------------- + + function Smaller (A, B : Ureal) return Boolean is + begin + return A < B and then A + Small < B; + end Smaller; + -- Start of processing for Freeze_Fixed_Point_Type begin @@ -8155,7 +8150,7 @@ package body Freeze is if Present (Atype) then Set_Esize (Typ, Esize (Atype)); else - Set_Esize (Typ, Esize (Base_Type (Typ))); + Set_Esize (Typ, Esize (Btyp)); end if; end if; @@ -8435,6 +8430,110 @@ package body Freeze is Set_Realval (Hi, Actual_Hi); end Fudge; + -- Enforce some limitations for ordinary fixed-point types. They come + -- from an exact algorithm used to implement Text_IO.Fixed_IO and the + -- Fore, Image and Value attributes. The requirement on the Small is + -- to lie in the range 2**(-(Siz - 1)) .. 2**(Siz - 1) for a type of + -- Siz bits (Siz=32,64,128) and the requirement on the bounds is to + -- be smaller in magnitude than 10.0**N * 2**(Siz - 1), where N is + -- given by the formula N = floor ((Siz - 1) * log 2 / log 10). + + -- If the bounds of a 32-bit type are too large, force 64-bit type + + if Actual_Size <= 32 + and then Small <= Ureal_2_31 + and then (Smaller (Expr_Value_R (Lo), Ureal_M_2_10_18) + or else Larger (Expr_Value_R (Hi), Ureal_2_10_18)) + then + Actual_Size := 33; + end if; + + -- If the bounds of a 64-bit type are too large, force 128-bit type + + if System_Max_Integer_Size = 128 + and then Actual_Size <= 64 + and then Small <= Ureal_2_63 + and then (Smaller (Expr_Value_R (Lo), Ureal_M_9_10_36) + or else Larger (Expr_Value_R (Hi), Ureal_9_10_36)) + then + Actual_Size := 65; + end if; + + -- Give error messages for first subtypes and not base types, as the + -- bounds of base types are always maximum for their size, see below. + + if System_Max_Integer_Size < 128 and then Typ /= Btyp then + + -- See the 128-bit case below for the reason why we cannot test + -- against the 2**(-63) .. 2**63 range. This quirk should have + -- been kludged around as in the 128-bit case below, but it was + -- not and we end up with a ludicrous range as a result??? + + if Small < Ureal_2_M_80 then + Error_Msg_Name_1 := Name_Small; + Error_Msg_N + ("`&''%` too small, minimum allowed is 2.0'*'*(-80)", Typ); + + elsif Small > Ureal_2_80 then + Error_Msg_Name_1 := Name_Small; + Error_Msg_N + ("`&''%` too large, maximum allowed is 2.0'*'*80", Typ); + end if; + + if Smaller (Expr_Value_R (Lo), Ureal_M_9_10_36) then + Error_Msg_Name_1 := Name_First; + Error_Msg_N + ("`&''%` too small, minimum allowed is -9.0E+36", Typ); + end if; + + if Larger (Expr_Value_R (Hi), Ureal_9_10_36) then + Error_Msg_Name_1 := Name_Last; + Error_Msg_N + ("`&''%` too large, maximum allowed is 9.0E+36", Typ); + end if; + + elsif System_Max_Integer_Size = 128 and then Typ /= Btyp then + + -- ACATS c35902d tests a delta equal to 2**(-(Max_Mantissa + 1)) + -- but we cannot really support anything smaller than Fine_Delta + -- because of the way we implement I/O for fixed point types??? + + if Small = Ureal_2_M_128 then + null; + + elsif Small < Ureal_2_M_127 then + Error_Msg_Name_1 := Name_Small; + Error_Msg_N + ("`&''%` too small, minimum allowed is 2.0'*'*(-127)", Typ); + + elsif Small > Ureal_2_127 then + Error_Msg_Name_1 := Name_Small; + Error_Msg_N + ("`&''%` too large, maximum allowed is 2.0'*'*127", Typ); + end if; + + if Actual_Size > 64 + and then Norm_Num (Small) /= Uint_1 + and then Norm_Den (Small) /= Uint_1 + then + Error_Msg_Name_1 := Name_Small; + Error_Msg_N + ("`&''%` not an integer or reciprocal of an integer", Typ); + end if; + + if Smaller (Expr_Value_R (Lo), Ureal_M_10_76) then + Error_Msg_Name_1 := Name_First; + Error_Msg_N + ("`&''%` too small, minimum allowed is -1.0E+76", Typ); + end if; + + if Larger (Expr_Value_R (Hi), Ureal_10_76) then + Error_Msg_Name_1 := Name_Last; + Error_Msg_N + ("`&''%` too large, maximum allowed is 1.0E+76", Typ); + end if; + end if; + -- For the decimal case, none of this fudging is required, since there -- are no end-point problems in the decimal case (the end-points are -- always included). @@ -8446,12 +8545,13 @@ package body Freeze is -- At this stage, the actual size has been calculated and the proper -- required bounds are stored in the low and high bounds. - if Actual_Size > 64 then + if Actual_Size > System_Max_Integer_Size then Error_Msg_Uint_1 := UI_From_Int (Actual_Size); + Error_Msg_Uint_2 := UI_From_Int (System_Max_Integer_Size); Error_Msg_N - ("size required (^) for type& too large, maximum allowed is 64", + ("size required (^) for type& too large, maximum allowed is ^", Typ); - Actual_Size := 64; + Actual_Size := System_Max_Integer_Size; end if; -- Check size against explicit given size @@ -8477,8 +8577,10 @@ package body Freeze is Actual_Size := 16; elsif Actual_Size <= 32 then Actual_Size := 32; - else + elsif Actual_Size <= 64 then Actual_Size := 64; + else + Actual_Size := 128; end if; Init_Esize (Typ, Actual_Size); @@ -8489,7 +8591,7 @@ package body Freeze is -- the full width of the allocated size in bits, to avoid junk range -- checks on intermediate computations. - if Base_Type (Typ) = Typ then + if Typ = Btyp then Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1)))); Set_Realval (Hi, (Small * (Uint_2 ** (Actual_Size - 1) - 1))); end if; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 1169f85a02b..66665206c4c 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -15709,16 +15709,26 @@ The small is the largest power of two that does not exceed the delta. supported for fixed point types. See 3.5.9(10)." @end itemize -For an ordinary fixed point type, the small must lie in 2.0**(-80) .. 2.0**80 -and the range in -10.0**36 .. 10.0**36; any combination is permitted that -does not result in a mantissa larger than 63 bits. However, if the mantissa -is larger than 53 bits on machines where Long_Long_Float is 64 bits (true -of all architectures except x86), then the output from Text_IO may be -accurate to only 53 bits, rather than the full mantissa. This is because -floating-point conversions may be used to convert fixed point. - -For a decimal fixed point type, the small must lie in 10.0**(-18) .. 10.0**18 -and the digits in 1 .. 18. +For an ordinary fixed point type, on 32-bit platforms, the small must lie in +2.0**(-80) .. 2.0**80 and the range in -9.0E+36 .. 9.0E+36; any combination +is permitted that does not result in a mantissa larger than 63 bits. + +On 64-bit platforms, the small must lie in 2.0**(-127) .. 2.0**127 and the +range in -1.0E+76 .. 1.0E+76; any combination is permitted that does not +result in a mantissa larger than 63 bits, and any combination is permitted +that results in a mantissa between 64 and 127 bits if the small is either +an integer or the reciprocal of an integer. + +If the small is either an integer or the reciprocal of an integer, which +is the case if no @code{small} clause is provided, then the operations of the +fixed point type are entirely implemented by means of integer instructions. +In the other cases, some operations, in particular input and output, may be +implemented by means of floating-point instructions and may be affected by +accuracy issues on architectures other than x86. + +For a decimal fixed point type, on 32-bit platforms, the small must lie in +1.0E-18 .. 1.0E+18 and the digits in 1 .. 18. On 64-bit platforms, the +small must lie in 1.0E-38 .. 1.0E+38 and the digits in 1 .. 38. @itemize * 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; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 42578dbef32..c1ea69511cb 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -249,14 +249,24 @@ package Rtsfind is System_Fat_VAX_G_Float, System_Finalization_Masters, System_Finalization_Root, - System_Fore, + System_Fore_Decimal_32, + System_Fore_Decimal_64, + System_Fore_Decimal_128, + System_Fore_Fixed_32, + System_Fore_Fixed_64, + System_Fore_Fixed_128, + System_Fore_Real, System_Img_Bool, System_Img_Char, - System_Img_Dec, + System_Img_Decimal_32, + System_Img_Decimal_64, + System_Img_Decimal_128, System_Img_Enum, System_Img_Enum_New, + System_Img_Fixed_32, + System_Img_Fixed_64, + System_Img_Fixed_128, System_Img_Int, - System_Img_LLD, System_Img_LLI, System_Img_LLLI, System_Img_LLU, @@ -417,10 +427,14 @@ package Rtsfind is System_Unsigned_Types, System_Val_Bool, System_Val_Char, - System_Val_Dec, + System_Val_Decimal_32, + System_Val_Decimal_64, + System_Val_Decimal_128, System_Val_Enum, + System_Val_Fixed_32, + System_Val_Fixed_64, + System_Val_Fixed_128, System_Val_Int, - System_Val_LLD, System_Val_LLI, System_Val_LLLI, System_Val_LLU, @@ -756,8 +770,10 @@ package Rtsfind is RE_Subtract_With_Ovflo_Check64, -- System.Arith_64 RE_Add_With_Ovflo_Check128, -- System.Arith_128 + RE_Double_Divide128, -- System.Arith_128 RE_Multiply_With_Ovflo_Check128, -- System.Arith_128 RE_Subtract_With_Ovflo_Check128, -- System.Arith_128 + RE_Scaled_Divide128, -- System.Arith_128 RE_Create_AST_Handler, -- System.AST_Handling @@ -943,14 +959,30 @@ package Rtsfind is RE_Root_Controlled, -- System.Finalization_Root RE_Root_Controlled_Ptr, -- System.Finalization_Root - RE_Fore, -- System.Fore + RE_Fore_Decimal32, -- System.Fore_Decimal_32 + + RE_Fore_Decimal64, -- System.Fore_Decimal_64 + + RE_Fore_Decimal128, -- System.Fore_Decimal_128 + + RE_Fore_Fixed32, -- System.Fore_Fixed_32 + + RE_Fore_Fixed64, -- System.Fore_Fixed_64 + + RE_Fore_Fixed128, -- System.Fore_Fixed_128 + + RE_Fore_Real, -- System.Fore_Real RE_Image_Boolean, -- System.Img_Bool RE_Image_Character, -- System.Img_Char RE_Image_Character_05, -- System.Img_Char - RE_Image_Decimal, -- System.Img_Dec + RE_Image_Decimal32, -- System.Img_Decimal_32 + + RE_Image_Decimal64, -- System.Img_Decimal_64 + + RE_Image_Decimal128, -- System.Img_Decimal_128 RE_Image_Enumeration_8, -- System.Img_Enum_New RE_Image_Enumeration_16, -- System.Img_Enum_New @@ -958,8 +990,6 @@ package Rtsfind is RE_Image_Integer, -- System.Img_Int - RE_Image_Long_Long_Decimal, -- System.Img_LLD - RE_Image_Long_Long_Integer, -- System.Img_LLI RE_Image_Long_Long_Long_Integer, -- System.Img_LLLI @@ -968,6 +998,10 @@ package Rtsfind is RE_Image_Long_Long_Long_Unsigned, -- System.Img_LLLU + RE_Image_Fixed32, -- System.Img_Fixed_32 + RE_Image_Fixed64, -- System.Img_Fixed_64 + RE_Image_Fixed128, -- System.Img_Fixed_128 + RE_Image_Ordinary_Fixed_Point, -- System.Img_Real RE_Image_Floating_Point, -- System.Img_Real @@ -1991,15 +2025,23 @@ package Rtsfind is RE_Value_Character, -- System.Val_Char - RE_Value_Decimal, -- System.Val_Dec + RE_Value_Decimal32, -- System_Val_Decimal_32 + + RE_Value_Decimal64, -- System_Val_Decimal_64 + + RE_Value_Decimal128, -- System_Val_Decimal_128 RE_Value_Enumeration_8, -- System.Val_Enum RE_Value_Enumeration_16, -- System.Val_Enum RE_Value_Enumeration_32, -- System.Val_Enum - RE_Value_Integer, -- System.Val_Int + RE_Value_Fixed32, -- System_Val_Fixed_32 + + RE_Value_Fixed64, -- System_Val_Fixed_64 - RE_Value_Long_Long_Decimal, -- System.Val_LLD + RE_Value_Fixed128, -- System_Val_Fixed_128 + + RE_Value_Integer, -- System.Val_Int RE_Value_Long_Long_Integer, -- System.Val_LLI @@ -2403,8 +2445,10 @@ package Rtsfind is RE_Subtract_With_Ovflo_Check64 => System_Arith_64, RE_Add_With_Ovflo_Check128 => System_Arith_128, + RE_Double_Divide128 => System_Arith_128, RE_Multiply_With_Ovflo_Check128 => System_Arith_128, RE_Subtract_With_Ovflo_Check128 => System_Arith_128, + RE_Scaled_Divide128 => System_Arith_128, RE_Create_AST_Handler => System_AST_Handling, @@ -2596,14 +2640,30 @@ package Rtsfind is RE_Root_Controlled => System_Finalization_Root, RE_Root_Controlled_Ptr => System_Finalization_Root, - RE_Fore => System_Fore, + RE_Fore_Decimal32 => System_Fore_Decimal_32, + + RE_Fore_Decimal64 => System_Fore_Decimal_64, + + RE_Fore_Decimal128 => System_Fore_Decimal_128, + + RE_Fore_Fixed32 => System_Fore_Fixed_32, + + RE_Fore_Fixed64 => System_Fore_Fixed_64, + + RE_Fore_Fixed128 => System_Fore_Fixed_128, + + RE_Fore_Real => System_Fore_Real, RE_Image_Boolean => System_Img_Bool, RE_Image_Character => System_Img_Char, RE_Image_Character_05 => System_Img_Char, - RE_Image_Decimal => System_Img_Dec, + RE_Image_Decimal32 => System_Img_Decimal_32, + + RE_Image_Decimal64 => System_Img_Decimal_64, + + RE_Image_Decimal128 => System_Img_Decimal_128, RE_Image_Enumeration_8 => System_Img_Enum_New, RE_Image_Enumeration_16 => System_Img_Enum_New, @@ -2611,8 +2671,6 @@ package Rtsfind is RE_Image_Integer => System_Img_Int, - RE_Image_Long_Long_Decimal => System_Img_LLD, - RE_Image_Long_Long_Integer => System_Img_LLI, RE_Image_Long_Long_Long_Integer => System_Img_LLLI, @@ -2621,6 +2679,10 @@ package Rtsfind is RE_Image_Long_Long_Long_Unsigned => System_Img_LLLU, + RE_Image_Fixed32 => System_Img_Fixed_32, + RE_Image_Fixed64 => System_Img_Fixed_64, + RE_Image_Fixed128 => System_Img_Fixed_128, + RE_Image_Ordinary_Fixed_Point => System_Img_Real, RE_Image_Floating_Point => System_Img_Real, @@ -3644,15 +3706,23 @@ package Rtsfind is RE_Value_Character => System_Val_Char, - RE_Value_Decimal => System_Val_Dec, + RE_Value_Decimal32 => System_Val_Decimal_32, + + RE_Value_Decimal64 => System_Val_Decimal_64, + + RE_Value_Decimal128 => System_Val_Decimal_128, RE_Value_Enumeration_8 => System_Val_Enum, RE_Value_Enumeration_16 => System_Val_Enum, RE_Value_Enumeration_32 => System_Val_Enum, - RE_Value_Integer => System_Val_Int, + RE_Value_Fixed32 => System_Val_Fixed_32, + + RE_Value_Fixed64 => System_Val_Fixed_64, - RE_Value_Long_Long_Decimal => System_Val_LLD, + RE_Value_Fixed128 => System_Val_Fixed_128, + + RE_Value_Integer => System_Val_Int, RE_Value_Long_Long_Integer => System_Val_LLI, diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 8085867dee6..f487f734587 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -14945,6 +14945,10 @@ package body Sem_Ch3 is Loc : constant Source_Ptr := Sloc (Def); Digs_Expr : constant Node_Id := Digits_Expression (Def); Delta_Expr : constant Node_Id := Delta_Expression (Def); + Max_Digits : constant Nat := + (if System_Max_Integer_Size = 128 then 38 else 18); + -- Maximum number of digits that can be represented in an integer + Implicit_Base : Entity_Id; Digs_Val : Uint; Delta_Val : Ureal; @@ -14982,9 +14986,10 @@ package body Sem_Ch3 is Scale_Val := Scale_Val + 1; end loop; - if Scale_Val > 18 then - Error_Msg_N ("scale exceeds maximum value of 18", Def); - Scale_Val := UI_From_Int (+18); + if Scale_Val > Max_Digits then + Error_Msg_Uint_1 := UI_From_Int (Max_Digits); + Error_Msg_N ("scale exceeds maximum value of ^", Def); + Scale_Val := UI_From_Int (Max_Digits); end if; else @@ -14993,9 +14998,10 @@ package body Sem_Ch3 is Scale_Val := Scale_Val - 1; end loop; - if Scale_Val < -18 then - Error_Msg_N ("scale is less than minimum value of -18", Def); - Scale_Val := UI_From_Int (-18); + if Scale_Val < -Max_Digits then + Error_Msg_Uint_1 := UI_From_Int (-Max_Digits); + Error_Msg_N ("scale is less than minimum value of ^", Def); + Scale_Val := UI_From_Int (-Max_Digits); end if; end if; @@ -15017,9 +15023,10 @@ package body Sem_Ch3 is Check_Digits_Expression (Digs_Expr); Digs_Val := Expr_Value (Digs_Expr); - if Digs_Val > 18 then - Digs_Val := UI_From_Int (+18); - Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr); + if Digs_Val > Max_Digits then + Error_Msg_Uint_1 := UI_From_Int (Max_Digits); + Error_Msg_N ("digits value out of range, maximum is ^", Digs_Expr); + Digs_Val := UI_From_Int (Max_Digits); end if; Set_Digits_Value (Implicit_Base, Digs_Val); diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads index 5742e51dea2..848239fafb0 100644 --- a/gcc/ada/stand.ads +++ b/gcc/ada/stand.ads @@ -451,10 +451,11 @@ package Stand is -- universal integer and universal real, it is never used for runtime -- calculations). - Standard_Integer_8 : Entity_Id; - Standard_Integer_16 : Entity_Id; - Standard_Integer_32 : Entity_Id; - Standard_Integer_64 : Entity_Id; + Standard_Integer_8 : Entity_Id; + Standard_Integer_16 : Entity_Id; + Standard_Integer_32 : Entity_Id; + Standard_Integer_64 : Entity_Id; + Standard_Integer_128 : Entity_Id; -- These are signed integer types with the indicated sizes. Used for the -- underlying implementation types for fixed-point and enumeration types. diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index abae0cdda90..5f1f759a44e 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -63,6 +63,7 @@ package Uintp is Uint_15 : constant Uint; Uint_16 : constant Uint; Uint_24 : constant Uint; + Uint_31 : constant Uint; Uint_32 : constant Uint; Uint_63 : constant Uint; Uint_64 : constant Uint; @@ -80,9 +81,13 @@ package Uintp is Uint_Minus_8 : constant Uint; Uint_Minus_9 : constant Uint; Uint_Minus_12 : constant Uint; + Uint_Minus_18 : constant Uint; + Uint_Minus_31 : constant Uint; Uint_Minus_36 : constant Uint; Uint_Minus_63 : constant Uint; + Uint_Minus_76 : constant Uint; Uint_Minus_80 : constant Uint; + Uint_Minus_127 : constant Uint; Uint_Minus_128 : constant Uint; type UI_Vector is array (Pos range <>) of Int; @@ -470,6 +475,7 @@ private Uint_15 : constant Uint := Uint (Uint_Direct_Bias + 15); Uint_16 : constant Uint := Uint (Uint_Direct_Bias + 16); Uint_24 : constant Uint := Uint (Uint_Direct_Bias + 24); + Uint_31 : constant Uint := Uint (Uint_Direct_Bias + 31); Uint_32 : constant Uint := Uint (Uint_Direct_Bias + 32); Uint_63 : constant Uint := Uint (Uint_Direct_Bias + 63); Uint_64 : constant Uint := Uint (Uint_Direct_Bias + 64); @@ -487,9 +493,13 @@ private Uint_Minus_8 : constant Uint := Uint (Uint_Direct_Bias - 8); Uint_Minus_9 : constant Uint := Uint (Uint_Direct_Bias - 9); Uint_Minus_12 : constant Uint := Uint (Uint_Direct_Bias - 12); + Uint_Minus_18 : constant Uint := Uint (Uint_Direct_Bias - 18); + Uint_Minus_31 : constant Uint := Uint (Uint_Direct_Bias - 31); Uint_Minus_36 : constant Uint := Uint (Uint_Direct_Bias - 36); Uint_Minus_63 : constant Uint := Uint (Uint_Direct_Bias - 63); + Uint_Minus_76 : constant Uint := Uint (Uint_Direct_Bias - 76); Uint_Minus_80 : constant Uint := Uint (Uint_Direct_Bias - 80); + Uint_Minus_127 : constant Uint := Uint (Uint_Direct_Bias - 127); Uint_Minus_128 : constant Uint := Uint (Uint_Direct_Bias - 128); Uint_Max_Simple_Mul : constant := Uint_Direct_Bias + 2**15; diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb index f45f26133b9..88cb6815e08 100644 --- a/gcc/ada/urealp.adb +++ b/gcc/ada/urealp.adb @@ -73,20 +73,28 @@ package body Urealp is -- The following universal reals are the values returned by the constant -- functions. They are initialized by the initialization procedure. - UR_0 : Ureal; - UR_M_0 : Ureal; - UR_Tenth : Ureal; - UR_Half : Ureal; - UR_1 : Ureal; - UR_2 : Ureal; - UR_10 : Ureal; - UR_10_36 : Ureal; - UR_M_10_36 : Ureal; - UR_100 : Ureal; - UR_2_128 : Ureal; - UR_2_80 : Ureal; - UR_2_M_128 : Ureal; - UR_2_M_80 : Ureal; + UR_0 : Ureal; + UR_M_0 : Ureal; + UR_Tenth : Ureal; + UR_Half : Ureal; + UR_1 : Ureal; + UR_2 : Ureal; + UR_10 : Ureal; + UR_2_10_18 : Ureal; + UR_9_10_36 : Ureal; + UR_10_76 : Ureal; + UR_M_2_10_18 : Ureal; + UR_M_9_10_36 : Ureal; + UR_M_10_76 : Ureal; + UR_100 : Ureal; + UR_2_127 : Ureal; + UR_2_128 : Ureal; + UR_2_31 : Ureal; + UR_2_63 : Ureal; + UR_2_80 : Ureal; + UR_2_M_127 : Ureal; + UR_2_M_128 : Ureal; + UR_2_M_80 : Ureal; Normalized_Real : Ureal := No_Ureal; -- Used to memoize Norm_Num and Norm_Den, if either of these functions @@ -288,20 +296,28 @@ package body Urealp is procedure Initialize is begin Ureals.Init; - UR_0 := UR_From_Components (Uint_0, Uint_1, 0, False); - UR_M_0 := UR_From_Components (Uint_0, Uint_1, 0, True); - UR_Half := UR_From_Components (Uint_1, Uint_1, 2, False); - UR_Tenth := UR_From_Components (Uint_1, Uint_1, 10, False); - UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False); - UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False); - UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False); - UR_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, False); - UR_M_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, True); - UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False); - UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False); - UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False); - UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False); - UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False); + UR_0 := UR_From_Components (Uint_0, Uint_1, 0, False); + UR_M_0 := UR_From_Components (Uint_0, Uint_1, 0, True); + UR_Half := UR_From_Components (Uint_1, Uint_1, 2, False); + UR_Tenth := UR_From_Components (Uint_1, Uint_1, 10, False); + UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False); + UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False); + UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False); + UR_2_10_18 := UR_From_Components (Uint_2, Uint_Minus_18, 10, False); + UR_9_10_36 := UR_From_Components (Uint_9, Uint_Minus_36, 10, False); + UR_10_76 := UR_From_Components (Uint_1, Uint_Minus_76, 10, False); + UR_M_2_10_18 := UR_From_Components (Uint_2, Uint_Minus_18, 10, True); + UR_M_9_10_36 := UR_From_Components (Uint_9, Uint_Minus_36, 10, True); + UR_M_10_76 := UR_From_Components (Uint_1, Uint_Minus_76, 10, True); + UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False); + UR_2_127 := UR_From_Components (Uint_1, Uint_Minus_127, 2, False); + UR_2_M_127 := UR_From_Components (Uint_1, Uint_127, 2, False); + UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False); + UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False); + UR_2_31 := UR_From_Components (Uint_1, Uint_Minus_31, 2, False); + UR_2_63 := UR_From_Components (Uint_1, Uint_Minus_63, 2, False); + UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False); + UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False); end Initialize; ---------------- @@ -1408,14 +1424,6 @@ package body Urealp is UI_Write (Int (UI_Image_Length - 1) - Val.Den, Decimal); end if; - -- Constants in a base other than 10 can still be easily written in - -- normal Ada literal style if the numerator is one. - - elsif Val.Rbase /= 0 and then Val.Num = 1 then - Write_Int (Val.Rbase); - Write_Str ("#1.0#E"); - UI_Write (-Val.Den); - -- Other constants with a base other than 10 are written using one of -- the following forms, depending on the sign of the number and the -- sign of the exponent (= minus denominator value). See that we are @@ -1525,14 +1533,50 @@ package body Urealp is return UR_100; end Ureal_100; + ------------------- + -- Ureal_2_10_18 -- + ------------------- + + function Ureal_2_10_18 return Ureal is + begin + return UR_2_10_18; + end Ureal_2_10_18; + + ------------------- + -- Ureal_9_10_36 -- + ------------------- + + function Ureal_9_10_36 return Ureal is + begin + return UR_9_10_36; + end Ureal_9_10_36; + ----------------- - -- Ureal_10_36 -- + -- Ureal_10_76 -- ----------------- - function Ureal_10_36 return Ureal is + function Ureal_10_76 return Ureal is + begin + return UR_10_76; + end Ureal_10_76; + + ---------------- + -- Ureal_2_31 -- + ---------------- + + function Ureal_2_31 return Ureal is + begin + return UR_2_31; + end Ureal_2_31; + + ---------------- + -- Ureal_2_63 -- + ---------------- + + function Ureal_2_63 return Ureal is begin - return UR_10_36; - end Ureal_10_36; + return UR_2_63; + end Ureal_2_63; ---------------- -- Ureal_2_80 -- @@ -1544,6 +1588,15 @@ package body Urealp is end Ureal_2_80; ----------------- + -- Ureal_2_127 -- + ----------------- + + function Ureal_2_127 return Ureal is + begin + return UR_2_127; + end Ureal_2_127; + + ----------------- -- Ureal_2_128 -- ----------------- @@ -1562,6 +1615,15 @@ package body Urealp is end Ureal_2_M_80; ------------------- + -- Ureal_2_M_127 -- + ------------------- + + function Ureal_2_M_127 return Ureal is + begin + return UR_2_M_127; + end Ureal_2_M_127; + + ------------------- -- Ureal_2_M_128 -- ------------------- @@ -1588,14 +1650,32 @@ package body Urealp is return UR_M_0; end Ureal_M_0; + --------------------- + -- Ureal_M_2_10_18 -- + --------------------- + + function Ureal_M_2_10_18 return Ureal is + begin + return UR_M_2_10_18; + end Ureal_M_2_10_18; + + --------------------- + -- Ureal_M_9_10_36 -- + --------------------- + + function Ureal_M_9_10_36 return Ureal is + begin + return UR_M_9_10_36; + end Ureal_M_9_10_36; + ------------------- - -- Ureal_M_10_36 -- + -- Ureal_M_10_76 -- ------------------- - function Ureal_M_10_36 return Ureal is + function Ureal_M_10_76 return Ureal is begin - return UR_M_10_36; - end Ureal_M_10_36; + return UR_M_10_76; + end Ureal_M_10_76; ----------------- -- Ureal_Tenth -- diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads index 5c511efcd1a..3f747359ee7 100644 --- a/gcc/ada/urealp.ads +++ b/gcc/ada/urealp.ads @@ -106,23 +106,47 @@ package Urealp is function Ureal_100 return Ureal; -- Returns value 100.0 + function Ureal_2_31 return Ureal; + -- Returns value 2.0 ** 31 + + function Ureal_2_63 return Ureal; + -- Returns value 2.0 ** 63 + function Ureal_2_80 return Ureal; -- Returns value 2.0 ** 80 function Ureal_2_M_80 return Ureal; -- Returns value 2.0 ** (-80) + function Ureal_2_127 return Ureal; + -- Returns value 2.0 ** 127 + + function Ureal_2_M_127 return Ureal; + -- Returns value 2.0 ** (-127) + function Ureal_2_128 return Ureal; -- Returns value 2.0 ** 128 function Ureal_2_M_128 return Ureal; -- Returns value 2.0 ** (-128) - function Ureal_10_36 return Ureal; - -- Returns value 10.0 ** 36 + function Ureal_2_10_18 return Ureal; + -- Returns value 2.0 * 10.0 ** 18 + + function Ureal_M_2_10_18 return Ureal; + -- Returns value -2.0 * 10.0 ** 18 + + function Ureal_9_10_36 return Ureal; + -- Returns value 9.0 * 10.0 ** 36 + + function Ureal_M_9_10_36 return Ureal; + -- Returns value -9.0 * 10.0 ** 36 + + function Ureal_10_76 return Ureal; + -- Returns value 10.0 ** 76 - function Ureal_M_10_36 return Ureal; - -- Returns value -10.0 ** 36 + function Ureal_M_10_76 return Ureal; + -- Returns value -10.0 ** 76 ----------------- -- Subprograms -- diff --git a/gcc/testsuite/gnat.dg/multfixed.adb b/gcc/testsuite/gnat.dg/multfixed.adb index 572cd32c748..6eeda8876b6 100644 --- a/gcc/testsuite/gnat.dg/multfixed.adb +++ b/gcc/testsuite/gnat.dg/multfixed.adb @@ -1,6 +1,7 @@ -- { dg-do run } with Ada.Exceptions; use Ada.Exceptions; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; procedure Multfixed is Z : constant := 4387648782261400837.0; @@ -18,7 +19,7 @@ begin raise Program_Error; exception when Exc : Constraint_Error => - if Exception_Message (Exc) /= "System.Arith_64.Impl.Raise_Error: Double arithmetic overflow" then + if Count (Exception_Message (Exc), "overflow") = 0 then raise Program_Error; end if; end Multfixed; |