Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-nbnbin__gmp.adb @ 145:1830386684a0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-9.2.0
author anatofuz
date Thu, 13 Feb 2020 11:34:05 +0900
parents
children
comparison
equal deleted inserted replaced
131:84e7813d76e9 145:1830386684a0
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;