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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [s-fatgen.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                       S Y S T E M . F A T _ G E N                        --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, 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
--  The implementation here is portable to any IEEE implementation. It does
33
--  not handle non-binary radix, and also assumes that model numbers and
34
--  machine numbers are basically identical, which is not true of all possible
35
--  floating-point implementations. On a non-IEEE machine, this body must be
36
--  specialized appropriately, or better still, its generic instantiations
37
--  should be replaced by efficient machine-specific code.
38
 
39
with Ada.Unchecked_Conversion;
40
with System;
41
package body System.Fat_Gen is
42
 
43
   Float_Radix        : constant T := T (T'Machine_Radix);
44
   Radix_To_M_Minus_1 : constant T := Float_Radix ** (T'Machine_Mantissa - 1);
45
 
46
   pragma Assert (T'Machine_Radix = 2);
47
   --  This version does not handle radix 16
48
 
49
   --  Constants for Decompose and Scaling
50
 
51
   Rad    : constant T := T (T'Machine_Radix);
52
   Invrad : constant T := 1.0 / Rad;
53
 
54
   subtype Expbits is Integer range 0 .. 6;
55
   --  2 ** (2 ** 7) might overflow.  How big can radix-16 exponents get?
56
 
57
   Log_Power : constant array (Expbits) of Integer := (1, 2, 4, 8, 16, 32, 64);
58
 
59
   R_Power : constant array (Expbits) of T :=
60
     (Rad **  1,
61
      Rad **  2,
62
      Rad **  4,
63
      Rad **  8,
64
      Rad ** 16,
65
      Rad ** 32,
66
      Rad ** 64);
67
 
68
   R_Neg_Power : constant array (Expbits) of T :=
69
     (Invrad **  1,
70
      Invrad **  2,
71
      Invrad **  4,
72
      Invrad **  8,
73
      Invrad ** 16,
74
      Invrad ** 32,
75
      Invrad ** 64);
76
 
77
   -----------------------
78
   -- Local Subprograms --
79
   -----------------------
80
 
81
   procedure Decompose (XX : T; Frac : out T; Expo : out UI);
82
   --  Decomposes a floating-point number into fraction and exponent parts.
83
   --  Both results are signed, with Frac having the sign of XX, and UI has
84
   --  the sign of the exponent. The absolute value of Frac is in the range
85
   --  0.0 <= Frac < 1.0. If Frac = 0.0 or -0.0, then Expo is always zero.
86
 
87
   function Gradual_Scaling  (Adjustment : UI) return T;
88
   --  Like Scaling with a first argument of 1.0, but returns the smallest
89
   --  denormal rather than zero when the adjustment is smaller than
90
   --  Machine_Emin. Used for Succ and Pred.
91
 
92
   --------------
93
   -- Adjacent --
94
   --------------
95
 
96
   function Adjacent (X, Towards : T) return T is
97
   begin
98
      if Towards = X then
99
         return X;
100
      elsif Towards > X then
101
         return Succ (X);
102
      else
103
         return Pred (X);
104
      end if;
105
   end Adjacent;
106
 
107
   -------------
108
   -- Ceiling --
109
   -------------
110
 
111
   function Ceiling (X : T) return T is
112
      XT : constant T := Truncation (X);
113
   begin
114
      if X <= 0.0 then
115
         return XT;
116
      elsif X = XT then
117
         return X;
118
      else
119
         return XT + 1.0;
120
      end if;
121
   end Ceiling;
122
 
123
   -------------
124
   -- Compose --
125
   -------------
126
 
127
   function Compose (Fraction : T; Exponent : UI) return T is
128
      Arg_Frac : T;
129
      Arg_Exp  : UI;
130
      pragma Unreferenced (Arg_Exp);
131
   begin
132
      Decompose (Fraction, Arg_Frac, Arg_Exp);
133
      return Scaling (Arg_Frac, Exponent);
134
   end Compose;
135
 
136
   ---------------
137
   -- Copy_Sign --
138
   ---------------
139
 
140
   function Copy_Sign (Value, Sign : T) return T is
141
      Result : T;
142
 
143
      function Is_Negative (V : T) return Boolean;
144
      pragma Import (Intrinsic, Is_Negative);
145
 
146
   begin
147
      Result := abs Value;
148
 
149
      if Is_Negative (Sign) then
150
         return -Result;
151
      else
152
         return Result;
153
      end if;
154
   end Copy_Sign;
155
 
156
   ---------------
157
   -- Decompose --
158
   ---------------
159
 
160
   procedure Decompose (XX : T; Frac : out T; Expo : out UI) is
161
      X : constant T := T'Machine (XX);
162
 
163
   begin
164
      if X = 0.0 then
165
         Frac := X;
166
         Expo := 0;
167
 
168
         --  More useful would be defining Expo to be T'Machine_Emin - 1 or
169
         --  T'Machine_Emin - T'Machine_Mantissa, which would preserve
170
         --  monotonicity of the exponent function ???
171
 
172
      --  Check for infinities, transfinites, whatnot
173
 
174
      elsif X > T'Safe_Last then
175
         Frac := Invrad;
176
         Expo := T'Machine_Emax + 1;
177
 
178
      elsif X < T'Safe_First then
179
         Frac := -Invrad;
180
         Expo := T'Machine_Emax + 2;    -- how many extra negative values?
181
 
182
      else
183
         --  Case of nonzero finite x. Essentially, we just multiply
184
         --  by Rad ** (+-2**N) to reduce the range.
185
 
186
         declare
187
            Ax : T  := abs X;
188
            Ex : UI := 0;
189
 
190
         --  Ax * Rad ** Ex is invariant
191
 
192
         begin
193
            if Ax >= 1.0 then
194
               while Ax >= R_Power (Expbits'Last) loop
195
                  Ax := Ax * R_Neg_Power (Expbits'Last);
196
                  Ex := Ex + Log_Power (Expbits'Last);
197
               end loop;
198
 
199
               --  Ax < Rad ** 64
200
 
201
               for N in reverse Expbits'First .. Expbits'Last - 1 loop
202
                  if Ax >= R_Power (N) then
203
                     Ax := Ax * R_Neg_Power (N);
204
                     Ex := Ex + Log_Power (N);
205
                  end if;
206
 
207
                  --  Ax < R_Power (N)
208
               end loop;
209
 
210
               --  1 <= Ax < Rad
211
 
212
               Ax := Ax * Invrad;
213
               Ex := Ex + 1;
214
 
215
            else
216
               --  0 < ax < 1
217
 
218
               while Ax < R_Neg_Power (Expbits'Last) loop
219
                  Ax := Ax * R_Power (Expbits'Last);
220
                  Ex := Ex - Log_Power (Expbits'Last);
221
               end loop;
222
 
223
               --  Rad ** -64 <= Ax < 1
224
 
225
               for N in reverse Expbits'First .. Expbits'Last - 1 loop
226
                  if Ax < R_Neg_Power (N) then
227
                     Ax := Ax * R_Power (N);
228
                     Ex := Ex - Log_Power (N);
229
                  end if;
230
 
231
                  --  R_Neg_Power (N) <= Ax < 1
232
               end loop;
233
            end if;
234
 
235
            Frac := (if X > 0.0 then Ax else -Ax);
236
            Expo := Ex;
237
         end;
238
      end if;
239
   end Decompose;
240
 
241
   --------------
242
   -- Exponent --
243
   --------------
244
 
245
   function Exponent (X : T) return UI is
246
      X_Frac : T;
247
      X_Exp  : UI;
248
      pragma Unreferenced (X_Frac);
249
   begin
250
      Decompose (X, X_Frac, X_Exp);
251
      return X_Exp;
252
   end Exponent;
253
 
254
   -----------
255
   -- Floor --
256
   -----------
257
 
258
   function Floor (X : T) return T is
259
      XT : constant T := Truncation (X);
260
   begin
261
      if X >= 0.0 then
262
         return XT;
263
      elsif XT = X then
264
         return X;
265
      else
266
         return XT - 1.0;
267
      end if;
268
   end Floor;
269
 
270
   --------------
271
   -- Fraction --
272
   --------------
273
 
274
   function Fraction (X : T) return T is
275
      X_Frac : T;
276
      X_Exp  : UI;
277
      pragma Unreferenced (X_Exp);
278
   begin
279
      Decompose (X, X_Frac, X_Exp);
280
      return X_Frac;
281
   end Fraction;
282
 
283
   ---------------------
284
   -- Gradual_Scaling --
285
   ---------------------
286
 
287
   function Gradual_Scaling  (Adjustment : UI) return T is
288
      Y  : T;
289
      Y1 : T;
290
      Ex : UI := Adjustment;
291
 
292
   begin
293
      if Adjustment < T'Machine_Emin - 1 then
294
         Y  := 2.0 ** T'Machine_Emin;
295
         Y1 := Y;
296
         Ex := Ex - T'Machine_Emin;
297
         while Ex < 0 loop
298
            Y := T'Machine (Y / 2.0);
299
 
300
            if Y = 0.0 then
301
               return Y1;
302
            end if;
303
 
304
            Ex := Ex + 1;
305
            Y1 := Y;
306
         end loop;
307
 
308
         return Y1;
309
 
310
      else
311
         return Scaling (1.0, Adjustment);
312
      end if;
313
   end Gradual_Scaling;
314
 
315
   ------------------
316
   -- Leading_Part --
317
   ------------------
318
 
319
   function Leading_Part (X : T; Radix_Digits : UI) return T is
320
      L    : UI;
321
      Y, Z : T;
322
 
323
   begin
324
      if Radix_Digits >= T'Machine_Mantissa then
325
         return X;
326
 
327
      elsif Radix_Digits <= 0 then
328
         raise Constraint_Error;
329
 
330
      else
331
         L := Exponent (X) - Radix_Digits;
332
         Y := Truncation (Scaling (X, -L));
333
         Z := Scaling (Y, L);
334
         return Z;
335
      end if;
336
   end Leading_Part;
337
 
338
   -------------
339
   -- Machine --
340
   -------------
341
 
342
   --  The trick with Machine is to force the compiler to store the result
343
   --  in memory so that we do not have extra precision used. The compiler
344
   --  is clever, so we have to outwit its possible optimizations! We do
345
   --  this by using an intermediate pragma Volatile location.
346
 
347
   function Machine (X : T) return T is
348
      Temp : T;
349
      pragma Volatile (Temp);
350
   begin
351
      Temp := X;
352
      return Temp;
353
   end Machine;
354
 
355
   ----------------------
356
   -- Machine_Rounding --
357
   ----------------------
358
 
359
   --  For now, the implementation is identical to that of Rounding, which is
360
   --  a permissible behavior, but is not the most efficient possible approach.
361
 
362
   function Machine_Rounding (X : T) return T is
363
      Result : T;
364
      Tail   : T;
365
 
366
   begin
367
      Result := Truncation (abs X);
368
      Tail   := abs X - Result;
369
 
370
      if Tail >= 0.5  then
371
         Result := Result + 1.0;
372
      end if;
373
 
374
      if X > 0.0 then
375
         return Result;
376
 
377
      elsif X < 0.0 then
378
         return -Result;
379
 
380
      --  For zero case, make sure sign of zero is preserved
381
 
382
      else
383
         return X;
384
      end if;
385
   end Machine_Rounding;
386
 
387
   -----------
388
   -- Model --
389
   -----------
390
 
391
   --  We treat Model as identical to Machine. This is true of IEEE and other
392
   --  nice floating-point systems, but not necessarily true of all systems.
393
 
394
   function Model (X : T) return T is
395
   begin
396
      return Machine (X);
397
   end Model;
398
 
399
   ----------
400
   -- Pred --
401
   ----------
402
 
403
   --  Subtract from the given number a number equivalent to the value of its
404
   --  least significant bit. Given that the most significant bit represents
405
   --  a value of 1.0 * radix ** (exp - 1), the value we want is obtained by
406
   --  shifting this by (mantissa-1) bits to the right, i.e. decreasing the
407
   --  exponent by that amount.
408
 
409
   --  Zero has to be treated specially, since its exponent is zero
410
 
411
   function Pred (X : T) return T is
412
      X_Frac : T;
413
      X_Exp  : UI;
414
 
415
   begin
416
      if X = 0.0 then
417
         return -Succ (X);
418
 
419
      else
420
         Decompose (X, X_Frac, X_Exp);
421
 
422
         --  A special case, if the number we had was a positive power of
423
         --  two, then we want to subtract half of what we would otherwise
424
         --  subtract, since the exponent is going to be reduced.
425
 
426
         --  Note that X_Frac has the same sign as X, so if X_Frac is 0.5,
427
         --  then we know that we have a positive number (and hence a
428
         --  positive power of 2).
429
 
430
         if X_Frac = 0.5 then
431
            return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1);
432
 
433
         --  Otherwise the exponent is unchanged
434
 
435
         else
436
            return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa);
437
         end if;
438
      end if;
439
   end Pred;
440
 
441
   ---------------
442
   -- Remainder --
443
   ---------------
444
 
445
   function Remainder (X, Y : T) return T is
446
      A        : T;
447
      B        : T;
448
      Arg      : T;
449
      P        : T;
450
      P_Frac   : T;
451
      Sign_X   : T;
452
      IEEE_Rem : T;
453
      Arg_Exp  : UI;
454
      P_Exp    : UI;
455
      K        : UI;
456
      P_Even   : Boolean;
457
 
458
      Arg_Frac : T;
459
      pragma Unreferenced (Arg_Frac);
460
 
461
   begin
462
      if Y = 0.0 then
463
         raise Constraint_Error;
464
      end if;
465
 
466
      if X > 0.0 then
467
         Sign_X :=  1.0;
468
         Arg := X;
469
      else
470
         Sign_X := -1.0;
471
         Arg := -X;
472
      end if;
473
 
474
      P := abs Y;
475
 
476
      if Arg < P then
477
         P_Even := True;
478
         IEEE_Rem := Arg;
479
         P_Exp := Exponent (P);
480
 
481
      else
482
         Decompose (Arg, Arg_Frac, Arg_Exp);
483
         Decompose (P,   P_Frac,   P_Exp);
484
 
485
         P := Compose (P_Frac, Arg_Exp);
486
         K := Arg_Exp - P_Exp;
487
         P_Even := True;
488
         IEEE_Rem := Arg;
489
 
490
         for Cnt in reverse 0 .. K loop
491
            if IEEE_Rem >= P then
492
               P_Even := False;
493
               IEEE_Rem := IEEE_Rem - P;
494
            else
495
               P_Even := True;
496
            end if;
497
 
498
            P := P * 0.5;
499
         end loop;
500
      end if;
501
 
502
      --  That completes the calculation of modulus remainder. The final
503
      --  step is get the IEEE remainder. Here we need to compare Rem with
504
      --  (abs Y) / 2. We must be careful of unrepresentable Y/2 value
505
      --  caused by subnormal numbers
506
 
507
      if P_Exp >= 0 then
508
         A := IEEE_Rem;
509
         B := abs Y * 0.5;
510
 
511
      else
512
         A := IEEE_Rem * 2.0;
513
         B := abs Y;
514
      end if;
515
 
516
      if A > B or else (A = B and then not P_Even) then
517
         IEEE_Rem := IEEE_Rem - abs Y;
518
      end if;
519
 
520
      return Sign_X * IEEE_Rem;
521
   end Remainder;
522
 
523
   --------------
524
   -- Rounding --
525
   --------------
526
 
527
   function Rounding (X : T) return T is
528
      Result : T;
529
      Tail   : T;
530
 
531
   begin
532
      Result := Truncation (abs X);
533
      Tail   := abs X - Result;
534
 
535
      if Tail >= 0.5  then
536
         Result := Result + 1.0;
537
      end if;
538
 
539
      if X > 0.0 then
540
         return Result;
541
 
542
      elsif X < 0.0 then
543
         return -Result;
544
 
545
      --  For zero case, make sure sign of zero is preserved
546
 
547
      else
548
         return X;
549
      end if;
550
   end Rounding;
551
 
552
   -------------
553
   -- Scaling --
554
   -------------
555
 
556
   --  Return x * rad ** adjustment quickly,
557
   --  or quietly underflow to zero, or overflow naturally.
558
 
559
   function Scaling (X : T; Adjustment : UI) return T is
560
   begin
561
      if X = 0.0 or else Adjustment = 0 then
562
         return X;
563
      end if;
564
 
565
      --  Nonzero x essentially, just multiply repeatedly by Rad ** (+-2**n)
566
 
567
      declare
568
         Y  : T  := X;
569
         Ex : UI := Adjustment;
570
 
571
      --  Y * Rad ** Ex is invariant
572
 
573
      begin
574
         if Ex < 0 then
575
            while Ex <= -Log_Power (Expbits'Last) loop
576
               Y := Y * R_Neg_Power (Expbits'Last);
577
               Ex := Ex + Log_Power (Expbits'Last);
578
            end loop;
579
 
580
            --  -64 < Ex <= 0
581
 
582
            for N in reverse Expbits'First .. Expbits'Last - 1 loop
583
               if Ex <= -Log_Power (N) then
584
                  Y := Y * R_Neg_Power (N);
585
                  Ex := Ex + Log_Power (N);
586
               end if;
587
 
588
               --  -Log_Power (N) < Ex <= 0
589
            end loop;
590
 
591
            --  Ex = 0
592
 
593
         else
594
            --  Ex >= 0
595
 
596
            while Ex >= Log_Power (Expbits'Last) loop
597
               Y := Y * R_Power (Expbits'Last);
598
               Ex := Ex - Log_Power (Expbits'Last);
599
            end loop;
600
 
601
            --  0 <= Ex < 64
602
 
603
            for N in reverse Expbits'First .. Expbits'Last - 1 loop
604
               if Ex >= Log_Power (N) then
605
                  Y := Y * R_Power (N);
606
                  Ex := Ex - Log_Power (N);
607
               end if;
608
 
609
               --  0 <= Ex < Log_Power (N)
610
 
611
            end loop;
612
 
613
            --  Ex = 0
614
         end if;
615
 
616
         return Y;
617
      end;
618
   end Scaling;
619
 
620
   ----------
621
   -- Succ --
622
   ----------
623
 
624
   --  Similar computation to that of Pred: find value of least significant
625
   --  bit of given number, and add. Zero has to be treated specially since
626
   --  the exponent can be zero, and also we want the smallest denormal if
627
   --  denormals are supported.
628
 
629
   function Succ (X : T) return T is
630
      X_Frac : T;
631
      X_Exp  : UI;
632
      X1, X2 : T;
633
 
634
   begin
635
      if X = 0.0 then
636
         X1 := 2.0 ** T'Machine_Emin;
637
 
638
         --  Following loop generates smallest denormal
639
 
640
         loop
641
            X2 := T'Machine (X1 / 2.0);
642
            exit when X2 = 0.0;
643
            X1 := X2;
644
         end loop;
645
 
646
         return X1;
647
 
648
      else
649
         Decompose (X, X_Frac, X_Exp);
650
 
651
         --  A special case, if the number we had was a negative power of
652
         --  two, then we want to add half of what we would otherwise add,
653
         --  since the exponent is going to be reduced.
654
 
655
         --  Note that X_Frac has the same sign as X, so if X_Frac is -0.5,
656
         --  then we know that we have a negative number (and hence a
657
         --  negative power of 2).
658
 
659
         if X_Frac = -0.5 then
660
            return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1);
661
 
662
         --  Otherwise the exponent is unchanged
663
 
664
         else
665
            return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa);
666
         end if;
667
      end if;
668
   end Succ;
669
 
670
   ----------------
671
   -- Truncation --
672
   ----------------
673
 
674
   --  The basic approach is to compute
675
 
676
   --    T'Machine (RM1 + N) - RM1
677
 
678
   --  where N >= 0.0 and RM1 = radix ** (mantissa - 1)
679
 
680
   --  This works provided that the intermediate result (RM1 + N) does not
681
   --  have extra precision (which is why we call Machine). When we compute
682
   --  RM1 + N, the exponent of N will be normalized and the mantissa shifted
683
   --  shifted appropriately so the lower order bits, which cannot contribute
684
   --  to the integer part of N, fall off on the right. When we subtract RM1
685
   --  again, the significant bits of N are shifted to the left, and what we
686
   --  have is an integer, because only the first e bits are different from
687
   --  zero (assuming binary radix here).
688
 
689
   function Truncation (X : T) return T is
690
      Result : T;
691
 
692
   begin
693
      Result := abs X;
694
 
695
      if Result >= Radix_To_M_Minus_1 then
696
         return Machine (X);
697
 
698
      else
699
         Result := Machine (Radix_To_M_Minus_1 + Result) - Radix_To_M_Minus_1;
700
 
701
         if Result > abs X  then
702
            Result := Result - 1.0;
703
         end if;
704
 
705
         if X > 0.0 then
706
            return  Result;
707
 
708
         elsif X < 0.0 then
709
            return -Result;
710
 
711
         --  For zero case, make sure sign of zero is preserved
712
 
713
         else
714
            return X;
715
         end if;
716
      end if;
717
   end Truncation;
718
 
719
   -----------------------
720
   -- Unbiased_Rounding --
721
   -----------------------
722
 
723
   function Unbiased_Rounding (X : T) return T is
724
      Abs_X  : constant T := abs X;
725
      Result : T;
726
      Tail   : T;
727
 
728
   begin
729
      Result := Truncation (Abs_X);
730
      Tail   := Abs_X - Result;
731
 
732
      if Tail > 0.5  then
733
         Result := Result + 1.0;
734
 
735
      elsif Tail = 0.5 then
736
         Result := 2.0 * Truncation ((Result / 2.0) + 0.5);
737
      end if;
738
 
739
      if X > 0.0 then
740
         return Result;
741
 
742
      elsif X < 0.0 then
743
         return -Result;
744
 
745
      --  For zero case, make sure sign of zero is preserved
746
 
747
      else
748
         return X;
749
      end if;
750
   end Unbiased_Rounding;
751
 
752
   -----------
753
   -- Valid --
754
   -----------
755
 
756
   --  Note: this routine does not work for VAX float. We compensate for this
757
   --  in Exp_Attr by using the Valid functions in Vax_Float_Operations rather
758
   --  than the corresponding instantiation of this function.
759
 
760
   function Valid (X : not null access T) return Boolean is
761
 
762
      IEEE_Emin : constant Integer := T'Machine_Emin - 1;
763
      IEEE_Emax : constant Integer := T'Machine_Emax - 1;
764
 
765
      IEEE_Bias : constant Integer := -(IEEE_Emin - 1);
766
 
767
      subtype IEEE_Exponent_Range is
768
        Integer range IEEE_Emin - 1 .. IEEE_Emax + 1;
769
 
770
      --  The implementation of this floating point attribute uses a
771
      --  representation type Float_Rep that allows direct access to the
772
      --  exponent and mantissa parts of a floating point number.
773
 
774
      --  The Float_Rep type is an array of Float_Word elements. This
775
      --  representation is chosen to make it possible to size the type based
776
      --  on a generic parameter. Since the array size is known at compile
777
      --  time, efficient code can still be generated. The size of Float_Word
778
      --  elements should be large enough to allow accessing the exponent in
779
      --  one read, but small enough so that all floating point object sizes
780
      --  are a multiple of the Float_Word'Size.
781
 
782
      --  The following conditions must be met for all possible
783
      --  instantiations of the attributes package:
784
 
785
      --    - T'Size is an integral multiple of Float_Word'Size
786
 
787
      --    - The exponent and sign are completely contained in a single
788
      --      component of Float_Rep, named Most_Significant_Word (MSW).
789
 
790
      --    - The sign occupies the most significant bit of the MSW and the
791
      --      exponent is in the following bits. Unused bits (if any) are in
792
      --      the least significant part.
793
 
794
      type Float_Word is mod 2**Positive'Min (System.Word_Size, 32);
795
      type Rep_Index is range 0 .. 7;
796
 
797
      Rep_Words : constant Positive :=
798
         (T'Size + Float_Word'Size - 1) / Float_Word'Size;
799
      Rep_Last  : constant Rep_Index := Rep_Index'Min
800
        (Rep_Index (Rep_Words - 1), (T'Mantissa + 16) / Float_Word'Size);
801
      --  Determine the number of Float_Words needed for representing the
802
      --  entire floating-point value. Do not take into account excessive
803
      --  padding, as occurs on IA-64 where 80 bits floats get padded to 128
804
      --  bits. In general, the exponent field cannot be larger than 15 bits,
805
      --  even for 128-bit floating-point types, so the final format size
806
      --  won't be larger than T'Mantissa + 16.
807
 
808
      type Float_Rep is
809
         array (Rep_Index range 0 .. Rep_Index (Rep_Words - 1)) of Float_Word;
810
 
811
      pragma Suppress_Initialization (Float_Rep);
812
      --  This pragma suppresses the generation of an initialization procedure
813
      --  for type Float_Rep when operating in Initialize/Normalize_Scalars
814
      --  mode. This is not just a matter of efficiency, but of functionality,
815
      --  since Valid has a pragma Inline_Always, which is not permitted if
816
      --  there are nested subprograms present.
817
 
818
      Most_Significant_Word : constant Rep_Index :=
819
                                Rep_Last * Standard'Default_Bit_Order;
820
      --  Finding the location of the Exponent_Word is a bit tricky. In general
821
      --  we assume Word_Order = Bit_Order. This expression needs to be refined
822
      --  for VMS.
823
 
824
      Exponent_Factor : constant Float_Word :=
825
                          2**(Float_Word'Size - 1) /
826
                            Float_Word (IEEE_Emax - IEEE_Emin + 3) *
827
                              Boolean'Pos (Most_Significant_Word /= 2) +
828
                                Boolean'Pos (Most_Significant_Word = 2);
829
      --  Factor that the extracted exponent needs to be divided by to be in
830
      --  range 0 .. IEEE_Emax - IEEE_Emin + 2. Special kludge: Exponent_Factor
831
      --  is 1 for x86/IA64 double extended as GCC adds unused bits to the
832
      --  type.
833
 
834
      Exponent_Mask : constant Float_Word :=
835
                        Float_Word (IEEE_Emax - IEEE_Emin + 2) *
836
                          Exponent_Factor;
837
      --  Value needed to mask out the exponent field. This assumes that the
838
      --  range IEEE_Emin - 1 .. IEEE_Emax + contains 2**N values, for some N
839
      --  in Natural.
840
 
841
      function To_Float is new Ada.Unchecked_Conversion (Float_Rep, T);
842
 
843
      type Float_Access is access all T;
844
      function To_Address is
845
         new Ada.Unchecked_Conversion (Float_Access, System.Address);
846
 
847
      XA : constant System.Address := To_Address (Float_Access (X));
848
 
849
      R : Float_Rep;
850
      pragma Import (Ada, R);
851
      for R'Address use XA;
852
      --  R is a view of the input floating-point parameter. Note that we
853
      --  must avoid copying the actual bits of this parameter in float
854
      --  form (since it may be a signalling NaN.
855
 
856
      E  : constant IEEE_Exponent_Range :=
857
             Integer ((R (Most_Significant_Word) and Exponent_Mask) /
858
                                                        Exponent_Factor)
859
               - IEEE_Bias;
860
      --  Mask/Shift T to only get bits from the exponent. Then convert biased
861
      --  value to integer value.
862
 
863
      SR : Float_Rep;
864
      --  Float_Rep representation of significant of X.all
865
 
866
   begin
867
      if T'Denorm then
868
 
869
         --  All denormalized numbers are valid, so the only invalid numbers
870
         --  are overflows and NaNs, both with exponent = Emax + 1.
871
 
872
         return E /= IEEE_Emax + 1;
873
 
874
      end if;
875
 
876
      --  All denormalized numbers except 0.0 are invalid
877
 
878
      --  Set exponent of X to zero, so we end up with the significand, which
879
      --  definitely is a valid number and can be converted back to a float.
880
 
881
      SR := R;
882
      SR (Most_Significant_Word) :=
883
           (SR (Most_Significant_Word)
884
             and not Exponent_Mask) + Float_Word (IEEE_Bias) * Exponent_Factor;
885
 
886
      return (E in IEEE_Emin .. IEEE_Emax) or else
887
         ((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0);
888
   end Valid;
889
 
890
   ---------------------
891
   -- Unaligned_Valid --
892
   ---------------------
893
 
894
   function Unaligned_Valid (A : System.Address) return Boolean is
895
      subtype FS is String (1 .. T'Size / Character'Size);
896
      type FSP is access FS;
897
 
898
      function To_FSP is new Ada.Unchecked_Conversion (Address, FSP);
899
 
900
      Local_T : aliased T;
901
 
902
   begin
903
      --  Note that we have to be sure that we do not load the value into a
904
      --  floating-point register, since a signalling NaN may cause a trap.
905
      --  The following assignment is what does the actual alignment, since
906
      --  we know that the target Local_T is aligned.
907
 
908
      To_FSP (Local_T'Address).all := To_FSP (A).all;
909
 
910
      --  Now that we have an aligned value, we can use the normal aligned
911
      --  version of Valid to obtain the required result.
912
 
913
      return Valid (Local_T'Access);
914
   end Unaligned_Valid;
915
 
916
end System.Fat_Gen;

powered by: WebSVN 2.1.0

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