1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- U I N T P -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Output; use Output; 33with Tree_IO; use Tree_IO; 34 35with GNAT.HTable; use GNAT.HTable; 36 37package body Uintp is 38 39 ------------------------ 40 -- Local Declarations -- 41 ------------------------ 42 43 Uint_Int_First : Uint := Uint_0; 44 -- Uint value containing Int'First value, set by Initialize. The initial 45 -- value of Uint_0 is used for an assertion check that ensures that this 46 -- value is not used before it is initialized. This value is used in the 47 -- UI_Is_In_Int_Range predicate, and it is right that this is a host value, 48 -- since the issue is host representation of integer values. 49 50 Uint_Int_Last : Uint; 51 -- Uint value containing Int'Last value set by Initialize 52 53 UI_Power_2 : array (Int range 0 .. 64) of Uint; 54 -- This table is used to memoize exponentiations by powers of 2. The Nth 55 -- entry, if set, contains the Uint value 2 ** N. Initially UI_Power_2_Set 56 -- is zero and only the 0'th entry is set, the invariant being that all 57 -- entries in the range 0 .. UI_Power_2_Set are initialized. 58 59 UI_Power_2_Set : Nat; 60 -- Number of entries set in UI_Power_2; 61 62 UI_Power_10 : array (Int range 0 .. 64) of Uint; 63 -- This table is used to memoize exponentiations by powers of 10 in the 64 -- same manner as described above for UI_Power_2. 65 66 UI_Power_10_Set : Nat; 67 -- Number of entries set in UI_Power_10; 68 69 Uints_Min : Uint; 70 Udigits_Min : Int; 71 -- These values are used to make sure that the mark/release mechanism does 72 -- not destroy values saved in the U_Power tables or in the hash table used 73 -- by UI_From_Int. Whenever an entry is made in either of these tables, 74 -- Uints_Min and Udigits_Min are updated to protect the entry, and Release 75 -- never cuts back beyond these minimum values. 76 77 Int_0 : constant Int := 0; 78 Int_1 : constant Int := 1; 79 Int_2 : constant Int := 2; 80 -- These values are used in some cases where the use of numeric literals 81 -- would cause ambiguities (integer vs Uint). 82 83 ---------------------------- 84 -- UI_From_Int Hash Table -- 85 ---------------------------- 86 87 -- UI_From_Int uses a hash table to avoid duplicating entries and wasting 88 -- storage. This is particularly important for complex cases of back 89 -- annotation. 90 91 subtype Hnum is Nat range 0 .. 1022; 92 93 function Hash_Num (F : Int) return Hnum; 94 -- Hashing function 95 96 package UI_Ints is new Simple_HTable ( 97 Header_Num => Hnum, 98 Element => Uint, 99 No_Element => No_Uint, 100 Key => Int, 101 Hash => Hash_Num, 102 Equal => "="); 103 104 ----------------------- 105 -- Local Subprograms -- 106 ----------------------- 107 108 function Direct (U : Uint) return Boolean; 109 pragma Inline (Direct); 110 -- Returns True if U is represented directly 111 112 function Direct_Val (U : Uint) return Int; 113 -- U is a Uint for is represented directly. The returned result is the 114 -- value represented. 115 116 function GCD (Jin, Kin : Int) return Int; 117 -- Compute GCD of two integers. Assumes that Jin >= Kin >= 0 118 119 procedure Image_Out 120 (Input : Uint; 121 To_Buffer : Boolean; 122 Format : UI_Format); 123 -- Common processing for UI_Image and UI_Write, To_Buffer is set True for 124 -- UI_Image, and false for UI_Write, and Format is copied from the Format 125 -- parameter to UI_Image or UI_Write. 126 127 procedure Init_Operand (UI : Uint; Vec : out UI_Vector); 128 pragma Inline (Init_Operand); 129 -- This procedure puts the value of UI into the vector in canonical 130 -- multiple precision format. The parameter should be of the correct size 131 -- as determined by a previous call to N_Digits (UI). The first digit of 132 -- Vec contains the sign, all other digits are always non-negative. Note 133 -- that the input may be directly represented, and in this case Vec will 134 -- contain the corresponding one or two digit value. The low bound of Vec 135 -- is always 1. 136 137 function Least_Sig_Digit (Arg : Uint) return Int; 138 pragma Inline (Least_Sig_Digit); 139 -- Returns the Least Significant Digit of Arg quickly. When the given Uint 140 -- is less than 2**15, the value returned is the input value, in this case 141 -- the result may be negative. It is expected that any use will mask off 142 -- unnecessary bits. This is used for finding Arg mod B where B is a power 143 -- of two. Hence the actual base is irrelevant as long as it is a power of 144 -- two. 145 146 procedure Most_Sig_2_Digits 147 (Left : Uint; 148 Right : Uint; 149 Left_Hat : out Int; 150 Right_Hat : out Int); 151 -- Returns leading two significant digits from the given pair of Uint's. 152 -- Mathematically: returns Left / (Base ** K) and Right / (Base ** K) where 153 -- K is as small as possible S.T. Right_Hat < Base * Base. It is required 154 -- that Left > Right for the algorithm to work. 155 156 function N_Digits (Input : Uint) return Int; 157 pragma Inline (N_Digits); 158 -- Returns number of "digits" in a Uint 159 160 procedure UI_Div_Rem 161 (Left, Right : Uint; 162 Quotient : out Uint; 163 Remainder : out Uint; 164 Discard_Quotient : Boolean := False; 165 Discard_Remainder : Boolean := False); 166 -- Compute Euclidean division of Left by Right. If Discard_Quotient is 167 -- False then the quotient is returned in Quotient (otherwise Quotient is 168 -- set to No_Uint). If Discard_Remainder is False, then the remainder is 169 -- returned in Remainder (otherwise Remainder is set to No_Uint). 170 -- 171 -- If Discard_Quotient is True, Quotient is set to No_Uint 172 -- If Discard_Remainder is True, Remainder is set to No_Uint 173 174 function Vector_To_Uint 175 (In_Vec : UI_Vector; 176 Negative : Boolean) return Uint; 177 -- Functions that calculate values in UI_Vectors, call this function to 178 -- create and return the Uint value. In_Vec contains the multiple precision 179 -- (Base) representation of a non-negative value. Leading zeroes are 180 -- permitted. Negative is set if the desired result is the negative of the 181 -- given value. The result will be either the appropriate directly 182 -- represented value, or a table entry in the proper canonical format is 183 -- created and returned. 184 -- 185 -- Note that Init_Operand puts a signed value in the result vector, but 186 -- Vector_To_Uint is always presented with a non-negative value. The 187 -- processing of signs is something that is done by the caller before 188 -- calling Vector_To_Uint. 189 190 ------------ 191 -- Direct -- 192 ------------ 193 194 function Direct (U : Uint) return Boolean is 195 begin 196 return Int (U) <= Int (Uint_Direct_Last); 197 end Direct; 198 199 ---------------- 200 -- Direct_Val -- 201 ---------------- 202 203 function Direct_Val (U : Uint) return Int is 204 begin 205 pragma Assert (Direct (U)); 206 return Int (U) - Int (Uint_Direct_Bias); 207 end Direct_Val; 208 209 --------- 210 -- GCD -- 211 --------- 212 213 function GCD (Jin, Kin : Int) return Int is 214 J, K, Tmp : Int; 215 216 begin 217 pragma Assert (Jin >= Kin); 218 pragma Assert (Kin >= Int_0); 219 220 J := Jin; 221 K := Kin; 222 while K /= Uint_0 loop 223 Tmp := J mod K; 224 J := K; 225 K := Tmp; 226 end loop; 227 228 return J; 229 end GCD; 230 231 -------------- 232 -- Hash_Num -- 233 -------------- 234 235 function Hash_Num (F : Int) return Hnum is 236 begin 237 return Types."mod" (F, Hnum'Range_Length); 238 end Hash_Num; 239 240 --------------- 241 -- Image_Out -- 242 --------------- 243 244 procedure Image_Out 245 (Input : Uint; 246 To_Buffer : Boolean; 247 Format : UI_Format) 248 is 249 Marks : constant Uintp.Save_Mark := Uintp.Mark; 250 Base : Uint; 251 Ainput : Uint; 252 253 Digs_Output : Natural := 0; 254 -- Counts digits output. In hex mode, but not in decimal mode, we 255 -- put an underline after every four hex digits that are output. 256 257 Exponent : Natural := 0; 258 -- If the number is too long to fit in the buffer, we switch to an 259 -- approximate output format with an exponent. This variable records 260 -- the exponent value. 261 262 function Better_In_Hex return Boolean; 263 -- Determines if it is better to generate digits in base 16 (result 264 -- is true) or base 10 (result is false). The choice is purely a 265 -- matter of convenience and aesthetics, so it does not matter which 266 -- value is returned from a correctness point of view. 267 268 procedure Image_Char (C : Character); 269 -- Internal procedure to output one character 270 271 procedure Image_Exponent (N : Natural); 272 -- Output non-zero exponent. Note that we only use the exponent form in 273 -- the buffer case, so we know that To_Buffer is true. 274 275 procedure Image_Uint (U : Uint); 276 -- Internal procedure to output characters of non-negative Uint 277 278 ------------------- 279 -- Better_In_Hex -- 280 ------------------- 281 282 function Better_In_Hex return Boolean is 283 T16 : constant Uint := Uint_2 ** Int'(16); 284 A : Uint; 285 286 begin 287 A := UI_Abs (Input); 288 289 -- Small values up to 2**16 can always be in decimal 290 291 if A < T16 then 292 return False; 293 end if; 294 295 -- Otherwise, see if we are a power of 2 or one less than a power 296 -- of 2. For the moment these are the only cases printed in hex. 297 298 if A mod Uint_2 = Uint_1 then 299 A := A + Uint_1; 300 end if; 301 302 loop 303 if A mod T16 /= Uint_0 then 304 return False; 305 306 else 307 A := A / T16; 308 end if; 309 310 exit when A < T16; 311 end loop; 312 313 while A > Uint_2 loop 314 if A mod Uint_2 /= Uint_0 then 315 return False; 316 317 else 318 A := A / Uint_2; 319 end if; 320 end loop; 321 322 return True; 323 end Better_In_Hex; 324 325 ---------------- 326 -- Image_Char -- 327 ---------------- 328 329 procedure Image_Char (C : Character) is 330 begin 331 if To_Buffer then 332 if UI_Image_Length + 6 > UI_Image_Max then 333 Exponent := Exponent + 1; 334 else 335 UI_Image_Length := UI_Image_Length + 1; 336 UI_Image_Buffer (UI_Image_Length) := C; 337 end if; 338 else 339 Write_Char (C); 340 end if; 341 end Image_Char; 342 343 -------------------- 344 -- Image_Exponent -- 345 -------------------- 346 347 procedure Image_Exponent (N : Natural) is 348 begin 349 if N >= 10 then 350 Image_Exponent (N / 10); 351 end if; 352 353 UI_Image_Length := UI_Image_Length + 1; 354 UI_Image_Buffer (UI_Image_Length) := 355 Character'Val (Character'Pos ('0') + N mod 10); 356 end Image_Exponent; 357 358 ---------------- 359 -- Image_Uint -- 360 ---------------- 361 362 procedure Image_Uint (U : Uint) is 363 H : constant array (Int range 0 .. 15) of Character := 364 "0123456789ABCDEF"; 365 366 Q, R : Uint; 367 begin 368 UI_Div_Rem (U, Base, Q, R); 369 370 if Q > Uint_0 then 371 Image_Uint (Q); 372 end if; 373 374 if Digs_Output = 4 and then Base = Uint_16 then 375 Image_Char ('_'); 376 Digs_Output := 0; 377 end if; 378 379 Image_Char (H (UI_To_Int (R))); 380 381 Digs_Output := Digs_Output + 1; 382 end Image_Uint; 383 384 -- Start of processing for Image_Out 385 386 begin 387 if Input = No_Uint then 388 Image_Char ('?'); 389 return; 390 end if; 391 392 UI_Image_Length := 0; 393 394 if Input < Uint_0 then 395 Image_Char ('-'); 396 Ainput := -Input; 397 else 398 Ainput := Input; 399 end if; 400 401 if Format = Hex 402 or else (Format = Auto and then Better_In_Hex) 403 then 404 Base := Uint_16; 405 Image_Char ('1'); 406 Image_Char ('6'); 407 Image_Char ('#'); 408 Image_Uint (Ainput); 409 Image_Char ('#'); 410 411 else 412 Base := Uint_10; 413 Image_Uint (Ainput); 414 end if; 415 416 if Exponent /= 0 then 417 UI_Image_Length := UI_Image_Length + 1; 418 UI_Image_Buffer (UI_Image_Length) := 'E'; 419 Image_Exponent (Exponent); 420 end if; 421 422 Uintp.Release (Marks); 423 end Image_Out; 424 425 ------------------- 426 -- Init_Operand -- 427 ------------------- 428 429 procedure Init_Operand (UI : Uint; Vec : out UI_Vector) is 430 Loc : Int; 431 432 pragma Assert (Vec'First = Int'(1)); 433 434 begin 435 if Direct (UI) then 436 Vec (1) := Direct_Val (UI); 437 438 if Vec (1) >= Base then 439 Vec (2) := Vec (1) rem Base; 440 Vec (1) := Vec (1) / Base; 441 end if; 442 443 else 444 Loc := Uints.Table (UI).Loc; 445 446 for J in 1 .. Uints.Table (UI).Length loop 447 Vec (J) := Udigits.Table (Loc + J - 1); 448 end loop; 449 end if; 450 end Init_Operand; 451 452 ---------------- 453 -- Initialize -- 454 ---------------- 455 456 procedure Initialize is 457 begin 458 Uints.Init; 459 Udigits.Init; 460 461 Uint_Int_First := UI_From_Int (Int'First); 462 Uint_Int_Last := UI_From_Int (Int'Last); 463 464 UI_Power_2 (0) := Uint_1; 465 UI_Power_2_Set := 0; 466 467 UI_Power_10 (0) := Uint_1; 468 UI_Power_10_Set := 0; 469 470 Uints_Min := Uints.Last; 471 Udigits_Min := Udigits.Last; 472 473 UI_Ints.Reset; 474 end Initialize; 475 476 --------------------- 477 -- Least_Sig_Digit -- 478 --------------------- 479 480 function Least_Sig_Digit (Arg : Uint) return Int is 481 V : Int; 482 483 begin 484 if Direct (Arg) then 485 V := Direct_Val (Arg); 486 487 if V >= Base then 488 V := V mod Base; 489 end if; 490 491 -- Note that this result may be negative 492 493 return V; 494 495 else 496 return 497 Udigits.Table 498 (Uints.Table (Arg).Loc + Uints.Table (Arg).Length - 1); 499 end if; 500 end Least_Sig_Digit; 501 502 ---------- 503 -- Mark -- 504 ---------- 505 506 function Mark return Save_Mark is 507 begin 508 return (Save_Uint => Uints.Last, Save_Udigit => Udigits.Last); 509 end Mark; 510 511 ----------------------- 512 -- Most_Sig_2_Digits -- 513 ----------------------- 514 515 procedure Most_Sig_2_Digits 516 (Left : Uint; 517 Right : Uint; 518 Left_Hat : out Int; 519 Right_Hat : out Int) 520 is 521 begin 522 pragma Assert (Left >= Right); 523 524 if Direct (Left) then 525 Left_Hat := Direct_Val (Left); 526 Right_Hat := Direct_Val (Right); 527 return; 528 529 else 530 declare 531 L1 : constant Int := 532 Udigits.Table (Uints.Table (Left).Loc); 533 L2 : constant Int := 534 Udigits.Table (Uints.Table (Left).Loc + 1); 535 536 begin 537 -- It is not so clear what to return when Arg is negative??? 538 539 Left_Hat := abs (L1) * Base + L2; 540 end; 541 end if; 542 543 declare 544 Length_L : constant Int := Uints.Table (Left).Length; 545 Length_R : Int; 546 R1 : Int; 547 R2 : Int; 548 T : Int; 549 550 begin 551 if Direct (Right) then 552 T := Direct_Val (Left); 553 R1 := abs (T / Base); 554 R2 := T rem Base; 555 Length_R := 2; 556 557 else 558 R1 := abs (Udigits.Table (Uints.Table (Right).Loc)); 559 R2 := Udigits.Table (Uints.Table (Right).Loc + 1); 560 Length_R := Uints.Table (Right).Length; 561 end if; 562 563 if Length_L = Length_R then 564 Right_Hat := R1 * Base + R2; 565 elsif Length_L = Length_R + Int_1 then 566 Right_Hat := R1; 567 else 568 Right_Hat := 0; 569 end if; 570 end; 571 end Most_Sig_2_Digits; 572 573 --------------- 574 -- N_Digits -- 575 --------------- 576 577 -- Note: N_Digits returns 1 for No_Uint 578 579 function N_Digits (Input : Uint) return Int is 580 begin 581 if Direct (Input) then 582 if Direct_Val (Input) >= Base then 583 return 2; 584 else 585 return 1; 586 end if; 587 588 else 589 return Uints.Table (Input).Length; 590 end if; 591 end N_Digits; 592 593 -------------- 594 -- Num_Bits -- 595 -------------- 596 597 function Num_Bits (Input : Uint) return Nat is 598 Bits : Nat; 599 Num : Nat; 600 601 begin 602 -- Largest negative number has to be handled specially, since it is in 603 -- Int_Range, but we cannot take the absolute value. 604 605 if Input = Uint_Int_First then 606 return Int'Size; 607 608 -- For any other number in Int_Range, get absolute value of number 609 610 elsif UI_Is_In_Int_Range (Input) then 611 Num := abs (UI_To_Int (Input)); 612 Bits := 0; 613 614 -- If not in Int_Range then initialize bit count for all low order 615 -- words, and set number to high order digit. 616 617 else 618 Bits := Base_Bits * (Uints.Table (Input).Length - 1); 619 Num := abs (Udigits.Table (Uints.Table (Input).Loc)); 620 end if; 621 622 -- Increase bit count for remaining value in Num 623 624 while Types.">" (Num, 0) loop 625 Num := Num / 2; 626 Bits := Bits + 1; 627 end loop; 628 629 return Bits; 630 end Num_Bits; 631 632 --------- 633 -- pid -- 634 --------- 635 636 procedure pid (Input : Uint) is 637 begin 638 UI_Write (Input, Decimal); 639 Write_Eol; 640 end pid; 641 642 --------- 643 -- pih -- 644 --------- 645 646 procedure pih (Input : Uint) is 647 begin 648 UI_Write (Input, Hex); 649 Write_Eol; 650 end pih; 651 652 ------------- 653 -- Release -- 654 ------------- 655 656 procedure Release (M : Save_Mark) is 657 begin 658 Uints.Set_Last (Uint'Max (M.Save_Uint, Uints_Min)); 659 Udigits.Set_Last (Int'Max (M.Save_Udigit, Udigits_Min)); 660 end Release; 661 662 ---------------------- 663 -- Release_And_Save -- 664 ---------------------- 665 666 procedure Release_And_Save (M : Save_Mark; UI : in out Uint) is 667 begin 668 if Direct (UI) then 669 Release (M); 670 671 else 672 declare 673 UE_Len : constant Pos := Uints.Table (UI).Length; 674 UE_Loc : constant Int := Uints.Table (UI).Loc; 675 676 UD : constant Udigits.Table_Type (1 .. UE_Len) := 677 Udigits.Table (UE_Loc .. UE_Loc + UE_Len - 1); 678 679 begin 680 Release (M); 681 682 Uints.Append ((Length => UE_Len, Loc => Udigits.Last + 1)); 683 UI := Uints.Last; 684 685 for J in 1 .. UE_Len loop 686 Udigits.Append (UD (J)); 687 end loop; 688 end; 689 end if; 690 end Release_And_Save; 691 692 procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Uint) is 693 begin 694 if Direct (UI1) then 695 Release_And_Save (M, UI2); 696 697 elsif Direct (UI2) then 698 Release_And_Save (M, UI1); 699 700 else 701 declare 702 UE1_Len : constant Pos := Uints.Table (UI1).Length; 703 UE1_Loc : constant Int := Uints.Table (UI1).Loc; 704 705 UD1 : constant Udigits.Table_Type (1 .. UE1_Len) := 706 Udigits.Table (UE1_Loc .. UE1_Loc + UE1_Len - 1); 707 708 UE2_Len : constant Pos := Uints.Table (UI2).Length; 709 UE2_Loc : constant Int := Uints.Table (UI2).Loc; 710 711 UD2 : constant Udigits.Table_Type (1 .. UE2_Len) := 712 Udigits.Table (UE2_Loc .. UE2_Loc + UE2_Len - 1); 713 714 begin 715 Release (M); 716 717 Uints.Append ((Length => UE1_Len, Loc => Udigits.Last + 1)); 718 UI1 := Uints.Last; 719 720 for J in 1 .. UE1_Len loop 721 Udigits.Append (UD1 (J)); 722 end loop; 723 724 Uints.Append ((Length => UE2_Len, Loc => Udigits.Last + 1)); 725 UI2 := Uints.Last; 726 727 for J in 1 .. UE2_Len loop 728 Udigits.Append (UD2 (J)); 729 end loop; 730 end; 731 end if; 732 end Release_And_Save; 733 734 --------------- 735 -- Tree_Read -- 736 --------------- 737 738 procedure Tree_Read is 739 begin 740 Uints.Tree_Read; 741 Udigits.Tree_Read; 742 743 Tree_Read_Int (Int (Uint_Int_First)); 744 Tree_Read_Int (Int (Uint_Int_Last)); 745 Tree_Read_Int (UI_Power_2_Set); 746 Tree_Read_Int (UI_Power_10_Set); 747 Tree_Read_Int (Int (Uints_Min)); 748 Tree_Read_Int (Udigits_Min); 749 750 for J in 0 .. UI_Power_2_Set loop 751 Tree_Read_Int (Int (UI_Power_2 (J))); 752 end loop; 753 754 for J in 0 .. UI_Power_10_Set loop 755 Tree_Read_Int (Int (UI_Power_10 (J))); 756 end loop; 757 758 end Tree_Read; 759 760 ---------------- 761 -- Tree_Write -- 762 ---------------- 763 764 procedure Tree_Write is 765 begin 766 Uints.Tree_Write; 767 Udigits.Tree_Write; 768 769 Tree_Write_Int (Int (Uint_Int_First)); 770 Tree_Write_Int (Int (Uint_Int_Last)); 771 Tree_Write_Int (UI_Power_2_Set); 772 Tree_Write_Int (UI_Power_10_Set); 773 Tree_Write_Int (Int (Uints_Min)); 774 Tree_Write_Int (Udigits_Min); 775 776 for J in 0 .. UI_Power_2_Set loop 777 Tree_Write_Int (Int (UI_Power_2 (J))); 778 end loop; 779 780 for J in 0 .. UI_Power_10_Set loop 781 Tree_Write_Int (Int (UI_Power_10 (J))); 782 end loop; 783 784 end Tree_Write; 785 786 ------------- 787 -- UI_Abs -- 788 ------------- 789 790 function UI_Abs (Right : Uint) return Uint is 791 begin 792 if Right < Uint_0 then 793 return -Right; 794 else 795 return Right; 796 end if; 797 end UI_Abs; 798 799 ------------- 800 -- UI_Add -- 801 ------------- 802 803 function UI_Add (Left : Int; Right : Uint) return Uint is 804 begin 805 return UI_Add (UI_From_Int (Left), Right); 806 end UI_Add; 807 808 function UI_Add (Left : Uint; Right : Int) return Uint is 809 begin 810 return UI_Add (Left, UI_From_Int (Right)); 811 end UI_Add; 812 813 function UI_Add (Left : Uint; Right : Uint) return Uint is 814 begin 815 -- Simple cases of direct operands and addition of zero 816 817 if Direct (Left) then 818 if Direct (Right) then 819 return UI_From_Int (Direct_Val (Left) + Direct_Val (Right)); 820 821 elsif Int (Left) = Int (Uint_0) then 822 return Right; 823 end if; 824 825 elsif Direct (Right) and then Int (Right) = Int (Uint_0) then 826 return Left; 827 end if; 828 829 -- Otherwise full circuit is needed 830 831 declare 832 L_Length : constant Int := N_Digits (Left); 833 R_Length : constant Int := N_Digits (Right); 834 L_Vec : UI_Vector (1 .. L_Length); 835 R_Vec : UI_Vector (1 .. R_Length); 836 Sum_Length : Int; 837 Tmp_Int : Int; 838 Carry : Int; 839 Borrow : Int; 840 X_Bigger : Boolean := False; 841 Y_Bigger : Boolean := False; 842 Result_Neg : Boolean := False; 843 844 begin 845 Init_Operand (Left, L_Vec); 846 Init_Operand (Right, R_Vec); 847 848 -- At least one of the two operands is in multi-digit form. 849 -- Calculate the number of digits sufficient to hold result. 850 851 if L_Length > R_Length then 852 Sum_Length := L_Length + 1; 853 X_Bigger := True; 854 else 855 Sum_Length := R_Length + 1; 856 857 if R_Length > L_Length then 858 Y_Bigger := True; 859 end if; 860 end if; 861 862 -- Make copies of the absolute values of L_Vec and R_Vec into X and Y 863 -- both with lengths equal to the maximum possibly needed. This makes 864 -- looping over the digits much simpler. 865 866 declare 867 X : UI_Vector (1 .. Sum_Length); 868 Y : UI_Vector (1 .. Sum_Length); 869 Tmp_UI : UI_Vector (1 .. Sum_Length); 870 871 begin 872 for J in 1 .. Sum_Length - L_Length loop 873 X (J) := 0; 874 end loop; 875 876 X (Sum_Length - L_Length + 1) := abs L_Vec (1); 877 878 for J in 2 .. L_Length loop 879 X (J + (Sum_Length - L_Length)) := L_Vec (J); 880 end loop; 881 882 for J in 1 .. Sum_Length - R_Length loop 883 Y (J) := 0; 884 end loop; 885 886 Y (Sum_Length - R_Length + 1) := abs R_Vec (1); 887 888 for J in 2 .. R_Length loop 889 Y (J + (Sum_Length - R_Length)) := R_Vec (J); 890 end loop; 891 892 if (L_Vec (1) < Int_0) = (R_Vec (1) < Int_0) then 893 894 -- Same sign so just add 895 896 Carry := 0; 897 for J in reverse 1 .. Sum_Length loop 898 Tmp_Int := X (J) + Y (J) + Carry; 899 900 if Tmp_Int >= Base then 901 Tmp_Int := Tmp_Int - Base; 902 Carry := 1; 903 else 904 Carry := 0; 905 end if; 906 907 X (J) := Tmp_Int; 908 end loop; 909 910 return Vector_To_Uint (X, L_Vec (1) < Int_0); 911 912 else 913 -- Find which one has bigger magnitude 914 915 if not (X_Bigger or Y_Bigger) then 916 for J in L_Vec'Range loop 917 if abs L_Vec (J) > abs R_Vec (J) then 918 X_Bigger := True; 919 exit; 920 elsif abs R_Vec (J) > abs L_Vec (J) then 921 Y_Bigger := True; 922 exit; 923 end if; 924 end loop; 925 end if; 926 927 -- If they have identical magnitude, just return 0, else swap 928 -- if necessary so that X had the bigger magnitude. Determine 929 -- if result is negative at this time. 930 931 Result_Neg := False; 932 933 if not (X_Bigger or Y_Bigger) then 934 return Uint_0; 935 936 elsif Y_Bigger then 937 if R_Vec (1) < Int_0 then 938 Result_Neg := True; 939 end if; 940 941 Tmp_UI := X; 942 X := Y; 943 Y := Tmp_UI; 944 945 else 946 if L_Vec (1) < Int_0 then 947 Result_Neg := True; 948 end if; 949 end if; 950 951 -- Subtract Y from the bigger X 952 953 Borrow := 0; 954 955 for J in reverse 1 .. Sum_Length loop 956 Tmp_Int := X (J) - Y (J) + Borrow; 957 958 if Tmp_Int < Int_0 then 959 Tmp_Int := Tmp_Int + Base; 960 Borrow := -1; 961 else 962 Borrow := 0; 963 end if; 964 965 X (J) := Tmp_Int; 966 end loop; 967 968 return Vector_To_Uint (X, Result_Neg); 969 970 end if; 971 end; 972 end; 973 end UI_Add; 974 975 -------------------------- 976 -- UI_Decimal_Digits_Hi -- 977 -------------------------- 978 979 function UI_Decimal_Digits_Hi (U : Uint) return Nat is 980 begin 981 -- The maximum value of a "digit" is 32767, which is 5 decimal digits, 982 -- so an N_Digit number could take up to 5 times this number of digits. 983 -- This is certainly too high for large numbers but it is not worth 984 -- worrying about. 985 986 return 5 * N_Digits (U); 987 end UI_Decimal_Digits_Hi; 988 989 -------------------------- 990 -- UI_Decimal_Digits_Lo -- 991 -------------------------- 992 993 function UI_Decimal_Digits_Lo (U : Uint) return Nat is 994 begin 995 -- The maximum value of a "digit" is 32767, which is more than four 996 -- decimal digits, but not a full five digits. The easily computed 997 -- minimum number of decimal digits is thus 1 + 4 * the number of 998 -- digits. This is certainly too low for large numbers but it is not 999 -- worth worrying about. 1000 1001 return 1 + 4 * (N_Digits (U) - 1); 1002 end UI_Decimal_Digits_Lo; 1003 1004 ------------ 1005 -- UI_Div -- 1006 ------------ 1007 1008 function UI_Div (Left : Int; Right : Uint) return Uint is 1009 begin 1010 return UI_Div (UI_From_Int (Left), Right); 1011 end UI_Div; 1012 1013 function UI_Div (Left : Uint; Right : Int) return Uint is 1014 begin 1015 return UI_Div (Left, UI_From_Int (Right)); 1016 end UI_Div; 1017 1018 function UI_Div (Left, Right : Uint) return Uint is 1019 Quotient : Uint; 1020 Remainder : Uint; 1021 pragma Warnings (Off, Remainder); 1022 begin 1023 UI_Div_Rem 1024 (Left, Right, 1025 Quotient, Remainder, 1026 Discard_Remainder => True); 1027 return Quotient; 1028 end UI_Div; 1029 1030 ---------------- 1031 -- UI_Div_Rem -- 1032 ---------------- 1033 1034 procedure UI_Div_Rem 1035 (Left, Right : Uint; 1036 Quotient : out Uint; 1037 Remainder : out Uint; 1038 Discard_Quotient : Boolean := False; 1039 Discard_Remainder : Boolean := False) 1040 is 1041 begin 1042 pragma Assert (Right /= Uint_0); 1043 1044 Quotient := No_Uint; 1045 Remainder := No_Uint; 1046 1047 -- Cases where both operands are represented directly 1048 1049 if Direct (Left) and then Direct (Right) then 1050 declare 1051 DV_Left : constant Int := Direct_Val (Left); 1052 DV_Right : constant Int := Direct_Val (Right); 1053 1054 begin 1055 if not Discard_Quotient then 1056 Quotient := UI_From_Int (DV_Left / DV_Right); 1057 end if; 1058 1059 if not Discard_Remainder then 1060 Remainder := UI_From_Int (DV_Left rem DV_Right); 1061 end if; 1062 1063 return; 1064 end; 1065 end if; 1066 1067 declare 1068 L_Length : constant Int := N_Digits (Left); 1069 R_Length : constant Int := N_Digits (Right); 1070 Q_Length : constant Int := L_Length - R_Length + 1; 1071 L_Vec : UI_Vector (1 .. L_Length); 1072 R_Vec : UI_Vector (1 .. R_Length); 1073 D : Int; 1074 Remainder_I : Int; 1075 Tmp_Divisor : Int; 1076 Carry : Int; 1077 Tmp_Int : Int; 1078 Tmp_Dig : Int; 1079 1080 procedure UI_Div_Vector 1081 (L_Vec : UI_Vector; 1082 R_Int : Int; 1083 Quotient : out UI_Vector; 1084 Remainder : out Int); 1085 pragma Inline (UI_Div_Vector); 1086 -- Specialised variant for case where the divisor is a single digit 1087 1088 procedure UI_Div_Vector 1089 (L_Vec : UI_Vector; 1090 R_Int : Int; 1091 Quotient : out UI_Vector; 1092 Remainder : out Int) 1093 is 1094 Tmp_Int : Int; 1095 1096 begin 1097 Remainder := 0; 1098 for J in L_Vec'Range loop 1099 Tmp_Int := Remainder * Base + abs L_Vec (J); 1100 Quotient (Quotient'First + J - L_Vec'First) := Tmp_Int / R_Int; 1101 Remainder := Tmp_Int rem R_Int; 1102 end loop; 1103 1104 if L_Vec (L_Vec'First) < Int_0 then 1105 Remainder := -Remainder; 1106 end if; 1107 end UI_Div_Vector; 1108 1109 -- Start of processing for UI_Div_Rem 1110 1111 begin 1112 -- Result is zero if left operand is shorter than right 1113 1114 if L_Length < R_Length then 1115 if not Discard_Quotient then 1116 Quotient := Uint_0; 1117 end if; 1118 1119 if not Discard_Remainder then 1120 Remainder := Left; 1121 end if; 1122 1123 return; 1124 end if; 1125 1126 Init_Operand (Left, L_Vec); 1127 Init_Operand (Right, R_Vec); 1128 1129 -- Case of right operand is single digit. Here we can simply divide 1130 -- each digit of the left operand by the divisor, from most to least 1131 -- significant, carrying the remainder to the next digit (just like 1132 -- ordinary long division by hand). 1133 1134 if R_Length = Int_1 then 1135 Tmp_Divisor := abs R_Vec (1); 1136 1137 declare 1138 Quotient_V : UI_Vector (1 .. L_Length); 1139 1140 begin 1141 UI_Div_Vector (L_Vec, Tmp_Divisor, Quotient_V, Remainder_I); 1142 1143 if not Discard_Quotient then 1144 Quotient := 1145 Vector_To_Uint 1146 (Quotient_V, (L_Vec (1) < Int_0 xor R_Vec (1) < Int_0)); 1147 end if; 1148 1149 if not Discard_Remainder then 1150 Remainder := UI_From_Int (Remainder_I); 1151 end if; 1152 1153 return; 1154 end; 1155 end if; 1156 1157 -- The possible simple cases have been exhausted. Now turn to the 1158 -- algorithm D from the section of Knuth mentioned at the top of 1159 -- this package. 1160 1161 Algorithm_D : declare 1162 Dividend : UI_Vector (1 .. L_Length + 1); 1163 Divisor : UI_Vector (1 .. R_Length); 1164 Quotient_V : UI_Vector (1 .. Q_Length); 1165 Divisor_Dig1 : Int; 1166 Divisor_Dig2 : Int; 1167 Q_Guess : Int; 1168 R_Guess : Int; 1169 1170 begin 1171 -- [ NORMALIZE ] (step D1 in the algorithm). First calculate the 1172 -- scale d, and then multiply Left and Right (u and v in the book) 1173 -- by d to get the dividend and divisor to work with. 1174 1175 D := Base / (abs R_Vec (1) + 1); 1176 1177 Dividend (1) := 0; 1178 Dividend (2) := abs L_Vec (1); 1179 1180 for J in 3 .. L_Length + Int_1 loop 1181 Dividend (J) := L_Vec (J - 1); 1182 end loop; 1183 1184 Divisor (1) := abs R_Vec (1); 1185 1186 for J in Int_2 .. R_Length loop 1187 Divisor (J) := R_Vec (J); 1188 end loop; 1189 1190 if D > Int_1 then 1191 1192 -- Multiply Dividend by d 1193 1194 Carry := 0; 1195 for J in reverse Dividend'Range loop 1196 Tmp_Int := Dividend (J) * D + Carry; 1197 Dividend (J) := Tmp_Int rem Base; 1198 Carry := Tmp_Int / Base; 1199 end loop; 1200 1201 -- Multiply Divisor by d 1202 1203 Carry := 0; 1204 for J in reverse Divisor'Range loop 1205 Tmp_Int := Divisor (J) * D + Carry; 1206 Divisor (J) := Tmp_Int rem Base; 1207 Carry := Tmp_Int / Base; 1208 end loop; 1209 end if; 1210 1211 -- Main loop of long division algorithm 1212 1213 Divisor_Dig1 := Divisor (1); 1214 Divisor_Dig2 := Divisor (2); 1215 1216 for J in Quotient_V'Range loop 1217 1218 -- [ CALCULATE Q (hat) ] (step D3 in the algorithm) 1219 1220 -- Note: this version of step D3 is from the original published 1221 -- algorithm, which is known to have a bug causing overflows. 1222 -- See: http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz 1223 -- and http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz. 1224 -- The code below is the fixed version of this step. 1225 1226 Tmp_Int := Dividend (J) * Base + Dividend (J + 1); 1227 1228 -- Initial guess 1229 1230 Q_Guess := Tmp_Int / Divisor_Dig1; 1231 R_Guess := Tmp_Int rem Divisor_Dig1; 1232 1233 -- Refine the guess 1234 1235 while Q_Guess >= Base 1236 or else Divisor_Dig2 * Q_Guess > 1237 R_Guess * Base + Dividend (J + 2) 1238 loop 1239 Q_Guess := Q_Guess - 1; 1240 R_Guess := R_Guess + Divisor_Dig1; 1241 exit when R_Guess >= Base; 1242 end loop; 1243 1244 -- [ MULTIPLY & SUBTRACT ] (step D4). Q_Guess * Divisor is 1245 -- subtracted from the remaining dividend. 1246 1247 Carry := 0; 1248 for K in reverse Divisor'Range loop 1249 Tmp_Int := Dividend (J + K) - Q_Guess * Divisor (K) + Carry; 1250 Tmp_Dig := Tmp_Int rem Base; 1251 Carry := Tmp_Int / Base; 1252 1253 if Tmp_Dig < Int_0 then 1254 Tmp_Dig := Tmp_Dig + Base; 1255 Carry := Carry - 1; 1256 end if; 1257 1258 Dividend (J + K) := Tmp_Dig; 1259 end loop; 1260 1261 Dividend (J) := Dividend (J) + Carry; 1262 1263 -- [ TEST REMAINDER ] & [ ADD BACK ] (steps D5 and D6) 1264 1265 -- Here there is a slight difference from the book: the last 1266 -- carry is always added in above and below (cancelling each 1267 -- other). In fact the dividend going negative is used as 1268 -- the test. 1269 1270 -- If the Dividend went negative, then Q_Guess was off by 1271 -- one, so it is decremented, and the divisor is added back 1272 -- into the relevant portion of the dividend. 1273 1274 if Dividend (J) < Int_0 then 1275 Q_Guess := Q_Guess - 1; 1276 1277 Carry := 0; 1278 for K in reverse Divisor'Range loop 1279 Tmp_Int := Dividend (J + K) + Divisor (K) + Carry; 1280 1281 if Tmp_Int >= Base then 1282 Tmp_Int := Tmp_Int - Base; 1283 Carry := 1; 1284 else 1285 Carry := 0; 1286 end if; 1287 1288 Dividend (J + K) := Tmp_Int; 1289 end loop; 1290 1291 Dividend (J) := Dividend (J) + Carry; 1292 end if; 1293 1294 -- Finally we can get the next quotient digit 1295 1296 Quotient_V (J) := Q_Guess; 1297 end loop; 1298 1299 -- [ UNNORMALIZE ] (step D8) 1300 1301 if not Discard_Quotient then 1302 Quotient := Vector_To_Uint 1303 (Quotient_V, (L_Vec (1) < Int_0 xor R_Vec (1) < Int_0)); 1304 end if; 1305 1306 if not Discard_Remainder then 1307 declare 1308 Remainder_V : UI_Vector (1 .. R_Length); 1309 Discard_Int : Int; 1310 pragma Warnings (Off, Discard_Int); 1311 begin 1312 UI_Div_Vector 1313 (Dividend (Dividend'Last - R_Length + 1 .. Dividend'Last), 1314 D, 1315 Remainder_V, Discard_Int); 1316 Remainder := Vector_To_Uint (Remainder_V, L_Vec (1) < Int_0); 1317 end; 1318 end if; 1319 end Algorithm_D; 1320 end; 1321 end UI_Div_Rem; 1322 1323 ------------ 1324 -- UI_Eq -- 1325 ------------ 1326 1327 function UI_Eq (Left : Int; Right : Uint) return Boolean is 1328 begin 1329 return not UI_Ne (UI_From_Int (Left), Right); 1330 end UI_Eq; 1331 1332 function UI_Eq (Left : Uint; Right : Int) return Boolean is 1333 begin 1334 return not UI_Ne (Left, UI_From_Int (Right)); 1335 end UI_Eq; 1336 1337 function UI_Eq (Left : Uint; Right : Uint) return Boolean is 1338 begin 1339 return not UI_Ne (Left, Right); 1340 end UI_Eq; 1341 1342 -------------- 1343 -- UI_Expon -- 1344 -------------- 1345 1346 function UI_Expon (Left : Int; Right : Uint) return Uint is 1347 begin 1348 return UI_Expon (UI_From_Int (Left), Right); 1349 end UI_Expon; 1350 1351 function UI_Expon (Left : Uint; Right : Int) return Uint is 1352 begin 1353 return UI_Expon (Left, UI_From_Int (Right)); 1354 end UI_Expon; 1355 1356 function UI_Expon (Left : Int; Right : Int) return Uint is 1357 begin 1358 return UI_Expon (UI_From_Int (Left), UI_From_Int (Right)); 1359 end UI_Expon; 1360 1361 function UI_Expon (Left : Uint; Right : Uint) return Uint is 1362 begin 1363 pragma Assert (Right >= Uint_0); 1364 1365 -- Any value raised to power of 0 is 1 1366 1367 if Right = Uint_0 then 1368 return Uint_1; 1369 1370 -- 0 to any positive power is 0 1371 1372 elsif Left = Uint_0 then 1373 return Uint_0; 1374 1375 -- 1 to any power is 1 1376 1377 elsif Left = Uint_1 then 1378 return Uint_1; 1379 1380 -- Any value raised to power of 1 is that value 1381 1382 elsif Right = Uint_1 then 1383 return Left; 1384 1385 -- Cases which can be done by table lookup 1386 1387 elsif Right <= Uint_64 then 1388 1389 -- 2 ** N for N in 2 .. 64 1390 1391 if Left = Uint_2 then 1392 declare 1393 Right_Int : constant Int := Direct_Val (Right); 1394 1395 begin 1396 if Right_Int > UI_Power_2_Set then 1397 for J in UI_Power_2_Set + Int_1 .. Right_Int loop 1398 UI_Power_2 (J) := UI_Power_2 (J - Int_1) * Int_2; 1399 Uints_Min := Uints.Last; 1400 Udigits_Min := Udigits.Last; 1401 end loop; 1402 1403 UI_Power_2_Set := Right_Int; 1404 end if; 1405 1406 return UI_Power_2 (Right_Int); 1407 end; 1408 1409 -- 10 ** N for N in 2 .. 64 1410 1411 elsif Left = Uint_10 then 1412 declare 1413 Right_Int : constant Int := Direct_Val (Right); 1414 1415 begin 1416 if Right_Int > UI_Power_10_Set then 1417 for J in UI_Power_10_Set + Int_1 .. Right_Int loop 1418 UI_Power_10 (J) := UI_Power_10 (J - Int_1) * Int (10); 1419 Uints_Min := Uints.Last; 1420 Udigits_Min := Udigits.Last; 1421 end loop; 1422 1423 UI_Power_10_Set := Right_Int; 1424 end if; 1425 1426 return UI_Power_10 (Right_Int); 1427 end; 1428 end if; 1429 end if; 1430 1431 -- If we fall through, then we have the general case (see Knuth 4.6.3) 1432 1433 declare 1434 N : Uint := Right; 1435 Squares : Uint := Left; 1436 Result : Uint := Uint_1; 1437 M : constant Uintp.Save_Mark := Uintp.Mark; 1438 1439 begin 1440 loop 1441 if (Least_Sig_Digit (N) mod Int_2) = Int_1 then 1442 Result := Result * Squares; 1443 end if; 1444 1445 N := N / Uint_2; 1446 exit when N = Uint_0; 1447 Squares := Squares * Squares; 1448 end loop; 1449 1450 Uintp.Release_And_Save (M, Result); 1451 return Result; 1452 end; 1453 end UI_Expon; 1454 1455 ---------------- 1456 -- UI_From_CC -- 1457 ---------------- 1458 1459 function UI_From_CC (Input : Char_Code) return Uint is 1460 begin 1461 return UI_From_Int (Int (Input)); 1462 end UI_From_CC; 1463 1464 ----------------- 1465 -- UI_From_Int -- 1466 ----------------- 1467 1468 function UI_From_Int (Input : Int) return Uint is 1469 U : Uint; 1470 1471 begin 1472 if Min_Direct <= Input and then Input <= Max_Direct then 1473 return Uint (Int (Uint_Direct_Bias) + Input); 1474 end if; 1475 1476 -- If already in the hash table, return entry 1477 1478 U := UI_Ints.Get (Input); 1479 1480 if U /= No_Uint then 1481 return U; 1482 end if; 1483 1484 -- For values of larger magnitude, compute digits into a vector and call 1485 -- Vector_To_Uint. 1486 1487 declare 1488 Max_For_Int : constant := 3; 1489 -- Base is defined so that 3 Uint digits is sufficient to hold the 1490 -- largest possible Int value. 1491 1492 V : UI_Vector (1 .. Max_For_Int); 1493 1494 Temp_Integer : Int := Input; 1495 1496 begin 1497 for J in reverse V'Range loop 1498 V (J) := abs (Temp_Integer rem Base); 1499 Temp_Integer := Temp_Integer / Base; 1500 end loop; 1501 1502 U := Vector_To_Uint (V, Input < Int_0); 1503 UI_Ints.Set (Input, U); 1504 Uints_Min := Uints.Last; 1505 Udigits_Min := Udigits.Last; 1506 return U; 1507 end; 1508 end UI_From_Int; 1509 1510 ------------ 1511 -- UI_GCD -- 1512 ------------ 1513 1514 -- Lehmer's algorithm for GCD 1515 1516 -- The idea is to avoid using multiple precision arithmetic wherever 1517 -- possible, substituting Int arithmetic instead. See Knuth volume II, 1518 -- Algorithm L (page 329). 1519 1520 -- We use the same notation as Knuth (U_Hat standing for the obvious!) 1521 1522 function UI_GCD (Uin, Vin : Uint) return Uint is 1523 U, V : Uint; 1524 -- Copies of Uin and Vin 1525 1526 U_Hat, V_Hat : Int; 1527 -- The most Significant digits of U,V 1528 1529 A, B, C, D, T, Q, Den1, Den2 : Int; 1530 1531 Tmp_UI : Uint; 1532 Marks : constant Uintp.Save_Mark := Uintp.Mark; 1533 Iterations : Integer := 0; 1534 1535 begin 1536 pragma Assert (Uin >= Vin); 1537 pragma Assert (Vin >= Uint_0); 1538 1539 U := Uin; 1540 V := Vin; 1541 1542 loop 1543 Iterations := Iterations + 1; 1544 1545 if Direct (V) then 1546 if V = Uint_0 then 1547 return U; 1548 else 1549 return 1550 UI_From_Int (GCD (Direct_Val (V), UI_To_Int (U rem V))); 1551 end if; 1552 end if; 1553 1554 Most_Sig_2_Digits (U, V, U_Hat, V_Hat); 1555 A := 1; 1556 B := 0; 1557 C := 0; 1558 D := 1; 1559 1560 loop 1561 -- We might overflow and get division by zero here. This just 1562 -- means we cannot take the single precision step 1563 1564 Den1 := V_Hat + C; 1565 Den2 := V_Hat + D; 1566 exit when Den1 = Int_0 or else Den2 = Int_0; 1567 1568 -- Compute Q, the trial quotient 1569 1570 Q := (U_Hat + A) / Den1; 1571 1572 exit when Q /= ((U_Hat + B) / Den2); 1573 1574 -- A single precision step Euclid step will give same answer as a 1575 -- multiprecision one. 1576 1577 T := A - (Q * C); 1578 A := C; 1579 C := T; 1580 1581 T := B - (Q * D); 1582 B := D; 1583 D := T; 1584 1585 T := U_Hat - (Q * V_Hat); 1586 U_Hat := V_Hat; 1587 V_Hat := T; 1588 1589 end loop; 1590 1591 -- Take a multiprecision Euclid step 1592 1593 if B = Int_0 then 1594 1595 -- No single precision steps take a regular Euclid step 1596 1597 Tmp_UI := U rem V; 1598 U := V; 1599 V := Tmp_UI; 1600 1601 else 1602 -- Use prior single precision steps to compute this Euclid step 1603 1604 -- For constructs such as: 1605 -- sqrt_2: constant := 1.41421_35623_73095_04880_16887_24209_698; 1606 -- sqrt_eps: constant long_float := long_float( 1.0 / sqrt_2) 1607 -- ** long_float'machine_mantissa; 1608 -- 1609 -- we spend 80% of our time working on this step. Perhaps we need 1610 -- a special case Int / Uint dot product to speed things up. ??? 1611 1612 -- Alternatively we could increase the single precision iterations 1613 -- to handle Uint's of some small size ( <5 digits?). Then we 1614 -- would have more iterations on small Uint. On the code above, we 1615 -- only get 5 (on average) single precision iterations per large 1616 -- iteration. ??? 1617 1618 Tmp_UI := (UI_From_Int (A) * U) + (UI_From_Int (B) * V); 1619 V := (UI_From_Int (C) * U) + (UI_From_Int (D) * V); 1620 U := Tmp_UI; 1621 end if; 1622 1623 -- If the operands are very different in magnitude, the loop will 1624 -- generate large amounts of short-lived data, which it is worth 1625 -- removing periodically. 1626 1627 if Iterations > 100 then 1628 Release_And_Save (Marks, U, V); 1629 Iterations := 0; 1630 end if; 1631 end loop; 1632 end UI_GCD; 1633 1634 ------------ 1635 -- UI_Ge -- 1636 ------------ 1637 1638 function UI_Ge (Left : Int; Right : Uint) return Boolean is 1639 begin 1640 return not UI_Lt (UI_From_Int (Left), Right); 1641 end UI_Ge; 1642 1643 function UI_Ge (Left : Uint; Right : Int) return Boolean is 1644 begin 1645 return not UI_Lt (Left, UI_From_Int (Right)); 1646 end UI_Ge; 1647 1648 function UI_Ge (Left : Uint; Right : Uint) return Boolean is 1649 begin 1650 return not UI_Lt (Left, Right); 1651 end UI_Ge; 1652 1653 ------------ 1654 -- UI_Gt -- 1655 ------------ 1656 1657 function UI_Gt (Left : Int; Right : Uint) return Boolean is 1658 begin 1659 return UI_Lt (Right, UI_From_Int (Left)); 1660 end UI_Gt; 1661 1662 function UI_Gt (Left : Uint; Right : Int) return Boolean is 1663 begin 1664 return UI_Lt (UI_From_Int (Right), Left); 1665 end UI_Gt; 1666 1667 function UI_Gt (Left : Uint; Right : Uint) return Boolean is 1668 begin 1669 return UI_Lt (Left => Right, Right => Left); 1670 end UI_Gt; 1671 1672 --------------- 1673 -- UI_Image -- 1674 --------------- 1675 1676 procedure UI_Image (Input : Uint; Format : UI_Format := Auto) is 1677 begin 1678 Image_Out (Input, True, Format); 1679 end UI_Image; 1680 1681 ------------------------- 1682 -- UI_Is_In_Int_Range -- 1683 ------------------------- 1684 1685 function UI_Is_In_Int_Range (Input : Uint) return Boolean is 1686 begin 1687 -- Make sure we don't get called before Initialize 1688 1689 pragma Assert (Uint_Int_First /= Uint_0); 1690 1691 if Direct (Input) then 1692 return True; 1693 else 1694 return Input >= Uint_Int_First 1695 and then Input <= Uint_Int_Last; 1696 end if; 1697 end UI_Is_In_Int_Range; 1698 1699 ------------ 1700 -- UI_Le -- 1701 ------------ 1702 1703 function UI_Le (Left : Int; Right : Uint) return Boolean is 1704 begin 1705 return not UI_Lt (Right, UI_From_Int (Left)); 1706 end UI_Le; 1707 1708 function UI_Le (Left : Uint; Right : Int) return Boolean is 1709 begin 1710 return not UI_Lt (UI_From_Int (Right), Left); 1711 end UI_Le; 1712 1713 function UI_Le (Left : Uint; Right : Uint) return Boolean is 1714 begin 1715 return not UI_Lt (Left => Right, Right => Left); 1716 end UI_Le; 1717 1718 ------------ 1719 -- UI_Lt -- 1720 ------------ 1721 1722 function UI_Lt (Left : Int; Right : Uint) return Boolean is 1723 begin 1724 return UI_Lt (UI_From_Int (Left), Right); 1725 end UI_Lt; 1726 1727 function UI_Lt (Left : Uint; Right : Int) return Boolean is 1728 begin 1729 return UI_Lt (Left, UI_From_Int (Right)); 1730 end UI_Lt; 1731 1732 function UI_Lt (Left : Uint; Right : Uint) return Boolean is 1733 begin 1734 -- Quick processing for identical arguments 1735 1736 if Int (Left) = Int (Right) then 1737 return False; 1738 1739 -- Quick processing for both arguments directly represented 1740 1741 elsif Direct (Left) and then Direct (Right) then 1742 return Int (Left) < Int (Right); 1743 1744 -- At least one argument is more than one digit long 1745 1746 else 1747 declare 1748 L_Length : constant Int := N_Digits (Left); 1749 R_Length : constant Int := N_Digits (Right); 1750 1751 L_Vec : UI_Vector (1 .. L_Length); 1752 R_Vec : UI_Vector (1 .. R_Length); 1753 1754 begin 1755 Init_Operand (Left, L_Vec); 1756 Init_Operand (Right, R_Vec); 1757 1758 if L_Vec (1) < Int_0 then 1759 1760 -- First argument negative, second argument non-negative 1761 1762 if R_Vec (1) >= Int_0 then 1763 return True; 1764 1765 -- Both arguments negative 1766 1767 else 1768 if L_Length /= R_Length then 1769 return L_Length > R_Length; 1770 1771 elsif L_Vec (1) /= R_Vec (1) then 1772 return L_Vec (1) < R_Vec (1); 1773 1774 else 1775 for J in 2 .. L_Vec'Last loop 1776 if L_Vec (J) /= R_Vec (J) then 1777 return L_Vec (J) > R_Vec (J); 1778 end if; 1779 end loop; 1780 1781 return False; 1782 end if; 1783 end if; 1784 1785 else 1786 -- First argument non-negative, second argument negative 1787 1788 if R_Vec (1) < Int_0 then 1789 return False; 1790 1791 -- Both arguments non-negative 1792 1793 else 1794 if L_Length /= R_Length then 1795 return L_Length < R_Length; 1796 else 1797 for J in L_Vec'Range loop 1798 if L_Vec (J) /= R_Vec (J) then 1799 return L_Vec (J) < R_Vec (J); 1800 end if; 1801 end loop; 1802 1803 return False; 1804 end if; 1805 end if; 1806 end if; 1807 end; 1808 end if; 1809 end UI_Lt; 1810 1811 ------------ 1812 -- UI_Max -- 1813 ------------ 1814 1815 function UI_Max (Left : Int; Right : Uint) return Uint is 1816 begin 1817 return UI_Max (UI_From_Int (Left), Right); 1818 end UI_Max; 1819 1820 function UI_Max (Left : Uint; Right : Int) return Uint is 1821 begin 1822 return UI_Max (Left, UI_From_Int (Right)); 1823 end UI_Max; 1824 1825 function UI_Max (Left : Uint; Right : Uint) return Uint is 1826 begin 1827 if Left >= Right then 1828 return Left; 1829 else 1830 return Right; 1831 end if; 1832 end UI_Max; 1833 1834 ------------ 1835 -- UI_Min -- 1836 ------------ 1837 1838 function UI_Min (Left : Int; Right : Uint) return Uint is 1839 begin 1840 return UI_Min (UI_From_Int (Left), Right); 1841 end UI_Min; 1842 1843 function UI_Min (Left : Uint; Right : Int) return Uint is 1844 begin 1845 return UI_Min (Left, UI_From_Int (Right)); 1846 end UI_Min; 1847 1848 function UI_Min (Left : Uint; Right : Uint) return Uint is 1849 begin 1850 if Left <= Right then 1851 return Left; 1852 else 1853 return Right; 1854 end if; 1855 end UI_Min; 1856 1857 ------------- 1858 -- UI_Mod -- 1859 ------------- 1860 1861 function UI_Mod (Left : Int; Right : Uint) return Uint is 1862 begin 1863 return UI_Mod (UI_From_Int (Left), Right); 1864 end UI_Mod; 1865 1866 function UI_Mod (Left : Uint; Right : Int) return Uint is 1867 begin 1868 return UI_Mod (Left, UI_From_Int (Right)); 1869 end UI_Mod; 1870 1871 function UI_Mod (Left : Uint; Right : Uint) return Uint is 1872 Urem : constant Uint := Left rem Right; 1873 1874 begin 1875 if (Left < Uint_0) = (Right < Uint_0) 1876 or else Urem = Uint_0 1877 then 1878 return Urem; 1879 else 1880 return Right + Urem; 1881 end if; 1882 end UI_Mod; 1883 1884 ------------------------------- 1885 -- UI_Modular_Exponentiation -- 1886 ------------------------------- 1887 1888 function UI_Modular_Exponentiation 1889 (B : Uint; 1890 E : Uint; 1891 Modulo : Uint) return Uint 1892 is 1893 M : constant Save_Mark := Mark; 1894 1895 Result : Uint := Uint_1; 1896 Base : Uint := B; 1897 Exponent : Uint := E; 1898 1899 begin 1900 while Exponent /= Uint_0 loop 1901 if Least_Sig_Digit (Exponent) rem Int'(2) = Int'(1) then 1902 Result := (Result * Base) rem Modulo; 1903 end if; 1904 1905 Exponent := Exponent / Uint_2; 1906 Base := (Base * Base) rem Modulo; 1907 end loop; 1908 1909 Release_And_Save (M, Result); 1910 return Result; 1911 end UI_Modular_Exponentiation; 1912 1913 ------------------------ 1914 -- UI_Modular_Inverse -- 1915 ------------------------ 1916 1917 function UI_Modular_Inverse (N : Uint; Modulo : Uint) return Uint is 1918 M : constant Save_Mark := Mark; 1919 U : Uint; 1920 V : Uint; 1921 Q : Uint; 1922 R : Uint; 1923 X : Uint; 1924 Y : Uint; 1925 T : Uint; 1926 S : Int := 1; 1927 1928 begin 1929 U := Modulo; 1930 V := N; 1931 1932 X := Uint_1; 1933 Y := Uint_0; 1934 1935 loop 1936 UI_Div_Rem (U, V, Quotient => Q, Remainder => R); 1937 1938 U := V; 1939 V := R; 1940 1941 T := X; 1942 X := Y + Q * X; 1943 Y := T; 1944 S := -S; 1945 1946 exit when R = Uint_1; 1947 end loop; 1948 1949 if S = Int'(-1) then 1950 X := Modulo - X; 1951 end if; 1952 1953 Release_And_Save (M, X); 1954 return X; 1955 end UI_Modular_Inverse; 1956 1957 ------------ 1958 -- UI_Mul -- 1959 ------------ 1960 1961 function UI_Mul (Left : Int; Right : Uint) return Uint is 1962 begin 1963 return UI_Mul (UI_From_Int (Left), Right); 1964 end UI_Mul; 1965 1966 function UI_Mul (Left : Uint; Right : Int) return Uint is 1967 begin 1968 return UI_Mul (Left, UI_From_Int (Right)); 1969 end UI_Mul; 1970 1971 function UI_Mul (Left : Uint; Right : Uint) return Uint is 1972 begin 1973 -- Case where product fits in the range of a 32-bit integer 1974 1975 if Int (Left) <= Int (Uint_Max_Simple_Mul) 1976 and then 1977 Int (Right) <= Int (Uint_Max_Simple_Mul) 1978 then 1979 return UI_From_Int (Direct_Val (Left) * Direct_Val (Right)); 1980 end if; 1981 1982 -- Otherwise we have the general case (Algorithm M in Knuth) 1983 1984 declare 1985 L_Length : constant Int := N_Digits (Left); 1986 R_Length : constant Int := N_Digits (Right); 1987 L_Vec : UI_Vector (1 .. L_Length); 1988 R_Vec : UI_Vector (1 .. R_Length); 1989 Neg : Boolean; 1990 1991 begin 1992 Init_Operand (Left, L_Vec); 1993 Init_Operand (Right, R_Vec); 1994 Neg := (L_Vec (1) < Int_0) xor (R_Vec (1) < Int_0); 1995 L_Vec (1) := abs (L_Vec (1)); 1996 R_Vec (1) := abs (R_Vec (1)); 1997 1998 Algorithm_M : declare 1999 Product : UI_Vector (1 .. L_Length + R_Length); 2000 Tmp_Sum : Int; 2001 Carry : Int; 2002 2003 begin 2004 for J in Product'Range loop 2005 Product (J) := 0; 2006 end loop; 2007 2008 for J in reverse R_Vec'Range loop 2009 Carry := 0; 2010 for K in reverse L_Vec'Range loop 2011 Tmp_Sum := 2012 L_Vec (K) * R_Vec (J) + Product (J + K) + Carry; 2013 Product (J + K) := Tmp_Sum rem Base; 2014 Carry := Tmp_Sum / Base; 2015 end loop; 2016 2017 Product (J) := Carry; 2018 end loop; 2019 2020 return Vector_To_Uint (Product, Neg); 2021 end Algorithm_M; 2022 end; 2023 end UI_Mul; 2024 2025 ------------ 2026 -- UI_Ne -- 2027 ------------ 2028 2029 function UI_Ne (Left : Int; Right : Uint) return Boolean is 2030 begin 2031 return UI_Ne (UI_From_Int (Left), Right); 2032 end UI_Ne; 2033 2034 function UI_Ne (Left : Uint; Right : Int) return Boolean is 2035 begin 2036 return UI_Ne (Left, UI_From_Int (Right)); 2037 end UI_Ne; 2038 2039 function UI_Ne (Left : Uint; Right : Uint) return Boolean is 2040 begin 2041 -- Quick processing for identical arguments. Note that this takes 2042 -- care of the case of two No_Uint arguments. 2043 2044 if Int (Left) = Int (Right) then 2045 return False; 2046 end if; 2047 2048 -- See if left operand directly represented 2049 2050 if Direct (Left) then 2051 2052 -- If right operand directly represented then compare 2053 2054 if Direct (Right) then 2055 return Int (Left) /= Int (Right); 2056 2057 -- Left operand directly represented, right not, must be unequal 2058 2059 else 2060 return True; 2061 end if; 2062 2063 -- Right operand directly represented, left not, must be unequal 2064 2065 elsif Direct (Right) then 2066 return True; 2067 end if; 2068 2069 -- Otherwise both multi-word, do comparison 2070 2071 declare 2072 Size : constant Int := N_Digits (Left); 2073 Left_Loc : Int; 2074 Right_Loc : Int; 2075 2076 begin 2077 if Size /= N_Digits (Right) then 2078 return True; 2079 end if; 2080 2081 Left_Loc := Uints.Table (Left).Loc; 2082 Right_Loc := Uints.Table (Right).Loc; 2083 2084 for J in Int_0 .. Size - Int_1 loop 2085 if Udigits.Table (Left_Loc + J) /= 2086 Udigits.Table (Right_Loc + J) 2087 then 2088 return True; 2089 end if; 2090 end loop; 2091 2092 return False; 2093 end; 2094 end UI_Ne; 2095 2096 ---------------- 2097 -- UI_Negate -- 2098 ---------------- 2099 2100 function UI_Negate (Right : Uint) return Uint is 2101 begin 2102 -- Case where input is directly represented. Note that since the range 2103 -- of Direct values is non-symmetrical, the result may not be directly 2104 -- represented, this is taken care of in UI_From_Int. 2105 2106 if Direct (Right) then 2107 return UI_From_Int (-Direct_Val (Right)); 2108 2109 -- Full processing for multi-digit case. Note that we cannot just copy 2110 -- the value to the end of the table negating the first digit, since the 2111 -- range of Direct values is non-symmetrical, so we can have a negative 2112 -- value that is not Direct whose negation can be represented directly. 2113 2114 else 2115 declare 2116 R_Length : constant Int := N_Digits (Right); 2117 R_Vec : UI_Vector (1 .. R_Length); 2118 Neg : Boolean; 2119 2120 begin 2121 Init_Operand (Right, R_Vec); 2122 Neg := R_Vec (1) > Int_0; 2123 R_Vec (1) := abs R_Vec (1); 2124 return Vector_To_Uint (R_Vec, Neg); 2125 end; 2126 end if; 2127 end UI_Negate; 2128 2129 ------------- 2130 -- UI_Rem -- 2131 ------------- 2132 2133 function UI_Rem (Left : Int; Right : Uint) return Uint is 2134 begin 2135 return UI_Rem (UI_From_Int (Left), Right); 2136 end UI_Rem; 2137 2138 function UI_Rem (Left : Uint; Right : Int) return Uint is 2139 begin 2140 return UI_Rem (Left, UI_From_Int (Right)); 2141 end UI_Rem; 2142 2143 function UI_Rem (Left, Right : Uint) return Uint is 2144 Remainder : Uint; 2145 Quotient : Uint; 2146 pragma Warnings (Off, Quotient); 2147 2148 begin 2149 pragma Assert (Right /= Uint_0); 2150 2151 if Direct (Right) and then Direct (Left) then 2152 return UI_From_Int (Direct_Val (Left) rem Direct_Val (Right)); 2153 2154 else 2155 UI_Div_Rem 2156 (Left, Right, Quotient, Remainder, Discard_Quotient => True); 2157 return Remainder; 2158 end if; 2159 end UI_Rem; 2160 2161 ------------ 2162 -- UI_Sub -- 2163 ------------ 2164 2165 function UI_Sub (Left : Int; Right : Uint) return Uint is 2166 begin 2167 return UI_Add (Left, -Right); 2168 end UI_Sub; 2169 2170 function UI_Sub (Left : Uint; Right : Int) return Uint is 2171 begin 2172 return UI_Add (Left, -Right); 2173 end UI_Sub; 2174 2175 function UI_Sub (Left : Uint; Right : Uint) return Uint is 2176 begin 2177 if Direct (Left) and then Direct (Right) then 2178 return UI_From_Int (Direct_Val (Left) - Direct_Val (Right)); 2179 else 2180 return UI_Add (Left, -Right); 2181 end if; 2182 end UI_Sub; 2183 2184 -------------- 2185 -- UI_To_CC -- 2186 -------------- 2187 2188 function UI_To_CC (Input : Uint) return Char_Code is 2189 begin 2190 if Direct (Input) then 2191 return Char_Code (Direct_Val (Input)); 2192 2193 -- Case of input is more than one digit 2194 2195 else 2196 declare 2197 In_Length : constant Int := N_Digits (Input); 2198 In_Vec : UI_Vector (1 .. In_Length); 2199 Ret_CC : Char_Code; 2200 2201 begin 2202 Init_Operand (Input, In_Vec); 2203 2204 -- We assume value is positive 2205 2206 Ret_CC := 0; 2207 for Idx in In_Vec'Range loop 2208 Ret_CC := Ret_CC * Char_Code (Base) + 2209 Char_Code (abs In_Vec (Idx)); 2210 end loop; 2211 2212 return Ret_CC; 2213 end; 2214 end if; 2215 end UI_To_CC; 2216 2217 ---------------- 2218 -- UI_To_Int -- 2219 ---------------- 2220 2221 function UI_To_Int (Input : Uint) return Int is 2222 pragma Assert (Input /= No_Uint); 2223 2224 begin 2225 if Direct (Input) then 2226 return Direct_Val (Input); 2227 2228 -- Case of input is more than one digit 2229 2230 else 2231 declare 2232 In_Length : constant Int := N_Digits (Input); 2233 In_Vec : UI_Vector (1 .. In_Length); 2234 Ret_Int : Int; 2235 2236 begin 2237 -- Uints of more than one digit could be outside the range for 2238 -- Ints. Caller should have checked for this if not certain. 2239 -- Fatal error to attempt to convert from value outside Int'Range. 2240 2241 pragma Assert (UI_Is_In_Int_Range (Input)); 2242 2243 -- Otherwise, proceed ahead, we are OK 2244 2245 Init_Operand (Input, In_Vec); 2246 Ret_Int := 0; 2247 2248 -- Calculate -|Input| and then negates if value is positive. This 2249 -- handles our current definition of Int (based on 2s complement). 2250 -- Is it secure enough??? 2251 2252 for Idx in In_Vec'Range loop 2253 Ret_Int := Ret_Int * Base - abs In_Vec (Idx); 2254 end loop; 2255 2256 if In_Vec (1) < Int_0 then 2257 return Ret_Int; 2258 else 2259 return -Ret_Int; 2260 end if; 2261 end; 2262 end if; 2263 end UI_To_Int; 2264 2265 -------------- 2266 -- UI_Write -- 2267 -------------- 2268 2269 procedure UI_Write (Input : Uint; Format : UI_Format := Auto) is 2270 begin 2271 Image_Out (Input, False, Format); 2272 end UI_Write; 2273 2274 --------------------- 2275 -- Vector_To_Uint -- 2276 --------------------- 2277 2278 function Vector_To_Uint 2279 (In_Vec : UI_Vector; 2280 Negative : Boolean) 2281 return Uint 2282 is 2283 Size : Int; 2284 Val : Int; 2285 2286 begin 2287 -- The vector can contain leading zeros. These are not stored in the 2288 -- table, so loop through the vector looking for first non-zero digit 2289 2290 for J in In_Vec'Range loop 2291 if In_Vec (J) /= Int_0 then 2292 2293 -- The length of the value is the length of the rest of the vector 2294 2295 Size := In_Vec'Last - J + 1; 2296 2297 -- One digit value can always be represented directly 2298 2299 if Size = Int_1 then 2300 if Negative then 2301 return Uint (Int (Uint_Direct_Bias) - In_Vec (J)); 2302 else 2303 return Uint (Int (Uint_Direct_Bias) + In_Vec (J)); 2304 end if; 2305 2306 -- Positive two digit values may be in direct representation range 2307 2308 elsif Size = Int_2 and then not Negative then 2309 Val := In_Vec (J) * Base + In_Vec (J + 1); 2310 2311 if Val <= Max_Direct then 2312 return Uint (Int (Uint_Direct_Bias) + Val); 2313 end if; 2314 end if; 2315 2316 -- The value is outside the direct representation range and must 2317 -- therefore be stored in the table. Expand the table to contain 2318 -- the count and digits. The index of the new table entry will be 2319 -- returned as the result. 2320 2321 Uints.Append ((Length => Size, Loc => Udigits.Last + 1)); 2322 2323 if Negative then 2324 Val := -In_Vec (J); 2325 else 2326 Val := +In_Vec (J); 2327 end if; 2328 2329 Udigits.Append (Val); 2330 2331 for K in 2 .. Size loop 2332 Udigits.Append (In_Vec (J + K - 1)); 2333 end loop; 2334 2335 return Uints.Last; 2336 end if; 2337 end loop; 2338 2339 -- Dropped through loop only if vector contained all zeros 2340 2341 return Uint_0; 2342 end Vector_To_Uint; 2343 2344end Uintp; 2345