]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/ada/urealp.adb
Licensing changes to GPLv3 resp. GPLv3 with GCC Runtime Exception.
[thirdparty/gcc.git] / gcc / ada / urealp.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- U R E A L P --
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 with Alloc;
33 with Output; use Output;
34 with Table;
35 with Tree_IO; use Tree_IO;
36
37 package body Urealp is
38
39 Ureal_First_Entry : constant Ureal := Ureal'Succ (No_Ureal);
40 -- First subscript allocated in Ureal table (note that we can't just
41 -- add 1 to No_Ureal, since "+" means something different for Ureals!
42
43 type Ureal_Entry is record
44 Num : Uint;
45 -- Numerator (always non-negative)
46
47 Den : Uint;
48 -- Denominator (always non-zero, always positive if base is zero)
49
50 Rbase : Nat;
51 -- Base value. If Rbase is zero, then the value is simply Num / Den.
52 -- If Rbase is non-zero, then the value is Num / (Rbase ** Den)
53
54 Negative : Boolean;
55 -- Flag set if value is negative
56 end record;
57
58 -- The following representation clause ensures that the above record
59 -- has no holes. We do this so that when instances of this record are
60 -- written by Tree_Gen, we do not write uninitialized values to the file.
61
62 for Ureal_Entry use record
63 Num at 0 range 0 .. 31;
64 Den at 4 range 0 .. 31;
65 Rbase at 8 range 0 .. 31;
66 Negative at 12 range 0 .. 31;
67 end record;
68
69 for Ureal_Entry'Size use 16 * 8;
70 -- This ensures that we did not leave out any fields
71
72 package Ureals is new Table.Table (
73 Table_Component_Type => Ureal_Entry,
74 Table_Index_Type => Ureal'Base,
75 Table_Low_Bound => Ureal_First_Entry,
76 Table_Initial => Alloc.Ureals_Initial,
77 Table_Increment => Alloc.Ureals_Increment,
78 Table_Name => "Ureals");
79
80 -- The following universal reals are the values returned by the constant
81 -- functions. They are initialized by the initialization procedure.
82
83 UR_0 : Ureal;
84 UR_M_0 : Ureal;
85 UR_Tenth : Ureal;
86 UR_Half : Ureal;
87 UR_1 : Ureal;
88 UR_2 : Ureal;
89 UR_10 : Ureal;
90 UR_10_36 : Ureal;
91 UR_M_10_36 : Ureal;
92 UR_100 : Ureal;
93 UR_2_128 : Ureal;
94 UR_2_80 : Ureal;
95 UR_2_M_128 : Ureal;
96 UR_2_M_80 : Ureal;
97
98 Num_Ureal_Constants : constant := 10;
99 -- This is used for an assertion check in Tree_Read and Tree_Write to
100 -- help remember to add values to these routines when we add to the list.
101
102 Normalized_Real : Ureal := No_Ureal;
103 -- Used to memoize Norm_Num and Norm_Den, if either of these functions
104 -- is called, this value is set and Normalized_Entry contains the result
105 -- of the normalization. On subsequent calls, this is used to avoid the
106 -- call to Normalize if it has already been made.
107
108 Normalized_Entry : Ureal_Entry;
109 -- Entry built by most recent call to Normalize
110
111 -----------------------
112 -- Local Subprograms --
113 -----------------------
114
115 function Decimal_Exponent_Hi (V : Ureal) return Int;
116 -- Returns an estimate of the exponent of Val represented as a normalized
117 -- decimal number (non-zero digit before decimal point), The estimate is
118 -- either correct, or high, but never low. The accuracy of the estimate
119 -- affects only the efficiency of the comparison routines.
120
121 function Decimal_Exponent_Lo (V : Ureal) return Int;
122 -- Returns an estimate of the exponent of Val represented as a normalized
123 -- decimal number (non-zero digit before decimal point), The estimate is
124 -- either correct, or low, but never high. The accuracy of the estimate
125 -- affects only the efficiency of the comparison routines.
126
127 function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int;
128 -- U is a Ureal entry for which the base value is non-zero, the value
129 -- returned is the equivalent decimal exponent value, i.e. the value of
130 -- Den, adjusted as though the base were base 10. The value is rounded
131 -- to the nearest integer, and so can be one off.
132
133 function Is_Integer (Num, Den : Uint) return Boolean;
134 -- Return true if the real quotient of Num / Den is an integer value
135
136 function Normalize (Val : Ureal_Entry) return Ureal_Entry;
137 -- Normalizes the Ureal_Entry by reducing it to lowest terms (with a
138 -- base value of 0).
139
140 function Same (U1, U2 : Ureal) return Boolean;
141 pragma Inline (Same);
142 -- Determines if U1 and U2 are the same Ureal. Note that we cannot use
143 -- the equals operator for this test, since that tests for equality,
144 -- not identity.
145
146 function Store_Ureal (Val : Ureal_Entry) return Ureal;
147 -- This store a new entry in the universal reals table and return
148 -- its index in the table.
149
150 -------------------------
151 -- Decimal_Exponent_Hi --
152 -------------------------
153
154 function Decimal_Exponent_Hi (V : Ureal) return Int is
155 Val : constant Ureal_Entry := Ureals.Table (V);
156
157 begin
158 -- Zero always returns zero
159
160 if UR_Is_Zero (V) then
161 return 0;
162
163 -- For numbers in rational form, get the maximum number of digits in the
164 -- numerator and the minimum number of digits in the denominator, and
165 -- subtract. For example:
166
167 -- 1000 / 99 = 1.010E+1
168 -- 9999 / 10 = 9.999E+2
169
170 -- This estimate may of course be high, but that is acceptable
171
172 elsif Val.Rbase = 0 then
173 return UI_Decimal_Digits_Hi (Val.Num) -
174 UI_Decimal_Digits_Lo (Val.Den);
175
176 -- For based numbers, just subtract the decimal exponent from the
177 -- high estimate of the number of digits in the numerator and add
178 -- one to accommodate possible round off errors for non-decimal
179 -- bases. For example:
180
181 -- 1_500_000 / 10**4 = 1.50E-2
182
183 else -- Val.Rbase /= 0
184 return UI_Decimal_Digits_Hi (Val.Num) -
185 Equivalent_Decimal_Exponent (Val) + 1;
186 end if;
187 end Decimal_Exponent_Hi;
188
189 -------------------------
190 -- Decimal_Exponent_Lo --
191 -------------------------
192
193 function Decimal_Exponent_Lo (V : Ureal) return Int is
194 Val : constant Ureal_Entry := Ureals.Table (V);
195
196 begin
197 -- Zero always returns zero
198
199 if UR_Is_Zero (V) then
200 return 0;
201
202 -- For numbers in rational form, get min digits in numerator, max digits
203 -- in denominator, and subtract and subtract one more for possible loss
204 -- during the division. For example:
205
206 -- 1000 / 99 = 1.010E+1
207 -- 9999 / 10 = 9.999E+2
208
209 -- This estimate may of course be low, but that is acceptable
210
211 elsif Val.Rbase = 0 then
212 return UI_Decimal_Digits_Lo (Val.Num) -
213 UI_Decimal_Digits_Hi (Val.Den) - 1;
214
215 -- For based numbers, just subtract the decimal exponent from the
216 -- low estimate of the number of digits in the numerator and subtract
217 -- one to accommodate possible round off errors for non-decimal
218 -- bases. For example:
219
220 -- 1_500_000 / 10**4 = 1.50E-2
221
222 else -- Val.Rbase /= 0
223 return UI_Decimal_Digits_Lo (Val.Num) -
224 Equivalent_Decimal_Exponent (Val) - 1;
225 end if;
226 end Decimal_Exponent_Lo;
227
228 -----------------
229 -- Denominator --
230 -----------------
231
232 function Denominator (Real : Ureal) return Uint is
233 begin
234 return Ureals.Table (Real).Den;
235 end Denominator;
236
237 ---------------------------------
238 -- Equivalent_Decimal_Exponent --
239 ---------------------------------
240
241 function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int is
242
243 -- The following table is a table of logs to the base 10
244
245 Logs : constant array (Nat range 1 .. 16) of Long_Float := (
246 1 => 0.000000000000000,
247 2 => 0.301029995663981,
248 3 => 0.477121254719662,
249 4 => 0.602059991327962,
250 5 => 0.698970004336019,
251 6 => 0.778151250383644,
252 7 => 0.845098040014257,
253 8 => 0.903089986991944,
254 9 => 0.954242509439325,
255 10 => 1.000000000000000,
256 11 => 1.041392685158230,
257 12 => 1.079181246047620,
258 13 => 1.113943352306840,
259 14 => 1.146128035678240,
260 15 => 1.176091259055680,
261 16 => 1.204119982655920);
262
263 begin
264 pragma Assert (U.Rbase /= 0);
265 return Int (Long_Float (UI_To_Int (U.Den)) * Logs (U.Rbase));
266 end Equivalent_Decimal_Exponent;
267
268 ----------------
269 -- Initialize --
270 ----------------
271
272 procedure Initialize is
273 begin
274 Ureals.Init;
275 UR_0 := UR_From_Components (Uint_0, Uint_1, 0, False);
276 UR_M_0 := UR_From_Components (Uint_0, Uint_1, 0, True);
277 UR_Half := UR_From_Components (Uint_1, Uint_1, 2, False);
278 UR_Tenth := UR_From_Components (Uint_1, Uint_1, 10, False);
279 UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False);
280 UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False);
281 UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False);
282 UR_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, False);
283 UR_M_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, True);
284 UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False);
285 UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False);
286 UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False);
287 UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False);
288 UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False);
289 end Initialize;
290
291 ----------------
292 -- Is_Integer --
293 ----------------
294
295 function Is_Integer (Num, Den : Uint) return Boolean is
296 begin
297 return (Num / Den) * Den = Num;
298 end Is_Integer;
299
300 ----------
301 -- Mark --
302 ----------
303
304 function Mark return Save_Mark is
305 begin
306 return Save_Mark (Ureals.Last);
307 end Mark;
308
309 --------------
310 -- Norm_Den --
311 --------------
312
313 function Norm_Den (Real : Ureal) return Uint is
314 begin
315 if not Same (Real, Normalized_Real) then
316 Normalized_Real := Real;
317 Normalized_Entry := Normalize (Ureals.Table (Real));
318 end if;
319
320 return Normalized_Entry.Den;
321 end Norm_Den;
322
323 --------------
324 -- Norm_Num --
325 --------------
326
327 function Norm_Num (Real : Ureal) return Uint is
328 begin
329 if not Same (Real, Normalized_Real) then
330 Normalized_Real := Real;
331 Normalized_Entry := Normalize (Ureals.Table (Real));
332 end if;
333
334 return Normalized_Entry.Num;
335 end Norm_Num;
336
337 ---------------
338 -- Normalize --
339 ---------------
340
341 function Normalize (Val : Ureal_Entry) return Ureal_Entry is
342 J : Uint;
343 K : Uint;
344 Tmp : Uint;
345 Num : Uint;
346 Den : Uint;
347 M : constant Uintp.Save_Mark := Uintp.Mark;
348
349 begin
350 -- Start by setting J to the greatest of the absolute values of the
351 -- numerator and the denominator (taking into account the base value),
352 -- and K to the lesser of the two absolute values. The gcd of Num and
353 -- Den is the gcd of J and K.
354
355 if Val.Rbase = 0 then
356 J := Val.Num;
357 K := Val.Den;
358
359 elsif Val.Den < 0 then
360 J := Val.Num * Val.Rbase ** (-Val.Den);
361 K := Uint_1;
362
363 else
364 J := Val.Num;
365 K := Val.Rbase ** Val.Den;
366 end if;
367
368 Num := J;
369 Den := K;
370
371 if K > J then
372 Tmp := J;
373 J := K;
374 K := Tmp;
375 end if;
376
377 J := UI_GCD (J, K);
378 Num := Num / J;
379 Den := Den / J;
380 Uintp.Release_And_Save (M, Num, Den);
381
382 -- Divide numerator and denominator by gcd and return result
383
384 return (Num => Num,
385 Den => Den,
386 Rbase => 0,
387 Negative => Val.Negative);
388 end Normalize;
389
390 ---------------
391 -- Numerator --
392 ---------------
393
394 function Numerator (Real : Ureal) return Uint is
395 begin
396 return Ureals.Table (Real).Num;
397 end Numerator;
398
399 --------
400 -- pr --
401 --------
402
403 procedure pr (Real : Ureal) is
404 begin
405 UR_Write (Real);
406 Write_Eol;
407 end pr;
408
409 -----------
410 -- Rbase --
411 -----------
412
413 function Rbase (Real : Ureal) return Nat is
414 begin
415 return Ureals.Table (Real).Rbase;
416 end Rbase;
417
418 -------------
419 -- Release --
420 -------------
421
422 procedure Release (M : Save_Mark) is
423 begin
424 Ureals.Set_Last (Ureal (M));
425 end Release;
426
427 ----------
428 -- Same --
429 ----------
430
431 function Same (U1, U2 : Ureal) return Boolean is
432 begin
433 return Int (U1) = Int (U2);
434 end Same;
435
436 -----------------
437 -- Store_Ureal --
438 -----------------
439
440 function Store_Ureal (Val : Ureal_Entry) return Ureal is
441 begin
442 Ureals.Append (Val);
443
444 -- Normalize representation of signed values
445
446 if Val.Num < 0 then
447 Ureals.Table (Ureals.Last).Negative := True;
448 Ureals.Table (Ureals.Last).Num := -Val.Num;
449 end if;
450
451 return Ureals.Last;
452 end Store_Ureal;
453
454 ---------------
455 -- Tree_Read --
456 ---------------
457
458 procedure Tree_Read is
459 begin
460 pragma Assert (Num_Ureal_Constants = 10);
461
462 Ureals.Tree_Read;
463 Tree_Read_Int (Int (UR_0));
464 Tree_Read_Int (Int (UR_M_0));
465 Tree_Read_Int (Int (UR_Tenth));
466 Tree_Read_Int (Int (UR_Half));
467 Tree_Read_Int (Int (UR_1));
468 Tree_Read_Int (Int (UR_2));
469 Tree_Read_Int (Int (UR_10));
470 Tree_Read_Int (Int (UR_100));
471 Tree_Read_Int (Int (UR_2_128));
472 Tree_Read_Int (Int (UR_2_M_128));
473
474 -- Clear the normalization cache
475
476 Normalized_Real := No_Ureal;
477 end Tree_Read;
478
479 ----------------
480 -- Tree_Write --
481 ----------------
482
483 procedure Tree_Write is
484 begin
485 pragma Assert (Num_Ureal_Constants = 10);
486
487 Ureals.Tree_Write;
488 Tree_Write_Int (Int (UR_0));
489 Tree_Write_Int (Int (UR_M_0));
490 Tree_Write_Int (Int (UR_Tenth));
491 Tree_Write_Int (Int (UR_Half));
492 Tree_Write_Int (Int (UR_1));
493 Tree_Write_Int (Int (UR_2));
494 Tree_Write_Int (Int (UR_10));
495 Tree_Write_Int (Int (UR_100));
496 Tree_Write_Int (Int (UR_2_128));
497 Tree_Write_Int (Int (UR_2_M_128));
498 end Tree_Write;
499
500 ------------
501 -- UR_Abs --
502 ------------
503
504 function UR_Abs (Real : Ureal) return Ureal is
505 Val : constant Ureal_Entry := Ureals.Table (Real);
506
507 begin
508 return Store_Ureal (
509 (Num => Val.Num,
510 Den => Val.Den,
511 Rbase => Val.Rbase,
512 Negative => False));
513 end UR_Abs;
514
515 ------------
516 -- UR_Add --
517 ------------
518
519 function UR_Add (Left : Uint; Right : Ureal) return Ureal is
520 begin
521 return UR_From_Uint (Left) + Right;
522 end UR_Add;
523
524 function UR_Add (Left : Ureal; Right : Uint) return Ureal is
525 begin
526 return Left + UR_From_Uint (Right);
527 end UR_Add;
528
529 function UR_Add (Left : Ureal; Right : Ureal) return Ureal is
530 Lval : Ureal_Entry := Ureals.Table (Left);
531 Rval : Ureal_Entry := Ureals.Table (Right);
532
533 Num : Uint;
534
535 begin
536 -- Note, in the temporary Ureal_Entry values used in this procedure,
537 -- we store the sign as the sign of the numerator (i.e. xxx.Num may
538 -- be negative, even though in stored entries this can never be so)
539
540 if Lval.Rbase /= 0 and then Lval.Rbase = Rval.Rbase then
541
542 declare
543 Opd_Min, Opd_Max : Ureal_Entry;
544 Exp_Min, Exp_Max : Uint;
545
546 begin
547 if Lval.Negative then
548 Lval.Num := (-Lval.Num);
549 end if;
550
551 if Rval.Negative then
552 Rval.Num := (-Rval.Num);
553 end if;
554
555 if Lval.Den < Rval.Den then
556 Exp_Min := Lval.Den;
557 Exp_Max := Rval.Den;
558 Opd_Min := Lval;
559 Opd_Max := Rval;
560 else
561 Exp_Min := Rval.Den;
562 Exp_Max := Lval.Den;
563 Opd_Min := Rval;
564 Opd_Max := Lval;
565 end if;
566
567 Num :=
568 Opd_Min.Num * Lval.Rbase ** (Exp_Max - Exp_Min) + Opd_Max.Num;
569
570 if Num = 0 then
571 return Store_Ureal (
572 (Num => Uint_0,
573 Den => Uint_1,
574 Rbase => 0,
575 Negative => Lval.Negative));
576
577 else
578 return Store_Ureal (
579 (Num => abs Num,
580 Den => Exp_Max,
581 Rbase => Lval.Rbase,
582 Negative => (Num < 0)));
583 end if;
584 end;
585
586 else
587 declare
588 Ln : Ureal_Entry := Normalize (Lval);
589 Rn : Ureal_Entry := Normalize (Rval);
590
591 begin
592 if Ln.Negative then
593 Ln.Num := (-Ln.Num);
594 end if;
595
596 if Rn.Negative then
597 Rn.Num := (-Rn.Num);
598 end if;
599
600 Num := (Ln.Num * Rn.Den) + (Rn.Num * Ln.Den);
601
602 if Num = 0 then
603 return Store_Ureal (
604 (Num => Uint_0,
605 Den => Uint_1,
606 Rbase => 0,
607 Negative => Lval.Negative));
608
609 else
610 return Store_Ureal (
611 Normalize (
612 (Num => abs Num,
613 Den => Ln.Den * Rn.Den,
614 Rbase => 0,
615 Negative => (Num < 0))));
616 end if;
617 end;
618 end if;
619 end UR_Add;
620
621 ----------------
622 -- UR_Ceiling --
623 ----------------
624
625 function UR_Ceiling (Real : Ureal) return Uint is
626 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
627
628 begin
629 if Val.Negative then
630 return UI_Negate (Val.Num / Val.Den);
631 else
632 return (Val.Num + Val.Den - 1) / Val.Den;
633 end if;
634 end UR_Ceiling;
635
636 ------------
637 -- UR_Div --
638 ------------
639
640 function UR_Div (Left : Uint; Right : Ureal) return Ureal is
641 begin
642 return UR_From_Uint (Left) / Right;
643 end UR_Div;
644
645 function UR_Div (Left : Ureal; Right : Uint) return Ureal is
646 begin
647 return Left / UR_From_Uint (Right);
648 end UR_Div;
649
650 function UR_Div (Left, Right : Ureal) return Ureal is
651 Lval : constant Ureal_Entry := Ureals.Table (Left);
652 Rval : constant Ureal_Entry := Ureals.Table (Right);
653 Rneg : constant Boolean := Rval.Negative xor Lval.Negative;
654
655 begin
656 pragma Assert (Rval.Num /= Uint_0);
657
658 if Lval.Rbase = 0 then
659
660 if Rval.Rbase = 0 then
661 return Store_Ureal (
662 Normalize (
663 (Num => Lval.Num * Rval.Den,
664 Den => Lval.Den * Rval.Num,
665 Rbase => 0,
666 Negative => Rneg)));
667
668 elsif Is_Integer (Lval.Num, Rval.Num * Lval.Den) then
669 return Store_Ureal (
670 (Num => Lval.Num / (Rval.Num * Lval.Den),
671 Den => (-Rval.Den),
672 Rbase => Rval.Rbase,
673 Negative => Rneg));
674
675 elsif Rval.Den < 0 then
676 return Store_Ureal (
677 Normalize (
678 (Num => Lval.Num,
679 Den => Rval.Rbase ** (-Rval.Den) *
680 Rval.Num *
681 Lval.Den,
682 Rbase => 0,
683 Negative => Rneg)));
684
685 else
686 return Store_Ureal (
687 Normalize (
688 (Num => Lval.Num * Rval.Rbase ** Rval.Den,
689 Den => Rval.Num * Lval.Den,
690 Rbase => 0,
691 Negative => Rneg)));
692 end if;
693
694 elsif Is_Integer (Lval.Num, Rval.Num) then
695
696 if Rval.Rbase = Lval.Rbase then
697 return Store_Ureal (
698 (Num => Lval.Num / Rval.Num,
699 Den => Lval.Den - Rval.Den,
700 Rbase => Lval.Rbase,
701 Negative => Rneg));
702
703 elsif Rval.Rbase = 0 then
704 return Store_Ureal (
705 (Num => (Lval.Num / Rval.Num) * Rval.Den,
706 Den => Lval.Den,
707 Rbase => Lval.Rbase,
708 Negative => Rneg));
709
710 elsif Rval.Den < 0 then
711 declare
712 Num, Den : Uint;
713
714 begin
715 if Lval.Den < 0 then
716 Num := (Lval.Num / Rval.Num) * (Lval.Rbase ** (-Lval.Den));
717 Den := Rval.Rbase ** (-Rval.Den);
718 else
719 Num := Lval.Num / Rval.Num;
720 Den := (Lval.Rbase ** Lval.Den) *
721 (Rval.Rbase ** (-Rval.Den));
722 end if;
723
724 return Store_Ureal (
725 (Num => Num,
726 Den => Den,
727 Rbase => 0,
728 Negative => Rneg));
729 end;
730
731 else
732 return Store_Ureal (
733 (Num => (Lval.Num / Rval.Num) *
734 (Rval.Rbase ** Rval.Den),
735 Den => Lval.Den,
736 Rbase => Lval.Rbase,
737 Negative => Rneg));
738 end if;
739
740 else
741 declare
742 Num, Den : Uint;
743
744 begin
745 if Lval.Den < 0 then
746 Num := Lval.Num * (Lval.Rbase ** (-Lval.Den));
747 Den := Rval.Num;
748
749 else
750 Num := Lval.Num;
751 Den := Rval.Num * (Lval.Rbase ** Lval.Den);
752 end if;
753
754 if Rval.Rbase /= 0 then
755 if Rval.Den < 0 then
756 Den := Den * (Rval.Rbase ** (-Rval.Den));
757 else
758 Num := Num * (Rval.Rbase ** Rval.Den);
759 end if;
760
761 else
762 Num := Num * Rval.Den;
763 end if;
764
765 return Store_Ureal (
766 Normalize (
767 (Num => Num,
768 Den => Den,
769 Rbase => 0,
770 Negative => Rneg)));
771 end;
772 end if;
773 end UR_Div;
774
775 -----------
776 -- UR_Eq --
777 -----------
778
779 function UR_Eq (Left, Right : Ureal) return Boolean is
780 begin
781 return not UR_Ne (Left, Right);
782 end UR_Eq;
783
784 ---------------------
785 -- UR_Exponentiate --
786 ---------------------
787
788 function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal is
789 X : constant Uint := abs N;
790 Bas : Ureal;
791 Val : Ureal_Entry;
792 Neg : Boolean;
793 IBas : Uint;
794
795 begin
796 -- If base is negative, then the resulting sign depends on whether
797 -- the exponent is even or odd (even => positive, odd = negative)
798
799 if UR_Is_Negative (Real) then
800 Neg := (N mod 2) /= 0;
801 Bas := UR_Negate (Real);
802 else
803 Neg := False;
804 Bas := Real;
805 end if;
806
807 Val := Ureals.Table (Bas);
808
809 -- If the base is a small integer, then we can return the result in
810 -- exponential form, which can save a lot of time for junk exponents.
811
812 IBas := UR_Trunc (Bas);
813
814 if IBas <= 16
815 and then UR_From_Uint (IBas) = Bas
816 then
817 return Store_Ureal (
818 (Num => Uint_1,
819 Den => -N,
820 Rbase => UI_To_Int (UR_Trunc (Bas)),
821 Negative => Neg));
822
823 -- If the exponent is negative then we raise the numerator and the
824 -- denominator (after normalization) to the absolute value of the
825 -- exponent and we return the reciprocal. An assert error will happen
826 -- if the numerator is zero.
827
828 elsif N < 0 then
829 pragma Assert (Val.Num /= 0);
830 Val := Normalize (Val);
831
832 return Store_Ureal (
833 (Num => Val.Den ** X,
834 Den => Val.Num ** X,
835 Rbase => 0,
836 Negative => Neg));
837
838 -- If positive, we distinguish the case when the base is not zero, in
839 -- which case the new denominator is just the product of the old one
840 -- with the exponent,
841
842 else
843 if Val.Rbase /= 0 then
844
845 return Store_Ureal (
846 (Num => Val.Num ** X,
847 Den => Val.Den * X,
848 Rbase => Val.Rbase,
849 Negative => Neg));
850
851 -- And when the base is zero, in which case we exponentiate
852 -- the old denominator.
853
854 else
855 return Store_Ureal (
856 (Num => Val.Num ** X,
857 Den => Val.Den ** X,
858 Rbase => 0,
859 Negative => Neg));
860 end if;
861 end if;
862 end UR_Exponentiate;
863
864 --------------
865 -- UR_Floor --
866 --------------
867
868 function UR_Floor (Real : Ureal) return Uint is
869 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
870
871 begin
872 if Val.Negative then
873 return UI_Negate ((Val.Num + Val.Den - 1) / Val.Den);
874 else
875 return Val.Num / Val.Den;
876 end if;
877 end UR_Floor;
878
879 ------------------------
880 -- UR_From_Components --
881 ------------------------
882
883 function UR_From_Components
884 (Num : Uint;
885 Den : Uint;
886 Rbase : Nat := 0;
887 Negative : Boolean := False)
888 return Ureal
889 is
890 begin
891 return Store_Ureal (
892 (Num => Num,
893 Den => Den,
894 Rbase => Rbase,
895 Negative => Negative));
896 end UR_From_Components;
897
898 ------------------
899 -- UR_From_Uint --
900 ------------------
901
902 function UR_From_Uint (UI : Uint) return Ureal is
903 begin
904 return UR_From_Components
905 (abs UI, Uint_1, Negative => (UI < 0));
906 end UR_From_Uint;
907
908 -----------
909 -- UR_Ge --
910 -----------
911
912 function UR_Ge (Left, Right : Ureal) return Boolean is
913 begin
914 return not (Left < Right);
915 end UR_Ge;
916
917 -----------
918 -- UR_Gt --
919 -----------
920
921 function UR_Gt (Left, Right : Ureal) return Boolean is
922 begin
923 return (Right < Left);
924 end UR_Gt;
925
926 --------------------
927 -- UR_Is_Negative --
928 --------------------
929
930 function UR_Is_Negative (Real : Ureal) return Boolean is
931 begin
932 return Ureals.Table (Real).Negative;
933 end UR_Is_Negative;
934
935 --------------------
936 -- UR_Is_Positive --
937 --------------------
938
939 function UR_Is_Positive (Real : Ureal) return Boolean is
940 begin
941 return not Ureals.Table (Real).Negative
942 and then Ureals.Table (Real).Num /= 0;
943 end UR_Is_Positive;
944
945 ----------------
946 -- UR_Is_Zero --
947 ----------------
948
949 function UR_Is_Zero (Real : Ureal) return Boolean is
950 begin
951 return Ureals.Table (Real).Num = 0;
952 end UR_Is_Zero;
953
954 -----------
955 -- UR_Le --
956 -----------
957
958 function UR_Le (Left, Right : Ureal) return Boolean is
959 begin
960 return not (Right < Left);
961 end UR_Le;
962
963 -----------
964 -- UR_Lt --
965 -----------
966
967 function UR_Lt (Left, Right : Ureal) return Boolean is
968 begin
969 -- An operand is not less than itself
970
971 if Same (Left, Right) then
972 return False;
973
974 -- Deal with zero cases
975
976 elsif UR_Is_Zero (Left) then
977 return UR_Is_Positive (Right);
978
979 elsif UR_Is_Zero (Right) then
980 return Ureals.Table (Left).Negative;
981
982 -- Different signs are decisive (note we dealt with zero cases)
983
984 elsif Ureals.Table (Left).Negative
985 and then not Ureals.Table (Right).Negative
986 then
987 return True;
988
989 elsif not Ureals.Table (Left).Negative
990 and then Ureals.Table (Right).Negative
991 then
992 return False;
993
994 -- Signs are same, do rapid check based on worst case estimates of
995 -- decimal exponent, which will often be decisive. Precise test
996 -- depends on whether operands are positive or negative.
997
998 elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) then
999 return UR_Is_Positive (Left);
1000
1001 elsif Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right) then
1002 return UR_Is_Negative (Left);
1003
1004 -- If we fall through, full gruesome test is required. This happens
1005 -- if the numbers are close together, or in some weird (/=10) base.
1006
1007 else
1008 declare
1009 Imrk : constant Uintp.Save_Mark := Mark;
1010 Rmrk : constant Urealp.Save_Mark := Mark;
1011 Lval : Ureal_Entry;
1012 Rval : Ureal_Entry;
1013 Result : Boolean;
1014
1015 begin
1016 Lval := Ureals.Table (Left);
1017 Rval := Ureals.Table (Right);
1018
1019 -- An optimization. If both numbers are based, then subtract
1020 -- common value of base to avoid unnecessarily giant numbers
1021
1022 if Lval.Rbase = Rval.Rbase and then Lval.Rbase /= 0 then
1023 if Lval.Den < Rval.Den then
1024 Rval.Den := Rval.Den - Lval.Den;
1025 Lval.Den := Uint_0;
1026 else
1027 Lval.Den := Lval.Den - Rval.Den;
1028 Rval.Den := Uint_0;
1029 end if;
1030 end if;
1031
1032 Lval := Normalize (Lval);
1033 Rval := Normalize (Rval);
1034
1035 if Lval.Negative then
1036 Result := (Lval.Num * Rval.Den) > (Rval.Num * Lval.Den);
1037 else
1038 Result := (Lval.Num * Rval.Den) < (Rval.Num * Lval.Den);
1039 end if;
1040
1041 Release (Imrk);
1042 Release (Rmrk);
1043 return Result;
1044 end;
1045 end if;
1046 end UR_Lt;
1047
1048 ------------
1049 -- UR_Max --
1050 ------------
1051
1052 function UR_Max (Left, Right : Ureal) return Ureal is
1053 begin
1054 if Left >= Right then
1055 return Left;
1056 else
1057 return Right;
1058 end if;
1059 end UR_Max;
1060
1061 ------------
1062 -- UR_Min --
1063 ------------
1064
1065 function UR_Min (Left, Right : Ureal) return Ureal is
1066 begin
1067 if Left <= Right then
1068 return Left;
1069 else
1070 return Right;
1071 end if;
1072 end UR_Min;
1073
1074 ------------
1075 -- UR_Mul --
1076 ------------
1077
1078 function UR_Mul (Left : Uint; Right : Ureal) return Ureal is
1079 begin
1080 return UR_From_Uint (Left) * Right;
1081 end UR_Mul;
1082
1083 function UR_Mul (Left : Ureal; Right : Uint) return Ureal is
1084 begin
1085 return Left * UR_From_Uint (Right);
1086 end UR_Mul;
1087
1088 function UR_Mul (Left, Right : Ureal) return Ureal is
1089 Lval : constant Ureal_Entry := Ureals.Table (Left);
1090 Rval : constant Ureal_Entry := Ureals.Table (Right);
1091 Num : Uint := Lval.Num * Rval.Num;
1092 Den : Uint;
1093 Rneg : constant Boolean := Lval.Negative xor Rval.Negative;
1094
1095 begin
1096 if Lval.Rbase = 0 then
1097 if Rval.Rbase = 0 then
1098 return Store_Ureal (
1099 Normalize (
1100 (Num => Num,
1101 Den => Lval.Den * Rval.Den,
1102 Rbase => 0,
1103 Negative => Rneg)));
1104
1105 elsif Is_Integer (Num, Lval.Den) then
1106 return Store_Ureal (
1107 (Num => Num / Lval.Den,
1108 Den => Rval.Den,
1109 Rbase => Rval.Rbase,
1110 Negative => Rneg));
1111
1112 elsif Rval.Den < 0 then
1113 return Store_Ureal (
1114 Normalize (
1115 (Num => Num * (Rval.Rbase ** (-Rval.Den)),
1116 Den => Lval.Den,
1117 Rbase => 0,
1118 Negative => Rneg)));
1119
1120 else
1121 return Store_Ureal (
1122 Normalize (
1123 (Num => Num,
1124 Den => Lval.Den * (Rval.Rbase ** Rval.Den),
1125 Rbase => 0,
1126 Negative => Rneg)));
1127 end if;
1128
1129 elsif Lval.Rbase = Rval.Rbase then
1130 return Store_Ureal (
1131 (Num => Num,
1132 Den => Lval.Den + Rval.Den,
1133 Rbase => Lval.Rbase,
1134 Negative => Rneg));
1135
1136 elsif Rval.Rbase = 0 then
1137 if Is_Integer (Num, Rval.Den) then
1138 return Store_Ureal (
1139 (Num => Num / Rval.Den,
1140 Den => Lval.Den,
1141 Rbase => Lval.Rbase,
1142 Negative => Rneg));
1143
1144 elsif Lval.Den < 0 then
1145 return Store_Ureal (
1146 Normalize (
1147 (Num => Num * (Lval.Rbase ** (-Lval.Den)),
1148 Den => Rval.Den,
1149 Rbase => 0,
1150 Negative => Rneg)));
1151
1152 else
1153 return Store_Ureal (
1154 Normalize (
1155 (Num => Num,
1156 Den => Rval.Den * (Lval.Rbase ** Lval.Den),
1157 Rbase => 0,
1158 Negative => Rneg)));
1159 end if;
1160
1161 else
1162 Den := Uint_1;
1163
1164 if Lval.Den < 0 then
1165 Num := Num * (Lval.Rbase ** (-Lval.Den));
1166 else
1167 Den := Den * (Lval.Rbase ** Lval.Den);
1168 end if;
1169
1170 if Rval.Den < 0 then
1171 Num := Num * (Rval.Rbase ** (-Rval.Den));
1172 else
1173 Den := Den * (Rval.Rbase ** Rval.Den);
1174 end if;
1175
1176 return Store_Ureal (
1177 Normalize (
1178 (Num => Num,
1179 Den => Den,
1180 Rbase => 0,
1181 Negative => Rneg)));
1182 end if;
1183 end UR_Mul;
1184
1185 -----------
1186 -- UR_Ne --
1187 -----------
1188
1189 function UR_Ne (Left, Right : Ureal) return Boolean is
1190 begin
1191 -- Quick processing for case of identical Ureal values (note that
1192 -- this also deals with comparing two No_Ureal values).
1193
1194 if Same (Left, Right) then
1195 return False;
1196
1197 -- Deal with case of one or other operand is No_Ureal, but not both
1198
1199 elsif Same (Left, No_Ureal) or else Same (Right, No_Ureal) then
1200 return True;
1201
1202 -- Do quick check based on number of decimal digits
1203
1204 elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) or else
1205 Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right)
1206 then
1207 return True;
1208
1209 -- Otherwise full comparison is required
1210
1211 else
1212 declare
1213 Imrk : constant Uintp.Save_Mark := Mark;
1214 Rmrk : constant Urealp.Save_Mark := Mark;
1215 Lval : constant Ureal_Entry := Normalize (Ureals.Table (Left));
1216 Rval : constant Ureal_Entry := Normalize (Ureals.Table (Right));
1217 Result : Boolean;
1218
1219 begin
1220 if UR_Is_Zero (Left) then
1221 return not UR_Is_Zero (Right);
1222
1223 elsif UR_Is_Zero (Right) then
1224 return not UR_Is_Zero (Left);
1225
1226 -- Both operands are non-zero
1227
1228 else
1229 Result :=
1230 Rval.Negative /= Lval.Negative
1231 or else Rval.Num /= Lval.Num
1232 or else Rval.Den /= Lval.Den;
1233 Release (Imrk);
1234 Release (Rmrk);
1235 return Result;
1236 end if;
1237 end;
1238 end if;
1239 end UR_Ne;
1240
1241 ---------------
1242 -- UR_Negate --
1243 ---------------
1244
1245 function UR_Negate (Real : Ureal) return Ureal is
1246 begin
1247 return Store_Ureal (
1248 (Num => Ureals.Table (Real).Num,
1249 Den => Ureals.Table (Real).Den,
1250 Rbase => Ureals.Table (Real).Rbase,
1251 Negative => not Ureals.Table (Real).Negative));
1252 end UR_Negate;
1253
1254 ------------
1255 -- UR_Sub --
1256 ------------
1257
1258 function UR_Sub (Left : Uint; Right : Ureal) return Ureal is
1259 begin
1260 return UR_From_Uint (Left) + UR_Negate (Right);
1261 end UR_Sub;
1262
1263 function UR_Sub (Left : Ureal; Right : Uint) return Ureal is
1264 begin
1265 return Left + UR_From_Uint (-Right);
1266 end UR_Sub;
1267
1268 function UR_Sub (Left, Right : Ureal) return Ureal is
1269 begin
1270 return Left + UR_Negate (Right);
1271 end UR_Sub;
1272
1273 ----------------
1274 -- UR_To_Uint --
1275 ----------------
1276
1277 function UR_To_Uint (Real : Ureal) return Uint is
1278 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
1279 Res : Uint;
1280
1281 begin
1282 Res := (Val.Num + (Val.Den / 2)) / Val.Den;
1283
1284 if Val.Negative then
1285 return UI_Negate (Res);
1286 else
1287 return Res;
1288 end if;
1289 end UR_To_Uint;
1290
1291 --------------
1292 -- UR_Trunc --
1293 --------------
1294
1295 function UR_Trunc (Real : Ureal) return Uint is
1296 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
1297
1298 begin
1299 if Val.Negative then
1300 return -(Val.Num / Val.Den);
1301 else
1302 return Val.Num / Val.Den;
1303 end if;
1304 end UR_Trunc;
1305
1306 --------------
1307 -- UR_Write --
1308 --------------
1309
1310 procedure UR_Write (Real : Ureal) is
1311 Val : constant Ureal_Entry := Ureals.Table (Real);
1312
1313 begin
1314 -- If value is negative, we precede the constant by a minus sign
1315 -- and add an extra layer of parentheses on the outside since the
1316 -- minus sign is part of the value, not a negation operator.
1317
1318 if Val.Negative then
1319 Write_Str ("(-");
1320 end if;
1321
1322 -- Constants in base 10 can be written in normal Ada literal style
1323
1324 if Val.Rbase = 10 then
1325 UI_Write (Val.Num / 10);
1326 Write_Char ('.');
1327 UI_Write (Val.Num mod 10);
1328
1329 if Val.Den /= 0 then
1330 Write_Char ('E');
1331 UI_Write (1 - Val.Den);
1332 end if;
1333
1334 -- Constants in a base other than 10 can still be easily written
1335 -- in normal Ada literal style if the numerator is one.
1336
1337 elsif Val.Rbase /= 0 and then Val.Num = 1 then
1338 Write_Int (Val.Rbase);
1339 Write_Str ("#1.0#E");
1340 UI_Write (-Val.Den);
1341
1342 -- Other constants with a base other than 10 are written using one
1343 -- of the following forms, depending on the sign of the number
1344 -- and the sign of the exponent (= minus denominator value)
1345
1346 -- (numerator.0*base**exponent)
1347 -- (numerator.0*base**(-exponent))
1348
1349 elsif Val.Rbase /= 0 then
1350 Write_Char ('(');
1351 UI_Write (Val.Num, Decimal);
1352 Write_Str (".0*");
1353 Write_Int (Val.Rbase);
1354 Write_Str ("**");
1355
1356 if Val.Den <= 0 then
1357 UI_Write (-Val.Den, Decimal);
1358
1359 else
1360 Write_Str ("(-");
1361 UI_Write (Val.Den, Decimal);
1362 Write_Char (')');
1363 end if;
1364
1365 Write_Char (')');
1366
1367 -- Rational constants with a denominator of 1 can be written as
1368 -- a real literal for the numerator integer.
1369
1370 elsif Val.Den = 1 then
1371 UI_Write (Val.Num, Decimal);
1372 Write_Str (".0");
1373
1374 -- Non-based (rational) constants are written in (num/den) style
1375
1376 else
1377 Write_Char ('(');
1378 UI_Write (Val.Num, Decimal);
1379 Write_Str (".0/");
1380 UI_Write (Val.Den, Decimal);
1381 Write_Str (".0)");
1382 end if;
1383
1384 -- Add trailing paren for negative values
1385
1386 if Val.Negative then
1387 Write_Char (')');
1388 end if;
1389 end UR_Write;
1390
1391 -------------
1392 -- Ureal_0 --
1393 -------------
1394
1395 function Ureal_0 return Ureal is
1396 begin
1397 return UR_0;
1398 end Ureal_0;
1399
1400 -------------
1401 -- Ureal_1 --
1402 -------------
1403
1404 function Ureal_1 return Ureal is
1405 begin
1406 return UR_1;
1407 end Ureal_1;
1408
1409 -------------
1410 -- Ureal_2 --
1411 -------------
1412
1413 function Ureal_2 return Ureal is
1414 begin
1415 return UR_2;
1416 end Ureal_2;
1417
1418 --------------
1419 -- Ureal_10 --
1420 --------------
1421
1422 function Ureal_10 return Ureal is
1423 begin
1424 return UR_10;
1425 end Ureal_10;
1426
1427 ---------------
1428 -- Ureal_100 --
1429 ---------------
1430
1431 function Ureal_100 return Ureal is
1432 begin
1433 return UR_100;
1434 end Ureal_100;
1435
1436 -----------------
1437 -- Ureal_10_36 --
1438 -----------------
1439
1440 function Ureal_10_36 return Ureal is
1441 begin
1442 return UR_10_36;
1443 end Ureal_10_36;
1444
1445 ----------------
1446 -- Ureal_2_80 --
1447 ----------------
1448
1449 function Ureal_2_80 return Ureal is
1450 begin
1451 return UR_2_80;
1452 end Ureal_2_80;
1453
1454 -----------------
1455 -- Ureal_2_128 --
1456 -----------------
1457
1458 function Ureal_2_128 return Ureal is
1459 begin
1460 return UR_2_128;
1461 end Ureal_2_128;
1462
1463 -------------------
1464 -- Ureal_2_M_80 --
1465 -------------------
1466
1467 function Ureal_2_M_80 return Ureal is
1468 begin
1469 return UR_2_M_80;
1470 end Ureal_2_M_80;
1471
1472 -------------------
1473 -- Ureal_2_M_128 --
1474 -------------------
1475
1476 function Ureal_2_M_128 return Ureal is
1477 begin
1478 return UR_2_M_128;
1479 end Ureal_2_M_128;
1480
1481 ----------------
1482 -- Ureal_Half --
1483 ----------------
1484
1485 function Ureal_Half return Ureal is
1486 begin
1487 return UR_Half;
1488 end Ureal_Half;
1489
1490 ---------------
1491 -- Ureal_M_0 --
1492 ---------------
1493
1494 function Ureal_M_0 return Ureal is
1495 begin
1496 return UR_M_0;
1497 end Ureal_M_0;
1498
1499 -------------------
1500 -- Ureal_M_10_36 --
1501 -------------------
1502
1503 function Ureal_M_10_36 return Ureal is
1504 begin
1505 return UR_M_10_36;
1506 end Ureal_M_10_36;
1507
1508 -----------------
1509 -- Ureal_Tenth --
1510 -----------------
1511
1512 function Ureal_Tenth return Ureal is
1513 begin
1514 return UR_Tenth;
1515 end Ureal_Tenth;
1516
1517 end Urealp;