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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-imgrea.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
--                      S Y S T E M . I M G _ R E A L                       --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2011, 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
with System.Img_LLU;        use System.Img_LLU;
33
with System.Img_Uns;        use System.Img_Uns;
34
with System.Powten_Table;   use System.Powten_Table;
35
with System.Unsigned_Types; use System.Unsigned_Types;
36
with System.Float_Control;
37
 
38
package body System.Img_Real is
39
 
40
   --  The following defines the maximum number of digits that we can convert
41
   --  accurately. This is limited by the precision of Long_Long_Float, and
42
   --  also by the number of digits we can hold in Long_Long_Unsigned, which
43
   --  is the integer type we use as an intermediate for the result.
44
 
45
   --  We assume that in practice, the limitation will come from the digits
46
   --  value, rather than the integer value. This is true for typical IEEE
47
   --  implementations, and at worst, the only loss is for some precision
48
   --  in very high precision floating-point output.
49
 
50
   --  Note that in the following, the "-2" accounts for the sign and one
51
   --  extra digits, since we need the maximum number of 9's that can be
52
   --  supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width
53
   --  is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits,
54
   --  but the maximum number of 9's that can be supported is 19.
55
 
56
   Maxdigs : constant :=
57
               Natural'Min
58
                 (Long_Long_Unsigned'Width - 2, Long_Long_Float'Digits);
59
 
60
   Unsdigs : constant := Unsigned'Width - 2;
61
   --  Number of digits that can be converted using type Unsigned
62
   --  See above for the explanation of the -2.
63
 
64
   Maxscaling : constant := 5000;
65
   --  Max decimal scaling required during conversion of floating-point
66
   --  numbers to decimal. This is used to defend against infinite
67
   --  looping in the conversion, as can be caused by erroneous executions.
68
   --  The largest exponent used on any current system is 2**16383, which
69
   --  is approximately 10**4932, and the highest number of decimal digits
70
   --  is about 35 for 128-bit floating-point formats, so 5000 leaves
71
   --  enough room for scaling such values
72
 
73
   function Is_Negative (V : Long_Long_Float) return Boolean;
74
   pragma Import (Intrinsic, Is_Negative);
75
 
76
   --------------------------
77
   -- Image_Floating_Point --
78
   --------------------------
79
 
80
   procedure Image_Floating_Point
81
     (V    : Long_Long_Float;
82
      S    : in out String;
83
      P    : out Natural;
84
      Digs : Natural)
85
   is
86
      pragma Assert (S'First = 1);
87
 
88
   begin
89
      --  Decide whether a blank should be prepended before the call to
90
      --  Set_Image_Real. We generate a blank for positive values, and
91
      --  also for positive zeroes. For negative zeroes, we generate a
92
      --  space only if Signed_Zeroes is True (the RM only permits the
93
      --  output of -0.0 on targets where this is the case). We can of
94
      --  course still see a -0.0 on a target where Signed_Zeroes is
95
      --  False (since this attribute refers to the proper handling of
96
      --  negative zeroes, not to their existence).
97
 
98
      if not Is_Negative (V)
99
        or else (not Long_Long_Float'Signed_Zeros and then V = -0.0)
100
      then
101
         S (1) := ' ';
102
         P := 1;
103
      else
104
         P := 0;
105
      end if;
106
 
107
      Set_Image_Real (V, S, P, 1, Digs - 1, 3);
108
   end Image_Floating_Point;
109
 
110
   --------------------------------
111
   -- Image_Ordinary_Fixed_Point --
112
   --------------------------------
113
 
114
   procedure Image_Ordinary_Fixed_Point
115
     (V   : Long_Long_Float;
116
      S   : in out String;
117
      P   : out Natural;
118
      Aft : Natural)
119
   is
120
      pragma Assert (S'First = 1);
121
 
122
   begin
123
      --  Output space at start if non-negative
124
 
125
      if V >= 0.0 then
126
         S (1) := ' ';
127
         P := 1;
128
      else
129
         P := 0;
130
      end if;
131
 
132
      Set_Image_Real (V, S, P, 1, Aft, 0);
133
   end Image_Ordinary_Fixed_Point;
134
 
135
   --------------------
136
   -- Set_Image_Real --
137
   --------------------
138
 
139
   procedure Set_Image_Real
140
     (V    : Long_Long_Float;
141
      S    : out String;
142
      P    : in out Natural;
143
      Fore : Natural;
144
      Aft  : Natural;
145
      Exp  : Natural)
146
   is
147
      NFrac : constant Natural := Natural'Max (Aft, 1);
148
      Sign  : Character;
149
      X     : aliased Long_Long_Float;
150
      --  This is declared aliased because the expansion of X'Valid passes
151
      --  X by access and JGNAT requires all access parameters to be aliased.
152
      --  The Valid attribute probably needs to be handled via a different
153
      --  expansion for JGNAT, and this use of aliased should be removed
154
      --  once Valid is handled properly. ???
155
      Scale : Integer;
156
      Expon : Integer;
157
 
158
      Field_Max : constant := 255;
159
      --  This should be the same value as Ada.[Wide_]Text_IO.Field'Last.
160
      --  It is not worth dragging in Ada.Text_IO to pick up this value,
161
      --  since it really should never be necessary to change it!
162
 
163
      Digs : String (1 .. 2 * Field_Max + 16);
164
      --  Array used to hold digits of converted integer value. This is a
165
      --  large enough buffer to accommodate ludicrous values of Fore and Aft.
166
 
167
      Ndigs : Natural;
168
      --  Number of digits stored in Digs (and also subscript of last digit)
169
 
170
      procedure Adjust_Scale (S : Natural);
171
      --  Adjusts the value in X by multiplying or dividing by a power of
172
      --  ten so that it is in the range 10**(S-1) <= X < 10**S. Includes
173
      --  adding 0.5 to round the result, readjusting if the rounding causes
174
      --  the result to wander out of the range. Scale is adjusted to reflect
175
      --  the power of ten used to divide the result (i.e. one is added to
176
      --  the scale value for each division by 10.0, or one is subtracted
177
      --  for each multiplication by 10.0).
178
 
179
      procedure Convert_Integer;
180
      --  Takes the value in X, outputs integer digits into Digs. On return,
181
      --  Ndigs is set to the number of digits stored. The digits are stored
182
      --  in Digs (1 .. Ndigs),
183
 
184
      procedure Set (C : Character);
185
      --  Sets character C in output buffer
186
 
187
      procedure Set_Blanks_And_Sign (N : Integer);
188
      --  Sets leading blanks and minus sign if needed. N is the number of
189
      --  positions to be filled (a minus sign is output even if N is zero
190
      --  or negative, but for a positive value, if N is non-positive, then
191
      --  the call has no effect).
192
 
193
      procedure Set_Digs (S, E : Natural);
194
      --  Set digits S through E from Digs buffer. No effect if S > E
195
 
196
      procedure Set_Special_Fill (N : Natural);
197
      --  After outputting +Inf, -Inf or NaN, this routine fills out the
198
      --  rest of the field with * characters. The argument is the number
199
      --  of characters output so far (either 3 or 4)
200
 
201
      procedure Set_Zeros (N : Integer);
202
      --  Set N zeros, no effect if N is negative
203
 
204
      pragma Inline (Set);
205
      pragma Inline (Set_Digs);
206
      pragma Inline (Set_Zeros);
207
 
208
      ------------------
209
      -- Adjust_Scale --
210
      ------------------
211
 
212
      procedure Adjust_Scale (S : Natural) is
213
         Lo  : Natural;
214
         Hi  : Natural;
215
         Mid : Natural;
216
         XP  : Long_Long_Float;
217
 
218
      begin
219
         --  Cases where scaling up is required
220
 
221
         if X < Powten (S - 1) then
222
 
223
            --  What we are looking for is a power of ten to multiply X by
224
            --  so that the result lies within the required range.
225
 
226
            loop
227
               XP := X * Powten (Maxpow);
228
               exit when XP >= Powten (S - 1) or else Scale < -Maxscaling;
229
               X := XP;
230
               Scale := Scale - Maxpow;
231
            end loop;
232
 
233
            --  The following exception is only raised in case of erroneous
234
            --  execution, where a number was considered valid but still
235
            --  fails to scale up. One situation where this can happen is
236
            --  when a system which is supposed to be IEEE-compliant, but
237
            --  has been reconfigured to flush denormals to zero.
238
 
239
            if Scale < -Maxscaling then
240
               raise Constraint_Error;
241
            end if;
242
 
243
            --  Here we know that we must multiply by at least 10**1 and that
244
            --  10**Maxpow takes us too far: binary search to find right one.
245
 
246
            --  Because of roundoff errors, it is possible for the value
247
            --  of XP to be just outside of the interval when Lo >= Hi. In
248
            --  that case we adjust explicitly by a factor of 10. This
249
            --  can only happen with a value that is very close to an
250
            --  exact power of 10.
251
 
252
            Lo := 1;
253
            Hi := Maxpow;
254
 
255
            loop
256
               Mid := (Lo + Hi) / 2;
257
               XP := X * Powten (Mid);
258
 
259
               if XP < Powten (S - 1) then
260
 
261
                  if Lo >= Hi then
262
                     Mid := Mid + 1;
263
                     XP := XP * 10.0;
264
                     exit;
265
 
266
                  else
267
                     Lo := Mid + 1;
268
                  end if;
269
 
270
               elsif XP >= Powten (S) then
271
 
272
                  if Lo >= Hi then
273
                     Mid := Mid - 1;
274
                     XP := XP / 10.0;
275
                     exit;
276
 
277
                  else
278
                     Hi := Mid - 1;
279
                  end if;
280
 
281
               else
282
                  exit;
283
               end if;
284
            end loop;
285
 
286
            X := XP;
287
            Scale := Scale - Mid;
288
 
289
         --  Cases where scaling down is required
290
 
291
         elsif X >= Powten (S) then
292
 
293
            --  What we are looking for is a power of ten to divide X by
294
            --  so that the result lies within the required range.
295
 
296
            loop
297
               XP := X / Powten (Maxpow);
298
               exit when XP < Powten (S) or else Scale > Maxscaling;
299
               X := XP;
300
               Scale := Scale + Maxpow;
301
            end loop;
302
 
303
            --  The following exception is only raised in case of erroneous
304
            --  execution, where a number was considered valid but still
305
            --  fails to scale up. One situation where this can happen is
306
            --  when a system which is supposed to be IEEE-compliant, but
307
            --  has been reconfigured to flush denormals to zero.
308
 
309
            if Scale > Maxscaling then
310
               raise Constraint_Error;
311
            end if;
312
 
313
            --  Here we know that we must divide by at least 10**1 and that
314
            --  10**Maxpow takes us too far, binary search to find right one.
315
 
316
            Lo := 1;
317
            Hi := Maxpow;
318
 
319
            loop
320
               Mid := (Lo + Hi) / 2;
321
               XP := X / Powten (Mid);
322
 
323
               if XP < Powten (S - 1) then
324
 
325
                  if Lo >= Hi then
326
                     XP := XP * 10.0;
327
                     Mid := Mid - 1;
328
                     exit;
329
 
330
                  else
331
                     Hi := Mid - 1;
332
                  end if;
333
 
334
               elsif XP >= Powten (S) then
335
 
336
                  if Lo >= Hi then
337
                     XP := XP / 10.0;
338
                     Mid := Mid + 1;
339
                     exit;
340
 
341
                  else
342
                     Lo := Mid + 1;
343
                  end if;
344
 
345
               else
346
                  exit;
347
               end if;
348
            end loop;
349
 
350
            X := XP;
351
            Scale := Scale + Mid;
352
 
353
         --  Here we are already scaled right
354
 
355
         else
356
            null;
357
         end if;
358
 
359
         --  Round, readjusting scale if needed. Note that if a readjustment
360
         --  occurs, then it is never necessary to round again, because there
361
         --  is no possibility of such a second rounding causing a change.
362
 
363
         X := X + 0.5;
364
 
365
         if X >= Powten (S) then
366
            X := X / 10.0;
367
            Scale := Scale + 1;
368
         end if;
369
 
370
      end Adjust_Scale;
371
 
372
      ---------------------
373
      -- Convert_Integer --
374
      ---------------------
375
 
376
      procedure Convert_Integer is
377
      begin
378
         --  Use Unsigned routine if possible, since on many machines it will
379
         --  be significantly more efficient than the Long_Long_Unsigned one.
380
 
381
         if X < Powten (Unsdigs) then
382
            Ndigs := 0;
383
            Set_Image_Unsigned
384
              (Unsigned (Long_Long_Float'Truncation (X)),
385
               Digs, Ndigs);
386
 
387
         --  But if we want more digits than fit in Unsigned, we have to use
388
         --  the Long_Long_Unsigned routine after all.
389
 
390
         else
391
            Ndigs := 0;
392
            Set_Image_Long_Long_Unsigned
393
              (Long_Long_Unsigned (Long_Long_Float'Truncation (X)),
394
               Digs, Ndigs);
395
         end if;
396
      end Convert_Integer;
397
 
398
      ---------
399
      -- Set --
400
      ---------
401
 
402
      procedure Set (C : Character) is
403
      begin
404
         P := P + 1;
405
         S (P) := C;
406
      end Set;
407
 
408
      -------------------------
409
      -- Set_Blanks_And_Sign --
410
      -------------------------
411
 
412
      procedure Set_Blanks_And_Sign (N : Integer) is
413
      begin
414
         if Sign = '-' then
415
            for J in 1 .. N - 1 loop
416
               Set (' ');
417
            end loop;
418
 
419
            Set ('-');
420
 
421
         else
422
            for J in 1 .. N loop
423
               Set (' ');
424
            end loop;
425
         end if;
426
      end Set_Blanks_And_Sign;
427
 
428
      --------------
429
      -- Set_Digs --
430
      --------------
431
 
432
      procedure Set_Digs (S, E : Natural) is
433
      begin
434
         for J in S .. E loop
435
            Set (Digs (J));
436
         end loop;
437
      end Set_Digs;
438
 
439
      ----------------------
440
      -- Set_Special_Fill --
441
      ----------------------
442
 
443
      procedure Set_Special_Fill (N : Natural) is
444
         F : Natural;
445
 
446
      begin
447
         F := Fore + 1 + Aft - N;
448
 
449
         if Exp /= 0 then
450
            F := F + Exp + 1;
451
         end if;
452
 
453
         for J in 1 .. F loop
454
            Set ('*');
455
         end loop;
456
      end Set_Special_Fill;
457
 
458
      ---------------
459
      -- Set_Zeros --
460
      ---------------
461
 
462
      procedure Set_Zeros (N : Integer) is
463
      begin
464
         for J in 1 .. N loop
465
            Set ('0');
466
         end loop;
467
      end Set_Zeros;
468
 
469
   --  Start of processing for Set_Image_Real
470
 
471
   begin
472
      --  We call the floating-point processor reset routine so that we can
473
      --  be sure the floating-point processor is properly set for conversion
474
      --  calls. This is notably need on Windows, where calls to the operating
475
      --  system randomly reset the processor into 64-bit mode.
476
 
477
      System.Float_Control.Reset;
478
 
479
      Scale := 0;
480
 
481
      --  Deal with invalid values first,
482
 
483
      if not V'Valid then
484
 
485
         --  Note that we're taking our chances here, as V might be
486
         --  an invalid bit pattern resulting from erroneous execution
487
         --  (caused by using uninitialized variables for example).
488
 
489
         --  No matter what, we'll at least get reasonable behaviour,
490
         --  converting to infinity or some other value, or causing an
491
         --  exception to be raised is fine.
492
 
493
         --  If the following test succeeds, then we definitely have
494
         --  an infinite value, so we print Inf.
495
 
496
         if V > Long_Long_Float'Last then
497
            Set ('+');
498
            Set ('I');
499
            Set ('n');
500
            Set ('f');
501
            Set_Special_Fill (4);
502
 
503
         --  In all other cases we print NaN
504
 
505
         elsif V < Long_Long_Float'First then
506
            Set ('-');
507
            Set ('I');
508
            Set ('n');
509
            Set ('f');
510
            Set_Special_Fill (4);
511
 
512
         else
513
            Set ('N');
514
            Set ('a');
515
            Set ('N');
516
            Set_Special_Fill (3);
517
         end if;
518
 
519
         return;
520
      end if;
521
 
522
      --  Positive values
523
 
524
      if V > 0.0 then
525
         X := V;
526
         Sign := '+';
527
 
528
      --  Negative values
529
 
530
      elsif V < 0.0 then
531
         X := -V;
532
         Sign := '-';
533
 
534
      --  Zero values
535
 
536
      elsif V = 0.0 then
537
         if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then
538
            Sign := '-';
539
         else
540
            Sign := '+';
541
         end if;
542
 
543
         Set_Blanks_And_Sign (Fore - 1);
544
         Set ('0');
545
         Set ('.');
546
         Set_Zeros (NFrac);
547
 
548
         if Exp /= 0 then
549
            Set ('E');
550
            Set ('+');
551
            Set_Zeros (Natural'Max (1, Exp - 1));
552
         end if;
553
 
554
         return;
555
 
556
      else
557
         --  It should not be possible for a NaN to end up here.
558
         --  Either the 'Valid test has failed, or we have some form
559
         --  of erroneous execution. Raise Constraint_Error instead of
560
         --  attempting to go ahead printing the value.
561
 
562
         raise Constraint_Error;
563
      end if;
564
 
565
      --  X and Sign are set here, and X is known to be a valid,
566
      --  non-zero floating-point number.
567
 
568
      --  Case of non-zero value with Exp = 0
569
 
570
      if Exp = 0 then
571
 
572
         --  First step is to multiply by 10 ** Nfrac to get an integer
573
         --  value to be output, an then add 0.5 to round the result.
574
 
575
         declare
576
            NF : Natural := NFrac;
577
 
578
         begin
579
            loop
580
               --  If we are larger than Powten (Maxdigs) now, then
581
               --  we have too many significant digits, and we have
582
               --  not even finished multiplying by NFrac (NF shows
583
               --  the number of unaccounted-for digits).
584
 
585
               if X >= Powten (Maxdigs) then
586
 
587
                  --  In this situation, we only to generate a reasonable
588
                  --  number of significant digits, and then zeroes after.
589
                  --  So first we rescale to get:
590
 
591
                  --    10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs
592
 
593
                  --  and then convert the resulting integer
594
 
595
                  Adjust_Scale (Maxdigs);
596
                  Convert_Integer;
597
 
598
                  --  If that caused rescaling, then add zeros to the end
599
                  --  of the number to account for this scaling. Also add
600
                  --  zeroes to account for the undone multiplications
601
 
602
                  for J in 1 .. Scale + NF loop
603
                     Ndigs := Ndigs + 1;
604
                     Digs (Ndigs) := '0';
605
                  end loop;
606
 
607
                  exit;
608
 
609
               --  If multiplication is complete, then convert the resulting
610
               --  integer after rounding (note that X is non-negative)
611
 
612
               elsif NF = 0 then
613
                  X := X + 0.5;
614
                  Convert_Integer;
615
                  exit;
616
 
617
               --  Otherwise we can go ahead with the multiplication. If it
618
               --  can be done in one step, then do it in one step.
619
 
620
               elsif NF < Maxpow then
621
                  X := X * Powten (NF);
622
                  NF := 0;
623
 
624
               --  If it cannot be done in one step, then do partial scaling
625
 
626
               else
627
                  X := X * Powten (Maxpow);
628
                  NF := NF - Maxpow;
629
               end if;
630
            end loop;
631
         end;
632
 
633
         --  If number of available digits is less or equal to NFrac,
634
         --  then we need an extra zero before the decimal point.
635
 
636
         if Ndigs <= NFrac then
637
            Set_Blanks_And_Sign (Fore - 1);
638
            Set ('0');
639
            Set ('.');
640
            Set_Zeros (NFrac - Ndigs);
641
            Set_Digs (1, Ndigs);
642
 
643
         --  Normal case with some digits before the decimal point
644
 
645
         else
646
            Set_Blanks_And_Sign (Fore - (Ndigs - NFrac));
647
            Set_Digs (1, Ndigs - NFrac);
648
            Set ('.');
649
            Set_Digs (Ndigs - NFrac + 1, Ndigs);
650
         end if;
651
 
652
      --  Case of non-zero value with non-zero Exp value
653
 
654
      else
655
         --  If NFrac is less than Maxdigs, then all the fraction digits are
656
         --  significant, so we can scale the resulting integer accordingly.
657
 
658
         if NFrac < Maxdigs then
659
            Adjust_Scale (NFrac + 1);
660
            Convert_Integer;
661
 
662
         --  Otherwise, we get the maximum number of digits available
663
 
664
         else
665
            Adjust_Scale (Maxdigs);
666
            Convert_Integer;
667
 
668
            for J in 1 .. NFrac - Maxdigs + 1 loop
669
               Ndigs := Ndigs + 1;
670
               Digs (Ndigs) := '0';
671
               Scale := Scale - 1;
672
            end loop;
673
         end if;
674
 
675
         Set_Blanks_And_Sign (Fore - 1);
676
         Set (Digs (1));
677
         Set ('.');
678
         Set_Digs (2, Ndigs);
679
 
680
         --  The exponent is the scaling factor adjusted for the digits
681
         --  that we output after the decimal point, since these were
682
         --  included in the scaled digits that we output.
683
 
684
         Expon := Scale + NFrac;
685
 
686
         Set ('E');
687
         Ndigs := 0;
688
 
689
         if Expon >= 0 then
690
            Set ('+');
691
            Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs);
692
         else
693
            Set ('-');
694
            Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs);
695
         end if;
696
 
697
         Set_Zeros (Exp - Ndigs - 1);
698
         Set_Digs (1, Ndigs);
699
      end if;
700
 
701
   end Set_Image_Real;
702
 
703
end System.Img_Real;

powered by: WebSVN 2.1.0

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