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