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 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.Conversions; use Ada.Characters.Conversions; 39with Ada.Characters.Handling; use Ada.Characters.Handling; 40 41package 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 730end Ada.Numerics.Big_Numbers.Big_Integers; 731