File : a-tifiio.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                 A D A . T E X T _ I O . F I X E D _ I O                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 --                                                                          --
  19 --                                                                          --
  20 --                                                                          --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31 
  32 --  Fixed point I/O
  33 --  ---------------
  34 
  35 --  The following documents implementation details of the fixed point
  36 --  input/output routines in the GNAT run time. The first part describes
  37 --  general properties of fixed point types as defined by the Ada 95 standard,
  38 --  including the Information Systems Annex.
  39 
  40 --  Subsequently these are reduced to implementation constraints and the impact
  41 --  of these constraints on a few possible approaches to I/O are given.
  42 --  Based on this analysis, a specific implementation is selected for use in
  43 --  the GNAT run time. Finally, the chosen algorithm is analyzed numerically in
  44 --  order to provide user-level documentation on limits for range and precision
  45 --  of fixed point types as well as accuracy of input/output conversions.
  46 
  47 --  -------------------------------------------
  48 --  - General Properties of Fixed Point Types -
  49 --  -------------------------------------------
  50 
  51 --  Operations on fixed point values, other than input and output, are not
  52 --  important for the purposes of this document. Only the set of values that a
  53 --  fixed point type can represent and the input and output operations are
  54 --  significant.
  55 
  56 --  Values
  57 --  ------
  58 
  59 --  Set set of values of a fixed point type comprise the integral
  60 --  multiples of a number called the small of the type. The small can
  61 --  either be a power of ten, a power of two or (if the implementation
  62 --  allows) an arbitrary strictly positive real value.
  63 
  64 --  Implementations need to support fixed-point types with a precision
  65 --  of at least 24 bits, and (in order to comply with the Information
  66 --  Systems Annex) decimal types need to support at least digits 18.
  67 --  For the rest, however, no requirements exist for the minimal small
  68 --  and range that need to be supported.
  69 
  70 --  Operations
  71 --  ----------
  72 
  73 --  'Image and 'Wide_Image (see RM 3.5(34))
  74 
  75 --          These attributes return a decimal real literal best approximating
  76 --          the value (rounded away from zero if halfway between) with a
  77 --          single leading character that is either a minus sign or a space,
  78 --          one or more digits before the decimal point (with no redundant
  79 --          leading zeros), a decimal point, and N digits after the decimal
  80 --          point. For a subtype S, the value of N is S'Aft, the smallest
  81 --          positive integer such that (10**N)*S'Delta is greater or equal to
  82 --          one, see RM 3.5.10(5).
  83 
  84 --          For an arbitrary small, this means large number arithmetic needs
  85 --          to be performed.
  86 
  87 --  Put (see RM A.10.9(22-26))
  88 
  89 --          The requirements for Put add no extra constraints over the image
  90 --          attributes, although it would be nice to be able to output more
  91 --          than S'Aft digits after the decimal point for values of subtype S.
  92 
  93 --  'Value and 'Wide_Value attribute (RM 3.5(40-55))
  94 
  95 --          Since the input can be given in any base in the range 2..16,
  96 --          accurate conversion to a fixed point number may require
  97 --          arbitrary precision arithmetic if there is no limit on the
  98 --          magnitude of the small of the fixed point type.
  99 
 100 --  Get (see RM A.10.9(12-21))
 101 
 102 --          The requirements for Get are identical to those of the Value
 103 --          attribute.
 104 
 105 --  ------------------------------
 106 --  - Implementation Constraints -
 107 --  ------------------------------
 108 
 109 --  The requirements listed above for the input/output operations lead to
 110 --  significant complexity, if no constraints are put on supported smalls.
 111 
 112 --  Implementation Strategies
 113 --  -------------------------
 114 
 115 --  * Float arithmetic
 116 --  * Arbitrary-precision integer arithmetic
 117 --  * Fixed-precision integer arithmetic
 118 
 119 --  Although it seems convenient to convert fixed point numbers to floating-
 120 --  point and then print them, this leads to a number of restrictions.
 121 --  The first one is precision. The widest floating-point type generally
 122 --  available has 53 bits of mantissa. This means that Fine_Delta cannot
 123 --  be less than 2.0**(-53).
 124 
 125 --  In GNAT, Fine_Delta is 2.0**(-63), and Duration for example is a
 126 --  64-bit type. It would still be possible to use multi-precision
 127 --  floating-point to perform calculations using longer mantissas,
 128 --  but this is a much harder approach.
 129 
 130 --  The base conversions needed for input and output of (non-decimal)
 131 --  fixed point types can be seen as pairs of integer multiplications
 132 --  and divisions.
 133 
 134 --  Arbitrary-precision integer arithmetic would be suitable for the job
 135 --  at hand, but has the draw-back that it is very heavy implementation-wise.
 136 --  Especially in embedded systems, where fixed point types are often used,
 137 --  it may not be desirable to require large amounts of storage and time
 138 --  for fixed I/O operations.
 139 
 140 --  Fixed-precision integer arithmetic has the advantage of simplicity and
 141 --  speed. For the most common fixed point types this would be a perfect
 142 --  solution. The downside however may be a too limited set of acceptable
 143 --  fixed point types.
 144 
 145 --  Extra Precision
 146 --  ---------------
 147 
 148 --  Using a scaled divide which truncates and returns a remainder R,
 149 --  another E trailing digits can be calculated by computing the value
 150 --  (R * (10.0**E)) / Z using another scaled divide. This procedure
 151 --  can be repeated to compute an arbitrary number of digits in linear
 152 --  time and storage. The last scaled divide should be rounded, with
 153 --  a possible carry propagating to the more significant digits, to
 154 --  ensure correct rounding of the unit in the last place.
 155 
 156 --  An extension of this technique is to limit the value of Q to 9 decimal
 157 --  digits, since 32-bit integers can be much more efficient than 64-bit
 158 --  integers to output.
 159 
 160 with Interfaces;                        use Interfaces;
 161 with System.Arith_64;                   use System.Arith_64;
 162 with System.Img_Real;                   use System.Img_Real;
 163 with Ada.Text_IO;                       use Ada.Text_IO;
 164 with Ada.Text_IO.Float_Aux;
 165 with Ada.Text_IO.Generic_Aux;
 166 
 167 package body Ada.Text_IO.Fixed_IO is
 168 
 169    --  Note: we still use the floating-point I/O routines for input of
 170    --  ordinary fixed-point and output using exponent format. This will
 171    --  result in inaccuracies for fixed point types with a small that is
 172    --  not a power of two, and for types that require more precision than
 173    --  is available in Long_Long_Float.
 174 
 175    package Aux renames Ada.Text_IO.Float_Aux;
 176 
 177    Extra_Layout_Space : constant Field := 5 + Num'Fore;
 178    --  Extra space that may be needed for output of sign, decimal point,
 179    --  exponent indication and mandatory decimals after and before the
 180    --  decimal point. A string with length
 181 
 182    --    Fore + Aft + Exp + Extra_Layout_Space
 183 
 184    --  is always long enough for formatting any fixed point number
 185 
 186    --  Implementation of Put routines
 187 
 188    --  The following section describes a specific implementation choice for
 189    --  performing base conversions needed for output of values of a fixed
 190    --  point type T with small T'Small. The goal is to be able to output
 191    --  all values of types with a precision of 64 bits and a delta of at
 192    --  least 2.0**(-63), as these are current GNAT limitations already.
 193 
 194    --  The chosen algorithm uses fixed precision integer arithmetic for
 195    --  reasons of simplicity and efficiency. It is important to understand
 196    --  in what ways the most simple and accurate approach to fixed point I/O
 197    --  is limiting, before considering more complicated schemes.
 198 
 199    --  Without loss of generality assume T has a range (-2.0**63) * T'Small
 200    --  .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the
 201    --  decimal point and T'Fore - 1 before. If T'Small is integer, or
 202    --  1.0 / T'Small is integer, let S = T'Small and E = 0. For other T'Small,
 203    --  let S and E be integers such that S / 10**E best approximates T'Small
 204    --  and S is in the range 10**17 .. 10**18 - 1. The extra decimal scaling
 205    --  factor 10**E can be trivially handled during final output, by adjusting
 206    --  the decimal point or exponent.
 207 
 208    --  Convert a value X * S of type T to a 64-bit integer value Q equal
 209    --  to 10.0**D * (X * S) rounded to the nearest integer.
 210    --  This conversion is a scaled integer divide of the form
 211 
 212    --     Q := (X * Y) / Z,
 213 
 214    --  where all variables are 64-bit signed integers using 2's complement,
 215    --  and both the multiplication and division are done using full
 216    --  intermediate precision. The final decimal value to be output is
 217 
 218    --     Q * 10**(E-D)
 219 
 220    --  This value can be written to the output file or to the result string
 221    --  according to the format described in RM A.3.10. The details of this
 222    --  operation are omitted here.
 223 
 224    --  A 64-bit value can contain all integers with 18 decimal digits, but
 225    --  not all with 19 decimal digits. If the total number of requested output
 226    --  digits (Fore - 1) + Aft is greater than 18, for purposes of the
 227    --  conversion Aft is adjusted to 18 - (Fore - 1). In that case, or
 228    --  when Fore > 19, trailing zeros can complete the output after writing
 229    --  the first 18 significant digits, or the technique described in the
 230    --  next section can be used.
 231 
 232    --  The final expression for D is
 233 
 234    --     D := Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1)));
 235 
 236    --  For Y and Z the following expressions can be derived:
 237 
 238    --     Q / (10.0**D) = X * S
 239 
 240    --     Q = X * S * (10.0**D) = (X * Y) / Z
 241 
 242    --     S * 10.0**D = Y / Z;
 243 
 244    --  If S is an integer greater than or equal to one, then Fore must be at
 245    --  least 20 in order to print T'First, which is at most -2.0**63.
 246    --  This means D < 0, so use
 247 
 248    --    (1)   Y = -S and Z = -10**(-D)
 249 
 250    --  If 1.0 / S is an integer greater than one, use
 251 
 252    --    (2)   Y = -10**D and Z = -(1.0 / S), for D >= 0
 253 
 254    --  or
 255 
 256    --    (3)   Y = 1 and Z = (1.0 / S) * 10**(-D), for D < 0
 257 
 258    --  Negative values are used for nominator Y and denominator Z, so that S
 259    --  can have a maximum value of 2.0**63 and a minimum of 2.0**(-63).
 260    --  For Z in -1 .. -9, Fore will still be 20, and D will be negative, as
 261    --  (-2.0**63) / -9 is greater than 10**18. In these cases there is room
 262    --  in the denominator for the extra decimal scaling required, so case (3)
 263    --  will not overflow.
 264 
 265    pragma Assert (System.Fine_Delta >= 2.0**(-63));
 266    pragma Assert (Num'Small in 2.0**(-63) .. 2.0**63);
 267    pragma Assert (Num'Fore <= 37);
 268    --  These assertions need to be relaxed to allow for a Small of
 269    --  2.0**(-64) at least, since there is an ACATS test for this ???
 270 
 271    Max_Digits : constant := 18;
 272    --  Maximum number of decimal digits that can be represented in a
 273    --  64-bit signed number, see above
 274 
 275    --  The constants E0 .. E5 implement a binary search for the appropriate
 276    --  power of ten to scale the small so that it has one digit before the
 277    --  decimal point.
 278 
 279    subtype Int is Integer;
 280    E0 : constant Int := -(20 * Boolean'Pos (Num'Small >= 1.0E1));
 281    E1 : constant Int := E0 + 10 * Boolean'Pos (Num'Small * 10.0**E0 < 1.0E-10);
 282    E2 : constant Int := E1 +  5 * Boolean'Pos (Num'Small * 10.0**E1 < 1.0E-5);
 283    E3 : constant Int := E2 +  3 * Boolean'Pos (Num'Small * 10.0**E2 < 1.0E-3);
 284    E4 : constant Int := E3 +  2 * Boolean'Pos (Num'Small * 10.0**E3 < 1.0E-1);
 285    E5 : constant Int := E4 +  1 * Boolean'Pos (Num'Small * 10.0**E4 < 1.0E-0);
 286 
 287    Scale : constant Integer := E5;
 288 
 289    pragma Assert (Num'Small * 10.0**Scale >= 1.0
 290                    and then Num'Small * 10.0**Scale < 10.0);
 291 
 292    Exact : constant Boolean :=
 293      Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
 294        or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)
 295        or else Num'Small >= 10.0**Max_Digits;
 296    --  True iff a numerator and denominator can be calculated such that
 297    --  their ratio exactly represents the small of Num.
 298 
 299    procedure Put
 300      (To   : out String;
 301       Last : out Natural;
 302       Item : Num;
 303       Fore : Integer;
 304       Aft  : Field;
 305       Exp  : Field);
 306    --  Actual output function, used internally by all other Put routines.
 307    --  The formal Fore is an Integer, not a Field, because the routine is
 308    --  also called from the version of Put that performs I/O to a string,
 309    --  where the starting position depends on the size of the String, and
 310    --  bears no relation to the bounds of Field.
 311 
 312    ---------
 313    -- Get --
 314    ---------
 315 
 316    procedure Get
 317      (File  : File_Type;
 318       Item  : out Num;
 319       Width : Field := 0)
 320    is
 321       pragma Unsuppress (Range_Check);
 322    begin
 323       Aux.Get (File, Long_Long_Float (Item), Width);
 324    exception
 325       when Constraint_Error => raise Data_Error;
 326    end Get;
 327 
 328    procedure Get
 329      (Item  : out Num;
 330       Width : Field := 0)
 331    is
 332       pragma Unsuppress (Range_Check);
 333    begin
 334       Aux.Get (Current_In, Long_Long_Float (Item), Width);
 335    exception
 336       when Constraint_Error => raise Data_Error;
 337    end Get;
 338 
 339    procedure Get
 340      (From : String;
 341       Item : out Num;
 342       Last : out Positive)
 343    is
 344       pragma Unsuppress (Range_Check);
 345    begin
 346       Aux.Gets (From, Long_Long_Float (Item), Last);
 347    exception
 348       when Constraint_Error => raise Data_Error;
 349    end Get;
 350 
 351    ---------
 352    -- Put --
 353    ---------
 354 
 355    procedure Put
 356      (File : File_Type;
 357       Item : Num;
 358       Fore : Field := Default_Fore;
 359       Aft  : Field := Default_Aft;
 360       Exp  : Field := Default_Exp)
 361    is
 362       S    : String (1 .. Fore + Aft + Exp + Extra_Layout_Space);
 363       Last : Natural;
 364    begin
 365       Put (S, Last, Item, Fore, Aft, Exp);
 366       Generic_Aux.Put_Item (File, S (1 .. Last));
 367    end Put;
 368 
 369    procedure Put
 370      (Item : Num;
 371       Fore : Field := Default_Fore;
 372       Aft  : Field := Default_Aft;
 373       Exp  : Field := Default_Exp)
 374    is
 375       S    : String (1 .. Fore + Aft + Exp + Extra_Layout_Space);
 376       Last : Natural;
 377    begin
 378       Put (S, Last, Item, Fore, Aft, Exp);
 379       Generic_Aux.Put_Item (Text_IO.Current_Out, S (1 .. Last));
 380    end Put;
 381 
 382    procedure Put
 383      (To   : out String;
 384       Item : Num;
 385       Aft  : Field := Default_Aft;
 386       Exp  : Field := Default_Exp)
 387    is
 388       Fore : constant Integer :=
 389         To'Length
 390           - 1                      -- Decimal point
 391           - Field'Max (1, Aft)     -- Decimal part
 392           - Boolean'Pos (Exp /= 0) -- Exponent indicator
 393           - Exp;                   -- Exponent
 394 
 395       Last : Natural;
 396 
 397    begin
 398       if Fore - Boolean'Pos (Item < 0.0) < 1 then
 399          raise Layout_Error;
 400       end if;
 401 
 402       Put (To, Last, Item, Fore, Aft, Exp);
 403 
 404       if Last /= To'Last then
 405          raise Layout_Error;
 406       end if;
 407    end Put;
 408 
 409    procedure Put
 410      (To   : out String;
 411       Last : out Natural;
 412       Item : Num;
 413       Fore : Integer;
 414       Aft  : Field;
 415       Exp  : Field)
 416    is
 417       subtype Digit is Int64 range 0 .. 9;
 418 
 419       X   : constant Int64   := Int64'Integer_Value (Item);
 420       A   : constant Field   := Field'Max (Aft, 1);
 421       Neg : constant Boolean := (Item < 0.0);
 422       Pos : Integer := 0;  -- Next digit X has value X * 10.0**Pos;
 423 
 424       procedure Put_Character (C : Character);
 425       pragma Inline (Put_Character);
 426       --  Add C to the output string To, updating Last
 427 
 428       procedure Put_Digit (X : Digit);
 429       --  Add digit X to the output string (going from left to right), updating
 430       --  Last and Pos, and inserting the sign, leading zeros or a decimal
 431       --  point when necessary. After outputting the first digit, Pos must not
 432       --  be changed outside Put_Digit anymore.
 433 
 434       procedure Put_Int64 (X : Int64; Scale : Integer);
 435       --  Output the decimal number abs X * 10**Scale
 436 
 437       procedure Put_Scaled
 438         (X, Y, Z : Int64;
 439          A       : Field;
 440          E       : Integer);
 441       --  Output the decimal number (X * Y / Z) * 10**E, producing A digits
 442       --  after the decimal point and rounding the final digit. The value
 443       --  X * Y / Z is computed with full precision, but must be in the
 444       --  range of Int64.
 445 
 446       -------------------
 447       -- Put_Character --
 448       -------------------
 449 
 450       procedure Put_Character (C : Character) is
 451       begin
 452          Last := Last + 1;
 453 
 454          --  Never put a character outside of string To. Exception Layout_Error
 455          --  will be raised later if Last is greater than To'Last.
 456 
 457          if Last <= To'Last then
 458             To (Last) := C;
 459          end if;
 460       end Put_Character;
 461 
 462       ---------------
 463       -- Put_Digit --
 464       ---------------
 465 
 466       procedure Put_Digit (X : Digit) is
 467          Digs : constant array (Digit) of Character := "0123456789";
 468 
 469       begin
 470          if Last = To'First - 1 then
 471             if X /= 0 or else Pos <= 0 then
 472 
 473                --  Before outputting first digit, include leading space,
 474                --  possible minus sign and, if the first digit is fractional,
 475                --  decimal seperator and leading zeros.
 476 
 477                --  The Fore part has Pos + 1 + Boolean'Pos (Neg) characters,
 478                --  if Pos >= 0 and otherwise has a single zero digit plus minus
 479                --  sign if negative. Add leading space if necessary.
 480 
 481                for J in Integer'Max (0, Pos) + 2 + Boolean'Pos (Neg) .. Fore
 482                loop
 483                   Put_Character (' ');
 484                end loop;
 485 
 486                --  Output minus sign, if number is negative
 487 
 488                if Neg then
 489                   Put_Character ('-');
 490                end if;
 491 
 492                --  If starting with fractional digit, output leading zeros
 493 
 494                if Pos < 0 then
 495                   Put_Character ('0');
 496                   Put_Character ('.');
 497 
 498                   for J in Pos .. -2 loop
 499                      Put_Character ('0');
 500                   end loop;
 501                end if;
 502 
 503                Put_Character (Digs (X));
 504             end if;
 505 
 506          else
 507             --  This is not the first digit to be output, so the only
 508             --  special handling is that for the decimal point
 509 
 510             if Pos = -1 then
 511                Put_Character ('.');
 512             end if;
 513 
 514             Put_Character (Digs (X));
 515          end if;
 516 
 517          Pos := Pos - 1;
 518       end Put_Digit;
 519 
 520       ---------------
 521       -- Put_Int64 --
 522       ---------------
 523 
 524       procedure Put_Int64 (X : Int64; Scale : Integer) is
 525       begin
 526          if X = 0 then
 527             return;
 528          end if;
 529 
 530          if X not in -9 .. 9 then
 531             Put_Int64 (X / 10, Scale + 1);
 532          end if;
 533 
 534          --  Use Put_Digit to advance Pos. This fixes a case where the second
 535          --  or later Scaled_Divide would omit leading zeroes, resulting in
 536          --  too few digits produced and a Layout_Error as result.
 537 
 538          while Pos > Scale loop
 539             Put_Digit (0);
 540          end loop;
 541 
 542          --  If and only if more than one digit is output before the decimal
 543          --  point, pos will be unequal to scale when outputting the first
 544          --  digit.
 545 
 546          pragma Assert (Pos = Scale or else Last = To'First - 1);
 547 
 548          Pos := Scale;
 549 
 550          Put_Digit (abs (X rem 10));
 551       end Put_Int64;
 552 
 553       ----------------
 554       -- Put_Scaled --
 555       ----------------
 556 
 557       procedure Put_Scaled
 558         (X, Y, Z : Int64;
 559          A       : Field;
 560          E       : Integer)
 561       is
 562          pragma Assert (E >= -Max_Digits);
 563          AA : constant Field := E + A;
 564          N  : constant Natural := (AA + Max_Digits - 1) / Max_Digits + 1;
 565 
 566          Q  : array (0 .. N - 1) of Int64 := (others => 0);
 567          --  Each element of Q has Max_Digits decimal digits, except the
 568          --  last, which has eAA rem Max_Digits. Only Q (Q'First) may have an
 569          --  absolute value equal to or larger than 10**Max_Digits. Only the
 570          --  absolute value of the elements is not significant, not the sign.
 571 
 572          XX : Int64 := X;
 573          YY : Int64 := Y;
 574 
 575       begin
 576          for J in Q'Range loop
 577             exit when XX = 0;
 578 
 579             if J > 0 then
 580                YY := 10**(Integer'Min (Max_Digits, AA - (J - 1) * Max_Digits));
 581             end if;
 582 
 583             Scaled_Divide (XX, YY, Z, Q (J), R => XX, Round => False);
 584          end loop;
 585 
 586          if -E > A then
 587             pragma Assert (N = 1);
 588 
 589             Discard_Extra_Digits : declare
 590                Factor : constant Int64 := 10**(-E - A);
 591 
 592             begin
 593                --  The scaling factors were such that the first division
 594                --  produced more digits than requested. So divide away extra
 595                --  digits and compute new remainder for later rounding.
 596 
 597                if abs (Q (0) rem Factor) >= Factor / 2 then
 598                   Q (0) := abs (Q (0) / Factor) + 1;
 599                else
 600                   Q (0) := Q (0) / Factor;
 601                end if;
 602 
 603                XX := 0;
 604             end Discard_Extra_Digits;
 605          end if;
 606 
 607          --  At this point XX is a remainder and we need to determine if the
 608          --  quotient in Q must be rounded away from zero.
 609 
 610          --  As XX is less than the divisor, it is safe to take its absolute
 611          --  without chance of overflow. The check to see if XX is at least
 612          --  half the absolute value of the divisor must be done carefully to
 613          --  avoid overflow or lose precision.
 614 
 615          XX := abs XX;
 616 
 617          if XX >= 2**62
 618             or else (Z < 0 and then (-XX) * 2 <= Z)
 619             or else (Z >= 0 and then XX * 2 >= Z)
 620          then
 621             --  OK, rounding is necessary. As the sign is not significant,
 622             --  take advantage of the fact that an extra negative value will
 623             --  always be available when propagating the carry.
 624 
 625             Q (Q'Last) := -abs Q (Q'Last) - 1;
 626 
 627             Propagate_Carry :
 628             for J in reverse 1 .. Q'Last loop
 629                if Q (J) = YY or else Q (J) = -YY then
 630                   Q (J) := 0;
 631                   Q (J - 1) := -abs Q (J - 1) - 1;
 632 
 633                else
 634                   exit Propagate_Carry;
 635                end if;
 636             end loop Propagate_Carry;
 637          end if;
 638 
 639          for J in Q'First .. Q'Last - 1 loop
 640             Put_Int64 (Q (J), E - J * Max_Digits);
 641          end loop;
 642 
 643          Put_Int64 (Q (Q'Last), -A);
 644       end Put_Scaled;
 645 
 646    --  Start of processing for Put
 647 
 648    begin
 649       Last := To'First - 1;
 650 
 651       if Exp /= 0 then
 652 
 653          --  With the Exp format, it is not known how many output digits to
 654          --  generate, as leading zeros must be ignored. Computing too many
 655          --  digits and then truncating the output will not give the closest
 656          --  output, it is necessary to round at the correct digit.
 657 
 658          --  The general approach is as follows: as long as no digits have
 659          --  been generated, compute the Aft next digits (without rounding).
 660          --  Once a non-zero digit is generated, determine the exact number
 661          --  of digits remaining and compute them with rounding.
 662 
 663          --  Since a large number of iterations might be necessary in case
 664          --  of Aft = 1, the following optimization would be desirable.
 665 
 666          --  Count the number Z of leading zero bits in the integer
 667          --  representation of X, and start with producing Aft + Z * 1000 /
 668          --  3322 digits in the first scaled division.
 669 
 670          --  However, the floating-point routines are still used now ???
 671 
 672          System.Img_Real.Set_Image_Real (Long_Long_Float (Item), To, Last,
 673             Fore, Aft, Exp);
 674          return;
 675       end if;
 676 
 677       if Exact then
 678          declare
 679             D : constant Integer := Integer'Min (A, Max_Digits
 680                                                             - (Num'Fore - 1));
 681             Y : constant Int64   := Int64'Min (Int64 (-Num'Small), -1)
 682                                      * 10**Integer'Max (0, D);
 683             Z : constant Int64   := Int64'Min (Int64 (-(1.0 / Num'Small)), -1)
 684                                      * 10**Integer'Max (0, -D);
 685          begin
 686             Put_Scaled (X, Y, Z, A, -D);
 687          end;
 688 
 689       else -- not Exact
 690          declare
 691             E : constant Integer := Max_Digits - 1 + Scale;
 692             D : constant Integer := Scale - 1;
 693             Y : constant Int64   := Int64 (-Num'Small * 10.0**E);
 694             Z : constant Int64   := -10**Max_Digits;
 695          begin
 696             Put_Scaled (X, Y, Z, A, -D);
 697          end;
 698       end if;
 699 
 700       --  If only zero digits encountered, unit digit has not been output yet
 701 
 702       if Last < To'First then
 703          Pos := 0;
 704 
 705       elsif Last > To'Last then
 706          raise Layout_Error; -- Not enough room in the output variable
 707       end if;
 708 
 709       --  Always output digits up to the first one after the decimal point
 710 
 711       while Pos >= -A loop
 712          Put_Digit (0);
 713       end loop;
 714    end Put;
 715 
 716 end Ada.Text_IO.Fixed_IO;