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