From: Eric Botcazou Date: Mon, 23 Nov 2020 14:42:08 +0000 (+0100) Subject: [Ada] Implement tiered support for floating-point input operations X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=338e513351c03cf66197e8316a69d5459e52f9ed;p=gcc.git [Ada] Implement tiered support for floating-point input operations gcc/ada/ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Remove s-fatsfl$(objext) and add s-valflt$(objext), s-vallfl$(objext), s-valllf$(objext). * exp_attr.adb (Find_Fat_Info): Merge Short_Float and Float cases. * exp_imgv.adb (Expand_Value_Attribute): Replace RE_Value_Real with RE_Value_Long_Long_Float for fixed-point types and use appropriate base type for floating-point types. * rtsfind.ads (RTU_Id): Remove System_Fat_IEEE_Long_Float, System_Fat_IEEE_Short_Float and System_Val_Real, add System_Val_Flt, System_Val_LFlt and System_Val_LLF. (RE_Id): Remove RE_Attr_IEEE_Long, RE_Fat_IEEE_Long, RE_Attr_IEEE_Short, RE_Fat_IEEE_Short, RE_Attr_Short_Float, add RE_Value_Float, RE_Value_Long_Float, RE_Value_Long_Long_Float, (RE_Unit_Table): Likewise. * libgnat/a-ticoau.ads: Add with clause for Float_Aux and make the package generic. (Get): Change parameter types to Num. (Put): Likewise. (Gets): Likewise. (Puts): Likewise. * libgnat/a-ticoau.adb: Remove clause and renaming for Float_Aux. (Get): Change parameter types to Num. (Gets): Likewise. (Put): Likewise. (Puts): Likewise. Add conversion to Long_Long_Float. * libgnat/a-ticoio.adb: Remove with clause for Ada.Text_IO, add with clause for Float_Aux, add with and use clauses for System.Val_Flt, System.Val_LFlt and System.Val_LLF. Instantiate Float_Aux and Complex_Aux on Float, Long_Float, and Long_Long_Float. (OK_Float): New boolean constant. (OK_Long_Float): Likewise. (Get): Call appropriate Get routine from auxiliary package. (Get): Call appropriate Gets routine from auxiliary package. (Put): Call appropriate Put routine from auxiliary package. (Put): Call appropriate Puts routine from auxiliary package. * libgnat/a-tideau.adb: Remove with and use clause for Float_Aux. * libgnat/a-tifiau.adb: Likewise. * libgnat/a-tifiio.adb: Add with and use clause for System.Val_LLF. Instantiate Float_Aux on Long_Long_Float. (Get): Adjust call to Get routine from auxiliary package. (Get): Adjust call to Gets routine from auxiliary package. (Put): Adjust call to Put routine from auxiliary package. (Put): Adjust call to Puts routine from auxiliary package. * libgnat/a-tifiio__128.adb: Likewise. (Get): Likewise. (Get): Likewise. (Put): Likewise. (Put): Likewise. * libgnat/a-tiflau.ads: Make the package generic. (Get): Change parameter type to Num. (Put): Likewise. (Gets): Likewise. (Puts): Likewise. * libgnat/a-tiflau.adb: Remove clauses for System.Val_Real. (Get): Change parameter type to Num and call Scan routine. (Gets): Likewise. (Load_Real): Move to... (Put): Change parameter type and add conversion to Long_Long_Float. (Puts): Likewise. * libgnat/a-tiflio.adb: Add with and use clauses for System.Val_Flt, System.Val_LFlt and System.Val_LLF. Instantiate Float_Aux on Float, Long_Float and Long_Long_Float. (OK_Float): New boolean constant. (OK_Long_Float): Likewise. (Get): Call appropriate Get routine from auxiliary package. (Get): Call previous variant. (Get): Call appropriate Gets routine from auxiliary package. (Put): Call appropriate Put routine from auxiliary package. (Put): Call previous variant. (Put): Call appropriate Puts routine from auxiliary package. * libgnat/a-tigeau.ads (Load_Real): New procedure. * libgnat/a-tigeau.adb (Load_Real): ...here. * libgnat/a-wtcoau.ads: Add with clause for Float_Aux and make the package generic. (Get): Change parameter types to Num. (Put): Likewise. (Gets): Likewise. (Puts): Likewise. * libgnat/a-wtcoau.adb: Remove clause and renaming for Float_Aux. (Get): Change parameter types to Num. (Gets): Likewise. (Put): Likewise. (Puts): Likewise. Add conversion to Long_Long_Float. * libgnat/a-wtcoio.ads: Remove use clause for Complex_Types and use qualified names throughout accordingly. * libgnat/a-wtcoio.adb: Remove clause for Ada.Unchecked_Conversion, add with clause for Float_Aux, add clauses for System.Val_Flt, System.Val_LFlt and System.Val_LLF. Add clause for Complex_Types. Instantiate Float_Aux and Complex_Aux on Float, Long_Float, and Long_Long_Float. Remove LLF subtype and TFT instantiation. (OK_Float): New boolean constant. (OK_Long_Float): Likewise. (Get): Call appropriate Get routine from auxiliary package. (Get): Call appropriate Gets routine from auxiliary package. (Put): Call appropriate Put routine from auxiliary package. (Put): Call appropriate Puts routine from auxiliary package. * libgnat/a-wtdeau.adb: Remove with and use clause for Float_Aux. * libgnat/a-wtfiau.adb: Likewise. * libgnat/a-wtfiio.adb: Add with and use clause for System.Val_LLF. Instantiate Float_Aux on Long_Long_Float. (Get): Adjust call to Get routine from auxiliary package. (Get): Adjust call to Gets routine from auxiliary package. (Put): Adjust call to Put routine from auxiliary package. (Put): Adjust call to Puts routine from auxiliary package. * libgnat/a-wtfiio__128.adb: Likewise. (Get): Likewise. (Get): Likewise. (Put): Likewise. (Put): Likewise. * libgnat/a-wtflau.ads: Make the package generic. (Get): Change parameter type to Num. (Put): Likewise. (Gets): Likewise. (Puts): Likewise. * libgnat/a-wtflau.adb: Remove clauses for System.Val_Real. (Get): Change parameter type to Num and call Scan routine. Set Ptr parameter lazily. (Gets): Likewise. (Load_Real): Move to... (Put): Change parameter type and add conversion to Long_Long_Float. Bump buffer length to Max_Real_Image_Length. (Puts): Likewise. * libgnat/a-wtflio.adb: Add with and use clauses for System.Val_Flt, System.Val_LFlt and System.Val_LLF. Instantiate Float_Aux on Float, Long_Float and Long_Long_Float. (OK_Float): New boolean constant. (OK_Long_Float): Likewise. (Get): Call appropriate Get routine from auxiliary package. Add pragma Unsuppress (Range_Check) and manual validity check. (Get): Call appropriate Gets routine from auxiliary package. Add pragma Unsuppress (Range_Check) and manual validity check. (Put): Call appropriate Put routine from auxiliary package. (Put): Call appropriate Puts routine from auxiliary package. * libgnat/a-wtgeau.ads (Load_Real): New procedure. * libgnat/a-wtgeau.adb (Load_Real): ...here. * libgnat/a-ztcoau.ads: Add with clause for Float_Aux and make the package generic. (Get): Change parameter types to Num. (Put): Likewise. (Gets): Likewise. (Puts): Likewise. * libgnat/a-ztcoau.adb: Remove clause and renaming for Float_Aux. (Get): Change parameter types to Num. (Gets): Likewise. (Put): Likewise. (Puts): Likewise. Add conversion to Long_Long_Float. * libgnat/a-ztcoio.ads: Remove use clause for Complex_Types and use qualified names throughout accordingly. * libgnat/a-ztcoio.adb: Remove clause for Ada.Unchecked_Conversion, add with clause for Float_Aux, add clauses for System.Val_Flt, System.Val_LFlt and System.Val_LLF. Add clause for Complex_Types. Instantiate Float_Aux and Complex_Aux on Float, Long_Float, and Long_Long_Float. Remove LLF subtype and TFT instantiation. (OK_Float): New boolean constant. (OK_Long_Float): Likewise. (Get): Call appropriate Get routine from auxiliary package. (Get): Call appropriate Gets routine from auxiliary package. (Put): Call appropriate Put routine from auxiliary package. (Put): Call appropriate Puts routine from auxiliary package. * libgnat/a-ztdeau.adb: Remove with and use clause for Float_Aux. * libgnat/a-ztfiau.adb: Likewise. * libgnat/a-ztfiio.adb: Add with and use clause for System.Val_LLF. Instantiate Float_Aux on Long_Long_Float. (Get): Adjust call to Get routine from auxiliary package. (Get): Adjust call to Gets routine from auxiliary package. (Put): Adjust call to Put routine from auxiliary package. (Put): Adjust call to Puts routine from auxiliary package. * libgnat/a-ztfiio__128.adb: Likewise. (Get): Likewise. (Get): Likewise. (Put): Likewise. (Put): Likewise. * libgnat/a-ztflau.ads: Make the package generic. (Get): Change parameter type to Num. (Put): Likewise. (Gets): Likewise. (Puts): Likewise. * libgnat/a-ztflau.adb: Remove clauses for System.Val_Real. (Get): Change parameter type to Num and call Scan routine. Set Ptr parameter lazily. (Gets): Likewise. (Load_Real): Move to... (Put): Change parameter type and add conversion to Long_Long_Float. Bump buffer length to Max_Real_Image_Length. (Puts): Likewise. * libgnat/a-ztflio.adb: Add with and use clauses for System.Val_Flt, System.Val_LFlt and System.Val_LLF. Instantiate Float_Aux on Float, Long_Float and Long_Long_Float. (OK_Float): New boolean constant. (OK_Long_Float): Likewise. (Get): Call appropriate Get routine from auxiliary package. Add pragma Unsuppress (Range_Check) and manual validity check. (Get): Call appropriate Gets routine from auxiliary package. Add pragma Unsuppress (Range_Check) and manual validity check. (Put): Call appropriate Put routine from auxiliary package. (Put): Call appropriate Puts routine from auxiliary package. * libgnat/a-ztgeau.ads (Load_Real): New procedure. * libgnat/a-ztgeau.adb (Load_Real): ...here. * libgnat/s-fatsfl.ads: Delete. * libgnat/s-valflt.ads: New package. * libgnat/s-vallfl.ads: Likewise. * libgnat/s-valllf.ads: Likewise. * libgnat/s-valrea.ads: Make generic. Add assertions, defensive code and clarify intent. (Scan_Real): Change parameter type to Num. (Value_Real): Likewise. * libgnat/s-valrea.adb: Instantiate Value_R on Uns. (Integer_to_Real): Change parameter and result to Num. Call Float_Control.Reset only if the mantissa is 64 bits. Use a divide to compute the final value if the scale is negative. (Scan_Real): Change result to Num. (Value_Real): Likewise. * libgnat/s-valuer.adb: Add assertions, defensive code and clarify intent. (F_Limit): Delete. (I_Limit): Likewise. (Precision_Limit): Always use the integer limit. * libgnat/s-fatgen.adb: Add pragma Annotate. --- diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 64ddc2678df..8c99258f7b8 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -596,7 +596,6 @@ GNATRTL_NONTASKING_OBJS= \ s-fatgen$(objext) \ s-fatlfl$(objext) \ s-fatllf$(objext) \ - s-fatsfl$(objext) \ s-ficobl$(objext) \ s-filatt$(objext) \ s-fileio$(objext) \ @@ -756,7 +755,10 @@ GNATRTL_NONTASKING_OBJS= \ s-vafi32$(objext) \ s-vafi64$(objext) \ s-valenu$(objext) \ + s-valflt$(objext) \ s-valint$(objext) \ + s-vallfl$(objext) \ + s-valllf$(objext) \ s-vallli$(objext) \ s-valllu$(objext) \ s-valrea$(objext) \ diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index ff3d54f7880..7f63a2d88d1 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -8311,27 +8311,25 @@ package body Exp_Attr is -- All we do is use the root type (historically this dealt with -- VAX-float .. to be cleaned up further later ???) - Fat_Type := Rtyp; + if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then + Fat_Type := Standard_Float; + Fat_Pkg := RE_Attr_Float; - if Fat_Type = Standard_Short_Float then - Fat_Pkg := RE_Attr_Short_Float; + elsif Rtyp = Standard_Long_Float then + Fat_Type := Standard_Long_Float; + Fat_Pkg := RE_Attr_Long_Float; - elsif Fat_Type = Standard_Float then - Fat_Pkg := RE_Attr_Float; - - elsif Fat_Type = Standard_Long_Float then - Fat_Pkg := RE_Attr_Long_Float; - - elsif Fat_Type = Standard_Long_Long_Float then - Fat_Pkg := RE_Attr_Long_Long_Float; + elsif Rtyp = Standard_Long_Long_Float then + Fat_Type := Standard_Long_Long_Float; + Fat_Pkg := RE_Attr_Long_Long_Float; -- Universal real (which is its own root type) is treated as being -- equivalent to Standard.Long_Long_Float, since it is defined to -- have the same precision as the longest Float type. - elsif Fat_Type = Universal_Real then + elsif Rtyp = Universal_Real then Fat_Type := Standard_Long_Long_Float; - Fat_Pkg := RE_Attr_Long_Long_Float; + Fat_Pkg := RE_Attr_Long_Long_Float; else raise Program_Error; diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index b79d30afa5b..3faa90f1216 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -1008,10 +1008,10 @@ package body Exp_Imgv is then Vid := RE_Value_Fixed128; else - Vid := RE_Value_Real; + Vid := RE_Value_Long_Long_Float; end if; - if Vid /= RE_Value_Real then + if Vid /= RE_Value_Long_Long_Float then Append_To (Args, Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Rtyp)))); @@ -1031,7 +1031,18 @@ package body Exp_Imgv is end; elsif Is_Floating_Point_Type (Rtyp) then - Vid := RE_Value_Real; + if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then + Vid := RE_Value_Float; + + elsif Rtyp = Standard_Long_Float then + Vid := RE_Value_Long_Float; + + elsif Rtyp = Standard_Long_Long_Float then + Vid := RE_Value_Long_Long_Float; + + else + raise Program_Error; + end if; -- Only other possibility is user-defined enumeration type diff --git a/gcc/ada/libgnat/a-ticoau.adb b/gcc/ada/libgnat/a-ticoau.adb index e4f56dd74e1..cf9430582d5 100644 --- a/gcc/ada/libgnat/a-ticoau.adb +++ b/gcc/ada/libgnat/a-ticoau.adb @@ -30,22 +30,19 @@ ------------------------------------------------------------------------------ with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; -with Ada.Text_IO.Float_Aux; with System.Img_Real; use System.Img_Real; package body Ada.Text_IO.Complex_Aux is - package Aux renames Ada.Text_IO.Float_Aux; - --------- -- Get -- --------- procedure Get (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; + ItemR : out Num; + ItemI : out Num; Width : Field) is Buf : String (1 .. Field'Last); @@ -95,8 +92,8 @@ package body Ada.Text_IO.Complex_Aux is procedure Gets (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; + ItemR : out Num; + ItemI : out Num; Last : out Positive) is Paren : Boolean; @@ -139,8 +136,8 @@ package body Ada.Text_IO.Complex_Aux is procedure Put (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Fore : Field; Aft : Field; Exp : Field) @@ -159,8 +156,8 @@ package body Ada.Text_IO.Complex_Aux is procedure Puts (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Aft : Field; Exp : Field) is @@ -174,9 +171,9 @@ package body Ada.Text_IO.Complex_Aux is -- Both parts are initially converted with a Fore of 0 Rptr := 0; - Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp); + Set_Image_Real (Long_Long_Float (ItemR), R_String, Rptr, 0, Aft, Exp); Iptr := 0; - Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp); + Set_Image_Real (Long_Long_Float (ItemI), I_String, Iptr, 0, Aft, Exp); -- Check room for both parts plus parens plus comma (RM G.1.3(34)) diff --git a/gcc/ada/libgnat/a-ticoau.ads b/gcc/ada/libgnat/a-ticoau.ads index 739dce87383..22555cf3faa 100644 --- a/gcc/ada/libgnat/a-ticoau.ads +++ b/gcc/ada/libgnat/a-ticoau.ads @@ -30,39 +30,46 @@ ------------------------------------------------------------------------------ -- This package contains the routines for Ada.Text_IO.Complex_IO that are --- shared among separate instantiations of this package. The routines in --- this package are identical semantically to those in Complex_IO itself, --- except that the generic parameter Complex has been replaced by separate --- real and imaginary values of type Long_Long_Float, and default parameters --- have been removed because they are supplied explicitly by the calls from --- within the generic template. +-- shared among separate instantiations of this package. The routines in this +-- package are identical semantically to those in Complex_IO, except that the +-- generic parameter Complex has been replaced by separate real and imaginary +-- parameters, and default parameters have been removed because they are +-- supplied explicitly by the calls from within the generic template. + +with Ada.Text_IO.Float_Aux; + +private generic + + type Num is digits <>; + + with package Aux is new Ada.Text_IO.Float_Aux (Num, <>); package Ada.Text_IO.Complex_Aux is procedure Get (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; + ItemR : out Num; + ItemI : out Num; Width : Field); procedure Put (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Fore : Field; Aft : Field; Exp : Field); procedure Gets (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; + ItemR : out Num; + ItemI : out Num; Last : out Positive); procedure Puts (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Aft : Field; Exp : Field); diff --git a/gcc/ada/libgnat/a-ticoio.adb b/gcc/ada/libgnat/a-ticoio.adb index fa52b60b782..e35a745e3fd 100644 --- a/gcc/ada/libgnat/a-ticoio.adb +++ b/gcc/ada/libgnat/a-ticoio.adb @@ -29,18 +29,42 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Text_IO; - with Ada.Text_IO.Complex_Aux; +with Ada.Text_IO.Float_Aux; +with System.Val_Flt; use System.Val_Flt; +with System.Val_LFlt; use System.Val_LFlt; +with System.Val_LLF; use System.Val_LLF; package body Ada.Text_IO.Complex_IO is use Complex_Types; - package Aux renames Ada.Text_IO.Complex_Aux; + package Scalar_Float is new + Ada.Text_IO.Float_Aux (Float, Scan_Float); + + package Scalar_Long_Float is new + Ada.Text_IO.Float_Aux (Long_Float, Scan_Long_Float); + + package Scalar_Long_Long_Float is new + Ada.Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + + package Aux_Float is new + Ada.Text_IO.Complex_Aux (Float, Scalar_Float); + + package Aux_Long_Float is new + Ada.Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float); - subtype LLF is Long_Long_Float; - -- Type used for calls to routines in Aux + package Aux_Long_Long_Float is new + Ada.Text_IO.Complex_Aux (Long_Long_Float, Scalar_Long_Long_Float); + + -- Throughout this generic body, we distinguish between the case where type + -- Float is OK, where type Long_Float is OK and where type Long_Long_Float + -- is needed. These boolean constants are used to test for this, such that + -- only code for the relevant case is included in the instance. + + OK_Float : constant Boolean := Real'Base'Digits <= Float'Digits; + + OK_Long_Float : constant Boolean := Real'Base'Digits <= Long_Float'Digits; --------- -- Get -- @@ -48,14 +72,24 @@ package body Ada.Text_IO.Complex_IO is procedure Get (File : File_Type; - Item : out Complex_Types.Complex; + Item : out Complex; Width : Field := 0) is Real_Item : Real'Base; Imag_Item : Real'Base; begin - Aux.Get (File, LLF (Real_Item), LLF (Imag_Item), Width); + if OK_Float then + Aux_Float.Get (File, Float (Real_Item), Float (Imag_Item), Width); + elsif OK_Long_Float then + Aux_Long_Float.Get + (File, Long_Float (Real_Item), Long_Float (Imag_Item), Width); + else + Aux_Long_Long_Float.Get + (File, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item), + Width); + end if; + Item := (Real_Item, Imag_Item); exception @@ -67,7 +101,7 @@ package body Ada.Text_IO.Complex_IO is --------- procedure Get - (Item : out Complex_Types.Complex; + (Item : out Complex; Width : Field := 0) is begin @@ -80,14 +114,24 @@ package body Ada.Text_IO.Complex_IO is procedure Get (From : String; - Item : out Complex_Types.Complex; + Item : out Complex; Last : out Positive) is Real_Item : Real'Base; Imag_Item : Real'Base; begin - Aux.Gets (From, LLF (Real_Item), LLF (Imag_Item), Last); + if OK_Float then + Aux_Float.Gets (From, Float (Real_Item), Float (Imag_Item), Last); + elsif OK_Long_Float then + Aux_Long_Float.Gets + (From, Long_Float (Real_Item), Long_Float (Imag_Item), Last); + else + Aux_Long_Long_Float.Gets + (From, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item), + Last); + end if; + Item := (Real_Item, Imag_Item); exception @@ -100,13 +144,24 @@ package body Ada.Text_IO.Complex_IO is procedure Put (File : File_Type; - Item : Complex_Types.Complex; + Item : Complex; Fore : Field := Default_Fore; Aft : Field := Default_Aft; Exp : Field := Default_Exp) is begin - Aux.Put (File, LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); + if OK_Float then + Aux_Float.Put + (File, Float (Re (Item)), Float (Im (Item)), Fore, Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Put + (File, Long_Float (Re (Item)), Long_Float (Im (Item)), Fore, Aft, + Exp); + else + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)), + Fore, Aft, Exp); + end if; end Put; --------- @@ -114,7 +169,7 @@ package body Ada.Text_IO.Complex_IO is --------- procedure Put - (Item : Complex_Types.Complex; + (Item : Complex; Fore : Field := Default_Fore; Aft : Field := Default_Aft; Exp : Field := Default_Exp) @@ -129,12 +184,21 @@ package body Ada.Text_IO.Complex_IO is procedure Put (To : out String; - Item : Complex_Types.Complex; + Item : Complex; Aft : Field := Default_Aft; Exp : Field := Default_Exp) is begin - Aux.Puts (To, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); + if OK_Float then + Aux_Float.Puts (To, Float (Re (Item)), Float (Im (Item)), Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Puts + (To, Long_Float (Re (Item)), Long_Float (Im (Item)), Aft, Exp); + else + Aux_Long_Long_Float.Puts + (To, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)), + Aft, Exp); + end if; end Put; end Ada.Text_IO.Complex_IO; diff --git a/gcc/ada/libgnat/a-tideau.adb b/gcc/ada/libgnat/a-tideau.adb index 5878234dde4..ac751c13e1a 100644 --- a/gcc/ada/libgnat/a-tideau.adb +++ b/gcc/ada/libgnat/a-tideau.adb @@ -30,7 +30,6 @@ ------------------------------------------------------------------------------ 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.Decimal_Aux is diff --git a/gcc/ada/libgnat/a-tifiau.adb b/gcc/ada/libgnat/a-tifiau.adb index 92595524feb..c6f4430e7cb 100644 --- a/gcc/ada/libgnat/a-tifiau.adb +++ b/gcc/ada/libgnat/a-tifiau.adb @@ -30,7 +30,6 @@ ------------------------------------------------------------------------------ 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 diff --git a/gcc/ada/libgnat/a-tifiio.adb b/gcc/ada/libgnat/a-tifiio.adb index 61c68ec8ba7..0d9f6a55090 100644 --- a/gcc/ada/libgnat/a-tifiio.adb +++ b/gcc/ada/libgnat/a-tifiio.adb @@ -160,6 +160,7 @@ 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.Val_LLF; use System.Val_LLF; package body Ada.Text_IO.Fixed_IO is @@ -177,6 +178,9 @@ package body Ada.Text_IO.Fixed_IO is package Aux64 is new Ada.Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64); + package Aux_Long_Long_Float is new + Ada.Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + -- Throughout this generic body, we distinguish between the case where type -- Int32 is OK and where type Int64 is OK. These boolean constants are used -- to test for this, such that only code for the relevant case is included @@ -279,7 +283,7 @@ package body Ada.Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Get (File, Long_Long_Float (Item), Width); + Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width); end if; exception @@ -313,7 +317,7 @@ package body Ada.Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Gets (From, Long_Long_Float (Item), Last); + Aux_Long_Long_Float.Gets (From, Long_Long_Float (Item), Last); end if; exception @@ -341,7 +345,8 @@ package body Ada.Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Item), Fore, Aft, Exp); end if; end Put; @@ -371,7 +376,7 @@ package body Ada.Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Puts (To, Long_Long_Float (Item), Aft, Exp); + Aux_Long_Long_Float.Puts (To, Long_Long_Float (Item), Aft, Exp); end if; end Put; diff --git a/gcc/ada/libgnat/a-tifiio__128.adb b/gcc/ada/libgnat/a-tifiio__128.adb index 578beb1fb1c..ba96bd83f25 100644 --- a/gcc/ada/libgnat/a-tifiio__128.adb +++ b/gcc/ada/libgnat/a-tifiio__128.adb @@ -162,6 +162,7 @@ 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.Val_LLF; use System.Val_LLF; package body Ada.Text_IO.Fixed_IO is @@ -183,6 +184,9 @@ package body Ada.Text_IO.Fixed_IO is package Aux128 is new Ada.Text_IO.Fixed_Aux (Int128, Scan_Fixed128, Set_Image_Fixed128); + package Aux_Long_Long_Float is new + Ada.Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + -- Throughout this generic body, we distinguish between the case where type -- Int32 is OK, where type Int64 is OK and where type Int128 is OK. These -- boolean constants are used to test for this, such that only code for the @@ -319,7 +323,7 @@ package body Ada.Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Get (File, Long_Long_Float (Item), Width); + Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width); end if; exception @@ -358,7 +362,7 @@ package body Ada.Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Gets (From, Long_Long_Float (Item), Last); + Aux_Long_Long_Float.Gets (From, Long_Long_Float (Item), Last); end if; exception @@ -390,7 +394,8 @@ package body Ada.Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Item), Fore, Aft, Exp); end if; end Put; @@ -424,7 +429,7 @@ package body Ada.Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Puts (To, Long_Long_Float (Item), Aft, Exp); + Aux_Long_Long_Float.Puts (To, Long_Long_Float (Item), Aft, Exp); end if; end Put; diff --git a/gcc/ada/libgnat/a-tiflau.adb b/gcc/ada/libgnat/a-tiflau.adb index ddb52a5eebf..4955a992f73 100644 --- a/gcc/ada/libgnat/a-tiflau.adb +++ b/gcc/ada/libgnat/a-tiflau.adb @@ -32,7 +32,6 @@ with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; with System.Img_Real; use System.Img_Real; -with System.Val_Real; use System.Val_Real; package body Ada.Text_IO.Float_Aux is @@ -42,7 +41,7 @@ package body Ada.Text_IO.Float_Aux is procedure Get (File : File_Type; - Item : out Long_Long_Float; + Item : out Num; Width : Field) is Buf : String (1 .. Field'Last); @@ -58,7 +57,7 @@ package body Ada.Text_IO.Float_Aux is Ptr := 1; end if; - Item := Scan_Real (Buf, Ptr'Access, Stop); + Item := Scan (Buf, Ptr'Access, Stop); Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get; @@ -68,127 +67,27 @@ package body Ada.Text_IO.Float_Aux is procedure Gets (From : String; - Item : out Long_Long_Float; + Item : out Num; Last : out Positive) is Pos : aliased Integer; begin String_Skip (From, Pos); - Item := Scan_Real (From, Pos'Access, From'Last); + Item := Scan (From, Pos'Access, From'Last); Last := Pos - 1; exception when Constraint_Error => raise Data_Error; end Gets; - --------------- - -- Load_Real -- - --------------- - - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Loaded : Boolean; - - begin - -- Skip initial blanks, and load possible sign - - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - -- Case of .nnnn - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Otherwise must have digits to start - - else - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Based cases. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - - -- Case of nnn#.xxx# - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '#', ':'); - - -- Case of nnn#xxx.[xxx]# or nnn#xxx# - - else - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - end if; - - -- As usual, it seems strange to allow mixed base characters, - -- but that is what ACVC tests expect, see CE3804M, case (3). - - Load (File, Buf, Ptr, '#', ':'); - end if; - - -- Case of nnn.[nnn] or nnn - - else - -- Prevent the potential processing of '.' in cases where the - -- initial digits have a trailing underscore. - - if Buf (Ptr) = '_' then - return; - end if; - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr); - end if; - end if; - end if; - - -- Deal with exponent - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end Load_Real; - --------- -- Put -- --------- procedure Put (File : File_Type; - Item : Long_Long_Float; + Item : Num; Fore : Field; Aft : Field; Exp : Field) @@ -197,7 +96,7 @@ package body Ada.Text_IO.Float_Aux is Ptr : Natural := 0; begin - Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); + Set_Image_Real (Long_Long_Float (Item), Buf, Ptr, Fore, Aft, Exp); Put_Item (File, Buf (1 .. Ptr)); end Put; @@ -207,7 +106,7 @@ package body Ada.Text_IO.Float_Aux is procedure Puts (To : out String; - Item : Long_Long_Float; + Item : Num; Aft : Field; Exp : Field) is @@ -215,7 +114,8 @@ package body Ada.Text_IO.Float_Aux is Ptr : Natural := 0; begin - Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); + Set_Image_Real + (Long_Long_Float (Item), Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); if Ptr > To'Length then raise Layout_Error; diff --git a/gcc/ada/libgnat/a-tiflau.ads b/gcc/ada/libgnat/a-tiflau.ads index 68ac9ebffe6..2dfe76da974 100644 --- a/gcc/ada/libgnat/a-tiflau.ads +++ b/gcc/ada/libgnat/a-tiflau.ads @@ -31,41 +31,42 @@ -- This package contains the routines for Ada.Text_IO.Float_IO that are -- shared among separate instantiations of this package. The routines in --- this package are identical semantically to those in Float_IO itself, --- except that generic parameter Num has been replaced by Long_Long_Float, --- and the default parameters have been removed because they are supplied +-- this package are identical semantically to those in Float_IO, except +-- that the default parameters have been removed because they are supplied -- explicitly by the calls from within the generic template. This package --- is also used by Ada.Text_IO.Fixed_IO, and Ada.Text_IO.Decimal_IO. +-- is also used by Ada.Text_IO.Fixed_IO and Ada.Text_IO.Decimal_IO. -private package Ada.Text_IO.Float_Aux is +private generic - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load a possibly signed - -- real literal value from the input file into Buf, starting at Ptr + 1. + type Num is digits <>; + + with function Scan + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Num; + +package Ada.Text_IO.Float_Aux is procedure Get (File : File_Type; - Item : out Long_Long_Float; + Item : out Num; Width : Field); procedure Put (File : File_Type; - Item : Long_Long_Float; + Item : Num; Fore : Field; Aft : Field; Exp : Field); procedure Gets (From : String; - Item : out Long_Long_Float; + Item : out Num; Last : out Positive); procedure Puts (To : out String; - Item : Long_Long_Float; + Item : Num; Aft : Field; Exp : Field); diff --git a/gcc/ada/libgnat/a-tiflio.adb b/gcc/ada/libgnat/a-tiflio.adb index 8da79f102f1..db1cea2dcd0 100644 --- a/gcc/ada/libgnat/a-tiflio.adb +++ b/gcc/ada/libgnat/a-tiflio.adb @@ -30,10 +30,29 @@ ------------------------------------------------------------------------------ with Ada.Text_IO.Float_Aux; +with System.Val_Flt; use System.Val_Flt; +with System.Val_LFlt; use System.Val_LFlt; +with System.Val_LLF; use System.Val_LLF; package body Ada.Text_IO.Float_IO with SPARK_Mode => Off is - package Aux renames Ada.Text_IO.Float_Aux; + package Aux_Float is new + Ada.Text_IO.Float_Aux (Float, Scan_Float); + + package Aux_Long_Float is new + Ada.Text_IO.Float_Aux (Long_Float, Scan_Long_Float); + + package Aux_Long_Long_Float is new + Ada.Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + + -- Throughout this generic body, we distinguish between the case where type + -- Float is OK, where type Long_Float is OK and where type Long_Long_Float + -- is needed. These boolean constants are used to test for this, such that + -- only code for the relevant case is included in the instance. + + OK_Float : constant Boolean := Num'Base'Digits <= Float'Digits; + + OK_Long_Float : constant Boolean := Num'Base'Digits <= Long_Float'Digits; --------- -- Get -- @@ -47,7 +66,13 @@ package body Ada.Text_IO.Float_IO with SPARK_Mode => Off is pragma Unsuppress (Range_Check); begin - Aux.Get (File, Long_Long_Float (Item), Width); + if OK_Float then + Aux_Float.Get (File, Float (Item), Width); + elsif OK_Long_Float then + Aux_Long_Float.Get (File, Long_Float (Item), Width); + else + Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width); + end if; -- In the case where the type is unconstrained (e.g. Standard'Float), -- the above conversion may result in an infinite value, which is @@ -66,22 +91,8 @@ package body Ada.Text_IO.Float_IO with SPARK_Mode => Off is (Item : out Num; Width : Field := 0) is - pragma Unsuppress (Range_Check); - begin - Aux.Get (Current_In, Long_Long_Float (Item), Width); - - -- In the case where the type is unconstrained (e.g. Standard'Float), - -- the above conversion may result in an infinite value, which is - -- normally fine for a conversion, but in this case, we want to treat - -- that as a data error. - - if not Item'Valid then - raise Data_Error; - end if; - - exception - when Constraint_Error => raise Data_Error; + Get (Current_In, Item, Width); end Get; procedure Get @@ -92,7 +103,13 @@ package body Ada.Text_IO.Float_IO with SPARK_Mode => Off is pragma Unsuppress (Range_Check); begin - Aux.Gets (From, Long_Long_Float (Item), Last); + if OK_Float then + Aux_Float.Gets (From, Float (Item), Last); + elsif OK_Long_Float then + Aux_Long_Float.Gets (From, Long_Float (Item), Last); + else + Aux_Long_Long_Float.Gets (From, Long_Long_Float (Item), Last); + end if; -- In the case where the type is unconstrained (e.g. Standard'Float), -- the above conversion may result in an infinite value, which is @@ -119,7 +136,14 @@ package body Ada.Text_IO.Float_IO with SPARK_Mode => Off is Exp : Field := Default_Exp) is begin - Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + if OK_Float then + Aux_Float.Put (File, Float (Item), Fore, Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp); + else + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Item), Fore, Aft, Exp); + end if; end Put; procedure Put @@ -129,7 +153,7 @@ package body Ada.Text_IO.Float_IO with SPARK_Mode => Off is Exp : Field := Default_Exp) is begin - Aux.Put (Current_Out, Long_Long_Float (Item), Fore, Aft, Exp); + Put (Current_Out, Item, Fore, Aft, Exp); end Put; procedure Put @@ -139,7 +163,13 @@ package body Ada.Text_IO.Float_IO with SPARK_Mode => Off is Exp : Field := Default_Exp) is begin - Aux.Puts (To, Long_Long_Float (Item), Aft, Exp); + if OK_Float then + Aux_Float.Puts (To, Float (Item), Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Puts (To, Long_Float (Item), Aft, Exp); + else + Aux_Long_Long_Float.Puts (To, Long_Long_Float (Item), Aft, Exp); + end if; end Put; end Ada.Text_IO.Float_IO; diff --git a/gcc/ada/libgnat/a-tigeau.adb b/gcc/ada/libgnat/a-tigeau.adb index f1ba60a6839..5e13dae20ba 100644 --- a/gcc/ada/libgnat/a-tigeau.adb +++ b/gcc/ada/libgnat/a-tigeau.adb @@ -376,6 +376,106 @@ package body Ada.Text_IO.Generic_Aux is end if; end Load_Integer; + --------------- + -- Load_Real -- + --------------- + + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Loaded : Boolean; + + begin + -- Skip initial blanks, and load possible sign + + Load_Skip (File); + Load (File, Buf, Ptr, '+', '-'); + + -- Case of .nnnn + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Otherwise must have digits to start + + else + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Based cases. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + + -- Case of nnn#.xxx# + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '#', ':'); + + -- Case of nnn#xxx.[xxx]# or nnn#xxx# + + else + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + end if; + + -- As usual, it seems strange to allow mixed base characters, + -- but that is what ACVC tests expect, see CE3804M, case (3). + + Load (File, Buf, Ptr, '#', ':'); + end if; + + -- Case of nnn.[nnn] or nnn + + else + -- Prevent the potential processing of '.' in cases where the + -- initial digits have a trailing underscore. + + if Buf (Ptr) = '_' then + return; + end if; + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr); + end if; + end if; + end if; + + -- Deal with exponent + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end Load_Real; + --------------- -- Load_Skip -- --------------- diff --git a/gcc/ada/libgnat/a-tigeau.ads b/gcc/ada/libgnat/a-tigeau.ads index 09334b371dd..d6acd8db32a 100644 --- a/gcc/ada/libgnat/a-tigeau.ads +++ b/gcc/ada/libgnat/a-tigeau.ads @@ -156,6 +156,12 @@ private package Ada.Text_IO.Generic_Aux is Ptr : in out Natural); -- Loads a possibly signed integer literal value + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- Loads a possibly signed real literal value + function Nextc (File : File_Type) return Integer; -- Like Getc, but includes a call to Ungetc, so that the file -- pointer is not moved by the call. diff --git a/gcc/ada/libgnat/a-wtcoau.adb b/gcc/ada/libgnat/a-wtcoau.adb index a60336b3d5d..05a6d9d1ebc 100644 --- a/gcc/ada/libgnat/a-wtcoau.adb +++ b/gcc/ada/libgnat/a-wtcoau.adb @@ -30,22 +30,19 @@ ------------------------------------------------------------------------------ with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; -with Ada.Wide_Text_IO.Float_Aux; with System.Img_Real; use System.Img_Real; package body Ada.Wide_Text_IO.Complex_Aux is - package Aux renames Ada.Wide_Text_IO.Float_Aux; - --------- -- Get -- --------- procedure Get (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; + ItemR : out Num; + ItemI : out Num; Width : Field) is Buf : String (1 .. Field'Last); @@ -95,8 +92,8 @@ package body Ada.Wide_Text_IO.Complex_Aux is procedure Gets (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; + ItemR : out Num; + ItemI : out Num; Last : out Positive) is Paren : Boolean; @@ -139,8 +136,8 @@ package body Ada.Wide_Text_IO.Complex_Aux is procedure Put (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Fore : Field; Aft : Field; Exp : Field) @@ -159,8 +156,8 @@ package body Ada.Wide_Text_IO.Complex_Aux is procedure Puts (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Aft : Field; Exp : Field) is @@ -174,9 +171,9 @@ package body Ada.Wide_Text_IO.Complex_Aux is -- Both parts are initially converted with a Fore of 0 Rptr := 0; - Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp); + Set_Image_Real (Long_Long_Float (ItemR), R_String, Rptr, 0, Aft, Exp); Iptr := 0; - Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp); + Set_Image_Real (Long_Long_Float (ItemI), I_String, Iptr, 0, Aft, Exp); -- Check room for both parts plus parens plus comma (RM G.1.3(34)) diff --git a/gcc/ada/libgnat/a-wtcoau.ads b/gcc/ada/libgnat/a-wtcoau.ads index 781dd8dc945..affb969548a 100644 --- a/gcc/ada/libgnat/a-wtcoau.ads +++ b/gcc/ada/libgnat/a-wtcoau.ads @@ -29,40 +29,47 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routines for Ada.Wide_Text_IO.Complex_IO that --- are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Complex_IO itself, --- except that the generic parameter Complex has been replaced by separate --- real and imaginary values of type Long_Long_Float, and default parameters --- have been removed because they are supplied explicitly by the calls from --- within the generic template. +-- This package contains the routines for Ada.Wide_Text_IO.Complex_IO that are +-- shared among separate instantiations of this package. The routines in this +-- package are identical semantically to those in Complex_IO, except that the +-- generic parameter Complex has been replaced by separate real and imaginary +-- parameters, and default parameters have been removed because they are +-- supplied explicitly by the calls from within the generic template. + +with Ada.Wide_Text_IO.Float_Aux; + +private generic + + type Num is digits <>; + + with package Aux is new Ada.Wide_Text_IO.Float_Aux (Num, <>); package Ada.Wide_Text_IO.Complex_Aux is procedure Get (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; + ItemR : out Num; + ItemI : out Num; Width : Field); - procedure Gets - (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Last : out Positive); - procedure Put (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Fore : Field; Aft : Field; Exp : Field); + procedure Gets + (From : String; + ItemR : out Num; + ItemI : out Num; + Last : out Positive); + procedure Puts (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Aft : Field; Exp : Field); diff --git a/gcc/ada/libgnat/a-wtcoio.adb b/gcc/ada/libgnat/a-wtcoio.adb index 1dc4a2e2f2c..8e9ff7af385 100644 --- a/gcc/ada/libgnat/a-wtcoio.adb +++ b/gcc/ada/libgnat/a-wtcoio.adb @@ -30,24 +30,43 @@ ------------------------------------------------------------------------------ with Ada.Wide_Text_IO.Complex_Aux; +with Ada.Wide_Text_IO.Float_Aux; +with System.Val_Flt; use System.Val_Flt; +with System.Val_LFlt; use System.Val_LFlt; +with System.Val_LLF; use System.Val_LLF; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; +package body Ada.Wide_Text_IO.Complex_IO is -with Ada.Unchecked_Conversion; + use Complex_Types; -package body Ada.Wide_Text_IO.Complex_IO is + package Scalar_Float is new + Ada.Wide_Text_IO.Float_Aux (Float, Scan_Float); + + package Scalar_Long_Float is new + Ada.Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float); + + package Scalar_Long_Long_Float is new + Ada.Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + + package Aux_Float is new + Ada.Wide_Text_IO.Complex_Aux (Float, Scalar_Float); - package Aux renames Ada.Wide_Text_IO.Complex_Aux; + package Aux_Long_Float is new + Ada.Wide_Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float); - subtype LLF is Long_Long_Float; - -- Type used for calls to routines in Aux + package Aux_Long_Long_Float is new + Ada.Wide_Text_IO.Complex_Aux (Long_Long_Float, Scalar_Long_Long_Float); - function TFT is new - Ada.Unchecked_Conversion (File_Type, Ada.Wide_Text_IO.File_Type); - -- This unchecked conversion is to get around a visibility bug in - -- GNAT version 2.04w. It should be possible to simply use the - -- subtype declared above and do normal checked conversions. + -- Throughout this generic body, we distinguish between the case where type + -- Float is OK, where type Long_Float is OK and where type Long_Long_Float + -- is needed. These boolean constants are used to test for this, such that + -- only code for the relevant case is included in the instance. + + OK_Float : constant Boolean := Real'Base'Digits <= Float'Digits; + + OK_Long_Float : constant Boolean := Real'Base'Digits <= Long_Float'Digits; --------- -- Get -- @@ -62,7 +81,17 @@ package body Ada.Wide_Text_IO.Complex_IO is Imag_Item : Real'Base; begin - Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width); + if OK_Float then + Aux_Float.Get (File, Float (Real_Item), Float (Imag_Item), Width); + elsif OK_Long_Float then + Aux_Long_Float.Get + (File, Long_Float (Real_Item), Long_Float (Imag_Item), Width); + else + Aux_Long_Long_Float.Get + (File, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item), + Width); + end if; + Item := (Real_Item, Imag_Item); exception @@ -100,7 +129,17 @@ package body Ada.Wide_Text_IO.Complex_IO is -- Aux.Gets will raise Data_Error in any case. begin - Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last); + if OK_Float then + Aux_Float.Gets (S, Float (Real_Item), Float (Imag_Item), Last); + elsif OK_Long_Float then + Aux_Long_Float.Gets + (S, Long_Float (Real_Item), Long_Float (Imag_Item), Last); + else + Aux_Long_Long_Float.Gets + (S, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item), + Last); + end if; + Item := (Real_Item, Imag_Item); exception @@ -119,7 +158,18 @@ package body Ada.Wide_Text_IO.Complex_IO is Exp : Field := Default_Exp) is begin - Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); + if OK_Float then + Aux_Float.Put + (File, Float (Re (Item)), Float (Im (Item)), Fore, Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Put + (File, Long_Float (Re (Item)), Long_Float (Im (Item)), Fore, Aft, + Exp); + else + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)), + Fore, Aft, Exp); + end if; end Put; --------- @@ -149,7 +199,16 @@ package body Ada.Wide_Text_IO.Complex_IO is S : String (To'First .. To'Last); begin - Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); + if OK_Float then + Aux_Float.Puts (S, Float (Re (Item)), Float (Im (Item)), Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Puts + (S, Long_Float (Re (Item)), Long_Float (Im (Item)), Aft, Exp); + else + Aux_Long_Long_Float.Puts + (S, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)), + Aft, Exp); + end if; for J in S'Range loop To (J) := Wide_Character'Val (Character'Pos (S (J))); diff --git a/gcc/ada/libgnat/a-wtcoio.ads b/gcc/ada/libgnat/a-wtcoio.ads index 31fab2b6f22..f80a5b9719a 100644 --- a/gcc/ada/libgnat/a-wtcoio.ads +++ b/gcc/ada/libgnat/a-wtcoio.ads @@ -20,42 +20,40 @@ generic package Ada.Wide_Text_IO.Complex_IO is - use Complex_Types; - Default_Fore : Field := 2; - Default_Aft : Field := Real'Digits - 1; + Default_Aft : Field := Complex_Types.Real'Digits - 1; Default_Exp : Field := 3; procedure Get (File : File_Type; - Item : out Complex; + Item : out Complex_Types.Complex; Width : Field := 0); procedure Get - (Item : out Complex; + (Item : out Complex_Types.Complex; Width : Field := 0); procedure Put (File : File_Type; - Item : Complex; + Item : Complex_Types.Complex; Fore : Field := Default_Fore; Aft : Field := Default_Aft; Exp : Field := Default_Exp); procedure Put - (Item : Complex; + (Item : Complex_Types.Complex; Fore : Field := Default_Fore; Aft : Field := Default_Aft; Exp : Field := Default_Exp); procedure Get (From : Wide_String; - Item : out Complex; + Item : out Complex_Types.Complex; Last : out Positive); procedure Put (To : out Wide_String; - Item : Complex; + Item : Complex_Types.Complex; Aft : Field := Default_Aft; Exp : Field := Default_Exp); diff --git a/gcc/ada/libgnat/a-wtdeau.adb b/gcc/ada/libgnat/a-wtdeau.adb index 268ba4da606..57fcc92a20f 100644 --- a/gcc/ada/libgnat/a-wtdeau.adb +++ b/gcc/ada/libgnat/a-wtdeau.adb @@ -30,7 +30,6 @@ ------------------------------------------------------------------------------ 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.Decimal_Aux is diff --git a/gcc/ada/libgnat/a-wtfiau.adb b/gcc/ada/libgnat/a-wtfiau.adb index d4a153413af..611b76ddf5b 100644 --- a/gcc/ada/libgnat/a-wtfiau.adb +++ b/gcc/ada/libgnat/a-wtfiau.adb @@ -30,7 +30,6 @@ ------------------------------------------------------------------------------ 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 diff --git a/gcc/ada/libgnat/a-wtfiio.adb b/gcc/ada/libgnat/a-wtfiio.adb index 570c5da72d8..e2537ae0ce3 100644 --- a/gcc/ada/libgnat/a-wtfiio.adb +++ b/gcc/ada/libgnat/a-wtfiio.adb @@ -36,6 +36,7 @@ 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.Val_LLF; use System.Val_LLF; with System.WCh_Con; use System.WCh_Con; with System.WCh_WtS; use System.WCh_WtS; @@ -55,6 +56,9 @@ package body Ada.Wide_Text_IO.Fixed_IO is package Aux64 is new Ada.Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64); + package Aux_Long_Long_Float is new + Ada.Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + -- Throughout this generic body, we distinguish between the case where type -- Int32 is OK and where type Int64 is OK. These boolean constants are used -- to test for this, such that only code for the relevant case is included @@ -157,7 +161,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Get (File, Long_Long_Float (Item), Width); + Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width); end if; exception @@ -197,7 +201,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Gets (S, Long_Long_Float (Item), Last); + Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last); end if; exception @@ -225,7 +229,8 @@ package body Ada.Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Item), Fore, Aft, Exp); end if; end Put; @@ -257,7 +262,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp); end if; for J in S'Range loop diff --git a/gcc/ada/libgnat/a-wtfiio__128.adb b/gcc/ada/libgnat/a-wtfiio__128.adb index aa45e5d375d..a5801be16ee 100644 --- a/gcc/ada/libgnat/a-wtfiio__128.adb +++ b/gcc/ada/libgnat/a-wtfiio__128.adb @@ -38,6 +38,7 @@ 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.Val_LLF; use System.Val_LLF; with System.WCh_Con; use System.WCh_Con; with System.WCh_WtS; use System.WCh_WtS; @@ -61,6 +62,9 @@ package body Ada.Wide_Text_IO.Fixed_IO is package Aux128 is new Ada.Wide_Text_IO.Fixed_Aux (Int128, Scan_Fixed128, Set_Image_Fixed128); + package Aux_Long_Long_Float is new + Ada.Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + -- Throughout this generic body, we distinguish between the case where type -- Int32 is OK, where type Int64 is OK and where type Int128 is OK. These -- boolean constants are used to test for this, such that only code for the @@ -197,7 +201,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Get (File, Long_Long_Float (Item), Width); + Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width); end if; exception @@ -242,7 +246,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Gets (S, Long_Long_Float (Item), Last); + Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last); end if; exception @@ -274,7 +278,8 @@ package body Ada.Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Item), Fore, Aft, Exp); end if; end Put; @@ -310,7 +315,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp); end if; for J in S'Range loop diff --git a/gcc/ada/libgnat/a-wtflau.adb b/gcc/ada/libgnat/a-wtflau.adb index fd9ff1a6aa1..7db1b7867b6 100644 --- a/gcc/ada/libgnat/a-wtflau.adb +++ b/gcc/ada/libgnat/a-wtflau.adb @@ -31,8 +31,7 @@ with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; -with System.Img_Real; use System.Img_Real; -with System.Val_Real; use System.Val_Real; +with System.Img_Real; use System.Img_Real; package body Ada.Wide_Text_IO.Float_Aux is @@ -42,12 +41,12 @@ package body Ada.Wide_Text_IO.Float_Aux is procedure Get (File : File_Type; - Item : out Long_Long_Float; + Item : out Num; Width : Field) is Buf : String (1 .. Field'Last); Stop : Integer := 0; - Ptr : aliased Integer := 1; + Ptr : aliased Integer; begin if Width /= 0 then @@ -55,10 +54,10 @@ package body Ada.Wide_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); - + Item := Scan (Buf, Ptr'Access, Stop); Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get; @@ -68,137 +67,36 @@ package body Ada.Wide_Text_IO.Float_Aux is procedure Gets (From : String; - Item : out Long_Long_Float; + Item : out Num; Last : out Positive) is Pos : aliased Integer; begin String_Skip (From, Pos); - Item := Scan_Real (From, Pos'Access, From'Last); + Item := Scan (From, Pos'Access, From'Last); Last := Pos - 1; exception - when Constraint_Error => - raise Data_Error; + when Constraint_Error => raise Data_Error; end Gets; - --------------- - -- Load_Real -- - --------------- - - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Loaded : Boolean; - - begin - -- Skip initial blanks and load possible sign - - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - -- Case of .nnnn - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Otherwise must have digits to start - - else - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - - -- Case of nnn#.xxx# - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '#', ':'); - - -- Case of nnn#xxx.[xxx]# or nnn#xxx# - - else - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - end if; - - -- As usual, it seems strange to allow mixed base characters, - -- but that is what ACVC tests expect, see CE3804M, case (3). - - Load (File, Buf, Ptr, '#', ':'); - end if; - - -- Case of nnn.[nnn] or nnn - - else - -- Prevent the potential processing of '.' in cases where the - -- initial digits have a trailing underscore. - - if Buf (Ptr) = '_' then - return; - end if; - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr); - end if; - end if; - end if; - - -- Deal with exponent - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end Load_Real; - --------- -- Put -- --------- procedure Put (File : File_Type; - Item : Long_Long_Float; + Item : Num; Fore : Field; Aft : Field; Exp : Field) is - Buf : String (1 .. Field'Last); + Buf : String (1 .. Max_Real_Image_Length); Ptr : Natural := 0; begin - Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); + Set_Image_Real (Long_Long_Float (Item), Buf, Ptr, Fore, Aft, Exp); Put_Item (File, Buf (1 .. Ptr)); end Put; @@ -208,15 +106,16 @@ package body Ada.Wide_Text_IO.Float_Aux is procedure Puts (To : out String; - Item : Long_Long_Float; + Item : Num; Aft : Field; Exp : Field) is - Buf : String (1 .. Field'Last); + Buf : String (1 .. Max_Real_Image_Length); Ptr : Natural := 0; begin - Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); + Set_Image_Real + (Long_Long_Float (Item), Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); if Ptr > To'Length then raise Layout_Error; diff --git a/gcc/ada/libgnat/a-wtflau.ads b/gcc/ada/libgnat/a-wtflau.ads index 3598f77d73e..82ace794bc4 100644 --- a/gcc/ada/libgnat/a-wtflau.ads +++ b/gcc/ada/libgnat/a-wtflau.ads @@ -31,41 +31,42 @@ -- This package contains the routines for Ada.Wide_Text_IO.Float_IO that -- are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Float_IO itself, --- except that generic parameter Num has been replaced by Long_Long_Float, --- and the default parameters have been removed because they are supplied +-- in this package are identical semantically to those in Float_IO, except +-- that the default parameters have been removed because they are supplied -- explicitly by the calls from within the generic template. This package --- is also used by Ada.Wide_Text_IO.Fixed_IO, Ada.Wide_Text_IO.Decimal_IO. +-- is also used by Ada.Wide_Text_IO.Fixed_IO and Ada.Wide_Text_IO.Decimal_IO. -private package Ada.Wide_Text_IO.Float_Aux is +private generic - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load a possibly signed - -- real literal value from the input file into Buf, starting at Ptr + 1. + type Num is digits <>; + + with function Scan + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Num; + +package Ada.Wide_Text_IO.Float_Aux is procedure Get (File : File_Type; - Item : out Long_Long_Float; + Item : out Num; Width : Field); - procedure Gets - (From : String; - Item : out Long_Long_Float; - Last : out Positive); - procedure Put (File : File_Type; - Item : Long_Long_Float; + Item : Num; Fore : Field; Aft : Field; Exp : Field); + procedure Gets + (From : String; + Item : out Num; + Last : out Positive); + procedure Puts (To : out String; - Item : Long_Long_Float; + Item : Num; Aft : Field; Exp : Field); diff --git a/gcc/ada/libgnat/a-wtflio.adb b/gcc/ada/libgnat/a-wtflio.adb index 07d33b1d830..369178633f1 100644 --- a/gcc/ada/libgnat/a-wtflio.adb +++ b/gcc/ada/libgnat/a-wtflio.adb @@ -30,13 +30,31 @@ ------------------------------------------------------------------------------ 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.Val_Flt; use System.Val_Flt; +with System.Val_LFlt; use System.Val_LFlt; +with System.Val_LLF; use System.Val_LLF; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Text_IO.Float_IO is - package Aux renames Ada.Wide_Text_IO.Float_Aux; + package Aux_Float is new + Ada.Wide_Text_IO.Float_Aux (Float, Scan_Float); + + package Aux_Long_Float is new + Ada.Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float); + + package Aux_Long_Long_Float is new + Ada.Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + + -- Throughout this generic body, we distinguish between the case where type + -- Float is OK, where type Long_Float is OK and where type Long_Long_Float + -- is needed. These boolean constants are used to test for this, such that + -- only code for the relevant case is included in the instance. + + OK_Float : constant Boolean := Num'Base'Digits <= Float'Digits; + + OK_Long_Float : constant Boolean := Num'Base'Digits <= Long_Float'Digits; --------- -- Get -- @@ -47,8 +65,25 @@ package body Ada.Wide_Text_IO.Float_IO is Item : out Num; Width : Field := 0) is + pragma Unsuppress (Range_Check); + begin - Aux.Get (File, Long_Long_Float (Item), Width); + if OK_Float then + Aux_Float.Get (File, Float (Item), Width); + elsif OK_Long_Float then + Aux_Long_Float.Get (File, Long_Float (Item), Width); + else + Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width); + end if; + + -- In the case where the type is unconstrained (e.g. Standard'Float), + -- the above conversion may result in an infinite value, which is + -- normally fine for a conversion, but in this case, we want to treat + -- that as a data error. + + if not Item'Valid then + raise Data_Error; + end if; exception when Constraint_Error => raise Data_Error; @@ -67,6 +102,8 @@ package body Ada.Wide_Text_IO.Float_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 @@ -74,7 +111,22 @@ package body Ada.Wide_Text_IO.Float_IO is -- Aux.Gets will raise Data_Error in any case. begin - Aux.Gets (S, Long_Long_Float (Item), Last); + if OK_Float then + Aux_Float.Gets (S, Float (Item), Last); + elsif OK_Long_Float then + Aux_Long_Float.Gets (S, Long_Float (Item), Last); + else + Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last); + end if; + + -- In the case where the type is unconstrained (e.g. Standard'Float), + -- the above conversion may result in an infinite value, which is + -- normally fine for a conversion, but in this case, we want to treat + -- that as a data error. + + if not Item'Valid then + raise Data_Error; + end if; exception when Constraint_Error => raise Data_Error; @@ -92,7 +144,14 @@ package body Ada.Wide_Text_IO.Float_IO is Exp : Field := Default_Exp) is begin - Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + if OK_Float then + Aux_Float.Put (File, Float (Item), Fore, Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp); + else + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Item), Fore, Aft, Exp); + end if; end Put; procedure Put @@ -114,7 +173,13 @@ package body Ada.Wide_Text_IO.Float_IO is S : String (To'First .. To'Last); begin - Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + if OK_Float then + Aux_Float.Puts (S, Float (Item), Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Puts (S, Long_Float (Item), Aft, Exp); + else + Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp); + end if; for J in S'Range loop To (J) := Wide_Character'Val (Character'Pos (S (J))); diff --git a/gcc/ada/libgnat/a-wtgeau.adb b/gcc/ada/libgnat/a-wtgeau.adb index 9d24070e98d..bc9b459a9f7 100644 --- a/gcc/ada/libgnat/a-wtgeau.adb +++ b/gcc/ada/libgnat/a-wtgeau.adb @@ -402,6 +402,106 @@ package body Ada.Wide_Text_IO.Generic_Aux is end if; end Load_Integer; + --------------- + -- Load_Real -- + --------------- + + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Loaded : Boolean; + + begin + -- Skip initial blanks and load possible sign + + Load_Skip (File); + Load (File, Buf, Ptr, '+', '-'); + + -- Case of .nnnn + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Otherwise must have digits to start + + else + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + + -- Case of nnn#.xxx# + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '#', ':'); + + -- Case of nnn#xxx.[xxx]# or nnn#xxx# + + else + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + end if; + + -- As usual, it seems strange to allow mixed base characters, + -- but that is what ACVC tests expect, see CE3804M, case (3). + + Load (File, Buf, Ptr, '#', ':'); + end if; + + -- Case of nnn.[nnn] or nnn + + else + -- Prevent the potential processing of '.' in cases where the + -- initial digits have a trailing underscore. + + if Buf (Ptr) = '_' then + return; + end if; + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr); + end if; + end if; + end if; + + -- Deal with exponent + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end Load_Real; + --------------- -- Load_Skip -- --------------- diff --git a/gcc/ada/libgnat/a-wtgeau.ads b/gcc/ada/libgnat/a-wtgeau.ads index 9577ac2bd33..7c899717c2d 100644 --- a/gcc/ada/libgnat/a-wtgeau.ads +++ b/gcc/ada/libgnat/a-wtgeau.ads @@ -155,6 +155,12 @@ package Ada.Wide_Text_IO.Generic_Aux is Ptr : in out Natural); -- Loads a possibly signed integer literal value + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- Loads a possibly signed real literal value + procedure Put_Item (File : File_Type; Str : String); -- This routine is like Wide_Text_IO.Put, except that it checks for -- overflow of bounded lines, as described in (RM A.10.6(8)). It is used diff --git a/gcc/ada/libgnat/a-ztcoau.adb b/gcc/ada/libgnat/a-ztcoau.adb index ffe0a9012e9..bb336809542 100644 --- a/gcc/ada/libgnat/a-ztcoau.adb +++ b/gcc/ada/libgnat/a-ztcoau.adb @@ -30,22 +30,19 @@ ------------------------------------------------------------------------------ with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; -with Ada.Wide_Wide_Text_IO.Float_Aux; with System.Img_Real; use System.Img_Real; package body Ada.Wide_Wide_Text_IO.Complex_Aux is - package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; - --------- -- Get -- --------- procedure Get (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; + ItemR : out Num; + ItemI : out Num; Width : Field) is Buf : String (1 .. Field'Last); @@ -95,8 +92,8 @@ package body Ada.Wide_Wide_Text_IO.Complex_Aux is procedure Gets (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; + ItemR : out Num; + ItemI : out Num; Last : out Positive) is Paren : Boolean; @@ -139,8 +136,8 @@ package body Ada.Wide_Wide_Text_IO.Complex_Aux is procedure Put (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Fore : Field; Aft : Field; Exp : Field) @@ -159,8 +156,8 @@ package body Ada.Wide_Wide_Text_IO.Complex_Aux is procedure Puts (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Aft : Field; Exp : Field) is @@ -174,9 +171,9 @@ package body Ada.Wide_Wide_Text_IO.Complex_Aux is -- Both parts are initially converted with a Fore of 0 Rptr := 0; - Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp); + Set_Image_Real (Long_Long_Float (ItemR), R_String, Rptr, 0, Aft, Exp); Iptr := 0; - Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp); + Set_Image_Real (Long_Long_Float (ItemI), I_String, Iptr, 0, Aft, Exp); -- Check room for both parts plus parens plus comma (RM G.1.3(34)) diff --git a/gcc/ada/libgnat/a-ztcoau.ads b/gcc/ada/libgnat/a-ztcoau.ads index b68c38b18cc..43546d804df 100644 --- a/gcc/ada/libgnat/a-ztcoau.ads +++ b/gcc/ada/libgnat/a-ztcoau.ads @@ -15,38 +15,45 @@ -- This package contains the routines for Ada.Wide_Wide_Text_IO.Complex_IO -- that are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Complex_IO itself, --- except that the generic parameter Complex has been replaced by separate --- real and imaginary values of type Long_Long_Float, and default parameters --- have been removed because they are supplied explicitly by the calls from --- within the generic template. +-- in this package are identical semantically to those in Complex_IO, except +-- that the generic parameter Complex has been replaced by separate real and +-- imaginary parameters, and default parameters have been removed because they +-- are supplied explicitly by the calls from within the generic template. + +with Ada.Wide_Wide_Text_IO.Float_Aux; + +private generic + + type Num is digits <>; + + with package Aux is new Ada.Wide_Wide_Text_IO.Float_Aux (Num, <>); package Ada.Wide_Wide_Text_IO.Complex_Aux is procedure Get (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; + ItemR : out Num; + ItemI : out Num; Width : Field); - procedure Gets - (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Last : out Positive); - procedure Put (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Fore : Field; Aft : Field; Exp : Field); + procedure Gets + (From : String; + ItemR : out Num; + ItemI : out Num; + Last : out Positive); + procedure Puts (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; + ItemR : Num; + ItemI : Num; Aft : Field; Exp : Field); diff --git a/gcc/ada/libgnat/a-ztcoio.adb b/gcc/ada/libgnat/a-ztcoio.adb index 711c7bbc733..51031912604 100644 --- a/gcc/ada/libgnat/a-ztcoio.adb +++ b/gcc/ada/libgnat/a-ztcoio.adb @@ -30,24 +30,46 @@ ------------------------------------------------------------------------------ with Ada.Wide_Wide_Text_IO.Complex_Aux; - -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; +with Ada.Wide_Wide_Text_IO.Float_Aux; +with System.Val_Flt; use System.Val_Flt; +with System.Val_LFlt; use System.Val_LFlt; +with System.Val_LLF; use System.Val_LLF; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; with Ada.Unchecked_Conversion; package body Ada.Wide_Wide_Text_IO.Complex_IO is - package Aux renames Ada.Wide_Wide_Text_IO.Complex_Aux; + use Complex_Types; + + package Scalar_Float is new + Ada.Wide_Wide_Text_IO.Float_Aux (Float, Scan_Float); + + package Scalar_Long_Float is new + Ada.Wide_Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float); + + package Scalar_Long_Long_Float is new + Ada.Wide_Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + + package Aux_Float is new + Ada.Wide_Wide_Text_IO.Complex_Aux (Float, Scalar_Float); - subtype LLF is Long_Long_Float; - -- Type used for calls to routines in Aux + package Aux_Long_Float is new + Ada.Wide_Wide_Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float); - function TFT is new - Ada.Unchecked_Conversion (File_Type, Ada.Wide_Wide_Text_IO.File_Type); - -- This unchecked conversion is to get around a visibility bug in - -- GNAT version 2.04w. It should be possible to simply use the - -- subtype declared above and do normal checked conversions. + package Aux_Long_Long_Float is new + Ada.Wide_Wide_Text_IO.Complex_Aux + (Long_Long_Float, Scalar_Long_Long_Float); + + -- Throughout this generic body, we distinguish between the case where type + -- Float is OK, where type Long_Float is OK and where type Long_Long_Float + -- is needed. These boolean constants are used to test for this, such that + -- only code for the relevant case is included in the instance. + + OK_Float : constant Boolean := Real'Base'Digits <= Float'Digits; + + OK_Long_Float : constant Boolean := Real'Base'Digits <= Long_Float'Digits; --------- -- Get -- @@ -62,7 +84,17 @@ package body Ada.Wide_Wide_Text_IO.Complex_IO is Imag_Item : Real'Base; begin - Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width); + if OK_Float then + Aux_Float.Get (File, Float (Real_Item), Float (Imag_Item), Width); + elsif OK_Long_Float then + Aux_Long_Float.Get + (File, Long_Float (Real_Item), Long_Float (Imag_Item), Width); + else + Aux_Long_Long_Float.Get + (File, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item), + Width); + end if; + Item := (Real_Item, Imag_Item); exception @@ -100,7 +132,17 @@ package body Ada.Wide_Wide_Text_IO.Complex_IO is -- Aux.Gets will raise Data_Error in any case. begin - Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last); + if OK_Float then + Aux_Float.Gets (S, Float (Real_Item), Float (Imag_Item), Last); + elsif OK_Long_Float then + Aux_Long_Float.Gets + (S, Long_Float (Real_Item), Long_Float (Imag_Item), Last); + else + Aux_Long_Long_Float.Gets + (S, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item), + Last); + end if; + Item := (Real_Item, Imag_Item); exception @@ -119,7 +161,18 @@ package body Ada.Wide_Wide_Text_IO.Complex_IO is Exp : Field := Default_Exp) is begin - Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); + if OK_Float then + Aux_Float.Put + (File, Float (Re (Item)), Float (Im (Item)), Fore, Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Put + (File, Long_Float (Re (Item)), Long_Float (Im (Item)), Fore, Aft, + Exp); + else + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)), + Fore, Aft, Exp); + end if; end Put; --------- @@ -149,7 +202,16 @@ package body Ada.Wide_Wide_Text_IO.Complex_IO is S : String (To'First .. To'Last); begin - Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); + if OK_Float then + Aux_Float.Puts (S, Float (Re (Item)), Float (Im (Item)), Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Puts + (S, Long_Float (Re (Item)), Long_Float (Im (Item)), Aft, Exp); + else + Aux_Long_Long_Float.Puts + (S, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)), + Aft, Exp); + 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-ztcoio.ads b/gcc/ada/libgnat/a-ztcoio.ads index 866fd879c64..2a08153a36d 100644 --- a/gcc/ada/libgnat/a-ztcoio.ads +++ b/gcc/ada/libgnat/a-ztcoio.ads @@ -23,39 +23,39 @@ package Ada.Wide_Wide_Text_IO.Complex_IO is use Complex_Types; Default_Fore : Field := 2; - Default_Aft : Field := Real'Digits - 1; + Default_Aft : Field := Complex_Types.Real'Digits - 1; Default_Exp : Field := 3; procedure Get (File : File_Type; - Item : out Complex; + Item : out Complex_Types.Complex; Width : Field := 0); procedure Get - (Item : out Complex; + (Item : out Complex_Types.Complex; Width : Field := 0); procedure Put (File : File_Type; - Item : Complex; + Item : Complex_Types.Complex; Fore : Field := Default_Fore; Aft : Field := Default_Aft; Exp : Field := Default_Exp); procedure Put - (Item : Complex; + (Item : Complex_Types.Complex; Fore : Field := Default_Fore; Aft : Field := Default_Aft; Exp : Field := Default_Exp); procedure Get (From : Wide_Wide_String; - Item : out Complex; + Item : out Complex_Types.Complex; Last : out Positive); procedure Put (To : out Wide_Wide_String; - Item : Complex; + Item : Complex_Types.Complex; Aft : Field := Default_Aft; Exp : Field := Default_Exp); diff --git a/gcc/ada/libgnat/a-ztdeau.adb b/gcc/ada/libgnat/a-ztdeau.adb index 6c2af9f2ce1..ec6431bee99 100644 --- a/gcc/ada/libgnat/a-ztdeau.adb +++ b/gcc/ada/libgnat/a-ztdeau.adb @@ -30,7 +30,6 @@ ------------------------------------------------------------------------------ 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.Decimal_Aux is diff --git a/gcc/ada/libgnat/a-ztfiau.adb b/gcc/ada/libgnat/a-ztfiau.adb index f26a16a41ae..1e94fef0231 100644 --- a/gcc/ada/libgnat/a-ztfiau.adb +++ b/gcc/ada/libgnat/a-ztfiau.adb @@ -30,7 +30,6 @@ ------------------------------------------------------------------------------ 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 diff --git a/gcc/ada/libgnat/a-ztfiio.adb b/gcc/ada/libgnat/a-ztfiio.adb index 3c3224d3c57..53ed45b8ee3 100644 --- a/gcc/ada/libgnat/a-ztfiio.adb +++ b/gcc/ada/libgnat/a-ztfiio.adb @@ -36,6 +36,7 @@ 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.Val_LLF; use System.Val_LLF; with System.WCh_Con; use System.WCh_Con; with System.WCh_WtS; use System.WCh_WtS; @@ -55,6 +56,9 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is package Aux64 is new Ada.Wide_Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64); + package Aux_Long_Long_Float is new + Ada.Wide_Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + -- Throughout this generic body, we distinguish between the case where type -- Int32 is OK and where type Int64 is OK. These boolean constants are used -- to test for this, such that only code for the relevant case is included @@ -157,7 +161,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Get (File, Long_Long_Float (Item), Width); + Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width); end if; exception @@ -197,7 +201,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Gets (S, Long_Long_Float (Item), Last); + Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last); end if; exception @@ -225,7 +229,8 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Item), Fore, Aft, Exp); end if; end Put; @@ -257,7 +262,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp); end if; for J in S'Range loop diff --git a/gcc/ada/libgnat/a-ztfiio__128.adb b/gcc/ada/libgnat/a-ztfiio__128.adb index 3254fb8c7de..13ed410354f 100644 --- a/gcc/ada/libgnat/a-ztfiio__128.adb +++ b/gcc/ada/libgnat/a-ztfiio__128.adb @@ -38,6 +38,7 @@ 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.Val_LLF; use System.Val_LLF; with System.WCh_Con; use System.WCh_Con; with System.WCh_WtS; use System.WCh_WtS; @@ -62,6 +63,9 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is Ada.Wide_Wide_Text_IO.Fixed_Aux (Int128, Scan_Fixed128, Set_Image_Fixed128); + package Aux_Long_Long_Float is new + Ada.Wide_Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + -- Throughout this generic body, we distinguish between the case where type -- Int32 is OK, where type Int64 is OK and where type Int128 is OK. These -- boolean constants are used to test for this, such that only code for the @@ -198,7 +202,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Get (File, Long_Long_Float (Item), Width); + Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width); end if; exception @@ -243,7 +247,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator)); else - Float_Aux.Gets (S, Long_Long_Float (Item), Last); + Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last); end if; exception @@ -275,7 +279,8 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Item), Fore, Aft, Exp); end if; end Put; @@ -311,7 +316,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is -Num'Small_Numerator, -Num'Small_Denominator, For0, Num'Aft); else - Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp); end if; for J in S'Range loop diff --git a/gcc/ada/libgnat/a-ztflau.adb b/gcc/ada/libgnat/a-ztflau.adb index c0c55ba8ba2..1bddcd86ddf 100644 --- a/gcc/ada/libgnat/a-ztflau.adb +++ b/gcc/ada/libgnat/a-ztflau.adb @@ -31,8 +31,7 @@ with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; -with System.Img_Real; use System.Img_Real; -with System.Val_Real; use System.Val_Real; +with System.Img_Real; use System.Img_Real; package body Ada.Wide_Wide_Text_IO.Float_Aux is @@ -42,12 +41,12 @@ package body Ada.Wide_Wide_Text_IO.Float_Aux is procedure Get (File : File_Type; - Item : out Long_Long_Float; + Item : out Num; Width : Field) is Buf : String (1 .. Field'Last); Stop : Integer := 0; - Ptr : aliased Integer := 1; + Ptr : aliased Integer; begin if Width /= 0 then @@ -55,10 +54,10 @@ package body Ada.Wide_Wide_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); - + Item := Scan (Buf, Ptr'Access, Stop); Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get; @@ -68,137 +67,36 @@ package body Ada.Wide_Wide_Text_IO.Float_Aux is procedure Gets (From : String; - Item : out Long_Long_Float; + Item : out Num; Last : out Positive) is Pos : aliased Integer; begin String_Skip (From, Pos); - Item := Scan_Real (From, Pos'Access, From'Last); + Item := Scan (From, Pos'Access, From'Last); Last := Pos - 1; exception - when Constraint_Error => - raise Data_Error; + when Constraint_Error => raise Data_Error; end Gets; - --------------- - -- Load_Real -- - --------------- - - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Loaded : Boolean; - - begin - -- Skip initial blanks and load possible sign - - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - -- Case of .nnnn - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Otherwise must have digits to start - - else - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - - -- Case of nnn#.xxx# - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '#', ':'); - - -- Case of nnn#xxx.[xxx]# or nnn#xxx# - - else - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - end if; - - -- As usual, it seems strange to allow mixed base characters, - -- but that is what ACVC tests expect, see CE3804M, case (3). - - Load (File, Buf, Ptr, '#', ':'); - end if; - - -- Case of nnn.[nnn] or nnn - - else - -- Prevent the potential processing of '.' in cases where the - -- initial digits have a trailing underscore. - - if Buf (Ptr) = '_' then - return; - end if; - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr); - end if; - end if; - end if; - - -- Deal with exponent - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end Load_Real; - --------- -- Put -- --------- procedure Put (File : File_Type; - Item : Long_Long_Float; + Item : Num; Fore : Field; Aft : Field; Exp : Field) is - Buf : String (1 .. Field'Last); + Buf : String (1 .. Max_Real_Image_Length); Ptr : Natural := 0; begin - Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); + Set_Image_Real (Long_Long_Float (Item), Buf, Ptr, Fore, Aft, Exp); Put_Item (File, Buf (1 .. Ptr)); end Put; @@ -208,15 +106,16 @@ package body Ada.Wide_Wide_Text_IO.Float_Aux is procedure Puts (To : out String; - Item : Long_Long_Float; + Item : Num; Aft : Field; Exp : Field) is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; + Buf : String (1 .. Max_Real_Image_Length); + Ptr : Natural := 0; begin - Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); + Set_Image_Real + (Long_Long_Float (Item), Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); if Ptr > To'Length then raise Layout_Error; diff --git a/gcc/ada/libgnat/a-ztflau.ads b/gcc/ada/libgnat/a-ztflau.ads index dc24682bd32..48fba8267ac 100644 --- a/gcc/ada/libgnat/a-ztflau.ads +++ b/gcc/ada/libgnat/a-ztflau.ads @@ -31,41 +31,42 @@ -- This package contains the routines for Ada.Wide_Wide_Text_IO.Float_IO that -- are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Float_IO itself, --- except that generic parameter Num has been replaced by Long_Long_Float, --- and the default parameters have been removed because they are supplied +-- in this package are identical semantically to those in Float_IO, except +-- that the default parameters have been removed because they are supplied -- explicitly by the calls from within the generic template. Also used by --- Ada.Wide_Wide_Text_IO.Fixed_IO, and by Ada.Wide_Wide_Text_IO.Decimal_IO. +-- Ada.Wide_Wide_Text_IO.Fixed_IO and by Ada.Wide_Wide_Text_IO.Decimal_IO. -private package Ada.Wide_Wide_Text_IO.Float_Aux is +private generic - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load a possibly signed - -- real literal value from the input file into Buf, starting at Ptr + 1. + type Num is digits <>; + + with function Scan + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Num; + +package Ada.Wide_Wide_Text_IO.Float_Aux is procedure Get (File : File_Type; - Item : out Long_Long_Float; + Item : out Num; Width : Field); - procedure Gets - (From : String; - Item : out Long_Long_Float; - Last : out Positive); - procedure Put (File : File_Type; - Item : Long_Long_Float; + Item : Num; Fore : Field; Aft : Field; Exp : Field); + procedure Gets + (From : String; + Item : out Num; + Last : out Positive); + procedure Puts (To : out String; - Item : Long_Long_Float; + Item : Num; Aft : Field; Exp : Field); diff --git a/gcc/ada/libgnat/a-ztflio.adb b/gcc/ada/libgnat/a-ztflio.adb index 0640dacdbbd..e491e629897 100644 --- a/gcc/ada/libgnat/a-ztflio.adb +++ b/gcc/ada/libgnat/a-ztflio.adb @@ -30,12 +30,31 @@ ------------------------------------------------------------------------------ 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.Val_Flt; use System.Val_Flt; +with System.Val_LFlt; use System.Val_LFlt; +with System.Val_LLF; use System.Val_LLF; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Wide_Text_IO.Float_IO is - package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; + package Aux_Float is new + Ada.Wide_Wide_Text_IO.Float_Aux (Float, Scan_Float); + + package Aux_Long_Float is new + Ada.Wide_Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float); + + package Aux_Long_Long_Float is new + Ada.Wide_Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float); + + -- Throughout this generic body, we distinguish between the case where type + -- Float is OK, where type Long_Float is OK and where type Long_Long_Float + -- is needed. These boolean constants are used to test for this, such that + -- only code for the relevant case is included in the instance. + + OK_Float : constant Boolean := Num'Base'Digits <= Float'Digits; + + OK_Long_Float : constant Boolean := Num'Base'Digits <= Long_Float'Digits; --------- -- Get -- @@ -46,8 +65,25 @@ package body Ada.Wide_Wide_Text_IO.Float_IO is Item : out Num; Width : Field := 0) is + pragma Unsuppress (Range_Check); + begin - Aux.Get (File, Long_Long_Float (Item), Width); + if OK_Float then + Aux_Float.Get (File, Float (Item), Width); + elsif OK_Long_Float then + Aux_Long_Float.Get (File, Long_Float (Item), Width); + else + Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width); + end if; + + -- In the case where the type is unconstrained (e.g. Standard'Float), + -- the above conversion may result in an infinite value, which is + -- normally fine for a conversion, but in this case, we want to treat + -- that as a data error. + + if not Item'Valid then + raise Data_Error; + end if; exception when Constraint_Error => raise Data_Error; @@ -66,6 +102,8 @@ package body Ada.Wide_Wide_Text_IO.Float_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 +111,22 @@ package body Ada.Wide_Wide_Text_IO.Float_IO is -- Aux.Gets will raise Data_Error in any case. begin - Aux.Gets (S, Long_Long_Float (Item), Last); + if OK_Float then + Aux_Float.Gets (S, Float (Item), Last); + elsif OK_Long_Float then + Aux_Long_Float.Gets (S, Long_Float (Item), Last); + else + Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last); + end if; + + -- In the case where the type is unconstrained (e.g. Standard'Float), + -- the above conversion may result in an infinite value, which is + -- normally fine for a conversion, but in this case, we want to treat + -- that as a data error. + + if not Item'Valid then + raise Data_Error; + end if; exception when Constraint_Error => raise Data_Error; @@ -91,7 +144,14 @@ package body Ada.Wide_Wide_Text_IO.Float_IO is Exp : Field := Default_Exp) is begin - Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + if OK_Float then + Aux_Float.Put (File, Float (Item), Fore, Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp); + else + Aux_Long_Long_Float.Put + (File, Long_Long_Float (Item), Fore, Aft, Exp); + end if; end Put; procedure Put @@ -113,7 +173,13 @@ package body Ada.Wide_Wide_Text_IO.Float_IO is S : String (To'First .. To'Last); begin - Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + if OK_Float then + Aux_Float.Puts (S, Float (Item), Aft, Exp); + elsif OK_Long_Float then + Aux_Long_Float.Puts (S, Long_Float (Item), Aft, Exp); + else + Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp); + 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-ztgeau.adb b/gcc/ada/libgnat/a-ztgeau.adb index be7aecc9ecf..6b5e4c5add8 100644 --- a/gcc/ada/libgnat/a-ztgeau.adb +++ b/gcc/ada/libgnat/a-ztgeau.adb @@ -402,6 +402,106 @@ package body Ada.Wide_Wide_Text_IO.Generic_Aux is end if; end Load_Integer; + --------------- + -- Load_Real -- + --------------- + + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Loaded : Boolean; + + begin + -- Skip initial blanks and load possible sign + + Load_Skip (File); + Load (File, Buf, Ptr, '+', '-'); + + -- Case of .nnnn + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Otherwise must have digits to start + + else + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + + -- Case of nnn#.xxx# + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '#', ':'); + + -- Case of nnn#xxx.[xxx]# or nnn#xxx# + + else + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + end if; + + -- As usual, it seems strange to allow mixed base characters, + -- but that is what ACVC tests expect, see CE3804M, case (3). + + Load (File, Buf, Ptr, '#', ':'); + end if; + + -- Case of nnn.[nnn] or nnn + + else + -- Prevent the potential processing of '.' in cases where the + -- initial digits have a trailing underscore. + + if Buf (Ptr) = '_' then + return; + end if; + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr); + end if; + end if; + end if; + + -- Deal with exponent + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end Load_Real; + --------------- -- Load_Skip -- --------------- diff --git a/gcc/ada/libgnat/a-ztgeau.ads b/gcc/ada/libgnat/a-ztgeau.ads index 68d4a33cb37..6b80ed4cfe1 100644 --- a/gcc/ada/libgnat/a-ztgeau.ads +++ b/gcc/ada/libgnat/a-ztgeau.ads @@ -155,6 +155,12 @@ package Ada.Wide_Wide_Text_IO.Generic_Aux is Ptr : in out Natural); -- Loads a possibly signed integer literal value + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- Loads a possibly signed real literal value + procedure Put_Item (File : File_Type; Str : String); -- This routine is like Wide_Wide_Text_IO.Put, except that it checks for -- overflow of bounded lines, as described in (RM A.10.6(8)). It is used diff --git a/gcc/ada/libgnat/s-fatgen.adb b/gcc/ada/libgnat/s-fatgen.adb index 950b377bb38..9f25987e428 100644 --- a/gcc/ada/libgnat/s-fatgen.adb +++ b/gcc/ada/libgnat/s-fatgen.adb @@ -654,6 +654,8 @@ package body System.Fat_Gen is if Adjustment > IEEE_Emax - Exp then XX := 0.0; return (if Minus then -1.0 / XX else 1.0 / XX); + pragma Annotate + (CodePeer, Intentional, "overflow check", "Infinity produced"); pragma Annotate (CodePeer, Intentional, "divide by zero", "Infinity produced"); diff --git a/gcc/ada/libgnat/s-fatsfl.ads b/gcc/ada/libgnat/s-fatsfl.ads deleted file mode 100644 index 45b13e15ba9..00000000000 --- a/gcc/ada/libgnat/s-fatsfl.ads +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ S F L T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains an instantiation of the floating-point attribute --- runtime routines for the type Short_Float. - -with System.Fat_Gen; - -package System.Fat_SFlt is - pragma Pure; - - -- Note the only entity from this package that is accessed by Rtsfind - -- is the name of the package instantiation. Entities within this package - -- (i.e. the individual floating-point attribute routines) are accessed - -- by name using selected notation. - - package Attr_Short_Float is new System.Fat_Gen (Short_Float); - -end System.Fat_SFlt; diff --git a/gcc/ada/libgnat/s-valflt.ads b/gcc/ada/libgnat/s-valflt.ads new file mode 100644 index 00000000000..476a25189a3 --- /dev/null +++ b/gcc/ada/libgnat/s-valflt.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ F L T -- +-- -- +-- 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 -- +-- . -- +-- -- +-- 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 floating point +-- type Float, for use in Text_IO.Float_IO and the Value attribute. + +with Interfaces; +with System.Val_Real; + +package System.Val_Flt is + pragma Preelaborate; + + package Impl is new Val_Real (Float, Interfaces.Unsigned_32); + + function Scan_Float + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Float + renames Impl.Scan_Real; + + function Value_Float (Str : String) return Float + renames Impl.Value_Real; + +end System.Val_Flt; diff --git a/gcc/ada/libgnat/s-vallfl.ads b/gcc/ada/libgnat/s-vallfl.ads new file mode 100644 index 00000000000..5bb6da47867 --- /dev/null +++ b/gcc/ada/libgnat/s-vallfl.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L F L T -- +-- -- +-- 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 -- +-- . -- +-- -- +-- 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 floating point +-- type Long_Float, for use in Text_IO.Float_IO and the Value attribute. + +with Interfaces; +with System.Val_Real; + +package System.Val_LFlt is + pragma Preelaborate; + + package Impl is new Val_Real (Long_Float, Interfaces.Unsigned_64); + + function Scan_Long_Float + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Long_Float + renames Impl.Scan_Real; + + function Value_Long_Float (Str : String) return Long_Float + renames Impl.Value_Real; + +end System.Val_LFlt; diff --git a/gcc/ada/libgnat/s-valllf.ads b/gcc/ada/libgnat/s-valllf.ads new file mode 100644 index 00000000000..715f6acba78 --- /dev/null +++ b/gcc/ada/libgnat/s-valllf.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L 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 -- +-- . -- +-- -- +-- 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 floating point +-- type Long_Long_Float, for use in Text_IO.Float_IO and the Value attribute. + +with Interfaces; +with System.Val_Real; + +package System.Val_LLF is + pragma Preelaborate; + + package Impl is new Val_Real (Long_Long_Float, Interfaces.Unsigned_64); + + function Scan_Long_Long_Float + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Long_Long_Float + renames Impl.Scan_Real; + + function Value_Long_Long_Float (Str : String) return Long_Long_Float + renames Impl.Value_Real; + +end System.Val_LLF; diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb index 693b261657d..cd02dfea5f6 100644 --- a/gcc/ada/libgnat/s-valrea.adb +++ b/gcc/ada/libgnat/s-valrea.adb @@ -36,14 +36,14 @@ with System.Value_R; package body System.Val_Real is - package Impl is new Value_R (Long_Long_Unsigned, Floating => True); + package Impl is new Value_R (Uns, Floating => True); function Integer_to_Real (Str : String; - Val : Long_Long_Unsigned; + Val : Uns; Base : Unsigned; Scale : Integer; - Minus : Boolean) return Long_Long_Float; + Minus : Boolean) return Num; -- Convert the real value from integer to real representation --------------------- @@ -52,26 +52,34 @@ package body System.Val_Real is function Integer_to_Real (Str : String; - Val : Long_Long_Unsigned; + Val : Uns; Base : Unsigned; Scale : Integer; - Minus : Boolean) return Long_Long_Float + Minus : Boolean) return Num is + pragma Assert (Base in 2 .. 16); + pragma Unsuppress (Range_Check); - R_Val : Long_Long_Float; + R_Val : Num; begin -- We call the floating-point processor reset routine so we can be sure - -- that the processor is properly set for conversions. This is notably + -- that the x87 FPU is properly set for conversions. This is especially -- needed on Windows, where calls to the operating system randomly reset -- the processor into 64-bit mode. - System.Float_Control.Reset; + if Num'Machine_Mantissa = 64 then + System.Float_Control.Reset; + end if; - -- Compute the final value + -- Compute the final value with a single rounding if possible - R_Val := Long_Long_Float (Val) * Long_Long_Float (Base) ** Scale; + if Scale < 0 then + R_Val := Num (Val) / Num (Base) ** (-Scale); + else + R_Val := Num (Val) * Num (Base) ** Scale; + end if; -- Finally deal with initial minus sign, note that this processing is -- done even if Uval is zero, so that -0.0 is correctly interpreted. @@ -87,16 +95,16 @@ package body System.Val_Real is --------------- function Scan_Real - (Str : String; - Ptr : not null access Integer; - Max : Integer) - return Long_Long_Float + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Num is Base : Unsigned; Scale : Integer; Extra : Unsigned; + pragma Unreferenced (Extra); Minus : Boolean; - Val : Long_Long_Unsigned; + Val : Uns; begin Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scale, Extra, Minus); @@ -108,12 +116,13 @@ package body System.Val_Real is -- Value_Real -- ---------------- - function Value_Real (Str : String) return Long_Long_Float is + function Value_Real (Str : String) return Num is Base : Unsigned; Scale : Integer; Extra : Unsigned; + pragma Unreferenced (Extra); Minus : Boolean; - Val : Long_Long_Unsigned; + Val : Uns; begin Val := Impl.Value_Raw_Real (Str, Base, Scale, Extra, Minus); diff --git a/gcc/ada/libgnat/s-valrea.ads b/gcc/ada/libgnat/s-valrea.ads index cb5374c7ba0..961c4803a84 100644 --- a/gcc/ada/libgnat/s-valrea.ads +++ b/gcc/ada/libgnat/s-valrea.ads @@ -29,13 +29,22 @@ -- -- ------------------------------------------------------------------------------ +-- This package contains routines for scanning real values for use in +-- Text_IO.Float_IO and the Value attribute. + +generic + + type Num is digits <>; + + type Uns is mod <>; + package System.Val_Real is pragma Preelaborate; function Scan_Real (Str : String; Ptr : not null access Integer; - Max : Integer) return Long_Long_Float; + Max : Integer) return Num; -- 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 @@ -65,10 +74,10 @@ package System.Val_Real is -- 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_Real (Str : String) return Long_Long_Float; + function Value_Real (Str : String) return Num; -- Used in computing X'Value (Str) where X is a floating-point type or 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 - -- out of range of Long_Long_Float. + -- out of range of Num. end System.Val_Real; diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb index 06d7adcbd7a..04b064fbe08 100644 --- a/gcc/ada/libgnat/s-valuer.adb +++ b/gcc/ada/libgnat/s-valuer.adb @@ -33,11 +33,7 @@ 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); + Precision_Limit : constant Uns := 2 ** (Uns'Size - 1); -- Limit beyond which additional digits are dropped subtype Char_As_Digit is Unsigned range 0 .. 17; @@ -133,6 +129,8 @@ package body System.Value_R is is pragma Assert (Base in 2 .. 16); + pragma Assert (Index in Str'Range); + pragma Assert (Max <= Str'Last); Umax : constant Uns := (Precision_Limit - Uns (Base) + 1) / Uns (Base); -- Max value which cannot overflow on accumulating next digit @@ -144,8 +142,9 @@ package body System.Value_R is -- Set to True if addition of a digit will cause Value to be superior -- to Precision_Limit. - Precision_Limit_Just_Reached : Boolean := False; + Precision_Limit_Just_Reached : Boolean; -- Set to True if Precision_Limit_Reached was just set to True + -- Only used when Floating = False. Digit : Char_As_Digit; -- The current digit @@ -166,6 +165,10 @@ package body System.Value_R is Extra := 0; end if; + if not Floating then + Precision_Limit_Just_Reached := False; + end if; + -- The function precondition is that the first character is a valid -- digit. @@ -194,7 +197,7 @@ package body System.Value_R is -- continue only to assess the validity of the string. if Precision_Limit_Reached then - if Precision_Limit_Just_Reached and then not Floating then + if not Floating and then Precision_Limit_Just_Reached then if Digit >= Base / 2 then if Extra = Base - 1 then Extra := 0; @@ -244,7 +247,10 @@ package body System.Value_R is else Extra := Digit; Precision_Limit_Reached := True; - Precision_Limit_Just_Reached := True; + + if not Floating then + Precision_Limit_Just_Reached := True; + end if; end if; end if; end if; @@ -308,8 +314,9 @@ package body System.Value_R is -- Set to True if addition of a digit will cause Value to be superior -- to Precision_Limit. - Precision_Limit_Just_Reached : Boolean := False; - -- Set to True if Precision_Limit_Reached was just set to True + Precision_Limit_Just_Reached : Boolean; + -- Set to True if Precision_Limit_Reached was just set to True. + -- Only used when Floating = False. Digit : Char_As_Digit; -- The current digit @@ -324,6 +331,12 @@ package body System.Value_R is Scale := 0; Extra := 0; + if not Floating then + Precision_Limit_Just_Reached := False; + end if; + + pragma Assert (Max <= Str'Last); + -- The function precondition is that the first character is a valid -- digit. @@ -354,7 +367,7 @@ package body System.Value_R is if Precision_Limit_Reached then Scale := Scale + 1; - if Precision_Limit_Just_Reached and then not Floating then + if not Floating and then Precision_Limit_Just_Reached then if Digit >= Base / 2 then if Extra = Base - 1 then Extra := 0; @@ -378,7 +391,11 @@ package body System.Value_R is else Extra := Digit; Precision_Limit_Reached := True; - Precision_Limit_Just_Reached := True; + + if not Floating then + Precision_Limit_Just_Reached := True; + end if; + Scale := Scale + 1; end if; end if; @@ -409,7 +426,6 @@ package body System.Value_R is end if; end if; end loop; - end Scan_Integral_Digits; ------------------- @@ -425,6 +441,8 @@ package body System.Value_R is Extra : out Unsigned; Minus : out Boolean) return Uns is + pragma Assert (Max <= Str'Last); + After_Point : Boolean; -- True if a decimal should be parsed @@ -440,7 +458,7 @@ package body System.Value_R is -- Local copy of string pointer Start : Positive; - -- Position of starting non-blank character + pragma Unreferenced (Start); Value : Uns; -- Mantissa as an Integer @@ -461,14 +479,15 @@ package body System.Value_R is Scan_Sign (Str, Ptr, Max, Minus, Start); Index := Ptr.all; - Ptr.all := Start; - -- First character can be either a decimal digit or a dot + pragma Assert (Index >= Str'First); - if Str (Index) in '0' .. '9' then - pragma Annotate - (CodePeer, False_Positive, "test always true", "defensive code"); + pragma Annotate (CodePeer, Modified, Str (Index)); + + -- First character can be either a decimal digit or a dot and for some + -- reason CodePeer incorrectly thinks it is always a digit. + if Str (Index) in '0' .. '9' then After_Point := False; -- If this is a digit it can indicates either the float decimal @@ -496,13 +515,16 @@ package body System.Value_R is -- Check if the first number encountered is a base + pragma Assert (Index >= Str'First); + 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 + if Value in 2 .. 16 then + Base := Unsigned (Value); + else Base_Violation := True; Base := 16; end if; @@ -533,6 +555,8 @@ package body System.Value_R is -- Do we have a dot? + pragma Assert (Index >= Str'First); + 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 @@ -549,6 +573,8 @@ package body System.Value_R is -- Scan the decimal part if After_Point then + pragma Assert (Index <= Max); + Scan_Decimal_Digits (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL); @@ -557,6 +583,8 @@ package body System.Value_R is -- If an explicit base was specified ensure that the delimiter is found if Base_Char /= ASCII.NUL then + pragma Assert (Index > Max or else Index in Str'Range); + if Index > Max or else Str (Index) /= Base_Char then Bad_Value (Str); else diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 665458fb1f0..27bbe0915ee 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -239,8 +239,6 @@ package Rtsfind is System_Exp_Mod, System_Exp_Uns, System_Fat_Flt, - System_Fat_IEEE_Long_Float, - System_Fat_IEEE_Short_Float, System_Fat_LFlt, System_Fat_LLF, System_Fat_SFlt, @@ -434,13 +432,15 @@ package Rtsfind is System_Val_Fixed_32, System_Val_Fixed_64, System_Val_Fixed_128, + System_Val_Flt, System_Val_Int, + System_Val_LFlt, + System_Val_LLF, System_Val_LLI, System_Val_LLLI, System_Val_LLU, System_Val_LLLU, System_Val_Name, - System_Val_Real, System_Val_Uns, System_Val_WChar, System_Version_Control, @@ -925,18 +925,10 @@ package Rtsfind is RE_Attr_Float, -- System.Fat_Flt - RE_Attr_IEEE_Long, -- System.Fat_IEEE_Long_Float - RE_Fat_IEEE_Long, -- System.Fat_IEEE_Long_Float - - RE_Attr_IEEE_Short, -- System.Fat_IEEE_Short_Float - RE_Fat_IEEE_Short, -- System.Fat_IEEE_Short_Float - RE_Attr_Long_Float, -- System.Fat_LFlt RE_Attr_Long_Long_Float, -- System.Fat_LLF - RE_Attr_Short_Float, -- System.Fat_SFlt - RE_Attr_VAX_D_Float, -- System.Fat_VAX_D_Float RE_Fat_VAX_D, -- System.Fat_VAX_D_Float @@ -2045,8 +2037,14 @@ package Rtsfind is RE_Value_Fixed128, -- System_Val_Fixed_128 + RE_Value_Float, -- System_Val_Flt + RE_Value_Integer, -- System.Val_Int + RE_Value_Long_Float, -- System_Val_LFlt + + RE_Value_Long_Long_Float, -- System_Val_LLF + RE_Value_Long_Long_Integer, -- System.Val_LLI RE_Value_Long_Long_Long_Integer, -- System.Val_LLLI @@ -2055,8 +2053,6 @@ package Rtsfind is RE_Value_Long_Long_Long_Unsigned, -- System.Val_LLLU - RE_Value_Real, -- System.Val_Real - RE_Value_Unsigned, -- System.Val_Uns RE_Value_Wide_Character, -- System.Val_WChar @@ -2610,18 +2606,10 @@ package Rtsfind is RE_Attr_Float => System_Fat_Flt, - RE_Attr_IEEE_Long => System_Fat_IEEE_Long_Float, - RE_Fat_IEEE_Long => System_Fat_IEEE_Long_Float, - - RE_Attr_IEEE_Short => System_Fat_IEEE_Short_Float, - RE_Fat_IEEE_Short => System_Fat_IEEE_Short_Float, - RE_Attr_Long_Float => System_Fat_LFlt, RE_Attr_Long_Long_Float => System_Fat_LLF, - RE_Attr_Short_Float => System_Fat_SFlt, - RE_Attr_VAX_D_Float => System_Fat_VAX_D_Float, RE_Fat_VAX_D => System_Fat_VAX_D_Float, @@ -3730,8 +3718,14 @@ package Rtsfind is RE_Value_Fixed128 => System_Val_Fixed_128, + RE_Value_Float => System_Val_Flt, + RE_Value_Integer => System_Val_Int, + RE_Value_Long_Float => System_Val_LFlt, + + RE_Value_Long_Long_Float => System_Val_LLF, + RE_Value_Long_Long_Integer => System_Val_LLI, RE_Value_Long_Long_Long_Integer => System_Val_LLLI, @@ -3740,8 +3734,6 @@ package Rtsfind is RE_Value_Long_Long_Long_Unsigned => System_Val_LLLU, - RE_Value_Real => System_Val_Real, - RE_Value_Unsigned => System_Val_Uns, RE_Value_Wide_Character => System_Val_WChar,