|
145
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 2019, Free Software Foundation, Inc. --
|
|
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
|
17 -- --
|
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
21 -- --
|
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 with Ada.Unchecked_Deallocation;
|
|
|
33 with Ada.Characters.Conversions; use Ada.Characters.Conversions;
|
|
|
34
|
|
|
35 with Interfaces; use Interfaces;
|
|
|
36
|
|
|
37 with System.Generic_Bignums;
|
|
|
38
|
|
|
39 package body Ada.Numerics.Big_Numbers.Big_Integers is
|
|
|
40
|
|
|
41 package Bignums is new
|
|
|
42 System.Generic_Bignums (Use_Secondary_Stack => False);
|
|
|
43 use Bignums, System;
|
|
|
44
|
|
|
45 procedure Free is new Ada.Unchecked_Deallocation (Bignum_Data, Bignum);
|
|
|
46
|
|
|
47 function Get_Bignum (Arg : Big_Integer) return Bignum is
|
|
|
48 (if Arg.Value.C = System.Null_Address
|
|
|
49 then raise Constraint_Error with "invalid big integer"
|
|
|
50 else To_Bignum (Arg.Value.C));
|
|
|
51 -- Check for validity of Arg and return the Bignum value stored in Arg.
|
|
|
52 -- Raise Constraint_Error if Arg is uninitialized.
|
|
|
53
|
|
|
54 procedure Set_Bignum (Arg : out Big_Integer; Value : Bignum)
|
|
|
55 with Inline;
|
|
|
56 -- Set the Bignum value stored in Arg to Value
|
|
|
57
|
|
|
58 ----------------
|
|
|
59 -- Set_Bignum --
|
|
|
60 ----------------
|
|
|
61
|
|
|
62 procedure Set_Bignum (Arg : out Big_Integer; Value : Bignum) is
|
|
|
63 begin
|
|
|
64 Arg.Value.C := To_Address (Value);
|
|
|
65 end Set_Bignum;
|
|
|
66
|
|
|
67 --------------
|
|
|
68 -- Is_Valid --
|
|
|
69 --------------
|
|
|
70
|
|
|
71 function Is_Valid (Arg : Big_Integer) return Boolean is
|
|
|
72 (Arg.Value.C /= System.Null_Address);
|
|
|
73
|
|
|
74 ---------
|
|
|
75 -- "=" --
|
|
|
76 ---------
|
|
|
77
|
|
|
78 function "=" (L, R : Big_Integer) return Boolean is
|
|
|
79 begin
|
|
|
80 return Big_EQ (Get_Bignum (L), Get_Bignum (R));
|
|
|
81 end "=";
|
|
|
82
|
|
|
83 ---------
|
|
|
84 -- "<" --
|
|
|
85 ---------
|
|
|
86
|
|
|
87 function "<" (L, R : Big_Integer) return Boolean is
|
|
|
88 begin
|
|
|
89 return Big_LT (Get_Bignum (L), Get_Bignum (R));
|
|
|
90 end "<";
|
|
|
91
|
|
|
92 ----------
|
|
|
93 -- "<=" --
|
|
|
94 ----------
|
|
|
95
|
|
|
96 function "<=" (L, R : Big_Integer) return Boolean is
|
|
|
97 begin
|
|
|
98 return Big_LE (Get_Bignum (L), Get_Bignum (R));
|
|
|
99 end "<=";
|
|
|
100
|
|
|
101 ---------
|
|
|
102 -- ">" --
|
|
|
103 ---------
|
|
|
104
|
|
|
105 function ">" (L, R : Big_Integer) return Boolean is
|
|
|
106 begin
|
|
|
107 return Big_GT (Get_Bignum (L), Get_Bignum (R));
|
|
|
108 end ">";
|
|
|
109
|
|
|
110 ----------
|
|
|
111 -- ">=" --
|
|
|
112 ----------
|
|
|
113
|
|
|
114 function ">=" (L, R : Big_Integer) return Boolean is
|
|
|
115 begin
|
|
|
116 return Big_GE (Get_Bignum (L), Get_Bignum (R));
|
|
|
117 end ">=";
|
|
|
118
|
|
|
119 --------------------
|
|
|
120 -- To_Big_Integer --
|
|
|
121 --------------------
|
|
|
122
|
|
|
123 function To_Big_Integer (Arg : Integer) return Big_Integer is
|
|
|
124 Result : Big_Integer;
|
|
|
125 begin
|
|
|
126 Set_Bignum (Result, To_Bignum (Long_Long_Integer (Arg)));
|
|
|
127 return Result;
|
|
|
128 end To_Big_Integer;
|
|
|
129
|
|
|
130 ----------------
|
|
|
131 -- To_Integer --
|
|
|
132 ----------------
|
|
|
133
|
|
|
134 function To_Integer (Arg : Big_Integer) return Integer is
|
|
|
135 begin
|
|
|
136 return Integer (From_Bignum (Get_Bignum (Arg)));
|
|
|
137 end To_Integer;
|
|
|
138
|
|
|
139 ------------------------
|
|
|
140 -- Signed_Conversions --
|
|
|
141 ------------------------
|
|
|
142
|
|
|
143 package body Signed_Conversions is
|
|
|
144
|
|
|
145 --------------------
|
|
|
146 -- To_Big_Integer --
|
|
|
147 --------------------
|
|
|
148
|
|
|
149 function To_Big_Integer (Arg : Int) return Big_Integer is
|
|
|
150 Result : Big_Integer;
|
|
|
151 begin
|
|
|
152 Set_Bignum (Result, To_Bignum (Long_Long_Integer (Arg)));
|
|
|
153 return Result;
|
|
|
154 end To_Big_Integer;
|
|
|
155
|
|
|
156 ----------------------
|
|
|
157 -- From_Big_Integer --
|
|
|
158 ----------------------
|
|
|
159
|
|
|
160 function From_Big_Integer (Arg : Big_Integer) return Int is
|
|
|
161 begin
|
|
|
162 return Int (From_Bignum (Get_Bignum (Arg)));
|
|
|
163 end From_Big_Integer;
|
|
|
164
|
|
|
165 end Signed_Conversions;
|
|
|
166
|
|
|
167 --------------------------
|
|
|
168 -- Unsigned_Conversions --
|
|
|
169 --------------------------
|
|
|
170
|
|
|
171 package body Unsigned_Conversions is
|
|
|
172
|
|
|
173 --------------------
|
|
|
174 -- To_Big_Integer --
|
|
|
175 --------------------
|
|
|
176
|
|
|
177 function To_Big_Integer (Arg : Int) return Big_Integer is
|
|
|
178 Result : Big_Integer;
|
|
|
179 begin
|
|
|
180 Set_Bignum (Result, To_Bignum (Unsigned_64 (Arg)));
|
|
|
181 return Result;
|
|
|
182 end To_Big_Integer;
|
|
|
183
|
|
|
184 ----------------------
|
|
|
185 -- From_Big_Integer --
|
|
|
186 ----------------------
|
|
|
187
|
|
|
188 function From_Big_Integer (Arg : Big_Integer) return Int is
|
|
|
189 begin
|
|
|
190 return Int (From_Bignum (Get_Bignum (Arg)));
|
|
|
191 end From_Big_Integer;
|
|
|
192
|
|
|
193 end Unsigned_Conversions;
|
|
|
194
|
|
|
195 ---------------
|
|
|
196 -- To_String --
|
|
|
197 ---------------
|
|
|
198
|
|
|
199 Hex_Chars : constant array (0 .. 15) of Character := "0123456789ABCDEF";
|
|
|
200
|
|
|
201 function To_String
|
|
|
202 (Arg : Big_Integer; Width : Field := 0; Base : Number_Base := 10)
|
|
|
203 return String
|
|
|
204 is
|
|
|
205 Big_Base : constant Big_Integer := To_Big_Integer (Integer (Base));
|
|
|
206
|
|
|
207 function Add_Base (S : String) return String;
|
|
|
208 -- Add base information if Base /= 10
|
|
|
209
|
|
|
210 function Leading_Padding
|
|
|
211 (Str : String;
|
|
|
212 Min_Length : Field;
|
|
|
213 Char : Character := ' ') return String;
|
|
|
214 -- Return padding of Char concatenated with Str so that the resulting
|
|
|
215 -- string is at least Min_Length long.
|
|
|
216
|
|
|
217 function Image (Arg : Big_Integer) return String;
|
|
|
218 -- Return image of Arg, assuming Arg is positive.
|
|
|
219
|
|
|
220 function Image (N : Natural) return String;
|
|
|
221 -- Return image of N, with no leading space.
|
|
|
222
|
|
|
223 --------------
|
|
|
224 -- Add_Base --
|
|
|
225 --------------
|
|
|
226
|
|
|
227 function Add_Base (S : String) return String is
|
|
|
228 begin
|
|
|
229 if Base = 10 then
|
|
|
230 return S;
|
|
|
231 else
|
|
|
232 return Image (Base) & "#" & S & "#";
|
|
|
233 end if;
|
|
|
234 end Add_Base;
|
|
|
235
|
|
|
236 -----------
|
|
|
237 -- Image --
|
|
|
238 -----------
|
|
|
239
|
|
|
240 function Image (N : Natural) return String is
|
|
|
241 S : constant String := Natural'Image (N);
|
|
|
242 begin
|
|
|
243 return S (2 .. S'Last);
|
|
|
244 end Image;
|
|
|
245
|
|
|
246 function Image (Arg : Big_Integer) return String is
|
|
|
247 begin
|
|
|
248 if Arg < Big_Base then
|
|
|
249 return (1 => Hex_Chars (To_Integer (Arg)));
|
|
|
250 else
|
|
|
251 return Image (Arg / Big_Base)
|
|
|
252 & Hex_Chars (To_Integer (Arg rem Big_Base));
|
|
|
253 end if;
|
|
|
254 end Image;
|
|
|
255
|
|
|
256 ---------------------
|
|
|
257 -- Leading_Padding --
|
|
|
258 ---------------------
|
|
|
259
|
|
|
260 function Leading_Padding
|
|
|
261 (Str : String;
|
|
|
262 Min_Length : Field;
|
|
|
263 Char : Character := ' ') return String is
|
|
|
264 begin
|
|
|
265 return (1 .. Integer'Max (Integer (Min_Length) - Str'Length, 0)
|
|
|
266 => Char) & Str;
|
|
|
267 end Leading_Padding;
|
|
|
268
|
|
|
269 begin
|
|
|
270 if Arg < To_Big_Integer (0) then
|
|
|
271 return Leading_Padding ("-" & Add_Base (Image (-Arg)), Width);
|
|
|
272 else
|
|
|
273 return Leading_Padding (" " & Add_Base (Image (Arg)), Width);
|
|
|
274 end if;
|
|
|
275 end To_String;
|
|
|
276
|
|
|
277 -----------------
|
|
|
278 -- From_String --
|
|
|
279 -----------------
|
|
|
280
|
|
|
281 function From_String (Arg : String) return Big_Integer is
|
|
|
282 Result : Big_Integer;
|
|
|
283 begin
|
|
|
284 -- ??? only support Long_Long_Integer, good enough for now
|
|
|
285 Set_Bignum (Result, To_Bignum (Long_Long_Integer'Value (Arg)));
|
|
|
286 return Result;
|
|
|
287 end From_String;
|
|
|
288
|
|
|
289 ---------------
|
|
|
290 -- Put_Image --
|
|
|
291 ---------------
|
|
|
292
|
|
|
293 procedure Put_Image
|
|
|
294 (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
|
|
|
295 Arg : Big_Integer) is
|
|
|
296 begin
|
|
|
297 Wide_Wide_String'Write (Stream, To_Wide_Wide_String (To_String (Arg)));
|
|
|
298 end Put_Image;
|
|
|
299
|
|
|
300 ---------
|
|
|
301 -- "+" --
|
|
|
302 ---------
|
|
|
303
|
|
|
304 function "+" (L : Big_Integer) return Big_Integer is
|
|
|
305 Result : Big_Integer;
|
|
|
306 begin
|
|
|
307 Set_Bignum (Result, new Bignum_Data'(Get_Bignum (L).all));
|
|
|
308 return Result;
|
|
|
309 end "+";
|
|
|
310
|
|
|
311 ---------
|
|
|
312 -- "-" --
|
|
|
313 ---------
|
|
|
314
|
|
|
315 function "-" (L : Big_Integer) return Big_Integer is
|
|
|
316 Result : Big_Integer;
|
|
|
317 begin
|
|
|
318 Set_Bignum (Result, Big_Neg (Get_Bignum (L)));
|
|
|
319 return Result;
|
|
|
320 end "-";
|
|
|
321
|
|
|
322 -----------
|
|
|
323 -- "abs" --
|
|
|
324 -----------
|
|
|
325
|
|
|
326 function "abs" (L : Big_Integer) return Big_Integer is
|
|
|
327 Result : Big_Integer;
|
|
|
328 begin
|
|
|
329 Set_Bignum (Result, Big_Abs (Get_Bignum (L)));
|
|
|
330 return Result;
|
|
|
331 end "abs";
|
|
|
332
|
|
|
333 ---------
|
|
|
334 -- "+" --
|
|
|
335 ---------
|
|
|
336
|
|
|
337 function "+" (L, R : Big_Integer) return Big_Integer is
|
|
|
338 Result : Big_Integer;
|
|
|
339 begin
|
|
|
340 Set_Bignum (Result, Big_Add (Get_Bignum (L), Get_Bignum (R)));
|
|
|
341 return Result;
|
|
|
342 end "+";
|
|
|
343
|
|
|
344 ---------
|
|
|
345 -- "-" --
|
|
|
346 ---------
|
|
|
347
|
|
|
348 function "-" (L, R : Big_Integer) return Big_Integer is
|
|
|
349 Result : Big_Integer;
|
|
|
350 begin
|
|
|
351 Set_Bignum (Result, Big_Sub (Get_Bignum (L), Get_Bignum (R)));
|
|
|
352 return Result;
|
|
|
353 end "-";
|
|
|
354
|
|
|
355 ---------
|
|
|
356 -- "*" --
|
|
|
357 ---------
|
|
|
358
|
|
|
359 function "*" (L, R : Big_Integer) return Big_Integer is
|
|
|
360 Result : Big_Integer;
|
|
|
361 begin
|
|
|
362 Set_Bignum (Result, Big_Mul (Get_Bignum (L), Get_Bignum (R)));
|
|
|
363 return Result;
|
|
|
364 end "*";
|
|
|
365
|
|
|
366 ---------
|
|
|
367 -- "/" --
|
|
|
368 ---------
|
|
|
369
|
|
|
370 function "/" (L, R : Big_Integer) return Big_Integer is
|
|
|
371 Result : Big_Integer;
|
|
|
372 begin
|
|
|
373 Set_Bignum (Result, Big_Div (Get_Bignum (L), Get_Bignum (R)));
|
|
|
374 return Result;
|
|
|
375 end "/";
|
|
|
376
|
|
|
377 -----------
|
|
|
378 -- "mod" --
|
|
|
379 -----------
|
|
|
380
|
|
|
381 function "mod" (L, R : Big_Integer) return Big_Integer is
|
|
|
382 Result : Big_Integer;
|
|
|
383 begin
|
|
|
384 Set_Bignum (Result, Big_Mod (Get_Bignum (L), Get_Bignum (R)));
|
|
|
385 return Result;
|
|
|
386 end "mod";
|
|
|
387
|
|
|
388 -----------
|
|
|
389 -- "rem" --
|
|
|
390 -----------
|
|
|
391
|
|
|
392 function "rem" (L, R : Big_Integer) return Big_Integer is
|
|
|
393 Result : Big_Integer;
|
|
|
394 begin
|
|
|
395 Set_Bignum (Result, Big_Rem (Get_Bignum (L), Get_Bignum (R)));
|
|
|
396 return Result;
|
|
|
397 end "rem";
|
|
|
398
|
|
|
399 ----------
|
|
|
400 -- "**" --
|
|
|
401 ----------
|
|
|
402
|
|
|
403 function "**" (L : Big_Integer; R : Natural) return Big_Integer is
|
|
|
404 begin
|
|
|
405 -- Explicitly check for validity before allocating Exp so that
|
|
|
406 -- the call to Get_Bignum below cannot raise an exception before
|
|
|
407 -- we get a chance to free Exp.
|
|
|
408
|
|
|
409 if not Is_Valid (L) then
|
|
|
410 raise Constraint_Error with "invalid big integer";
|
|
|
411 end if;
|
|
|
412
|
|
|
413 declare
|
|
|
414 Exp : Bignum := To_Bignum (Long_Long_Integer (R));
|
|
|
415 Result : Big_Integer;
|
|
|
416 begin
|
|
|
417 Set_Bignum (Result, Big_Exp (Get_Bignum (L), Exp));
|
|
|
418 Free (Exp);
|
|
|
419 return Result;
|
|
|
420 end;
|
|
|
421 end "**";
|
|
|
422
|
|
|
423 ---------
|
|
|
424 -- Min --
|
|
|
425 ---------
|
|
|
426
|
|
|
427 function Min (L, R : Big_Integer) return Big_Integer is
|
|
|
428 (if L < R then L else R);
|
|
|
429
|
|
|
430 ---------
|
|
|
431 -- Max --
|
|
|
432 ---------
|
|
|
433
|
|
|
434 function Max (L, R : Big_Integer) return Big_Integer is
|
|
|
435 (if L > R then L else R);
|
|
|
436
|
|
|
437 -----------------------------
|
|
|
438 -- Greatest_Common_Divisor --
|
|
|
439 -----------------------------
|
|
|
440
|
|
|
441 function Greatest_Common_Divisor (L, R : Big_Integer) return Big_Positive is
|
|
|
442 function GCD (A, B : Big_Integer) return Big_Integer;
|
|
|
443 -- Recursive internal version
|
|
|
444
|
|
|
445 ---------
|
|
|
446 -- GCD --
|
|
|
447 ---------
|
|
|
448
|
|
|
449 function GCD (A, B : Big_Integer) return Big_Integer is
|
|
|
450 begin
|
|
|
451 if Is_Zero (Get_Bignum (B)) then
|
|
|
452 return A;
|
|
|
453 else
|
|
|
454 return GCD (B, A rem B);
|
|
|
455 end if;
|
|
|
456 end GCD;
|
|
|
457
|
|
|
458 begin
|
|
|
459 return GCD (abs L, abs R);
|
|
|
460 end Greatest_Common_Divisor;
|
|
|
461
|
|
|
462 ------------
|
|
|
463 -- Adjust --
|
|
|
464 ------------
|
|
|
465
|
|
|
466 procedure Adjust (This : in out Controlled_Bignum) is
|
|
|
467 begin
|
|
|
468 if This.C /= System.Null_Address then
|
|
|
469 This.C := To_Address (new Bignum_Data'(To_Bignum (This.C).all));
|
|
|
470 end if;
|
|
|
471 end Adjust;
|
|
|
472
|
|
|
473 --------------
|
|
|
474 -- Finalize --
|
|
|
475 --------------
|
|
|
476
|
|
|
477 procedure Finalize (This : in out Controlled_Bignum) is
|
|
|
478 Tmp : Bignum := To_Bignum (This.C);
|
|
|
479 begin
|
|
|
480 Free (Tmp);
|
|
|
481 This.C := System.Null_Address;
|
|
|
482 end Finalize;
|
|
|
483
|
|
|
484 end Ada.Numerics.Big_Numbers.Big_Integers;
|
