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