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