a-tideio$(objext) \
a-tienau$(objext) \
a-tienio$(objext) \
+ a-tifiau$(objext) \
a-tifiio$(objext) \
a-tiflau$(objext) \
a-tiflio$(objext) \
a-wtedit$(objext) \
a-wtenau$(objext) \
a-wtenio$(objext) \
+ a-wtfiau$(objext) \
a-wtfiio$(objext) \
a-wtflau$(objext) \
a-wtflio$(objext) \
a-ztenau$(objext) \
a-ztenio$(objext) \
a-ztexio$(objext) \
+ a-ztfiau$(objext) \
a-ztfiio$(objext) \
a-ztflau$(objext) \
a-ztflio$(objext) \
s-aomoar$(objext) \
s-aotase$(objext) \
s-aridou$(objext) \
+ s-arit32$(objext) \
s-arit64$(objext) \
s-assert$(objext) \
s-atacco$(objext) \
s-finmas$(objext) \
s-finroo$(objext) \
s-flocon$(objext) \
- s-fore$(objext) \
+ s-fode32$(objext) \
+ s-fode64$(objext) \
+ s-fofi32$(objext) \
+ s-fofi64$(objext) \
+ s-fore_d$(objext) \
+ s-fore_f$(objext) \
+ s-forrea$(objext) \
s-gearop$(objext) \
s-genbig$(objext) \
s-geveop$(objext) \
s-gloloc$(objext) \
s-htable$(objext) \
s-imageb$(objext) \
+ s-imaged$(objext) \
+ s-imagef$(objext) \
s-imagei$(objext) \
s-imageu$(objext) \
s-imagew$(objext) \
+ s-imde32$(objext) \
+ s-imde64$(objext) \
s-imenne$(objext) \
+ s-imfi32$(objext) \
+ s-imfi64$(objext) \
s-imgbiu$(objext) \
s-imgboo$(objext) \
s-imgcha$(objext) \
- s-imgdec$(objext) \
s-imgenu$(objext) \
s-imgint$(objext) \
s-imgllb$(objext) \
- s-imglld$(objext) \
s-imglli$(objext) \
s-imgllu$(objext) \
s-imgllw$(objext) \
s-imgrea$(objext) \
s-imguns$(objext) \
+ s-imguti$(objext) \
s-imgwch$(objext) \
s-imgwiu$(objext) \
s-io$(objext) \
s-utf_32$(objext) \
s-valboo$(objext) \
s-valcha$(objext) \
- s-valdec$(objext) \
+ s-vade32$(objext) \
+ s-vade64$(objext) \
+ s-vafi32$(objext) \
+ s-vafi64$(objext) \
s-valenu$(objext) \
s-valint$(objext) \
- s-vallld$(objext) \
s-vallli$(objext) \
s-valllu$(objext) \
s-valrea$(objext) \
+ s-valued$(objext) \
+ s-valuef$(objext) \
s-valuei$(objext) \
+ s-valuer$(objext) \
s-valueu$(objext) \
s-valuns$(objext) \
s-valuti$(objext) \
TRASYM_DWARF_MINGW_OBJS = $(TRASYM_DWARF_COMMON_OBJS)
GNATRTL_128BIT_PAIRS = \
+ a-decima.ads<libgnat/a-decima__128.ads \
+ a-tideio.adb<libgnat/a-tideio__128.adb \
+ a-tifiio.adb<libgnat/a-tifiio__128.adb \
a-tiinio.adb<libgnat/a-tiinio__128.adb \
a-timoio.adb<libgnat/a-timoio__128.adb \
+ a-wtdeio.adb<libgnat/a-wtdeio__128.adb \
+ a-wtfiio.adb<libgnat/a-wtfiio__128.adb \
a-wtinio.adb<libgnat/a-wtinio__128.adb \
a-wtmoio.adb<libgnat/a-wtmoio__128.adb \
+ a-ztdeio.adb<libgnat/a-ztdeio__128.adb \
+ a-ztfiio.adb<libgnat/a-ztfiio__128.adb \
a-ztinio.adb<libgnat/a-ztinio__128.adb \
a-ztmoio.adb<libgnat/a-ztmoio__128.adb \
i-cexten.ads<libgnat/i-cexten__128.ads \
s-exnllli$(objext) \
s-expllli$(objext) \
s-explllu$(objext) \
+ s-fode128$(objext) \
+ s-fofi128$(objext) \
+ s-imde128$(objext) \
+ s-imfi128$(objext) \
s-imglllb$(objext) \
s-imgllli$(objext) \
s-imglllu$(objext) \
s-pack125$(objext) \
s-pack126$(objext) \
s-pack127$(objext) \
+ s-vade128$(objext) \
+ s-vafi128$(objext) \
s-valllli$(objext) \
s-vallllu$(objext) \
s-widllli$(objext) \
Set_Scope (Standard_Integer_64, Standard_Standard);
Build_Signed_Integer_Type (Standard_Integer_64, 64);
+ Standard_Integer_128 := New_Standard_Entity ("integer_128");
+ Decl := New_Node (N_Full_Type_Declaration, Stloc);
+ Set_Defining_Identifier (Decl, Standard_Integer_128);
+ Set_Scope (Standard_Integer_128, Standard_Standard);
+ Build_Signed_Integer_Type (Standard_Integer_128, 128);
+
-- Standard_*_Unsigned subtypes are not user visible, but they are
-- used internally. They are unsigned types with the same length as
-- the correspondingly named signed integer types.
"What combinations of small, range, and digits are
supported for fixed point types. See 3.5.9(10)."
-For an ordinary fixed point type, the small must lie in 2.0**(-80) .. 2.0**80
-and the range in -10.0**36 .. 10.0**36; any combination is permitted that
-does not result in a mantissa larger than 63 bits. However, if the mantissa
-is larger than 53 bits on machines where Long_Long_Float is 64 bits (true
-of all architectures except x86), then the output from Text_IO may be
-accurate to only 53 bits, rather than the full mantissa. This is because
-floating-point conversions may be used to convert fixed point.
-
-For a decimal fixed point type, the small must lie in 10.0**(-18) .. 10.0**18
-and the digits in 1 .. 18.
+For an ordinary fixed point type, on 32-bit platforms, the small must lie in
+2.0**(-80) .. 2.0**80 and the range in -9.0E+36 .. 9.0E+36; any combination
+is permitted that does not result in a mantissa larger than 63 bits.
+
+On 64-bit platforms, the small must lie in 2.0**(-127) .. 2.0**127 and the
+range in -1.0E+76 .. 1.0E+76; any combination is permitted that does not
+result in a mantissa larger than 63 bits, and any combination is permitted
+that results in a mantissa between 64 and 127 bits if the small is either
+an integer or the reciprocal of an integer.
+
+If the small is either an integer or the reciprocal of an integer, which
+is the case if no ``small`` clause is provided, then the operations of the
+fixed point type are entirely implemented by means of integer instructions.
+In the other cases, some operations, in particular input and output, may be
+implemented by means of floating-point instructions and may be affected by
+accuracy issues on architectures other than x86.
+
+For a decimal fixed point type, on 32-bit platforms, the small must lie in
+1.0E-18 .. 1.0E+18 and the digits in 1 .. 18. On 64-bit platforms, the
+small must lie in 1.0E-38 .. 1.0E+38 and the digits in 1 .. 38.
*
"The result of ``Tags.Expanded_Name`` for types declared
with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Uname; use Uname;
+with Urealp; use Urealp;
with Validsw; use Validsw;
package body Exp_Attr is
-- expands into
- -- Result_Type (System.Fore (Universal_Real (Type'First)),
- -- Universal_Real (Type'Last))
+ -- System.Fore_xx (ftyp (Typ'First), ftyp (Typ'Last) [,pm])
+
+ -- For decimal fixed-point types
+ -- xx = Decimal{32,64,128}
+ -- ftyp = Integer_{32,64,128}
+ -- pm = Typ'Scale
+
+ -- For the most common ordinary fixed-point types
+ -- xx = Fixed{32,64,128}
+ -- ftyp = Integer_{32,64,128}
+ -- pm = Typ'Small
+ -- 1.0 / Typ'Small
+
+ -- For other ordinary fixed-point types
+ -- xx = Real
+ -- ftyp = Universal_Real
+ -- pm = none
-- Note that we know that the type is a nonstatic subtype, or Fore would
- -- have itself been computed dynamically in Eval_Attribute.
+ -- have been computed statically in Eval_Attribute.
when Attribute_Fore =>
- Rewrite (N,
- Convert_To (Typ,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Fore), Loc),
+ declare
+ Arg_List : List_Id;
+ Fid : RE_Id;
+ Ftyp : Entity_Id;
- Parameter_Associations => New_List (
- Convert_To (Universal_Real,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_First)),
+ begin
+ if Is_Decimal_Fixed_Point_Type (Ptyp) then
+ if Esize (Ptyp) <= 32 then
+ Fid := RE_Fore_Decimal32;
+ Ftyp := RTE (RE_Integer_32);
+ elsif Esize (Ptyp) <= 64 then
+ Fid := RE_Fore_Decimal64;
+ Ftyp := RTE (RE_Integer_64);
+ else
+ Fid := RE_Fore_Decimal128;
+ Ftyp := RTE (RE_Integer_128);
+ end if;
- Convert_To (Universal_Real,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_Last))))));
+ else
+ declare
+ Num : constant Uint := Norm_Num (Small_Value (Ptyp));
+ Den : constant Uint := Norm_Den (Small_Value (Ptyp));
+ Max : constant Uint := UI_Max (Num, Den);
+ Min : constant Uint := UI_Min (Num, Den);
+ Siz : constant Uint := Esize (Ptyp);
- Analyze_And_Resolve (N, Typ);
+ begin
+ if Siz <= 32
+ and then Min = Uint_1
+ and then Max <= Uint_2 ** 31
+ then
+ Fid := RE_Fore_Fixed32;
+ Ftyp := RTE (RE_Integer_32);
+ elsif Siz <= 64
+ and then Min = Uint_1
+ and then Max <= Uint_2 ** 63
+ then
+ Fid := RE_Fore_Fixed64;
+ Ftyp := RTE (RE_Integer_64);
+ elsif System_Max_Integer_Size = 128
+ and then Min = Uint_1
+ and then Max <= Uint_2 ** 127
+ then
+ Fid := RE_Fore_Fixed128;
+ Ftyp := RTE (RE_Integer_128);
+ else
+ Fid := RE_Fore_Real;
+ Ftyp := Universal_Real;
+ end if;
+ end;
+ end if;
+
+ Arg_List := New_List (
+ Convert_To (Ftyp,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Attribute_Name => Name_First)));
+
+ Append_To (Arg_List,
+ Convert_To (Ftyp,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Attribute_Name => Name_Last)));
+
+ -- For decimal, append Scale and also set to do literal conversion
+
+ if Is_Decimal_Fixed_Point_Type (Ptyp) then
+ Set_Conversion_OK (First (Arg_List));
+ Set_Conversion_OK (Next (First (Arg_List)));
+
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, Scale_Value (Ptyp)));
+
+ -- For ordinary fixed-point types, append Num, Den parameters
+ -- and also set to do literal conversion
+
+ elsif Fid /= RE_Fore_Real then
+ Set_Conversion_OK (First (Arg_List));
+ Set_Conversion_OK (Next (First (Arg_List)));
+
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Ptyp))));
+
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Ptyp))));
+ end if;
+
+ Rewrite (N,
+ Convert_To (Typ,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (Fid), Loc),
+ Parameter_Associations => Arg_List)));
+
+ Analyze_And_Resolve (N, Typ);
+ end;
--------------
-- Fraction --
-- which used to fail when Fix_Val was a bound of the type and
-- the 'Small was not a representable number.
-- This transformation requires an integer type large enough to
- -- accommodate a fixed-point value. This will not be the case
- -- in systems where Duration is larger than Long_Integer.
+ -- accommodate a fixed-point value.
if Is_Ordinary_Fixed_Point_Type (Target_Type)
and then Is_Floating_Point_Type (Etype (Expr))
- and then RM_Size (Btyp) <= RM_Size (Standard_Long_Integer)
+ and then RM_Size (Btyp) <= System_Max_Integer_Size
and then Nkind (Lo) = N_Real_Literal
and then Nkind (Hi) = N_Real_Literal
then
declare
Expr_Id : constant Entity_Id := Make_Temporary (Loc, 'T', Conv);
- Int_Type : Entity_Id;
+ Int_Typ : constant Entity_Id :=
+ Small_Integer_Type_For (RM_Size (Btyp), False);
begin
- -- Find an integer type of the appropriate size to perform an
- -- unchecked conversion to the target fixed-point type.
-
- if RM_Size (Btyp) > RM_Size (Standard_Integer) then
- Int_Type := Standard_Long_Integer;
-
- elsif RM_Size (Btyp) > RM_Size (Standard_Short_Integer) then
- Int_Type := Standard_Integer;
-
- else
- Int_Type := Standard_Short_Integer;
- end if;
-
-- Generate a temporary with the integer value. Required in the
-- CCG compiler to ensure that run-time checks reference this
-- integer expression (instead of the resulting fixed-point
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Expr_Id,
- Object_Definition => New_Occurrence_Of (Int_Type, Loc),
+ Object_Definition => New_Occurrence_Of (Int_Typ, Loc),
Constant_Present => True,
Expression =>
- Convert_To (Int_Type, Expression (Conv))));
+ Convert_To (Int_Typ, Expression (Conv))));
-- Create integer objects for range checking of result.
Lo_Arg :=
Unchecked_Convert_To
- (Int_Type, New_Occurrence_Of (Expr_Id, Loc));
+ (Int_Typ, New_Occurrence_Of (Expr_Id, Loc));
Lo_Val :=
Make_Integer_Literal (Loc, Corresponding_Integer_Value (Lo));
Hi_Arg :=
Unchecked_Convert_To
- (Int_Type, New_Occurrence_Of (Expr_Id, Loc));
+ (Int_Typ, New_Occurrence_Of (Expr_Id, Loc));
Hi_Val :=
Make_Integer_Literal (Loc, Corresponding_Integer_Value (Hi));
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Urealp; use Urealp;
-- case the types need not be the same, and Build_Multiply chooses a type
-- long enough to hold the product (i.e. twice the size of the longer of
-- the two operand types), and both operands are converted to this type.
- -- The Etype of the result is also set to this value. However, the result
- -- can never overflow Integer_64, so this is the largest type that is ever
- -- generated. On return, the resulting node is analyzed and has Etype set.
+ -- The Etype of the result is also set to this value. On return, the
+ -- resulting node is analyzed and has Etype set.
function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id;
-- Builds an N_Op_Rem node from the given left and right operand
V : Uint;
Negative : Boolean := False) return Node_Id;
-- Given a non-negative universal integer value, build a typed integer
- -- literal node, using the smallest applicable standard integer type. If
- -- and only if Negative is true a negative literal is built. If V exceeds
- -- 2**63-1, the largest value allowed for perfect result set scaling
- -- factors (see RM G.2.3(22)), then Empty is returned. The node N provides
- -- the Sloc value for the constructed literal. The Etype of the resulting
- -- literal is correctly set, and it is marked as analyzed.
+ -- literal node, using the smallest applicable standard integer type.
+ -- If Negative is true, then a negative literal is built. If V exceeds
+ -- 2**(System_Max_Integer_Size - 1) - 1, the largest value allowed for
+ -- perfect result set scaling factors (see RM G.2.3(22)), then Empty is
+ -- returned. The node N provides the Sloc value for the constructed
+ -- literal. The Etype of the resulting literal is correctly set, and it
+ -- is marked as analyzed.
function Real_Literal (N : Node_Id; V : Ureal) return Node_Id;
-- Build a real literal node from the given value, the Etype of the
return L;
end if;
+ -- Otherwise we need to figure out the correct result type size
-- First figure out the effective sizes of the operands. Normally
-- the effective size of an operand is the RM_Size of the operand.
-- But a special case arises with operands whose size is known at
-- compile time. In this case, we can use the actual value of the
- -- operand to get its size if it would fit signed in 8 or 16 bits.
+ -- operand to get its size if it would fit in signed 8/16/32 bits.
Left_Size := UI_To_Int (RM_Size (Left_Type));
declare
Val : constant Uint := Expr_Value (L);
begin
- if Val < Int'(2 ** 7) then
+ if Val < Uint_2 ** 7 then
Left_Size := 8;
- elsif Val < Int'(2 ** 15) then
+ elsif Val < Uint_2 ** 15 then
Left_Size := 16;
+ elsif Val < Uint_2 ** 31 then
+ Left_Size := 32;
end if;
end;
end if;
elsif Rsize <= 32 then
Result_Type := Standard_Integer_32;
- else
+ elsif Rsize <= 64 or else System_Max_Integer_Size < 128 then
Result_Type := Standard_Integer_64;
+
+ else
+ Result_Type := Standard_Integer_128;
end if;
Rnode :=
Expr : Node_Id;
begin
- -- If denominator fits in 64 bits, we can build the operations directly
- -- without causing any intermediate overflow, so that's what we do.
+ -- If the denominator fits in Max_Integer_Size bits, we can build the
+ -- operations directly without causing any intermediate overflow.
- if Nat'Max (Y_Size, Z_Size) <= 32 then
- return
- Build_Divide (N, X, Build_Multiply (N, Y, Z));
+ if 2 * Nat'Max (Y_Size, Z_Size) <= System_Max_Integer_Size then
+ return Build_Divide (N, X, Build_Multiply (N, Y, Z));
-- Otherwise we use the runtime routine
- -- [Qnn : Interfaces.Integer_64,
- -- Rnn : Interfaces.Integer_64;
- -- Double_Divide (X, Y, Z, Qnn, Rnn, Round);
+ -- [Qnn : Interfaces.Integer_{64|128};
+ -- Rnn : Interfaces.Integer_{64|128};
+ -- Double_Divide{64|128} (X, Y, Z, Qnn, Rnn, Round);
-- Qnn]
else
-- Build_Double_Divide_Code --
------------------------------
- -- If the denominator can be computed in 64-bits, we build
+ -- If the denominator can be computed in Max_Integer_Size bits, we build
-- [Nnn : constant typ := typ (X);
-- Dnn : constant typ := typ (Y) * typ (Z)
-- Qnn : constant typ := Nnn / Dnn;
- -- Rnn : constant typ := Nnn / Dnn;
+ -- Rnn : constant typ := Nnn rem Dnn;
- -- If the numerator cannot be computed in 64 bits, we build
+ -- If the denominator cannot be computed in Max_Integer_Size bits, we build
- -- [Qnn : typ;
- -- Rnn : typ;
- -- Double_Divide (X, Y, Z, Qnn, Rnn, Round);]
+ -- [Qnn : Interfaces.Integer_{64|128};
+ -- Rnn : Interfaces.Integer_{64|128};
+ -- Double_Divide{64|128} (X, Y, Z, Qnn, Rnn, Round);]
procedure Build_Double_Divide_Code
(N : Node_Id;
Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y)));
Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z)));
+ QR_Id : RE_Id;
QR_Siz : Nat;
QR_Typ : Entity_Id;
Rnd : Entity_Id;
begin
- -- Find type that will allow computation of numerator
+ -- Find type that will allow computation of denominator
QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size));
if QR_Siz <= 16 then
QR_Typ := Standard_Integer_16;
+ QR_Id := RE_Null;
+
elsif QR_Siz <= 32 then
QR_Typ := Standard_Integer_32;
+ QR_Id := RE_Null;
+
elsif QR_Siz <= 64 then
QR_Typ := Standard_Integer_64;
+ QR_Id := RE_Null;
+
+ elsif QR_Siz <= 128 and then System_Max_Integer_Size = 128 then
+ QR_Typ := Standard_Integer_128;
+ QR_Id := RE_Null;
- -- For more than 64, bits, we use the 64-bit integer defined in
+ -- For more than Max_Integer_Size bits, we use the integer defined in
-- Interfaces, so that it can be handled by the runtime routine.
- else
+ elsif System_Max_Integer_Size < 128 then
QR_Typ := RTE (RE_Integer_64);
+ QR_Id := RE_Double_Divide64;
+
+ else
+ QR_Typ := RTE (RE_Integer_128);
+ QR_Id := RE_Double_Divide128;
end if;
-- Define quotient and remainder, and set their Etypes, so
Set_Etype (Qnn, QR_Typ);
Set_Etype (Rnn, QR_Typ);
- -- Case that we can compute the denominator in 64 bits
+ -- Case that we can compute the denominator in Max_Integer_Size bits
- if QR_Siz <= 64 then
+ if QR_Siz <= System_Max_Integer_Size then
-- Create temporaries for numerator and denominator and set Etypes,
-- so that New_Occurrence_Of picks them up for Build_xxx calls.
Defining_Identifier => Nnn,
Object_Definition => New_Occurrence_Of (QR_Typ, Loc),
Constant_Present => True,
- Expression => Build_Conversion (N, QR_Typ, X)),
+ Expression => Build_Conversion (N, QR_Typ, X)),
Make_Object_Declaration (Loc,
Defining_Identifier => Dnn,
Object_Definition => New_Occurrence_Of (QR_Typ, Loc),
Constant_Present => True,
- Expression =>
- Build_Multiply (N,
- Build_Conversion (N, QR_Typ, Y),
- Build_Conversion (N, QR_Typ, Z))));
+ Expression => Build_Multiply (N, Y, Z)));
Quo :=
Build_Divide (N,
New_Occurrence_Of (Nnn, Loc),
New_Occurrence_Of (Dnn, Loc))));
- -- Case where denominator does not fit in 64 bits, so we have to
- -- call the runtime routine to compute the quotient and remainder
+ -- Case where denominator does not fit in Max_Integer_Size bits, we have
+ -- to call the runtime routine to compute the quotient and remainder.
else
Rnd := Boolean_Literals (Rounded_Result_Set (N));
Object_Definition => New_Occurrence_Of (QR_Typ, Loc)),
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Double_Divide64), Loc),
+ Name => New_Occurrence_Of (RTE (QR_Id), Loc),
Parameter_Associations => New_List (
Build_Conversion (N, QR_Typ, X),
Build_Conversion (N, QR_Typ, Y),
-- the effective size of an operand is the RM_Size of the operand.
-- But a special case arises with operands whose size is known at
-- compile time. In this case, we can use the actual value of the
- -- operand to get its size if it would fit signed in 8 or 16 bits.
+ -- operand to get its size if it would fit in signed 8/16/32 bits.
Left_Size := UI_To_Int (RM_Size (Left_Type));
declare
Val : constant Uint := Expr_Value (L);
begin
- if Val < Int'(2 ** 7) then
+ if Val < Uint_2 ** 7 then
Left_Size := 8;
- elsif Val < Int'(2 ** 15) then
+ elsif Val < Uint_2 ** 15 then
Left_Size := 16;
+ elsif Val < Uint_2 ** 31 then
+ Left_Size := 32;
end if;
end;
end if;
elsif Rsize <= 32 then
Result_Type := Standard_Integer_32;
- else
+ elsif Rsize <= 64 or else System_Max_Integer_Size < 128 then
Result_Type := Standard_Integer_64;
+
+ else
+ Result_Type := Standard_Integer_128;
end if;
Rnode :=
Expr : Node_Id;
begin
- -- If numerator fits in 64 bits, we can build the operations directly
- -- without causing any intermediate overflow, so that's what we do.
+ -- If the numerator fits in Max_Integer_Size bits, we can build the
+ -- operations directly without causing any intermediate overflow.
- if Nat'Max (X_Size, Y_Size) <= 32 then
- return
- Build_Divide (N, Build_Multiply (N, X, Y), Z);
+ if 2 * Nat'Max (X_Size, Y_Size) <= System_Max_Integer_Size then
+ return Build_Divide (N, Build_Multiply (N, X, Y), Z);
-- Otherwise we use the runtime routine
- -- [Qnn : Integer_64,
- -- Rnn : Integer_64;
- -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round);
+ -- [Qnn : Integer_{64|128},
+ -- Rnn : Integer_{64|128};
+ -- Scaled_Divide{64|128} (X, Y, Z, Qnn, Rnn, Round);
-- Qnn]
else
-- Build_Scaled_Divide_Code --
------------------------------
- -- If the numerator can be computed in 64-bits, we build
+ -- If the numerator can be computed in Max_Integer_Size bits, we build
-- [Nnn : constant typ := typ (X) * typ (Y);
-- Dnn : constant typ := typ (Z)
-- Qnn : constant typ := Nnn / Dnn;
- -- Rnn : constant typ := Nnn / Dnn;
+ -- Rnn : constant typ := Nnn rem Dnn;
- -- If the numerator cannot be computed in 64 bits, we build
+ -- If the numerator cannot be computed in Max_Integer_Size bits, we build
- -- [Qnn : Interfaces.Integer_64;
- -- Rnn : Interfaces.Integer_64;
- -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round);]
+ -- [Qnn : Interfaces.Integer_{64|128};
+ -- Rnn : Interfaces.Integer_{64|128};
+ -- Scaled_Divide_{64|128} (X, Y, Z, Qnn, Rnn, Round);]
procedure Build_Scaled_Divide_Code
(N : Node_Id;
Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y)));
Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z)));
+ QR_Id : RE_Id;
QR_Siz : Nat;
QR_Typ : Entity_Id;
begin
-- Find type that will allow computation of numerator
- QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size));
+ QR_Siz := Nat'Max (2 * Nat'Max (X_Size, Y_Size), Z_Size);
if QR_Siz <= 16 then
QR_Typ := Standard_Integer_16;
+ QR_Id := RE_Null;
+
elsif QR_Siz <= 32 then
QR_Typ := Standard_Integer_32;
+ QR_Id := RE_Null;
+
elsif QR_Siz <= 64 then
QR_Typ := Standard_Integer_64;
+ QR_Id := RE_Null;
- -- For more than 64, bits, we use the 64-bit integer defined in
+ elsif QR_Siz <= 128 and then System_Max_Integer_Size = 128 then
+ QR_Typ := Standard_Integer_128;
+ QR_Id := RE_Null;
+
+ -- For more than Max_Integer_Size bits, we use the integer defined in
-- Interfaces, so that it can be handled by the runtime routine.
- else
+ elsif System_Max_Integer_Size < 128 then
QR_Typ := RTE (RE_Integer_64);
+ QR_Id := RE_Scaled_Divide64;
+
+ else
+ QR_Typ := RTE (RE_Integer_128);
+ QR_Id := RE_Scaled_Divide128;
end if;
-- Define quotient and remainder, and set their Etypes, so
Set_Etype (Qnn, QR_Typ);
Set_Etype (Rnn, QR_Typ);
- -- Case that we can compute the numerator in 64 bits
+ -- Case that we can compute the numerator in Max_Integer_Size bits
- if QR_Siz <= 64 then
+ if QR_Siz <= System_Max_Integer_Size then
Nnn := Make_Temporary (Loc, 'N');
Dnn := Make_Temporary (Loc, 'D');
Defining_Identifier => Nnn,
Object_Definition => New_Occurrence_Of (QR_Typ, Loc),
Constant_Present => True,
- Expression =>
- Build_Multiply (N,
- Build_Conversion (N, QR_Typ, X),
- Build_Conversion (N, QR_Typ, Y))),
+ Expression => Build_Multiply (N, X, Y)),
Make_Object_Declaration (Loc,
Defining_Identifier => Dnn,
Object_Definition => New_Occurrence_Of (QR_Typ, Loc),
Constant_Present => True,
- Expression => Build_Conversion (N, QR_Typ, Z)));
+ Expression => Build_Conversion (N, QR_Typ, Z)));
Quo :=
Build_Divide (N,
New_Occurrence_Of (Nnn, Loc),
New_Occurrence_Of (Dnn, Loc))));
- -- Case where numerator does not fit in 64 bits, so we have to
- -- call the runtime routine to compute the quotient and remainder
+ -- Case where numerator does not fit in Max_Integer_Size bits, we have
+ -- to call the runtime routine to compute the quotient and remainder.
else
Rnd := Boolean_Literals (Rounded_Result_Set (N));
Object_Definition => New_Occurrence_Of (QR_Typ, Loc)),
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Scaled_Divide64), Loc),
+ Name => New_Occurrence_Of (RTE (QR_Id), Loc),
Parameter_Associations => New_List (
Build_Conversion (N, QR_Typ, X),
Build_Conversion (N, QR_Typ, Y),
if Present (Lit_Int) then
Set_Result (N,
- Build_Multiply (N, Build_Multiply (N, Left, Right),
- Lit_Int));
+ Build_Multiply (N, Build_Multiply (N, Left, Right), Lit_Int));
return;
end if;
elsif V < Uint_2 ** 63 then
T := Standard_Integer_64;
+ elsif V < Uint_2 ** 127 and then System_Max_Integer_Size = 128 then
+ T := Standard_Integer_128;
+
else
return Empty;
end if;
package body Exp_Imgv is
- function Has_Decimal_Small (E : Entity_Id) return Boolean;
- -- Applies to all entities. True for a Decimal_Fixed_Point_Type, or an
- -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten.
- -- Shouldn't this be in einfo.adb or sem_aux.adb???
-
procedure Rewrite_Object_Image
(N : Node_Id;
Pref : Entity_Id;
-- xx = Boolean
-- tv = Boolean (Expr)
- -- For signed integer types with size <= Integer'Size
- -- xx = Integer
- -- tv = Integer (Expr)
-
- -- For other signed integer types
- -- xx = Long_Long_Integer
- -- tv = Long_Long_Integer (Expr)
-
- -- For modular types with modulus <= System.Unsigned_Types.Unsigned
- -- xx = Unsigned
- -- tv = System.Unsigned_Types.Unsigned (Expr)
+ -- For signed integer types
+ -- xx = [Long_Long_[Long_]]Integer
+ -- tv = [Long_Long_[Long_]]Integer (Expr)
- -- For other modular integer types
- -- xx = Long_Long_Unsigned
- -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
+ -- For modular types
+ -- xx = [Long_Long_[Long_]]Unsigned
+ -- tv = System.Unsigned_Types.[Long_Long_[Long_]]Unsigned (Expr)
-- For types whose root type is Wide_Character
-- xx = Wide_Character
-- tv = Long_Long_Float (Expr)
-- pm = typ'Digits (typ = subtype of expression)
- -- For ordinary fixed-point types
+ -- For decimal fixed-point types
+ -- xx = Decimal{32,64,128}
+ -- tv = Integer_{32,64,128} (Expr)? [convert with no scaling]
+ -- pm = typ'Scale (typ = subtype of expression)
+
+ -- For the most common ordinary fixed-point types
+ -- xx = Fixed{32,64,128}
+ -- tv = Integer_{32,64,128} (Expr) [convert with no scaling]
+ -- pm = typ'Small (typ = subtype of expression)
+ -- 1.0 / typ'Small
+ -- (Integer_{32,64,128} x typ'Small)'Fore
+ -- typ'Aft
+
+ -- For other ordinary fixed-point types
-- xx = Ordinary_Fixed_Point
-- tv = Long_Long_Float (Expr)
-- pm = typ'Aft (typ = subtype of expression)
- -- For decimal fixed-point types with size = Integer'Size
- -- xx = Decimal
- -- tv = Integer (Expr)
- -- pm = typ'Scale (typ = subtype of expression)
-
- -- For decimal fixed-point types with size > Integer'Size
- -- xx = Long_Long_Decimal
- -- tv = Long_Long_Integer?(Expr) [convert with no scaling]
- -- pm = typ'Scale (typ = subtype of expression)
-
-- For enumeration types other than those declared in package Standard
-- or System, Snn, Pnn, are expanded as above, but the call looks like:
Tent := RTE (RE_Long_Long_Long_Unsigned);
end if;
- elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then
- if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
- Imid := RE_Image_Decimal;
- Tent := Standard_Integer;
+ elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
+ if Esize (Rtyp) <= 32 then
+ Imid := RE_Image_Decimal32;
+ Tent := RTE (RE_Integer_32);
+ elsif Esize (Rtyp) <= 64 then
+ Imid := RE_Image_Decimal64;
+ Tent := RTE (RE_Integer_64);
else
- Imid := RE_Image_Long_Long_Decimal;
- Tent := Standard_Long_Long_Integer;
+ Imid := RE_Image_Decimal128;
+ Tent := RTE (RE_Integer_128);
end if;
elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
- Imid := RE_Image_Ordinary_Fixed_Point;
- Tent := Standard_Long_Long_Float;
+ declare
+ Num : constant Uint := Norm_Num (Small_Value (Rtyp));
+ Den : constant Uint := Norm_Den (Small_Value (Rtyp));
+ Max : constant Uint := UI_Max (Num, Den);
+ Min : constant Uint := UI_Min (Num, Den);
+ Siz : constant Uint := Esize (Rtyp);
+
+ begin
+ if Siz <= 32
+ and then Min = Uint_1
+ and then Max <= Uint_2 ** 31
+ then
+ Imid := RE_Image_Fixed32;
+ Tent := RTE (RE_Integer_32);
+ elsif Siz <= 64
+ and then Min = Uint_1
+ and then Max <= Uint_2 ** 63
+ then
+ Imid := RE_Image_Fixed64;
+ Tent := RTE (RE_Integer_64);
+ elsif System_Max_Integer_Size = 128
+ and then Min = Uint_1
+ and then Max <= Uint_2 ** 127
+ then
+ Imid := RE_Image_Fixed128;
+ Tent := RTE (RE_Integer_128);
+ else
+ Imid := RE_Image_Ordinary_Fixed_Point;
+ Tent := Standard_Long_Long_Float;
+ end if;
+ end;
elsif Is_Floating_Point_Type (Rtyp) then
Imid := RE_Image_Floating_Point;
Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Digits));
- -- For ordinary fixed-point types, append Aft parameter
+ -- For decimal, append Scale and also set to do literal conversion
- elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
- Append_To (Arg_List,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_Aft));
+ elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
+ Set_Conversion_OK (First (Arg_List));
+
+ Append_To (Arg_List, Make_Integer_Literal (Loc, Scale_Value (Ptyp)));
- if Has_Decimal_Small (Rtyp) then
+ -- For ordinary fixed-point types, append Num, Den, Fore, Aft parameters
+ -- and also set to do literal conversion.
+
+ elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
+ if Imid /= RE_Image_Ordinary_Fixed_Point then
Set_Conversion_OK (First (Arg_List));
- Set_Etype (First (Arg_List), Tent);
- end if;
- -- For decimal, append Scale and also set to do literal conversion
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Ptyp))));
- elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
- Append_To (Arg_List,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_Scale));
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Ptyp))));
- Set_Conversion_OK (First (Arg_List));
- Set_Etype (First (Arg_List), Tent);
+ -- We want to compute the Fore value for the fixed point type
+ -- whose mantissa type is Tent and whose small is typ'Small.
+
+ declare
+ T : Ureal := Uint_2 ** (Esize (Tent) - 1) * Small_Value (Ptyp);
+ F : Nat := 2;
+
+ begin
+ while T >= Ureal_10 loop
+ F := F + 1;
+ T := T / Ureal_10;
+ end loop;
+
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, UI_From_Int (F)));
+ end;
+ end if;
+
+ Append_To (Arg_List, Make_Integer_Literal (Loc, Aft_Value (Ptyp)));
-- For Wide_Character, append Ada 2005 indication
-- For types whose root type is Boolean
-- xx = Boolean
- -- For signed integer types with size <= Integer'Size
- -- xx = Integer
-
- -- For other signed integer types
- -- xx = Long_Long_Integer
-
- -- For modular types with modulus <= System.Unsigned_Types.Unsigned
- -- xx = Unsigned
+ -- For signed integer types
+ -- xx = [Long_Long_[Long_]]Integer
- -- For other modular integer types
- -- xx = Long_Long_Unsigned
+ -- For modular types
+ -- xx = [Long_Long_[Long_]]Unsigned
- -- For floating-point types and ordinary fixed-point types
+ -- For floating-point types
-- xx = Real
- -- For Wide_[Wide_]Character types, typ'Value (X) expands into:
+ -- For decimal fixed-point types, typ'Value (X) expands into
- -- btyp (Value_xx (X, EM))
+ -- btyp?(Value_Decimal{32,64,128} (X, typ'Scale));
- -- where btyp is the base type of the prefix, and EM is the encoding method
+ -- For the most common ordinary fixed-point types
- -- For decimal types with size <= Integer'Size, typ'Value (X)
- -- expands into
+ -- btyp?(Value_Fixed{32,64,128} (X, S, 1.0 / S));
+ -- where S = typ'Small
- -- btyp?(Value_Decimal (X, typ'Scale));
+ -- For Wide_[Wide_]Character types, typ'Value (X) expands into:
- -- For all other decimal types, typ'Value (X) expands into
+ -- btyp (Value_xx (X, EM))
- -- btyp?(Value_Long_Long_Decimal (X, typ'Scale))
+ -- where btyp is the base type of the prefix, and EM is the encoding method
-- For enumeration types other than those derived from types Boolean,
-- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
end if;
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
- if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
- Vid := RE_Value_Decimal;
+ if Esize (Rtyp) <= 32 and then abs (Scale_Value (Rtyp)) <= 9 then
+ Vid := RE_Value_Decimal32;
+ elsif Esize (Rtyp) <= 64 and then abs (Scale_Value (Rtyp)) <= 18 then
+ Vid := RE_Value_Decimal64;
else
- Vid := RE_Value_Long_Long_Decimal;
+ Vid := RE_Value_Decimal128;
end if;
- Append_To (Args,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Scale));
+ Append_To (Args, Make_Integer_Literal (Loc, Scale_Value (Rtyp)));
Rewrite (N,
OK_Convert_To (Btyp,
Analyze_And_Resolve (N, Btyp);
return;
- elsif Is_Real_Type (Rtyp) then
+ elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
+ declare
+ Num : constant Uint := Norm_Num (Small_Value (Rtyp));
+ Den : constant Uint := Norm_Den (Small_Value (Rtyp));
+ Max : constant Uint := UI_Max (Num, Den);
+ Min : constant Uint := UI_Min (Num, Den);
+ Siz : constant Uint := Esize (Rtyp);
+
+ begin
+ if Siz <= 32
+ and then Min = Uint_1
+ and then Max <= Uint_2 ** 31
+ then
+ Vid := RE_Value_Fixed32;
+ elsif Siz <= 64
+ and then Min = Uint_1
+ and then Max <= Uint_2 ** 63
+ then
+ Vid := RE_Value_Fixed64;
+ elsif System_Max_Integer_Size = 128
+ and then Min = Uint_1
+ and then Max <= Uint_2 ** 127
+ then
+ Vid := RE_Value_Fixed128;
+ else
+ Vid := RE_Value_Real;
+ end if;
+
+ if Vid /= RE_Value_Real then
+ Append_To (Args,
+ Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Rtyp))));
+
+ Append_To (Args,
+ Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Rtyp))));
+
+ Rewrite (N,
+ OK_Convert_To (Btyp,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (Vid), Loc),
+ Parameter_Associations => Args)));
+
+ Set_Etype (N, Btyp);
+ Analyze_And_Resolve (N, Btyp);
+ return;
+ end if;
+ end;
+
+ elsif Is_Floating_Point_Type (Rtyp) then
Vid := RE_Value_Real;
-- Only other possibility is user-defined enumeration type
-- yy = Boolean
-- For signed integer types
- -- xx = Width_Long_Long_Integer
- -- yy = Long_Long_Integer
+ -- xx = Width_[Long_Long_[Long_]]Integer
+ -- yy = [Long_Long_[Long_]]Integer
-- For modular integer types
- -- xx = Width_Long_Long_Unsigned
- -- yy = Long_Long_Unsigned
+ -- xx = Width_[Long_Long_[Long_]]Unsigned
+ -- yy = [Long_Long_[Long_]]Unsigned
-- For types derived from Wide_Character, typ'Width expands into
-- Wide_Wide_Character (typ'First),
-- Wide_Wide_Character (typ'Last));
- -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
+ -- For fixed point types, typ'Width and typ'Wide_[Wide_]Width expand into
+
+ -- if Ptyp'First > Ptyp'Last then 0 else Ptyp'Fore + 1 + Ptyp'Aft end if
+
+ -- and for floating point types, they expand into
-- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
YY := RTE (RE_Long_Long_Long_Unsigned);
end if;
- -- Real types
+ -- Fixed point types
- elsif Is_Real_Type (Rtyp) then
+ elsif Is_Fixed_Point_Type (Rtyp) then
+ Rewrite (N,
+ Make_If_Expression (Loc,
+ Expressions => New_List (
+
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Attribute_Name => Name_First),
+
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Attribute_Name => Name_Last)),
+
+ Make_Integer_Literal (Loc, 0),
+
+ Make_Op_Add (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Attribute_Name => Name_Fore),
+
+ Make_Op_Add (Loc,
+ Make_Integer_Literal (Loc, 1),
+ Make_Integer_Literal (Loc, Aft_Value (Ptyp)))))));
+
+ Analyze_And_Resolve (N, Typ);
+ return;
+
+ -- Floating point types
+
+ elsif Is_Floating_Point_Type (Rtyp) then
Rewrite (N,
Make_If_Expression (Loc,
Expressions => New_List (
Analyze_And_Resolve (N, Typ);
end Expand_Width_Attribute;
- -----------------------
- -- Has_Decimal_Small --
- -----------------------
-
- function Has_Decimal_Small (E : Entity_Id) return Boolean is
- begin
- return Is_Decimal_Fixed_Point_Type (E)
- or else
- (Is_Ordinary_Fixed_Point_Type (E)
- and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1);
- end Has_Decimal_Small;
-
--------------------------
-- Rewrite_Object_Image --
--------------------------
if Is_Fixed_Point_Type (E) then
Freeze_Fixed_Point_Type (E);
- -- Some error checks required for ordinary fixed-point type. Defer
- -- these till the freeze-point since we need the small and range
- -- values. We only do these checks for base types
-
- if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then
- if Small_Value (E) < Ureal_2_M_80 then
- Error_Msg_Name_1 := Name_Small;
- Error_Msg_N
- ("`&''%` too small, minimum allowed is 2.0'*'*(-80)", E);
-
- elsif Small_Value (E) > Ureal_2_80 then
- Error_Msg_Name_1 := Name_Small;
- Error_Msg_N
- ("`&''%` too large, maximum allowed is 2.0'*'*80", E);
- end if;
-
- if Expr_Value_R (Type_Low_Bound (E)) < Ureal_M_10_36 then
- Error_Msg_Name_1 := Name_First;
- Error_Msg_N
- ("`&''%` too small, minimum allowed is -10.0'*'*36", E);
- end if;
-
- if Expr_Value_R (Type_High_Bound (E)) > Ureal_10_36 then
- Error_Msg_Name_1 := Name_Last;
- Error_Msg_N
- ("`&''%` too large, maximum allowed is 10.0'*'*36", E);
- end if;
- end if;
-
elsif Is_Enumeration_Type (E) then
Freeze_Enumeration_Type (E);
-- Returns size of type with given bounds. Also leaves these
-- bounds set as the current bounds of the Typ.
+ function Larger (A, B : Ureal) return Boolean;
+ -- Returns true if A > B with a margin of Typ'Small
+
+ function Smaller (A, B : Ureal) return Boolean;
+ -- Returns true if A < B with a margin of Typ'Small
+
-----------
-- Fsize --
-----------
return Minimum_Size (Typ);
end Fsize;
+ ------------
+ -- Larger --
+ ------------
+
+ function Larger (A, B : Ureal) return Boolean is
+ begin
+ return A > B and then A - Small > B;
+ end Larger;
+
+ -------------
+ -- Smaller --
+ -------------
+
+ function Smaller (A, B : Ureal) return Boolean is
+ begin
+ return A < B and then A + Small < B;
+ end Smaller;
+
-- Start of processing for Freeze_Fixed_Point_Type
begin
if Present (Atype) then
Set_Esize (Typ, Esize (Atype));
else
- Set_Esize (Typ, Esize (Base_Type (Typ)));
+ Set_Esize (Typ, Esize (Btyp));
end if;
end if;
Set_Realval (Hi, Actual_Hi);
end Fudge;
+ -- Enforce some limitations for ordinary fixed-point types. They come
+ -- from an exact algorithm used to implement Text_IO.Fixed_IO and the
+ -- Fore, Image and Value attributes. The requirement on the Small is
+ -- to lie in the range 2**(-(Siz - 1)) .. 2**(Siz - 1) for a type of
+ -- Siz bits (Siz=32,64,128) and the requirement on the bounds is to
+ -- be smaller in magnitude than 10.0**N * 2**(Siz - 1), where N is
+ -- given by the formula N = floor ((Siz - 1) * log 2 / log 10).
+
+ -- If the bounds of a 32-bit type are too large, force 64-bit type
+
+ if Actual_Size <= 32
+ and then Small <= Ureal_2_31
+ and then (Smaller (Expr_Value_R (Lo), Ureal_M_2_10_18)
+ or else Larger (Expr_Value_R (Hi), Ureal_2_10_18))
+ then
+ Actual_Size := 33;
+ end if;
+
+ -- If the bounds of a 64-bit type are too large, force 128-bit type
+
+ if System_Max_Integer_Size = 128
+ and then Actual_Size <= 64
+ and then Small <= Ureal_2_63
+ and then (Smaller (Expr_Value_R (Lo), Ureal_M_9_10_36)
+ or else Larger (Expr_Value_R (Hi), Ureal_9_10_36))
+ then
+ Actual_Size := 65;
+ end if;
+
+ -- Give error messages for first subtypes and not base types, as the
+ -- bounds of base types are always maximum for their size, see below.
+
+ if System_Max_Integer_Size < 128 and then Typ /= Btyp then
+
+ -- See the 128-bit case below for the reason why we cannot test
+ -- against the 2**(-63) .. 2**63 range. This quirk should have
+ -- been kludged around as in the 128-bit case below, but it was
+ -- not and we end up with a ludicrous range as a result???
+
+ if Small < Ureal_2_M_80 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` too small, minimum allowed is 2.0'*'*(-80)", Typ);
+
+ elsif Small > Ureal_2_80 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` too large, maximum allowed is 2.0'*'*80", Typ);
+ end if;
+
+ if Smaller (Expr_Value_R (Lo), Ureal_M_9_10_36) then
+ Error_Msg_Name_1 := Name_First;
+ Error_Msg_N
+ ("`&''%` too small, minimum allowed is -9.0E+36", Typ);
+ end if;
+
+ if Larger (Expr_Value_R (Hi), Ureal_9_10_36) then
+ Error_Msg_Name_1 := Name_Last;
+ Error_Msg_N
+ ("`&''%` too large, maximum allowed is 9.0E+36", Typ);
+ end if;
+
+ elsif System_Max_Integer_Size = 128 and then Typ /= Btyp then
+
+ -- ACATS c35902d tests a delta equal to 2**(-(Max_Mantissa + 1))
+ -- but we cannot really support anything smaller than Fine_Delta
+ -- because of the way we implement I/O for fixed point types???
+
+ if Small = Ureal_2_M_128 then
+ null;
+
+ elsif Small < Ureal_2_M_127 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` too small, minimum allowed is 2.0'*'*(-127)", Typ);
+
+ elsif Small > Ureal_2_127 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` too large, maximum allowed is 2.0'*'*127", Typ);
+ end if;
+
+ if Actual_Size > 64
+ and then Norm_Num (Small) /= Uint_1
+ and then Norm_Den (Small) /= Uint_1
+ then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` not an integer or reciprocal of an integer", Typ);
+ end if;
+
+ if Smaller (Expr_Value_R (Lo), Ureal_M_10_76) then
+ Error_Msg_Name_1 := Name_First;
+ Error_Msg_N
+ ("`&''%` too small, minimum allowed is -1.0E+76", Typ);
+ end if;
+
+ if Larger (Expr_Value_R (Hi), Ureal_10_76) then
+ Error_Msg_Name_1 := Name_Last;
+ Error_Msg_N
+ ("`&''%` too large, maximum allowed is 1.0E+76", Typ);
+ end if;
+ end if;
+
-- For the decimal case, none of this fudging is required, since there
-- are no end-point problems in the decimal case (the end-points are
-- always included).
-- At this stage, the actual size has been calculated and the proper
-- required bounds are stored in the low and high bounds.
- if Actual_Size > 64 then
+ if Actual_Size > System_Max_Integer_Size then
Error_Msg_Uint_1 := UI_From_Int (Actual_Size);
+ Error_Msg_Uint_2 := UI_From_Int (System_Max_Integer_Size);
Error_Msg_N
- ("size required (^) for type& too large, maximum allowed is 64",
+ ("size required (^) for type& too large, maximum allowed is ^",
Typ);
- Actual_Size := 64;
+ Actual_Size := System_Max_Integer_Size;
end if;
-- Check size against explicit given size
Actual_Size := 16;
elsif Actual_Size <= 32 then
Actual_Size := 32;
- else
+ elsif Actual_Size <= 64 then
Actual_Size := 64;
+ else
+ Actual_Size := 128;
end if;
Init_Esize (Typ, Actual_Size);
-- the full width of the allocated size in bits, to avoid junk range
-- checks on intermediate computations.
- if Base_Type (Typ) = Typ then
+ if Typ = Btyp then
Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1))));
Set_Realval (Hi, (Small * (Uint_2 ** (Actual_Size - 1) - 1)));
end if;
supported for fixed point types. See 3.5.9(10)."
@end itemize
-For an ordinary fixed point type, the small must lie in 2.0**(-80) .. 2.0**80
-and the range in -10.0**36 .. 10.0**36; any combination is permitted that
-does not result in a mantissa larger than 63 bits. However, if the mantissa
-is larger than 53 bits on machines where Long_Long_Float is 64 bits (true
-of all architectures except x86), then the output from Text_IO may be
-accurate to only 53 bits, rather than the full mantissa. This is because
-floating-point conversions may be used to convert fixed point.
-
-For a decimal fixed point type, the small must lie in 10.0**(-18) .. 10.0**18
-and the digits in 1 .. 18.
+For an ordinary fixed point type, on 32-bit platforms, the small must lie in
+2.0**(-80) .. 2.0**80 and the range in -9.0E+36 .. 9.0E+36; any combination
+is permitted that does not result in a mantissa larger than 63 bits.
+
+On 64-bit platforms, the small must lie in 2.0**(-127) .. 2.0**127 and the
+range in -1.0E+76 .. 1.0E+76; any combination is permitted that does not
+result in a mantissa larger than 63 bits, and any combination is permitted
+that results in a mantissa between 64 and 127 bits if the small is either
+an integer or the reciprocal of an integer.
+
+If the small is either an integer or the reciprocal of an integer, which
+is the case if no @code{small} clause is provided, then the operations of the
+fixed point type are entirely implemented by means of integer instructions.
+In the other cases, some operations, in particular input and output, may be
+implemented by means of floating-point instructions and may be affected by
+accuracy issues on architectures other than x86.
+
+For a decimal fixed point type, on 32-bit platforms, the small must lie in
+1.0E-18 .. 1.0E+18 and the digits in 1 .. 18. On 64-bit platforms, the
+small must lie in 1.0E-38 .. 1.0E+38 and the digits in 1 .. 38.
@itemize *
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . D E C I M A L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the 128-bit version of this package
+
+package Ada.Decimal is
+ pragma Pure;
+
+ -- The compiler makes a number of assumptions based on the following five
+ -- constants (e.g. there is an assumption that decimal values can always
+ -- be represented in 128-bit signed binary form), so code modifications are
+ -- required to increase these constants.
+
+ Max_Scale : constant := +38;
+ Min_Scale : constant := -38;
+
+ Min_Delta : constant := 1.0E-38;
+ Max_Delta : constant := 1.0E+38;
+
+ Max_Decimal_Digits : constant := 38;
+
+ generic
+ type Dividend_Type is delta <> digits <>;
+ type Divisor_Type is delta <> digits <>;
+ type Quotient_Type is delta <> digits <>;
+ type Remainder_Type is delta <> digits <>;
+
+ procedure Divide
+ (Dividend : Dividend_Type;
+ Divisor : Divisor_Type;
+ Quotient : out Quotient_Type;
+ Remainder : out Remainder_Type);
+
+private
+ pragma Inline (Divide);
+
+end Ada.Decimal;
with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
with Ada.Text_IO.Float_Aux; use Ada.Text_IO.Float_Aux;
-with System.Img_Dec; use System.Img_Dec;
-with System.Img_LLD; use System.Img_LLD;
-with System.Val_Dec; use System.Val_Dec;
-with System.Val_LLD; use System.Val_LLD;
-
package body Ada.Text_IO.Decimal_Aux is
- -------------
- -- Get_Dec --
- -------------
+ ---------
+ -- Get --
+ ---------
- function Get_Dec
+ function Get
(File : File_Type;
Width : Field;
- Scale : Integer) return Integer
+ Scale : Integer) return Int
is
Buf : String (1 .. Field'Last);
Ptr : aliased Integer;
Stop : Integer := 0;
- Item : Integer;
+ Item : Int;
begin
if Width /= 0 then
Ptr := 1;
end if;
- Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Item := Scan (Buf, Ptr'Access, Stop, Scale);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
return Item;
- end Get_Dec;
-
- -------------
- -- Get_LLD --
- -------------
-
- function Get_LLD
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Long_Long_Integer
- is
- Buf : String (1 .. Field'Last);
- Ptr : aliased Integer;
- Stop : Integer := 0;
- Item : Long_Long_Integer;
+ end Get;
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Real (File, Buf, Stop);
- Ptr := 1;
- end if;
+ ----------
+ -- Gets --
+ ----------
- Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- return Item;
- end Get_LLD;
-
- --------------
- -- Gets_Dec --
- --------------
-
- function Gets_Dec
+ function Gets
(From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer
+ Last : out Positive;
+ Scale : Integer) return Int
is
Pos : aliased Integer;
- Item : Integer;
+ Item : Int;
begin
String_Skip (From, Pos);
- Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
+ Item := Scan (From, Pos'Access, From'Last, Scale);
+ Last := Pos - 1;
return Item;
exception
when Constraint_Error =>
- Last.all := Pos - 1;
+ Last := Pos - 1;
raise Data_Error;
- end Gets_Dec;
-
- --------------
- -- Gets_LLD --
- --------------
-
- function Gets_LLD
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer
- is
- Pos : aliased Integer;
- Item : Long_Long_Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
- return Item;
-
- exception
- when Constraint_Error =>
- Last.all := Pos - 1;
- raise Data_Error;
- end Gets_LLD;
-
- -------------
- -- Put_Dec --
- -------------
+ end Gets;
- procedure Put_Dec
- (File : File_Type;
- Item : Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
- Put_Item (File, Buf (1 .. Ptr));
- end Put_Dec;
-
- -------------
- -- Put_LLD --
- -------------
+ ---------
+ -- Put --
+ ---------
- procedure Put_LLD
+ procedure Put
(File : File_Type;
- Item : Long_Long_Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
Ptr : Natural := 0;
begin
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
- end Put_LLD;
+ end Put;
- --------------
- -- Puts_Dec --
- --------------
+ ----------
+ -- Puts --
+ ----------
- procedure Puts_Dec
+ procedure Puts
(To : out String;
- Item : Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
Fore : Integer;
Ptr : Natural := 0;
begin
- -- Compute Fore, allowing for Aft digits and the decimal dot
+ -- Compute Fore, allowing for the decimal dot and Aft digits
- Fore := To'Length - Field'Max (1, Aft) - 1;
+ Fore := To'Length - 1 - Field'Max (1, Aft);
- -- Allow for Exp and two more for E+ or E- if exponent present
+ -- Allow for Exp and one more for E if exponent present
if Exp /= 0 then
- Fore := Fore - 2 - Exp;
+ Fore := Fore - 1 - Field'Max (2, Exp);
end if;
-- Make sure we have enough room
- if Fore < 1 then
+ if Fore < 1 + Boolean'Pos (Item < 0) then
raise Layout_Error;
end if;
-- Do the conversion and check length of result
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To := Buf (1 .. Ptr);
- end if;
- end Puts_Dec;
-
- --------------
- -- Puts_LLD --
- --------------
-
- procedure Puts_LLD
- (To : out String;
- Item : Long_Long_Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Fore : Integer;
- Ptr : Natural := 0;
-
- begin
- Fore :=
- (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp);
-
- if Fore < 1 then
- raise Layout_Error;
- end if;
-
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
if Ptr > To'Length then
raise Layout_Error;
else
To := Buf (1 .. Ptr);
end if;
- end Puts_LLD;
+ end Puts;
end Ada.Text_IO.Decimal_Aux;
-- --
------------------------------------------------------------------------------
--- This package contains the routines for Ada.Text_IO.Decimal_IO that are
--- shared among separate instantiations of this package. The routines in
--- the package are identical semantically to those declared in Text_IO,
--- except that default values have been supplied by the generic, and the
--- Num parameter has been replaced by Integer or Long_Long_Integer, with
--- an additional Scale parameter giving the value of Num'Scale. In addition
--- the Get routines return the value rather than store it in an Out parameter.
+-- This package contains the implementation for Ada.Text_IO.Decimal_IO. The
+-- routines in this package are identical semantically to those in Decimal_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there is an
+-- additional Scale parameter giving the value of Num'Scale. In addition the
+-- Get routines return the value rather than store it in an Out parameter.
-private package Ada.Text_IO.Decimal_Aux is
+private generic
+ type Int is range <>;
- function Get_Dec
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Integer;
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int;
- function Get_LLD
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Long_Long_Integer;
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+
+package Ada.Text_IO.Decimal_Aux is
- procedure Put_Dec
+ function Get
(File : File_Type;
- Item : Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ Width : Field;
+ Scale : Integer) return Int;
- procedure Put_LLD
+ procedure Put
(File : File_Type;
- Item : Long_Long_Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
Scale : Integer);
- function Gets_Dec
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer;
-
- function Gets_LLD
+ function Gets
(From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer;
-
- procedure Puts_Dec
- (To : out String;
- Item : Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ Last : out Positive;
+ Scale : Integer) return Int;
- procedure Puts_LLD
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer);
-- --
------------------------------------------------------------------------------
+with Interfaces;
with Ada.Text_IO.Decimal_Aux;
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
package body Ada.Text_IO.Decimal_IO is
- package Aux renames Ada.Text_IO.Decimal_Aux;
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Aux32 is new
+ Ada.Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
+
+ package Aux64 is new
+ Ada.Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable and where type Int64 is needed. This Boolean is used
+ -- to test for these cases and since it is a constant, only code for the
+ -- relevant case will be included in the instance.
Scale : constant Integer := Num'Scale;
pragma Unsuppress (Range_Check);
begin
- if Num'Size > Integer'Size then
- Item := Num'Fixed_Value (Aux.Get_LLD (File, Width, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
else
- Item := Num'Fixed_Value (Aux.Get_Dec (File, Width, Scale));
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
end if;
exception
pragma Unsuppress (Range_Check);
begin
- if Num'Size > Integer'Size then
- Item := Num'Fixed_Value
- (Aux.Gets_LLD (From, Last'Unrestricted_Access, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (From, Last, Scale));
else
- Item := Num'Fixed_Value
- (Aux.Gets_Dec (From, Last'Unrestricted_Access, Scale));
+ Item := Num'Fixed_Value (Aux32.Gets (From, Last, Scale));
end if;
exception
Exp : Field := Default_Exp)
is
begin
- if Num'Size > Integer'Size then
- Aux.Put_LLD
- (File, Long_Long_Integer'Integer_Value (Item),
- Fore, Aft, Exp, Scale);
+ if Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
else
- Aux.Put_Dec
- (File, Integer'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
end if;
end Put;
Exp : Field := Default_Exp)
is
begin
- if Num'Size > Integer'Size then
- Aux.Puts_LLD
- (To, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale);
+ if Need64 then
+ Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp, Scale);
else
- Aux.Puts_Dec (To, Integer'Integer_Value (Item), Aft, Exp, Scale);
+ Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp, Scale);
end if;
end Put;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces;
+with Ada.Text_IO.Decimal_Aux;
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Img_Decimal_128; use System.Img_Decimal_128;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
+with System.Val_Decimal_128; use System.Val_Decimal_128;
+
+package body Ada.Text_IO.Decimal_IO is
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Aux32 is new
+ Ada.Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
+
+ package Aux64 is new
+ Ada.Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ package Aux128 is new
+ Ada.Text_IO.Decimal_Aux
+ (Int128,
+ Scan_Decimal128,
+ Set_Image_Decimal128);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ Need128 : constant Boolean := Num'Size > 64;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable, where type Int64 is acceptable and where an Int128
+ -- is needed. These boolean constants are used to test for these cases and
+ -- since it is a constant, only code for the relevant case will be included
+ -- in the instance.
+
+ Scale : constant Integer := Num'Scale;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Get (File, Width, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_In, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Gets (From, Last, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (From, Last, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Gets (From, Last, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if Need128 then
+ Aux128.Put
+ (File, Int128'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ else
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Out, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if Need128 then
+ Aux128.Puts (To, Int128'Integer_Value (Item), Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp, Scale);
+ else
+ Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp, Scale);
+ end if;
+ end Put;
+
+end Ada.Text_IO.Decimal_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F I X E D _ A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
+with Ada.Text_IO.Float_Aux; use Ada.Text_IO.Float_Aux;
+
+package body Ada.Text_IO.Fixed_Aux is
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Int;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan (Buf, Ptr'Access, Stop, Num, Den);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ return Item;
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Pos : aliased Integer;
+ Item : Int;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan (From, Pos'Access, From'Last, Num, Den);
+ Last := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ -- Compute Fore, allowing for the decimal dot and Aft digits
+
+ Fore := To'Length - 1 - Field'Max (1, Aft);
+
+ -- Allow for Exp and one more for E if exponent present
+
+ if Exp /= 0 then
+ Fore := Fore - 1 - Field'Max (2, Exp);
+ end if;
+
+ -- Make sure we have enough room
+
+ if Fore < 1 + Boolean'Pos (Item < 0) then
+ raise Layout_Error;
+ end if;
+
+ -- Do the conversion and check length of result
+
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts;
+
+end Ada.Text_IO.Fixed_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F I X E D _ A U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the implementation for Ada.Text_IO.Fixed_IO. The
+-- routines in this package are identical semantically to those in Fixed_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there are
+-- additional Num and Den parameters giving the value of Num'Small, as well
+-- as For0 and Aft0 giving some properties of Num'Small. In addition the Get
+-- routines return the value rather than store it in an Out parameter.
+
+private generic
+ type Int is range <>;
+
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int;
+ Den : Int) return Int;
+
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+
+package Ada.Text_IO.Fixed_Aux is
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+end Ada.Text_IO.Fixed_Aux;
-- solution. The downside however may be a too limited set of acceptable
-- fixed point types.
-with Interfaces; use Interfaces;
-with System.Arith_64; use System.Arith_64;
-with System.Img_Real; use System.Img_Real;
-with Ada.Text_IO; use Ada.Text_IO;
+with Interfaces;
+with Ada.Text_IO.Fixed_Aux;
with Ada.Text_IO.Float_Aux;
-with Ada.Text_IO.Generic_Aux;
+with System.Img_Fixed_32; use System.Img_Fixed_32;
+with System.Img_Fixed_64; use System.Img_Fixed_64;
+with System.Val_Fixed_32; use System.Val_Fixed_32;
+with System.Val_Fixed_64; use System.Val_Fixed_64;
package body Ada.Text_IO.Fixed_IO is
- -- Note: we still use the floating-point I/O routines for input of
- -- ordinary fixed-point and output using exponent format. This will
- -- result in inaccuracies for fixed point types with a small that is
- -- not a power of two, and for types that require more precision than
- -- is available in Long_Long_Float.
+ -- Note: we still use the floating-point I/O routines for types whose small
+ -- is not a sufficiently small integer or the reciprocal thereof. This will
+ -- result in inaccuracies for fixed point types that require more precision
+ -- than is available in Long_Long_Float.
- package Aux renames Ada.Text_IO.Float_Aux;
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
- Extra_Layout_Space : constant Field := 5 + Num'Fore;
- -- Extra space that may be needed for output of sign, decimal point,
- -- exponent indication and mandatory decimals after and before the
- -- decimal point. A string with length
+ package Aux32 is new
+ Ada.Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
- -- Fore + Aft + Exp + Extra_Layout_Space
-
- -- is always long enough for formatting any fixed point number.
-
- -- Implementation of Put routines
-
- -- The following section describes a specific implementation choice for
- -- performing base conversions needed for output of values of a fixed
- -- point type T with small T'Small. The goal is to be able to output
- -- all values of types with a precision of 64 bits and a delta of at
- -- least 2.0**(-63), as these are current GNAT limitations already.
-
- -- The chosen algorithm uses fixed precision integer arithmetic for
- -- reasons of simplicity and efficiency. It is important to understand
- -- in what ways the most simple and accurate approach to fixed point I/O
- -- is limiting, before considering more complicated schemes.
-
- -- Without loss of generality assume T has a range (-2.0**63) * T'Small
- -- .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the
- -- decimal point and T'Fore - 1 before. If T'Small is integer, or
- -- 1.0 / T'Small is integer, let S = T'Small and E = 0. For other T'Small,
- -- let S and E be integers such that S / 10**E best approximates T'Small
- -- and S is in the range 10**17 .. 10**18 - 1. The extra decimal scaling
- -- factor 10**E can be trivially handled during final output, by adjusting
- -- the decimal point or exponent.
-
- -- The idea is to convert a value X * S of type T to a 64-bit integer value
- -- Q equal to 10.0**D * (X * S) rounded to the nearest integer, using only
- -- a scaled integer divide of the form
-
- -- Q := (X * Y) / Z,
-
- -- where the variables X, Y, Z are 64-bit integers, and both multiplication
- -- and division are done using full intermediate precision. Then the final
- -- decimal value to be output is
-
- -- Q * 10**(E-D)
-
- -- This value can be written to the output file or to the result string
- -- according to the format described in RM A.3.10. The details of this
- -- operation are omitted here.
-
- -- A 64-bit value can represent all integers with 18 decimal digits, but
- -- not all with 19 decimal digits. If the total number of requested ouput
- -- digits (Fore - 1) + Aft is greater than 18 then, for purposes of the
- -- conversion, Aft is adjusted to 18 - (Fore - 1). In that case, trailing
- -- zeros can complete the output after writing the first 18 significant
- -- digits, or the technique described in the next section can be used.
-
- -- The final expression for D is
-
- -- D := Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1)));
-
- -- For Y and Z the following expressions can be derived:
-
- -- Q = X * S * (10.0**D) = (X * Y) / Z
-
- -- S * 10.0**D = Y / Z;
-
- -- If S is an integer greater than or equal to one, then Fore must be at
- -- least 20 in order to print T'First, which is at most -2.0**63. This
- -- means that D < 0, so use
-
- -- (1) Y = -S and Z = -10**(-D)
-
- -- If 1.0 / S is an integer greater than one, use
-
- -- (2) Y = -10**D and Z = -(1.0 / S), for D >= 0
-
- -- or
-
- -- (3) Y = -1 and Z = -(1.0 / S) * 10**(-D), for D < 0
-
- -- Negative values are used for nominator Y and denominator Z, so that S
- -- can have a maximum value of 2.0**63 and a minimum of 2.0**(-63).
- -- For Z in -1 .. -9, Fore will still be 20, and D will be negative, as
- -- (-2.0**63) / -9 is greater than 10**18. In these cases there is room
- -- in the denominator for the extra decimal scaling required, so case (3)
- -- will not overflow.
-
- -- Extra Precision
-
- -- Using a scaled divide which truncates and returns a remainder R,
- -- another K trailing digits can be calculated by computing the value
- -- (R * (10.0**K)) / Z using another scaled divide. This procedure
- -- can be repeated to compute an arbitrary number of digits in linear
- -- time and storage. The last scaled divide should be rounded, with
- -- a possible carry propagating to the more significant digits, to
- -- ensure correct rounding of the unit in the last place.
-
- -- A variant of this technique is to limit the value of Q to 9 decimal
- -- digits, since 32-bit integers can be much more efficient than 64-bit
- -- integers to output.
-
- pragma Assert (System.Fine_Delta >= 2.0**(-63));
- pragma Assert (Num'Small in 2.0**(-80) .. 2.0**80);
- pragma Assert (Num'Fore <= 37);
-
- Max_Digits : constant := 18;
- -- Maximum number of decimal digits that can be represented in a
- -- 64-bit signed number, see above
-
- -- The constants E0 .. E5 implement a binary search for the appropriate
- -- power of ten to scale the small so that it has one digit before the
- -- decimal point.
-
- subtype Int is Integer;
- E0 : constant Int := -(25 * Boolean'Pos (Num'Small >= 1.0E1));
- E1 : constant Int := E0 + 13 * Boolean'Pos (Num'Small * 10.0**E0 < 1.0E-13);
- E2 : constant Int := E1 + 6 * Boolean'Pos (Num'Small * 10.0**E1 < 1.0E-6);
- E3 : constant Int := E2 + 3 * Boolean'Pos (Num'Small * 10.0**E2 < 1.0E-3);
- E4 : constant Int := E3 + 2 * Boolean'Pos (Num'Small * 10.0**E3 < 1.0E-1);
- E5 : constant Int := E4 + 1 * Boolean'Pos (Num'Small * 10.0**E4 < 1.0E-0);
-
- Scale : constant Integer := E5;
-
- pragma Assert (Num'Small * 10.0**Scale >= 1.0
- and then Num'Small * 10.0**Scale < 10.0);
+ package Aux64 is new
+ Ada.Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
Exact : constant Boolean :=
(Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
- or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)
- or else Num'Small >= 10.0**Max_Digits)
+ or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small))
and then Num'Small >= 2.0**(-63)
and then Num'Small <= 2.0**63;
- -- True iff a 64-bit numerator and denominator can be calculated such that
- -- their ratio exactly represents the small of Num.
-
- procedure Put
- (To : out String;
- Last : out Natural;
- Item : Num;
- Fore : Integer;
- Aft : Field;
- Exp : Field);
- -- Actual output function, used internally by all other Put routines.
- -- The formal Fore is an Integer, not a Field, because the routine is
- -- also called from the version of Put that performs I/O to a string,
- -- where the starting position depends on the size of the String, and
- -- bears no relation to the bounds of Field.
+ -- True if the exact algorithm implemented in Fixed_Aux can be used. The
+ -- condition is a Small which is either an integer or the reciprocal of an
+ -- integer with the appropriate magnitude.
+
+ Need_64 : constant Boolean :=
+ Num'Object_Size > 32
+ or else Num'Small > 2.0**31
+ or else Num'Small < 2.0**(-31);
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable and where type Int64 is needed. This Boolean is used
+ -- to test for these cases and since it is a constant, only code for the
+ -- relevant case will be included in the instance.
+
+ E : constant Natural := 31 + 32 * Boolean'Pos (Need_64);
+ -- T'Size - 1 for the selected Int{32,64}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 18 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+18);
+ F2 : constant Natural :=
+ F1 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+9);
+ F3 : constant Natural :=
+ F2 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+5);
+ F4 : constant Natural :=
+ F3 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+3);
+ F5 : constant Natural :=
+ F4 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+2);
+ F6 : constant Natural :=
+ F5 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F6;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64} and
+ -- whose small is Num'Small.
---------
-- Get --
Width : Field := 0)
is
pragma Unsuppress (Range_Check);
+
begin
- Aux.Get (File, Long_Long_Float (Item), Width);
+ if not Exact then
+ Float_Aux.Get (File, Long_Long_Float (Item), Width);
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
+
exception
when Constraint_Error => raise Data_Error;
end Get;
(Item : out Num;
Width : Field := 0)
is
- pragma Unsuppress (Range_Check);
begin
- Aux.Get (Current_In, Long_Long_Float (Item), Width);
- exception
- when Constraint_Error => raise Data_Error;
+ Get (Current_Input, Item, Width);
end Get;
procedure Get
Last : out Positive)
is
pragma Unsuppress (Range_Check);
+
begin
- Aux.Gets (From, Long_Long_Float (Item), Last);
+ if not Exact then
+ Float_Aux.Gets (From, Long_Long_Float (Item), Last);
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (From, Last,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Gets (From, Last,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
+
exception
when Constraint_Error => raise Data_Error;
end Get;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp)
is
- S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space);
- Last : Natural;
begin
- Put (S, Last, Item, Fore, Aft, Exp);
- Generic_Aux.Put_Item (File, S (1 .. Last));
+ if not Exact then
+ Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ elsif Need_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ end if;
end Put;
procedure Put
Aft : Field := Default_Aft;
Exp : Field := Default_Exp)
is
- S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space);
- Last : Natural;
begin
- Put (S, Last, Item, Fore, Aft, Exp);
- Generic_Aux.Put_Item (Text_IO.Current_Out, S (1 .. Last));
+ Put (Current_Out, Item, Fore, Aft, Exp);
end Put;
procedure Put
Aft : Field := Default_Aft;
Exp : Field := Default_Exp)
is
- Fore : constant Integer :=
- To'Length
- - 1 -- Decimal point
- - Field'Max (1, Aft) -- Decimal part
- - Boolean'Pos (Exp /= 0) -- Exponent indicator
- - Exp; -- Exponent
-
- Last : Natural;
-
- begin
- if Fore - Boolean'Pos (Item < 0.0) < 1 then
- raise Layout_Error;
- end if;
-
- Put (To, Last, Item, Fore, Aft, Exp);
-
- if Last /= To'Last then
- raise Layout_Error;
- end if;
- end Put;
-
- procedure Put
- (To : out String;
- Last : out Natural;
- Item : Num;
- Fore : Integer;
- Aft : Field;
- Exp : Field)
- is
- subtype Digit is Int64 range 0 .. 9;
-
- X : constant Int64 := Int64'Integer_Value (Item);
- A : constant Field := Field'Max (Aft, 1);
- Neg : constant Boolean := (Item < 0.0);
- Pos : Integer := 0; -- Next digit X has value X * 10.0**Pos;
-
- procedure Put_Character (C : Character);
- pragma Inline (Put_Character);
- -- Add C to the output string To, updating Last
-
- procedure Put_Digit (X : Digit);
- -- Add digit X to the output string (going from left to right), updating
- -- Last and Pos, and inserting the sign, leading zeros or a decimal
- -- point when necessary. After outputting the first digit, Pos must not
- -- be changed outside Put_Digit anymore.
-
- procedure Put_Int64 (X : Int64; Scale : Integer);
- -- Output the decimal number abs X * 10**Scale
-
- procedure Put_Scaled
- (X, Y, Z : Int64;
- A : Field;
- E : Integer);
- -- Output the decimal number (X * Y / Z) * 10**E, producing A digits
- -- after the decimal point and rounding the final digit. The value
- -- X * Y / Z is computed with full precision, but must be in the
- -- range of Int64.
-
- -------------------
- -- Put_Character --
- -------------------
-
- procedure Put_Character (C : Character) is
- begin
- Last := Last + 1;
-
- -- Never put a character outside of string To. Exception Layout_Error
- -- will be raised later if Last is greater than To'Last.
-
- if Last <= To'Last then
- To (Last) := C;
- end if;
- end Put_Character;
-
- ---------------
- -- Put_Digit --
- ---------------
-
- procedure Put_Digit (X : Digit) is
- Digs : constant array (Digit) of Character := "0123456789";
-
- begin
- if Last = To'First - 1 then
- if X /= 0 or else Pos <= 0 then
-
- -- Before outputting first digit, include leading space,
- -- possible minus sign and, if the first digit is fractional,
- -- decimal seperator and leading zeros.
-
- -- The Fore part has Pos + 1 + Boolean'Pos (Neg) characters,
- -- if Pos >= 0 and otherwise has a single zero digit plus minus
- -- sign if negative. Add leading space if necessary.
-
- for J in Integer'Max (0, Pos) + 2 + Boolean'Pos (Neg) .. Fore
- loop
- Put_Character (' ');
- end loop;
-
- -- Output minus sign, if number is negative
-
- if Neg then
- Put_Character ('-');
- end if;
-
- -- If starting with fractional digit, output leading zeros
-
- if Pos < 0 then
- Put_Character ('0');
- Put_Character ('.');
-
- for J in Pos .. -2 loop
- Put_Character ('0');
- end loop;
- end if;
-
- Put_Character (Digs (X));
- end if;
-
- else
- -- This is not the first digit to be output, so the only
- -- special handling is that for the decimal point
-
- if Pos = -1 then
- Put_Character ('.');
- end if;
-
- Put_Character (Digs (X));
- end if;
-
- Pos := Pos - 1;
- end Put_Digit;
-
- ---------------
- -- Put_Int64 --
- ---------------
-
- procedure Put_Int64 (X : Int64; Scale : Integer) is
- begin
- if X = 0 then
- return;
- end if;
-
- if X not in -9 .. 9 then
- Put_Int64 (X / 10, Scale + 1);
- end if;
-
- -- Use Put_Digit to advance Pos. This fixes a case where the second
- -- or later Scaled_Divide would omit leading zeroes, resulting in
- -- too few digits produced and a Layout_Error as result.
-
- while Pos > Scale loop
- Put_Digit (0);
- end loop;
-
- -- If and only if more than one digit is output before the decimal
- -- point, pos will be unequal to scale when outputting the first
- -- digit.
-
- pragma Assert (Pos = Scale or else Last = To'First - 1);
-
- Pos := Scale;
-
- Put_Digit (abs (X rem 10));
- end Put_Int64;
-
- ----------------
- -- Put_Scaled --
- ----------------
-
- procedure Put_Scaled
- (X, Y, Z : Int64;
- A : Field;
- E : Integer)
- is
- pragma Assert (E >= -Max_Digits);
- AA : constant Field := Integer'Max (E + A, 0);
- N : constant Natural := (AA + Max_Digits - 1) / Max_Digits + 1;
-
- Q : array (0 .. N - 1) of Int64 := (others => 0);
- -- Each element of Q has Max_Digits decimal digits, except the
- -- last, which has AA rem Max_Digits. Only Q (Q'First) may have an
- -- absolute value equal to or larger than 10**Max_Digits. Only the
- -- absolute value of the elements is significant, not the sign.
-
- XX : Int64 := X;
- YY : Int64 := Y;
-
- begin
- for J in Q'Range loop
- exit when XX = 0;
-
- if J > 0 then
- YY := 10**(Integer'Min (Max_Digits, AA - (J - 1) * Max_Digits));
- end if;
-
- Scaled_Divide64 (XX, YY, Z, Q (J), R => XX, Round => False);
- end loop;
-
- if -E > A then
- pragma Assert (N = 1);
-
- Discard_Extra_Digits : declare
- Factor : constant Int64 := 10**(-E - A);
-
- begin
- -- The scaling factors were such that the first division
- -- produced more digits than requested. So divide away extra
- -- digits and compute new remainder for later rounding.
-
- if abs (Q (0) rem Factor) >= Factor / 2 then
- Q (0) := abs (Q (0) / Factor) + 1;
- else
- Q (0) := Q (0) / Factor;
- end if;
-
- XX := 0;
- end Discard_Extra_Digits;
- end if;
-
- -- At this point XX is a remainder and we need to determine if the
- -- quotient in Q must be rounded away from zero.
-
- -- As XX is less than the divisor, it is safe to take its absolute
- -- without chance of overflow. The check to see if XX is at least
- -- half the absolute value of the divisor must be done carefully to
- -- avoid overflow or lose precision.
-
- XX := abs XX;
-
- if XX >= 2**62
- or else (Z < 0 and then (-XX) * 2 <= Z)
- or else (Z >= 0 and then XX * 2 >= Z)
- then
- -- OK, rounding is necessary. As the sign is not significant,
- -- take advantage of the fact that an extra negative value will
- -- always be available when propagating the carry.
-
- Q (Q'Last) := -abs Q (Q'Last) - 1;
-
- Propagate_Carry :
- for J in reverse 1 .. Q'Last loop
- if Q (J) = YY or else Q (J) = -YY then
- Q (J) := 0;
- Q (J - 1) := -abs Q (J - 1) - 1;
-
- else
- exit Propagate_Carry;
- end if;
- end loop Propagate_Carry;
- end if;
-
- for J in Q'First .. Q'Last - 1 loop
- Put_Int64 (Q (J), E - J * Max_Digits);
- end loop;
-
- Put_Int64 (Q (Q'Last), -A);
- end Put_Scaled;
-
- -- Start of processing for Put
-
begin
- Last := To'First - 1;
-
- if Exp /= 0 then
-
- -- With the Exp format, it is not known how many output digits to
- -- generate, as leading zeros must be ignored. Computing too many
- -- digits and then truncating the output will not give the closest
- -- output, it is necessary to round at the correct digit.
-
- -- The general approach is as follows: as long as no digits have
- -- been generated, compute the Aft next digits (without rounding).
- -- Once a non-zero digit is generated, determine the exact number
- -- of digits remaining and compute them with rounding.
-
- -- Since a large number of iterations might be necessary in case
- -- of Aft = 1, the following optimization would be desirable.
-
- -- Count the number Z of leading zero bits in the integer
- -- representation of X, and start with producing Aft + Z * 1000 /
- -- 3322 digits in the first scaled division.
-
- -- However, the floating-point routines are still used now ???
-
- System.Img_Real.Set_Image_Real (Long_Long_Float (Item), To, Last,
- Fore, Aft, Exp);
- return;
- end if;
-
- if Exact then
- declare
- D : constant Integer := Integer'Min (A, Max_Digits
- - (Num'Fore - 1));
- Y : constant Int64 := Int64'Min (Int64 (-Num'Small), -1)
- * 10**Integer'Max (0, D);
- Z : constant Int64 := Int64'Min (Int64 (-(1.0 / Num'Small)), -1)
- * 10**Integer'Max (0, -D);
- begin
- Put_Scaled (X, Y, Z, A, -D);
- end;
-
- else -- not Exact
- declare
- E : constant Integer := Max_Digits - 1 + Scale;
- D : constant Integer := Scale - 1;
- Y : constant Int64 := Int64 (-Num'Small * 10.0**E);
- Z : constant Int64 := -10**Max_Digits;
- begin
- Put_Scaled (X, Y, Z, A, -D);
- end;
+ if not Exact then
+ Float_Aux.Puts (To, Long_Long_Float (Item), Aft, Exp);
+ elsif Need_64 then
+ Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
end if;
-
- -- If only zero digits encountered, unit digit has not been output yet
-
- if Last < To'First then
- Pos := 0;
-
- elsif Last > To'Last then
- raise Layout_Error; -- Not enough room in the output variable
- end if;
-
- -- Always output digits up to the first one after the decimal point
-
- while Pos >= -A loop
- Put_Digit (0);
- end loop;
end Put;
end Ada.Text_IO.Fixed_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F I X E D _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Fixed point I/O
+-- ---------------
+
+-- The following text documents implementation details of the fixed point
+-- input/output routines in the GNAT runtime. The first part describes the
+-- general properties of fixed point types as defined by the Ada standard,
+-- including the Information Systems Annex.
+
+-- Subsequently these are reduced to implementation constraints and the impact
+-- of these constraints on a few possible approaches to input/output is given.
+-- Based on this analysis, a specific implementation is selected for use in
+-- the GNAT runtime. Finally, the chosen algorithm is analyzed numerically in
+-- order to provide user-level documentation on limits for range and precision
+-- of fixed point types as well as accuracy of input/output conversions.
+
+-- -------------------------------------------
+-- - General Properties of Fixed Point Types -
+-- -------------------------------------------
+
+-- Operations on fixed point types, other than input/output, are not important
+-- for the purpose of this document. Only the set of values that a fixed point
+-- type can represent and the input/output operations are significant.
+
+-- Values
+-- ------
+
+-- The set of values of a fixed point type comprise the integral multiples of
+-- a number called the small of the type. The small can be either a power of
+-- two, a power of ten or (if the implementation allows) an arbitrary strictly
+-- positive real value.
+
+-- Implementations need to support ordinary fixed point types with a precision
+-- of at least 24 bits, and (in order to comply with the Information Systems
+-- Annex) decimal fixed point types with at least 18 digits. For the rest, no
+-- requirements exist for the minimal small and range that must be supported.
+
+-- Operations
+-- ----------
+
+-- 'Image and 'Wide_Image (see RM 3.5(34))
+
+-- These attributes return a decimal real literal best approximating
+-- the value (rounded away from zero if halfway between) with a
+-- single leading character that is either a minus sign or a space,
+-- one or more digits before the decimal point (with no redundant
+-- leading zeros), a decimal point, and N digits after the decimal
+-- point. For a subtype S, the value of N is S'Aft, the smallest
+-- positive integer such that (10**N)*S'Delta is greater or equal to
+-- one, see RM 3.5.10(5).
+
+-- For an arbitrary small, this means large number arithmetic needs
+-- to be performed.
+
+-- Put (see RM A.10.9(22-26))
+
+-- The requirements for Put add no extra constraints over the image
+-- attributes, although it would be nice to be able to output more
+-- than S'Aft digits after the decimal point for values of subtype S.
+
+-- 'Value and 'Wide_Value attribute (RM 3.5(40-55))
+
+-- Since the input can be given in any base in the range 2..16,
+-- accurate conversion to a fixed point number may require
+-- arbitrary precision arithmetic if there is no limit on the
+-- magnitude of the small of the fixed point type.
+
+-- Get (see RM A.10.9(12-21))
+
+-- The requirements for Get are identical to those of the Value
+-- attribute.
+
+-- ------------------------------
+-- - Implementation Constraints -
+-- ------------------------------
+
+-- The requirements listed above for the input/output operations lead to
+-- significant complexity, if no constraints are put on supported smalls.
+
+-- Implementation Strategies
+-- -------------------------
+
+-- * Floating point arithmetic
+-- * Arbitrary-precision integer arithmetic
+-- * Fixed-precision integer arithmetic
+
+-- Although it seems convenient to convert fixed point numbers to floating
+-- point and then print them, this leads to a number of restrictions.
+-- The first one is precision. The widest floating-point type generally
+-- available has 53 bits of mantissa. This means that Fine_Delta cannot
+-- be less than 2.0**(-53).
+
+-- In GNAT, Fine_Delta is 2.0**(-63), and Duration for example is a 64-bit
+-- type. This means that a floating-point type with 63 bits of mantissa needs
+-- to be used, which is only generally available on the x86 architecture. It
+-- would still be possible to use multi-precision floating point to perform
+-- calculations using longer mantissas, but this is a much harder approach.
+
+-- The base conversions needed for input/output of (non-decimal) fixed point
+-- types can be seen as pairs of integer multiplications and divisions.
+
+-- Arbitrary-precision integer arithmetic would be suitable for the job at
+-- hand, but has the drawback that it is very heavy implementation-wise.
+-- Especially in embedded systems, where fixed point types are often used,
+-- it may not be desirable to require large amounts of storage and time
+-- for fixed I/O operations.
+
+-- Fixed-precision integer arithmetic has the advantage of simplicity and
+-- speed. For the most common fixed point types this would be a perfect
+-- solution. The downside however may be a too limited set of acceptable
+-- fixed point types.
+
+with Interfaces;
+with Ada.Text_IO.Fixed_Aux;
+with Ada.Text_IO.Float_Aux;
+with System.Img_Fixed_32; use System.Img_Fixed_32;
+with System.Img_Fixed_64; use System.Img_Fixed_64;
+with System.Img_Fixed_128; use System.Img_Fixed_128;
+with System.Val_Fixed_32; use System.Val_Fixed_32;
+with System.Val_Fixed_64; use System.Val_Fixed_64;
+with System.Val_Fixed_128; use System.Val_Fixed_128;
+
+package body Ada.Text_IO.Fixed_IO is
+
+ -- Note: we still use the floating-point I/O routines for types whose small
+ -- is not a sufficiently small integer or the reciprocal thereof. This will
+ -- result in inaccuracies for fixed point types that require more precision
+ -- than is available in Long_Long_Float.
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Aux32 is new
+ Ada.Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
+
+ package Aux64 is new
+ Ada.Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
+
+ package Aux128 is new
+ Ada.Text_IO.Fixed_Aux (Int128, Scan_Fixed128, Set_Image_Fixed128);
+
+ Exact : constant Boolean :=
+ (Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
+ or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small))
+ and then Num'Small >= 2.0**(-127)
+ and then Num'Small <= 2.0**127;
+ -- True if the exact algorithm implemented in Fixed_Aux can be used. The
+ -- condition is a Small which is either an integer or the reciprocal of an
+ -- integer with the appropriate magnitude.
+
+ Need_64 : constant Boolean :=
+ Num'Object_Size > 32
+ or else Num'Small > 2.0**31
+ or else Num'Small < 2.0**(-31);
+ Need_128 : constant Boolean :=
+ Num'Object_Size > 64
+ or else Num'Small > 2.0**63
+ or else Num'Small < 2.0**(-63);
+ -- Throughout this generic body, we distinguish between the cases where
+ -- type Int32 is acceptable, where type Int64 is acceptable, and where
+ -- type Int128 is needed. These boolean constants are used to test for
+ -- these cases and since they are constant, only code for the relevant
+ -- case will be really included in the instance.
+
+ E : constant Natural :=
+ 31 + 32 * Boolean'Pos (Need_64) + 64 * Boolean'Pos (Need_128);
+ -- T'Size - 1 for the selected Int{32,64,128}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 38 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+38);
+ F2 : constant Natural :=
+ F1 + 19 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+19);
+ F3 : constant Natural :=
+ F2 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+9);
+ F4 : constant Natural :=
+ F3 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+5);
+ F5 : constant Natural :=
+ F4 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+3);
+ F6 : constant Natural :=
+ F5 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+2);
+ F7 : constant Natural :=
+ F6 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F6) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F7;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64,128} and
+ -- whose small is Num'Small.
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if not Exact then
+ Float_Aux.Get (File, Long_Long_Float (Item), Width);
+ elsif Need_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Get (File, Width,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small))));
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if not Exact then
+ Float_Aux.Gets (From, Long_Long_Float (Item), Last);
+ elsif Need_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Gets (From, Last,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small))));
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (From, Last,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Gets (From, Last,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if not Exact then
+ Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ elsif Need_128 then
+ Aux128.Put (File, Int128'Integer_Value (Item), Fore, Aft, Exp,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ elsif Need_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Out, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if not Exact then
+ Float_Aux.Puts (To, Long_Long_Float (Item), Aft, Exp);
+ elsif Need_128 then
+ Aux128.Puts (To, Int128'Integer_Value (Item), Aft, Exp,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ elsif Need_64 then
+ Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ end if;
+ end Put;
+
+end Ada.Text_IO.Fixed_IO;
is
Buf : String (1 .. Field'Last);
Stop : Integer := 0;
- Ptr : aliased Integer := 1;
+ Ptr : aliased Integer;
begin
if Width /= 0 then
String_Skip (Buf, Ptr);
else
Load_Real (File, Buf, Stop);
+ Ptr := 1;
end if;
Item := Scan_Real (Buf, Ptr'Access, Stop);
-
Check_End_Of_Field (Buf, Stop, Ptr, Width);
end Get;
Last := Pos - 1;
exception
- when Constraint_Error =>
- raise Data_Error;
+ when Constraint_Error => raise Data_Error;
end Gets;
---------------
with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
with Ada.Wide_Text_IO.Float_Aux; use Ada.Wide_Text_IO.Float_Aux;
-with System.Img_Dec; use System.Img_Dec;
-with System.Img_LLD; use System.Img_LLD;
-with System.Val_Dec; use System.Val_Dec;
-with System.Val_LLD; use System.Val_LLD;
-
package body Ada.Wide_Text_IO.Decimal_Aux is
- -------------
- -- Get_Dec --
- -------------
-
- function Get_Dec
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Integer
- is
- Buf : String (1 .. Field'Last);
- Ptr : aliased Integer;
- Stop : Integer := 0;
- Item : Integer;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Real (File, Buf, Stop);
- Ptr := 1;
- end if;
-
- Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- return Item;
- end Get_Dec;
-
- -------------
- -- Get_LLD --
- -------------
+ ---------
+ -- Get --
+ ---------
- function Get_LLD
+ function Get
(File : File_Type;
Width : Field;
- Scale : Integer) return Long_Long_Integer
+ Scale : Integer) return Int
is
Buf : String (1 .. Field'Last);
Ptr : aliased Integer;
Stop : Integer := 0;
- Item : Long_Long_Integer;
+ Item : Int;
begin
if Width /= 0 then
Ptr := 1;
end if;
- Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Item := Scan (Buf, Ptr'Access, Stop, Scale);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
return Item;
- end Get_LLD;
-
- --------------
- -- Gets_Dec --
- --------------
-
- function Gets_Dec
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer
- is
- Pos : aliased Integer;
- Item : Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
- return Item;
+ end Get;
- exception
- when Constraint_Error =>
- Last.all := Pos - 1;
- raise Data_Error;
-
- end Gets_Dec;
+ ----------
+ -- Gets --
+ ----------
- --------------
- -- Gets_LLD --
- --------------
-
- function Gets_LLD
+ function Gets
(From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer
+ Last : out Positive;
+ Scale : Integer) return Int
is
Pos : aliased Integer;
- Item : Long_Long_Integer;
+ Item : Int;
begin
String_Skip (From, Pos);
- Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
+ Item := Scan (From, Pos'Access, From'Last, Scale);
+ Last := Pos - 1;
return Item;
exception
when Constraint_Error =>
- Last.all := Pos - 1;
+ Last := Pos - 1;
raise Data_Error;
+ end Gets;
- end Gets_LLD;
-
- -------------
- -- Put_Dec --
- -------------
+ ---------
+ -- Put --
+ ---------
- procedure Put_Dec
+ procedure Put
(File : File_Type;
- Item : Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
Ptr : Natural := 0;
begin
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
- end Put_Dec;
+ end Put;
- -------------
- -- Put_LLD --
- -------------
+ ----------
+ -- Puts --
+ ----------
- procedure Put_LLD
- (File : File_Type;
- Item : Long_Long_Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
- Put_Item (File, Buf (1 .. Ptr));
- end Put_LLD;
-
- --------------
- -- Puts_Dec --
- --------------
-
- procedure Puts_Dec
+ procedure Puts
(To : out String;
- Item : Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
Fore : Integer;
Ptr : Natural := 0;
begin
- -- Compute Fore, allowing for Aft digits and the decimal dot
+ -- Compute Fore, allowing for the decimal dot and Aft digits
- Fore := To'Length - Field'Max (1, Aft) - 1;
+ Fore := To'Length - 1 - Field'Max (1, Aft);
- -- Allow for Exp and two more for E+ or E- if exponent present
+ -- Allow for Exp and one more for E if exponent present
if Exp /= 0 then
- Fore := Fore - 2 - Exp;
+ Fore := Fore - 1 - Field'Max (2, Exp);
end if;
-- Make sure we have enough room
- if Fore < 1 then
+ if Fore < 1 + Boolean'Pos (Item < 0) then
raise Layout_Error;
end if;
-- Do the conversion and check length of result
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To := Buf (1 .. Ptr);
- end if;
- end Puts_Dec;
-
- --------------
- -- Puts_LLD --
- --------------
-
- procedure Puts_LLD
- (To : out String;
- Item : Long_Long_Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Fore : Integer;
- Ptr : Natural := 0;
-
- begin
- Fore :=
- (if Exp = 0
- then To'Length - 1 - Aft
- else To'Length - 2 - Aft - Exp);
-
- if Fore < 1 then
- raise Layout_Error;
- end if;
-
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
if Ptr > To'Length then
raise Layout_Error;
else
To := Buf (1 .. Ptr);
end if;
- end Puts_LLD;
+ end Puts;
end Ada.Wide_Text_IO.Decimal_Aux;
-- --
------------------------------------------------------------------------------
--- This package contains the routines for Ada.Wide_Text_IO.Decimal_IO
--- that are shared among separate instantiations of this package. The
--- routines in the package are identical semantically to those declared
--- in Wide_Text_IO, except that default values have been supplied by the
--- generic, and the Num parameter has been replaced by Integer or
--- Long_Long_Integer, with an additional Scale parameter giving the
--- value of Num'Scale. In addition the Get routines return the value
--- rather than store it in an Out parameter.
+-- This package contains the implementation for Ada.Wide_Text_IO.Decimal_IO.
+-- Routines in this package are identical semantically to those in Decimal_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there is an
+-- additional Scale parameter giving the value of Num'Scale. In addition the
+-- Get routines return the value rather than store it in an Out parameter.
-private package Ada.Wide_Text_IO.Decimal_Aux is
+private generic
+ type Int is range <>;
- function Get_Dec
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Integer;
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int;
- function Get_LLD
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Long_Long_Integer;
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
- function Gets_Dec
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer;
+package Ada.Wide_Text_IO.Decimal_Aux is
- function Gets_LLD
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer;
-
- procedure Put_Dec
+ function Get
(File : File_Type;
- Item : Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ Width : Field;
+ Scale : Integer) return Int;
- procedure Put_LLD
+ procedure Put
(File : File_Type;
- Item : Long_Long_Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
Scale : Integer);
- procedure Puts_Dec
- (To : out String;
- Item : Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Scale : Integer) return Int;
- procedure Puts_LLD
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer);
------------------------------------------------------------------------------
with Ada.Wide_Text_IO.Decimal_Aux;
-
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Text_IO.Decimal_IO is
- package Aux renames Ada.Wide_Text_IO.Decimal_Aux;
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Aux32 is new
+ Ada.Wide_Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
+
+ package Aux64 is new
+ Ada.Wide_Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable and where type Int64 is needed. This Boolean is used
+ -- to test for these cases and since it is a constant, only code for the
+ -- relevant case will be included in the instance.
Scale : constant Integer := Num'Scale;
Item : out Num;
Width : Field := 0)
is
+ pragma Unsuppress (Range_Check);
+
begin
- if Num'Size > Integer'Size then
- Item := Num'Fixed_Value (Aux.Get_LLD (File, Width, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
else
- Item := Num'Fixed_Value (Aux.Get_Dec (File, Width, Scale));
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
end if;
+
exception
when Constraint_Error => raise Data_Error;
end Get;
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
-- Aux.Gets will raise Data_Error in any case.
begin
- if Num'Size > Integer'Size then
- -- Item := Num'Fixed_Value
- -- should write above, but gets assert error ???
- Item := Num
- (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale));
else
- -- Item := Num'Fixed_Value
- -- should write above, but gets assert error ???
- Item := Num
- (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale));
+ Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale));
end if;
exception
Exp : Field := Default_Exp)
is
begin
- if Num'Size > Integer'Size then
- Aux.Put_LLD
- (File, Long_Long_Integer'Integer_Value (Item),
- Fore, Aft, Exp, Scale);
+ if Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
else
- Aux.Put_Dec
- (File, Integer'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
end if;
end Put;
S : String (To'First .. To'Last);
begin
- if Num'Size > Integer'Size then
- Aux.Puts_LLD
- (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale);
-
+ if Need64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale);
else
- Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale);
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale);
end if;
for J in S'Range loop
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Text_IO.Decimal_Aux;
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Img_Decimal_128; use System.Img_Decimal_128;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
+with System.Val_Decimal_128; use System.Val_Decimal_128;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Text_IO.Decimal_IO is
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Aux32 is new
+ Ada.Wide_Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
+
+ package Aux64 is new
+ Ada.Wide_Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ package Aux128 is new
+ Ada.Wide_Text_IO.Decimal_Aux
+ (Int128,
+ Scan_Decimal128,
+ Set_Image_Decimal128);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ Need128 : constant Boolean := Num'Size > 64;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable, where type Int64 is acceptable and where an Int128
+ -- is needed. These boolean constants are used to test for these cases and
+ -- since it is a constant, only code for the relevant case will be included
+ -- in the instance.
+
+ Scale : constant Integer := Num'Scale;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Get (File, Width, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Gets (S, Last, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if Need128 then
+ Aux128.Put
+ (File, Int128'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ else
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Output, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Need128 then
+ Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale);
+ else
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Decimal_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
+with Ada.Wide_Text_IO.Float_Aux; use Ada.Wide_Text_IO.Float_Aux;
+
+package body Ada.Wide_Text_IO.Fixed_Aux is
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Int;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan (Buf, Ptr'Access, Stop, Num, Den);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ return Item;
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Pos : aliased Integer;
+ Item : Int;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan (From, Pos'Access, From'Last, Num, Den);
+ Last := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ -- Compute Fore, allowing for the decimal dot and Aft digits
+
+ Fore := To'Length - 1 - Field'Max (1, Aft);
+
+ -- Allow for Exp and one more for E if exponent present
+
+ if Exp /= 0 then
+ Fore := Fore - 1 - Field'Max (2, Exp);
+ end if;
+
+ -- Make sure we have enough room
+
+ if Fore < 1 + Boolean'Pos (Item < 0) then
+ raise Layout_Error;
+ end if;
+
+ -- Do the conversion and check length of result
+
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts;
+
+end Ada.Wide_Text_IO.Fixed_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the implementation for Ada.Wide_Text_IO.Fixed_IO.
+-- Routines in this package are identical semantically to those in Fixed_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there are
+-- additional Num and Den parameters giving the value of Num'Small, as well
+-- as For0 and Aft0 giving some properties of Num'Small. In addition the Get
+-- routines return the value rather than store it in an Out parameter.
+
+private generic
+ type Int is range <>;
+
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int;
+ Den : Int) return Int;
+
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+
+package Ada.Wide_Text_IO.Fixed_Aux is
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+end Ada.Wide_Text_IO.Fixed_Aux;
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O --
-- --
-- B o d y --
-- --
-- --
------------------------------------------------------------------------------
+with Interfaces;
+with Ada.Wide_Text_IO.Fixed_Aux;
with Ada.Wide_Text_IO.Float_Aux;
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_WtS; use System.WCh_WtS;
+with System.Img_Fixed_32; use System.Img_Fixed_32;
+with System.Img_Fixed_64; use System.Img_Fixed_64;
+with System.Val_Fixed_32; use System.Val_Fixed_32;
+with System.Val_Fixed_64; use System.Val_Fixed_64;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Text_IO.Fixed_IO is
- package Aux renames Ada.Wide_Text_IO.Float_Aux;
+ -- Note: we still use the floating-point I/O routines for types whose small
+ -- is not a sufficiently small integer or the reciprocal thereof. This will
+ -- result in inaccuracies for fixed point types that require more precision
+ -- than is available in Long_Long_Float.
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Aux32 is new
+ Ada.Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
+
+ package Aux64 is new
+ Ada.Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
+
+ Exact : constant Boolean :=
+ (Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
+ or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small))
+ and then Num'Small >= 2.0**(-63)
+ and then Num'Small <= 2.0**63;
+ -- True if the exact algorithm implemented in Fixed_Aux can be used. The
+ -- condition is a Small which is either an integer or the reciprocal of an
+ -- integer with the appropriate magnitude.
+
+ Need_64 : constant Boolean :=
+ Num'Object_Size > 32
+ or else Num'Small > 2.0**31
+ or else Num'Small < 2.0**(-31);
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable and where type Int64 is needed. This Boolean is used
+ -- to test for these cases and since it is a constant, only code for the
+ -- relevant case will be included in the instance.
+
+ E : constant Natural := 31 + 32 * Boolean'Pos (Need_64);
+ -- T'Size - 1 for the selected Int{32,64}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 18 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+18);
+ F2 : constant Natural :=
+ F1 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+9);
+ F3 : constant Natural :=
+ F2 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+5);
+ F4 : constant Natural :=
+ F3 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+3);
+ F5 : constant Natural :=
+ F4 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+2);
+ F6 : constant Natural :=
+ F5 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F6;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64} and
+ -- whose small is Num'Small.
---------
-- Get --
Item : out Num;
Width : Field := 0)
is
+ pragma Unsuppress (Range_Check);
+
begin
- Aux.Get (File, Long_Long_Float (Item), Width);
+ if not Exact then
+ Float_Aux.Get (File, Long_Long_Float (Item), Width);
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
exception
when Constraint_Error => raise Data_Error;
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
-- Aux.Gets will raise Data_Error in any case.
begin
- Aux.Gets (S, Long_Long_Float (Item), Last);
+ if not Exact then
+ Float_Aux.Gets (S, Long_Long_Float (Item), Last);
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (S, Last,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Gets (S, Last,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
exception
when Constraint_Error => raise Data_Error;
Exp : Field := Default_Exp)
is
begin
- Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ if not Exact then
+ Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ elsif Need_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ end if;
end Put;
procedure Put
S : String (To'First .. To'Last);
begin
- Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ if not Exact then
+ Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ elsif Need_64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ end if;
for J in S'Range loop
To (J) := Wide_Character'Val (Character'Pos (S (J)));
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces;
+with Ada.Wide_Text_IO.Fixed_Aux;
+with Ada.Wide_Text_IO.Float_Aux;
+with System.Img_Fixed_32; use System.Img_Fixed_32;
+with System.Img_Fixed_64; use System.Img_Fixed_64;
+with System.Img_Fixed_128; use System.Img_Fixed_128;
+with System.Val_Fixed_32; use System.Val_Fixed_32;
+with System.Val_Fixed_64; use System.Val_Fixed_64;
+with System.Val_Fixed_128; use System.Val_Fixed_128;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Text_IO.Fixed_IO is
+
+ -- Note: we still use the floating-point I/O routines for types whose small
+ -- is not a sufficiently small integer or the reciprocal thereof. This will
+ -- result in inaccuracies for fixed point types that require more precision
+ -- than is available in Long_Long_Float.
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Aux32 is new
+ Ada.Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
+
+ package Aux64 is new
+ Ada.Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
+
+ package Aux128 is new
+ Ada.Wide_Text_IO.Fixed_Aux (Int128, Scan_Fixed128, Set_Image_Fixed128);
+
+ Exact : constant Boolean :=
+ (Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
+ or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small))
+ and then Num'Small >= 2.0**(-127)
+ and then Num'Small <= 2.0**127;
+ -- True if the exact algorithm implemented in Fixed_Aux can be used. The
+ -- condition is a Small which is either an integer or the reciprocal of an
+ -- integer with the appropriate magnitude.
+
+ Need_64 : constant Boolean :=
+ Num'Object_Size > 32
+ or else Num'Small > 2.0**31
+ or else Num'Small < 2.0**(-31);
+ Need_128 : constant Boolean :=
+ Num'Object_Size > 64
+ or else Num'Small > 2.0**63
+ or else Num'Small < 2.0**(-63);
+ -- Throughout this generic body, we distinguish between the cases where
+ -- type Int32 is acceptable, where type Int64 is acceptable, and where
+ -- type Int128 is needed. These boolean constants are used to test for
+ -- these cases and since they are constant, only code for the relevant
+ -- case will be really included in the instance.
+
+ E : constant Natural :=
+ 31 + 32 * Boolean'Pos (Need_64) + 64 * Boolean'Pos (Need_128);
+ -- T'Size - 1 for the selected Int{32,64,128}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 38 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+38);
+ F2 : constant Natural :=
+ F1 + 19 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+19);
+ F3 : constant Natural :=
+ F2 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+9);
+ F4 : constant Natural :=
+ F3 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+5);
+ F5 : constant Natural :=
+ F4 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+3);
+ F6 : constant Natural :=
+ F5 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+2);
+ F7 : constant Natural :=
+ F6 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F6) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F7;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64,128} and
+ -- whose small is Num'Small.
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if not Exact then
+ Float_Aux.Get (File, Long_Long_Float (Item), Width);
+ elsif Need_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Get (File, Width,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small))));
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if not Exact then
+ Float_Aux.Gets (S, Long_Long_Float (Item), Last);
+ elsif Need_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Gets (S, Last,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small))));
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (S, Last,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Gets (S, Last,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if not Exact then
+ Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ elsif Need_128 then
+ Aux128.Put (File, Int128'Integer_Value (Item), Fore, Aft, Exp,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ elsif Need_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Output, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if not Exact then
+ Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ elsif Need_128 then
+ Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ elsif Need_64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ end if;
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Fixed_IO;
with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
with Ada.Wide_Wide_Text_IO.Float_Aux; use Ada.Wide_Wide_Text_IO.Float_Aux;
-with System.Img_Dec; use System.Img_Dec;
-with System.Img_LLD; use System.Img_LLD;
-with System.Val_Dec; use System.Val_Dec;
-with System.Val_LLD; use System.Val_LLD;
-
package body Ada.Wide_Wide_Text_IO.Decimal_Aux is
- -------------
- -- Get_Dec --
- -------------
-
- function Get_Dec
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Integer
- is
- Buf : String (1 .. Field'Last);
- Ptr : aliased Integer;
- Stop : Integer := 0;
- Item : Integer;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Real (File, Buf, Stop);
- Ptr := 1;
- end if;
-
- Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- return Item;
- end Get_Dec;
-
- -------------
- -- Get_LLD --
- -------------
+ ---------
+ -- Get --
+ ---------
- function Get_LLD
+ function Get
(File : File_Type;
Width : Field;
- Scale : Integer) return Long_Long_Integer
+ Scale : Integer) return Int
is
Buf : String (1 .. Field'Last);
Ptr : aliased Integer;
Stop : Integer := 0;
- Item : Long_Long_Integer;
+ Item : Int;
begin
if Width /= 0 then
Ptr := 1;
end if;
- Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Item := Scan (Buf, Ptr'Access, Stop, Scale);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
return Item;
- end Get_LLD;
-
- --------------
- -- Gets_Dec --
- --------------
-
- function Gets_Dec
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer
- is
- Pos : aliased Integer;
- Item : Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
- return Item;
+ end Get;
- exception
- when Constraint_Error =>
- Last.all := Pos - 1;
- raise Data_Error;
-
- end Gets_Dec;
+ ----------
+ -- Gets --
+ ----------
- --------------
- -- Gets_LLD --
- --------------
-
- function Gets_LLD
+ function Gets
(From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer
+ Last : out Positive;
+ Scale : Integer) return Int
is
Pos : aliased Integer;
- Item : Long_Long_Integer;
+ Item : Int;
begin
String_Skip (From, Pos);
- Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
+ Item := Scan (From, Pos'Access, From'Last, Scale);
+ Last := Pos - 1;
return Item;
exception
when Constraint_Error =>
- Last.all := Pos - 1;
+ Last := Pos - 1;
raise Data_Error;
+ end Gets;
- end Gets_LLD;
-
- -------------
- -- Put_Dec --
- -------------
+ ---------
+ -- Put --
+ ---------
- procedure Put_Dec
+ procedure Put
(File : File_Type;
- Item : Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
Ptr : Natural := 0;
begin
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
- end Put_Dec;
+ end Put;
- -------------
- -- Put_LLD --
- -------------
+ ----------
+ -- Puts --
+ ----------
- procedure Put_LLD
- (File : File_Type;
- Item : Long_Long_Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
- Put_Item (File, Buf (1 .. Ptr));
- end Put_LLD;
-
- --------------
- -- Puts_Dec --
- --------------
-
- procedure Puts_Dec
+ procedure Puts
(To : out String;
- Item : Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
Fore : Integer;
Ptr : Natural := 0;
begin
- -- Compute Fore, allowing for Aft digits and the decimal dot
+ -- Compute Fore, allowing for the decimal dot and Aft digits
- Fore := To'Length - Field'Max (1, Aft) - 1;
+ Fore := To'Length - 1 - Field'Max (1, Aft);
- -- Allow for Exp and two more for E+ or E- if exponent present
+ -- Allow for Exp and one more for E if exponent present
if Exp /= 0 then
- Fore := Fore - 2 - Exp;
+ Fore := Fore - 1 - Field'Max (2, Exp);
end if;
-- Make sure we have enough room
- if Fore < 1 then
+ if Fore < 1 + Boolean'Pos (Item < 0) then
raise Layout_Error;
end if;
-- Do the conversion and check length of result
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To := Buf (1 .. Ptr);
- end if;
- end Puts_Dec;
-
- --------------
- -- Puts_LLD --
- --------------
-
- procedure Puts_LLD
- (To : out String;
- Item : Long_Long_Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Fore : Integer;
- Ptr : Natural := 0;
-
- begin
- Fore :=
- (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp);
-
- if Fore < 1 then
- raise Layout_Error;
- end if;
-
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
if Ptr > To'Length then
raise Layout_Error;
else
To := Buf (1 .. Ptr);
end if;
- end Puts_LLD;
+ end Puts;
end Ada.Wide_Wide_Text_IO.Decimal_Aux;
-- --
------------------------------------------------------------------------------
--- This package contains the routines for Ada.Wide_Wide_Text_IO.Decimal_IO
--- that are shared among separate instantiations of this package. The
--- routines in the package are identical semantically to those declared
--- in Wide_Wide_Text_IO, except that default values have been supplied by the
--- generic, and the Num parameter has been replaced by Integer or
--- Long_Long_Integer, with an additional Scale parameter giving the
--- value of Num'Scale. In addition the Get routines return the value
--- rather than store it in an Out parameter.
+-- This package contains implementation for Ada.Wide_Wide_Text_IO.Decimal_IO
+-- Routines in this package are identical semantically to those in Decimal_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there is an
+-- additional Scale parameter giving the value of Num'Scale. In addition the
+-- Get routines return the value rather than store it in an Out parameter.
-private package Ada.Wide_Wide_Text_IO.Decimal_Aux is
+private generic
+ type Int is range <>;
- function Get_Dec
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Integer;
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int;
- function Get_LLD
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Long_Long_Integer;
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
- function Gets_Dec
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer;
+package Ada.Wide_Wide_Text_IO.Decimal_Aux is
- function Gets_LLD
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer;
-
- procedure Put_Dec
+ function Get
(File : File_Type;
- Item : Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ Width : Field;
+ Scale : Integer) return Int;
- procedure Put_LLD
+ procedure Put
(File : File_Type;
- Item : Long_Long_Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
Scale : Integer);
- procedure Puts_Dec
- (To : out String;
- Item : Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Scale : Integer) return Int;
- procedure Puts_LLD
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer);
------------------------------------------------------------------------------
with Ada.Wide_Wide_Text_IO.Decimal_Aux;
-
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Wide_Text_IO.Decimal_IO is
- package Aux renames Ada.Wide_Wide_Text_IO.Decimal_Aux;
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Aux32 is new
+ Ada.Wide_Wide_Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
+
+ package Aux64 is new
+ Ada.Wide_Wide_Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable and where type Int64 is needed. This Boolean is used
+ -- to test for these cases and since it is a constant, only code for the
+ -- relevant case will be included in the instance.
Scale : constant Integer := Num'Scale;
Item : out Num;
Width : Field := 0)
is
+ pragma Unsuppress (Range_Check);
+
begin
- if Num'Size > Integer'Size then
- Item := Num'Fixed_Value (Aux.Get_LLD (File, Width, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
else
- Item := Num'Fixed_Value (Aux.Get_Dec (File, Width, Scale));
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
end if;
+
exception
when Constraint_Error => raise Data_Error;
end Get;
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
-- Aux.Gets will raise Data_Error in any case.
begin
- if Num'Size > Integer'Size then
- -- Item := Num'Fixed_Value
- -- should write above, but gets assert error ???
- Item := Num
- (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale));
else
- -- Item := Num'Fixed_Value
- -- should write above, but gets assert error ???
- Item := Num
- (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale));
+ Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale));
end if;
exception
Exp : Field := Default_Exp)
is
begin
- if Num'Size > Integer'Size then
- Aux.Put_LLD
--- (File, Long_Long_Integer'Integer_Value (Item),
--- ???
- (File, Long_Long_Integer (Item),
- Fore, Aft, Exp, Scale);
+ if Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
else
- Aux.Put_Dec
--- (File, Integer'Integer_Value (Item), Fore, Aft, Exp, Scale);
--- ???
- (File, Integer (Item), Fore, Aft, Exp, Scale);
-
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
end if;
end Put;
S : String (To'First .. To'Last);
begin
- if Num'Size > Integer'Size then
--- Aux.Puts_LLD
--- (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale);
--- ???
- Aux.Puts_LLD
- (S, Long_Long_Integer (Item), Aft, Exp, Scale);
+ if Need64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale);
else
--- Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale);
--- ???
- Aux.Puts_Dec (S, Integer (Item), Aft, Exp, Scale);
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale);
end if;
for J in S'Range loop
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Decimal_Aux;
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Img_Decimal_128; use System.Img_Decimal_128;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
+with System.Val_Decimal_128; use System.Val_Decimal_128;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Wide_Text_IO.Decimal_IO is
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Aux32 is new
+ Ada.Wide_Wide_Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
+
+ package Aux64 is new
+ Ada.Wide_Wide_Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ package Aux128 is new
+ Ada.Wide_Wide_Text_IO.Decimal_Aux
+ (Int128,
+ Scan_Decimal128,
+ Set_Image_Decimal128);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ Need128 : constant Boolean := Num'Size > 64;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable, where type Int64 is acceptable and where an Int128
+ -- is needed. These boolean constants are used to test for these cases and
+ -- since it is a constant, only code for the relevant case will be included
+ -- in the instance.
+
+ Scale : constant Integer := Num'Scale;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Get (File, Width, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Gets (S, Last, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if Need128 then
+ Aux128.Put
+ (File, Int128'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ else
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Output, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Need128 then
+ Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale);
+ else
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Decimal_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
+with Ada.Wide_Wide_Text_IO.Float_Aux; use Ada.Wide_Wide_Text_IO.Float_Aux;
+
+package body Ada.Wide_Wide_Text_IO.Fixed_Aux is
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Int;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan (Buf, Ptr'Access, Stop, Num, Den);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ return Item;
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Pos : aliased Integer;
+ Item : Int;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan (From, Pos'Access, From'Last, Num, Den);
+ Last := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ -- Compute Fore, allowing for the decimal dot and Aft digits
+
+ Fore := To'Length - 1 - Field'Max (1, Aft);
+
+ -- Allow for Exp and one more for E if exponent present
+
+ if Exp /= 0 then
+ Fore := Fore - 1 - Field'Max (2, Exp);
+ end if;
+
+ -- Make sure we have enough room
+
+ if Fore < 1 + Boolean'Pos (Item < 0) then
+ raise Layout_Error;
+ end if;
+
+ -- Do the conversion and check length of result
+
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts;
+
+end Ada.Wide_Wide_Text_IO.Fixed_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the implementation for Ada.Wide_Wide_Text_IO.Fixed_IO
+-- Routines in this package are identical semantically to those in Fixed_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there are
+-- additional Num and Den parameters giving the value of Num'Small, as well
+-- as For0 and Aft0 giving some properties of Num'Small. In addition the Get
+-- routines return the value rather than store it in an Out parameter.
+
+private generic
+ type Int is range <>;
+
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int;
+ Den : Int) return Int;
+
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+
+package Ada.Wide_Wide_Text_IO.Fixed_Aux is
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+end Ada.Wide_Wide_Text_IO.Fixed_Aux;
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O --
-- --
-- B o d y --
-- --
-- --
------------------------------------------------------------------------------
+with Interfaces;
+with Ada.Wide_Wide_Text_IO.Fixed_Aux;
with Ada.Wide_Wide_Text_IO.Float_Aux;
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_WtS; use System.WCh_WtS;
+with System.Img_Fixed_32; use System.Img_Fixed_32;
+with System.Img_Fixed_64; use System.Img_Fixed_64;
+with System.Val_Fixed_32; use System.Val_Fixed_32;
+with System.Val_Fixed_64; use System.Val_Fixed_64;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Wide_Text_IO.Fixed_IO is
- package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux;
+ -- Note: we still use the floating-point I/O routines for types whose small
+ -- is not a sufficiently small integer or the reciprocal thereof. This will
+ -- result in inaccuracies for fixed point types that require more precision
+ -- than is available in Long_Long_Float.
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Aux32 is new
+ Ada.Wide_Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
+
+ package Aux64 is new
+ Ada.Wide_Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
+
+ Exact : constant Boolean :=
+ (Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
+ or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small))
+ and then Num'Small >= 2.0**(-63)
+ and then Num'Small <= 2.0**63;
+ -- True if the exact algorithm implemented in Fixed_Aux can be used. The
+ -- condition is a Small which is either an integer or the reciprocal of an
+ -- integer with the appropriate magnitude.
+
+ Need_64 : constant Boolean :=
+ Num'Object_Size > 32
+ or else Num'Small > 2.0**31
+ or else Num'Small < 2.0**(-31);
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable and where type Int64 is needed. This Boolean is used
+ -- to test for these cases and since it is a constant, only code for the
+ -- relevant case will be included in the instance.
+
+ E : constant Natural := 31 + 32 * Boolean'Pos (Need_64);
+ -- T'Size - 1 for the selected Int{32,64}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 18 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+18);
+ F2 : constant Natural :=
+ F1 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+9);
+ F3 : constant Natural :=
+ F2 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+5);
+ F4 : constant Natural :=
+ F3 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+3);
+ F5 : constant Natural :=
+ F4 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+2);
+ F6 : constant Natural :=
+ F5 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F6;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64} and
+ -- whose small is Num'Small.
---------
-- Get --
Item : out Num;
Width : Field := 0)
is
+ pragma Unsuppress (Range_Check);
+
begin
- Aux.Get (File, Long_Long_Float (Item), Width);
+ if not Exact then
+ Float_Aux.Get (File, Long_Long_Float (Item), Width);
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
exception
when Constraint_Error => raise Data_Error;
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
-- Aux.Gets will raise Data_Error in any case.
begin
- Aux.Gets (S, Long_Long_Float (Item), Last);
+ if not Exact then
+ Float_Aux.Gets (S, Long_Long_Float (Item), Last);
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (S, Last,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Gets (S, Last,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
exception
when Constraint_Error => raise Data_Error;
Exp : Field := Default_Exp)
is
begin
- Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ if not Exact then
+ Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ elsif Need_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ end if;
end Put;
procedure Put
S : String (To'First .. To'Last);
begin
- Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ if not Exact then
+ Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ elsif Need_64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ end if;
for J in S'Range loop
To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces;
+with Ada.Wide_Wide_Text_IO.Fixed_Aux;
+with Ada.Wide_Wide_Text_IO.Float_Aux;
+with System.Img_Fixed_32; use System.Img_Fixed_32;
+with System.Img_Fixed_64; use System.Img_Fixed_64;
+with System.Img_Fixed_128; use System.Img_Fixed_128;
+with System.Val_Fixed_32; use System.Val_Fixed_32;
+with System.Val_Fixed_64; use System.Val_Fixed_64;
+with System.Val_Fixed_128; use System.Val_Fixed_128;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Wide_Text_IO.Fixed_IO is
+
+ -- Note: we still use the floating-point I/O routines for types whose small
+ -- is not a sufficiently small integer or the reciprocal thereof. This will
+ -- result in inaccuracies for fixed point types that require more precision
+ -- than is available in Long_Long_Float.
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Aux32 is new
+ Ada.Wide_Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
+
+ package Aux64 is new
+ Ada.Wide_Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
+
+ package Aux128 is new
+ Ada.Wide_Wide_Text_IO.Fixed_Aux
+ (Int128, Scan_Fixed128, Set_Image_Fixed128);
+
+ Exact : constant Boolean :=
+ (Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
+ or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small))
+ and then Num'Small >= 2.0**(-127)
+ and then Num'Small <= 2.0**127;
+ -- True if the exact algorithm implemented in Fixed_Aux can be used. The
+ -- condition is a Small which is either an integer or the reciprocal of an
+ -- integer with the appropriate magnitude.
+
+ Need_64 : constant Boolean :=
+ Num'Object_Size > 32
+ or else Num'Small > 2.0**31
+ or else Num'Small < 2.0**(-31);
+ Need_128 : constant Boolean :=
+ Num'Object_Size > 64
+ or else Num'Small > 2.0**63
+ or else Num'Small < 2.0**(-63);
+ -- Throughout this generic body, we distinguish between the cases where
+ -- type Int32 is acceptable, where type Int64 is acceptable, and where
+ -- type Int128 is needed. These boolean constants are used to test for
+ -- these cases and since they are constant, only code for the relevant
+ -- case will be really included in the instance.
+
+ E : constant Natural :=
+ 31 + 32 * Boolean'Pos (Need_64) + 64 * Boolean'Pos (Need_128);
+ -- T'Size - 1 for the selected Int{32,64,128}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 38 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+38);
+ F2 : constant Natural :=
+ F1 + 19 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+19);
+ F3 : constant Natural :=
+ F2 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+9);
+ F4 : constant Natural :=
+ F3 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+5);
+ F5 : constant Natural :=
+ F4 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+3);
+ F6 : constant Natural :=
+ F5 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+2);
+ F7 : constant Natural :=
+ F6 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F6) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F7;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64,128} and
+ -- whose small is Num'Small.
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if not Exact then
+ Float_Aux.Get (File, Long_Long_Float (Item), Width);
+ elsif Need_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Get (File, Width,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small))));
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if not Exact then
+ Float_Aux.Gets (S, Long_Long_Float (Item), Last);
+ elsif Need_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Gets (S, Last,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small))));
+ elsif Need_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (S, Last,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small))));
+ else
+ Item := Num'Fixed_Value
+ (Aux32.Gets (S, Last,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small))));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if not Exact then
+ Float_Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ elsif Need_128 then
+ Aux128.Put (File, Int128'Integer_Value (Item), Fore, Aft, Exp,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ elsif Need_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Output, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if not Exact then
+ Float_Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ elsif Need_128 then
+ Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp,
+ Int128 (-Float'Ceiling (Num'Small)),
+ Int128 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ elsif Need_64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp,
+ Int64 (-Float'Ceiling (Num'Small)),
+ Int64 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ else
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp,
+ Int32 (-Float'Ceiling (Num'Small)),
+ Int32 (-Float'Ceiling (1.0 / Num'Small)),
+ For0, Num'Aft);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Fixed_IO;
Min : Result_Subtype := Default_Min;
Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype
is
- subtype IntV is Integer_64 range
- Integer_64'Integer_Value (Min) ..
- Integer_64'Integer_Value (Max);
- function R is new Random_Discrete (Integer_64, IntV'First);
begin
- return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ if Result_Subtype'Base'Size > 64 then
+ declare
+ subtype IntV is Integer_128 range
+ Integer_128'Integer_Value (Min) ..
+ Integer_128'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_128, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+
+ elsif Result_Subtype'Base'Size > 32 then
+ declare
+ subtype IntV is Integer_64 range
+ Integer_64'Integer_Value (Min) ..
+ Integer_64'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_64, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+
+ else
+ declare
+ subtype IntV is Integer_32 range
+ Integer_32'Integer_Value (Min) ..
+ Integer_32'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_32, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+ end if;
end Random_Decimal_Fixed;
---------------------------
Min : Result_Subtype := Default_Min;
Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype
is
- subtype IntV is Integer_64 range
- Integer_64'Integer_Value (Min) ..
- Integer_64'Integer_Value (Max);
- function R is new Random_Discrete (Integer_64, IntV'First);
begin
- return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ if Result_Subtype'Base'Size > 64 then
+ declare
+ subtype IntV is Integer_128 range
+ Integer_128'Integer_Value (Min) ..
+ Integer_128'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_128, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+
+ elsif Result_Subtype'Base'Size > 32 then
+ declare
+ subtype IntV is Integer_64 range
+ Integer_64'Integer_Value (Min) ..
+ Integer_64'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_64, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+
+ else
+ declare
+ subtype IntV is Integer_32 range
+ Integer_32'Integer_Value (Min) ..
+ Integer_32'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_32, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+ end if;
end Random_Ordinary_Fixed;
------------
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . A R I T H _ 3 2 --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Conversion;
+
+package body System.Arith_32 is
+
+ pragma Suppress (Overflow_Check);
+ pragma Suppress (Range_Check);
+
+ subtype Uns32 is Interfaces.Unsigned_32;
+ subtype Uns64 is Interfaces.Unsigned_64;
+
+ use Interfaces;
+
+ function To_Int is new Ada.Unchecked_Conversion (Uns32, Int32);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function "abs" (X : Int32) return Uns32 is
+ (if X = Int32'First
+ then 2**31
+ else Uns32 (Int32'(abs X)));
+ -- Convert absolute value of X to unsigned. Note that we can't just use
+ -- the expression of the Else since it overflows for X = Int32'First.
+
+ function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32)));
+ -- High order half of 64-bit value
+
+ function To_Neg_Int (A : Uns32) return Int32;
+ -- Convert to negative integer equivalent. If the input is in the range
+ -- 0 .. 2**31, then the corresponding nonpositive signed integer (obtained
+ -- by negating the given value) is returned, otherwise constraint error is
+ -- raised.
+
+ function To_Pos_Int (A : Uns32) return Int32;
+ -- Convert to positive integer equivalent. If the input is in the range
+ -- 0 .. 2**31 - 1, then the corresponding nonnegative signed integer is
+ -- returned, otherwise constraint error is raised.
+
+ procedure Raise_Error;
+ pragma No_Return (Raise_Error);
+ -- Raise constraint error with appropriate message
+
+ -----------------
+ -- Raise_Error --
+ -----------------
+
+ procedure Raise_Error is
+ begin
+ raise Constraint_Error with "32-bit arithmetic overflow";
+ end Raise_Error;
+
+ -------------------
+ -- Scaled_Divide --
+ -------------------
+
+ procedure Scaled_Divide32
+ (X, Y, Z : Int32;
+ Q, R : out Int32;
+ Round : Boolean)
+ is
+ Xu : constant Uns32 := abs X;
+ Yu : constant Uns32 := abs Y;
+ Zu : constant Uns32 := abs Z;
+
+ D : Uns64;
+ -- The dividend
+
+ Qu : Uns32;
+ Ru : Uns32;
+ -- Unsigned quotient and remainder
+
+ begin
+ -- First do the 64-bit multiplication
+
+ D := Uns64 (Xu) * Uns64 (Yu);
+
+ -- If dividend is too large, raise error
+
+ if Hi (D) >= Zu then
+ Raise_Error;
+
+ -- Then do the 64-bit division
+
+ else
+ Qu := Uns32 (D / Uns64 (Zu));
+ Ru := Uns32 (D rem Uns64 (Zu));
+ end if;
+
+ -- Deal with rounding case
+
+ if Round and then Ru > (Zu - Uns32'(1)) / Uns32'(2) then
+
+ -- Protect against wrapping around when rounding, by signaling
+ -- an overflow when the quotient is too large.
+
+ if Qu = Uns32'Last then
+ Raise_Error;
+ end if;
+
+ Qu := Qu + Uns32'(1);
+ end if;
+
+ -- Set final signs (RM 4.5.5(27-30))
+
+ -- Case of dividend (X * Y) sign positive
+
+ if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then
+ R := To_Pos_Int (Ru);
+ Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu));
+
+ -- Case of dividend (X * Y) sign negative
+
+ else
+ R := To_Neg_Int (Ru);
+ Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu));
+ end if;
+ end Scaled_Divide32;
+
+ ----------------
+ -- To_Neg_Int --
+ ----------------
+
+ function To_Neg_Int (A : Uns32) return Int32 is
+ R : constant Int32 :=
+ (if A = 2**31 then Int32'First else -To_Int (A));
+ -- Note that we can't just use the expression of the Else, because it
+ -- overflows for A = 2**31.
+ begin
+ if R <= 0 then
+ return R;
+ else
+ Raise_Error;
+ end if;
+ end To_Neg_Int;
+
+ ----------------
+ -- To_Pos_Int --
+ ----------------
+
+ function To_Pos_Int (A : Uns32) return Int32 is
+ R : constant Int32 := To_Int (A);
+ begin
+ if R >= 0 then
+ return R;
+ else
+ Raise_Error;
+ end if;
+ end To_Pos_Int;
+
+end System.Arith_32;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . A R I T H _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This unit provides software routines for doing arithmetic on 32-bit
+-- signed integer values in cases where either overflow checking is
+-- required, or intermediate results are longer than 32 bits.
+
+with Interfaces;
+
+package System.Arith_32 is
+ pragma Pure;
+
+ subtype Int32 is Interfaces.Integer_32;
+
+ procedure Scaled_Divide32
+ (X, Y, Z : Int32;
+ Q, R : out Int32;
+ Round : Boolean);
+ -- Performs the division of (X * Y) / Z, storing the quotient in Q
+ -- and the remainder in R. Constraint_Error is raised if Z is zero,
+ -- or if the quotient does not fit in 32 bits. Round indicates if
+ -- the result should be rounded. If Round is False, then Q, R are
+ -- the normal quotient and remainder from a truncating division.
+ -- If Round is True, then Q is the rounded quotient. The remainder
+ -- R is not affected by the setting of the Round flag.
+
+end System.Arith_32;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ D E C I M A L _ 1 2 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute for decimal
+-- fixed point types up to 128-bit mantissa.
+
+with Interfaces;
+with System.Fore_D;
+
+package System.Fore_Decimal_128 is
+ pragma Pure;
+
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Impl is new Fore_D (Int128);
+
+ function Fore_Decimal128 (Lo, Hi : Int128; Scale : Integer) return Natural
+ renames Impl.Fore_Decimal;
+
+end System.Fore_Decimal_128;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ D E C I M A L _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute for decimal
+-- fixed point types up to 32-bit mantissa.
+
+with Interfaces;
+with System.Fore_D;
+
+package System.Fore_Decimal_32 is
+ pragma Pure;
+
+ subtype Int32 is Interfaces.Integer_32;
+
+ package Impl is new Fore_D (Int32);
+
+ function Fore_Decimal32 (Lo, Hi : Int32; Scale : Integer) return Natural
+ renames Impl.Fore_Decimal;
+
+end System.Fore_Decimal_32;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ D E C I M A L _ 6 4 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute for decimal
+-- fixed point types up to 64-bit mantissa.
+
+with Interfaces;
+with System.Fore_D;
+
+package System.Fore_Decimal_64 is
+ pragma Pure;
+
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Impl is new Fore_D (Int64);
+
+ function Fore_Decimal64 (Lo, Hi : Int64; Scale : Integer) return Natural
+ renames Impl.Fore_Decimal;
+
+end System.Fore_Decimal_64;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O F I _ 1 2 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute for ordinary
+-- fixed point types up to 128-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_128;
+with System.Fore_F;
+
+package System.Fore_Fixed_128 is
+ pragma Pure;
+
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Impl is new Fore_F (Int128, Arith_128.Scaled_Divide128);
+
+ function Fore_Fixed128 (Lo, Hi, Num, Den : Int128) return Natural
+ renames Impl.Fore_Fixed;
+
+end System.Fore_Fixed_128;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ F I X E D _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute for ordinary
+-- fixed point types up to 32-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_32;
+with System.Fore_F;
+
+package System.Fore_Fixed_32 is
+ pragma Pure;
+
+ subtype Int32 is Interfaces.Integer_32;
+
+ package Impl is new Fore_F (Int32, Arith_32.Scaled_Divide32);
+
+ function Fore_Fixed32 (Lo, Hi, Num, Den : Int32) return Natural
+ renames Impl.Fore_Fixed;
+
+end System.Fore_Fixed_32;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ F I X E D _ 6 4 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute for ordinary
+-- fixed point types up to 64-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_64;
+with System.Fore_F;
+
+package System.Fore_Fixed_64 is
+ pragma Pure;
+
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Impl is new Fore_F (Int64, Arith_64.Scaled_Divide64);
+
+ function Fore_Fixed64 (Lo, Hi, Num, Den : Int64) return Natural
+ renames Impl.Fore_Fixed;
+
+end System.Fore_Fixed_64;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . F O R E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package body System.Fore is
-
- ----------
- -- Fore --
- ----------
-
- function Fore (Lo, Hi : Long_Long_Float) return Natural is
- T : Long_Long_Float := Long_Long_Float'Max (abs Lo, abs Hi);
- R : Natural;
-
- begin
- -- Initial value of 2 allows for sign and mandatory single digit
-
- R := 2;
-
- -- Loop to increase Fore as needed to include full range of values
-
- while T >= 10.0 loop
- T := T / 10.0;
- R := R + 1;
- end loop;
-
- return R;
- end Fore;
-end System.Fore;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . F O R E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the routine used for the 'Fore attribute
-
-package System.Fore is
- pragma Pure;
-
- function Fore (Lo, Hi : Long_Long_Float) return Natural;
- -- Compute Fore attribute value for a fixed-point type. The parameters
- -- are the low and high bounds values, converted to Long_Long_Float.
-
-end System.Fore;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Fore_D is
+
+ ------------------
+ -- Fore_Decimal --
+ ------------------
+
+ function Fore_Decimal (Lo, Hi : Int; Scale : Integer) return Natural is
+
+ function Negative_Abs (Val : Int) return Int is
+ (if Val <= 0 then Val else -Val);
+ -- Return the opposite of the absolute value of Val
+
+ T : Int := Int'Min (Negative_Abs (Lo), Negative_Abs (Hi));
+ F : Natural;
+
+ begin
+ -- Initial value of 2 allows for sign and mandatory single digit
+
+ F := 2;
+
+ -- Loop to increase Fore as needed to include full range of values
+
+ while T <= -10 loop
+ T := T / 10;
+ F := F + 1;
+ end loop;
+
+ return Natural'Max (F - Scale, 2);
+ end Fore_Decimal;
+
+end System.Fore_D;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the Fore attribute of decimal
+-- fixed point types.
+
+generic
+
+ type Int is range <>;
+
+package System.Fore_D is
+ pragma Pure;
+
+ function Fore_Decimal (Lo, Hi : Int; Scale : Integer) return Natural;
+ -- Compute Fore attribute value for a decimal fixed point type. The
+ -- parameters are the low and high bounds (in units of delta) and the
+ -- scale.
+
+end System.Fore_D;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ F --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Fore_F is
+
+ Maxdigs : constant Natural := Int'Width - 2;
+ -- Maximum number of decimal digits that can be represented in an Int.
+ -- The "-2" accounts for the sign and one extra digit, since we need the
+ -- maximum number of 9's that can be represented, e.g. for the 64-bit case,
+ -- Integer_64'Width is 20 since the maximum value is approximately 9.2E+18
+ -- and has 19 digits, but the maximum number of 9's that can be represented
+ -- in Integer_64 is only 18.
+
+ -- The prerequisite of the implementation is that the scaled divide does
+ -- not overflow, which means that the absolute value of the bounds of
+ -- the subtype must be smaller than 10**Maxdigs * 2**(Int'Size - 1).
+ -- Otherwise Constraint_Error is raised by the scaled divide operation.
+
+ ----------------
+ -- Fore_Fixed --
+ ----------------
+
+ function Fore_Fixed (Lo, Hi, Num, Den : Int) return Natural is
+ pragma Assert (Num < 0 and then Den < 0);
+ -- Accept only negative numbers to allow -2**(Int'Size - 1)
+
+ function Negative_Abs (Val : Int) return Int is
+ (if Val <= 0 then Val else -Val);
+ -- Return the opposite of the absolute value of Val
+
+ T : Int := Int'Min (Negative_Abs (Lo), Negative_Abs (Hi));
+ F : Natural;
+
+ begin
+ -- Initial value of 2 allows for sign and mandatory single digit
+
+ F := 2;
+
+ -- If the Small is 1, then no scaling is needed
+
+ if Num = -1 and then Den = -1 then
+ null;
+
+ -- The easy case is when the Small is the reciprocal of an integer
+
+ elsif Num = -1 then
+ T := T / Den;
+
+ -- If the Small is an integer, compute Q and R such that
+
+ -- T * Small = Q * 10**Maxdigs - R
+
+ -- then reason on Q if it is non-zero or else on R.
+
+ else pragma Assert (Den = -1);
+ declare
+ Q, R : Int;
+
+ begin
+ Scaled_Divide (T, Num, -10**Maxdigs, Q, R, Round => False);
+
+ if Q /= 0 then
+ T := Q;
+ F := F + Maxdigs;
+ else
+ T := R;
+ end if;
+ end;
+ end if;
+
+ -- Loop to increase Fore as needed to include full range of values
+
+ while T <= -10 or else T >= 10 loop
+ T := T / 10;
+ F := F + 1;
+ end loop;
+
+ return F;
+ end Fore_Fixed;
+
+end System.Fore_F;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ F --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the Fore attribute of ordinary
+-- fixed point types whose Small is an integer or its reciprocal.
+
+generic
+
+ type Int is range <>;
+
+ with procedure Scaled_Divide
+ (X, Y, Z : Int;
+ Q, R : out Int;
+ Round : Boolean);
+
+package System.Fore_F is
+ pragma Pure;
+
+ function Fore_Fixed (Lo, Hi, Num, Den : Int) return Natural;
+ -- Compute Fore attribute value for an ordinary fixed point type with small
+ -- Num/Den. The parameters are the low and high bounds (in units of small).
+
+end System.Fore_F;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ R E A L --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Fore_Real is
+
+ ---------------
+ -- Fore_Real --
+ ---------------
+
+ function Fore_Real (Lo, Hi : Long_Long_Float) return Natural is
+ T : Long_Long_Float := Long_Long_Float'Max (abs Lo, abs Hi);
+ F : Natural;
+
+ begin
+ -- Initial value of 2 allows for sign and mandatory single digit
+
+ F := 2;
+
+ -- Loop to increase Fore as needed to include full range of values
+
+ while T >= 10.0 loop
+ T := T / 10.0;
+ F := F + 1;
+ end loop;
+
+ return F;
+ end Fore_Real;
+
+end System.Fore_Real;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ R E A L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the Fore attribute of ordinary
+-- fixed point types whose Small is neither an integer nor its reciprocal.
+
+package System.Fore_Real is
+ pragma Pure;
+
+ function Fore_Real (Lo, Hi : Long_Long_Float) return Natural;
+ -- Compute Fore attribute value for a fixed point type. The parameters
+ -- are the low and high bounds, converted to Long_Long_Float.
+
+end System.Fore_Real;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Img_Util; use System.Img_Util;
+
+package body System.Image_D is
+
+ -------------------
+ -- Image_Decimal --
+ -------------------
+
+ procedure Image_Decimal
+ (V : Int;
+ S : in out String;
+ P : out Natural;
+ Scale : Integer)
+ is
+ pragma Assert (S'First = 1);
+
+ begin
+ -- Add space at start for non-negative numbers
+
+ if V >= 0 then
+ S (1) := ' ';
+ P := 1;
+ else
+ P := 0;
+ end if;
+
+ Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
+ end Image_Decimal;
+
+ -----------------------
+ -- Set_Image_Decimal --
+ -----------------------
+
+ procedure Set_Image_Decimal
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ is
+ Digs : String := Int'Image (V);
+ -- Sign and digits of decimal value
+
+ begin
+ Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp);
+ end Set_Image_Decimal;
+
+end System.Image_D;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- decimal fixed point types, and also for conversion operations required in
+-- Text_IO.Decimal_IO for such types.
+
+generic
+
+ type Int is range <>;
+
+package System.Image_D is
+ pragma Pure;
+
+ procedure Image_Decimal
+ (V : Int;
+ S : in out String;
+ P : out Natural;
+ Scale : Integer);
+ -- Computes fixed_type'Image (V), where V is the integer value (in units of
+ -- delta) of a decimal type whose Scale is as given and stores the result
+ -- S (1 .. P), updating P to the value of L. The image is given by the
+ -- rules in RM 3.5(34) for fixed-point type image functions. The caller
+ -- guarantees that S is long enough to hold the result and has a lower
+ -- bound of 1.
+
+ procedure Set_Image_Decimal
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+ -- Sets the image of V, where V is the integer value (in units of delta)
+ -- of a decimal type with the specified Scale, starting at S (P + 1) and
+ -- updating P to point to the last character stored, the caller promises
+ -- that the buffer is large enough and no check is made. Constraint_Error
+ -- will not necessarily be raised if this requirement is violated, since
+ -- it is perfectly valid to compile this unit with checks off. The Fore,
+ -- Aft and Exp values can be set to any valid values for the case of use
+ -- by Text_IO.Decimal_IO.
+
+end System.Image_D;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ F --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Image_I;
+with System.Img_Util; use System.Img_Util;
+
+package body System.Image_F is
+
+ package Image_I is new System.Image_I (Int);
+
+ procedure Set_Image_Integer
+ (V : Int;
+ S : in out String;
+ P : in out Natural)
+ renames Image_I.Set_Image_Integer;
+
+ -- The following section describes a specific implementation choice for
+ -- performing base conversions needed for output of values of a fixed
+ -- point type T with small T'Small. The goal is to be able to output
+ -- all values of fixed point types with a precision of 64 bits and a
+ -- small in the range 2.0**(-63) .. 2.0**63. The reasoning can easily
+ -- be adapted to fixed point types with a precision of 32 or 128 bits.
+
+ -- The chosen algorithm uses fixed precision integer arithmetic for
+ -- reasons of simplicity and efficiency. It is important to understand
+ -- in what ways the most simple and accurate approach to fixed point I/O
+ -- is limiting, before considering more complicated schemes.
+
+ -- Without loss of generality assume T has a range (-2.0**63) * T'Small
+ -- .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the
+ -- decimal point and T'Fore - 1 before. If T'Small is integer, or
+ -- 1.0 / T'Small is integer, let S = T'Small.
+
+ -- The idea is to convert a value X * S of type T to a 64-bit integer value
+ -- Q equal to 10.0**D * (X * S) rounded to the nearest integer, using only
+ -- a scaled integer divide of the form
+
+ -- Q = (X * Y) / Z,
+
+ -- where the variables X, Y, Z are 64-bit integers, and both multiplication
+ -- and division are done using full intermediate precision. Then the final
+ -- decimal value to be output is
+
+ -- Q * 10**(-D)
+
+ -- This value can be written to the output file or to the result string
+ -- according to the format described in RM A.3.10. The details of this
+ -- operation are omitted here.
+
+ -- A 64-bit value can represent all integers with 18 decimal digits, but
+ -- not all with 19 decimal digits. If the total number of requested ouput
+ -- digits (Fore - 1) + Aft is greater than 18 then, for purposes of the
+ -- conversion, Aft is adjusted to 18 - (Fore - 1). In that case, trailing
+ -- zeros can complete the output after writing the first 18 significant
+ -- digits, or the technique described in the next section can be used.
+ -- In addition, D cannot be smaller than -18, in order for 10.0**(-D) to
+ -- fit in a 64-bit integer.
+
+ -- The final expression for D is
+
+ -- D = Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1)));
+
+ -- For Y and Z the following expressions can be derived:
+
+ -- Q = X * S * (10.0**D) = (X * Y) / Z
+
+ -- If S is an integer greater than or equal to one, then Fore must be at
+ -- least 20 in order to print T'First, which is at most -2.0**63. This
+ -- means that D < 0, so use
+
+ -- (1) Y = -S and Z = -10**(-D)
+
+ -- If 1.0 / S is an integer greater than one, use
+
+ -- (2) Y = -10**D and Z = -(1.0 / S), for D >= 0
+
+ -- or
+
+ -- (3) Y = -1 and Z = -(1.0 / S) * 10**(-D), for D < 0
+
+ -- Negative values are used for nominator Y and denominator Z, so that S
+ -- can have a maximum value of 2.0**63 and a minimum of 2.0**(-63). For
+ -- -(1.0 / S) in -1 .. -9, Fore will still be 20, and D will be negative,
+ -- as (-2.0**63) / -9 is greater than 10**18. In these cases there is room
+ -- in the denominator for the extra decimal scaling required, so case (3)
+ -- will not overflow.
+
+ -- Using a scaled divide which truncates and returns a remainder R,
+ -- another K trailing digits can be calculated by computing the value
+ -- (R * (10.0**K)) / Z using another scaled divide. This procedure
+ -- can be repeated to compute an arbitrary number of digits in linear
+ -- time and storage. The last scaled divide should be rounded, with
+ -- a possible carry propagating to the more significant digits, to
+ -- ensure correct rounding of the unit in the last place.
+
+ Maxdigs : constant Natural := Int'Width - 2;
+ -- Maximum number of decimal digits that can be represented in an Int.
+ -- The "-2" accounts for the sign and one extra digit, since we need the
+ -- maximum number of 9's that can be represented, e.g. for the 64-bit case,
+ -- Integer_64'Width is 20 since the maximum value is approximately 9.2E+18
+ -- and has 19 digits, but the maximum number of 9's that can be represented
+ -- in Integer_64 is only 18.
+
+ -- The prerequisite of the implementation is that the first scaled divide
+ -- does not overflow, which means that the absolute value of the input X
+ -- must always be smaller than 10**Maxdigs * 2**(Int'Size - 1). Otherwise
+ -- Constraint_Error is raised by the scaled divide operation.
+
+ -----------------
+ -- Image_Fixed --
+ -----------------
+
+ procedure Image_Fixed
+ (V : Int;
+ S : in out String;
+ P : out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ pragma Assert (S'First = 1);
+
+ begin
+ -- Add space at start for non-negative numbers
+
+ if V >= 0 then
+ S (1) := ' ';
+ P := 1;
+ else
+ P := 0;
+ end if;
+
+ Set_Image_Fixed (V, S, P, Num, Den, For0, Aft0, 1, Aft0, 0);
+ end Image_Fixed;
+
+ ---------------------
+ -- Set_Image_Fixed --
+ ---------------------
+
+ procedure Set_Image_Fixed
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ is
+ pragma Assert (Num < 0 and then Den < 0);
+ -- Accept only negative numbers to allow -2**(Int'Size - 1)
+
+ pragma Assert (Num = -1 or else Den = -1);
+ -- Accept only integer or reciprocal of integer to control the
+ -- magnitude of the arithmetic operations below.
+
+ A : constant Natural :=
+ Boolean'Pos (Exp > 0) * Aft0 + Natural'Max (Aft, 1) + 1;
+ -- Number of digits after the decimal point to be computed. If Exp is
+ -- positive, we need to compute Aft decimal digits after the first non
+ -- zero digit and we are guaranteed there is at least one in the first
+ -- Aft0 digits (unless V is zero). In both cases, we compute one more
+ -- digit than requested so that Set_Decimal_Digits can round at Aft.
+
+ D : constant Integer :=
+ Integer'Max (-Maxdigs, Integer'Min (A, Maxdigs - (For0 - 1)));
+ Y : constant Int := Num * 10**Integer'Max (0, D);
+ Z : constant Int := Den * 10**Integer'Max (0, -D);
+ -- See the description of the algorithm above
+
+ AF : constant Natural := A - D;
+ -- Number of remaining digits to be computed after the first round. It
+ -- is larger than A if the first round does not compute all the digits
+ -- before the decimal point, i.e. (For0 - 1) larger than Maxdigs.
+
+ N : constant Natural := 1 + (AF + Maxdigs - 1) / Maxdigs;
+ -- Number of rounds of scaled divide to be performed
+
+ Q : Int;
+ -- Quotient of the scaled divide in this round. Only the first round
+ -- may yield more than Maxdigs digits. The sign is not significant.
+
+ Buf : String (1 .. Maxdigs);
+ Len : Natural;
+ -- Buffer for the image of the quotient
+
+ Digs : String (1 .. N * Maxdigs + 1);
+ Ndigs : Natural := 0;
+ -- Concatenated image of the successive quotients
+
+ Scale : Integer := 0;
+ -- Exponent such that the result is Digs (1 .. NDigs) * 10**(-Scale)
+
+ XX : Int := V;
+ YY : Int := Y;
+ -- First two operands of the scaled divide
+
+ begin
+ -- Set the first character like Image, either minus or space
+
+ Digs (1) := (if V < 0 then '-' else ' ');
+ Ndigs := 1;
+
+ for J in 1 .. N loop
+ exit when XX = 0;
+
+ Scaled_Divide (XX, YY, Z, Q, R => XX, Round => False);
+
+ if J = 1 then
+ if Q /= 0 then
+ Set_Image_Integer (abs Q, Digs, Ndigs);
+ end if;
+
+ Scale := Scale + D;
+
+ -- Prepare for next round, if any
+
+ YY := 10**Maxdigs;
+
+ else
+ Len := 0;
+ Set_Image_Integer (abs Q, Buf, Len);
+
+ if Ndigs = 1 then
+ Digs (2 .. Len + 1) := Buf (1 .. Len);
+ Ndigs := Len + 1;
+
+ else
+ -- Pad the output with zeroes up to Maxdigs
+
+ for K in 1 .. Maxdigs - Len loop
+ Digs (Ndigs + K) := '0';
+ end loop;
+
+ for K in 1 .. Len loop
+ Digs (Ndigs + Maxdigs - Len + K) := Buf (K);
+ end loop;
+
+ Ndigs := Ndigs + Maxdigs;
+ end if;
+
+ Scale := Scale + Maxdigs;
+ end if;
+ end loop;
+
+ -- If no digit was output, this is zero
+
+ if Ndigs = 1 then
+ Digs (1 .. 2) := " 0";
+ Ndigs := 2;
+ end if;
+
+ Set_Decimal_Digits (Digs, Ndigs, S, P, Scale, Fore, Aft, Exp);
+ end Set_Image_Fixed;
+
+end System.Image_F;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ F --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- ordinary fixed point types whose Small is an integer or its reciprocal,
+-- and also for conversion operations required in Text_IO.Fixed_IO for such
+-- types.
+
+generic
+
+ type Int is range <>;
+
+ with procedure Scaled_Divide
+ (X, Y, Z : Int;
+ Q, R : out Int;
+ Round : Boolean);
+
+package System.Image_F is
+ pragma Pure;
+
+ procedure Image_Fixed
+ (V : Int;
+ S : in out String;
+ P : out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+ -- Computes fixed_type'Image (V), where V is the integer value (in units of
+ -- small) of an ordinary fixed point type with small Num/Den, and stores
+ -- the result in S (1 .. P), updating P on return. The result is computed
+ -- according to the rules for image for fixed-point types (RM 3.5(34)).
+ -- For0 and Aft0 are the values of the Fore and Aft attributes for the
+ -- fixed point type whose mantissa type is Int and whose small is Num/Den.
+ -- This function is used only for fixed point whose Small is an integer or
+ -- its reciprocal (see package System.Img_Real for the handling of other
+ -- ordinary fixed-point types). The caller guarantees that S is long enough
+ -- to hold the result and has a lower bound of 1.
+
+ procedure Set_Image_Fixed
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+ -- Sets the image of V, where V is the integer value (in units of small)
+ -- of a fixed point type with small Num/Den, starting at S (P + 1) and
+ -- updating P to point to the last character stored, the caller promises
+ -- that the buffer is large enough and no check is made. Constraint_Error
+ -- will not necessarily be raised if this requirement is violated, since
+ -- it is perfectly valid to compile this unit with checks off. For0 and
+ -- Aft0 are the values of the Fore and Aft attributes for the fixed point
+ -- type whose mantissa type is Int and whose small is Num/Den. The Fore,
+ -- Aft and Exp can be set to any valid values for use by Text_IO.Fixed_IO.
+
+end System.Image_F;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ D E C I M A L _ 1 2 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- decimal fixed point types up to 128-bit mantissa, and also for conversion
+-- operations required in Text_IO.Decimal_IO for them.
+
+with Interfaces;
+with System.Image_D;
+
+package System.Img_Decimal_128 is
+ pragma Pure;
+
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Impl is new Image_D (Int128);
+
+ procedure Image_Decimal128
+ (V : Int128;
+ S : in out String;
+ P : out Natural;
+ Scale : Integer)
+ renames Impl.Image_Decimal;
+
+ procedure Set_Image_Decimal128
+ (V : Int128;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Decimal;
+
+end System.Img_Decimal_128;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ D E C I M A L _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- decimal fixed point types up to 32-bit mantissa, and also for conversion
+-- operations required in Text_IO.Decimal_IO for such types.
+
+with Interfaces;
+with System.Image_D;
+
+package System.Img_Decimal_32 is
+ pragma Pure;
+
+ subtype Int32 is Interfaces.Integer_32;
+
+ package Impl is new Image_D (Int32);
+
+ procedure Image_Decimal32
+ (V : Int32;
+ S : in out String;
+ P : out Natural;
+ Scale : Integer)
+ renames Impl.Image_Decimal;
+
+ procedure Set_Image_Decimal32
+ (V : Int32;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Decimal;
+
+end System.Img_Decimal_32;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ D E C I M A L _ 6 4 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- decimal fixed point types up to 64-bit mantissa, and also for conversion
+-- operations required in Text_IO.Decimal_IO for such types.
+
+with Interfaces;
+with System.Image_D;
+
+package System.Img_Decimal_64 is
+ pragma Pure;
+
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Impl is new Image_D (Int64);
+
+ procedure Image_Decimal64
+ (V : Int64;
+ S : in out String;
+ P : out Natural;
+ Scale : Integer)
+ renames Impl.Image_Decimal;
+
+ procedure Set_Image_Decimal64
+ (V : Int64;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Decimal;
+
+end System.Img_Decimal_64;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ F I X E D _ 1 2 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- ordinary fixed point types up to 128-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_128;
+with System.Image_F;
+
+package System.Img_Fixed_128 is
+ pragma Pure;
+
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Impl is new Image_F (Int128, Arith_128.Scaled_Divide128);
+
+ procedure Image_Fixed128
+ (V : Int128;
+ S : in out String;
+ P : out Natural;
+ Num : Int128;
+ Den : Int128;
+ For0 : Natural;
+ Aft0 : Natural)
+ renames Impl.Image_Fixed;
+
+ procedure Set_Image_Fixed128
+ (V : Int128;
+ S : in out String;
+ P : in out Natural;
+ Num : Int128;
+ Den : Int128;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Fixed;
+
+end System.Img_Fixed_128;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ F I X E D _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- ordinary fixed point types up to 32-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_32;
+with System.Image_F;
+
+package System.Img_Fixed_32 is
+ pragma Pure;
+
+ subtype Int32 is Interfaces.Integer_32;
+
+ package Impl is new Image_F (Int32, Arith_32.Scaled_Divide32);
+
+ procedure Image_Fixed32
+ (V : Int32;
+ S : in out String;
+ P : out Natural;
+ Num : Int32;
+ Den : Int32;
+ For0 : Natural;
+ Aft0 : Natural)
+ renames Impl.Image_Fixed;
+
+ procedure Set_Image_Fixed32
+ (V : Int32;
+ S : in out String;
+ P : in out Natural;
+ Num : Int32;
+ Den : Int32;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Fixed;
+
+end System.Img_Fixed_32;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ F I X E D _ 6 4 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- ordinary fixed point types up to 64-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_64;
+with System.Image_F;
+
+package System.Img_Fixed_64 is
+ pragma Pure;
+
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Impl is new Image_F (Int64, Arith_64.Scaled_Divide64);
+
+ procedure Image_Fixed64
+ (V : Int64;
+ S : in out String;
+ P : out Natural;
+ Num : Int64;
+ Den : Int64;
+ For0 : Natural;
+ Aft0 : Natural)
+ renames Impl.Image_Fixed;
+
+ procedure Set_Image_Fixed64
+ (V : Int64;
+ S : in out String;
+ P : in out Natural;
+ Num : Int64;
+ Den : Int64;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Fixed;
+
+end System.Img_Fixed_64;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . I M G _ D E C --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with System.Img_Int; use System.Img_Int;
-
-package body System.Img_Dec is
-
- -------------------
- -- Image_Decimal --
- -------------------
-
- procedure Image_Decimal
- (V : Integer;
- S : in out String;
- P : out Natural;
- Scale : Integer)
- is
- pragma Assert (S'First = 1);
-
- begin
- -- Add space at start for non-negative numbers
-
- if V >= 0 then
- S (1) := ' ';
- P := 1;
- else
- P := 0;
- end if;
-
- Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
- end Image_Decimal;
-
- ------------------------
- -- Set_Decimal_Digits --
- ------------------------
-
- procedure Set_Decimal_Digits
- (Digs : in out String;
- NDigs : Natural;
- S : out String;
- P : in out Natural;
- Scale : Integer;
- Fore : Natural;
- Aft : Natural;
- Exp : Natural)
- is
- pragma Assert (NDigs >= 1);
- pragma Assert (Digs'First = 1);
- pragma Assert (Digs'First < Digs'Last);
-
- Minus : constant Boolean := (Digs (Digs'First) = '-');
- -- Set True if input is negative
-
- Zero : Boolean := (Digs (Digs'First + 1) = '0');
- -- Set True if input is exactly zero (only case when a leading zero
- -- is permitted in the input string given to this procedure). This
- -- flag can get set later if rounding causes the value to become zero.
-
- FD : Natural := 2;
- -- First digit position of digits remaining to be processed
-
- LD : Natural := NDigs;
- -- Last digit position of digits remaining to be processed
-
- ND : Natural := NDigs - 1;
- -- Number of digits remaining to be processed (LD - FD + 1)
-
- Digits_Before_Point : Integer := ND - Scale;
- -- Number of digits before decimal point in the input value. This
- -- value can be negative if the input value is less than 0.1, so
- -- it is an indication of the current exponent. Digits_Before_Point
- -- is adjusted if the rounding step generates an extra digit.
-
- Digits_After_Point : constant Natural := Integer'Max (1, Aft);
- -- Digit positions after decimal point in result string
-
- Expon : Integer;
- -- Integer value of exponent
-
- procedure Round (N : Integer);
- -- Round the number in Digs. N is the position of the last digit to be
- -- retained in the rounded position (rounding is based on Digs (N + 1)
- -- FD, LD, ND are reset as necessary if required. Note that if the
- -- result value rounds up (e.g. 9.99 => 10.0), an extra digit can be
- -- placed in the sign position as a result of the rounding, this is
- -- the case in which FD is adjusted. The call to Round has no effect
- -- if N is outside the range FD .. LD.
-
- procedure Set (C : Character);
- pragma Inline (Set);
- -- Sets character C in output buffer
-
- procedure Set_Blanks_And_Sign (N : Integer);
- -- Sets leading blanks and minus sign if needed. N is the number of
- -- positions to be filled (a minus sign is output even if N is zero
- -- or negative, For a positive value, if N is non-positive, then
- -- a leading blank is filled.
-
- procedure Set_Digits (S, E : Natural);
- pragma Inline (Set_Digits);
- -- Set digits S through E from Digs, no effect if S > E
-
- procedure Set_Zeroes (N : Integer);
- pragma Inline (Set_Zeroes);
- -- Set N zeroes, no effect if N is negative
-
- -----------
- -- Round --
- -----------
-
- procedure Round (N : Integer) is
- D : Character;
-
- pragma Assert (NDigs >= 1);
- pragma Assert (Digs'First = 1);
- pragma Assert (Digs'First < Digs'Last);
-
- begin
- -- Nothing to do if rounding past the last digit we have
-
- if N >= LD then
- return;
-
- -- Cases of rounding before the initial digit
-
- elsif N < FD then
-
- -- The result is zero, unless we are rounding just before
- -- the first digit, and the first digit is five or more.
-
- if N = 1 and then Digs (Digs'First + 1) >= '5' then
- Digs (Digs'First) := '1';
- else
- Digs (Digs'First) := '0';
- Zero := True;
- end if;
-
- Digits_Before_Point := Digits_Before_Point + 1;
- FD := 1;
- LD := 1;
- ND := 1;
-
- -- Normal case of rounding an existing digit
-
- else
- LD := N;
- pragma Assert (LD >= 1);
- -- In this case, we have N < LD and N >= FD. FD is a Natural,
- -- So we can conclude, LD >= 1
- ND := LD - 1;
- pragma Assert (N + 1 <= Digs'Last);
-
- if Digs (N + 1) >= '5' then
- for J in reverse Digs'First + 1 .. Digs'First + N - 1 loop
- pragma Assert (Digs (J) in '0' .. '9' | ' ' | '-');
- -- Because it is a decimal image, we can assume that
- -- it can only contain these characters.
- D := Character'Succ (Digs (J));
-
- if D <= '9' then
- Digs (J) := D;
- return;
- else
- Digs (J) := '0';
- end if;
- end loop;
-
- -- Here the rounding overflows into the sign position. That's
- -- OK, because we already captured the value of the sign and
- -- we are in any case destroying the value in the Digs buffer
-
- Digs (Digs'First) := '1';
- FD := 1;
- ND := ND + 1;
- Digits_Before_Point := Digits_Before_Point + 1;
- end if;
- end if;
- end Round;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (C : Character) is
- begin
- pragma Assert (P >= (S'First - 1) and P < S'Last and
- P < Natural'Last);
- -- No check is done as documented in the header : updating P to
- -- point to the last character stored, the caller promises that the
- -- buffer is large enough and no check is made for this.
- -- Constraint_Error will not necessarily be raised if this
- -- requirement is violated, since it is perfectly valid to compile
- -- this unit with checks off.
- --
- -- Due to codepeer limitation, codepeer should be used with switch:
- -- -no-propagation system.img_dec.set_decimal_digits.set
- P := P + 1;
- S (P) := C;
- end Set;
-
- -------------------------
- -- Set_Blanks_And_Sign --
- -------------------------
-
- procedure Set_Blanks_And_Sign (N : Integer) is
- W : Integer := N;
-
- begin
- if Minus then
- W := W - 1;
-
- for J in 1 .. W loop
- Set (' ');
- end loop;
-
- Set ('-');
-
- else
- for J in 1 .. W loop
- Set (' ');
- end loop;
- end if;
- end Set_Blanks_And_Sign;
-
- ----------------
- -- Set_Digits --
- ----------------
-
- procedure Set_Digits (S, E : Natural) is
- begin
- pragma Assert (S >= Digs'First and E <= Digs'Last);
- -- S and E should be in the Digs array range
- -- TBC: Analysis should be completed
- for J in S .. E loop
- Set (Digs (J));
- end loop;
- end Set_Digits;
-
- ----------------
- -- Set_Zeroes --
- ----------------
-
- procedure Set_Zeroes (N : Integer) is
- begin
- for J in 1 .. N loop
- Set ('0');
- end loop;
- end Set_Zeroes;
-
- -- Start of processing for Set_Decimal_Digits
-
- begin
- -- Case of exponent given
-
- if Exp > 0 then
- Set_Blanks_And_Sign (Fore - 1);
- Round (Digits_After_Point + 2);
-
- Set (Digs (FD));
- FD := FD + 1;
- pragma Assert (ND >= 1);
- ND := ND - 1;
- Set ('.');
-
- if ND >= Digits_After_Point then
- Set_Digits (FD, FD + Digits_After_Point - 1);
- else
- Set_Digits (FD, LD);
- Set_Zeroes (Digits_After_Point - ND);
- end if;
-
- -- Calculate exponent. The number of digits before the decimal point
- -- in the input is Digits_Before_Point, and the number of digits
- -- before the decimal point in the output is 1, so we can get the
- -- exponent as the difference between these two values. The one
- -- exception is for the value zero, which by convention has an
- -- exponent of +0.
-
- Expon := (if Zero then 0 else Digits_Before_Point - 1);
- Set ('E');
- ND := 0;
-
- if Expon >= 0 then
- Set ('+');
- Set_Image_Integer (Expon, Digs, ND);
- else
- Set ('-');
- Set_Image_Integer (-Expon, Digs, ND);
- end if;
-
- Set_Zeroes (Exp - ND - 1);
- Set_Digits (1, ND);
- return;
-
- -- Case of no exponent given. To make these cases clear, we use
- -- examples. For all the examples, we assume Fore = 2, Aft = 3.
- -- A P in the example input string is an implied zero position,
- -- not included in the input string.
-
- else
- -- Round at correct position
- -- Input: 4PP => unchanged
- -- Input: 400.03 => unchanged
- -- Input 3.4567 => 3.457
- -- Input: 9.9999 => 10.000
- -- Input: 0.PPP5 => 0.001
- -- Input: 0.PPP4 => 0
- -- Input: 0.00003 => 0
-
- Round (LD - (Scale - Digits_After_Point));
-
- -- No digits before point in input
- -- Input: .123 Output: 0.123
- -- Input: .PP3 Output: 0.003
-
- if Digits_Before_Point <= 0 then
- Set_Blanks_And_Sign (Fore - 1);
- Set ('0');
- Set ('.');
-
- declare
- DA : Natural := Digits_After_Point;
- -- Digits remaining to output after point
-
- LZ : constant Integer := Integer'Min (DA, -Digits_Before_Point);
- -- Number of leading zeroes after point. Note: there used to be
- -- a Max of this result with zero, but that's redundant, since
- -- we know DA is positive, and because of the test above, we
- -- know that -Digits_Before_Point >= 0.
-
- begin
- Set_Zeroes (LZ);
- DA := DA - LZ;
-
- if DA < ND then
-
- -- Note: it is definitely possible for the above condition
- -- to be True, for example:
-
- -- V => 1234, Scale => 5, Fore => 0, After => 1, Exp => 0
-
- -- but in this case DA = 0, ND = 1, FD = 1, FD + DA-1 = 0
- -- so the arguments in the call are (1, 0) meaning that no
- -- digits are output.
-
- -- No obvious example exists where the following call to
- -- Set_Digits actually outputs some digits, but we lack a
- -- proof that no such example exists.
-
- -- So it is safer to retain this call, even though as a
- -- result it is hard (or perhaps impossible) to create a
- -- coverage test for the inlined code of the call.
-
- Set_Digits (FD, FD + DA - 1);
-
- else
- Set_Digits (FD, LD);
- Set_Zeroes (DA - ND);
- end if;
- end;
-
- -- At least one digit before point in input
-
- else
- -- Less digits in input than are needed before point
- -- Input: 1PP Output: 100.000
-
- if ND < Digits_Before_Point then
-
- -- Special case, if the input is the single digit 0, then we
- -- do not want 000.000, but instead 0.000.
-
- if ND = 1 and then Digs (FD) = '0' then
- Set_Blanks_And_Sign (Fore - 1);
- Set ('0');
-
- -- Normal case where we need to output scaling zeroes
-
- else
- Set_Blanks_And_Sign (Fore - Digits_Before_Point);
- Set_Digits (FD, LD);
- Set_Zeroes (Digits_Before_Point - ND);
- end if;
-
- -- Set period and zeroes after the period
-
- Set ('.');
- Set_Zeroes (Digits_After_Point);
-
- -- Input has full amount of digits before decimal point
-
- else
- Set_Blanks_And_Sign (Fore - Digits_Before_Point);
- pragma Assert (FD + Digits_Before_Point - 1 >= 0);
- -- In this branch, we have Digits_Before_Point > 0. It is the
- -- else of test (Digits_Before_Point <= 0)
- Set_Digits (FD, FD + Digits_Before_Point - 1);
- Set ('.');
- Set_Digits (FD + Digits_Before_Point, LD);
- Set_Zeroes (Digits_After_Point - (ND - Digits_Before_Point));
- end if;
- end if;
- end if;
- end Set_Decimal_Digits;
-
- -----------------------
- -- Set_Image_Decimal --
- -----------------------
-
- procedure Set_Image_Decimal
- (V : Integer;
- S : in out String;
- P : in out Natural;
- Scale : Integer;
- Fore : Natural;
- Aft : Natural;
- Exp : Natural)
- is
- Digs : String := Integer'Image (V);
- -- Sign and digits of decimal value
-
- begin
- Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp);
- end Set_Image_Decimal;
-
-end System.Img_Dec;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . I M G _ D E C --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Image for decimal fixed types where the size of the corresponding integer
--- type does not exceed Integer'Size (also used for Text_IO.Decimal_IO output)
-
-package System.Img_Dec is
- pragma Pure;
-
- procedure Image_Decimal
- (V : Integer;
- S : in out String;
- P : out Natural;
- Scale : Integer);
- -- Computes fixed_type'Image (V), where V is the integer value (in units of
- -- delta) of a decimal type whose Scale is as given and stores the result
- -- S (1 .. P), updating P to the value of L. The image is given by the
- -- rules in RM 3.5(34) for fixed-point type image functions. The caller
- -- guarantees that S is long enough to hold the result. S need not have a
- -- lower bound of 1.
-
- procedure Set_Image_Decimal
- (V : Integer;
- S : in out String;
- P : in out Natural;
- Scale : Integer;
- Fore : Natural;
- Aft : Natural;
- Exp : Natural);
- -- Sets the image of V, where V is the integer value (in units of delta)
- -- of a decimal type with the given Scale, starting at S (P + 1), updating
- -- P to point to the last character stored, the caller promises that the
- -- buffer is large enough and no check is made for this. Constraint_Error
- -- will not necessarily be raised if this requirement is violated, since
- -- it is perfectly valid to compile this unit with checks off. The Fore,
- -- Aft and Exp values can be set to any valid values for the case of use
- -- by Text_IO.Decimal_IO. Note that there is no leading space stored.
-
- procedure Set_Decimal_Digits
- (Digs : in out String;
- NDigs : Natural;
- S : out String;
- P : in out Natural;
- Scale : Integer;
- Fore : Natural;
- Aft : Natural;
- Exp : Natural);
- -- This procedure has the same semantics as Set_Image_Decimal, except that
- -- the value in Digs (1 .. NDigs) is given as a string of decimal digits
- -- preceded by either a minus sign or a space (i.e. the integer image of
- -- the value in units of delta). The call may destroy the value in Digs,
- -- which is why Digs is in-out (this happens if rounding is required).
- -- Set_Decimal_Digits is shared by all the decimal image routines.
-
-end System.Img_Dec;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . I M G _ L L D --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with System.Img_Dec; use System.Img_Dec;
-
-package body System.Img_LLD is
-
- -----------------------------
- -- Image_Long_Long_Decimal --
- ----------------------------
-
- procedure Image_Long_Long_Decimal
- (V : Long_Long_Integer;
- S : in out String;
- P : out Natural;
- Scale : Integer)
- is
- pragma Assert (S'First = 1);
-
- begin
- -- Add space at start for non-negative numbers
-
- if V >= 0 then
- S (1) := ' ';
- P := 1;
- else
- P := 0;
- end if;
-
- Set_Image_Long_Long_Decimal
- (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
- end Image_Long_Long_Decimal;
-
- ---------------------------------
- -- Set_Image_Long_Long_Decimal --
- ---------------------------------
-
- procedure Set_Image_Long_Long_Decimal
- (V : Long_Long_Integer;
- S : in out String;
- P : in out Natural;
- Scale : Integer;
- Fore : Natural;
- Aft : Natural;
- Exp : Natural)
- is
- Digs : String := Long_Long_Integer'Image (V);
- -- Sign and digits of decimal value
-
- begin
- Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp);
- end Set_Image_Long_Long_Decimal;
-
-end System.Img_LLD;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . I M G _ L L D --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Image for decimal fixed types where the size of the corresponding integer
--- type does exceeds Integer'Size (also used for Text_IO.Decimal_IO output)
-
-package System.Img_LLD is
- pragma Pure;
-
- procedure Image_Long_Long_Decimal
- (V : Long_Long_Integer;
- S : in out String;
- P : out Natural;
- Scale : Integer);
- -- Computes fixed_type'Image (V), where V is the integer value (in units of
- -- delta) of a decimal type whose Scale is as given and store the result in
- -- S (P + 1 .. L), updating P to the value of L. The image is given by the
- -- rules in RM 3.5(34) for fixed-point type image functions. The caller
- -- guarantees that S is long enough to hold the result. S need not have a
- -- lower bound of 1.
-
- procedure Set_Image_Long_Long_Decimal
- (V : Long_Long_Integer;
- S : in out String;
- P : in out Natural;
- Scale : Integer;
- Fore : Natural;
- Aft : Natural;
- Exp : Natural);
- -- Sets the image of V, where V is the integer value (in units of delta)
- -- of a decimal type with the given Scale, starting at S (P + 1), updating
- -- P to point to the last character stored, the caller promises that the
- -- buffer is large enough and no check is made for this. Constraint_Error
- -- will not necessarily be raised if this requirement is violated, since
- -- it is perfectly valid to compile this unit with checks off. The Fore,
- -- Aft and Exp values can be set to any valid values for the case of use
- -- by Text_IO.Decimal_IO. Note that there is no leading space stored.
-
-end System.Img_LLD;
-- in very high precision floating-point output.
-- Note that in the following, the "-2" accounts for the sign and one
- -- extra digits, since we need the maximum number of 9's that can be
- -- supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width
- -- is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits,
- -- but the maximum number of 9's that can be supported is 19.
+ -- extra digit, since we need the maximum number of 9's that can be
+ -- represented, e.g. for the 64-bit case, Long_Long_Unsigned'Width is
+ -- 21, since the maximum value (approx 1.8E+19) has 20 digits, but the
+ -- maximum number of 9's that can be represented is only 19.
Maxdigs : constant :=
Natural'Min
Unsdigs : constant := Unsigned'Width - 2;
-- Number of digits that can be converted using type Unsigned
- -- See above for the explanation of the -2.
Maxscaling : constant := 5000;
-- Max decimal scaling required during conversion of floating-point
-- Decide whether a blank should be prepended before the call to
-- Set_Image_Real. We generate a blank for positive values, and
-- also for positive zeroes. For negative zeroes, we generate a
- -- space only if Signed_Zeroes is True (the RM only permits the
- -- output of -0.0 on targets where this is the case). We can of
- -- course still see a -0.0 on a target where Signed_Zeroes is
- -- False (since this attribute refers to the proper handling of
- -- negative zeroes, not to their existence). We do not generate
+ -- blank only if Signed_Zeros is False (the RM only permits the
+ -- output of -0.0 when Signed_Zeros is True). We do not generate
-- a blank for positive infinity, since we output an explicit +.
if (not Is_Negative (V) and then V <= Long_Long_Float'Last)
Exp : Natural)
is
NFrac : constant Natural := Natural'Max (Aft, 1);
- Sign : Character;
+ Minus : Boolean;
X : Long_Long_Float;
Scale : Integer;
Expon : Integer;
procedure Set_Blanks_And_Sign (N : Integer) is
begin
- if Sign = '-' then
+ if Minus then
for J in 1 .. N - 1 loop
Set (' ');
end loop;
-- Start of processing for Set_Image_Real
begin
- -- We call the floating-point processor reset routine so that we can
- -- be sure the floating-point processor is properly set for conversion
- -- calls. This is notably need on Windows, where calls to the operating
- -- system randomly reset the processor into 64-bit mode.
+ -- We call the floating-point processor reset routine so we can be sure
+ -- that the processor is properly set for conversions. This is notably
+ -- needed on Windows, where calls to the operating system randomly reset
+ -- the processor into 64-bit mode.
System.Float_Control.Reset;
if V > 0.0 then
X := V;
- Sign := '+';
+ Minus := False;
-- Negative values
elsif V < 0.0 then
X := -V;
- Sign := '-';
+ Minus := True;
-- Zero values
elsif V = 0.0 then
if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then
- Sign := '-';
+ Minus := True;
else
- Sign := '+';
+ Minus := False;
end if;
Set_Blanks_And_Sign (Fore - 1);
raise Constraint_Error;
end if;
- -- X and Sign are set here, and X is known to be a valid,
+ -- X and Minus are set here, and X is known to be a valid,
-- non-zero floating-point number.
-- Case of non-zero value with Exp = 0
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ U T I L --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Img_Uns; use System.Img_Uns;
+
+package body System.Img_Util is
+
+ ------------------------
+ -- Set_Decimal_Digits --
+ ------------------------
+
+ procedure Set_Decimal_Digits
+ (Digs : in out String;
+ NDigs : Natural;
+ S : out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ is
+ pragma Assert (NDigs >= 1);
+ pragma Assert (Digs'First = 1);
+ pragma Assert (Digs'First < Digs'Last);
+
+ Minus : constant Boolean := (Digs (Digs'First) = '-');
+ -- Set True if input is negative
+
+ Zero : Boolean := (Digs (Digs'First + 1) = '0');
+ -- Set True if input is exactly zero (only case when a leading zero
+ -- is permitted in the input string given to this procedure). This
+ -- flag can get set later if rounding causes the value to become zero.
+
+ FD : Natural := 2;
+ -- First digit position of digits remaining to be processed
+
+ LD : Natural := NDigs;
+ -- Last digit position of digits remaining to be processed
+
+ ND : Natural := NDigs - 1;
+ -- Number of digits remaining to be processed (LD - FD + 1)
+
+ Digits_Before_Point : Integer := ND - Scale;
+ -- Number of digits before decimal point in the input value. This
+ -- value can be negative if the input value is less than 0.1, so
+ -- it is an indication of the current exponent. Digits_Before_Point
+ -- is adjusted if the rounding step generates an extra digit.
+
+ Digits_After_Point : constant Natural := Integer'Max (1, Aft);
+ -- Digit positions after decimal point in result string
+
+ Expon : Integer;
+ -- Integer value of exponent
+
+ procedure Round (N : Integer);
+ -- Round the number in Digs. N is the position of the last digit to be
+ -- retained in the rounded position (rounding is based on Digs (N + 1)
+ -- FD, LD, ND are reset as necessary if required. Note that if the
+ -- result value rounds up (e.g. 9.99 => 10.0), an extra digit can be
+ -- placed in the sign position as a result of the rounding, this is
+ -- the case in which FD is adjusted. The call to Round has no effect
+ -- if N is outside the range FD .. LD.
+
+ procedure Set (C : Character);
+ pragma Inline (Set);
+ -- Sets character C in output buffer
+
+ procedure Set_Blanks_And_Sign (N : Integer);
+ -- Sets leading blanks and minus sign if needed. N is the number of
+ -- positions to be filled (a minus sign is output even if N is zero
+ -- or negative, but for a positive value, if N is non-positive, then
+ -- the call has no effect).
+
+ procedure Set_Digits (S, E : Natural);
+ pragma Inline (Set_Digits);
+ -- Set digits S through E from Digs, no effect if S > E
+
+ procedure Set_Zeroes (N : Integer);
+ pragma Inline (Set_Zeroes);
+ -- Set N zeroes, no effect if N is negative
+
+ -----------
+ -- Round --
+ -----------
+
+ procedure Round (N : Integer) is
+ D : Character;
+
+ pragma Assert (NDigs >= 1);
+ pragma Assert (Digs'First = 1);
+ pragma Assert (Digs'First < Digs'Last);
+
+ begin
+ -- Nothing to do if rounding past the last digit we have
+
+ if N >= LD then
+ return;
+
+ -- Cases of rounding before the initial digit
+
+ elsif N < FD then
+
+ -- The result is zero, unless we are rounding just before
+ -- the first digit, and the first digit is five or more.
+
+ if N = 1 and then Digs (Digs'First + 1) >= '5' then
+ Digs (Digs'First) := '1';
+ else
+ Digs (Digs'First) := '0';
+ Zero := True;
+ end if;
+
+ Digits_Before_Point := Digits_Before_Point + 1;
+ FD := 1;
+ LD := 1;
+ ND := 1;
+
+ -- Normal case of rounding an existing digit
+
+ else
+ LD := N;
+ pragma Assert (LD >= 1);
+ -- In this case, we have N < LD and N >= FD. FD is a Natural,
+ -- So we can conclude, LD >= 1
+ ND := LD - 1;
+ pragma Assert (N + 1 <= Digs'Last);
+
+ if Digs (N + 1) >= '5' then
+ for J in reverse Digs'First + 1 .. Digs'First + N - 1 loop
+ pragma Assert (Digs (J) in '0' .. '9' | ' ' | '-');
+ -- Because it is a decimal image, we can assume that
+ -- it can only contain these characters.
+ D := Character'Succ (Digs (J));
+
+ if D <= '9' then
+ Digs (J) := D;
+ return;
+ else
+ Digs (J) := '0';
+ end if;
+ end loop;
+
+ -- Here the rounding overflows into the sign position. That's
+ -- OK, because we already captured the value of the sign and
+ -- we are in any case destroying the value in the Digs buffer
+
+ Digs (Digs'First) := '1';
+ FD := 1;
+ ND := ND + 1;
+ Digits_Before_Point := Digits_Before_Point + 1;
+ end if;
+ end if;
+ end Round;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (C : Character) is
+ begin
+ pragma Assert (P >= (S'First - 1) and P < S'Last and
+ P < Natural'Last);
+ -- No check is done as documented in the header : updating P to
+ -- point to the last character stored, the caller promises that the
+ -- buffer is large enough and no check is made for this.
+ -- Constraint_Error will not necessarily be raised if this
+ -- requirement is violated, since it is perfectly valid to compile
+ -- this unit with checks off.
+ P := P + 1;
+ S (P) := C;
+ end Set;
+
+ -------------------------
+ -- Set_Blanks_And_Sign --
+ -------------------------
+
+ procedure Set_Blanks_And_Sign (N : Integer) is
+ begin
+ if Minus then
+ for J in 1 .. N - 1 loop
+ Set (' ');
+ end loop;
+
+ Set ('-');
+
+ else
+ for J in 1 .. N loop
+ Set (' ');
+ end loop;
+ end if;
+ end Set_Blanks_And_Sign;
+
+ ----------------
+ -- Set_Digits --
+ ----------------
+
+ procedure Set_Digits (S, E : Natural) is
+ begin
+ pragma Assert (S >= Digs'First and E <= Digs'Last);
+ -- S and E should be in the Digs array range
+ -- TBC: Analysis should be completed
+ for J in S .. E loop
+ Set (Digs (J));
+ end loop;
+ end Set_Digits;
+
+ ----------------
+ -- Set_Zeroes --
+ ----------------
+
+ procedure Set_Zeroes (N : Integer) is
+ begin
+ for J in 1 .. N loop
+ Set ('0');
+ end loop;
+ end Set_Zeroes;
+
+ -- Start of processing for Set_Decimal_Digits
+
+ begin
+ -- Case of exponent given
+
+ if Exp > 0 then
+ Set_Blanks_And_Sign (Fore - 1);
+ Round (Digits_After_Point + 2);
+
+ Set (Digs (FD));
+ FD := FD + 1;
+ pragma Assert (ND >= 1);
+ ND := ND - 1;
+ Set ('.');
+
+ if ND >= Digits_After_Point then
+ Set_Digits (FD, FD + Digits_After_Point - 1);
+ else
+ Set_Digits (FD, LD);
+ Set_Zeroes (Digits_After_Point - ND);
+ end if;
+
+ -- Calculate exponent. The number of digits before the decimal point
+ -- in the input is Digits_Before_Point, and the number of digits
+ -- before the decimal point in the output is 1, so we can get the
+ -- exponent as the difference between these two values. The one
+ -- exception is for the value zero, which by convention has an
+ -- exponent of +0.
+
+ Expon := (if Zero then 0 else Digits_Before_Point - 1);
+
+ Set ('E');
+ ND := 0;
+
+ if Expon >= 0 then
+ Set ('+');
+ Set_Image_Unsigned (Unsigned (Expon), Digs, ND);
+ else
+ Set ('-');
+ Set_Image_Unsigned (Unsigned (-Expon), Digs, ND);
+ end if;
+
+ Set_Zeroes (Exp - ND - 1);
+ Set_Digits (1, ND);
+ return;
+
+ -- Case of no exponent given. To make these cases clear, we use
+ -- examples. For all the examples, we assume Fore = 2, Aft = 3.
+ -- A P in the example input string is an implied zero position,
+ -- not included in the input string.
+
+ else
+ -- Round at correct position
+ -- Input: 4PP => unchanged
+ -- Input: 400.03 => unchanged
+ -- Input 3.4567 => 3.457
+ -- Input: 9.9999 => 10.000
+ -- Input: 0.PPP5 => 0.001
+ -- Input: 0.PPP4 => 0
+ -- Input: 0.00003 => 0
+
+ Round (LD - (Scale - Digits_After_Point));
+
+ -- No digits before point in input
+ -- Input: .123 Output: 0.123
+ -- Input: .PP3 Output: 0.003
+
+ if Digits_Before_Point <= 0 then
+ Set_Blanks_And_Sign (Fore - 1);
+ Set ('0');
+ Set ('.');
+
+ declare
+ DA : Natural := Digits_After_Point;
+ -- Digits remaining to output after point
+
+ LZ : constant Integer := Integer'Min (DA, -Digits_Before_Point);
+ -- Number of leading zeroes after point. Note: there used to be
+ -- a Max of this result with zero, but that's redundant, since
+ -- we know DA is positive, and because of the test above, we
+ -- know that -Digits_Before_Point >= 0.
+
+ begin
+ Set_Zeroes (LZ);
+ DA := DA - LZ;
+
+ if DA < ND then
+
+ -- Note: it is definitely possible for the above condition
+ -- to be True, for example:
+
+ -- V => 1234, Scale => 5, Fore => 0, After => 1, Exp => 0
+
+ -- but in this case DA = 0, ND = 1, FD = 1, FD + DA-1 = 0
+ -- so the arguments in the call are (1, 0) meaning that no
+ -- digits are output.
+
+ -- No obvious example exists where the following call to
+ -- Set_Digits actually outputs some digits, but we lack a
+ -- proof that no such example exists.
+
+ -- So it is safer to retain this call, even though as a
+ -- result it is hard (or perhaps impossible) to create a
+ -- coverage test for the inlined code of the call.
+
+ Set_Digits (FD, FD + DA - 1);
+
+ else
+ Set_Digits (FD, LD);
+ Set_Zeroes (DA - ND);
+ end if;
+ end;
+
+ -- At least one digit before point in input
+
+ else
+ -- Less digits in input than are needed before point
+ -- Input: 1PP Output: 100.000
+
+ if ND < Digits_Before_Point then
+
+ -- Special case, if the input is the single digit 0, then we
+ -- do not want 000.000, but instead 0.000.
+
+ if ND = 1 and then Digs (FD) = '0' then
+ Set_Blanks_And_Sign (Fore - 1);
+ Set ('0');
+
+ -- Normal case where we need to output scaling zeroes
+
+ else
+ Set_Blanks_And_Sign (Fore - Digits_Before_Point);
+ Set_Digits (FD, LD);
+ Set_Zeroes (Digits_Before_Point - ND);
+ end if;
+
+ -- Set period and zeroes after the period
+
+ Set ('.');
+ Set_Zeroes (Digits_After_Point);
+
+ -- Input has full amount of digits before decimal point
+
+ else
+ Set_Blanks_And_Sign (Fore - Digits_Before_Point);
+ pragma Assert (FD + Digits_Before_Point - 1 >= 0);
+ -- In this branch, we have Digits_Before_Point > 0. It is the
+ -- else of test (Digits_Before_Point <= 0)
+ Set_Digits (FD, FD + Digits_Before_Point - 1);
+ Set ('.');
+ Set_Digits (FD + Digits_Before_Point, LD);
+ Set_Zeroes (Digits_After_Point - (ND - Digits_Before_Point));
+ end if;
+ end if;
+ end if;
+ end Set_Decimal_Digits;
+
+end System.Img_Util;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ U T I L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides some common utilities used by the s-imgxxx files
+
+package System.Img_Util is
+ pragma Pure;
+
+ procedure Set_Decimal_Digits
+ (Digs : in out String;
+ NDigs : Natural;
+ S : out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+ -- Sets the image of Digs (1 .. NDigs), which is a string of decimal digits
+ -- preceded by either a minus sign or a space, i.e. the integer image of
+ -- the value in units of delta of a decimal fixed point type with the given
+ -- Scale, starting at S (P + 1), updating P to point to the last character
+ -- stored, the caller promises that the buffer is large enough and no check
+ -- is made for this. Constraint_Error will not necessarily be raised if the
+ -- requirement is violated since it is perfectly valid to compile this unit
+ -- with checks off. The Fore, Aft and Exp values can be set to any valid
+ -- values for the case of use by Text_IO.Decimal_IO. Note that there is no
+ -- leading space stored. The call may destroy the value in Digs, which is
+ -- why Digs is in-out (this happens if rounding is required).
+
+end System.Img_Util;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ D E C I M A L _ 1 2 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning values for decimal fixed point
+-- types up to 128-bit mantissa, for use in Text_IO.Decimal_IO, and the Value
+-- attribute for such decimal types.
+
+with Interfaces;
+with System.Arith_128;
+with System.Value_D;
+
+package System.Val_Decimal_128 is
+ pragma Preelaborate;
+
+ subtype Int128 is Interfaces.Integer_128;
+ subtype Uns128 is Interfaces.Unsigned_128;
+
+ package Impl is new Value_D (Int128, Uns128, Arith_128.Scaled_Divide128);
+
+ function Scan_Decimal128
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int128
+ renames Impl.Scan_Decimal;
+
+ function Value_Decimal128
+ (Str : String;
+ Scale : Integer) return Int128
+ renames Impl.Value_Decimal;
+
+end System.Val_Decimal_128;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ D E C I M A L _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning values for decimal fixed point
+-- types up to 32-bit mantissa, for use in Text_IO.Decimal_IO, and the Value
+-- attribute for such decimal types.
+
+with Interfaces;
+with System.Arith_32;
+with System.Value_D;
+
+package System.Val_Decimal_32 is
+ pragma Preelaborate;
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Uns32 is Interfaces.Unsigned_32;
+
+ package Impl is new Value_D (Int32, Uns32, Arith_32.Scaled_Divide32);
+
+ function Scan_Decimal32
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int32
+ renames Impl.Scan_Decimal;
+
+ function Value_Decimal32 (Str : String; Scale : Integer) return Int32
+ renames Impl.Value_Decimal;
+
+end System.Val_Decimal_32;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ D E C I M A L _ 6 4 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning values for decimal fixed point
+-- types up to 64-bit mantissa, for use in Text_IO.Decimal_IO, and the Value
+-- attribute for such decimal types.
+
+with Interfaces;
+with System.Arith_64;
+with System.Value_D;
+
+package System.Val_Decimal_64 is
+ pragma Preelaborate;
+
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Uns64 is Interfaces.Unsigned_64;
+
+ package Impl is new Value_D (Int64, Uns64, Arith_64.Scaled_Divide64);
+
+ function Scan_Decimal64
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int64
+ renames Impl.Scan_Decimal;
+
+ function Value_Decimal64
+ (Str : String;
+ Scale : Integer) return Int64
+ renames Impl.Value_Decimal;
+
+end System.Val_Decimal_64;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ F I X E D _ 1 2 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning values for ordinary fixed point
+-- types up to 128-bit small and mantissa, for use in Text_IO.Decimal_IO, and
+-- the Value attribute for such decimal types.
+
+with Interfaces;
+with System.Arith_128;
+with System.Value_F;
+
+package System.Val_Fixed_128 is
+ pragma Preelaborate;
+
+ subtype Int128 is Interfaces.Integer_128;
+ subtype Uns128 is Interfaces.Unsigned_128;
+
+ package Impl is new Value_F (Int128, Uns128, Arith_128.Scaled_Divide128);
+
+ function Scan_Fixed128
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int128;
+ Den : Int128) return Int128
+ renames Impl.Scan_Fixed;
+
+ function Value_Fixed128
+ (Str : String; Num : Int128; Den : Int128) return Int128
+ renames Impl.Value_Fixed;
+
+end System.Val_Fixed_128;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ F I X E D _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning values for decimal fixed point
+-- types up to 32-bit small and mantissa, for use in Text_IO.Decimal_IO, and
+-- the Value attribute for such decimal types.
+
+with Interfaces;
+with System.Arith_32;
+with System.Value_F;
+
+package System.Val_Fixed_32 is
+ pragma Preelaborate;
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Uns32 is Interfaces.Unsigned_32;
+
+ package Impl is new Value_F (Int32, Uns32, Arith_32.Scaled_Divide32);
+
+ function Scan_Fixed32
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int32;
+ Den : Int32) return Int32
+ renames Impl.Scan_Fixed;
+
+ function Value_Fixed32
+ (Str : String; Num : Int32; Den : Int32) return Int32
+ renames Impl.Value_Fixed;
+
+end System.Val_Fixed_32;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ F I X E D _ 6 4 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning values for decimal fixed point
+-- types up to 64-bit small and mantissa, for use in Text_IO.Decimal_IO, and
+-- the Value attribute for such decimal types.
+
+with Interfaces;
+with System.Arith_64;
+with System.Value_F;
+
+package System.Val_Fixed_64 is
+ pragma Preelaborate;
+
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Uns64 is Interfaces.Unsigned_64;
+
+ package Impl is new Value_F (Int64, Uns64, Arith_64.Scaled_Divide64);
+
+ function Scan_Fixed64
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int64;
+ Den : Int64) return Int64
+ renames Impl.Scan_Fixed;
+
+ function Value_Fixed64
+ (Str : String; Num : Int64; Den : Int64) return Int64
+ renames Impl.Value_Fixed;
+
+end System.Val_Fixed_64;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A L _ D E C --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with System.Val_Real; use System.Val_Real;
-
-package body System.Val_Dec is
-
- ------------------
- -- Scan_Decimal --
- ------------------
-
- -- For decimal types where Size < Integer'Size, it is fine to use
- -- the floating-point circuit, since it certainly has sufficient
- -- precision for any reasonable hardware, and we just don't support
- -- things on junk hardware.
-
- function Scan_Decimal
- (Str : String;
- Ptr : not null access Integer;
- Max : Integer;
- Scale : Integer) return Integer
- is
- Val : Long_Long_Float;
- begin
- Val := Scan_Real (Str, Ptr, Max);
- return Integer (Val * 10.0 ** Scale);
- end Scan_Decimal;
-
- -------------------
- -- Value_Decimal --
- -------------------
-
- -- Again, we use the real circuit for this purpose
-
- function Value_Decimal (Str : String; Scale : Integer) return Integer is
- begin
- return Integer (Value_Real (Str) * 10.0 ** Scale);
- end Value_Decimal;
-
-end System.Val_Dec;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A L _ D E C --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains routines for scanning decimal values where the size
--- of the type is no greater than Standard.Integer'Size, for use in Text_IO.
--- Decimal_IO, and the Value attribute for such decimal types.
-
-package System.Val_Dec is
- pragma Preelaborate;
-
- function Scan_Decimal
- (Str : String;
- Ptr : not null access Integer;
- Max : Integer;
- Scale : Integer) return Integer;
- -- This function scans the string starting at Str (Ptr.all) for a valid
- -- real literal according to the syntax described in (RM 3.5(43)). The
- -- substring scanned extends no further than Str (Max). There are three
- -- cases for the return:
- --
- -- If a valid real literal is found after scanning past any initial spaces,
- -- then Ptr.all is updated past the last character of the literal (but
- -- trailing spaces are not scanned out). The value returned is the value
- -- Integer'Integer_Value (decimal-literal-value), using the given Scale
- -- to determine this value.
- --
- -- If no valid real literal is found, then Ptr.all points either to an
- -- initial non-digit character, or to Max + 1 if the field is all spaces
- -- and the exception Constraint_Error is raised.
- --
- -- If a syntactically valid integer is scanned, but the value is out of
- -- range, or, in the based case, the base value is out of range or there
- -- is an out of range digit, then Ptr.all points past the integer, and
- -- Constraint_Error is raised.
- --
- -- Note: these rules correspond to the requirements for leaving the
- -- pointer positioned in Text_Io.Get
- --
- -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
- -- special case of an all-blank string, and Ptr is unchanged, and hence
- -- is greater than Max as required in this case.
-
- function Value_Decimal (Str : String; Scale : Integer) return Integer;
- -- Used in computing X'Value (Str) where X is a decimal fixed-point type
- -- whose size does not exceed Standard.Integer'Size. Str is the string
- -- argument of the attribute. Constraint_Error is raised if the string
- -- is malformed or if the value is out of range of Integer (not the
- -- range of the fixed-point type, that check must be done by the caller.
- -- Otherwise the value returned is the value Integer'Integer_Value
- -- (decimal-literal-value), using Scale to determine this value.
-
-end System.Val_Dec;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A L _ L L D --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with System.Val_Real; use System.Val_Real;
-
-package body System.Val_LLD is
-
- ----------------------------
- -- Scan_Long_Long_Decimal --
- ----------------------------
-
- -- We use the floating-point circuit for now, this will be OK on a PC,
- -- but definitely does NOT have the required precision if the longest
- -- float type is IEEE double. This must be fixed in the future ???
-
- function Scan_Long_Long_Decimal
- (Str : String;
- Ptr : not null access Integer;
- Max : Integer;
- Scale : Integer) return Long_Long_Integer
- is
- Val : Long_Long_Float;
- begin
- Val := Scan_Real (Str, Ptr, Max);
- return Long_Long_Integer (Val * 10.0 ** Scale);
- end Scan_Long_Long_Decimal;
-
- -----------------------------
- -- Value_Long_Long_Decimal --
- -----------------------------
-
- -- Again we cheat and use floating-point ???
-
- function Value_Long_Long_Decimal
- (Str : String;
- Scale : Integer) return Long_Long_Integer
- is
- begin
- return Long_Long_Integer (Value_Real (Str) * 10.0 ** Scale);
- end Value_Long_Long_Decimal;
-
-end System.Val_LLD;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A L _ L L D --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains routines for scanning decimal values where the size
--- of the type is greater than Standard.Integer'Size, for use in Text_IO.
--- Decimal_IO, and the Value attribute for such decimal types.
-
-package System.Val_LLD is
- pragma Preelaborate;
-
- function Scan_Long_Long_Decimal
- (Str : String;
- Ptr : not null access Integer;
- Max : Integer;
- Scale : Integer) return Long_Long_Integer;
- -- This function scans the string starting at Str (Ptr.all) for a valid
- -- real literal according to the syntax described in (RM 3.5(43)). The
- -- substring scanned extends no further than Str (Max). There are three
- -- cases for the return:
- --
- -- If a valid real literal is found after scanning past any initial spaces,
- -- then Ptr.all is updated past the last character of the literal (but
- -- trailing spaces are not scanned out). The value returned is the value
- -- Long_Long_Integer'Integer_Value (decimal-literal-value), using the given
- -- Scale to determine this value.
- --
- -- If no valid real literal is found, then Ptr.all points either to an
- -- initial non-digit character, or to Max + 1 if the field is all spaces
- -- and the exception Constraint_Error is raised.
- --
- -- If a syntactically valid integer is scanned, but the value is out of
- -- range, or, in the based case, the base value is out of range or there
- -- is an out of range digit, then Ptr.all points past the integer, and
- -- Constraint_Error is raised.
- --
- -- Note: these rules correspond to the requirements for leaving the
- -- pointer positioned in Text_Io.Get
- --
- -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
- -- special case of an all-blank string, and Ptr is unchanged, and hence
- -- is greater than Max as required in this case.
-
- function Value_Long_Long_Decimal
- (Str : String;
- Scale : Integer) return Long_Long_Integer;
- -- Used in computing X'Value (Str) where X is a decimal types whose size
- -- exceeds Standard.Integer'Size. Str is the string argument of the
- -- attribute. Constraint_Error is raised if the string is malformed
- -- or if the value is out of range, otherwise the value returned is the
- -- value Long_Long_Integer'Integer_Value (decimal-literal-value), using
- -- the given Scale to determine this value.
-
-end System.Val_LLD;
-- --
------------------------------------------------------------------------------
-with System.Val_Util; use System.Val_Util;
with System.Float_Control;
+with System.Unsigned_Types; use System.Unsigned_Types;
+with System.Val_Util; use System.Val_Util;
+with System.Value_R;
package body System.Val_Real is
- procedure Scan_Integral_Digits
- (Str : String;
- Index : in out Integer;
- Max : Integer;
- Value : out Long_Long_Integer;
- Scale : out Integer;
- Base_Violation : in out Boolean;
- Base : Long_Long_Integer := 10;
- Base_Specified : Boolean := False);
- -- Scan the integral part of a real (i.e: before decimal separator)
- --
- -- The string parsed is Str (Index .. Max), and after the call Index will
- -- point to the first non parsed character.
- --
- -- For each digit parsed either value := value * base + digit, or scale
- -- is incremented by 1.
- --
- -- Base_Violation will be set to True a digit found is not part of the Base
-
- procedure Scan_Decimal_Digits
- (Str : String;
- Index : in out Integer;
- Max : Integer;
- Value : in out Long_Long_Integer;
- Scale : in out Integer;
- Base_Violation : in out Boolean;
- Base : Long_Long_Integer := 10;
- Base_Specified : Boolean := False);
- -- Scan the decimal part of a real (i.e: after decimal separator)
- --
- -- The string parsed is Str (Index .. Max), and after the call Index will
- -- point to the first non parsed character.
- --
- -- For each digit parsed value = value * base + digit and scale is
- -- decremented by 1. If precision limit is reached remaining digits are
- -- still parsed but ignored.
- --
- -- Base_Violation will be set to True a digit found is not part of the Base
-
- subtype Char_As_Digit is Long_Long_Integer range -2 .. 15;
- subtype Valid_Digit is Char_As_Digit range 0 .. Char_As_Digit'Last;
- Underscore : constant Char_As_Digit := -2;
- E_Digit : constant Char_As_Digit := 14;
-
- function As_Digit (C : Character) return Char_As_Digit;
- -- Given a character return the digit it represent. If the character is
- -- not a digit then a negative value is returned, -2 for underscore and
- -- -1 for any other character.
-
- Precision_Limit : constant Long_Long_Integer :=
- 2 ** (Long_Long_Float'Machine_Mantissa - 1) - 1;
- -- This is an upper bound for the number of bits used to represent the
- -- mantissa. Beyond that number, any digits parsed are useless.
-
- --------------
- -- As_Digit --
- --------------
-
- function As_Digit (C : Character) return Char_As_Digit is
- begin
- case C is
- when '0' .. '9' =>
- return Character'Pos (C) - Character'Pos ('0');
- when 'a' .. 'f' =>
- return Character'Pos (C) - (Character'Pos ('a') - 10);
- when 'A' .. 'F' =>
- return Character'Pos (C) - (Character'Pos ('A') - 10);
- when '_' =>
- return Underscore;
- when others =>
- return -1;
- end case;
- end As_Digit;
-
- -------------------------
- -- Scan_Decimal_Digits --
- -------------------------
-
- procedure Scan_Decimal_Digits
- (Str : String;
- Index : in out Integer;
- Max : Integer;
- Value : in out Long_Long_Integer;
- Scale : in out Integer;
- Base_Violation : in out Boolean;
- Base : Long_Long_Integer := 10;
- Base_Specified : Boolean := False)
-
+ package Impl is new Value_R (Long_Long_Unsigned, Floating => True);
+
+ function Integer_to_Real
+ (Str : String;
+ Val : Long_Long_Unsigned;
+ Base : Unsigned;
+ Scale : Integer;
+ Minus : Boolean) return Long_Long_Float;
+ -- Convert the real value from integer to real representation
+
+ ---------------------
+ -- Integer_to_Real --
+ ---------------------
+
+ function Integer_to_Real
+ (Str : String;
+ Val : Long_Long_Unsigned;
+ Base : Unsigned;
+ Scale : Integer;
+ Minus : Boolean) return Long_Long_Float
is
- Precision_Limit_Reached : Boolean := False;
- -- Set to True if addition of a digit will cause Value to be superior
- -- to Precision_Limit.
-
- Digit : Char_As_Digit;
- -- The current digit.
+ pragma Unsuppress (Range_Check);
- Trailing_Zeros : Natural := 0;
- -- Number of trailing zeros at a given point.
+ R_Val : Long_Long_Float;
begin
- pragma Assert (Base in 2 .. 16);
-
- -- If initial Scale is not 0 then it means that Precision_Limit was
- -- reached during integral part scanning.
- if Scale > 0 then
- Precision_Limit_Reached := True;
- end if;
-
- -- The function precondition is that the first character is a valid
- -- digit.
- Digit := As_Digit (Str (Index));
-
- loop
- -- Check if base is correct. If the base is not specified the digit
- -- E or e cannot be considered as a base violation as it can be used
- -- for exponentiation.
- if Digit >= Base then
- if Base_Specified then
- Base_Violation := True;
- elsif Digit = E_Digit then
- return;
- else
- Base_Violation := True;
- end if;
- end if;
-
- -- If precision limit has been reached just ignore any remaining
- -- digits for the computation of Value and Scale. The scanning
- -- should continue only to assess the validity of the string
- if not Precision_Limit_Reached then
- if Digit = 0 then
- -- Trailing '0' digits are ignored unless a non-zero digit is
- -- found.
- Trailing_Zeros := Trailing_Zeros + 1;
- else
-
- -- Handle accumulated zeros.
- for J in 1 .. Trailing_Zeros loop
- if Value > Precision_Limit / Base then
- Precision_Limit_Reached := True;
- exit;
- else
- Value := Value * Base;
- Scale := Scale - 1;
- end if;
- end loop;
-
- -- Reset trailing zero counter
- Trailing_Zeros := 0;
-
- -- Handle current non zero digit
- if Value > (Precision_Limit - Digit) / Base then
- Precision_Limit_Reached := True;
- else
- Value := Value * Base + Digit;
- Scale := Scale - 1;
- end if;
- end if;
- end if;
+ -- We call the floating-point processor reset routine so we can be sure
+ -- that the processor is properly set for conversions. This is notably
+ -- needed on Windows, where calls to the operating system randomly reset
+ -- the processor into 64-bit mode.
- -- Check next character
- Index := Index + 1;
-
- if Index > Max then
- return;
- end if;
-
- Digit := As_Digit (Str (Index));
-
- if Digit < 0 then
- if Digit = Underscore and Index + 1 <= Max then
- -- Underscore is only allowed if followed by a digit
- Digit := As_Digit (Str (Index + 1));
- if Digit in Valid_Digit then
- Index := Index + 1;
- else
- return;
- end if;
- else
- -- Neither a valid underscore nor a digit.
- return;
- end if;
- end if;
- end loop;
- end Scan_Decimal_Digits;
-
- --------------------------
- -- Scan_Integral_Digits --
- --------------------------
-
- procedure Scan_Integral_Digits
- (Str : String;
- Index : in out Integer;
- Max : Integer;
- Value : out Long_Long_Integer;
- Scale : out Integer;
- Base_Violation : in out Boolean;
- Base : Long_Long_Integer := 10;
- Base_Specified : Boolean := False)
- is
- Precision_Limit_Reached : Boolean := False;
- -- Set to True if addition of a digit will cause Value to be superior
- -- to Precision_Limit.
-
- Digit : Char_As_Digit;
- -- The current digit
- begin
-
- -- Initialize Scale and Value
- Value := 0;
- Scale := 0;
-
- -- The function precondition is that the first character is a valid
- -- digit.
- Digit := As_Digit (Str (Index));
-
- loop
- -- Check if base is correct. If the base is not specified the digit
- -- E or e cannot be considered as a base violation as it can be used
- -- for exponentiation.
- if Digit >= Base then
- if Base_Specified then
- Base_Violation := True;
- elsif Digit = E_Digit then
- return;
- else
- Base_Violation := True;
- end if;
- end if;
-
- if Precision_Limit_Reached then
- -- Precision limit has been reached so just update the exponent
- Scale := Scale + 1;
- else
- pragma Assert (Base /= 0);
+ System.Float_Control.Reset;
- if Value > (Precision_Limit - Digit) / Base then
- -- Updating Value will overflow so ignore this digit and any
- -- following ones. Only update the scale
- Precision_Limit_Reached := True;
- Scale := Scale + 1;
- else
- Value := Value * Base + Digit;
- end if;
- end if;
+ -- Compute the final value
- -- Look for the next character
- Index := Index + 1;
- if Index > Max then
- return;
- end if;
+ R_Val := Long_Long_Float (Val) * Long_Long_Float (Base) ** Scale;
- Digit := As_Digit (Str (Index));
+ -- Finally deal with initial minus sign, note that this processing is
+ -- done even if Uval is zero, so that -0.0 is correctly interpreted.
- if Digit not in Valid_Digit then
- -- Next character is not a digit. In that case stop scanning
- -- unless the next chracter is an underscore followed by a digit.
- if Digit = Underscore and Index + 1 <= Max then
- Digit := As_Digit (Str (Index + 1));
- if Digit in Valid_Digit then
- Index := Index + 1;
- else
- return;
- end if;
- else
- return;
- end if;
- end if;
- end loop;
+ return (if Minus then -R_Val else R_Val);
- end Scan_Integral_Digits;
+ exception
+ when Constraint_Error => Bad_Value (Str);
+ end Integer_to_Real;
---------------
-- Scan_Real --
Ptr : not null access Integer;
Max : Integer)
return Long_Long_Float
-
is
- Start : Positive;
- -- Position of starting non-blank character
-
+ Base : Unsigned;
+ Scale : Integer;
+ Extra : Unsigned;
Minus : Boolean;
- -- Set to True if minus sign is present, otherwise to False
-
- Index : Integer;
- -- Local copy of string pointer
-
- Int_Value : Long_Long_Integer := -1;
- -- Mantissa as an Integer
-
- Int_Scale : Integer := 0;
- -- Exponent value
-
- Base_Violation : Boolean := False;
- -- If True some digits where not in the base. The float is still scan
- -- till the end even if an error will be raised.
-
- Uval : Long_Long_Float := 0.0;
- -- Contain the final value at the end of the function
-
- After_Point : Boolean := False;
- -- True if a decimal should be parsed
-
- Base : Long_Long_Integer := 10;
- -- Current base (default: 10)
-
- Base_Char : Character := ASCII.NUL;
- -- Character used to set the base. If Nul this means that default
- -- base is used.
+ Val : Long_Long_Unsigned;
begin
- -- We do not tolerate strings with Str'Last = Positive'Last
-
- if Str'Last = Positive'Last then
- raise Program_Error with
- "string upper bound is Positive'Last, not supported";
- end if;
-
- -- We call the floating-point processor reset routine so that we can
- -- be sure the floating-point processor is properly set for conversion
- -- calls. This is notably need on Windows, where calls to the operating
- -- system randomly reset the processor into 64-bit mode.
-
- System.Float_Control.Reset;
-
- -- Scan the optional sign
- Scan_Sign (Str, Ptr, Max, Minus, Start);
- Index := Ptr.all;
- Ptr.all := Start;
-
- -- First character can be either a decimal digit or a dot.
- if Str (Index) in '0' .. '9' then
- pragma Annotate
- (CodePeer, Intentional,
- "test always true", "defensive code below");
-
- -- If this is a digit it can indicates either the float decimal
- -- part or the base to use
- Scan_Integral_Digits
- (Str,
- Index,
- Max => Max,
- Value => Int_Value,
- Scale => Int_Scale,
- Base_Violation => Base_Violation,
- Base => 10);
- elsif Str (Index) = '.' and then
- -- A dot is only allowed if followed by a digit.
- Index < Max and then
- Str (Index + 1) in '0' .. '9'
- then
- -- Initial point, allowed only if followed by digit (RM 3.5(47))
- After_Point := True;
- Index := Index + 1;
- Int_Value := 0;
- else
- Bad_Value (Str);
- end if;
-
- -- Check if the first number encountered is a base
- if Index < Max and then
- (Str (Index) = '#' or else Str (Index) = ':')
- then
- Base_Char := Str (Index);
- Base := Int_Value;
-
- -- Reset Int_Value to indicate that parsing of integral value should
- -- be done
- Int_Value := -1;
- if Base < 2 or else Base > 16 then
- Base_Violation := True;
- Base := 16;
- end if;
-
- Index := Index + 1;
-
- if Str (Index) = '.' and then
- Index < Max and then
- As_Digit (Str (Index + 1)) in Valid_Digit
- then
- After_Point := True;
- Index := Index + 1;
- Int_Value := 0;
- end if;
- end if;
-
- -- Does scanning of integral part needed
- if Int_Value < 0 then
- if Index > Max or else As_Digit (Str (Index)) not in Valid_Digit then
- Bad_Value (Str);
- end if;
-
- Scan_Integral_Digits
- (Str,
- Index,
- Max => Max,
- Value => Int_Value,
- Scale => Int_Scale,
- Base_Violation => Base_Violation,
- Base => Base,
- Base_Specified => Base_Char /= ASCII.NUL);
- end if;
-
- -- Do we have a dot ?
- if not After_Point and then
- Index <= Max and then
- Str (Index) = '.'
- then
- -- At this stage if After_Point was not set, this means that an
- -- integral part has been found. Thus the dot is valid even if not
- -- followed by a digit.
- if Index < Max and then As_Digit (Str (Index + 1)) in Valid_Digit then
- After_Point := True;
- end if;
-
- Index := Index + 1;
- end if;
-
- if After_Point then
- -- Parse decimal part
- Scan_Decimal_Digits
- (Str,
- Index,
- Max => Max,
- Value => Int_Value,
- Scale => Int_Scale,
- Base_Violation => Base_Violation,
- Base => Base,
- Base_Specified => Base_Char /= ASCII.NUL);
- end if;
-
- -- If an explicit base was specified ensure that the delimiter is found
- if Base_Char /= ASCII.NUL then
- if Index > Max or else Str (Index) /= Base_Char then
- Bad_Value (Str);
- else
- Index := Index + 1;
- end if;
- end if;
-
- -- Compute the final value
- Uval := Long_Long_Float (Int_Value);
-
- -- Update pointer and scan exponent.
- Ptr.all := Index;
-
- Int_Scale := Int_Scale + Scan_Exponent (Str,
- Ptr,
- Max,
- Real => True);
-
- Uval := Uval * Long_Long_Float (Base) ** Int_Scale;
-
- -- Here is where we check for a bad based number
- if Base_Violation then
- Bad_Value (Str);
-
- -- If OK, then deal with initial minus sign, note that this processing
- -- is done even if Uval is zero, so that -0.0 is correctly interpreted.
- else
- if Minus then
- return -Uval;
- else
- return Uval;
- end if;
- end if;
+ Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scale, Extra, Minus);
+ return Integer_to_Real (Str, Val, Base, Scale, Minus);
end Scan_Real;
----------------
----------------
function Value_Real (Str : String) return Long_Long_Float is
- begin
- -- We have to special case Str'Last = Positive'Last because the normal
- -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
- -- deal with this by converting to a subtype which fixes the bounds.
-
- if Str'Last = Positive'Last then
- declare
- subtype NT is String (1 .. Str'Length);
- begin
- return Value_Real (NT (Str));
- end;
+ Base : Unsigned;
+ Scale : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Long_Long_Unsigned;
- -- Normal case where Str'Last < Positive'Last
+ begin
+ Val := Impl.Value_Raw_Real (Str, Base, Scale, Extra, Minus);
- else
- declare
- V : Long_Long_Float;
- P : aliased Integer := Str'First;
- begin
- V := Scan_Real (Str, P'Access, Str'Last);
- Scan_Trailing_Blanks (Str, P);
- return V;
- end;
- end if;
+ return Integer_to_Real (Str, Val, Base, Scale, Minus);
end Value_Real;
end System.Val_Real;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L U E _ D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+with System.Val_Util; use System.Val_Util;
+with System.Value_R;
+
+package body System.Value_D is
+
+ package Impl is new Value_R (Uns, Floating => False);
+
+ function Integer_to_Decimal
+ (Str : String;
+ Val : Uns;
+ Base : Unsigned;
+ ScaleB : Integer;
+ Minus : Boolean;
+ Scale : Integer) return Int;
+ -- Convert the real value from integer to decimal representation
+
+ ------------------------
+ -- Integer_to_Decimal --
+ ------------------------
+
+ function Integer_to_Decimal
+ (Str : String;
+ Val : Uns;
+ Base : Unsigned;
+ ScaleB : Integer;
+ Minus : Boolean;
+ Scale : Integer) return Int
+ is
+ function Safe_Expont
+ (Base : Int;
+ Exp : in out Natural;
+ Factor : Int) return Int;
+ -- Return (Base ** Exp) * Factor if the computation does not overflow,
+ -- or else the number of the form (Base ** K) * Factor with the largest
+ -- magnitude if the former computation overflows. In both cases, Exp is
+ -- updated to contain the remaining power in the computation. Note that
+ -- Factor is expected to be positive in this context.
+
+ function Unsigned_To_Signed (Val : Uns) return Int;
+ -- Convert an integer value from unsigned to signed representation
+
+ -----------------
+ -- Safe_Expont --
+ -----------------
+
+ function Safe_Expont
+ (Base : Int;
+ Exp : in out Natural;
+ Factor : Int) return Int
+ is
+ pragma Assert (Base /= 0 and then Factor > 0);
+
+ Max : constant Int := Int'Last / Base;
+
+ Result : Int := Factor;
+
+ begin
+ while Exp > 0 and then Result <= Max loop
+ Result := Result * Base;
+ Exp := Exp - 1;
+ end loop;
+
+ return Result;
+ end Safe_Expont;
+
+ ------------------------
+ -- Unsigned_To_Signed --
+ ------------------------
+
+ function Unsigned_To_Signed (Val : Uns) return Int is
+ begin
+ -- Deal with overflow cases, and also with largest negative number
+
+ if Val > Uns (Int'Last) then
+ if Minus and then Val = Uns (-(Int'First)) then
+ return Int'First;
+ else
+ Bad_Value (Str);
+ end if;
+
+ -- Negative values
+
+ elsif Minus then
+ return -(Int (Val));
+
+ -- Positive values
+
+ else
+ return Int (Val);
+ end if;
+ end Unsigned_To_Signed;
+
+ begin
+ -- If the base of the value is 10 or its scaling factor is zero, then
+ -- add the scales (they are defined in the opposite sense) and apply
+ -- the result to the value, checking for overflow in the process.
+
+ if Base = 10 or else ScaleB = 0 then
+ declare
+ S : Integer := ScaleB + Scale;
+ V : Uns := Val;
+
+ begin
+ while S < 0 loop
+ V := V / 10;
+ S := S + 1;
+ end loop;
+
+ while S > 0 loop
+ if V <= Uns'Last / 10 then
+ V := V * 10;
+ S := S - 1;
+ else
+ Bad_Value (Str);
+ end if;
+ end loop;
+
+ return Unsigned_To_Signed (V);
+ end;
+
+ -- If the base of the value is not 10, use a scaled divide operation
+ -- to compute Val * (Base ** ScaleB) * (10 ** Scale).
+
+ else
+ declare
+ B : constant Int := Int (Base);
+ S : constant Integer := ScaleB;
+
+ V : Uns := Val;
+
+ Y, Z, Q, R : Int;
+
+ begin
+ -- If S is too negative, then drop trailing digits
+
+ if S < 0 then
+ declare
+ LS : Integer := -S;
+
+ begin
+ Y := 10 ** Integer'Max (0, Scale);
+ Z := Safe_Expont (B, LS, 10 ** Integer'Max (0, -Scale));
+
+ for J in 1 .. LS loop
+ V := V / Uns (B);
+ end loop;
+ end;
+
+ -- If S is too positive, then scale V up, which may then overflow
+
+ elsif S > 0 then
+ declare
+ LS : Integer := S;
+
+ begin
+ Y := Safe_Expont (B, LS, 10 ** Integer'Max (0, Scale));
+ Z := 10 ** Integer'Max (0, -Scale);
+
+ for J in 1 .. LS loop
+ if V <= Uns'Last / Uns (B) then
+ V := V * Uns (B);
+ else
+ Bad_Value (Str);
+ end if;
+ end loop;
+ end;
+
+ -- The case S equal to zero should have been handled earlier
+
+ else
+ raise Program_Error;
+ end if;
+
+ -- Perform a scale divide operation with rounding to match 'Image
+
+ Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q, R, Round => True);
+
+ return Q;
+ end;
+ end if;
+
+ exception
+ when Constraint_Error => Bad_Value (Str);
+ end Integer_to_Decimal;
+
+ ------------------
+ -- Scan_Decimal --
+ ------------------
+
+ function Scan_Decimal
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int
+ is
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Uns;
+
+ begin
+ Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus);
+
+ return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale);
+ end Scan_Decimal;
+
+ -------------------
+ -- Value_Decimal --
+ -------------------
+
+ function Value_Decimal (Str : String; Scale : Integer) return Int is
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Uns;
+
+ begin
+ Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus);
+
+ return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale);
+ end Value_Decimal;
+
+end System.Value_D;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L U E _ D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Value attribute for
+-- decimal fixed point types, and also for conversion operations required in
+-- Text_IO.Decimal_IO for such types.
+
+generic
+
+ type Int is range <>;
+
+ type Uns is mod <>;
+
+ with procedure Scaled_Divide
+ (X, Y, Z : Int;
+ Q, R : out Int;
+ Round : Boolean);
+
+package System.Value_D is
+ pragma Preelaborate;
+
+ function Scan_Decimal
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int;
+ -- This function scans the string starting at Str (Ptr.all) for a valid
+ -- real literal according to the syntax described in (RM 3.5(43)). The
+ -- substring scanned extends no further than Str (Max). There are three
+ -- cases for the return:
+ --
+ -- If a valid real literal is found after scanning past any initial spaces,
+ -- then Ptr.all is updated past the last character of the literal (but
+ -- trailing spaces are not scanned out). The value returned is the value
+ -- Int'Integer_Value (decimal-literal-value), using the given Scale to
+ -- determine this value.
+ --
+ -- If no valid real literal is found, then Ptr.all points either to an
+ -- initial non-digit character, or to Max + 1 if the field is all spaces
+ -- and the exception Constraint_Error is raised.
+ --
+ -- If a syntactically valid integer is scanned, but the value is out of
+ -- range, or, in the based case, the base value is out of range or there
+ -- is an out of range digit, then Ptr.all points past the integer, and
+ -- Constraint_Error is raised.
+ --
+ -- Note: these rules correspond to the requirements for leaving the
+ -- pointer positioned in Text_Io.Get
+ --
+ -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
+ -- special case of an all-blank string, and Ptr is unchanged, and hence
+ -- is greater than Max as required in this case.
+
+ function Value_Decimal (Str : String; Scale : Integer) return Int;
+ -- Used in computing X'Value (Str) where X is a decimal fixed-point type.
+ -- Str is the string argument of the attribute. Constraint_Error is raised
+ -- if the string is malformed or if the value is out of range of Int (not
+ -- the range of the fixed-point type, which must be done by the caller).
+ -- Otherwise the value returned is the value Int'Integer_Value
+ -- (decimal-literal-value), using Scale to determine this value.
+
+end System.Value_D;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L U E _ F --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+with System.Val_Util; use System.Val_Util;
+with System.Value_R;
+
+package body System.Value_F is
+
+ package Impl is new Value_R (Uns, Floating => False);
+
+ function Integer_To_Fixed
+ (Str : String;
+ Val : Uns;
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Num : Int;
+ Den : Int) return Int;
+ -- Convert the real value from integer to fixed point representation
+
+ -- The goal is to compute Val * (Base ** ScaleB) / (Num / Den) with correct
+ -- rounding for all decimal values output by Typ'Image, that is to say up
+ -- to Typ'Aft decimal digits. Unlike for the output, the RM does not say
+ -- what the rounding must be for the input, but a reasonable exegesis of
+ -- the intent is that Typ'Value o Typ'Image should be the identity, which
+ -- is made possible because 'Aft is defined such that 'Image is injective.
+
+ -- For a type with a mantissa of M bits including the sign, the number N1
+ -- of decimal digits required to represent all the numbers is given by:
+
+ -- N1 = ceil ((M - 1) * log 2 / log 10) [N1 = 10/19/39 for M = 32/64/128]
+
+ -- but this mantissa can represent any set of contiguous numbers with only
+ -- N2 different decimal digits where:
+
+ -- N2 = floor ((M - 1) * log 2 / log 10) [N2 = 9/18/38 for M = 32/64/128]
+
+ -- Of course N1 = N2 + 1 holds, which means both that Val may not contain
+ -- enough significant bits to represent all the values of the type and that
+ -- 1 extra decimal digit contains the information for the missing bits.
+
+ -- Therefore the actual computation to be performed is
+
+ -- V = (Val * Base + Extra) * (Base ** (ScaleB - 1)) / (Num / Den)
+
+ -- using two steps of scaled divide if Extra is non-zero
+
+ -- (1) Val * ((Base ** ScaleB) * Den) = Q1 * Num + R1
+
+ -- (2) Extra * ((Base ** ScaleB) * Den) = Q2 * (-Base) + R2
+
+ -- which yields after dividing (1) by Num and (2) by Num * Base and summing
+
+ -- V = Q1 + (R1 - Q2) / Num + R2 / (Num * Base)
+
+ -- but we get rid of the third term by using a rounding divide for (2).
+
+ ----------------------
+ -- Integer_To_Fixed --
+ ----------------------
+
+ function Integer_To_Fixed
+ (Str : String;
+ Val : Uns;
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Num : Int;
+ Den : Int) return Int
+ is
+ pragma Assert (Base in 2 .. 16);
+
+ pragma Assert (Extra < Base);
+ -- Accept only one extra digit after those used for Val
+
+ pragma Assert (Num < 0 and then Den < 0);
+ -- Accept only negative numbers to allow -2**(Int'Size - 1)
+
+ function Safe_Expont
+ (Base : Int;
+ Exp : in out Natural;
+ Factor : Int) return Int;
+ -- Return (Base ** Exp) * Factor if the computation does not overflow,
+ -- or else the number of the form (Base ** K) * Factor with the largest
+ -- magnitude if the former computation overflows. In both cases, Exp is
+ -- updated to contain the remaining power in the computation. Note that
+ -- Factor is expected to be negative in this context.
+
+ function Unsigned_To_Signed (Val : Uns) return Int;
+ -- Convert an integer value from unsigned to signed representation
+
+ -----------------
+ -- Safe_Expont --
+ -----------------
+
+ function Safe_Expont
+ (Base : Int;
+ Exp : in out Natural;
+ Factor : Int) return Int
+ is
+ pragma Assert (Base /= 0 and then Factor < 0);
+
+ Min : constant Int := Int'First / Base;
+
+ Result : Int := Factor;
+
+ begin
+ while Exp > 0 and then Result >= Min loop
+ Result := Result * Base;
+ Exp := Exp - 1;
+ end loop;
+
+ return Result;
+ end Safe_Expont;
+
+ ------------------------
+ -- Unsigned_To_Signed --
+ ------------------------
+
+ function Unsigned_To_Signed (Val : Uns) return Int is
+ begin
+ -- Deal with overflow cases, and also with largest negative number
+
+ if Val > Uns (Int'Last) then
+ if Minus and then Val = Uns (-(Int'First)) then
+ return Int'First;
+ else
+ Bad_Value (Str);
+ end if;
+
+ -- Negative values
+
+ elsif Minus then
+ return -(Int (Val));
+
+ -- Positive values
+
+ else
+ return Int (Val);
+ end if;
+ end Unsigned_To_Signed;
+
+ -- Local variables
+
+ B : constant Int := Int (Base);
+
+ V : Uns := Val;
+ S : Integer := ScaleB;
+ E : Uns := Uns (Extra);
+ N : Int := Num;
+ D : Int := Den;
+
+ Y, Z, Q1, R1, Q2, R2 : Int;
+
+ begin
+ -- We will use a scaled divide operation for which we must control the
+ -- magnitude of operands so that an overflow exception is not unduly
+ -- raised during the computation. The only real concern is the exponent
+ -- ScaleB so first try to reduce its magnitude in an exact manner.
+
+ while S < 0 and then (D rem B) = 0 loop
+ D := D / B;
+ S := S + 1;
+ end loop;
+
+ while S > 0 and then (N rem B) = 0 loop
+ N := N / B;
+ S := S - 1;
+ end loop;
+
+ -- If S is still too negative, then drop trailing digits, but preserve
+ -- the last dropped digit.
+
+ if S < 0 then
+ declare
+ LS : Integer := -S;
+
+ begin
+ Y := D;
+ Z := Safe_Expont (B, LS, N);
+
+ for J in 1 .. LS loop
+ E := V rem Uns (B);
+ V := V / Uns (B);
+ end loop;
+ end;
+
+ -- If S is still too positive, then scale V up, which may then overflow
+
+ elsif S > 0 then
+ declare
+ LS : Integer := S;
+
+ begin
+ Y := Safe_Expont (B, LS, D);
+ Z := N;
+
+ for J in 1 .. LS loop
+ if V <= Uns'Last / Uns (B) then
+ V := V * Uns (B);
+ else
+ Bad_Value (Str);
+ end if;
+ end loop;
+ end;
+
+ -- If S is zero, then proceed directly
+
+ else
+ Y := D;
+ Z := N;
+ end if;
+
+ -- Perform a scaled divide operation with final rounding to match Image
+ -- using two steps if there is an extra digit available. The second and
+ -- third operands are always negative so the sign of the quotient is the
+ -- sign of the first operand and the sign of the remainder the opposite.
+
+ if E /= 0 then
+ Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q1, R1, Round => False);
+ Scaled_Divide (Unsigned_To_Signed (E), Y, -B, Q2, R2, Round => True);
+
+ -- Avoid an overflow during the subtraction. Note that Q2 is smaller
+ -- than Y and R1 smaller than Z in magnitude, so it is safe to take
+ -- their absolute value.
+
+ if abs Q2 >= 2 ** (Int'Size - 2)
+ or else abs R1 >= 2 ** (Int'Size - 2)
+ then
+ declare
+ Bit : constant Int := Q2 rem 2;
+
+ begin
+ Q2 := (Q2 - Bit) / 2;
+ R1 := (R1 - Bit) / 2;
+ Y := -2;
+ end;
+
+ else
+ Y := -1;
+ end if;
+
+ Scaled_Divide (Q2 - R1, Y, Z, Q2, R2, Round => True);
+
+ return Q1 + Q2;
+
+ else
+ Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q1, R1, Round => True);
+
+ return Q1;
+ end if;
+
+ exception
+ when Constraint_Error => Bad_Value (Str);
+ end Integer_To_Fixed;
+
+ ----------------
+ -- Scan_Fixed --
+ ----------------
+
+ function Scan_Fixed
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Uns;
+
+ begin
+ Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus);
+
+ return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den);
+ end Scan_Fixed;
+
+ -----------------
+ -- Value_Fixed --
+ -----------------
+
+ function Value_Fixed
+ (Str : String;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Uns;
+
+ begin
+ Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus);
+
+ return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den);
+ end Value_Fixed;
+
+end System.Value_F;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L U E _ F --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Value attribute for
+-- ordinary fixed point types, and also for conversion operations required in
+-- Text_IO.Fixed_IO for such types.
+
+generic
+
+ type Int is range <>;
+
+ type Uns is mod <>;
+
+ with procedure Scaled_Divide
+ (X, Y, Z : Int;
+ Q, R : out Int;
+ Round : Boolean);
+
+package System.Value_F is
+ pragma Preelaborate;
+
+ function Scan_Fixed
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int;
+ Den : Int) return Int;
+ -- This function scans the string starting at Str (Ptr.all) for a valid
+ -- real literal according to the syntax described in (RM 3.5(43)). The
+ -- substring scanned extends no further than Str (Max). There are three
+ -- cases for the return:
+ --
+ -- If a valid real literal is found after scanning past any initial spaces,
+ -- then Ptr.all is updated past the last character of the literal (but
+ -- trailing spaces are not scanned out). The value returned is the value
+ -- Int'Integer_Value (decimal-literal-value), using the given Num/Den to
+ -- determine this value.
+ --
+ -- If no valid real literal is found, then Ptr.all points either to an
+ -- initial non-digit character, or to Max + 1 if the field is all spaces
+ -- and the exception Constraint_Error is raised.
+ --
+ -- If a syntactically valid integer is scanned, but the value is out of
+ -- range, or, in the based case, the base value is out of range or there
+ -- is an out of range digit, then Ptr.all points past the integer, and
+ -- Constraint_Error is raised.
+ --
+ -- Note: these rules correspond to the requirements for leaving the
+ -- pointer positioned in Text_Io.Get
+ --
+ -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
+ -- special case of an all-blank string, and Ptr is unchanged, and hence
+ -- is greater than Max as required in this case.
+
+ function Value_Fixed
+ (Str : String;
+ Num : Int;
+ Den : Int) return Int;
+ -- Used in computing X'Value (Str) where X is an ordinary fixed-point type.
+ -- Str is the string argument of the attribute. Constraint_Error is raised
+ -- if the string is malformed or if the value is out of range of Int (not
+ -- the range of the fixed-point type, which must be done by the caller).
+ -- Otherwise the value returned is the value Int'Integer_Value
+ -- (decimal-literal-value), using Small Num/Den to determine this value.
+
+end System.Value_F;
Uval := Scan_Raw_Unsigned (Str, Ptr, Max);
- -- Deal with overflow cases, and also with maximum negative number
+ -- Deal with overflow cases, and also with largest negative number
if Uval > Uns (Int'Last) then
if Minus and then Uval = Uns (-(Int'First)) then
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L U E _ R --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Val_Util; use System.Val_Util;
+
+package body System.Value_R is
+
+ F_Limit : constant Uns := 2 ** (Long_Long_Float'Machine_Mantissa - 1);
+ I_Limit : constant Uns := 2 ** (Uns'Size - 1);
+ -- Absolute value of largest representable signed integer
+
+ Precision_Limit : constant Uns := (if Floating then F_Limit else I_Limit);
+ -- Limit beyond which additional digits are dropped
+
+ subtype Char_As_Digit is Unsigned range 0 .. 17;
+ subtype Valid_Digit is Char_As_Digit range 0 .. 15;
+ E_Digit : constant Char_As_Digit := 14;
+ Underscore : constant Char_As_Digit := 16;
+ Not_A_Digit : constant Char_As_Digit := 17;
+
+ function As_Digit (C : Character) return Char_As_Digit;
+ -- Given a character return the digit it represents
+
+ procedure Scan_Decimal_Digits
+ (Str : String;
+ Index : in out Integer;
+ Max : Integer;
+ Value : in out Uns;
+ Scale : in out Integer;
+ Extra : in out Char_As_Digit;
+ Base_Violation : in out Boolean;
+ Base : Unsigned;
+ Base_Specified : Boolean);
+ -- Scan the decimal part of a real (i.e. after decimal separator)
+ --
+ -- The string parsed is Str (Index .. Max) and after the call Index will
+ -- point to the first non-parsed character.
+ --
+ -- For each digit parsed, Value = Value * Base + Digit and Scale is
+ -- decremented by 1. If precision limit is reached, remaining digits are
+ -- still parsed but ignored, except for the first which is stored in Extra.
+ --
+ -- Base_Violation is set to True if a digit found is not part of the Base
+ --
+ -- If Base_Specified is set, then the base was specified in the real
+
+ procedure Scan_Integral_Digits
+ (Str : String;
+ Index : in out Integer;
+ Max : Integer;
+ Value : out Uns;
+ Scale : out Integer;
+ Extra : out Char_As_Digit;
+ Base_Violation : in out Boolean;
+ Base : Unsigned;
+ Base_Specified : Boolean);
+ -- Scan the integral part of a real (i.e. before decimal separator)
+ --
+ -- The string parsed is Str (Index .. Max) and after the call Index will
+ -- point to the first non-parsed character.
+ --
+ -- For each digit parsed, either Value := Value * Base + Digit or Scale
+ -- is incremented by 1 if precision limit is reached, in which case the
+ -- remaining digits are still parsed but ignored, except for the first
+ -- which is stored in Extra.
+ --
+ -- Base_Violation is set to True if a digit found is not part of the Base
+ --
+ -- If Base_Specified is set, then the base was specified in the real
+
+ --------------
+ -- As_Digit --
+ --------------
+
+ function As_Digit (C : Character) return Char_As_Digit is
+ begin
+ case C is
+ when '0' .. '9' =>
+ return Character'Pos (C) - Character'Pos ('0');
+ when 'a' .. 'f' =>
+ return Character'Pos (C) - (Character'Pos ('a') - 10);
+ when 'A' .. 'F' =>
+ return Character'Pos (C) - (Character'Pos ('A') - 10);
+ when '_' =>
+ return Underscore;
+ when others =>
+ return Not_A_Digit;
+ end case;
+ end As_Digit;
+
+ -------------------------
+ -- Scan_Decimal_Digits --
+ -------------------------
+
+ procedure Scan_Decimal_Digits
+ (Str : String;
+ Index : in out Integer;
+ Max : Integer;
+ Value : in out Uns;
+ Scale : in out Integer;
+ Extra : in out Char_As_Digit;
+ Base_Violation : in out Boolean;
+ Base : Unsigned;
+ Base_Specified : Boolean)
+
+ is
+ pragma Assert (Base in 2 .. 16);
+
+ Umax : constant Uns := (Precision_Limit - Uns (Base) + 1) / Uns (Base);
+ -- Max value which cannot overflow on accumulating next digit
+
+ UmaxB : constant Uns := Precision_Limit / Uns (Base);
+ -- Numbers bigger than UmaxB overflow if multiplied by base
+
+ Precision_Limit_Reached : Boolean := False;
+ -- Set to True if addition of a digit will cause Value to be superior
+ -- to Precision_Limit.
+
+ Digit : Char_As_Digit;
+ -- The current digit
+
+ Temp : Uns;
+ -- Temporary
+
+ Trailing_Zeros : Natural := 0;
+ -- Number of trailing zeros at a given point
+
+ begin
+ -- If initial Scale is not 0 then it means that Precision_Limit was
+ -- reached during scanning of the integral part.
+
+ if Scale > 0 then
+ Precision_Limit_Reached := True;
+ else
+ Extra := 0;
+ end if;
+
+ -- The function precondition is that the first character is a valid
+ -- digit.
+
+ Digit := As_Digit (Str (Index));
+
+ loop
+ -- Check if base is correct. If the base is not specified, the digit
+ -- E or e cannot be considered as a base violation as it can be used
+ -- for exponentiation.
+
+ if Digit >= Base then
+ if Base_Specified then
+ Base_Violation := True;
+ elsif Digit = E_Digit then
+ return;
+ else
+ Base_Violation := True;
+ end if;
+ end if;
+
+ -- If precision limit has been reached, just ignore any remaining
+ -- digits for the computation of Value and Scale, but store the
+ -- first in Extra. The scanning should continue only to assess the
+ -- validity of the string.
+
+ if not Precision_Limit_Reached then
+
+ -- Trailing '0' digits are ignored until a non-zero digit is found
+
+ if Digit = 0 then
+ Trailing_Zeros := Trailing_Zeros + 1;
+
+ else
+ -- Handle accumulated zeros.
+
+ for J in 1 .. Trailing_Zeros loop
+ if Value <= UmaxB then
+ Value := Value * Uns (Base);
+ Scale := Scale - 1;
+
+ else
+ Precision_Limit_Reached := True;
+ exit;
+ end if;
+ end loop;
+
+ -- Reset trailing zero counter
+
+ Trailing_Zeros := 0;
+
+ -- Handle current non zero digit
+
+ Temp := Value * Uns (Base) + Uns (Digit);
+
+ if Value <= Umax
+ or else (Value <= UmaxB and then Temp <= Precision_Limit)
+ then
+ Value := Temp;
+ Scale := Scale - 1;
+
+ else
+ Extra := Digit;
+ Precision_Limit_Reached := True;
+ end if;
+ end if;
+ end if;
+
+ -- Check next character
+
+ Index := Index + 1;
+
+ if Index > Max then
+ return;
+ end if;
+
+ Digit := As_Digit (Str (Index));
+
+ if Digit not in Valid_Digit then
+
+ -- Underscore is only allowed if followed by a digit
+
+ if Digit = Underscore and Index + 1 <= Max then
+
+ Digit := As_Digit (Str (Index + 1));
+ if Digit in Valid_Digit then
+ Index := Index + 1;
+ else
+ return;
+ end if;
+
+ -- Neither a valid underscore nor a digit
+
+ else
+ return;
+ end if;
+ end if;
+ end loop;
+ end Scan_Decimal_Digits;
+
+ --------------------------
+ -- Scan_Integral_Digits --
+ --------------------------
+
+ procedure Scan_Integral_Digits
+ (Str : String;
+ Index : in out Integer;
+ Max : Integer;
+ Value : out Uns;
+ Scale : out Integer;
+ Extra : out Char_As_Digit;
+ Base_Violation : in out Boolean;
+ Base : Unsigned;
+ Base_Specified : Boolean)
+ is
+ pragma Assert (Base in 2 .. 16);
+
+ Umax : constant Uns := (Precision_Limit - Uns (Base) + 1) / Uns (Base);
+ -- Max value which cannot overflow on accumulating next digit
+
+ UmaxB : constant Uns := Precision_Limit / Uns (Base);
+ -- Numbers bigger than UmaxB overflow if multiplied by base
+
+ Precision_Limit_Reached : Boolean := False;
+ -- Set to True if addition of a digit will cause Value to be superior
+ -- to Precision_Limit.
+
+ Digit : Char_As_Digit;
+ -- The current digit
+
+ Temp : Uns;
+ -- Temporary
+
+ begin
+ -- Initialize Value, Scale and Extra
+
+ Value := 0;
+ Scale := 0;
+ Extra := 0;
+
+ -- The function precondition is that the first character is a valid
+ -- digit.
+
+ Digit := As_Digit (Str (Index));
+
+ loop
+ -- Check if base is correct. If the base is not specified, the digit
+ -- E or e cannot be considered as a base violation as it can be used
+ -- for exponentiation.
+
+ if Digit >= Base then
+ if Base_Specified then
+ Base_Violation := True;
+ elsif Digit = E_Digit then
+ return;
+ else
+ Base_Violation := True;
+ end if;
+ end if;
+
+ -- If precision limit has been reached, just ignore any remaining
+ -- digits for the computation of Value, but update Scale and store
+ -- the first in Extra. The scanning should continue only to assess
+ -- the validity of the string.
+
+ if Precision_Limit_Reached then
+ Scale := Scale + 1;
+
+ else
+ Temp := Value * Uns (Base) + Uns (Digit);
+
+ if Value <= Umax
+ or else (Value <= UmaxB and then Temp <= Precision_Limit)
+ then
+ Value := Temp;
+
+ else
+ Extra := Digit;
+ Precision_Limit_Reached := True;
+ Scale := Scale + 1;
+ end if;
+ end if;
+
+ -- Look for the next character
+
+ Index := Index + 1;
+ if Index > Max then
+ return;
+ end if;
+
+ Digit := As_Digit (Str (Index));
+
+ if Digit not in Valid_Digit then
+
+ -- Next character is not a digit. In that case stop scanning
+ -- unless the next chracter is an underscore followed by a digit.
+
+ if Digit = Underscore and Index + 1 <= Max then
+ Digit := As_Digit (Str (Index + 1));
+ if Digit in Valid_Digit then
+ Index := Index + 1;
+ else
+ return;
+ end if;
+ else
+ return;
+ end if;
+ end if;
+ end loop;
+
+ end Scan_Integral_Digits;
+
+ -------------------
+ -- Scan_Raw_Real --
+ -------------------
+
+ function Scan_Raw_Real
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Base : out Unsigned;
+ Scale : out Integer;
+ Extra : out Unsigned;
+ Minus : out Boolean) return Uns
+ is
+ After_Point : Boolean;
+ -- True if a decimal should be parsed
+
+ Base_Char : Character := ASCII.NUL;
+ -- Character used to set the base. If Nul this means that default
+ -- base is used.
+
+ Base_Violation : Boolean := False;
+ -- If True some digits where not in the base. The real is still scanned
+ -- till the end even if an error will be raised.
+
+ Index : Integer;
+ -- Local copy of string pointer
+
+ Start : Positive;
+ -- Position of starting non-blank character
+
+ Value : Uns;
+ -- Mantissa as an Integer
+
+ begin
+ -- The default base is 10
+
+ Base := 10;
+
+ -- We do not tolerate strings with Str'Last = Positive'Last
+
+ if Str'Last = Positive'Last then
+ raise Program_Error with
+ "string upper bound is Positive'Last, not supported";
+ end if;
+
+ -- Scan the optional sign
+
+ Scan_Sign (Str, Ptr, Max, Minus, Start);
+ Index := Ptr.all;
+ Ptr.all := Start;
+
+ -- First character can be either a decimal digit or a dot
+
+ if Str (Index) in '0' .. '9' then
+ After_Point := False;
+
+ pragma Annotate
+ (CodePeer, Intentional, "test always true", "defensive code below");
+
+ -- If this is a digit it can indicates either the float decimal
+ -- part or the base to use.
+
+ Scan_Integral_Digits
+ (Str, Index, Max, Value, Scale, Char_As_Digit (Extra),
+ Base_Violation, Base, Base_Specified => False);
+
+ -- A dot is allowed only if followed by a digit (RM 3.5(47))
+
+ elsif Str (Index) = '.'
+ and then Index < Max
+ and then Str (Index + 1) in '0' .. '9'
+ then
+ After_Point := True;
+ Index := Index + 1;
+ Value := 0;
+ Scale := 0;
+ Extra := 0;
+
+ else
+ Bad_Value (Str);
+ end if;
+
+ -- Check if the first number encountered is a base
+
+ if Index < Max
+ and then (Str (Index) = '#' or else Str (Index) = ':')
+ then
+ Base_Char := Str (Index);
+ Base := Unsigned (Value);
+
+ if Base < 2 or else Base > 16 then
+ Base_Violation := True;
+ Base := 16;
+ end if;
+
+ Index := Index + 1;
+
+ if Str (Index) = '.'
+ and then Index < Max
+ and then As_Digit (Str (Index + 1)) in Valid_Digit
+ then
+ After_Point := True;
+ Index := Index + 1;
+ Value := 0;
+ end if;
+ end if;
+
+ -- Scan the integral part if still necessary
+
+ if Base_Char /= ASCII.NUL and then not After_Point then
+ if Index > Max or else As_Digit (Str (Index)) not in Valid_Digit then
+ Bad_Value (Str);
+ end if;
+
+ Scan_Integral_Digits
+ (Str, Index, Max, Value, Scale, Char_As_Digit (Extra),
+ Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL);
+ end if;
+
+ -- Do we have a dot?
+
+ if not After_Point and then Index <= Max and then Str (Index) = '.' then
+
+ -- At this stage if After_Point was not set, this means that an
+ -- integral part has been found. Thus the dot is valid even if not
+ -- followed by a digit.
+
+ if Index < Max and then As_Digit (Str (Index + 1)) in Valid_Digit then
+ After_Point := True;
+ end if;
+
+ Index := Index + 1;
+ end if;
+
+ -- Scan the decimal part
+
+ if After_Point then
+ Scan_Decimal_Digits
+ (Str, Index, Max, Value, Scale, Char_As_Digit (Extra),
+ Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL);
+ end if;
+
+ -- If an explicit base was specified ensure that the delimiter is found
+
+ if Base_Char /= ASCII.NUL then
+ if Index > Max or else Str (Index) /= Base_Char then
+ Bad_Value (Str);
+ else
+ Index := Index + 1;
+ end if;
+ end if;
+
+ -- Update pointer and scan exponent
+
+ Ptr.all := Index;
+ Scale := Scale + Scan_Exponent (Str, Ptr, Max, Real => True);
+
+ -- Here is where we check for a bad based number
+
+ if Base_Violation then
+ Bad_Value (Str);
+ else
+ return Value;
+ end if;
+
+ end Scan_Raw_Real;
+
+ --------------------
+ -- Value_Raw_Real --
+ --------------------
+
+ function Value_Raw_Real
+ (Str : String;
+ Base : out Unsigned;
+ Scale : out Integer;
+ Extra : out Unsigned;
+ Minus : out Boolean) return Uns
+ is
+ begin
+ -- We have to special case Str'Last = Positive'Last because the normal
+ -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
+ -- deal with this by converting to a subtype which fixes the bounds.
+
+ if Str'Last = Positive'Last then
+ declare
+ subtype NT is String (1 .. Str'Length);
+ begin
+ return Value_Raw_Real (NT (Str), Base, Scale, Extra, Minus);
+ end;
+
+ -- Normal case where Str'Last < Positive'Last
+
+ else
+ declare
+ V : Uns;
+ P : aliased Integer := Str'First;
+ begin
+ V := Scan_Raw_Real
+ (Str, P'Access, Str'Last, Base, Scale, Extra, Minus);
+ Scan_Trailing_Blanks (Str, P);
+ return V;
+ end;
+ end if;
+ end Value_Raw_Real;
+
+end System.Value_R;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L U E _ R --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning real values for use in
+-- Text_IO.Decimal_IO, Fixed_IO, Float_IO and the Value attribute.
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+
+generic
+
+ type Uns is mod <>;
+
+ Floating : Boolean;
+
+package System.Value_R is
+ pragma Preelaborate;
+
+ function Scan_Raw_Real
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Base : out Unsigned;
+ Scale : out Integer;
+ Extra : out Unsigned;
+ Minus : out Boolean) return Uns;
+ -- This function scans the string starting at Str (Ptr.all) for a valid
+ -- real literal according to the syntax described in (RM 3.5(43)). The
+ -- substring scanned extends no further than Str (Max). There are three
+ -- cases for the return:
+ --
+ -- If a valid real is found after scanning past any initial spaces, then
+ -- Ptr.all is updated past the last character of the real (but trailing
+ -- spaces are not scanned out) and the Base, Scale, Extra and Minus out
+ -- parameters are set; if Val is the result of the call, then the real
+ -- represented by the literal is equal to
+ --
+ -- (Val * Base + Extra) * (Base ** (Scale - 1))
+ --
+ -- with the negative sign if Minus is true.
+ --
+ -- If no valid real is found, then Ptr.all points either to an initial
+ -- non-blank character, or to Max + 1 if the field is all spaces and the
+ -- exception Constraint_Error is raised.
+ --
+ -- If a syntactically valid real is scanned, but the value is out of
+ -- range, or, in the based case, the base value is out of range or there
+ -- is an out of range digit, then Ptr.all points past the real literal,
+ -- and Constraint_Error is raised.
+ --
+ -- Note: these rules correspond to the requirements for leaving the
+ -- pointer positioned in Text_Io.Get
+ --
+ -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
+ -- special case of an all-blank string, and Ptr is unchanged, and hence
+ -- is greater than Max as required in this case.
+ --
+ -- Note: this routine should not be called with Str'Last = Positive'Last.
+ -- If this occurs Program_Error is raised with a message noting that this
+ -- case is not supported. Most such cases are eliminated by the caller.
+
+ function Value_Raw_Real
+ (Str : String;
+ Base : out Unsigned;
+ Scale : out Integer;
+ Extra : out Unsigned;
+ Minus : out Boolean) return Uns;
+ -- Used in computing X'Value (Str) where X is a real type. Str is the
+ -- string argument of the attribute. Constraint_Error is raised if the
+ -- string is malformed.
+
+end System.Value_R;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 1024.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
System_Fat_VAX_G_Float,
System_Finalization_Masters,
System_Finalization_Root,
- System_Fore,
+ System_Fore_Decimal_32,
+ System_Fore_Decimal_64,
+ System_Fore_Decimal_128,
+ System_Fore_Fixed_32,
+ System_Fore_Fixed_64,
+ System_Fore_Fixed_128,
+ System_Fore_Real,
System_Img_Bool,
System_Img_Char,
- System_Img_Dec,
+ System_Img_Decimal_32,
+ System_Img_Decimal_64,
+ System_Img_Decimal_128,
System_Img_Enum,
System_Img_Enum_New,
+ System_Img_Fixed_32,
+ System_Img_Fixed_64,
+ System_Img_Fixed_128,
System_Img_Int,
- System_Img_LLD,
System_Img_LLI,
System_Img_LLLI,
System_Img_LLU,
System_Unsigned_Types,
System_Val_Bool,
System_Val_Char,
- System_Val_Dec,
+ System_Val_Decimal_32,
+ System_Val_Decimal_64,
+ System_Val_Decimal_128,
System_Val_Enum,
+ System_Val_Fixed_32,
+ System_Val_Fixed_64,
+ System_Val_Fixed_128,
System_Val_Int,
- System_Val_LLD,
System_Val_LLI,
System_Val_LLLI,
System_Val_LLU,
RE_Subtract_With_Ovflo_Check64, -- System.Arith_64
RE_Add_With_Ovflo_Check128, -- System.Arith_128
+ RE_Double_Divide128, -- System.Arith_128
RE_Multiply_With_Ovflo_Check128, -- System.Arith_128
RE_Subtract_With_Ovflo_Check128, -- System.Arith_128
+ RE_Scaled_Divide128, -- System.Arith_128
RE_Create_AST_Handler, -- System.AST_Handling
RE_Root_Controlled, -- System.Finalization_Root
RE_Root_Controlled_Ptr, -- System.Finalization_Root
- RE_Fore, -- System.Fore
+ RE_Fore_Decimal32, -- System.Fore_Decimal_32
+
+ RE_Fore_Decimal64, -- System.Fore_Decimal_64
+
+ RE_Fore_Decimal128, -- System.Fore_Decimal_128
+
+ RE_Fore_Fixed32, -- System.Fore_Fixed_32
+
+ RE_Fore_Fixed64, -- System.Fore_Fixed_64
+
+ RE_Fore_Fixed128, -- System.Fore_Fixed_128
+
+ RE_Fore_Real, -- System.Fore_Real
RE_Image_Boolean, -- System.Img_Bool
RE_Image_Character, -- System.Img_Char
RE_Image_Character_05, -- System.Img_Char
- RE_Image_Decimal, -- System.Img_Dec
+ RE_Image_Decimal32, -- System.Img_Decimal_32
+
+ RE_Image_Decimal64, -- System.Img_Decimal_64
+
+ RE_Image_Decimal128, -- System.Img_Decimal_128
RE_Image_Enumeration_8, -- System.Img_Enum_New
RE_Image_Enumeration_16, -- System.Img_Enum_New
RE_Image_Integer, -- System.Img_Int
- RE_Image_Long_Long_Decimal, -- System.Img_LLD
-
RE_Image_Long_Long_Integer, -- System.Img_LLI
RE_Image_Long_Long_Long_Integer, -- System.Img_LLLI
RE_Image_Long_Long_Long_Unsigned, -- System.Img_LLLU
+ RE_Image_Fixed32, -- System.Img_Fixed_32
+ RE_Image_Fixed64, -- System.Img_Fixed_64
+ RE_Image_Fixed128, -- System.Img_Fixed_128
+
RE_Image_Ordinary_Fixed_Point, -- System.Img_Real
RE_Image_Floating_Point, -- System.Img_Real
RE_Value_Character, -- System.Val_Char
- RE_Value_Decimal, -- System.Val_Dec
+ RE_Value_Decimal32, -- System_Val_Decimal_32
+
+ RE_Value_Decimal64, -- System_Val_Decimal_64
+
+ RE_Value_Decimal128, -- System_Val_Decimal_128
RE_Value_Enumeration_8, -- System.Val_Enum
RE_Value_Enumeration_16, -- System.Val_Enum
RE_Value_Enumeration_32, -- System.Val_Enum
- RE_Value_Integer, -- System.Val_Int
+ RE_Value_Fixed32, -- System_Val_Fixed_32
+
+ RE_Value_Fixed64, -- System_Val_Fixed_64
- RE_Value_Long_Long_Decimal, -- System.Val_LLD
+ RE_Value_Fixed128, -- System_Val_Fixed_128
+
+ RE_Value_Integer, -- System.Val_Int
RE_Value_Long_Long_Integer, -- System.Val_LLI
RE_Subtract_With_Ovflo_Check64 => System_Arith_64,
RE_Add_With_Ovflo_Check128 => System_Arith_128,
+ RE_Double_Divide128 => System_Arith_128,
RE_Multiply_With_Ovflo_Check128 => System_Arith_128,
RE_Subtract_With_Ovflo_Check128 => System_Arith_128,
+ RE_Scaled_Divide128 => System_Arith_128,
RE_Create_AST_Handler => System_AST_Handling,
RE_Root_Controlled => System_Finalization_Root,
RE_Root_Controlled_Ptr => System_Finalization_Root,
- RE_Fore => System_Fore,
+ RE_Fore_Decimal32 => System_Fore_Decimal_32,
+
+ RE_Fore_Decimal64 => System_Fore_Decimal_64,
+
+ RE_Fore_Decimal128 => System_Fore_Decimal_128,
+
+ RE_Fore_Fixed32 => System_Fore_Fixed_32,
+
+ RE_Fore_Fixed64 => System_Fore_Fixed_64,
+
+ RE_Fore_Fixed128 => System_Fore_Fixed_128,
+
+ RE_Fore_Real => System_Fore_Real,
RE_Image_Boolean => System_Img_Bool,
RE_Image_Character => System_Img_Char,
RE_Image_Character_05 => System_Img_Char,
- RE_Image_Decimal => System_Img_Dec,
+ RE_Image_Decimal32 => System_Img_Decimal_32,
+
+ RE_Image_Decimal64 => System_Img_Decimal_64,
+
+ RE_Image_Decimal128 => System_Img_Decimal_128,
RE_Image_Enumeration_8 => System_Img_Enum_New,
RE_Image_Enumeration_16 => System_Img_Enum_New,
RE_Image_Integer => System_Img_Int,
- RE_Image_Long_Long_Decimal => System_Img_LLD,
-
RE_Image_Long_Long_Integer => System_Img_LLI,
RE_Image_Long_Long_Long_Integer => System_Img_LLLI,
RE_Image_Long_Long_Long_Unsigned => System_Img_LLLU,
+ RE_Image_Fixed32 => System_Img_Fixed_32,
+ RE_Image_Fixed64 => System_Img_Fixed_64,
+ RE_Image_Fixed128 => System_Img_Fixed_128,
+
RE_Image_Ordinary_Fixed_Point => System_Img_Real,
RE_Image_Floating_Point => System_Img_Real,
RE_Value_Character => System_Val_Char,
- RE_Value_Decimal => System_Val_Dec,
+ RE_Value_Decimal32 => System_Val_Decimal_32,
+
+ RE_Value_Decimal64 => System_Val_Decimal_64,
+
+ RE_Value_Decimal128 => System_Val_Decimal_128,
RE_Value_Enumeration_8 => System_Val_Enum,
RE_Value_Enumeration_16 => System_Val_Enum,
RE_Value_Enumeration_32 => System_Val_Enum,
- RE_Value_Integer => System_Val_Int,
+ RE_Value_Fixed32 => System_Val_Fixed_32,
+
+ RE_Value_Fixed64 => System_Val_Fixed_64,
- RE_Value_Long_Long_Decimal => System_Val_LLD,
+ RE_Value_Fixed128 => System_Val_Fixed_128,
+
+ RE_Value_Integer => System_Val_Int,
RE_Value_Long_Long_Integer => System_Val_LLI,
Loc : constant Source_Ptr := Sloc (Def);
Digs_Expr : constant Node_Id := Digits_Expression (Def);
Delta_Expr : constant Node_Id := Delta_Expression (Def);
+ Max_Digits : constant Nat :=
+ (if System_Max_Integer_Size = 128 then 38 else 18);
+ -- Maximum number of digits that can be represented in an integer
+
Implicit_Base : Entity_Id;
Digs_Val : Uint;
Delta_Val : Ureal;
Scale_Val := Scale_Val + 1;
end loop;
- if Scale_Val > 18 then
- Error_Msg_N ("scale exceeds maximum value of 18", Def);
- Scale_Val := UI_From_Int (+18);
+ if Scale_Val > Max_Digits then
+ Error_Msg_Uint_1 := UI_From_Int (Max_Digits);
+ Error_Msg_N ("scale exceeds maximum value of ^", Def);
+ Scale_Val := UI_From_Int (Max_Digits);
end if;
else
Scale_Val := Scale_Val - 1;
end loop;
- if Scale_Val < -18 then
- Error_Msg_N ("scale is less than minimum value of -18", Def);
- Scale_Val := UI_From_Int (-18);
+ if Scale_Val < -Max_Digits then
+ Error_Msg_Uint_1 := UI_From_Int (-Max_Digits);
+ Error_Msg_N ("scale is less than minimum value of ^", Def);
+ Scale_Val := UI_From_Int (-Max_Digits);
end if;
end if;
Check_Digits_Expression (Digs_Expr);
Digs_Val := Expr_Value (Digs_Expr);
- if Digs_Val > 18 then
- Digs_Val := UI_From_Int (+18);
- Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr);
+ if Digs_Val > Max_Digits then
+ Error_Msg_Uint_1 := UI_From_Int (Max_Digits);
+ Error_Msg_N ("digits value out of range, maximum is ^", Digs_Expr);
+ Digs_Val := UI_From_Int (Max_Digits);
end if;
Set_Digits_Value (Implicit_Base, Digs_Val);
-- universal integer and universal real, it is never used for runtime
-- calculations).
- Standard_Integer_8 : Entity_Id;
- Standard_Integer_16 : Entity_Id;
- Standard_Integer_32 : Entity_Id;
- Standard_Integer_64 : Entity_Id;
+ Standard_Integer_8 : Entity_Id;
+ Standard_Integer_16 : Entity_Id;
+ Standard_Integer_32 : Entity_Id;
+ Standard_Integer_64 : Entity_Id;
+ Standard_Integer_128 : Entity_Id;
-- These are signed integer types with the indicated sizes. Used for the
-- underlying implementation types for fixed-point and enumeration types.
Uint_15 : constant Uint;
Uint_16 : constant Uint;
Uint_24 : constant Uint;
+ Uint_31 : constant Uint;
Uint_32 : constant Uint;
Uint_63 : constant Uint;
Uint_64 : constant Uint;
Uint_Minus_8 : constant Uint;
Uint_Minus_9 : constant Uint;
Uint_Minus_12 : constant Uint;
+ Uint_Minus_18 : constant Uint;
+ Uint_Minus_31 : constant Uint;
Uint_Minus_36 : constant Uint;
Uint_Minus_63 : constant Uint;
+ Uint_Minus_76 : constant Uint;
Uint_Minus_80 : constant Uint;
+ Uint_Minus_127 : constant Uint;
Uint_Minus_128 : constant Uint;
type UI_Vector is array (Pos range <>) of Int;
Uint_15 : constant Uint := Uint (Uint_Direct_Bias + 15);
Uint_16 : constant Uint := Uint (Uint_Direct_Bias + 16);
Uint_24 : constant Uint := Uint (Uint_Direct_Bias + 24);
+ Uint_31 : constant Uint := Uint (Uint_Direct_Bias + 31);
Uint_32 : constant Uint := Uint (Uint_Direct_Bias + 32);
Uint_63 : constant Uint := Uint (Uint_Direct_Bias + 63);
Uint_64 : constant Uint := Uint (Uint_Direct_Bias + 64);
Uint_Minus_8 : constant Uint := Uint (Uint_Direct_Bias - 8);
Uint_Minus_9 : constant Uint := Uint (Uint_Direct_Bias - 9);
Uint_Minus_12 : constant Uint := Uint (Uint_Direct_Bias - 12);
+ Uint_Minus_18 : constant Uint := Uint (Uint_Direct_Bias - 18);
+ Uint_Minus_31 : constant Uint := Uint (Uint_Direct_Bias - 31);
Uint_Minus_36 : constant Uint := Uint (Uint_Direct_Bias - 36);
Uint_Minus_63 : constant Uint := Uint (Uint_Direct_Bias - 63);
+ Uint_Minus_76 : constant Uint := Uint (Uint_Direct_Bias - 76);
Uint_Minus_80 : constant Uint := Uint (Uint_Direct_Bias - 80);
+ Uint_Minus_127 : constant Uint := Uint (Uint_Direct_Bias - 127);
Uint_Minus_128 : constant Uint := Uint (Uint_Direct_Bias - 128);
Uint_Max_Simple_Mul : constant := Uint_Direct_Bias + 2**15;
-- The following universal reals are the values returned by the constant
-- functions. They are initialized by the initialization procedure.
- UR_0 : Ureal;
- UR_M_0 : Ureal;
- UR_Tenth : Ureal;
- UR_Half : Ureal;
- UR_1 : Ureal;
- UR_2 : Ureal;
- UR_10 : Ureal;
- UR_10_36 : Ureal;
- UR_M_10_36 : Ureal;
- UR_100 : Ureal;
- UR_2_128 : Ureal;
- UR_2_80 : Ureal;
- UR_2_M_128 : Ureal;
- UR_2_M_80 : Ureal;
+ UR_0 : Ureal;
+ UR_M_0 : Ureal;
+ UR_Tenth : Ureal;
+ UR_Half : Ureal;
+ UR_1 : Ureal;
+ UR_2 : Ureal;
+ UR_10 : Ureal;
+ UR_2_10_18 : Ureal;
+ UR_9_10_36 : Ureal;
+ UR_10_76 : Ureal;
+ UR_M_2_10_18 : Ureal;
+ UR_M_9_10_36 : Ureal;
+ UR_M_10_76 : Ureal;
+ UR_100 : Ureal;
+ UR_2_127 : Ureal;
+ UR_2_128 : Ureal;
+ UR_2_31 : Ureal;
+ UR_2_63 : Ureal;
+ UR_2_80 : Ureal;
+ UR_2_M_127 : Ureal;
+ UR_2_M_128 : Ureal;
+ UR_2_M_80 : Ureal;
Normalized_Real : Ureal := No_Ureal;
-- Used to memoize Norm_Num and Norm_Den, if either of these functions
procedure Initialize is
begin
Ureals.Init;
- UR_0 := UR_From_Components (Uint_0, Uint_1, 0, False);
- UR_M_0 := UR_From_Components (Uint_0, Uint_1, 0, True);
- UR_Half := UR_From_Components (Uint_1, Uint_1, 2, False);
- UR_Tenth := UR_From_Components (Uint_1, Uint_1, 10, False);
- UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False);
- UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False);
- UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False);
- UR_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, False);
- UR_M_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, True);
- UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False);
- UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False);
- UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False);
- UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False);
- UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False);
+ UR_0 := UR_From_Components (Uint_0, Uint_1, 0, False);
+ UR_M_0 := UR_From_Components (Uint_0, Uint_1, 0, True);
+ UR_Half := UR_From_Components (Uint_1, Uint_1, 2, False);
+ UR_Tenth := UR_From_Components (Uint_1, Uint_1, 10, False);
+ UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False);
+ UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False);
+ UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False);
+ UR_2_10_18 := UR_From_Components (Uint_2, Uint_Minus_18, 10, False);
+ UR_9_10_36 := UR_From_Components (Uint_9, Uint_Minus_36, 10, False);
+ UR_10_76 := UR_From_Components (Uint_1, Uint_Minus_76, 10, False);
+ UR_M_2_10_18 := UR_From_Components (Uint_2, Uint_Minus_18, 10, True);
+ UR_M_9_10_36 := UR_From_Components (Uint_9, Uint_Minus_36, 10, True);
+ UR_M_10_76 := UR_From_Components (Uint_1, Uint_Minus_76, 10, True);
+ UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False);
+ UR_2_127 := UR_From_Components (Uint_1, Uint_Minus_127, 2, False);
+ UR_2_M_127 := UR_From_Components (Uint_1, Uint_127, 2, False);
+ UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False);
+ UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False);
+ UR_2_31 := UR_From_Components (Uint_1, Uint_Minus_31, 2, False);
+ UR_2_63 := UR_From_Components (Uint_1, Uint_Minus_63, 2, False);
+ UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False);
+ UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False);
end Initialize;
----------------
UI_Write (Int (UI_Image_Length - 1) - Val.Den, Decimal);
end if;
- -- Constants in a base other than 10 can still be easily written in
- -- normal Ada literal style if the numerator is one.
-
- elsif Val.Rbase /= 0 and then Val.Num = 1 then
- Write_Int (Val.Rbase);
- Write_Str ("#1.0#E");
- UI_Write (-Val.Den);
-
-- Other constants with a base other than 10 are written using one of
-- the following forms, depending on the sign of the number and the
-- sign of the exponent (= minus denominator value). See that we are
return UR_100;
end Ureal_100;
+ -------------------
+ -- Ureal_2_10_18 --
+ -------------------
+
+ function Ureal_2_10_18 return Ureal is
+ begin
+ return UR_2_10_18;
+ end Ureal_2_10_18;
+
+ -------------------
+ -- Ureal_9_10_36 --
+ -------------------
+
+ function Ureal_9_10_36 return Ureal is
+ begin
+ return UR_9_10_36;
+ end Ureal_9_10_36;
+
-----------------
- -- Ureal_10_36 --
+ -- Ureal_10_76 --
-----------------
- function Ureal_10_36 return Ureal is
+ function Ureal_10_76 return Ureal is
+ begin
+ return UR_10_76;
+ end Ureal_10_76;
+
+ ----------------
+ -- Ureal_2_31 --
+ ----------------
+
+ function Ureal_2_31 return Ureal is
+ begin
+ return UR_2_31;
+ end Ureal_2_31;
+
+ ----------------
+ -- Ureal_2_63 --
+ ----------------
+
+ function Ureal_2_63 return Ureal is
begin
- return UR_10_36;
- end Ureal_10_36;
+ return UR_2_63;
+ end Ureal_2_63;
----------------
-- Ureal_2_80 --
return UR_2_80;
end Ureal_2_80;
+ -----------------
+ -- Ureal_2_127 --
+ -----------------
+
+ function Ureal_2_127 return Ureal is
+ begin
+ return UR_2_127;
+ end Ureal_2_127;
+
-----------------
-- Ureal_2_128 --
-----------------
return UR_2_M_80;
end Ureal_2_M_80;
+ -------------------
+ -- Ureal_2_M_127 --
+ -------------------
+
+ function Ureal_2_M_127 return Ureal is
+ begin
+ return UR_2_M_127;
+ end Ureal_2_M_127;
+
-------------------
-- Ureal_2_M_128 --
-------------------
return UR_M_0;
end Ureal_M_0;
+ ---------------------
+ -- Ureal_M_2_10_18 --
+ ---------------------
+
+ function Ureal_M_2_10_18 return Ureal is
+ begin
+ return UR_M_2_10_18;
+ end Ureal_M_2_10_18;
+
+ ---------------------
+ -- Ureal_M_9_10_36 --
+ ---------------------
+
+ function Ureal_M_9_10_36 return Ureal is
+ begin
+ return UR_M_9_10_36;
+ end Ureal_M_9_10_36;
+
-------------------
- -- Ureal_M_10_36 --
+ -- Ureal_M_10_76 --
-------------------
- function Ureal_M_10_36 return Ureal is
+ function Ureal_M_10_76 return Ureal is
begin
- return UR_M_10_36;
- end Ureal_M_10_36;
+ return UR_M_10_76;
+ end Ureal_M_10_76;
-----------------
-- Ureal_Tenth --
function Ureal_100 return Ureal;
-- Returns value 100.0
+ function Ureal_2_31 return Ureal;
+ -- Returns value 2.0 ** 31
+
+ function Ureal_2_63 return Ureal;
+ -- Returns value 2.0 ** 63
+
function Ureal_2_80 return Ureal;
-- Returns value 2.0 ** 80
function Ureal_2_M_80 return Ureal;
-- Returns value 2.0 ** (-80)
+ function Ureal_2_127 return Ureal;
+ -- Returns value 2.0 ** 127
+
+ function Ureal_2_M_127 return Ureal;
+ -- Returns value 2.0 ** (-127)
+
function Ureal_2_128 return Ureal;
-- Returns value 2.0 ** 128
function Ureal_2_M_128 return Ureal;
-- Returns value 2.0 ** (-128)
- function Ureal_10_36 return Ureal;
- -- Returns value 10.0 ** 36
+ function Ureal_2_10_18 return Ureal;
+ -- Returns value 2.0 * 10.0 ** 18
+
+ function Ureal_M_2_10_18 return Ureal;
+ -- Returns value -2.0 * 10.0 ** 18
+
+ function Ureal_9_10_36 return Ureal;
+ -- Returns value 9.0 * 10.0 ** 36
+
+ function Ureal_M_9_10_36 return Ureal;
+ -- Returns value -9.0 * 10.0 ** 36
+
+ function Ureal_10_76 return Ureal;
+ -- Returns value 10.0 ** 76
- function Ureal_M_10_36 return Ureal;
- -- Returns value -10.0 ** 36
+ function Ureal_M_10_76 return Ureal;
+ -- Returns value -10.0 ** 76
-----------------
-- Subprograms --
-- { dg-do run }
with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Strings.Fixed; use Ada.Strings.Fixed;
procedure Multfixed is
Z : constant := 4387648782261400837.0;
raise Program_Error;
exception
when Exc : Constraint_Error =>
- if Exception_Message (Exc) /= "System.Arith_64.Impl.Raise_Error: Double arithmetic overflow" then
+ if Count (Exception_Message (Exc), "overflow") = 0 then
raise Program_Error;
end if;
end Multfixed;
projects / gcc.git / commitdiff