?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* config/darwin.c (darwin_assemble_visibility): Treat
[official-gcc.git] / gcc / ada / uintp.adb
bloba98bd9f376bd412f8845c8947a1538b01a4a1c37
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- U I N T P --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2012, 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
1169 begin
1170 -- [ NORMALIZE ] (step D1 in the algorithm). First calculate the
1171 -- scale d, and then multiply Left and Right (u and v in the book)
1172 -- by d to get the dividend and divisor to work with.
1173
1174 D := Base / (abs R_Vec (1) + 1);
1175
1176 Dividend (1) := 0;
1177 Dividend (2) := abs L_Vec (1);
1178
1179 for J in 3 .. L_Length + Int_1 loop
1180 Dividend (J) := L_Vec (J - 1);
1181 end loop;
1182
1183 Divisor (1) := abs R_Vec (1);
1184
1185 for J in Int_2 .. R_Length loop
1186 Divisor (J) := R_Vec (J);
1187 end loop;
1188
1189 if D > Int_1 then
1190
1191 -- Multiply Dividend by d
1192
1193 Carry := 0;
1194 for J in reverse Dividend'Range loop
1195 Tmp_Int := Dividend (J) * D + Carry;
1196 Dividend (J) := Tmp_Int rem Base;
1197 Carry := Tmp_Int / Base;
1198 end loop;
1199
1200 -- Multiply Divisor by d
1201
1202 Carry := 0;
1203 for J in reverse Divisor'Range loop
1204 Tmp_Int := Divisor (J) * D + Carry;
1205 Divisor (J) := Tmp_Int rem Base;
1206 Carry := Tmp_Int / Base;
1207 end loop;
1208 end if;
1209
1210 -- Main loop of long division algorithm
1211
1212 Divisor_Dig1 := Divisor (1);
1213 Divisor_Dig2 := Divisor (2);
1214
1215 for J in Quotient_V'Range loop
1216
1217 -- [ CALCULATE Q (hat) ] (step D3 in the algorithm)
1218
1219 Tmp_Int := Dividend (J) * Base + Dividend (J + 1);
1220
1221 -- Initial guess
1222
1223 if Dividend (J) = Divisor_Dig1 then
1224 Q_Guess := Base - 1;
1225 else
1226 Q_Guess := Tmp_Int / Divisor_Dig1;
1227 end if;
1228
1229 -- Refine the guess
1230
1231 while Divisor_Dig2 * Q_Guess >
1232 (Tmp_Int - Q_Guess * Divisor_Dig1) * Base +
1233 Dividend (J + 2)
1234 loop
1235 Q_Guess := Q_Guess - 1;
1236 end loop;
1237
1238 -- [ MULTIPLY & SUBTRACT ] (step D4). Q_Guess * Divisor is
1239 -- subtracted from the remaining dividend.
1240
1241 Carry := 0;
1242 for K in reverse Divisor'Range loop
1243 Tmp_Int := Dividend (J + K) - Q_Guess * Divisor (K) + Carry;
1244 Tmp_Dig := Tmp_Int rem Base;
1245 Carry := Tmp_Int / Base;
1246
1247 if Tmp_Dig < Int_0 then
1248 Tmp_Dig := Tmp_Dig + Base;
1249 Carry := Carry - 1;
1250 end if;
1251
1252 Dividend (J + K) := Tmp_Dig;
1253 end loop;
1254
1255 Dividend (J) := Dividend (J) + Carry;
1256
1257 -- [ TEST REMAINDER ] & [ ADD BACK ] (steps D5 and D6)
1258
1259 -- Here there is a slight difference from the book: the last
1260 -- carry is always added in above and below (cancelling each
1261 -- other). In fact the dividend going negative is used as
1262 -- the test.
1263
1264 -- If the Dividend went negative, then Q_Guess was off by
1265 -- one, so it is decremented, and the divisor is added back
1266 -- into the relevant portion of the dividend.
1267
1268 if Dividend (J) < Int_0 then
1269 Q_Guess := Q_Guess - 1;
1270
1271 Carry := 0;
1272 for K in reverse Divisor'Range loop
1273 Tmp_Int := Dividend (J + K) + Divisor (K) + Carry;
1274
1275 if Tmp_Int >= Base then
1276 Tmp_Int := Tmp_Int - Base;
1277 Carry := 1;
1278 else
1279 Carry := 0;
1280 end if;
1281
1282 Dividend (J + K) := Tmp_Int;
1283 end loop;
1284
1285 Dividend (J) := Dividend (J) + Carry;
1286 end if;
1287
1288 -- Finally we can get the next quotient digit
1289
1290 Quotient_V (J) := Q_Guess;
1291 end loop;
1292
1293 -- [ UNNORMALIZE ] (step D8)
1294
1295 if not Discard_Quotient then
1296 Quotient := Vector_To_Uint
1297 (Quotient_V, (L_Vec (1) < Int_0 xor R_Vec (1) < Int_0));
1298 end if;
1299
1300 if not Discard_Remainder then
1301 declare
1302 Remainder_V : UI_Vector (1 .. R_Length);
1303 Discard_Int : Int;
1304 pragma Warnings (Off, Discard_Int);
1305 begin
1306 UI_Div_Vector
1307 (Dividend (Dividend'Last - R_Length + 1 .. Dividend'Last),
1308 D,
1309 Remainder_V, Discard_Int);
1310 Remainder := Vector_To_Uint (Remainder_V, L_Vec (1) < Int_0);
1311 end;
1312 end if;
1313 end Algorithm_D;
1314 end;
1315 end UI_Div_Rem;
1316
1317 ------------
1318 -- UI_Eq --
1319 ------------
1320
1321 function UI_Eq (Left : Int; Right : Uint) return Boolean is
1322 begin
1323 return not UI_Ne (UI_From_Int (Left), Right);
1324 end UI_Eq;
1325
1326 function UI_Eq (Left : Uint; Right : Int) return Boolean is
1327 begin
1328 return not UI_Ne (Left, UI_From_Int (Right));
1329 end UI_Eq;
1330
1331 function UI_Eq (Left : Uint; Right : Uint) return Boolean is
1332 begin
1333 return not UI_Ne (Left, Right);
1334 end UI_Eq;
1335
1336 --------------
1337 -- UI_Expon --
1338 --------------
1339
1340 function UI_Expon (Left : Int; Right : Uint) return Uint is
1341 begin
1342 return UI_Expon (UI_From_Int (Left), Right);
1343 end UI_Expon;
1344
1345 function UI_Expon (Left : Uint; Right : Int) return Uint is
1346 begin
1347 return UI_Expon (Left, UI_From_Int (Right));
1348 end UI_Expon;
1349
1350 function UI_Expon (Left : Int; Right : Int) return Uint is
1351 begin
1352 return UI_Expon (UI_From_Int (Left), UI_From_Int (Right));
1353 end UI_Expon;
1354
1355 function UI_Expon (Left : Uint; Right : Uint) return Uint is
1356 begin
1357 pragma Assert (Right >= Uint_0);
1358
1359 -- Any value raised to power of 0 is 1
1360
1361 if Right = Uint_0 then
1362 return Uint_1;
1363
1364 -- 0 to any positive power is 0
1365
1366 elsif Left = Uint_0 then
1367 return Uint_0;
1368
1369 -- 1 to any power is 1
1370
1371 elsif Left = Uint_1 then
1372 return Uint_1;
1373
1374 -- Any value raised to power of 1 is that value
1375
1376 elsif Right = Uint_1 then
1377 return Left;
1378
1379 -- Cases which can be done by table lookup
1380
1381 elsif Right <= Uint_64 then
1382
1383 -- 2 ** N for N in 2 .. 64
1384
1385 if Left = Uint_2 then
1386 declare
1387 Right_Int : constant Int := Direct_Val (Right);
1388
1389 begin
1390 if Right_Int > UI_Power_2_Set then
1391 for J in UI_Power_2_Set + Int_1 .. Right_Int loop
1392 UI_Power_2 (J) := UI_Power_2 (J - Int_1) * Int_2;
1393 Uints_Min := Uints.Last;
1394 Udigits_Min := Udigits.Last;
1395 end loop;
1396
1397 UI_Power_2_Set := Right_Int;
1398 end if;
1399
1400 return UI_Power_2 (Right_Int);
1401 end;
1402
1403 -- 10 ** N for N in 2 .. 64
1404
1405 elsif Left = Uint_10 then
1406 declare
1407 Right_Int : constant Int := Direct_Val (Right);
1408
1409 begin
1410 if Right_Int > UI_Power_10_Set then
1411 for J in UI_Power_10_Set + Int_1 .. Right_Int loop
1412 UI_Power_10 (J) := UI_Power_10 (J - Int_1) * Int (10);
1413 Uints_Min := Uints.Last;
1414 Udigits_Min := Udigits.Last;
1415 end loop;
1416
1417 UI_Power_10_Set := Right_Int;
1418 end if;
1419
1420 return UI_Power_10 (Right_Int);
1421 end;
1422 end if;
1423 end if;
1424
1425 -- If we fall through, then we have the general case (see Knuth 4.6.3)
1426
1427 declare
1428 N : Uint := Right;
1429 Squares : Uint := Left;
1430 Result : Uint := Uint_1;
1431 M : constant Uintp.Save_Mark := Uintp.Mark;
1432
1433 begin
1434 loop
1435 if (Least_Sig_Digit (N) mod Int_2) = Int_1 then
1436 Result := Result * Squares;
1437 end if;
1438
1439 N := N / Uint_2;
1440 exit when N = Uint_0;
1441 Squares := Squares * Squares;
1442 end loop;
1443
1444 Uintp.Release_And_Save (M, Result);
1445 return Result;
1446 end;
1447 end UI_Expon;
1448
1449 ----------------
1450 -- UI_From_CC --
1451 ----------------
1452
1453 function UI_From_CC (Input : Char_Code) return Uint is
1454 begin
1455 return UI_From_Int (Int (Input));
1456 end UI_From_CC;
1457
1458 -----------------
1459 -- UI_From_Int --
1460 -----------------
1461
1462 function UI_From_Int (Input : Int) return Uint is
1463 U : Uint;
1464
1465 begin
1466 if Min_Direct <= Input and then Input <= Max_Direct then
1467 return Uint (Int (Uint_Direct_Bias) + Input);
1468 end if;
1469
1470 -- If already in the hash table, return entry
1471
1472 U := UI_Ints.Get (Input);
1473
1474 if U /= No_Uint then
1475 return U;
1476 end if;
1477
1478 -- For values of larger magnitude, compute digits into a vector and call
1479 -- Vector_To_Uint.
1480
1481 declare
1482 Max_For_Int : constant := 3;
1483 -- Base is defined so that 3 Uint digits is sufficient to hold the
1484 -- largest possible Int value.
1485
1486 V : UI_Vector (1 .. Max_For_Int);
1487
1488 Temp_Integer : Int := Input;
1489
1490 begin
1491 for J in reverse V'Range loop
1492 V (J) := abs (Temp_Integer rem Base);
1493 Temp_Integer := Temp_Integer / Base;
1494 end loop;
1495
1496 U := Vector_To_Uint (V, Input < Int_0);
1497 UI_Ints.Set (Input, U);
1498 Uints_Min := Uints.Last;
1499 Udigits_Min := Udigits.Last;
1500 return U;
1501 end;
1502 end UI_From_Int;
1503
1504 ------------
1505 -- UI_GCD --
1506 ------------
1507
1508 -- Lehmer's algorithm for GCD
1509
1510 -- The idea is to avoid using multiple precision arithmetic wherever
1511 -- possible, substituting Int arithmetic instead. See Knuth volume II,
1512 -- Algorithm L (page 329).
1513
1514 -- We use the same notation as Knuth (U_Hat standing for the obvious!)
1515
1516 function UI_GCD (Uin, Vin : Uint) return Uint is
1517 U, V : Uint;
1518 -- Copies of Uin and Vin
1519
1520 U_Hat, V_Hat : Int;
1521 -- The most Significant digits of U,V
1522
1523 A, B, C, D, T, Q, Den1, Den2 : Int;
1524
1525 Tmp_UI : Uint;
1526 Marks : constant Uintp.Save_Mark := Uintp.Mark;
1527 Iterations : Integer := 0;
1528
1529 begin
1530 pragma Assert (Uin >= Vin);
1531 pragma Assert (Vin >= Uint_0);
1532
1533 U := Uin;
1534 V := Vin;
1535
1536 loop
1537 Iterations := Iterations + 1;
1538
1539 if Direct (V) then
1540 if V = Uint_0 then
1541 return U;
1542 else
1543 return
1544 UI_From_Int (GCD (Direct_Val (V), UI_To_Int (U rem V)));
1545 end if;
1546 end if;
1547
1548 Most_Sig_2_Digits (U, V, U_Hat, V_Hat);
1549 A := 1;
1550 B := 0;
1551 C := 0;
1552 D := 1;
1553
1554 loop
1555 -- We might overflow and get division by zero here. This just
1556 -- means we cannot take the single precision step
1557
1558 Den1 := V_Hat + C;
1559 Den2 := V_Hat + D;
1560 exit when Den1 = Int_0 or else Den2 = Int_0;
1561
1562 -- Compute Q, the trial quotient
1563
1564 Q := (U_Hat + A) / Den1;
1565
1566 exit when Q /= ((U_Hat + B) / Den2);
1567
1568 -- A single precision step Euclid step will give same answer as a
1569 -- multiprecision one.
1570
1571 T := A - (Q * C);
1572 A := C;
1573 C := T;
1574
1575 T := B - (Q * D);
1576 B := D;
1577 D := T;
1578
1579 T := U_Hat - (Q * V_Hat);
1580 U_Hat := V_Hat;
1581 V_Hat := T;
1582
1583 end loop;
1584
1585 -- Take a multiprecision Euclid step
1586
1587 if B = Int_0 then
1588
1589 -- No single precision steps take a regular Euclid step
1590
1591 Tmp_UI := U rem V;
1592 U := V;
1593 V := Tmp_UI;
1594
1595 else
1596 -- Use prior single precision steps to compute this Euclid step
1597
1598 -- For constructs such as:
1599 -- sqrt_2: constant := 1.41421_35623_73095_04880_16887_24209_698;
1600 -- sqrt_eps: constant long_float := long_float( 1.0 / sqrt_2)
1601 -- ** long_float'machine_mantissa;
1602 --
1603 -- we spend 80% of our time working on this step. Perhaps we need
1604 -- a special case Int / Uint dot product to speed things up. ???
1605
1606 -- Alternatively we could increase the single precision iterations
1607 -- to handle Uint's of some small size ( <5 digits?). Then we
1608 -- would have more iterations on small Uint. On the code above, we
1609 -- only get 5 (on average) single precision iterations per large
1610 -- iteration. ???
1611
1612 Tmp_UI := (UI_From_Int (A) * U) + (UI_From_Int (B) * V);
1613 V := (UI_From_Int (C) * U) + (UI_From_Int (D) * V);
1614 U := Tmp_UI;
1615 end if;
1616
1617 -- If the operands are very different in magnitude, the loop will
1618 -- generate large amounts of short-lived data, which it is worth
1619 -- removing periodically.
1620
1621 if Iterations > 100 then
1622 Release_And_Save (Marks, U, V);
1623 Iterations := 0;
1624 end if;
1625 end loop;
1626 end UI_GCD;
1627
1628 ------------
1629 -- UI_Ge --
1630 ------------
1631
1632 function UI_Ge (Left : Int; Right : Uint) return Boolean is
1633 begin
1634 return not UI_Lt (UI_From_Int (Left), Right);
1635 end UI_Ge;
1636
1637 function UI_Ge (Left : Uint; Right : Int) return Boolean is
1638 begin
1639 return not UI_Lt (Left, UI_From_Int (Right));
1640 end UI_Ge;
1641
1642 function UI_Ge (Left : Uint; Right : Uint) return Boolean is
1643 begin
1644 return not UI_Lt (Left, Right);
1645 end UI_Ge;
1646
1647 ------------
1648 -- UI_Gt --
1649 ------------
1650
1651 function UI_Gt (Left : Int; Right : Uint) return Boolean is
1652 begin
1653 return UI_Lt (Right, UI_From_Int (Left));
1654 end UI_Gt;
1655
1656 function UI_Gt (Left : Uint; Right : Int) return Boolean is
1657 begin
1658 return UI_Lt (UI_From_Int (Right), Left);
1659 end UI_Gt;
1660
1661 function UI_Gt (Left : Uint; Right : Uint) return Boolean is
1662 begin
1663 return UI_Lt (Left => Right, Right => Left);
1664 end UI_Gt;
1665
1666 ---------------
1667 -- UI_Image --
1668 ---------------
1669
1670 procedure UI_Image (Input : Uint; Format : UI_Format := Auto) is
1671 begin
1672 Image_Out (Input, True, Format);
1673 end UI_Image;
1674
1675 -------------------------
1676 -- UI_Is_In_Int_Range --
1677 -------------------------
1678
1679 function UI_Is_In_Int_Range (Input : Uint) return Boolean is
1680 begin
1681 -- Make sure we don't get called before Initialize
1682
1683 pragma Assert (Uint_Int_First /= Uint_0);
1684
1685 if Direct (Input) then
1686 return True;
1687 else
1688 return Input >= Uint_Int_First
1689 and then Input <= Uint_Int_Last;
1690 end if;
1691 end UI_Is_In_Int_Range;
1692
1693 ------------
1694 -- UI_Le --
1695 ------------
1696
1697 function UI_Le (Left : Int; Right : Uint) return Boolean is
1698 begin
1699 return not UI_Lt (Right, UI_From_Int (Left));
1700 end UI_Le;
1701
1702 function UI_Le (Left : Uint; Right : Int) return Boolean is
1703 begin
1704 return not UI_Lt (UI_From_Int (Right), Left);
1705 end UI_Le;
1706
1707 function UI_Le (Left : Uint; Right : Uint) return Boolean is
1708 begin
1709 return not UI_Lt (Left => Right, Right => Left);
1710 end UI_Le;
1711
1712 ------------
1713 -- UI_Lt --
1714 ------------
1715
1716 function UI_Lt (Left : Int; Right : Uint) return Boolean is
1717 begin
1718 return UI_Lt (UI_From_Int (Left), Right);
1719 end UI_Lt;
1720
1721 function UI_Lt (Left : Uint; Right : Int) return Boolean is
1722 begin
1723 return UI_Lt (Left, UI_From_Int (Right));
1724 end UI_Lt;
1725
1726 function UI_Lt (Left : Uint; Right : Uint) return Boolean is
1727 begin
1728 -- Quick processing for identical arguments
1729
1730 if Int (Left) = Int (Right) then
1731 return False;
1732
1733 -- Quick processing for both arguments directly represented
1734
1735 elsif Direct (Left) and then Direct (Right) then
1736 return Int (Left) < Int (Right);
1737
1738 -- At least one argument is more than one digit long
1739
1740 else
1741 declare
1742 L_Length : constant Int := N_Digits (Left);
1743 R_Length : constant Int := N_Digits (Right);
1744
1745 L_Vec : UI_Vector (1 .. L_Length);
1746 R_Vec : UI_Vector (1 .. R_Length);
1747
1748 begin
1749 Init_Operand (Left, L_Vec);
1750 Init_Operand (Right, R_Vec);
1751
1752 if L_Vec (1) < Int_0 then
1753
1754 -- First argument negative, second argument non-negative
1755
1756 if R_Vec (1) >= Int_0 then
1757 return True;
1758
1759 -- Both arguments negative
1760
1761 else
1762 if L_Length /= R_Length then
1763 return L_Length > R_Length;
1764
1765 elsif L_Vec (1) /= R_Vec (1) then
1766 return L_Vec (1) < R_Vec (1);
1767
1768 else
1769 for J in 2 .. L_Vec'Last loop
1770 if L_Vec (J) /= R_Vec (J) then
1771 return L_Vec (J) > R_Vec (J);
1772 end if;
1773 end loop;
1774
1775 return False;
1776 end if;
1777 end if;
1778
1779 else
1780 -- First argument non-negative, second argument negative
1781
1782 if R_Vec (1) < Int_0 then
1783 return False;
1784
1785 -- Both arguments non-negative
1786
1787 else
1788 if L_Length /= R_Length then
1789 return L_Length < R_Length;
1790 else
1791 for J in L_Vec'Range loop
1792 if L_Vec (J) /= R_Vec (J) then
1793 return L_Vec (J) < R_Vec (J);
1794 end if;
1795 end loop;
1796
1797 return False;
1798 end if;
1799 end if;
1800 end if;
1801 end;
1802 end if;
1803 end UI_Lt;
1804
1805 ------------
1806 -- UI_Max --
1807 ------------
1808
1809 function UI_Max (Left : Int; Right : Uint) return Uint is
1810 begin
1811 return UI_Max (UI_From_Int (Left), Right);
1812 end UI_Max;
1813
1814 function UI_Max (Left : Uint; Right : Int) return Uint is
1815 begin
1816 return UI_Max (Left, UI_From_Int (Right));
1817 end UI_Max;
1818
1819 function UI_Max (Left : Uint; Right : Uint) return Uint is
1820 begin
1821 if Left >= Right then
1822 return Left;
1823 else
1824 return Right;
1825 end if;
1826 end UI_Max;
1827
1828 ------------
1829 -- UI_Min --
1830 ------------
1831
1832 function UI_Min (Left : Int; Right : Uint) return Uint is
1833 begin
1834 return UI_Min (UI_From_Int (Left), Right);
1835 end UI_Min;
1836
1837 function UI_Min (Left : Uint; Right : Int) return Uint is
1838 begin
1839 return UI_Min (Left, UI_From_Int (Right));
1840 end UI_Min;
1841
1842 function UI_Min (Left : Uint; Right : Uint) return Uint is
1843 begin
1844 if Left <= Right then
1845 return Left;
1846 else
1847 return Right;
1848 end if;
1849 end UI_Min;
1850
1851 -------------
1852 -- UI_Mod --
1853 -------------
1854
1855 function UI_Mod (Left : Int; Right : Uint) return Uint is
1856 begin
1857 return UI_Mod (UI_From_Int (Left), Right);
1858 end UI_Mod;
1859
1860 function UI_Mod (Left : Uint; Right : Int) return Uint is
1861 begin
1862 return UI_Mod (Left, UI_From_Int (Right));
1863 end UI_Mod;
1864
1865 function UI_Mod (Left : Uint; Right : Uint) return Uint is
1866 Urem : constant Uint := Left rem Right;
1867
1868 begin
1869 if (Left < Uint_0) = (Right < Uint_0)
1870 or else Urem = Uint_0
1871 then
1872 return Urem;
1873 else
1874 return Right + Urem;
1875 end if;
1876 end UI_Mod;
1877
1878 -------------------------------
1879 -- UI_Modular_Exponentiation --
1880 -------------------------------
1881
1882 function UI_Modular_Exponentiation
1883 (B : Uint;
1884 E : Uint;
1885 Modulo : Uint) return Uint
1886 is
1887 M : constant Save_Mark := Mark;
1888
1889 Result : Uint := Uint_1;
1890 Base : Uint := B;
1891 Exponent : Uint := E;
1892
1893 begin
1894 while Exponent /= Uint_0 loop
1895 if Least_Sig_Digit (Exponent) rem Int'(2) = Int'(1) then
1896 Result := (Result * Base) rem Modulo;
1897 end if;
1898
1899 Exponent := Exponent / Uint_2;
1900 Base := (Base * Base) rem Modulo;
1901 end loop;
1902
1903 Release_And_Save (M, Result);
1904 return Result;
1905 end UI_Modular_Exponentiation;
1906
1907 ------------------------
1908 -- UI_Modular_Inverse --
1909 ------------------------
1910
1911 function UI_Modular_Inverse (N : Uint; Modulo : Uint) return Uint is
1912 M : constant Save_Mark := Mark;
1913 U : Uint;
1914 V : Uint;
1915 Q : Uint;
1916 R : Uint;
1917 X : Uint;
1918 Y : Uint;
1919 T : Uint;
1920 S : Int := 1;
1921
1922 begin
1923 U := Modulo;
1924 V := N;
1925
1926 X := Uint_1;
1927 Y := Uint_0;
1928
1929 loop
1930 UI_Div_Rem (U, V, Quotient => Q, Remainder => R);
1931
1932 U := V;
1933 V := R;
1934
1935 T := X;
1936 X := Y + Q * X;
1937 Y := T;
1938 S := -S;
1939
1940 exit when R = Uint_1;
1941 end loop;
1942
1943 if S = Int'(-1) then
1944 X := Modulo - X;
1945 end if;
1946
1947 Release_And_Save (M, X);
1948 return X;
1949 end UI_Modular_Inverse;
1950
1951 ------------
1952 -- UI_Mul --
1953 ------------
1954
1955 function UI_Mul (Left : Int; Right : Uint) return Uint is
1956 begin
1957 return UI_Mul (UI_From_Int (Left), Right);
1958 end UI_Mul;
1959
1960 function UI_Mul (Left : Uint; Right : Int) return Uint is
1961 begin
1962 return UI_Mul (Left, UI_From_Int (Right));
1963 end UI_Mul;
1964
1965 function UI_Mul (Left : Uint; Right : Uint) return Uint is
1966 begin
1967 -- Case where product fits in the range of a 32-bit integer
1968
1969 if Int (Left) <= Int (Uint_Max_Simple_Mul)
1970 and then
1971 Int (Right) <= Int (Uint_Max_Simple_Mul)
1972 then
1973 return UI_From_Int (Direct_Val (Left) * Direct_Val (Right));
1974 end if;
1975
1976 -- Otherwise we have the general case (Algorithm M in Knuth)
1977
1978 declare
1979 L_Length : constant Int := N_Digits (Left);
1980 R_Length : constant Int := N_Digits (Right);
1981 L_Vec : UI_Vector (1 .. L_Length);
1982 R_Vec : UI_Vector (1 .. R_Length);
1983 Neg : Boolean;
1984
1985 begin
1986 Init_Operand (Left, L_Vec);
1987 Init_Operand (Right, R_Vec);
1988 Neg := (L_Vec (1) < Int_0) xor (R_Vec (1) < Int_0);
1989 L_Vec (1) := abs (L_Vec (1));
1990 R_Vec (1) := abs (R_Vec (1));
1991
1992 Algorithm_M : declare
1993 Product : UI_Vector (1 .. L_Length + R_Length);
1994 Tmp_Sum : Int;
1995 Carry : Int;
1996
1997 begin
1998 for J in Product'Range loop
1999 Product (J) := 0;
2000 end loop;
2001
2002 for J in reverse R_Vec'Range loop
2003 Carry := 0;
2004 for K in reverse L_Vec'Range loop
2005 Tmp_Sum :=
2006 L_Vec (K) * R_Vec (J) + Product (J + K) + Carry;
2007 Product (J + K) := Tmp_Sum rem Base;
2008 Carry := Tmp_Sum / Base;
2009 end loop;
2010
2011 Product (J) := Carry;
2012 end loop;
2013
2014 return Vector_To_Uint (Product, Neg);
2015 end Algorithm_M;
2016 end;
2017 end UI_Mul;
2018
2019 ------------
2020 -- UI_Ne --
2021 ------------
2022
2023 function UI_Ne (Left : Int; Right : Uint) return Boolean is
2024 begin
2025 return UI_Ne (UI_From_Int (Left), Right);
2026 end UI_Ne;
2027
2028 function UI_Ne (Left : Uint; Right : Int) return Boolean is
2029 begin
2030 return UI_Ne (Left, UI_From_Int (Right));
2031 end UI_Ne;
2032
2033 function UI_Ne (Left : Uint; Right : Uint) return Boolean is
2034 begin
2035 -- Quick processing for identical arguments. Note that this takes
2036 -- care of the case of two No_Uint arguments.
2037
2038 if Int (Left) = Int (Right) then
2039 return False;
2040 end if;
2041
2042 -- See if left operand directly represented
2043
2044 if Direct (Left) then
2045
2046 -- If right operand directly represented then compare
2047
2048 if Direct (Right) then
2049 return Int (Left) /= Int (Right);
2050
2051 -- Left operand directly represented, right not, must be unequal
2052
2053 else
2054 return True;
2055 end if;
2056
2057 -- Right operand directly represented, left not, must be unequal
2058
2059 elsif Direct (Right) then
2060 return True;
2061 end if;
2062
2063 -- Otherwise both multi-word, do comparison
2064
2065 declare
2066 Size : constant Int := N_Digits (Left);
2067 Left_Loc : Int;
2068 Right_Loc : Int;
2069
2070 begin
2071 if Size /= N_Digits (Right) then
2072 return True;
2073 end if;
2074
2075 Left_Loc := Uints.Table (Left).Loc;
2076 Right_Loc := Uints.Table (Right).Loc;
2077
2078 for J in Int_0 .. Size - Int_1 loop
2079 if Udigits.Table (Left_Loc + J) /=
2080 Udigits.Table (Right_Loc + J)
2081 then
2082 return True;
2083 end if;
2084 end loop;
2085
2086 return False;
2087 end;
2088 end UI_Ne;
2089
2090 ----------------
2091 -- UI_Negate --
2092 ----------------
2093
2094 function UI_Negate (Right : Uint) return Uint is
2095 begin
2096 -- Case where input is directly represented. Note that since the range
2097 -- of Direct values is non-symmetrical, the result may not be directly
2098 -- represented, this is taken care of in UI_From_Int.
2099
2100 if Direct (Right) then
2101 return UI_From_Int (-Direct_Val (Right));
2102
2103 -- Full processing for multi-digit case. Note that we cannot just copy
2104 -- the value to the end of the table negating the first digit, since the
2105 -- range of Direct values is non-symmetrical, so we can have a negative
2106 -- value that is not Direct whose negation can be represented directly.
2107
2108 else
2109 declare
2110 R_Length : constant Int := N_Digits (Right);
2111 R_Vec : UI_Vector (1 .. R_Length);
2112 Neg : Boolean;
2113
2114 begin
2115 Init_Operand (Right, R_Vec);
2116 Neg := R_Vec (1) > Int_0;
2117 R_Vec (1) := abs R_Vec (1);
2118 return Vector_To_Uint (R_Vec, Neg);
2119 end;
2120 end if;
2121 end UI_Negate;
2122
2123 -------------
2124 -- UI_Rem --
2125 -------------
2126
2127 function UI_Rem (Left : Int; Right : Uint) return Uint is
2128 begin
2129 return UI_Rem (UI_From_Int (Left), Right);
2130 end UI_Rem;
2131
2132 function UI_Rem (Left : Uint; Right : Int) return Uint is
2133 begin
2134 return UI_Rem (Left, UI_From_Int (Right));
2135 end UI_Rem;
2136
2137 function UI_Rem (Left, Right : Uint) return Uint is
2138 Remainder : Uint;
2139 Quotient : Uint;
2140 pragma Warnings (Off, Quotient);
2141
2142 begin
2143 pragma Assert (Right /= Uint_0);
2144
2145 if Direct (Right) and then Direct (Left) then
2146 return UI_From_Int (Direct_Val (Left) rem Direct_Val (Right));
2147
2148 else
2149 UI_Div_Rem
2150 (Left, Right, Quotient, Remainder, Discard_Quotient => True);
2151 return Remainder;
2152 end if;
2153 end UI_Rem;
2154
2155 ------------
2156 -- UI_Sub --
2157 ------------
2158
2159 function UI_Sub (Left : Int; Right : Uint) return Uint is
2160 begin
2161 return UI_Add (Left, -Right);
2162 end UI_Sub;
2163
2164 function UI_Sub (Left : Uint; Right : Int) return Uint is
2165 begin
2166 return UI_Add (Left, -Right);
2167 end UI_Sub;
2168
2169 function UI_Sub (Left : Uint; Right : Uint) return Uint is
2170 begin
2171 if Direct (Left) and then Direct (Right) then
2172 return UI_From_Int (Direct_Val (Left) - Direct_Val (Right));
2173 else
2174 return UI_Add (Left, -Right);
2175 end if;
2176 end UI_Sub;
2177
2178 --------------
2179 -- UI_To_CC --
2180 --------------
2181
2182 function UI_To_CC (Input : Uint) return Char_Code is
2183 begin
2184 if Direct (Input) then
2185 return Char_Code (Direct_Val (Input));
2186
2187 -- Case of input is more than one digit
2188
2189 else
2190 declare
2191 In_Length : constant Int := N_Digits (Input);
2192 In_Vec : UI_Vector (1 .. In_Length);
2193 Ret_CC : Char_Code;
2194
2195 begin
2196 Init_Operand (Input, In_Vec);
2197
2198 -- We assume value is positive
2199
2200 Ret_CC := 0;
2201 for Idx in In_Vec'Range loop
2202 Ret_CC := Ret_CC * Char_Code (Base) +
2203 Char_Code (abs In_Vec (Idx));
2204 end loop;
2205
2206 return Ret_CC;
2207 end;
2208 end if;
2209 end UI_To_CC;
2210
2211 ----------------
2212 -- UI_To_Int --
2213 ----------------
2214
2215 function UI_To_Int (Input : Uint) return Int is
2216 pragma Assert (Input /= No_Uint);
2217
2218 begin
2219 if Direct (Input) then
2220 return Direct_Val (Input);
2221
2222 -- Case of input is more than one digit
2223
2224 else
2225 declare
2226 In_Length : constant Int := N_Digits (Input);
2227 In_Vec : UI_Vector (1 .. In_Length);
2228 Ret_Int : Int;
2229
2230 begin
2231 -- Uints of more than one digit could be outside the range for
2232 -- Ints. Caller should have checked for this if not certain.
2233 -- Fatal error to attempt to convert from value outside Int'Range.
2234
2235 pragma Assert (UI_Is_In_Int_Range (Input));
2236
2237 -- Otherwise, proceed ahead, we are OK
2238
2239 Init_Operand (Input, In_Vec);
2240 Ret_Int := 0;
2241
2242 -- Calculate -|Input| and then negates if value is positive. This
2243 -- handles our current definition of Int (based on 2s complement).
2244 -- Is it secure enough???
2245
2246 for Idx in In_Vec'Range loop
2247 Ret_Int := Ret_Int * Base - abs In_Vec (Idx);
2248 end loop;
2249
2250 if In_Vec (1) < Int_0 then
2251 return Ret_Int;
2252 else
2253 return -Ret_Int;
2254 end if;
2255 end;
2256 end if;
2257 end UI_To_Int;
2258
2259 --------------
2260 -- UI_Write --
2261 --------------
2262
2263 procedure UI_Write (Input : Uint; Format : UI_Format := Auto) is
2264 begin
2265 Image_Out (Input, False, Format);
2266 end UI_Write;
2267
2268 ---------------------
2269 -- Vector_To_Uint --
2270 ---------------------
2271
2272 function Vector_To_Uint
2273 (In_Vec : UI_Vector;
2274 Negative : Boolean)
2275 return Uint
2276 is
2277 Size : Int;
2278 Val : Int;
2279
2280 begin
2281 -- The vector can contain leading zeros. These are not stored in the
2282 -- table, so loop through the vector looking for first non-zero digit
2283
2284 for J in In_Vec'Range loop
2285 if In_Vec (J) /= Int_0 then
2286
2287 -- The length of the value is the length of the rest of the vector
2288
2289 Size := In_Vec'Last - J + 1;
2290
2291 -- One digit value can always be represented directly
2292
2293 if Size = Int_1 then
2294 if Negative then
2295 return Uint (Int (Uint_Direct_Bias) - In_Vec (J));
2296 else
2297 return Uint (Int (Uint_Direct_Bias) + In_Vec (J));
2298 end if;
2299
2300 -- Positive two digit values may be in direct representation range
2301
2302 elsif Size = Int_2 and then not Negative then
2303 Val := In_Vec (J) * Base + In_Vec (J + 1);
2304
2305 if Val <= Max_Direct then
2306 return Uint (Int (Uint_Direct_Bias) + Val);
2307 end if;
2308 end if;
2309
2310 -- The value is outside the direct representation range and must
2311 -- therefore be stored in the table. Expand the table to contain
2312 -- the count and digits. The index of the new table entry will be
2313 -- returned as the result.
2314
2315 Uints.Append ((Length => Size, Loc => Udigits.Last + 1));
2316
2317 if Negative then
2318 Val := -In_Vec (J);
2319 else
2320 Val := +In_Vec (J);
2321 end if;
2322
2323 Udigits.Append (Val);
2324
2325 for K in 2 .. Size loop
2326 Udigits.Append (In_Vec (J + K - 1));
2327 end loop;
2328
2329 return Uints.Last;
2330 end if;
2331 end loop;
2332
2333 -- Dropped through loop only if vector contained all zeros
2334
2335 return Uint_0;
2336 end Vector_To_Uint;
2337
2338 end Uintp;
Mirror of the offical gcc git repository hosted at gcc.gnu.org