|
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 -- This is the GMP version of this package
|
|
|
33
|
|
|
34 with Ada.Unchecked_Conversion;
|
|
|
35 with Ada.Unchecked_Deallocation;
|
|
|
36 with Interfaces.C; use Interfaces.C;
|
|
|
37 with Interfaces.C.Strings; use Interfaces.C.Strings;
|
|
|
38 with Ada.Characters.Conversions; use Ada.Characters.Conversions;
|
|
|
39 with Ada.Characters.Handling; use Ada.Characters.Handling;
|
|
|
40
|
|
|
41 package body Ada.Numerics.Big_Numbers.Big_Integers is
|
|
|
42
|
|
|
43 use System;
|
|
|
44
|
|
|
45 pragma Linker_Options ("-lgmp");
|
|
|
46
|
|
|
47 type mpz_t is record
|
|
|
48 mp_alloc : Integer;
|
|
|
49 mp_size : Integer;
|
|
|
50 mp_d : System.Address;
|
|
|
51 end record;
|
|
|
52 pragma Convention (C, mpz_t);
|
|
|
53 type mpz_t_ptr is access all mpz_t;
|
|
|
54
|
|
|
55 function To_Mpz is new Ada.Unchecked_Conversion (System.Address, mpz_t_ptr);
|
|
|
56 function To_Address is new
|
|
|
57 Ada.Unchecked_Conversion (mpz_t_ptr, System.Address);
|
|
|
58
|
|
|
59 function Get_Mpz (Arg : Optional_Big_Integer) return mpz_t_ptr is
|
|
|
60 (To_Mpz (Arg.Value.C));
|
|
|
61 -- Return the mpz_t value stored in Arg
|
|
|
62
|
|
|
63 procedure Set_Mpz (Arg : in out Optional_Big_Integer; Value : mpz_t_ptr)
|
|
|
64 with Inline;
|
|
|
65 -- Set the mpz_t value stored in Arg to Value
|
|
|
66
|
|
|
67 procedure Allocate (This : in out Optional_Big_Integer) with Inline;
|
|
|
68 -- Allocate an Optional_Big_Integer, including the underlying mpz
|
|
|
69
|
|
|
70 procedure mpz_init_set (ROP : access mpz_t; OP : access constant mpz_t);
|
|
|
71 pragma Import (C, mpz_init_set, "__gmpz_init_set");
|
|
|
72
|
|
|
73 procedure mpz_set (ROP : access mpz_t; OP : access constant mpz_t);
|
|
|
74 pragma Import (C, mpz_set, "__gmpz_set");
|
|
|
75
|
|
|
76 function mpz_cmp (OP1, OP2 : access constant mpz_t) return Integer;
|
|
|
77 pragma Import (C, mpz_cmp, "__gmpz_cmp");
|
|
|
78
|
|
|
79 function mpz_cmp_ui
|
|
|
80 (OP1 : access constant mpz_t; OP2 : unsigned_long) return Integer;
|
|
|
81 pragma Import (C, mpz_cmp_ui, "__gmpz_cmp_ui");
|
|
|
82
|
|
|
83 procedure mpz_set_si (ROP : access mpz_t; OP : long);
|
|
|
84 pragma Import (C, mpz_set_si, "__gmpz_set_si");
|
|
|
85
|
|
|
86 procedure mpz_set_ui (ROP : access mpz_t; OP : unsigned_long);
|
|
|
87 pragma Import (C, mpz_set_ui, "__gmpz_set_ui");
|
|
|
88
|
|
|
89 function mpz_get_si (OP : access constant mpz_t) return long;
|
|
|
90 pragma Import (C, mpz_get_si, "__gmpz_get_si");
|
|
|
91
|
|
|
92 function mpz_get_ui (OP : access constant mpz_t) return unsigned_long;
|
|
|
93 pragma Import (C, mpz_get_ui, "__gmpz_get_ui");
|
|
|
94
|
|
|
95 procedure mpz_neg (ROP : access mpz_t; OP : access constant mpz_t);
|
|
|
96 pragma Import (C, mpz_neg, "__gmpz_neg");
|
|
|
97
|
|
|
98 procedure mpz_sub (ROP : access mpz_t; OP1, OP2 : access constant mpz_t);
|
|
|
99 pragma Import (C, mpz_sub, "__gmpz_sub");
|
|
|
100
|
|
|
101 -------------
|
|
|
102 -- Set_Mpz --
|
|
|
103 -------------
|
|
|
104
|
|
|
105 procedure Set_Mpz (Arg : in out Optional_Big_Integer; Value : mpz_t_ptr) is
|
|
|
106 begin
|
|
|
107 Arg.Value.C := To_Address (Value);
|
|
|
108 end Set_Mpz;
|
|
|
109
|
|
|
110 --------------
|
|
|
111 -- Is_Valid --
|
|
|
112 --------------
|
|
|
113
|
|
|
114 function Is_Valid (Arg : Optional_Big_Integer) return Boolean is
|
|
|
115 (Arg.Value.C /= System.Null_Address);
|
|
|
116
|
|
|
117 --------------------------
|
|
|
118 -- Invalid_Big_Integer --
|
|
|
119 --------------------------
|
|
|
120
|
|
|
121 function Invalid_Big_Integer return Optional_Big_Integer is
|
|
|
122 (Value => (Ada.Finalization.Controlled with C => System.Null_Address));
|
|
|
123
|
|
|
124 ---------
|
|
|
125 -- "=" --
|
|
|
126 ---------
|
|
|
127
|
|
|
128 function "=" (L, R : Big_Integer) return Boolean is
|
|
|
129 begin
|
|
|
130 return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) = 0;
|
|
|
131 end "=";
|
|
|
132
|
|
|
133 ---------
|
|
|
134 -- "<" --
|
|
|
135 ---------
|
|
|
136
|
|
|
137 function "<" (L, R : Big_Integer) return Boolean is
|
|
|
138 begin
|
|
|
139 return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) < 0;
|
|
|
140 end "<";
|
|
|
141
|
|
|
142 ----------
|
|
|
143 -- "<=" --
|
|
|
144 ----------
|
|
|
145
|
|
|
146 function "<=" (L, R : Big_Integer) return Boolean is
|
|
|
147 begin
|
|
|
148 return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) <= 0;
|
|
|
149 end "<=";
|
|
|
150
|
|
|
151 ---------
|
|
|
152 -- ">" --
|
|
|
153 ---------
|
|
|
154
|
|
|
155 function ">" (L, R : Big_Integer) return Boolean is
|
|
|
156 begin
|
|
|
157 return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) > 0;
|
|
|
158 end ">";
|
|
|
159
|
|
|
160 ----------
|
|
|
161 -- ">=" --
|
|
|
162 ----------
|
|
|
163
|
|
|
164 function ">=" (L, R : Big_Integer) return Boolean is
|
|
|
165 begin
|
|
|
166 return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) >= 0;
|
|
|
167 end ">=";
|
|
|
168
|
|
|
169 --------------------
|
|
|
170 -- To_Big_Integer --
|
|
|
171 --------------------
|
|
|
172
|
|
|
173 function To_Big_Integer (Arg : Integer) return Big_Integer is
|
|
|
174 Result : Optional_Big_Integer;
|
|
|
175 begin
|
|
|
176 Allocate (Result);
|
|
|
177 mpz_set_si (Get_Mpz (Result), long (Arg));
|
|
|
178 return Result;
|
|
|
179 end To_Big_Integer;
|
|
|
180
|
|
|
181 ----------------
|
|
|
182 -- To_Integer --
|
|
|
183 ----------------
|
|
|
184
|
|
|
185 function To_Integer (Arg : Big_Integer) return Integer is
|
|
|
186 begin
|
|
|
187 return Integer (mpz_get_si (Get_Mpz (Arg)));
|
|
|
188 end To_Integer;
|
|
|
189
|
|
|
190 ------------------------
|
|
|
191 -- Signed_Conversions --
|
|
|
192 ------------------------
|
|
|
193
|
|
|
194 package body Signed_Conversions is
|
|
|
195
|
|
|
196 --------------------
|
|
|
197 -- To_Big_Integer --
|
|
|
198 --------------------
|
|
|
199
|
|
|
200 function To_Big_Integer (Arg : Int) return Big_Integer is
|
|
|
201 Result : Optional_Big_Integer;
|
|
|
202 begin
|
|
|
203 Allocate (Result);
|
|
|
204 mpz_set_si (Get_Mpz (Result), long (Arg));
|
|
|
205 return Result;
|
|
|
206 end To_Big_Integer;
|
|
|
207
|
|
|
208 ----------------------
|
|
|
209 -- From_Big_Integer --
|
|
|
210 ----------------------
|
|
|
211
|
|
|
212 function From_Big_Integer (Arg : Big_Integer) return Int is
|
|
|
213 begin
|
|
|
214 return Int (mpz_get_si (Get_Mpz (Arg)));
|
|
|
215 end From_Big_Integer;
|
|
|
216
|
|
|
217 end Signed_Conversions;
|
|
|
218
|
|
|
219 --------------------------
|
|
|
220 -- Unsigned_Conversions --
|
|
|
221 --------------------------
|
|
|
222
|
|
|
223 package body Unsigned_Conversions is
|
|
|
224
|
|
|
225 --------------------
|
|
|
226 -- To_Big_Integer --
|
|
|
227 --------------------
|
|
|
228
|
|
|
229 function To_Big_Integer (Arg : Int) return Big_Integer is
|
|
|
230 Result : Optional_Big_Integer;
|
|
|
231 begin
|
|
|
232 Allocate (Result);
|
|
|
233 mpz_set_ui (Get_Mpz (Result), unsigned_long (Arg));
|
|
|
234 return Result;
|
|
|
235 end To_Big_Integer;
|
|
|
236
|
|
|
237 ----------------------
|
|
|
238 -- From_Big_Integer --
|
|
|
239 ----------------------
|
|
|
240
|
|
|
241 function From_Big_Integer (Arg : Big_Integer) return Int is
|
|
|
242 begin
|
|
|
243 return Int (mpz_get_ui (Get_Mpz (Arg)));
|
|
|
244 end From_Big_Integer;
|
|
|
245
|
|
|
246 end Unsigned_Conversions;
|
|
|
247
|
|
|
248 ---------------
|
|
|
249 -- To_String --
|
|
|
250 ---------------
|
|
|
251
|
|
|
252 function To_String
|
|
|
253 (Arg : Big_Integer; Width : Field := 0; Base : Number_Base := 10)
|
|
|
254 return String
|
|
|
255 is
|
|
|
256 function mpz_get_str
|
|
|
257 (STR : System.Address;
|
|
|
258 BASE : Integer;
|
|
|
259 OP : access constant mpz_t) return chars_ptr;
|
|
|
260 pragma Import (C, mpz_get_str, "__gmpz_get_str");
|
|
|
261
|
|
|
262 function mpz_sizeinbase
|
|
|
263 (this : access constant mpz_t; base : Integer) return size_t;
|
|
|
264 pragma Import (C, mpz_sizeinbase, "__gmpz_sizeinbase");
|
|
|
265
|
|
|
266 function Add_Base (S : String) return String;
|
|
|
267 -- Add base information if Base /= 10
|
|
|
268
|
|
|
269 function Leading_Padding
|
|
|
270 (Str : String;
|
|
|
271 Min_Length : Field;
|
|
|
272 Char : Character := ' ') return String;
|
|
|
273 -- Return padding of Char concatenated with Str so that the resulting
|
|
|
274 -- string is at least Min_Length long.
|
|
|
275
|
|
|
276 function Image (N : Natural) return String;
|
|
|
277 -- Return image of N, with no leading space.
|
|
|
278
|
|
|
279 --------------
|
|
|
280 -- Add_Base --
|
|
|
281 --------------
|
|
|
282
|
|
|
283 function Add_Base (S : String) return String is
|
|
|
284 begin
|
|
|
285 if Base = 10 then
|
|
|
286 return S;
|
|
|
287 else
|
|
|
288 return Image (Base) & "#" & To_Upper (S) & "#";
|
|
|
289 end if;
|
|
|
290 end Add_Base;
|
|
|
291
|
|
|
292 -----------
|
|
|
293 -- Image --
|
|
|
294 -----------
|
|
|
295
|
|
|
296 function Image (N : Natural) return String is
|
|
|
297 S : constant String := Natural'Image (N);
|
|
|
298 begin
|
|
|
299 return S (2 .. S'Last);
|
|
|
300 end Image;
|
|
|
301
|
|
|
302 ---------------------
|
|
|
303 -- Leading_Padding --
|
|
|
304 ---------------------
|
|
|
305
|
|
|
306 function Leading_Padding
|
|
|
307 (Str : String;
|
|
|
308 Min_Length : Field;
|
|
|
309 Char : Character := ' ') return String is
|
|
|
310 begin
|
|
|
311 return (1 .. Integer'Max (Integer (Min_Length) - Str'Length, 0)
|
|
|
312 => Char) & Str;
|
|
|
313 end Leading_Padding;
|
|
|
314
|
|
|
315 Number_Digits : constant Integer :=
|
|
|
316 Integer (mpz_sizeinbase (Get_Mpz (Arg), Integer (abs Base)));
|
|
|
317
|
|
|
318 Buffer : aliased String (1 .. Number_Digits + 2);
|
|
|
319 -- The correct number to allocate is 2 more than Number_Digits in order
|
|
|
320 -- to handle a possible minus sign and the null-terminator.
|
|
|
321
|
|
|
322 Result : constant chars_ptr :=
|
|
|
323 mpz_get_str (Buffer'Address, Integer (Base), Get_Mpz (Arg));
|
|
|
324 S : constant String := Value (Result);
|
|
|
325
|
|
|
326 begin
|
|
|
327 if S (1) = '-' then
|
|
|
328 return Leading_Padding ("-" & Add_Base (S (2 .. S'Last)), Width);
|
|
|
329 else
|
|
|
330 return Leading_Padding (" " & Add_Base (S), Width);
|
|
|
331 end if;
|
|
|
332 end To_String;
|
|
|
333
|
|
|
334 -----------------
|
|
|
335 -- From_String --
|
|
|
336 -----------------
|
|
|
337
|
|
|
338 function From_String (Arg : String) return Big_Integer is
|
|
|
339 function mpz_set_str
|
|
|
340 (this : access mpz_t;
|
|
|
341 str : System.Address;
|
|
|
342 base : Integer := 10) return Integer;
|
|
|
343 pragma Import (C, mpz_set_str, "__gmpz_set_str");
|
|
|
344
|
|
|
345 Result : Optional_Big_Integer;
|
|
|
346 First : Natural;
|
|
|
347 Last : Natural;
|
|
|
348 Base : Natural;
|
|
|
349
|
|
|
350 begin
|
|
|
351 Allocate (Result);
|
|
|
352
|
|
|
353 if Arg (Arg'Last) /= '#' then
|
|
|
354
|
|
|
355 -- Base 10 number
|
|
|
356
|
|
|
357 First := Arg'First;
|
|
|
358 Last := Arg'Last;
|
|
|
359 Base := 10;
|
|
|
360 else
|
|
|
361 -- Compute the xx base in a xx#yyyyy# number
|
|
|
362
|
|
|
363 if Arg'Length < 4 then
|
|
|
364 raise Constraint_Error;
|
|
|
365 end if;
|
|
|
366
|
|
|
367 First := 0;
|
|
|
368 Last := Arg'Last - 1;
|
|
|
369
|
|
|
370 for J in Arg'First + 1 .. Last loop
|
|
|
371 if Arg (J) = '#' then
|
|
|
372 First := J;
|
|
|
373 exit;
|
|
|
374 end if;
|
|
|
375 end loop;
|
|
|
376
|
|
|
377 if First = 0 then
|
|
|
378 raise Constraint_Error;
|
|
|
379 end if;
|
|
|
380
|
|
|
381 Base := Natural'Value (Arg (Arg'First .. First - 1));
|
|
|
382 First := First + 1;
|
|
|
383 end if;
|
|
|
384
|
|
|
385 declare
|
|
|
386 Str : aliased String (1 .. Last - First + 2);
|
|
|
387 Index : Natural := 0;
|
|
|
388 begin
|
|
|
389 -- Strip underscores
|
|
|
390
|
|
|
391 for J in First .. Last loop
|
|
|
392 if Arg (J) /= '_' then
|
|
|
393 Index := Index + 1;
|
|
|
394 Str (Index) := Arg (J);
|
|
|
395 end if;
|
|
|
396 end loop;
|
|
|
397
|
|
|
398 Index := Index + 1;
|
|
|
399 Str (Index) := ASCII.NUL;
|
|
|
400
|
|
|
401 if mpz_set_str (Get_Mpz (Result), Str'Address, Base) /= 0 then
|
|
|
402 raise Constraint_Error;
|
|
|
403 end if;
|
|
|
404 end;
|
|
|
405
|
|
|
406 return Result;
|
|
|
407 end From_String;
|
|
|
408
|
|
|
409 ---------------
|
|
|
410 -- Put_Image --
|
|
|
411 ---------------
|
|
|
412
|
|
|
413 procedure Put_Image
|
|
|
414 (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
|
|
|
415 Arg : Big_Integer) is
|
|
|
416 begin
|
|
|
417 Wide_Wide_String'Write (Stream, To_Wide_Wide_String (To_String (Arg)));
|
|
|
418 end Put_Image;
|
|
|
419
|
|
|
420 ---------
|
|
|
421 -- "+" --
|
|
|
422 ---------
|
|
|
423
|
|
|
424 function "+" (L : Big_Integer) return Big_Integer is
|
|
|
425 Result : Optional_Big_Integer;
|
|
|
426 begin
|
|
|
427 Set_Mpz (Result, new mpz_t);
|
|
|
428 mpz_init_set (Get_Mpz (Result), Get_Mpz (L));
|
|
|
429 return Result;
|
|
|
430 end "+";
|
|
|
431
|
|
|
432 ---------
|
|
|
433 -- "-" --
|
|
|
434 ---------
|
|
|
435
|
|
|
436 function "-" (L : Big_Integer) return Big_Integer is
|
|
|
437 Result : Optional_Big_Integer;
|
|
|
438 begin
|
|
|
439 Allocate (Result);
|
|
|
440 mpz_neg (Get_Mpz (Result), Get_Mpz (L));
|
|
|
441 return Result;
|
|
|
442 end "-";
|
|
|
443
|
|
|
444 -----------
|
|
|
445 -- "abs" --
|
|
|
446 -----------
|
|
|
447
|
|
|
448 function "abs" (L : Big_Integer) return Big_Integer is
|
|
|
449 procedure mpz_abs (ROP : access mpz_t; OP : access constant mpz_t);
|
|
|
450 pragma Import (C, mpz_abs, "__gmpz_abs");
|
|
|
451
|
|
|
452 Result : Optional_Big_Integer;
|
|
|
453 begin
|
|
|
454 Allocate (Result);
|
|
|
455 mpz_abs (Get_Mpz (Result), Get_Mpz (L));
|
|
|
456 return Result;
|
|
|
457 end "abs";
|
|
|
458
|
|
|
459 ---------
|
|
|
460 -- "+" --
|
|
|
461 ---------
|
|
|
462
|
|
|
463 function "+" (L, R : Big_Integer) return Big_Integer is
|
|
|
464 procedure mpz_add
|
|
|
465 (ROP : access mpz_t; OP1, OP2 : access constant mpz_t);
|
|
|
466 pragma Import (C, mpz_add, "__gmpz_add");
|
|
|
467
|
|
|
468 Result : Optional_Big_Integer;
|
|
|
469
|
|
|
470 begin
|
|
|
471 Allocate (Result);
|
|
|
472 mpz_add (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
|
|
|
473 return Result;
|
|
|
474 end "+";
|
|
|
475
|
|
|
476 ---------
|
|
|
477 -- "-" --
|
|
|
478 ---------
|
|
|
479
|
|
|
480 function "-" (L, R : Big_Integer) return Big_Integer is
|
|
|
481 Result : Optional_Big_Integer;
|
|
|
482 begin
|
|
|
483 Allocate (Result);
|
|
|
484 mpz_sub (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
|
|
|
485 return Result;
|
|
|
486 end "-";
|
|
|
487
|
|
|
488 ---------
|
|
|
489 -- "*" --
|
|
|
490 ---------
|
|
|
491
|
|
|
492 function "*" (L, R : Big_Integer) return Big_Integer is
|
|
|
493 procedure mpz_mul
|
|
|
494 (ROP : access mpz_t; OP1, OP2 : access constant mpz_t);
|
|
|
495 pragma Import (C, mpz_mul, "__gmpz_mul");
|
|
|
496
|
|
|
497 Result : Optional_Big_Integer;
|
|
|
498
|
|
|
499 begin
|
|
|
500 Allocate (Result);
|
|
|
501 mpz_mul (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
|
|
|
502 return Result;
|
|
|
503 end "*";
|
|
|
504
|
|
|
505 ---------
|
|
|
506 -- "/" --
|
|
|
507 ---------
|
|
|
508
|
|
|
509 function "/" (L, R : Big_Integer) return Big_Integer is
|
|
|
510 procedure mpz_tdiv_q (Q : access mpz_t; N, D : access constant mpz_t);
|
|
|
511 pragma Import (C, mpz_tdiv_q, "__gmpz_tdiv_q");
|
|
|
512 begin
|
|
|
513 if mpz_cmp_ui (Get_Mpz (R), 0) = 0 then
|
|
|
514 raise Constraint_Error;
|
|
|
515 end if;
|
|
|
516
|
|
|
517 declare
|
|
|
518 Result : Optional_Big_Integer;
|
|
|
519 begin
|
|
|
520 Allocate (Result);
|
|
|
521 mpz_tdiv_q (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
|
|
|
522 return Result;
|
|
|
523 end;
|
|
|
524 end "/";
|
|
|
525
|
|
|
526 -----------
|
|
|
527 -- "mod" --
|
|
|
528 -----------
|
|
|
529
|
|
|
530 function "mod" (L, R : Big_Integer) return Big_Integer is
|
|
|
531 procedure mpz_mod (R : access mpz_t; N, D : access constant mpz_t);
|
|
|
532 pragma Import (C, mpz_mod, "__gmpz_mod");
|
|
|
533 -- result is always non-negative
|
|
|
534
|
|
|
535 L_Negative, R_Negative : Boolean;
|
|
|
536
|
|
|
537 begin
|
|
|
538 if mpz_cmp_ui (Get_Mpz (R), 0) = 0 then
|
|
|
539 raise Constraint_Error;
|
|
|
540 end if;
|
|
|
541
|
|
|
542 declare
|
|
|
543 Result : Optional_Big_Integer;
|
|
|
544 begin
|
|
|
545 Allocate (Result);
|
|
|
546 L_Negative := mpz_cmp_ui (Get_Mpz (L), 0) < 0;
|
|
|
547 R_Negative := mpz_cmp_ui (Get_Mpz (R), 0) < 0;
|
|
|
548
|
|
|
549 if not (L_Negative or R_Negative) then
|
|
|
550 mpz_mod (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
|
|
|
551 else
|
|
|
552 -- The GMP library provides operators defined by C semantics, but
|
|
|
553 -- the semantics of Ada's mod operator are not the same as C's
|
|
|
554 -- when negative values are involved. We do the following to
|
|
|
555 -- implement the required Ada semantics.
|
|
|
556
|
|
|
557 declare
|
|
|
558 Temp_Left : Big_Integer;
|
|
|
559 Temp_Right : Big_Integer;
|
|
|
560 Temp_Result : Big_Integer;
|
|
|
561
|
|
|
562 begin
|
|
|
563 Allocate (Temp_Result);
|
|
|
564 Set_Mpz (Temp_Left, new mpz_t);
|
|
|
565 Set_Mpz (Temp_Right, new mpz_t);
|
|
|
566 mpz_init_set (Get_Mpz (Temp_Left), Get_Mpz (L));
|
|
|
567 mpz_init_set (Get_Mpz (Temp_Right), Get_Mpz (R));
|
|
|
568
|
|
|
569 if L_Negative then
|
|
|
570 mpz_neg (Get_Mpz (Temp_Left), Get_Mpz (Temp_Left));
|
|
|
571 end if;
|
|
|
572
|
|
|
573 if R_Negative then
|
|
|
574 mpz_neg (Get_Mpz (Temp_Right), Get_Mpz (Temp_Right));
|
|
|
575 end if;
|
|
|
576
|
|
|
577 -- now both Temp_Left and Temp_Right are nonnegative
|
|
|
578
|
|
|
579 mpz_mod (Get_Mpz (Temp_Result),
|
|
|
580 Get_Mpz (Temp_Left),
|
|
|
581 Get_Mpz (Temp_Right));
|
|
|
582
|
|
|
583 if mpz_cmp_ui (Get_Mpz (Temp_Result), 0) = 0 then
|
|
|
584 -- if Temp_Result is zero we are done
|
|
|
585 mpz_set (Get_Mpz (Result), Get_Mpz (Temp_Result));
|
|
|
586
|
|
|
587 elsif L_Negative then
|
|
|
588 if R_Negative then
|
|
|
589 mpz_neg (Get_Mpz (Result), Get_Mpz (Temp_Result));
|
|
|
590 else -- L is negative but R is not
|
|
|
591 mpz_sub (Get_Mpz (Result),
|
|
|
592 Get_Mpz (Temp_Right),
|
|
|
593 Get_Mpz (Temp_Result));
|
|
|
594 end if;
|
|
|
595 else
|
|
|
596 pragma Assert (R_Negative);
|
|
|
597 mpz_sub (Get_Mpz (Result),
|
|
|
598 Get_Mpz (Temp_Result),
|
|
|
599 Get_Mpz (Temp_Right));
|
|
|
600 end if;
|
|
|
601 end;
|
|
|
602 end if;
|
|
|
603
|
|
|
604 return Result;
|
|
|
605 end;
|
|
|
606 end "mod";
|
|
|
607
|
|
|
608 -----------
|
|
|
609 -- "rem" --
|
|
|
610 -----------
|
|
|
611
|
|
|
612 function "rem" (L, R : Big_Integer) return Big_Integer is
|
|
|
613 procedure mpz_tdiv_r (R : access mpz_t; N, D : access constant mpz_t);
|
|
|
614 pragma Import (C, mpz_tdiv_r, "__gmpz_tdiv_r");
|
|
|
615 -- R will have the same sign as N.
|
|
|
616
|
|
|
617 begin
|
|
|
618 if mpz_cmp_ui (Get_Mpz (R), 0) = 0 then
|
|
|
619 raise Constraint_Error;
|
|
|
620 end if;
|
|
|
621
|
|
|
622 declare
|
|
|
623 Result : Optional_Big_Integer;
|
|
|
624 begin
|
|
|
625 Allocate (Result);
|
|
|
626 mpz_tdiv_r (R => Get_Mpz (Result),
|
|
|
627 N => Get_Mpz (L),
|
|
|
628 D => Get_Mpz (R));
|
|
|
629 -- the result takes the sign of N, as required by the RM
|
|
|
630
|
|
|
631 return Result;
|
|
|
632 end;
|
|
|
633 end "rem";
|
|
|
634
|
|
|
635 ----------
|
|
|
636 -- "**" --
|
|
|
637 ----------
|
|
|
638
|
|
|
639 function "**" (L : Big_Integer; R : Natural) return Big_Integer is
|
|
|
640 procedure mpz_pow_ui (ROP : access mpz_t;
|
|
|
641 BASE : access constant mpz_t;
|
|
|
642 EXP : unsigned_long);
|
|
|
643 pragma Import (C, mpz_pow_ui, "__gmpz_pow_ui");
|
|
|
644
|
|
|
645 Result : Optional_Big_Integer;
|
|
|
646
|
|
|
647 begin
|
|
|
648 Allocate (Result);
|
|
|
649 mpz_pow_ui (Get_Mpz (Result), Get_Mpz (L), unsigned_long (R));
|
|
|
650 return Result;
|
|
|
651 end "**";
|
|
|
652
|
|
|
653 ---------
|
|
|
654 -- Min --
|
|
|
655 ---------
|
|
|
656
|
|
|
657 function Min (L, R : Big_Integer) return Big_Integer is
|
|
|
658 (if L < R then L else R);
|
|
|
659
|
|
|
660 ---------
|
|
|
661 -- Max --
|
|
|
662 ---------
|
|
|
663
|
|
|
664 function Max (L, R : Big_Integer) return Big_Integer is
|
|
|
665 (if L > R then L else R);
|
|
|
666
|
|
|
667 -----------------------------
|
|
|
668 -- Greatest_Common_Divisor --
|
|
|
669 -----------------------------
|
|
|
670
|
|
|
671 function Greatest_Common_Divisor (L, R : Big_Integer) return Big_Integer is
|
|
|
672 procedure mpz_gcd
|
|
|
673 (ROP : access mpz_t; Op1, Op2 : access constant mpz_t);
|
|
|
674 pragma Import (C, mpz_gcd, "__gmpz_gcd");
|
|
|
675
|
|
|
676 Result : Optional_Big_Integer;
|
|
|
677
|
|
|
678 begin
|
|
|
679 Allocate (Result);
|
|
|
680 mpz_gcd (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
|
|
|
681 return Result;
|
|
|
682 end Greatest_Common_Divisor;
|
|
|
683
|
|
|
684 --------------
|
|
|
685 -- Allocate --
|
|
|
686 --------------
|
|
|
687
|
|
|
688 procedure Allocate (This : in out Optional_Big_Integer) is
|
|
|
689 procedure mpz_init (this : access mpz_t);
|
|
|
690 pragma Import (C, mpz_init, "__gmpz_init");
|
|
|
691 begin
|
|
|
692 Set_Mpz (This, new mpz_t);
|
|
|
693 mpz_init (Get_Mpz (This));
|
|
|
694 end Allocate;
|
|
|
695
|
|
|
696 ------------
|
|
|
697 -- Adjust --
|
|
|
698 ------------
|
|
|
699
|
|
|
700 procedure Adjust (This : in out Controlled_Bignum) is
|
|
|
701 Value : constant mpz_t_ptr := To_Mpz (This.C);
|
|
|
702 begin
|
|
|
703 if Value /= null then
|
|
|
704 This.C := To_Address (new mpz_t);
|
|
|
705 mpz_init_set (To_Mpz (This.C), Value);
|
|
|
706 end if;
|
|
|
707 end Adjust;
|
|
|
708
|
|
|
709 --------------
|
|
|
710 -- Finalize --
|
|
|
711 --------------
|
|
|
712
|
|
|
713 procedure Finalize (This : in out Controlled_Bignum) is
|
|
|
714 procedure Free is new Ada.Unchecked_Deallocation (mpz_t, mpz_t_ptr);
|
|
|
715
|
|
|
716 procedure mpz_clear (this : access mpz_t);
|
|
|
717 pragma Import (C, mpz_clear, "__gmpz_clear");
|
|
|
718
|
|
|
719 Mpz : mpz_t_ptr;
|
|
|
720
|
|
|
721 begin
|
|
|
722 if This.C /= System.Null_Address then
|
|
|
723 Mpz := To_Mpz (This.C);
|
|
|
724 mpz_clear (Mpz);
|
|
|
725 Free (Mpz);
|
|
|
726 This.C := System.Null_Address;
|
|
|
727 end if;
|
|
|
728 end Finalize;
|
|
|
729
|
|
|
730 end Ada.Numerics.Big_Numbers.Big_Integers;
|
