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-2003 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 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. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34with Alloc; 35with Output; use Output; 36with Table; 37with Tree_IO; use Tree_IO; 38 39package 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 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 71 UR_0 : Ureal; 72 UR_M_0 : Ureal; 73 UR_Tenth : Ureal; 74 UR_Half : Ureal; 75 UR_1 : Ureal; 76 UR_2 : Ureal; 77 UR_10 : Ureal; 78 UR_10_36 : Ureal; 79 UR_M_10_36 : Ureal; 80 UR_100 : Ureal; 81 UR_2_128 : Ureal; 82 UR_2_80 : Ureal; 83 UR_2_M_128 : Ureal; 84 UR_2_M_80 : Ureal; 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 166 -- one to accommodate possible round off errors for non-decimal 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; 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 205 -- one to accommodate possible round off errors for non-decimal 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; 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); 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); 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); 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); 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 615 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); 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 778 X : constant Uint := abs N; 779 Bas : Ureal; 780 Val : Ureal_Entry; 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 858 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); 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 868 ------------------------ 869 -- UR_From_Components -- 870 ------------------------ 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 994 -- if the numbers are close together, or in some weird (/=10) base. 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; 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 1267 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); 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 1312 1313 if Val.Rbase = 10 then 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; 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 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 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 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 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 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 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 1506end Urealp; 1507