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