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