-------------------------------------------------------------------------------- ---- GNAT RUN-TIME COMPONENTS ---- ---- S Y S T E M . I M G _ R E A L ---- ---- B o d y ---- ---- Copyright (C) 1992-2011, 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. ---- ---- ---- ---- ---- ---- 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. ---- --------------------------------------------------------------------------------withSystem.Img_LLU;useSystem.Img_LLU;withSystem.Img_Uns;useSystem.Img_Uns;withSystem.Powten_Table;useSystem.Powten_Table;withSystem.Unsigned_Types;useSystem.Unsigned_Types;withSystem.Float_Control;packagebodySystem.Img_Realis-- The following defines the maximum number of digits that we can convert-- accurately. This is limited by the precision of Long_Long_Float, and-- also by the number of digits we can hold in Long_Long_Unsigned, which-- is the integer type we use as an intermediate for the result.-- We assume that in practice, the limitation will come from the digits-- value, rather than the integer value. This is true for typical IEEE-- implementations, and at worst, the only loss is for some precision-- 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.Maxdigs :constant:= Natural'Min (Long_Long_Unsigned'Width - 2, Long_Long_Float'Digits); 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-- numbers to decimal. This is used to defend against infinite-- looping in the conversion, as can be caused by erroneous executions.-- The largest exponent used on any current system is 2**16383, which-- is approximately 10**4932, and the highest number of decimal digits-- is about 35 for 128-bit floating-point formats, so 5000 leaves-- enough room for scaling such valuesfunctionIs_Negative (V : Long_Long_Float)returnBoolean;pragmaImport (Intrinsic, Is_Negative);---------------------------- Image_Floating_Point ----------------------------procedureImage_Floating_Point (V : Long_Long_Float; S :inoutString; P :outNatural; Digs : Natural)ispragmaAssert (S'First = 1);begin-- 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).ifnotIs_Negative (V)orelse(notLong_Long_Float'Signed_ZerosandthenV = -0.0)thenS (1) := ' '; P := 1;elseP := 0;endif; Set_Image_Real (V, S, P, 1, Digs - 1, 3);endImage_Floating_Point;---------------------------------- Image_Ordinary_Fixed_Point ----------------------------------procedureImage_Ordinary_Fixed_Point (V : Long_Long_Float; S :inoutString; P :outNatural; Aft : Natural)ispragmaAssert (S'First = 1);begin-- Output space at start if non-negativeifV >= 0.0thenS (1) := ' '; P := 1;elseP := 0;endif; Set_Image_Real (V, S, P, 1, Aft, 0);endImage_Ordinary_Fixed_Point;---------------------- Set_Image_Real ----------------------procedureSet_Image_Real (V : Long_Long_Float; S :outString; P :inoutNatural; Fore : Natural; Aft : Natural; Exp : Natural)isNFrac :constantNatural := Natural'Max (Aft, 1); Sign : Character; X :aliasedLong_Long_Float;-- This is declared aliased because the expansion of X'Valid passes-- X by access and JGNAT requires all access parameters to be aliased.-- The Valid attribute probably needs to be handled via a different-- expansion for JGNAT, and this use of aliased should be removed-- once Valid is handled properly. ???Scale : Integer; Expon : Integer; Field_Max :constant:= 255;-- This should be the same value as Ada.[Wide_]Text_IO.Field'Last.-- It is not worth dragging in Ada.Text_IO to pick up this value,-- since it really should never be necessary to change it!Digs : String (1 .. 2 * Field_Max + 16);-- Array used to hold digits of converted integer value. This is a-- large enough buffer to accommodate ludicrous values of Fore and Aft.Ndigs : Natural;-- Number of digits stored in Digs (and also subscript of last digit)procedureAdjust_Scale (S : Natural);-- Adjusts the value in X by multiplying or dividing by a power of-- ten so that it is in the range 10**(S-1) <= X < 10**S. Includes-- adding 0.5 to round the result, readjusting if the rounding causes-- the result to wander out of the range. Scale is adjusted to reflect-- the power of ten used to divide the result (i.e. one is added to-- the scale value for each division by 10.0, or one is subtracted-- for each multiplication by 10.0).procedureConvert_Integer;-- Takes the value in X, outputs integer digits into Digs. On return,-- Ndigs is set to the number of digits stored. The digits are stored-- in Digs (1 .. Ndigs),procedureSet (C : Character);-- Sets character C in output bufferprocedureSet_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).procedureSet_Digs (S, E : Natural);-- Set digits S through E from Digs buffer. No effect if S > EprocedureSet_Special_Fill (N : Natural);-- After outputting +Inf, -Inf or NaN, this routine fills out the-- rest of the field with * characters. The argument is the number-- of characters output so far (either 3 or 4)procedureSet_Zeros (N : Integer);-- Set N zeros, no effect if N is negativepragmaInline (Set);pragmaInline (Set_Digs);pragmaInline (Set_Zeros);-------------------- Adjust_Scale --------------------procedureAdjust_Scale (S : Natural)isLo : Natural; Hi : Natural; Mid : Natural; XP : Long_Long_Float;begin-- Cases where scaling up is requiredifX < Powten (S - 1)then-- What we are looking for is a power of ten to multiply X by-- so that the result lies within the required range.loopXP := X * Powten (Maxpow);exitwhenXP >= Powten (S - 1)orelseScale < -Maxscaling; X := XP; Scale := Scale - Maxpow;endloop;-- The following exception is only raised in case of erroneous-- execution, where a number was considered valid but still-- fails to scale up. One situation where this can happen is-- when a system which is supposed to be IEEE-compliant, but-- has been reconfigured to flush denormals to zero.ifScale < -MaxscalingthenraiseConstraint_Error;endif;-- Here we know that we must multiply by at least 10**1 and that-- 10**Maxpow takes us too far: binary search to find right one.-- Because of roundoff errors, it is possible for the value-- of XP to be just outside of the interval when Lo >= Hi. In-- that case we adjust explicitly by a factor of 10. This-- can only happen with a value that is very close to an-- exact power of 10.Lo := 1; Hi := Maxpow;loopMid := (Lo + Hi) / 2; XP := X * Powten (Mid);ifXP < Powten (S - 1)thenifLo >= HithenMid := Mid + 1; XP := XP * 10.0;exit;elseLo := Mid + 1;endif;elsifXP >= Powten (S)thenifLo >= HithenMid := Mid - 1; XP := XP / 10.0;exit;elseHi := Mid - 1;endif;elseexit;endif;endloop; X := XP; Scale := Scale - Mid;-- Cases where scaling down is requiredelsifX >= Powten (S)then-- What we are looking for is a power of ten to divide X by-- so that the result lies within the required range.loopXP := X / Powten (Maxpow);exitwhenXP < Powten (S)orelseScale > Maxscaling; X := XP; Scale := Scale + Maxpow;endloop;-- The following exception is only raised in case of erroneous-- execution, where a number was considered valid but still-- fails to scale up. One situation where this can happen is-- when a system which is supposed to be IEEE-compliant, but-- has been reconfigured to flush denormals to zero.ifScale > MaxscalingthenraiseConstraint_Error;endif;-- Here we know that we must divide by at least 10**1 and that-- 10**Maxpow takes us too far, binary search to find right one.Lo := 1; Hi := Maxpow;loopMid := (Lo + Hi) / 2; XP := X / Powten (Mid);ifXP < Powten (S - 1)thenifLo >= HithenXP := XP * 10.0; Mid := Mid - 1;exit;elseHi := Mid - 1;endif;elsifXP >= Powten (S)thenifLo >= HithenXP := XP / 10.0; Mid := Mid + 1;exit;elseLo := Mid + 1;endif;elseexit;endif;endloop; X := XP; Scale := Scale + Mid;-- Here we are already scaled rightelsenull;endif;-- Round, readjusting scale if needed. Note that if a readjustment-- occurs, then it is never necessary to round again, because there-- is no possibility of such a second rounding causing a change.X := X + 0.5;ifX >= Powten (S)thenX := X / 10.0; Scale := Scale + 1;endif;endAdjust_Scale;----------------------- Convert_Integer -----------------------procedureConvert_Integerisbegin-- Use Unsigned routine if possible, since on many machines it will-- be significantly more efficient than the Long_Long_Unsigned one.ifX < Powten (Unsdigs)thenNdigs := 0; Set_Image_Unsigned (Unsigned (Long_Long_Float'Truncation (X)), Digs, Ndigs);-- But if we want more digits than fit in Unsigned, we have to use-- the Long_Long_Unsigned routine after all.elseNdigs := 0; Set_Image_Long_Long_Unsigned (Long_Long_Unsigned (Long_Long_Float'Truncation (X)), Digs, Ndigs);endif;endConvert_Integer;----------- Set -----------procedureSet (C : Character)isbeginP := P + 1; S (P) := C;endSet;--------------------------- Set_Blanks_And_Sign ---------------------------procedureSet_Blanks_And_Sign (N : Integer)isbeginifSign = '-'thenforJin1 .. N - 1loopSet (' ');endloop; Set ('-');elseforJin1 .. NloopSet (' ');endloop;endif;endSet_Blanks_And_Sign;---------------- Set_Digs ----------------procedureSet_Digs (S, E : Natural)isbeginforJinS .. EloopSet (Digs (J));endloop;endSet_Digs;------------------------ Set_Special_Fill ------------------------procedureSet_Special_Fill (N : Natural)isF : Natural;beginF := Fore + 1 + Aft - N;ifExp /= 0thenF := F + Exp + 1;endif;forJin1 .. FloopSet ('*');endloop;endSet_Special_Fill;----------------- Set_Zeros -----------------procedureSet_Zeros (N : Integer)isbeginforJin1 .. NloopSet ('0');endloop;endSet_Zeros;-- Start of processing for Set_Image_Realbegin-- 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; Scale := 0;-- Deal with invalid values first,ifnotV'Validthen-- Note that we're taking our chances here, as V might be-- an invalid bit pattern resulting from erroneous execution-- (caused by using uninitialized variables for example).-- No matter what, we'll at least get reasonable behaviour,-- converting to infinity or some other value, or causing an-- exception to be raised is fine.-- If the following test succeeds, then we definitely have-- an infinite value, so we print Inf.ifV > Long_Long_Float'LastthenSet ('+'); Set ('I'); Set ('n'); Set ('f'); Set_Special_Fill (4);-- In all other cases we print NaNelsifV < Long_Long_Float'FirstthenSet ('-'); Set ('I'); Set ('n'); Set ('f'); Set_Special_Fill (4);elseSet ('N'); Set ('a'); Set ('N'); Set_Special_Fill (3);endif;return;endif;-- Positive valuesifV > 0.0thenX := V; Sign := '+';-- Negative valueselsifV < 0.0thenX := -V; Sign := '-';-- Zero valueselsifV = 0.0thenifLong_Long_Float'Signed_ZerosandthenIs_Negative (V)thenSign := '-';elseSign := '+';endif; Set_Blanks_And_Sign (Fore - 1); Set ('0'); Set ('.'); Set_Zeros (NFrac);ifExp /= 0thenSet ('E'); Set ('+'); Set_Zeros (Natural'Max (1, Exp - 1));endif;return;else-- It should not be possible for a NaN to end up here.-- Either the 'Valid test has failed, or we have some form-- of erroneous execution. Raise Constraint_Error instead of-- attempting to go ahead printing the value.raiseConstraint_Error;endif;-- X and Sign are set here, and X is known to be a valid,-- non-zero floating-point number.-- Case of non-zero value with Exp = 0ifExp = 0then-- First step is to multiply by 10 ** Nfrac to get an integer-- value to be output, an then add 0.5 to round the result.declareNF : Natural := NFrac;beginloop-- If we are larger than Powten (Maxdigs) now, then-- we have too many significant digits, and we have-- not even finished multiplying by NFrac (NF shows-- the number of unaccounted-for digits).ifX >= Powten (Maxdigs)then-- In this situation, we only to generate a reasonable-- number of significant digits, and then zeroes after.-- So first we rescale to get:-- 10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs-- and then convert the resulting integerAdjust_Scale (Maxdigs); Convert_Integer;-- If that caused rescaling, then add zeros to the end-- of the number to account for this scaling. Also add-- zeroes to account for the undone multiplicationsforJin1 .. Scale + NFloopNdigs := Ndigs + 1; Digs (Ndigs) := '0';endloop;exit;-- If multiplication is complete, then convert the resulting-- integer after rounding (note that X is non-negative)elsifNF = 0thenX := X + 0.5; Convert_Integer;exit;-- Otherwise we can go ahead with the multiplication. If it-- can be done in one step, then do it in one step.elsifNF < MaxpowthenX := X * Powten (NF); NF := 0;-- If it cannot be done in one step, then do partial scalingelseX := X * Powten (Maxpow); NF := NF - Maxpow;endif;endloop;end;-- If number of available digits is less or equal to NFrac,-- then we need an extra zero before the decimal point.ifNdigs <= NFracthenSet_Blanks_And_Sign (Fore - 1); Set ('0'); Set ('.'); Set_Zeros (NFrac - Ndigs); Set_Digs (1, Ndigs);-- Normal case with some digits before the decimal pointelseSet_Blanks_And_Sign (Fore - (Ndigs - NFrac)); Set_Digs (1, Ndigs - NFrac); Set ('.'); Set_Digs (Ndigs - NFrac + 1, Ndigs);endif;-- Case of non-zero value with non-zero Exp valueelse-- If NFrac is less than Maxdigs, then all the fraction digits are-- significant, so we can scale the resulting integer accordingly.ifNFrac < MaxdigsthenAdjust_Scale (NFrac + 1); Convert_Integer;-- Otherwise, we get the maximum number of digits availableelseAdjust_Scale (Maxdigs); Convert_Integer;forJin1 .. NFrac - Maxdigs + 1loopNdigs := Ndigs + 1; Digs (Ndigs) := '0'; Scale := Scale - 1;endloop;endif; Set_Blanks_And_Sign (Fore - 1); Set (Digs (1)); Set ('.'); Set_Digs (2, Ndigs);-- The exponent is the scaling factor adjusted for the digits-- that we output after the decimal point, since these were-- included in the scaled digits that we output.Expon := Scale + NFrac; Set ('E'); Ndigs := 0;ifExpon >= 0thenSet ('+'); Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs);elseSet ('-'); Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs);endif; Set_Zeros (Exp - Ndigs - 1); Set_Digs (1, Ndigs);endif;endSet_Image_Real;endSystem.Img_Real;