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