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