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-2021, 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. 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 COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Alloc; 27with Output; use Output; 28with Table; 29 30package body Urealp is 31 32 Ureal_First_Entry : constant Ureal := Ureal'Succ (No_Ureal); 33 -- First subscript allocated in Ureal table (note that we can't just 34 -- add 1 to No_Ureal, since "+" means something different for Ureals). 35 36 type Ureal_Entry is record 37 Num : Uint; 38 -- Numerator (always non-negative) 39 40 Den : Uint; 41 -- Denominator (always non-zero, always positive if base is zero) 42 43 Rbase : Nat; 44 -- Base value. If Rbase is zero, then the value is simply Num / Den. 45 -- If Rbase is non-zero, then the value is Num / (Rbase ** Den) 46 47 Negative : Boolean; 48 -- Flag set if value is negative 49 end record; 50 51 -- The following representation clause ensures that the above record 52 -- has no holes. We do this so that when instances of this record are 53 -- written, we do not write uninitialized values to the file. 54 55 for Ureal_Entry use record 56 Num at 0 range 0 .. 31; 57 Den at 4 range 0 .. 31; 58 Rbase at 8 range 0 .. 31; 59 Negative at 12 range 0 .. 31; 60 end record; 61 62 for Ureal_Entry'Size use 16 * 8; 63 -- This ensures that we did not leave out any fields 64 65 package Ureals is new Table.Table ( 66 Table_Component_Type => Ureal_Entry, 67 Table_Index_Type => Ureal'Base, 68 Table_Low_Bound => Ureal_First_Entry, 69 Table_Initial => Alloc.Ureals_Initial, 70 Table_Increment => Alloc.Ureals_Increment, 71 Table_Name => "Ureals"); 72 73 -- The following universal reals are the values returned by the constant 74 -- functions. They are initialized by the initialization procedure. 75 76 UR_0 : Ureal; 77 UR_M_0 : Ureal; 78 UR_Tenth : Ureal; 79 UR_Half : Ureal; 80 UR_1 : Ureal; 81 UR_2 : Ureal; 82 UR_10 : Ureal; 83 UR_2_10_18 : Ureal; 84 UR_9_10_36 : Ureal; 85 UR_10_76 : Ureal; 86 UR_M_2_10_18 : Ureal; 87 UR_M_9_10_36 : Ureal; 88 UR_M_10_76 : Ureal; 89 UR_100 : Ureal; 90 UR_2_127 : Ureal; 91 UR_2_128 : Ureal; 92 UR_2_31 : Ureal; 93 UR_2_63 : Ureal; 94 UR_2_80 : Ureal; 95 UR_2_M_127 : Ureal; 96 UR_2_M_128 : Ureal; 97 UR_2_M_80 : Ureal; 98 99 Normalized_Real : Ureal := No_Ureal; 100 -- Used to memoize Norm_Num and Norm_Den, if either of these functions 101 -- is called, this value is set and Normalized_Entry contains the result 102 -- of the normalization. On subsequent calls, this is used to avoid the 103 -- call to Normalize if it has already been made. 104 105 Normalized_Entry : Ureal_Entry; 106 -- Entry built by most recent call to Normalize 107 108 ----------------------- 109 -- Local Subprograms -- 110 ----------------------- 111 112 function Decimal_Exponent_Hi (V : Ureal) return Int; 113 -- Returns an estimate of the exponent of Val represented as a normalized 114 -- decimal number (non-zero digit before decimal point), the estimate is 115 -- either correct, or high, but never low. The accuracy of the estimate 116 -- affects only the efficiency of the comparison routines. 117 118 function Decimal_Exponent_Lo (V : Ureal) return Int; 119 -- Returns an estimate of the exponent of Val represented as a normalized 120 -- decimal number (non-zero digit before decimal point), the estimate is 121 -- either correct, or low, but never high. The accuracy of the estimate 122 -- affects only the efficiency of the comparison routines. 123 124 function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int; 125 -- U is a Ureal entry for which the base value is non-zero, the value 126 -- returned is the equivalent decimal exponent value, i.e. the value of 127 -- Den, adjusted as though the base were base 10. The value is rounded 128 -- toward zero (truncated), and so its value can be off by one. 129 130 function Is_Integer (Num, Den : Uint) return Boolean; 131 -- Return true if the real quotient of Num / Den is an integer value 132 133 function Normalize (Val : Ureal_Entry) return Ureal_Entry; 134 -- Normalizes the Ureal_Entry by reducing it to lowest terms (with a base 135 -- value of 0). 136 137 function Same (U1, U2 : Ureal) return Boolean; 138 pragma Inline (Same); 139 -- Determines if U1 and U2 are the same Ureal. Note that we cannot use 140 -- the equals operator for this test, since that tests for equality, not 141 -- identity. 142 143 function Store_Ureal (Val : Ureal_Entry) return Ureal; 144 -- This store a new entry in the universal reals table and return its index 145 -- in the table. 146 147 function Store_Ureal_Normalized (Val : Ureal_Entry) return Ureal; 148 pragma Inline (Store_Ureal_Normalized); 149 -- Like Store_Ureal, but normalizes its operand first 150 151 ------------------------- 152 -- Decimal_Exponent_Hi -- 153 ------------------------- 154 155 function Decimal_Exponent_Hi (V : Ureal) return Int is 156 Val : constant Ureal_Entry := Ureals.Table (V); 157 158 begin 159 -- Zero always returns zero 160 161 if UR_Is_Zero (V) then 162 return 0; 163 164 -- For numbers in rational form, get the maximum number of digits in the 165 -- numerator and the minimum number of digits in the denominator, and 166 -- subtract. For example: 167 168 -- 1000 / 99 = 1.010E+1 169 -- 9999 / 10 = 9.999E+2 170 171 -- This estimate may of course be high, but that is acceptable 172 173 elsif Val.Rbase = 0 then 174 return UI_Decimal_Digits_Hi (Val.Num) - 175 UI_Decimal_Digits_Lo (Val.Den); 176 177 -- For based numbers, get the maximum number of digits in the numerator 178 -- minus one and the either exact or floor value of the decimal exponent 179 -- of the denominator, and subtract. For example: 180 181 -- 321 / 10**3 = 3.21E-1 182 -- 435 / 5**7 = 5.57E-3 183 184 else 185 declare 186 E : Int; 187 188 begin 189 if Val.Rbase = 10 then 190 E := UI_To_Int (Val.Den); 191 192 else 193 E := Equivalent_Decimal_Exponent (Val); 194 if E < 0 then 195 E := E - 1; 196 end if; 197 end if; 198 199 return UI_Decimal_Digits_Hi (Val.Num) - 1 - E; 200 end; 201 end if; 202 end Decimal_Exponent_Hi; 203 204 ------------------------- 205 -- Decimal_Exponent_Lo -- 206 ------------------------- 207 208 function Decimal_Exponent_Lo (V : Ureal) return Int is 209 Val : constant Ureal_Entry := Ureals.Table (V); 210 211 begin 212 -- Zero always returns zero 213 214 if UR_Is_Zero (V) then 215 return 0; 216 217 -- For numbers in rational form, get min digits in numerator, max digits 218 -- in denominator, and subtract and subtract one more for possible loss 219 -- during the division. For example: 220 221 -- 1000 / 99 = 1.010E+1 222 -- 9999 / 10 = 9.999E+2 223 224 -- This estimate may of course be low, but that is acceptable 225 226 elsif Val.Rbase = 0 then 227 return UI_Decimal_Digits_Lo (Val.Num) - 228 UI_Decimal_Digits_Hi (Val.Den) - 1; 229 230 -- For based numbers, get the minimum number of digits in the numerator 231 -- minus one and the either exact or ceil value of the decimal exponent 232 -- of the denominator, and subtract. For example: 233 234 -- 321 / 10**3 = 3.21E-1 235 -- 435 / 5**7 = 5.57E-3 236 237 else 238 declare 239 E : Int; 240 241 begin 242 if Val.Rbase = 10 then 243 E := UI_To_Int (Val.Den); 244 245 else 246 E := Equivalent_Decimal_Exponent (Val); 247 if E > 0 then 248 E := E + 1; 249 end if; 250 end if; 251 252 return UI_Decimal_Digits_Lo (Val.Num) - 1 - E; 253 end; 254 end if; 255 end Decimal_Exponent_Lo; 256 257 ----------------- 258 -- Denominator -- 259 ----------------- 260 261 function Denominator (Real : Ureal) return Uint is 262 begin 263 return Ureals.Table (Real).Den; 264 end Denominator; 265 266 --------------------------------- 267 -- Equivalent_Decimal_Exponent -- 268 --------------------------------- 269 270 function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int is 271 272 type Ratio is record 273 Num : Nat; 274 Den : Nat; 275 end record; 276 277 -- The following table is a table of logs to the base 10. All values 278 -- have at least 15 digits of precision, and do not exceed the true 279 -- value. To avoid the use of floating point, and as a result potential 280 -- target dependency, each entry is represented as a fraction of two 281 -- integers. 282 283 Logs : constant array (Nat range 1 .. 16) of Ratio := 284 (1 => (Num => 0, Den => 1), -- 0 285 2 => (Num => 15_392_313, Den => 51_132_157), -- 0.301029995663981 286 3 => (Num => 731_111_920, Den => 1532_339_867), -- 0.477121254719662 287 4 => (Num => 30_784_626, Den => 51_132_157), -- 0.602059991327962 288 5 => (Num => 111_488_153, Den => 159_503_487), -- 0.698970004336018 289 6 => (Num => 84_253_929, Den => 108_274_489), -- 0.778151250383643 290 7 => (Num => 35_275_468, Den => 41_741_273), -- 0.845098040014256 291 8 => (Num => 46_176_939, Den => 51_132_157), -- 0.903089986991943 292 9 => (Num => 417_620_173, Den => 437_645_744), -- 0.954242509439324 293 10 => (Num => 1, Den => 1), -- 1.000000000000000 294 11 => (Num => 136_507_510, Den => 131_081_687), -- 1.041392685158225 295 12 => (Num => 26_797_783, Den => 24_831_587), -- 1.079181246047624 296 13 => (Num => 73_333_297, Den => 65_832_160), -- 1.113943352306836 297 14 => (Num => 102_941_258, Den => 89_816_543), -- 1.146128035678238 298 15 => (Num => 53_385_559, Den => 45_392_361), -- 1.176091259055681 299 16 => (Num => 78_897_839, Den => 65_523_237)); -- 1.204119982655924 300 301 function Scale (X : Uint; R : Ratio) return Int; 302 -- Compute the value of X scaled by R 303 304 ----------- 305 -- Scale -- 306 ----------- 307 308 function Scale (X : Uint; R : Ratio) return Int is 309 begin 310 return UI_To_Int (X * R.Num / R.Den); 311 end Scale; 312 313 begin 314 pragma Assert (U.Rbase /= 0); 315 return Scale (U.Den, Logs (U.Rbase)); 316 end Equivalent_Decimal_Exponent; 317 318 ---------------- 319 -- Initialize -- 320 ---------------- 321 322 procedure Initialize is 323 begin 324 Ureals.Init; 325 UR_0 := UR_From_Components (Uint_0, Uint_1, 0, False); 326 UR_M_0 := UR_From_Components (Uint_0, Uint_1, 0, True); 327 UR_Half := UR_From_Components (Uint_1, Uint_1, 2, False); 328 UR_Tenth := UR_From_Components (Uint_1, Uint_1, 10, False); 329 UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False); 330 UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False); 331 UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False); 332 UR_2_10_18 := UR_From_Components (Uint_2, Uint_Minus_18, 10, False); 333 UR_9_10_36 := UR_From_Components (Uint_9, Uint_Minus_36, 10, False); 334 UR_10_76 := UR_From_Components (Uint_1, Uint_Minus_76, 10, False); 335 UR_M_2_10_18 := UR_From_Components (Uint_2, Uint_Minus_18, 10, True); 336 UR_M_9_10_36 := UR_From_Components (Uint_9, Uint_Minus_36, 10, True); 337 UR_M_10_76 := UR_From_Components (Uint_1, Uint_Minus_76, 10, True); 338 UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False); 339 UR_2_127 := UR_From_Components (Uint_1, Uint_Minus_127, 2, False); 340 UR_2_M_127 := UR_From_Components (Uint_1, Uint_127, 2, False); 341 UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False); 342 UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False); 343 UR_2_31 := UR_From_Components (Uint_1, Uint_Minus_31, 2, False); 344 UR_2_63 := UR_From_Components (Uint_1, Uint_Minus_63, 2, False); 345 UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False); 346 UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False); 347 end Initialize; 348 349 ---------------- 350 -- Is_Integer -- 351 ---------------- 352 353 function Is_Integer (Num, Den : Uint) return Boolean is 354 begin 355 return (Num / Den) * Den = Num; 356 end Is_Integer; 357 358 ---------- 359 -- Mark -- 360 ---------- 361 362 function Mark return Save_Mark is 363 begin 364 return Save_Mark (Ureals.Last); 365 end Mark; 366 367 -------------- 368 -- Norm_Den -- 369 -------------- 370 371 function Norm_Den (Real : Ureal) return Uint is 372 begin 373 if not Same (Real, Normalized_Real) then 374 Normalized_Real := Real; 375 Normalized_Entry := Normalize (Ureals.Table (Real)); 376 end if; 377 378 return Normalized_Entry.Den; 379 end Norm_Den; 380 381 -------------- 382 -- Norm_Num -- 383 -------------- 384 385 function Norm_Num (Real : Ureal) return Uint is 386 begin 387 if not Same (Real, Normalized_Real) then 388 Normalized_Real := Real; 389 Normalized_Entry := Normalize (Ureals.Table (Real)); 390 end if; 391 392 return Normalized_Entry.Num; 393 end Norm_Num; 394 395 --------------- 396 -- Normalize -- 397 --------------- 398 399 function Normalize (Val : Ureal_Entry) return Ureal_Entry is 400 J : Uint; 401 K : Uint; 402 Tmp : Uint; 403 Num : Uint; 404 Den : Uint; 405 M : constant Uintp.Save_Mark := Mark; 406 407 begin 408 -- Start by setting J to the greatest of the absolute values of the 409 -- numerator and the denominator (taking into account the base value), 410 -- and K to the lesser of the two absolute values. The gcd of Num and 411 -- Den is the gcd of J and K. 412 413 if Val.Rbase = 0 then 414 J := Val.Num; 415 K := Val.Den; 416 417 elsif Val.Den < 0 then 418 J := Val.Num * Val.Rbase ** (-Val.Den); 419 K := Uint_1; 420 421 else 422 J := Val.Num; 423 K := Val.Rbase ** Val.Den; 424 end if; 425 426 Num := J; 427 Den := K; 428 429 if K > J then 430 Tmp := J; 431 J := K; 432 K := Tmp; 433 end if; 434 435 J := UI_GCD (J, K); 436 Num := Num / J; 437 Den := Den / J; 438 Uintp.Release_And_Save (M, Num, Den); 439 440 -- Divide numerator and denominator by gcd and return result 441 442 return (Num => Num, 443 Den => Den, 444 Rbase => 0, 445 Negative => Val.Negative); 446 end Normalize; 447 448 --------------- 449 -- Numerator -- 450 --------------- 451 452 function Numerator (Real : Ureal) return Uint is 453 begin 454 return Ureals.Table (Real).Num; 455 end Numerator; 456 457 -------- 458 -- pr -- 459 -------- 460 461 procedure pr (Real : Ureal) is 462 begin 463 UR_Write (Real); 464 Write_Eol; 465 end pr; 466 467 ----------- 468 -- Rbase -- 469 ----------- 470 471 function Rbase (Real : Ureal) return Nat is 472 begin 473 return Ureals.Table (Real).Rbase; 474 end Rbase; 475 476 ------------- 477 -- Release -- 478 ------------- 479 480 procedure Release (M : Save_Mark) is 481 begin 482 Ureals.Set_Last (Ureal (M)); 483 end Release; 484 485 ---------- 486 -- Same -- 487 ---------- 488 489 function Same (U1, U2 : Ureal) return Boolean is 490 begin 491 return Int (U1) = Int (U2); 492 end Same; 493 494 ----------------- 495 -- Store_Ureal -- 496 ----------------- 497 498 function Store_Ureal (Val : Ureal_Entry) return Ureal is 499 begin 500 Ureals.Append (Val); 501 502 -- Normalize representation of signed values 503 504 if Val.Num < 0 then 505 Ureals.Table (Ureals.Last).Negative := True; 506 Ureals.Table (Ureals.Last).Num := -Val.Num; 507 end if; 508 509 return Ureals.Last; 510 end Store_Ureal; 511 512 ---------------------------- 513 -- Store_Ureal_Normalized -- 514 ---------------------------- 515 516 function Store_Ureal_Normalized (Val : Ureal_Entry) return Ureal is 517 begin 518 return Store_Ureal (Normalize (Val)); 519 end Store_Ureal_Normalized; 520 521 ------------ 522 -- UR_Abs -- 523 ------------ 524 525 function UR_Abs (Real : Ureal) return Ureal is 526 Val : constant Ureal_Entry := Ureals.Table (Real); 527 528 begin 529 return Store_Ureal 530 ((Num => Val.Num, 531 Den => Val.Den, 532 Rbase => Val.Rbase, 533 Negative => False)); 534 end UR_Abs; 535 536 ------------ 537 -- UR_Add -- 538 ------------ 539 540 function UR_Add (Left : Uint; Right : Ureal) return Ureal is 541 begin 542 return UR_From_Uint (Left) + Right; 543 end UR_Add; 544 545 function UR_Add (Left : Ureal; Right : Uint) return Ureal is 546 begin 547 return Left + UR_From_Uint (Right); 548 end UR_Add; 549 550 function UR_Add (Left : Ureal; Right : Ureal) return Ureal is 551 Lval : Ureal_Entry := Ureals.Table (Left); 552 Rval : Ureal_Entry := Ureals.Table (Right); 553 Num : Uint; 554 555 begin 556 pragma Annotate (CodePeer, Modified, Lval); 557 pragma Annotate (CodePeer, Modified, Rval); 558 559 -- Note, in the temporary Ureal_Entry values used in this procedure, 560 -- we store the sign as the sign of the numerator (i.e. xxx.Num may 561 -- be negative, even though in stored entries this can never be so) 562 563 if Lval.Rbase /= 0 and then Lval.Rbase = Rval.Rbase then 564 declare 565 Opd_Min, Opd_Max : Ureal_Entry; 566 Exp_Min, Exp_Max : Uint; 567 568 begin 569 if Lval.Negative then 570 Lval.Num := (-Lval.Num); 571 end if; 572 573 if Rval.Negative then 574 Rval.Num := (-Rval.Num); 575 end if; 576 577 if Lval.Den < Rval.Den then 578 Exp_Min := Lval.Den; 579 Exp_Max := Rval.Den; 580 Opd_Min := Lval; 581 Opd_Max := Rval; 582 else 583 Exp_Min := Rval.Den; 584 Exp_Max := Lval.Den; 585 Opd_Min := Rval; 586 Opd_Max := Lval; 587 end if; 588 589 Num := 590 Opd_Min.Num * Lval.Rbase ** (Exp_Max - Exp_Min) + Opd_Max.Num; 591 592 if Num = 0 then 593 return Store_Ureal 594 ((Num => Uint_0, 595 Den => Uint_1, 596 Rbase => 0, 597 Negative => Lval.Negative)); 598 599 else 600 return Store_Ureal 601 ((Num => abs Num, 602 Den => Exp_Max, 603 Rbase => Lval.Rbase, 604 Negative => (Num < 0))); 605 end if; 606 end; 607 608 else 609 declare 610 Ln : Ureal_Entry := Normalize (Lval); 611 Rn : Ureal_Entry := Normalize (Rval); 612 613 begin 614 if Ln.Negative then 615 Ln.Num := (-Ln.Num); 616 end if; 617 618 if Rn.Negative then 619 Rn.Num := (-Rn.Num); 620 end if; 621 622 Num := (Ln.Num * Rn.Den) + (Rn.Num * Ln.Den); 623 624 if Num = 0 then 625 return Store_Ureal 626 ((Num => Uint_0, 627 Den => Uint_1, 628 Rbase => 0, 629 Negative => Lval.Negative)); 630 631 else 632 return Store_Ureal_Normalized 633 ((Num => abs Num, 634 Den => Ln.Den * Rn.Den, 635 Rbase => 0, 636 Negative => (Num < 0))); 637 end if; 638 end; 639 end if; 640 end UR_Add; 641 642 ---------------- 643 -- UR_Ceiling -- 644 ---------------- 645 646 function UR_Ceiling (Real : Ureal) return Uint is 647 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); 648 begin 649 if Val.Negative then 650 return UI_Negate (Val.Num / Val.Den); 651 else 652 return (Val.Num + Val.Den - 1) / Val.Den; 653 end if; 654 end UR_Ceiling; 655 656 ------------ 657 -- UR_Div -- 658 ------------ 659 660 function UR_Div (Left : Uint; Right : Ureal) return Ureal is 661 begin 662 return UR_From_Uint (Left) / Right; 663 end UR_Div; 664 665 function UR_Div (Left : Ureal; Right : Uint) return Ureal is 666 begin 667 return Left / UR_From_Uint (Right); 668 end UR_Div; 669 670 function UR_Div (Left, Right : Ureal) return Ureal is 671 Lval : constant Ureal_Entry := Ureals.Table (Left); 672 Rval : constant Ureal_Entry := Ureals.Table (Right); 673 Rneg : constant Boolean := Rval.Negative xor Lval.Negative; 674 675 begin 676 pragma Annotate (CodePeer, Modified, Lval); 677 pragma Annotate (CodePeer, Modified, Rval); 678 pragma Assert (Rval.Num /= Uint_0); 679 680 if Lval.Rbase = 0 then 681 if Rval.Rbase = 0 then 682 return Store_Ureal_Normalized 683 ((Num => Lval.Num * Rval.Den, 684 Den => Lval.Den * Rval.Num, 685 Rbase => 0, 686 Negative => Rneg)); 687 688 elsif Is_Integer (Lval.Num, Rval.Num * Lval.Den) then 689 return Store_Ureal 690 ((Num => Lval.Num / (Rval.Num * Lval.Den), 691 Den => (-Rval.Den), 692 Rbase => Rval.Rbase, 693 Negative => Rneg)); 694 695 elsif Rval.Den < 0 then 696 return Store_Ureal_Normalized 697 ((Num => Lval.Num, 698 Den => Rval.Rbase ** (-Rval.Den) * 699 Rval.Num * 700 Lval.Den, 701 Rbase => 0, 702 Negative => Rneg)); 703 704 else 705 return Store_Ureal_Normalized 706 ((Num => Lval.Num * Rval.Rbase ** Rval.Den, 707 Den => Rval.Num * Lval.Den, 708 Rbase => 0, 709 Negative => Rneg)); 710 end if; 711 712 elsif Is_Integer (Lval.Num, Rval.Num) then 713 if Rval.Rbase = Lval.Rbase then 714 return Store_Ureal 715 ((Num => Lval.Num / Rval.Num, 716 Den => Lval.Den - Rval.Den, 717 Rbase => Lval.Rbase, 718 Negative => Rneg)); 719 720 elsif Rval.Rbase = 0 then 721 return Store_Ureal 722 ((Num => (Lval.Num / Rval.Num) * Rval.Den, 723 Den => Lval.Den, 724 Rbase => Lval.Rbase, 725 Negative => Rneg)); 726 727 elsif Rval.Den < 0 then 728 declare 729 Num, Den : Uint; 730 731 begin 732 if Lval.Den < 0 then 733 Num := (Lval.Num / Rval.Num) * (Lval.Rbase ** (-Lval.Den)); 734 Den := Rval.Rbase ** (-Rval.Den); 735 else 736 Num := Lval.Num / Rval.Num; 737 Den := (Lval.Rbase ** Lval.Den) * 738 (Rval.Rbase ** (-Rval.Den)); 739 end if; 740 741 return Store_Ureal 742 ((Num => Num, 743 Den => Den, 744 Rbase => 0, 745 Negative => Rneg)); 746 end; 747 748 else 749 return Store_Ureal 750 ((Num => (Lval.Num / Rval.Num) * 751 (Rval.Rbase ** Rval.Den), 752 Den => Lval.Den, 753 Rbase => Lval.Rbase, 754 Negative => Rneg)); 755 end if; 756 757 else 758 declare 759 Num, Den : Uint; 760 761 begin 762 if Lval.Den < 0 then 763 Num := Lval.Num * (Lval.Rbase ** (-Lval.Den)); 764 Den := Rval.Num; 765 else 766 Num := Lval.Num; 767 Den := Rval.Num * (Lval.Rbase ** Lval.Den); 768 end if; 769 770 if Rval.Rbase /= 0 then 771 if Rval.Den < 0 then 772 Den := Den * (Rval.Rbase ** (-Rval.Den)); 773 else 774 Num := Num * (Rval.Rbase ** Rval.Den); 775 end if; 776 777 else 778 Num := Num * Rval.Den; 779 end if; 780 781 return Store_Ureal_Normalized 782 ((Num => Num, 783 Den => Den, 784 Rbase => 0, 785 Negative => Rneg)); 786 end; 787 end if; 788 end UR_Div; 789 790 ----------- 791 -- UR_Eq -- 792 ----------- 793 794 function UR_Eq (Left, Right : Ureal) return Boolean is 795 begin 796 return not UR_Ne (Left, Right); 797 end UR_Eq; 798 799 --------------------- 800 -- UR_Exponentiate -- 801 --------------------- 802 803 function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal is 804 X : constant Uint := abs N; 805 Bas : Ureal; 806 Val : Ureal_Entry; 807 Neg : Boolean; 808 IBas : Uint; 809 810 begin 811 -- If base is negative, then the resulting sign depends on whether 812 -- the exponent is even or odd (even => positive, odd = negative) 813 814 if UR_Is_Negative (Real) then 815 Neg := (N mod 2) /= 0; 816 Bas := UR_Negate (Real); 817 else 818 Neg := False; 819 Bas := Real; 820 end if; 821 822 Val := Ureals.Table (Bas); 823 824 -- If the base is a small integer, then we can return the result in 825 -- exponential form, which can save a lot of time for junk exponents. 826 827 IBas := UR_Trunc (Bas); 828 829 if IBas <= 16 830 and then UR_From_Uint (IBas) = Bas 831 then 832 return Store_Ureal 833 ((Num => Uint_1, 834 Den => -N, 835 Rbase => UI_To_Int (UR_Trunc (Bas)), 836 Negative => Neg)); 837 838 -- If the exponent is negative then we raise the numerator and the 839 -- denominator (after normalization) to the absolute value of the 840 -- exponent and we return the reciprocal. An assert error will happen 841 -- if the numerator is zero. 842 843 elsif N < 0 then 844 pragma Assert (Val.Num /= 0); 845 Val := Normalize (Val); 846 847 return Store_Ureal 848 ((Num => Val.Den ** X, 849 Den => Val.Num ** X, 850 Rbase => 0, 851 Negative => Neg)); 852 853 -- If positive, we distinguish the case when the base is not zero, in 854 -- which case the new denominator is just the product of the old one 855 -- with the exponent, 856 857 else 858 if Val.Rbase /= 0 then 859 860 return Store_Ureal 861 ((Num => Val.Num ** X, 862 Den => Val.Den * X, 863 Rbase => Val.Rbase, 864 Negative => Neg)); 865 866 -- And when the base is zero, in which case we exponentiate 867 -- the old denominator. 868 869 else 870 return Store_Ureal 871 ((Num => Val.Num ** X, 872 Den => Val.Den ** X, 873 Rbase => 0, 874 Negative => Neg)); 875 end if; 876 end if; 877 end UR_Exponentiate; 878 879 -------------- 880 -- UR_Floor -- 881 -------------- 882 883 function UR_Floor (Real : Ureal) return Uint is 884 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); 885 begin 886 if Val.Negative then 887 return UI_Negate ((Val.Num + Val.Den - 1) / Val.Den); 888 else 889 return Val.Num / Val.Den; 890 end if; 891 end UR_Floor; 892 893 ------------------------ 894 -- UR_From_Components -- 895 ------------------------ 896 897 function UR_From_Components 898 (Num : Uint; 899 Den : Uint; 900 Rbase : Nat := 0; 901 Negative : Boolean := False) 902 return Ureal 903 is 904 begin 905 return Store_Ureal 906 ((Num => Num, 907 Den => Den, 908 Rbase => Rbase, 909 Negative => Negative)); 910 end UR_From_Components; 911 912 ------------------ 913 -- UR_From_Uint -- 914 ------------------ 915 916 function UR_From_Uint (UI : Uint) return Ureal is 917 begin 918 return UR_From_Components 919 (abs UI, Uint_1, Negative => (UI < 0)); 920 end UR_From_Uint; 921 922 ----------- 923 -- UR_Ge -- 924 ----------- 925 926 function UR_Ge (Left, Right : Ureal) return Boolean is 927 begin 928 return not (Left < Right); 929 end UR_Ge; 930 931 ----------- 932 -- UR_Gt -- 933 ----------- 934 935 function UR_Gt (Left, Right : Ureal) return Boolean is 936 begin 937 return (Right < Left); 938 end UR_Gt; 939 940 -------------------- 941 -- UR_Is_Negative -- 942 -------------------- 943 944 function UR_Is_Negative (Real : Ureal) return Boolean is 945 begin 946 return Ureals.Table (Real).Negative; 947 end UR_Is_Negative; 948 949 -------------------- 950 -- UR_Is_Positive -- 951 -------------------- 952 953 function UR_Is_Positive (Real : Ureal) return Boolean is 954 begin 955 return not Ureals.Table (Real).Negative 956 and then Ureals.Table (Real).Num /= 0; 957 end UR_Is_Positive; 958 959 ---------------- 960 -- UR_Is_Zero -- 961 ---------------- 962 963 function UR_Is_Zero (Real : Ureal) return Boolean is 964 begin 965 return Ureals.Table (Real).Num = 0; 966 end UR_Is_Zero; 967 968 ----------- 969 -- UR_Le -- 970 ----------- 971 972 function UR_Le (Left, Right : Ureal) return Boolean is 973 begin 974 return not (Right < Left); 975 end UR_Le; 976 977 ----------- 978 -- UR_Lt -- 979 ----------- 980 981 function UR_Lt (Left, Right : Ureal) return Boolean is 982 begin 983 -- An operand is not less than itself 984 985 if Same (Left, Right) then 986 return False; 987 988 -- Deal with zero cases 989 990 elsif UR_Is_Zero (Left) then 991 return UR_Is_Positive (Right); 992 993 elsif UR_Is_Zero (Right) then 994 return Ureals.Table (Left).Negative; 995 996 -- Different signs are decisive (note we dealt with zero cases) 997 998 elsif Ureals.Table (Left).Negative 999 and then not Ureals.Table (Right).Negative 1000 then 1001 return True; 1002 1003 elsif not Ureals.Table (Left).Negative 1004 and then Ureals.Table (Right).Negative 1005 then 1006 return False; 1007 1008 -- Signs are same, do rapid check based on worst case estimates of 1009 -- decimal exponent, which will often be decisive. Precise test 1010 -- depends on whether operands are positive or negative. 1011 1012 elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) then 1013 return UR_Is_Positive (Left); 1014 1015 elsif Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right) then 1016 return UR_Is_Negative (Left); 1017 1018 -- If we fall through, full gruesome test is required. This happens 1019 -- if the numbers are close together, or in some weird (/=10) base. 1020 1021 else 1022 declare 1023 Imrk : constant Uintp.Save_Mark := Mark; 1024 Rmrk : constant Urealp.Save_Mark := Mark; 1025 Lval : Ureal_Entry; 1026 Rval : Ureal_Entry; 1027 Result : Boolean; 1028 1029 begin 1030 Lval := Ureals.Table (Left); 1031 Rval := Ureals.Table (Right); 1032 1033 -- An optimization. If both numbers are based, then subtract 1034 -- common value of base to avoid unnecessarily giant numbers 1035 1036 if Lval.Rbase = Rval.Rbase and then Lval.Rbase /= 0 then 1037 if Lval.Den < Rval.Den then 1038 Rval.Den := Rval.Den - Lval.Den; 1039 Lval.Den := Uint_0; 1040 else 1041 Lval.Den := Lval.Den - Rval.Den; 1042 Rval.Den := Uint_0; 1043 end if; 1044 end if; 1045 1046 Lval := Normalize (Lval); 1047 Rval := Normalize (Rval); 1048 1049 if Lval.Negative then 1050 Result := (Lval.Num * Rval.Den) > (Rval.Num * Lval.Den); 1051 else 1052 Result := (Lval.Num * Rval.Den) < (Rval.Num * Lval.Den); 1053 end if; 1054 1055 Release (Imrk); 1056 Release (Rmrk); 1057 return Result; 1058 end; 1059 end if; 1060 end UR_Lt; 1061 1062 ------------ 1063 -- UR_Max -- 1064 ------------ 1065 1066 function UR_Max (Left, Right : Ureal) return Ureal is 1067 begin 1068 if Left >= Right then 1069 return Left; 1070 else 1071 return Right; 1072 end if; 1073 end UR_Max; 1074 1075 ------------ 1076 -- UR_Min -- 1077 ------------ 1078 1079 function UR_Min (Left, Right : Ureal) return Ureal is 1080 begin 1081 if Left <= Right then 1082 return Left; 1083 else 1084 return Right; 1085 end if; 1086 end UR_Min; 1087 1088 ------------ 1089 -- UR_Mul -- 1090 ------------ 1091 1092 function UR_Mul (Left : Uint; Right : Ureal) return Ureal is 1093 begin 1094 return UR_From_Uint (Left) * Right; 1095 end UR_Mul; 1096 1097 function UR_Mul (Left : Ureal; Right : Uint) return Ureal is 1098 begin 1099 return Left * UR_From_Uint (Right); 1100 end UR_Mul; 1101 1102 function UR_Mul (Left, Right : Ureal) return Ureal is 1103 Lval : constant Ureal_Entry := Ureals.Table (Left); 1104 Rval : constant Ureal_Entry := Ureals.Table (Right); 1105 Num : Uint := Lval.Num * Rval.Num; 1106 Den : Uint; 1107 Rneg : constant Boolean := Lval.Negative xor Rval.Negative; 1108 1109 begin 1110 if Lval.Rbase = 0 then 1111 if Rval.Rbase = 0 then 1112 return Store_Ureal_Normalized 1113 ((Num => Num, 1114 Den => Lval.Den * Rval.Den, 1115 Rbase => 0, 1116 Negative => Rneg)); 1117 1118 elsif Is_Integer (Num, Lval.Den) then 1119 return Store_Ureal 1120 ((Num => Num / Lval.Den, 1121 Den => Rval.Den, 1122 Rbase => Rval.Rbase, 1123 Negative => Rneg)); 1124 1125 elsif Rval.Den < 0 then 1126 return Store_Ureal_Normalized 1127 ((Num => Num * (Rval.Rbase ** (-Rval.Den)), 1128 Den => Lval.Den, 1129 Rbase => 0, 1130 Negative => Rneg)); 1131 1132 else 1133 return Store_Ureal_Normalized 1134 ((Num => Num, 1135 Den => Lval.Den * (Rval.Rbase ** Rval.Den), 1136 Rbase => 0, 1137 Negative => Rneg)); 1138 end if; 1139 1140 elsif Lval.Rbase = Rval.Rbase then 1141 return Store_Ureal 1142 ((Num => Num, 1143 Den => Lval.Den + Rval.Den, 1144 Rbase => Lval.Rbase, 1145 Negative => Rneg)); 1146 1147 elsif Rval.Rbase = 0 then 1148 if Is_Integer (Num, Rval.Den) then 1149 return Store_Ureal 1150 ((Num => Num / Rval.Den, 1151 Den => Lval.Den, 1152 Rbase => Lval.Rbase, 1153 Negative => Rneg)); 1154 1155 elsif Lval.Den < 0 then 1156 return Store_Ureal_Normalized 1157 ((Num => Num * (Lval.Rbase ** (-Lval.Den)), 1158 Den => Rval.Den, 1159 Rbase => 0, 1160 Negative => Rneg)); 1161 1162 else 1163 return Store_Ureal_Normalized 1164 ((Num => Num, 1165 Den => Rval.Den * (Lval.Rbase ** Lval.Den), 1166 Rbase => 0, 1167 Negative => Rneg)); 1168 end if; 1169 1170 else 1171 Den := Uint_1; 1172 1173 if Lval.Den < 0 then 1174 Num := Num * (Lval.Rbase ** (-Lval.Den)); 1175 else 1176 Den := Den * (Lval.Rbase ** Lval.Den); 1177 end if; 1178 1179 if Rval.Den < 0 then 1180 Num := Num * (Rval.Rbase ** (-Rval.Den)); 1181 else 1182 Den := Den * (Rval.Rbase ** Rval.Den); 1183 end if; 1184 1185 return Store_Ureal_Normalized 1186 ((Num => Num, 1187 Den => Den, 1188 Rbase => 0, 1189 Negative => Rneg)); 1190 end if; 1191 end UR_Mul; 1192 1193 ----------- 1194 -- UR_Ne -- 1195 ----------- 1196 1197 function UR_Ne (Left, Right : Ureal) return Boolean is 1198 begin 1199 -- Quick processing for case of identical Ureal values (note that 1200 -- this also deals with comparing two No_Ureal values). 1201 1202 if Same (Left, Right) then 1203 return False; 1204 1205 -- Deal with case of one or other operand is No_Ureal, but not both 1206 1207 elsif Same (Left, No_Ureal) or else Same (Right, No_Ureal) then 1208 return True; 1209 1210 -- Do quick check based on number of decimal digits 1211 1212 elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) or else 1213 Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right) 1214 then 1215 return True; 1216 1217 -- Otherwise full comparison is required 1218 1219 else 1220 declare 1221 Imrk : constant Uintp.Save_Mark := Mark; 1222 Rmrk : constant Urealp.Save_Mark := Mark; 1223 Lval : constant Ureal_Entry := Normalize (Ureals.Table (Left)); 1224 Rval : constant Ureal_Entry := Normalize (Ureals.Table (Right)); 1225 Result : Boolean; 1226 1227 begin 1228 if UR_Is_Zero (Left) then 1229 return not UR_Is_Zero (Right); 1230 1231 elsif UR_Is_Zero (Right) then 1232 return not UR_Is_Zero (Left); 1233 1234 -- Both operands are non-zero 1235 1236 else 1237 Result := 1238 Rval.Negative /= Lval.Negative 1239 or else Rval.Num /= Lval.Num 1240 or else Rval.Den /= Lval.Den; 1241 Release (Imrk); 1242 Release (Rmrk); 1243 return Result; 1244 end if; 1245 end; 1246 end if; 1247 end UR_Ne; 1248 1249 --------------- 1250 -- UR_Negate -- 1251 --------------- 1252 1253 function UR_Negate (Real : Ureal) return Ureal is 1254 begin 1255 return Store_Ureal 1256 ((Num => Ureals.Table (Real).Num, 1257 Den => Ureals.Table (Real).Den, 1258 Rbase => Ureals.Table (Real).Rbase, 1259 Negative => not Ureals.Table (Real).Negative)); 1260 end UR_Negate; 1261 1262 ------------ 1263 -- UR_Sub -- 1264 ------------ 1265 1266 function UR_Sub (Left : Uint; Right : Ureal) return Ureal is 1267 begin 1268 return UR_From_Uint (Left) + UR_Negate (Right); 1269 end UR_Sub; 1270 1271 function UR_Sub (Left : Ureal; Right : Uint) return Ureal is 1272 begin 1273 return Left + UR_From_Uint (-Right); 1274 end UR_Sub; 1275 1276 function UR_Sub (Left, Right : Ureal) return Ureal is 1277 begin 1278 return Left + UR_Negate (Right); 1279 end UR_Sub; 1280 1281 ---------------- 1282 -- UR_To_Uint -- 1283 ---------------- 1284 1285 function UR_To_Uint (Real : Ureal) return Uint is 1286 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); 1287 Res : Uint; 1288 1289 begin 1290 Res := (Val.Num + (Val.Den / 2)) / Val.Den; 1291 1292 if Val.Negative then 1293 return UI_Negate (Res); 1294 else 1295 return Res; 1296 end if; 1297 end UR_To_Uint; 1298 1299 -------------- 1300 -- UR_Trunc -- 1301 -------------- 1302 1303 function UR_Trunc (Real : Ureal) return Uint is 1304 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); 1305 begin 1306 if Val.Negative then 1307 return -(Val.Num / Val.Den); 1308 else 1309 return Val.Num / Val.Den; 1310 end if; 1311 end UR_Trunc; 1312 1313 -------------- 1314 -- UR_Write -- 1315 -------------- 1316 1317 procedure UR_Write (Real : Ureal; Brackets : Boolean := False) is 1318 Val : constant Ureal_Entry := Ureals.Table (Real); 1319 T : Uint; 1320 1321 begin 1322 -- If value is negative, we precede the constant by a minus sign 1323 1324 if Val.Negative then 1325 Write_Char ('-'); 1326 end if; 1327 1328 -- Zero is zero 1329 1330 if Val.Num = 0 then 1331 Write_Str ("0.0"); 1332 1333 -- For constants with a denominator of zero, the value is simply the 1334 -- numerator value, since we are dividing by base**0, which is 1. 1335 1336 elsif Val.Den = 0 then 1337 UI_Write (Val.Num, Decimal); 1338 Write_Str (".0"); 1339 1340 -- Small powers of 2 get written in decimal fixed-point format 1341 1342 elsif Val.Rbase = 2 1343 and then Val.Den <= 3 1344 and then Val.Den >= -16 1345 then 1346 if Val.Den = 1 then 1347 T := Val.Num * (10 / 2); 1348 UI_Write (T / 10, Decimal); 1349 Write_Char ('.'); 1350 UI_Write (T mod 10, Decimal); 1351 1352 elsif Val.Den = 2 then 1353 T := Val.Num * (100 / 4); 1354 UI_Write (T / 100, Decimal); 1355 Write_Char ('.'); 1356 UI_Write (T mod 100 / 10, Decimal); 1357 1358 if T mod 10 /= 0 then 1359 UI_Write (T mod 10, Decimal); 1360 end if; 1361 1362 elsif Val.Den = 3 then 1363 T := Val.Num * (1000 / 8); 1364 UI_Write (T / 1000, Decimal); 1365 Write_Char ('.'); 1366 UI_Write (T mod 1000 / 100, Decimal); 1367 1368 if T mod 100 /= 0 then 1369 UI_Write (T mod 100 / 10, Decimal); 1370 1371 if T mod 10 /= 0 then 1372 UI_Write (T mod 10, Decimal); 1373 end if; 1374 end if; 1375 1376 else 1377 UI_Write (Val.Num * (Uint_2 ** (-Val.Den)), Decimal); 1378 Write_Str (".0"); 1379 end if; 1380 1381 -- Constants in base 10 or 16 can be written in normal Ada literal 1382 -- style, as long as they fit in the UI_Image_Buffer. Using hexadecimal 1383 -- notation, 4 bytes are required for the 16# # part, and every fifth 1384 -- character is an underscore. So, a buffer of size N has room for 1385 -- ((N - 4) - (N - 4) / 5) * 4 bits, 1386 -- or at least 1387 -- N * 16 / 5 - 12 bits. 1388 1389 elsif (Val.Rbase = 10 or else Val.Rbase = 16) 1390 and then Num_Bits (Val.Num) < UI_Image_Buffer'Length * 16 / 5 - 12 1391 then 1392 pragma Assert (Val.Den /= 0); 1393 1394 -- Use fixed-point format for small scaling values 1395 1396 if (Val.Rbase = 10 and then Val.Den < 0 and then Val.Den > -3) 1397 or else (Val.Rbase = 16 and then Val.Den = -1) 1398 then 1399 UI_Write (Val.Num * Val.Rbase**(-Val.Den), Decimal); 1400 Write_Str (".0"); 1401 1402 -- Write hexadecimal constants in exponential notation with a zero 1403 -- unit digit. This matches the Ada canonical form for floating point 1404 -- numbers, and also ensures that the underscores end up in the 1405 -- correct place. 1406 1407 elsif Val.Rbase = 16 then 1408 UI_Image (Val.Num, Hex); 1409 pragma Assert (Val.Rbase = 16); 1410 1411 Write_Str ("16#0."); 1412 Write_Str (UI_Image_Buffer (4 .. UI_Image_Length)); 1413 1414 -- For exponent, exclude 16# # and underscores from length 1415 1416 UI_Image_Length := UI_Image_Length - 4; 1417 UI_Image_Length := UI_Image_Length - UI_Image_Length / 5; 1418 1419 Write_Char ('E'); 1420 UI_Write (Int (UI_Image_Length) - Val.Den, Decimal); 1421 1422 elsif Val.Den = 1 then 1423 UI_Write (Val.Num / 10, Decimal); 1424 Write_Char ('.'); 1425 UI_Write (Val.Num mod 10, Decimal); 1426 1427 elsif Val.Den = 2 then 1428 UI_Write (Val.Num / 100, Decimal); 1429 Write_Char ('.'); 1430 UI_Write (Val.Num / 10 mod 10, Decimal); 1431 UI_Write (Val.Num mod 10, Decimal); 1432 1433 -- Else use decimal exponential format 1434 1435 else 1436 -- Write decimal constants with a non-zero unit digit. This 1437 -- matches usual scientific notation. 1438 1439 UI_Image (Val.Num, Decimal); 1440 Write_Char (UI_Image_Buffer (1)); 1441 Write_Char ('.'); 1442 1443 if UI_Image_Length = 1 then 1444 Write_Char ('0'); 1445 else 1446 Write_Str (UI_Image_Buffer (2 .. UI_Image_Length)); 1447 end if; 1448 1449 Write_Char ('E'); 1450 UI_Write (Int (UI_Image_Length - 1) - Val.Den, Decimal); 1451 end if; 1452 1453 -- Other constants with a base other than 10 are written using one of 1454 -- the following forms, depending on the sign of the number and the 1455 -- sign of the exponent (= minus denominator value). See that we are 1456 -- replacing the division by a multiplication (updating accordingly the 1457 -- sign of the exponent) to generate an expression whose computation 1458 -- does not cause a division by 0 when base**exponent is very small. 1459 1460 -- numerator.0*base**exponent 1461 -- numerator.0*base**-exponent 1462 1463 -- And of course an exponent of 0 can be omitted. 1464 1465 elsif Val.Rbase /= 0 then 1466 if Brackets then 1467 Write_Char ('['); 1468 end if; 1469 1470 UI_Write (Val.Num, Decimal); 1471 Write_Str (".0"); 1472 1473 if Val.Den /= 0 then 1474 Write_Char ('*'); 1475 Write_Int (Val.Rbase); 1476 Write_Str ("**"); 1477 1478 if Val.Den <= 0 then 1479 UI_Write (-Val.Den, Decimal); 1480 else 1481 Write_Str ("(-"); 1482 UI_Write (Val.Den, Decimal); 1483 Write_Char (')'); 1484 end if; 1485 end if; 1486 1487 if Brackets then 1488 Write_Char (']'); 1489 end if; 1490 1491 -- Rationals where numerator is divisible by denominator can be output 1492 -- as literals after we do the division. This includes the common case 1493 -- where the denominator is 1. 1494 1495 elsif Val.Num mod Val.Den = 0 then 1496 UI_Write (Val.Num / Val.Den, Decimal); 1497 Write_Str (".0"); 1498 1499 -- Other non-based (rational) constants are written in num/den style 1500 1501 else 1502 if Brackets then 1503 Write_Char ('['); 1504 end if; 1505 1506 UI_Write (Val.Num, Decimal); 1507 Write_Str (".0/"); 1508 UI_Write (Val.Den, Decimal); 1509 Write_Str (".0"); 1510 1511 if Brackets then 1512 Write_Char (']'); 1513 end if; 1514 end if; 1515 end UR_Write; 1516 1517 ---------------------- 1518 -- UR_Write_To_JSON -- 1519 ---------------------- 1520 1521 -- We defer to the implementation of UR_Write in all cases, either directly 1522 -- for values that are naturally written in a JSON compatible format, or by 1523 -- first computing a decimal approxixmation for other values. 1524 1525 procedure UR_Write_To_JSON (Real : Ureal) is 1526 Val : constant Ureal_Entry := Ureals.Table (Real); 1527 Imrk : constant Uintp.Save_Mark := Mark; 1528 Rmrk : constant Urealp.Save_Mark := Mark; 1529 1530 T : Ureal; 1531 1532 begin 1533 -- Zero is zero 1534 1535 if Val.Num = 0 then 1536 T := Real; 1537 1538 -- For constants with a denominator of zero, the value is simply the 1539 -- numerator value, since we are dividing by base**0, which is 1. 1540 1541 elsif Val.Den = 0 then 1542 T := Real; 1543 1544 -- Small powers of 2 get written in decimal fixed-point format 1545 1546 elsif Val.Rbase = 2 1547 and then Val.Den <= 3 1548 and then Val.Den >= -16 1549 then 1550 T := Real; 1551 1552 -- Constants in base 10 can be written in normal Ada literal style 1553 1554 elsif Val.Rbase = 10 then 1555 T := Real; 1556 1557 -- Rationals where numerator is divisible by denominator can be output 1558 -- as literals after we do the division. This includes the common case 1559 -- where the denominator is 1. 1560 1561 elsif Val.Rbase = 0 and then Val.Num mod Val.Den = 0 then 1562 T := Real; 1563 1564 -- For other constants, compute an approxixmation in base 10 1565 1566 else 1567 declare 1568 A : constant Ureal := UR_Abs (Real); 1569 -- The absolute value 1570 1571 E : constant Uint := 1572 (if A < Ureal_1 1573 then UI_From_Int (3 - Decimal_Exponent_Lo (Real)) 1574 else Uint_3); 1575 -- The exponent for at least 3 digits after the decimal point 1576 1577 Num : constant Uint := 1578 UR_To_Uint (UR_Mul (A, UR_Exponentiate (Ureal_10, E))); 1579 -- The numerator appropriately rounded 1580 1581 begin 1582 T := UR_From_Components (Num, E, 10, Val.Negative); 1583 end; 1584 end if; 1585 1586 UR_Write (T); 1587 Release (Imrk); 1588 Release (Rmrk); 1589 end UR_Write_To_JSON; 1590 1591 ------------- 1592 -- Ureal_0 -- 1593 ------------- 1594 1595 function Ureal_0 return Ureal is 1596 begin 1597 return UR_0; 1598 end Ureal_0; 1599 1600 ------------- 1601 -- Ureal_1 -- 1602 ------------- 1603 1604 function Ureal_1 return Ureal is 1605 begin 1606 return UR_1; 1607 end Ureal_1; 1608 1609 ------------- 1610 -- Ureal_2 -- 1611 ------------- 1612 1613 function Ureal_2 return Ureal is 1614 begin 1615 return UR_2; 1616 end Ureal_2; 1617 1618 -------------- 1619 -- Ureal_10 -- 1620 -------------- 1621 1622 function Ureal_10 return Ureal is 1623 begin 1624 return UR_10; 1625 end Ureal_10; 1626 1627 --------------- 1628 -- Ureal_100 -- 1629 --------------- 1630 1631 function Ureal_100 return Ureal is 1632 begin 1633 return UR_100; 1634 end Ureal_100; 1635 1636 ------------------- 1637 -- Ureal_2_10_18 -- 1638 ------------------- 1639 1640 function Ureal_2_10_18 return Ureal is 1641 begin 1642 return UR_2_10_18; 1643 end Ureal_2_10_18; 1644 1645 ------------------- 1646 -- Ureal_9_10_36 -- 1647 ------------------- 1648 1649 function Ureal_9_10_36 return Ureal is 1650 begin 1651 return UR_9_10_36; 1652 end Ureal_9_10_36; 1653 1654 ----------------- 1655 -- Ureal_10_76 -- 1656 ----------------- 1657 1658 function Ureal_10_76 return Ureal is 1659 begin 1660 return UR_10_76; 1661 end Ureal_10_76; 1662 1663 ---------------- 1664 -- Ureal_2_31 -- 1665 ---------------- 1666 1667 function Ureal_2_31 return Ureal is 1668 begin 1669 return UR_2_31; 1670 end Ureal_2_31; 1671 1672 ---------------- 1673 -- Ureal_2_63 -- 1674 ---------------- 1675 1676 function Ureal_2_63 return Ureal is 1677 begin 1678 return UR_2_63; 1679 end Ureal_2_63; 1680 1681 ---------------- 1682 -- Ureal_2_80 -- 1683 ---------------- 1684 1685 function Ureal_2_80 return Ureal is 1686 begin 1687 return UR_2_80; 1688 end Ureal_2_80; 1689 1690 ----------------- 1691 -- Ureal_2_127 -- 1692 ----------------- 1693 1694 function Ureal_2_127 return Ureal is 1695 begin 1696 return UR_2_127; 1697 end Ureal_2_127; 1698 1699 ----------------- 1700 -- Ureal_2_128 -- 1701 ----------------- 1702 1703 function Ureal_2_128 return Ureal is 1704 begin 1705 return UR_2_128; 1706 end Ureal_2_128; 1707 1708 ------------------- 1709 -- Ureal_2_M_80 -- 1710 ------------------- 1711 1712 function Ureal_2_M_80 return Ureal is 1713 begin 1714 return UR_2_M_80; 1715 end Ureal_2_M_80; 1716 1717 ------------------- 1718 -- Ureal_2_M_127 -- 1719 ------------------- 1720 1721 function Ureal_2_M_127 return Ureal is 1722 begin 1723 return UR_2_M_127; 1724 end Ureal_2_M_127; 1725 1726 ------------------- 1727 -- Ureal_2_M_128 -- 1728 ------------------- 1729 1730 function Ureal_2_M_128 return Ureal is 1731 begin 1732 return UR_2_M_128; 1733 end Ureal_2_M_128; 1734 1735 ---------------- 1736 -- Ureal_Half -- 1737 ---------------- 1738 1739 function Ureal_Half return Ureal is 1740 begin 1741 return UR_Half; 1742 end Ureal_Half; 1743 1744 --------------- 1745 -- Ureal_M_0 -- 1746 --------------- 1747 1748 function Ureal_M_0 return Ureal is 1749 begin 1750 return UR_M_0; 1751 end Ureal_M_0; 1752 1753 --------------------- 1754 -- Ureal_M_2_10_18 -- 1755 --------------------- 1756 1757 function Ureal_M_2_10_18 return Ureal is 1758 begin 1759 return UR_M_2_10_18; 1760 end Ureal_M_2_10_18; 1761 1762 --------------------- 1763 -- Ureal_M_9_10_36 -- 1764 --------------------- 1765 1766 function Ureal_M_9_10_36 return Ureal is 1767 begin 1768 return UR_M_9_10_36; 1769 end Ureal_M_9_10_36; 1770 1771 ------------------- 1772 -- Ureal_M_10_76 -- 1773 ------------------- 1774 1775 function Ureal_M_10_76 return Ureal is 1776 begin 1777 return UR_M_10_76; 1778 end Ureal_M_10_76; 1779 1780 ----------------- 1781 -- Ureal_Tenth -- 1782 ----------------- 1783 1784 function Ureal_Tenth return Ureal is 1785 begin 1786 return UR_Tenth; 1787 end Ureal_Tenth; 1788 1789end Urealp; 1790