OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-tifiio.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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-2010, 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
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
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) =
295
                                Float'Ceiling (1.0 / Num'Small)
296
              or else Num'Small >= 10.0**Max_Digits;
297
   --  True iff a numerator and denominator can be calculated such that
298
   --  their ratio exactly represents the small of Num.
299
 
300
   procedure Put
301
     (To   : out String;
302
      Last : out Natural;
303
      Item : Num;
304
      Fore : Integer;
305
      Aft  : Field;
306
      Exp  : Field);
307
   --  Actual output function, used internally by all other Put routines.
308
   --  The formal Fore is an Integer, not a Field, because the routine is
309
   --  also called from the version of Put that performs I/O to a string,
310
   --  where the starting position depends on the size of the String, and
311
   --  bears no relation to the bounds of Field.
312
 
313
   ---------
314
   -- Get --
315
   ---------
316
 
317
   procedure Get
318
     (File  : File_Type;
319
      Item  : out Num;
320
      Width : Field := 0)
321
   is
322
      pragma Unsuppress (Range_Check);
323
   begin
324
      Aux.Get (File, Long_Long_Float (Item), Width);
325
   exception
326
      when Constraint_Error => raise Data_Error;
327
   end Get;
328
 
329
   procedure Get
330
     (Item  : out Num;
331
      Width : Field := 0)
332
   is
333
      pragma Unsuppress (Range_Check);
334
   begin
335
      Aux.Get (Current_In, Long_Long_Float (Item), Width);
336
   exception
337
      when Constraint_Error => raise Data_Error;
338
   end Get;
339
 
340
   procedure Get
341
     (From : String;
342
      Item : out Num;
343
      Last : out Positive)
344
   is
345
      pragma Unsuppress (Range_Check);
346
   begin
347
      Aux.Gets (From, Long_Long_Float (Item), Last);
348
   exception
349
      when Constraint_Error => raise Data_Error;
350
   end Get;
351
 
352
   ---------
353
   -- Put --
354
   ---------
355
 
356
   procedure Put
357
     (File : File_Type;
358
      Item : Num;
359
      Fore : Field := Default_Fore;
360
      Aft  : Field := Default_Aft;
361
      Exp  : Field := Default_Exp)
362
   is
363
      S    : String (1 .. Fore + Aft + Exp + Extra_Layout_Space);
364
      Last : Natural;
365
   begin
366
      Put (S, Last, Item, Fore, Aft, Exp);
367
      Generic_Aux.Put_Item (File, S (1 .. Last));
368
   end Put;
369
 
370
   procedure Put
371
     (Item : Num;
372
      Fore : Field := Default_Fore;
373
      Aft  : Field := Default_Aft;
374
      Exp  : Field := Default_Exp)
375
   is
376
      S    : String (1 .. Fore + Aft + Exp + Extra_Layout_Space);
377
      Last : Natural;
378
   begin
379
      Put (S, Last, Item, Fore, Aft, Exp);
380
      Generic_Aux.Put_Item (Text_IO.Current_Out, S (1 .. Last));
381
   end Put;
382
 
383
   procedure Put
384
     (To   : out String;
385
      Item : Num;
386
      Aft  : Field := Default_Aft;
387
      Exp  : Field := Default_Exp)
388
   is
389
      Fore : constant Integer :=
390
               To'Length
391
                 - 1                      -- Decimal point
392
                 - Field'Max (1, Aft)     -- Decimal part
393
                 - Boolean'Pos (Exp /= 0) -- Exponent indicator
394
                 - Exp;                   -- Exponent
395
 
396
      Last : Natural;
397
 
398
   begin
399
      if Fore - Boolean'Pos (Item < 0.0) < 1 then
400
         raise Layout_Error;
401
      end if;
402
 
403
      Put (To, Last, Item, Fore, Aft, Exp);
404
 
405
      if Last /= To'Last then
406
         raise Layout_Error;
407
      end if;
408
   end Put;
409
 
410
   procedure Put
411
     (To   : out String;
412
      Last : out Natural;
413
      Item : Num;
414
      Fore : Integer;
415
      Aft  : Field;
416
      Exp  : Field)
417
   is
418
      subtype Digit is Int64 range 0 .. 9;
419
 
420
      X   : constant Int64   := Int64'Integer_Value (Item);
421
      A   : constant Field   := Field'Max (Aft, 1);
422
      Neg : constant Boolean := (Item < 0.0);
423
      Pos : Integer := 0;  -- Next digit X has value X * 10.0**Pos;
424
 
425
      procedure Put_Character (C : Character);
426
      pragma Inline (Put_Character);
427
      --  Add C to the output string To, updating Last
428
 
429
      procedure Put_Digit (X : Digit);
430
      --  Add digit X to the output string (going from left to right), updating
431
      --  Last and Pos, and inserting the sign, leading zeros or a decimal
432
      --  point when necessary. After outputting the first digit, Pos must not
433
      --  be changed outside Put_Digit anymore.
434
 
435
      procedure Put_Int64 (X : Int64; Scale : Integer);
436
      --  Output the decimal number abs X * 10**Scale
437
 
438
      procedure Put_Scaled
439
        (X, Y, Z : Int64;
440
         A       : Field;
441
         E       : Integer);
442
      --  Output the decimal number (X * Y / Z) * 10**E, producing A digits
443
      --  after the decimal point and rounding the final digit. The value
444
      --  X * Y / Z is computed with full precision, but must be in the
445
      --  range of Int64.
446
 
447
      -------------------
448
      -- Put_Character --
449
      -------------------
450
 
451
      procedure Put_Character (C : Character) is
452
      begin
453
         Last := Last + 1;
454
 
455
         --  Never put a character outside of string To. Exception Layout_Error
456
         --  will be raised later if Last is greater than To'Last.
457
 
458
         if Last <= To'Last then
459
            To (Last) := C;
460
         end if;
461
      end Put_Character;
462
 
463
      ---------------
464
      -- Put_Digit --
465
      ---------------
466
 
467
      procedure Put_Digit (X : Digit) is
468
         Digs : constant array (Digit) of Character := "0123456789";
469
 
470
      begin
471
         if Last = To'First - 1 then
472
            if X /= 0 or else Pos <= 0 then
473
 
474
               --  Before outputting first digit, include leading space,
475
               --  possible minus sign and, if the first digit is fractional,
476
               --  decimal seperator and leading zeros.
477
 
478
               --  The Fore part has Pos + 1 + Boolean'Pos (Neg) characters,
479
               --  if Pos >= 0 and otherwise has a single zero digit plus minus
480
               --  sign if negative. Add leading space if necessary.
481
 
482
               for J in Integer'Max (0, Pos) + 2 + Boolean'Pos (Neg) .. Fore
483
               loop
484
                  Put_Character (' ');
485
               end loop;
486
 
487
               --  Output minus sign, if number is negative
488
 
489
               if Neg then
490
                  Put_Character ('-');
491
               end if;
492
 
493
               --  If starting with fractional digit, output leading zeros
494
 
495
               if Pos < 0 then
496
                  Put_Character ('0');
497
                  Put_Character ('.');
498
 
499
                  for J in Pos .. -2 loop
500
                     Put_Character ('0');
501
                  end loop;
502
               end if;
503
 
504
               Put_Character (Digs (X));
505
            end if;
506
 
507
         else
508
            --  This is not the first digit to be output, so the only
509
            --  special handling is that for the decimal point
510
 
511
            if Pos = -1 then
512
               Put_Character ('.');
513
            end if;
514
 
515
            Put_Character (Digs (X));
516
         end if;
517
 
518
         Pos := Pos - 1;
519
      end Put_Digit;
520
 
521
      ---------------
522
      -- Put_Int64 --
523
      ---------------
524
 
525
      procedure Put_Int64 (X : Int64; Scale : Integer) is
526
      begin
527
         if X = 0 then
528
            return;
529
         end if;
530
 
531
         if X not in -9 .. 9 then
532
            Put_Int64 (X / 10, Scale + 1);
533
         end if;
534
 
535
         --  Use Put_Digit to advance Pos. This fixes a case where the second
536
         --  or later Scaled_Divide would omit leading zeroes, resulting in
537
         --  too few digits produced and a Layout_Error as result.
538
 
539
         while Pos > Scale loop
540
            Put_Digit (0);
541
         end loop;
542
 
543
         --  If and only if more than one digit is output before the decimal
544
         --  point, pos will be unequal to scale when outputting the first
545
         --  digit.
546
 
547
         pragma Assert (Pos = Scale or else Last = To'First - 1);
548
 
549
         Pos := Scale;
550
 
551
         Put_Digit (abs (X rem 10));
552
      end Put_Int64;
553
 
554
      ----------------
555
      -- Put_Scaled --
556
      ----------------
557
 
558
      procedure Put_Scaled
559
        (X, Y, Z : Int64;
560
         A       : Field;
561
         E       : Integer)
562
      is
563
         pragma Assert (E >= -Max_Digits);
564
         AA : constant Field := E + A;
565
         N  : constant Natural := (AA + Max_Digits - 1) / Max_Digits + 1;
566
 
567
         Q  : array (0 .. N - 1) of Int64 := (others => 0);
568
         --  Each element of Q has Max_Digits decimal digits, except the
569
         --  last, which has eAA rem Max_Digits. Only Q (Q'First) may have an
570
         --  absolute value equal to or larger than 10**Max_Digits. Only the
571
         --  absolute value of the elements is not significant, not the sign.
572
 
573
         XX : Int64 := X;
574
         YY : Int64 := Y;
575
 
576
      begin
577
         for J in Q'Range loop
578
            exit when XX = 0;
579
 
580
            if J > 0 then
581
               YY := 10**(Integer'Min (Max_Digits, AA - (J - 1) * Max_Digits));
582
            end if;
583
 
584
            Scaled_Divide (XX, YY, Z, Q (J), R => XX, Round => False);
585
         end loop;
586
 
587
         if -E > A then
588
            pragma Assert (N = 1);
589
 
590
            Discard_Extra_Digits : declare
591
               Factor : constant Int64 := 10**(-E - A);
592
 
593
            begin
594
               --  The scaling factors were such that the first division
595
               --  produced more digits than requested. So divide away extra
596
               --  digits and compute new remainder for later rounding.
597
 
598
               if abs (Q (0) rem Factor) >= Factor / 2 then
599
                  Q (0) := abs (Q (0) / Factor) + 1;
600
               else
601
                  Q (0) := Q (0) / Factor;
602
               end if;
603
 
604
               XX := 0;
605
            end Discard_Extra_Digits;
606
         end if;
607
 
608
         --  At this point XX is a remainder and we need to determine if the
609
         --  quotient in Q must be rounded away from zero.
610
 
611
         --  As XX is less than the divisor, it is safe to take its absolute
612
         --  without chance of overflow. The check to see if XX is at least
613
         --  half the absolute value of the divisor must be done carefully to
614
         --  avoid overflow or lose precision.
615
 
616
         XX := abs XX;
617
 
618
         if XX >= 2**62
619
            or else (Z < 0 and then (-XX) * 2 <= Z)
620
            or else (Z >= 0 and then XX * 2 >= Z)
621
         then
622
            --  OK, rounding is necessary. As the sign is not significant,
623
            --  take advantage of the fact that an extra negative value will
624
            --  always be available when propagating the carry.
625
 
626
            Q (Q'Last) := -abs Q (Q'Last) - 1;
627
 
628
            Propagate_Carry :
629
            for J in reverse 1 .. Q'Last loop
630
               if Q (J) = YY or else Q (J) = -YY then
631
                  Q (J) := 0;
632
                  Q (J - 1) := -abs Q (J - 1) - 1;
633
 
634
               else
635
                  exit Propagate_Carry;
636
               end if;
637
            end loop Propagate_Carry;
638
         end if;
639
 
640
         for J in Q'First .. Q'Last - 1 loop
641
            Put_Int64 (Q (J), E - J * Max_Digits);
642
         end loop;
643
 
644
         Put_Int64 (Q (Q'Last), -A);
645
      end Put_Scaled;
646
 
647
   --  Start of processing for Put
648
 
649
   begin
650
      Last := To'First - 1;
651
 
652
      if Exp /= 0 then
653
 
654
         --  With the Exp format, it is not known how many output digits to
655
         --  generate, as leading zeros must be ignored. Computing too many
656
         --  digits and then truncating the output will not give the closest
657
         --  output, it is necessary to round at the correct digit.
658
 
659
         --  The general approach is as follows: as long as no digits have
660
         --  been generated, compute the Aft next digits (without rounding).
661
         --  Once a non-zero digit is generated, determine the exact number
662
         --  of digits remaining and compute them with rounding.
663
 
664
         --  Since a large number of iterations might be necessary in case
665
         --  of Aft = 1, the following optimization would be desirable.
666
 
667
         --  Count the number Z of leading zero bits in the integer
668
         --  representation of X, and start with producing Aft + Z * 1000 /
669
         --  3322 digits in the first scaled division.
670
 
671
         --  However, the floating-point routines are still used now ???
672
 
673
         System.Img_Real.Set_Image_Real (Long_Long_Float (Item), To, Last,
674
            Fore, Aft, Exp);
675
         return;
676
      end if;
677
 
678
      if Exact then
679
         declare
680
            D : constant Integer := Integer'Min (A, Max_Digits
681
                                                            - (Num'Fore - 1));
682
            Y : constant Int64   := Int64'Min (Int64 (-Num'Small), -1)
683
                                     * 10**Integer'Max (0, D);
684
            Z : constant Int64   := Int64'Min (Int64 (-(1.0 / Num'Small)), -1)
685
                                     * 10**Integer'Max (0, -D);
686
         begin
687
            Put_Scaled (X, Y, Z, A, -D);
688
         end;
689
 
690
      else -- not Exact
691
         declare
692
            E : constant Integer := Max_Digits - 1 + Scale;
693
            D : constant Integer := Scale - 1;
694
            Y : constant Int64   := Int64 (-Num'Small * 10.0**E);
695
            Z : constant Int64   := -10**Max_Digits;
696
         begin
697
            Put_Scaled (X, Y, Z, A, -D);
698
         end;
699
      end if;
700
 
701
      --  If only zero digits encountered, unit digit has not been output yet
702
 
703
      if Last < To'First then
704
         Pos := 0;
705
 
706
      elsif Last > To'Last then
707
         raise Layout_Error; -- Not enough room in the output variable
708
      end if;
709
 
710
      --  Always output digits up to the first one after the decimal point
711
 
712
      while Pos >= -A loop
713
         Put_Digit (0);
714
      end loop;
715
   end Put;
716
 
717
end Ada.Text_IO.Fixed_IO;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.