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