1 /* 2 * Copyright (c) 2001 by The XFree86 Project, Inc. 3 * 4 * Permission is hereby granted, free of charge, to any person obtaining a 5 * copy of this software and associated documentation files (the "Software"), 6 * to deal in the Software without restriction, including without limitation 7 * the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 * and/or sell copies of the Software, and to permit persons to whom the 9 * Software is furnished to do so, subject to the following conditions: 10 * 11 * The above copyright notice and this permission notice shall be included in 12 * all copies or substantial portions of the Software. 13 * 14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF 19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 20 * SOFTWARE. 21 * 22 * Except as contained in this notice, the name of the XFree86 Project shall 23 * not be used in advertising or otherwise to promote the sale, use or other 24 * dealings in this Software without prior written authorization from the 25 * XFree86 Project. 26 * 27 * Author: Paulo Csar Pereira de Andrade 28 */ 29 30 /* $XFree86: xc/programs/xedit/lisp/math.c,v 1.23tsi Exp $ */ 31 32 #include "lisp/math.h" 33 #include "lisp/private.h" 34 35 #ifdef __APPLE__ 36 # define finite(x) isfinite(x) 37 #endif 38 39 /* 40 * Prototypes 41 */ 42 static LispObj *LispDivide(LispBuiltin*, int, int); 43 44 /* 45 * Initialization 46 */ 47 static LispObj *obj_zero, *obj_one; 48 LispObj *Ocomplex, *Oequal_; 49 50 LispObj *Oshort_float, *Osingle_float, *Odouble_float, *Olong_float; 51 52 Atom_id Sdefault_float_format; 53 54 /* 55 * Implementation 56 */ 57 #include "lisp/mathimp.c" 58 59 void 60 LispMathInit(void) 61 { 62 LispObj *object, *result; 63 64 mp_set_malloc(LispMalloc); 65 mp_set_calloc(LispCalloc); 66 mp_set_realloc(LispRealloc); 67 mp_set_free(LispFree); 68 69 number_init(); 70 obj_zero = FIXNUM(0); 71 obj_one = FIXNUM(1); 72 73 Oequal_ = STATIC_ATOM("="); 74 Ocomplex = STATIC_ATOM(Scomplex->value); 75 Oshort_float = STATIC_ATOM("SHORT-FLOAT"); 76 LispExportSymbol(Oshort_float); 77 Osingle_float = STATIC_ATOM("SINGLE-FLOAT"); 78 LispExportSymbol(Osingle_float); 79 Odouble_float = STATIC_ATOM("DOUBLE-FLOAT"); 80 LispExportSymbol(Odouble_float); 81 Olong_float = STATIC_ATOM("LONG-FLOAT"); 82 LispExportSymbol(Olong_float); 83 84 object = STATIC_ATOM("*DEFAULT-FLOAT-FORMAT*"); 85 LispProclaimSpecial(object, Odouble_float, NIL); 86 LispExportSymbol(object); 87 Sdefault_float_format = ATOMID(object); 88 89 object = STATIC_ATOM("PI"); 90 result = number_pi(); 91 LispProclaimSpecial(object, result, NIL); 92 LispExportSymbol(object); 93 94 object = STATIC_ATOM("MOST-POSITIVE-FIXNUM"); 95 LispDefconstant(object, FIXNUM(MOST_POSITIVE_FIXNUM), NIL); 96 LispExportSymbol(object); 97 98 object = STATIC_ATOM("MOST-NEGATIVE-FIXNUM"); 99 LispDefconstant(object, FIXNUM(MOST_NEGATIVE_FIXNUM), NIL); 100 LispExportSymbol(object); 101 } 102 103 LispObj * 104 Lisp_Mul(LispBuiltin *builtin) 105 /* 106 * &rest numbers 107 */ 108 { 109 n_number num; 110 LispObj *number, *numbers; 111 112 numbers = ARGUMENT(0); 113 114 if (CONSP(numbers)) { 115 number = CAR(numbers); 116 117 numbers = CDR(numbers); 118 if (!CONSP(numbers)) { 119 CHECK_NUMBER(number); 120 return (number); 121 } 122 } 123 else 124 return (FIXNUM(1)); 125 126 set_number_object(&num, number); 127 do { 128 mul_number_object(&num, CAR(numbers)); 129 numbers = CDR(numbers); 130 } while (CONSP(numbers)); 131 132 return (make_number_object(&num)); 133 } 134 135 LispObj * 136 Lisp_Plus(LispBuiltin *builtin) 137 /* 138 + &rest numbers 139 */ 140 { 141 n_number num; 142 LispObj *number, *numbers; 143 144 numbers = ARGUMENT(0); 145 146 if (CONSP(numbers)) { 147 number = CAR(numbers); 148 149 numbers = CDR(numbers); 150 if (!CONSP(numbers)) { 151 CHECK_NUMBER(number); 152 return (number); 153 } 154 } 155 else 156 return (FIXNUM(0)); 157 158 set_number_object(&num, number); 159 do { 160 add_number_object(&num, CAR(numbers)); 161 numbers = CDR(numbers); 162 } while (CONSP(numbers)); 163 164 return (make_number_object(&num)); 165 } 166 167 LispObj * 168 Lisp_Minus(LispBuiltin *builtin) 169 /* 170 - number &rest more_numbers 171 */ 172 { 173 n_number num; 174 LispObj *number, *more_numbers; 175 176 more_numbers = ARGUMENT(1); 177 number = ARGUMENT(0); 178 179 set_number_object(&num, number); 180 if (!CONSP(more_numbers)) { 181 neg_number(&num); 182 183 return (make_number_object(&num)); 184 } 185 do { 186 sub_number_object(&num, CAR(more_numbers)); 187 more_numbers = CDR(more_numbers); 188 } while (CONSP(more_numbers)); 189 190 return (make_number_object(&num)); 191 } 192 193 LispObj * 194 Lisp_Div(LispBuiltin *builtin) 195 /* 196 / number &rest more_numbers 197 */ 198 { 199 n_number num; 200 LispObj *number, *more_numbers; 201 202 more_numbers = ARGUMENT(1); 203 number = ARGUMENT(0); 204 205 if (CONSP(more_numbers)) 206 set_number_object(&num, number); 207 else { 208 num.complex = 0; 209 num.real.type = N_FIXNUM; 210 num.real.data.fixnum = 1; 211 goto div_one_argument; 212 } 213 214 for (;;) { 215 number = CAR(more_numbers); 216 more_numbers = CDR(more_numbers); 217 218 div_one_argument: 219 div_number_object(&num, number); 220 if (!CONSP(more_numbers)) 221 break; 222 } 223 224 return (make_number_object(&num)); 225 } 226 227 LispObj * 228 Lisp_OnePlus(LispBuiltin *builtin) 229 /* 230 1+ number 231 */ 232 { 233 n_number num; 234 LispObj *number; 235 236 number = ARGUMENT(0); 237 num.complex = 0; 238 num.real.type = N_FIXNUM; 239 num.real.data.fixnum = 1; 240 add_number_object(&num, number); 241 242 return (make_number_object(&num)); 243 } 244 245 LispObj * 246 Lisp_OneMinus(LispBuiltin *builtin) 247 /* 248 1- number 249 */ 250 { 251 n_number num; 252 LispObj *number; 253 254 number = ARGUMENT(0); 255 num.complex = 0; 256 num.real.type = N_FIXNUM; 257 num.real.data.fixnum = -1; 258 add_number_object(&num, number); 259 260 return (make_number_object(&num)); 261 } 262 263 LispObj * 264 Lisp_Less(LispBuiltin *builtin) 265 /* 266 < number &rest more-numbers 267 */ 268 { 269 LispObj *compare, *number, *more_numbers; 270 271 more_numbers = ARGUMENT(1); 272 compare = ARGUMENT(0); 273 274 if (CONSP(more_numbers)) { 275 do { 276 number = CAR(more_numbers); 277 if (cmp_object_object(compare, number, 1) >= 0) 278 return (NIL); 279 compare = number; 280 more_numbers = CDR(more_numbers); 281 } while (CONSP(more_numbers)); 282 } 283 else { 284 CHECK_REAL(compare); 285 } 286 287 return (T); 288 } 289 290 LispObj * 291 Lisp_LessEqual(LispBuiltin *builtin) 292 /* 293 <= number &rest more-numbers 294 */ 295 { 296 LispObj *compare, *number, *more_numbers; 297 298 more_numbers = ARGUMENT(1); 299 compare = ARGUMENT(0); 300 301 if (CONSP(more_numbers)) { 302 do { 303 number = CAR(more_numbers); 304 if (cmp_object_object(compare, number, 1) > 0) 305 return (NIL); 306 compare = number; 307 more_numbers = CDR(more_numbers); 308 } while (CONSP(more_numbers)); 309 } 310 else { 311 CHECK_REAL(compare); 312 } 313 314 return (T); 315 } 316 317 LispObj * 318 Lisp_Equal_(LispBuiltin *builtin) 319 /* 320 = number &rest more-numbers 321 */ 322 { 323 LispObj *compare, *number, *more_numbers; 324 325 more_numbers = ARGUMENT(1); 326 compare = ARGUMENT(0); 327 328 if (CONSP(more_numbers)) { 329 do { 330 number = CAR(more_numbers); 331 if (cmp_object_object(compare, number, 0) != 0) 332 return (NIL); 333 compare = number; 334 more_numbers = CDR(more_numbers); 335 } while (CONSP(more_numbers)); 336 } 337 else { 338 CHECK_REAL(compare); 339 } 340 341 return (T); 342 } 343 344 LispObj * 345 Lisp_Greater(LispBuiltin *builtin) 346 /* 347 > number &rest more-numbers 348 */ 349 { 350 LispObj *compare, *number, *more_numbers; 351 352 more_numbers = ARGUMENT(1); 353 compare = ARGUMENT(0); 354 355 if (CONSP(more_numbers)) { 356 do { 357 number = CAR(more_numbers); 358 if (cmp_object_object(compare, number, 1) <= 0) 359 return (NIL); 360 compare = number; 361 more_numbers = CDR(more_numbers); 362 } while (CONSP(more_numbers)); 363 } 364 else { 365 CHECK_REAL(compare); 366 } 367 368 return (T); 369 } 370 371 LispObj * 372 Lisp_GreaterEqual(LispBuiltin *builtin) 373 /* 374 >= number &rest more-numbers 375 */ 376 { 377 LispObj *compare, *number, *more_numbers; 378 379 more_numbers = ARGUMENT(1); 380 compare = ARGUMENT(0); 381 382 if (CONSP(more_numbers)) { 383 do { 384 number = CAR(more_numbers); 385 if (cmp_object_object(compare, number, 1) < 0) 386 return (NIL); 387 compare = number; 388 more_numbers = CDR(more_numbers); 389 } while (CONSP(more_numbers)); 390 } 391 else { 392 CHECK_REAL(compare); 393 } 394 395 return (T); 396 } 397 398 LispObj * 399 Lisp_NotEqual(LispBuiltin *builtin) 400 /* 401 /= number &rest more-numbers 402 */ 403 { 404 LispObj *object, *compare, *number, *more_numbers; 405 406 more_numbers = ARGUMENT(1); 407 number = ARGUMENT(0); 408 409 if (!CONSP(more_numbers)) { 410 CHECK_REAL(number); 411 412 return (T); 413 } 414 415 /* compare all numbers */ 416 while (1) { 417 compare = number; 418 for (object = more_numbers; CONSP(object); object = CDR(object)) { 419 number = CAR(object); 420 421 if (cmp_object_object(compare, number, 0) == 0) 422 return (NIL); 423 } 424 if (CONSP(more_numbers)) { 425 number = CAR(more_numbers); 426 more_numbers = CDR(more_numbers); 427 } 428 else 429 break; 430 } 431 432 return (T); 433 } 434 435 LispObj * 436 Lisp_Min(LispBuiltin *builtin) 437 /* 438 min number &rest more-numbers 439 */ 440 { 441 LispObj *result, *number, *more_numbers; 442 443 more_numbers = ARGUMENT(1); 444 result = ARGUMENT(0); 445 446 if (CONSP(more_numbers)) { 447 do { 448 number = CAR(more_numbers); 449 if (cmp_object_object(result, number, 1) > 0) 450 result = number; 451 more_numbers = CDR(more_numbers); 452 } while (CONSP(more_numbers)); 453 } 454 else { 455 CHECK_REAL(result); 456 } 457 458 return (result); 459 } 460 461 LispObj * 462 Lisp_Max(LispBuiltin *builtin) 463 /* 464 max number &rest more-numbers 465 */ 466 { 467 LispObj *result, *number, *more_numbers; 468 469 more_numbers = ARGUMENT(1); 470 result = ARGUMENT(0); 471 472 if (CONSP(more_numbers)) { 473 do { 474 number = CAR(more_numbers); 475 if (cmp_object_object(result, number, 1) < 0) 476 result = number; 477 more_numbers = CDR(more_numbers); 478 } while (CONSP(more_numbers)); 479 } 480 else { 481 CHECK_REAL(result); 482 } 483 484 return (result); 485 } 486 487 LispObj * 488 Lisp_Abs(LispBuiltin *builtin) 489 /* 490 abs number 491 */ 492 { 493 LispObj *result, *number; 494 495 result = number = ARGUMENT(0); 496 497 switch (OBJECT_TYPE(number)) { 498 case LispFixnum_t: 499 case LispInteger_t: 500 case LispBignum_t: 501 case LispDFloat_t: 502 case LispRatio_t: 503 case LispBigratio_t: 504 if (cmp_real_object(&zero, number) > 0) { 505 n_real real; 506 507 set_real_object(&real, number); 508 neg_real(&real); 509 result = make_real_object(&real); 510 } 511 break; 512 case LispComplex_t: { 513 n_number num; 514 515 set_number_object(&num, number); 516 abs_number(&num); 517 result = make_number_object(&num); 518 } break; 519 default: 520 fatal_builtin_object_error(builtin, number, NOT_A_NUMBER); 521 break; 522 } 523 524 return (result); 525 } 526 527 LispObj * 528 Lisp_Complex(LispBuiltin *builtin) 529 /* 530 complex realpart &optional imagpart 531 */ 532 { 533 LispObj *realpart, *imagpart; 534 535 imagpart = ARGUMENT(1); 536 realpart = ARGUMENT(0); 537 538 CHECK_REAL(realpart); 539 540 if (imagpart == UNSPEC) 541 return (realpart); 542 else { 543 CHECK_REAL(imagpart); 544 } 545 if (!FLOATP(imagpart) && cmp_real_object(&zero, imagpart) == 0) 546 return (realpart); 547 548 return (COMPLEX(realpart, imagpart)); 549 } 550 551 LispObj * 552 Lisp_Complexp(LispBuiltin *builtin) 553 /* 554 complexp object 555 */ 556 { 557 LispObj *object; 558 559 object = ARGUMENT(0); 560 561 return (COMPLEXP(object) ? T : NIL); 562 } 563 564 LispObj * 565 Lisp_Conjugate(LispBuiltin *builtin) 566 /* 567 conjugate number 568 */ 569 { 570 n_number num; 571 LispObj *number, *realpart, *imagpart; 572 573 number = ARGUMENT(0); 574 575 CHECK_NUMBER(number); 576 577 if (REALP(number)) 578 return (number); 579 580 realpart = OCXR(number); 581 num.complex = 0; 582 num.real.type = N_FIXNUM; 583 num.real.data.fixnum = -1; 584 mul_number_object(&num, OCXI(number)); 585 imagpart = make_number_object(&num); 586 587 return (COMPLEX(realpart, imagpart)); 588 } 589 590 LispObj * 591 Lisp_Decf(LispBuiltin *builtin) 592 /* 593 decf place &optional delta 594 */ 595 { 596 n_number num; 597 LispObj *place, *delta, *number; 598 599 delta = ARGUMENT(1); 600 place = ARGUMENT(0); 601 602 if (SYMBOLP(place)) { 603 number = LispGetVar(place); 604 if (number == NULL) 605 LispDestroy("EVAL: the variable %s is unbound", STROBJ(place)); 606 } 607 else 608 number = EVAL(place); 609 610 if (delta != UNSPEC) { 611 LispObj *operand; 612 613 operand = EVAL(delta); 614 set_number_object(&num, number); 615 sub_number_object(&num, operand); 616 number = make_number_object(&num); 617 } 618 else { 619 num.complex = 0; 620 num.real.type = N_FIXNUM; 621 num.real.data.fixnum = -1; 622 add_number_object(&num, number); 623 number = make_number_object(&num); 624 } 625 626 if (SYMBOLP(place)) { 627 CHECK_CONSTANT(place); 628 LispSetVar(place, number); 629 } 630 else { 631 GC_ENTER(); 632 633 GC_PROTECT(number); 634 (void)APPLY2(Osetf, place, number); 635 GC_LEAVE(); 636 } 637 638 return (number); 639 } 640 641 LispObj * 642 Lisp_Denominator(LispBuiltin *builtin) 643 /* 644 denominator rational 645 */ 646 { 647 LispObj *result, *rational; 648 649 rational = ARGUMENT(0); 650 651 switch (OBJECT_TYPE(rational)) { 652 case LispFixnum_t: 653 case LispInteger_t: 654 case LispBignum_t: 655 result = FIXNUM(1); 656 break; 657 case LispRatio_t: 658 result = INTEGER(OFRD(rational)); 659 break; 660 case LispBigratio_t: 661 if (mpi_fiti(OBRD(rational))) 662 result = INTEGER(mpi_geti(OBRD(rational))); 663 else { 664 mpi *den = XALLOC(mpi); 665 666 mpi_init(den); 667 mpi_set(den, OBRD(rational)); 668 result = BIGNUM(den); 669 } 670 break; 671 default: 672 LispDestroy("%s: %s is not a rational number", 673 STRFUN(builtin), STROBJ(rational)); 674 /*NOTREACHED*/ 675 result = NIL; 676 } 677 678 return (result); 679 } 680 681 LispObj * 682 Lisp_Evenp(LispBuiltin *builtin) 683 /* 684 evenp integer 685 */ 686 { 687 LispObj *result, *integer; 688 689 integer = ARGUMENT(0); 690 691 switch (OBJECT_TYPE(integer)) { 692 case LispFixnum_t: 693 result = FIXNUM_VALUE(integer) % 2 ? NIL : T; 694 break; 695 case LispInteger_t: 696 result = INT_VALUE(integer) % 2 ? NIL : T; 697 break; 698 case LispBignum_t: 699 result = mpi_remi(OBI(integer), 2) ? NIL : T; 700 break; 701 default: 702 fatal_builtin_object_error(builtin, integer, NOT_AN_INTEGER); 703 /*NOTREACHED*/ 704 result = NIL; 705 } 706 707 return (result); 708 } 709 710 /* only one float format */ 711 LispObj * 712 Lisp_Float(LispBuiltin *builtin) 713 /* 714 float number &optional other 715 */ 716 { 717 LispObj *number, *other; 718 719 other = ARGUMENT(1); 720 number = ARGUMENT(0); 721 722 if (other != UNSPEC) { 723 CHECK_DFLOAT(other); 724 } 725 726 return (LispFloatCoerce(builtin, number)); 727 } 728 729 LispObj * 730 LispFloatCoerce(LispBuiltin *builtin, LispObj *number) 731 { 732 double value; 733 734 switch (OBJECT_TYPE(number)) { 735 case LispFixnum_t: 736 value = FIXNUM_VALUE(number); 737 break; 738 case LispInteger_t: 739 value = INT_VALUE(number); 740 break; 741 case LispBignum_t: 742 value = mpi_getd(OBI(number)); 743 break; 744 case LispDFloat_t: 745 return (number); 746 case LispRatio_t: 747 value = (double)OFRN(number) / (double)OFRD(number); 748 break; 749 case LispBigratio_t: 750 value = mpr_getd(OBR(number)); 751 break; 752 default: 753 value = 0.0; 754 fatal_builtin_object_error(builtin, number, NOT_A_REAL_NUMBER); 755 break; 756 } 757 758 if (!finite(value)) 759 fatal_error(FLOATING_POINT_OVERFLOW); 760 761 return (DFLOAT(value)); 762 } 763 764 LispObj * 765 Lisp_Floatp(LispBuiltin *builtin) 766 /* 767 floatp object 768 */ 769 { 770 LispObj *object; 771 772 object = ARGUMENT(0); 773 774 return (FLOATP(object) ? T : NIL); 775 } 776 777 LispObj * 778 Lisp_Gcd(LispBuiltin *builtin) 779 /* 780 gcd &rest integers 781 */ 782 { 783 n_real real; 784 LispObj *integers, *integer, *operand; 785 786 integers = ARGUMENT(0); 787 788 if (!CONSP(integers)) 789 return (FIXNUM(0)); 790 791 integer = CAR(integers); 792 793 CHECK_INTEGER(integer); 794 set_real_object(&real, integer); 795 integers = CDR(integers); 796 797 for (; CONSP(integers); integers = CDR(integers)) { 798 operand = CAR(integers); 799 gcd_real_object(&real, operand); 800 } 801 abs_real(&real); 802 803 return (make_real_object(&real)); 804 } 805 806 LispObj * 807 Lisp_Imagpart(LispBuiltin *builtin) 808 /* 809 imagpart number 810 */ 811 { 812 LispObj *number; 813 814 number = ARGUMENT(0); 815 816 if (COMPLEXP(number)) 817 return (OCXI(number)); 818 else { 819 CHECK_REAL(number); 820 } 821 822 return (FIXNUM(0)); 823 } 824 825 LispObj * 826 Lisp_Incf(LispBuiltin *builtin) 827 /* 828 incf place &optional delta 829 */ 830 { 831 n_number num; 832 LispObj *place, *delta, *number; 833 834 delta = ARGUMENT(1); 835 place = ARGUMENT(0); 836 837 if (SYMBOLP(place)) { 838 number = LispGetVar(place); 839 if (number == NULL) 840 LispDestroy("EVAL: the variable %s is unbound", STROBJ(place)); 841 } 842 else 843 number = EVAL(place); 844 845 if (delta != UNSPEC) { 846 LispObj *operand; 847 848 operand = EVAL(delta); 849 set_number_object(&num, number); 850 add_number_object(&num, operand); 851 number = make_number_object(&num); 852 } 853 else { 854 num.complex = 0; 855 num.real.type = N_FIXNUM; 856 num.real.data.fixnum = 1; 857 add_number_object(&num, number); 858 number = make_number_object(&num); 859 } 860 861 if (SYMBOLP(place)) { 862 CHECK_CONSTANT(place); 863 LispSetVar(place, number); 864 } 865 else { 866 GC_ENTER(); 867 868 GC_PROTECT(number); 869 (void)APPLY2(Osetf, place, number); 870 GC_LEAVE(); 871 } 872 873 return (number); 874 } 875 876 LispObj * 877 Lisp_Integerp(LispBuiltin *builtin) 878 /* 879 integerp object 880 */ 881 { 882 LispObj *object; 883 884 object = ARGUMENT(0); 885 886 return (INTEGERP(object) ? T : NIL); 887 } 888 889 LispObj * 890 Lisp_Isqrt(LispBuiltin *builtin) 891 /* 892 isqrt natural 893 */ 894 { 895 LispObj *natural, *result; 896 897 natural = ARGUMENT(0); 898 899 if (cmp_object_object(natural, obj_zero, 1) < 0) 900 goto not_a_natural_number; 901 902 switch (OBJECT_TYPE(natural)) { 903 case LispFixnum_t: 904 result = FIXNUM((long)floor(sqrt(FIXNUM_VALUE(natural)))); 905 break; 906 case LispInteger_t: 907 result = INTEGER((long)floor(sqrt(INT_VALUE(natural)))); 908 break; 909 case LispBignum_t: { 910 mpi *bigi; 911 912 bigi = XALLOC(mpi); 913 mpi_init(bigi); 914 mpi_sqrt(bigi, OBI(natural)); 915 if (mpi_fiti(bigi)) { 916 result = INTEGER(mpi_geti(bigi)); 917 mpi_clear(bigi); 918 XFREE(bigi); 919 } 920 else 921 result = BIGNUM(bigi); 922 } break; 923 default: 924 goto not_a_natural_number; 925 } 926 927 return (result); 928 929 not_a_natural_number: 930 LispDestroy("%s: %s is not a natural number", 931 STRFUN(builtin), STROBJ(natural)); 932 /*NOTREACHED*/ 933 return (NIL); 934 } 935 936 LispObj * 937 Lisp_Lcm(LispBuiltin *builtin) 938 /* 939 lcm &rest integers 940 */ 941 { 942 n_real real, gcd; 943 LispObj *integers, *operand; 944 945 integers = ARGUMENT(0); 946 947 if (!CONSP(integers)) 948 return (FIXNUM(1)); 949 950 operand = CAR(integers); 951 952 CHECK_INTEGER(operand); 953 set_real_object(&real, operand); 954 integers = CDR(integers); 955 956 gcd.type = N_FIXNUM; 957 gcd.data.fixnum = 0; 958 959 for (; CONSP(integers); integers = CDR(integers)) { 960 operand = CAR(integers); 961 962 if (real.type == N_FIXNUM && real.data.fixnum == 0) 963 break; 964 965 /* calculate gcd before changing integer */ 966 clear_real(&gcd); 967 set_real_real(&gcd, &real); 968 gcd_real_object(&gcd, operand); 969 970 /* calculate lcm */ 971 mul_real_object(&real, operand); 972 div_real_real(&real, &gcd); 973 } 974 clear_real(&gcd); 975 abs_real(&real); 976 977 return (make_real_object(&real)); 978 } 979 980 LispObj * 981 Lisp_Logand(LispBuiltin *builtin) 982 /* 983 logand &rest integers 984 */ 985 { 986 n_real real; 987 988 LispObj *integers; 989 990 integers = ARGUMENT(0); 991 992 real.type = N_FIXNUM; 993 real.data.fixnum = -1; 994 995 for (; CONSP(integers); integers = CDR(integers)) 996 and_real_object(&real, CAR(integers)); 997 998 return (make_real_object(&real)); 999 } 1000 1001 LispObj * 1002 Lisp_Logeqv(LispBuiltin *builtin) 1003 /* 1004 logeqv &rest integers 1005 */ 1006 { 1007 n_real real; 1008 1009 LispObj *integers; 1010 1011 integers = ARGUMENT(0); 1012 1013 real.type = N_FIXNUM; 1014 real.data.fixnum = -1; 1015 1016 for (; CONSP(integers); integers = CDR(integers)) 1017 eqv_real_object(&real, CAR(integers)); 1018 1019 return (make_real_object(&real)); 1020 } 1021 1022 LispObj * 1023 Lisp_Logior(LispBuiltin *builtin) 1024 /* 1025 logior &rest integers 1026 */ 1027 { 1028 n_real real; 1029 1030 LispObj *integers; 1031 1032 integers = ARGUMENT(0); 1033 1034 real.type = N_FIXNUM; 1035 real.data.fixnum = 0; 1036 1037 for (; CONSP(integers); integers = CDR(integers)) 1038 ior_real_object(&real, CAR(integers)); 1039 1040 return (make_real_object(&real)); 1041 } 1042 1043 LispObj * 1044 Lisp_Lognot(LispBuiltin *builtin) 1045 /* 1046 lognot integer 1047 */ 1048 { 1049 n_real real; 1050 1051 LispObj *integer; 1052 1053 integer = ARGUMENT(0); 1054 1055 CHECK_INTEGER(integer); 1056 1057 set_real_object(&real, integer); 1058 not_real(&real); 1059 1060 return (make_real_object(&real)); 1061 } 1062 1063 LispObj * 1064 Lisp_Logxor(LispBuiltin *builtin) 1065 /* 1066 logxor &rest integers 1067 */ 1068 { 1069 n_real real; 1070 1071 LispObj *integers; 1072 1073 integers = ARGUMENT(0); 1074 1075 real.type = N_FIXNUM; 1076 real.data.fixnum = 0; 1077 1078 for (; CONSP(integers); integers = CDR(integers)) 1079 xor_real_object(&real, CAR(integers)); 1080 1081 return (make_real_object(&real)); 1082 } 1083 1084 LispObj * 1085 Lisp_Minusp(LispBuiltin *builtin) 1086 /* 1087 minusp number 1088 */ 1089 { 1090 LispObj *number; 1091 1092 number = ARGUMENT(0); 1093 1094 CHECK_REAL(number); 1095 1096 return (cmp_real_object(&zero, number) > 0 ? T : NIL); 1097 } 1098 1099 LispObj * 1100 Lisp_Mod(LispBuiltin *builtin) 1101 /* 1102 mod number divisor 1103 */ 1104 { 1105 LispObj *result; 1106 1107 LispObj *number, *divisor; 1108 1109 divisor = ARGUMENT(1); 1110 number = ARGUMENT(0); 1111 1112 if (INTEGERP(number) && INTEGERP(divisor)) { 1113 n_real real; 1114 1115 set_real_object(&real, number); 1116 mod_real_object(&real, divisor); 1117 result = make_real_object(&real); 1118 } 1119 else { 1120 n_number num; 1121 1122 set_number_object(&num, number); 1123 divide_number_object(&num, divisor, NDIVIDE_FLOOR, 0); 1124 result = make_real_object(&(num.imag)); 1125 clear_real(&(num.real)); 1126 } 1127 1128 return (result); 1129 } 1130 1131 LispObj * 1132 Lisp_Numberp(LispBuiltin *builtin) 1133 /* 1134 numberp object 1135 */ 1136 { 1137 LispObj *object; 1138 1139 object = ARGUMENT(0); 1140 1141 return (NUMBERP(object) ? T : NIL); 1142 } 1143 1144 LispObj * 1145 Lisp_Numerator(LispBuiltin *builtin) 1146 /* 1147 numerator rational 1148 */ 1149 { 1150 LispObj *result, *rational; 1151 1152 rational = ARGUMENT(0); 1153 1154 switch (OBJECT_TYPE(rational)) { 1155 case LispFixnum_t: 1156 case LispInteger_t: 1157 case LispBignum_t: 1158 result = rational; 1159 break; 1160 case LispRatio_t: 1161 result = INTEGER(OFRN(rational)); 1162 break; 1163 case LispBigratio_t: 1164 if (mpi_fiti(OBRN(rational))) 1165 result = INTEGER(mpi_geti(OBRN(rational))); 1166 else { 1167 mpi *num = XALLOC(mpi); 1168 1169 mpi_init(num); 1170 mpi_set(num, OBRN(rational)); 1171 result = BIGNUM(num); 1172 } 1173 break; 1174 default: 1175 LispDestroy("%s: %s is not a rational number", 1176 STRFUN(builtin), STROBJ(rational)); 1177 /*NOTREACHED*/ 1178 result = NIL; 1179 } 1180 1181 return (result); 1182 } 1183 1184 LispObj * 1185 Lisp_Oddp(LispBuiltin *builtin) 1186 /* 1187 oddp integer 1188 */ 1189 { 1190 LispObj *result, *integer; 1191 1192 integer = ARGUMENT(0); 1193 1194 switch (OBJECT_TYPE(integer)) { 1195 case LispFixnum_t: 1196 result = FIXNUM_VALUE(integer) % 2 ? T : NIL; 1197 break; 1198 case LispInteger_t: 1199 result = INT_VALUE(integer) % 2 ? T : NIL; 1200 break; 1201 case LispBignum_t: 1202 result = mpi_remi(OBI(integer), 2) ? T : NIL; 1203 break; 1204 default: 1205 fatal_builtin_object_error(builtin, integer, NOT_AN_INTEGER); 1206 /*NOTREACHED*/ 1207 result = NIL; 1208 } 1209 1210 return (result); 1211 } 1212 1213 LispObj * 1214 Lisp_Plusp(LispBuiltin *builtin) 1215 /* 1216 plusp number 1217 */ 1218 { 1219 LispObj *number; 1220 1221 number = ARGUMENT(0); 1222 1223 CHECK_REAL(number); 1224 1225 return (cmp_real_object(&zero, number) < 0 ? T : NIL); 1226 } 1227 1228 LispObj * 1229 Lisp_Rational(LispBuiltin *builtin) 1230 /* 1231 rational number 1232 */ 1233 { 1234 LispObj *number; 1235 1236 number = ARGUMENT(0); 1237 1238 if (DFLOATP(number)) { 1239 double numerator = ODF(number); 1240 1241 if ((long)numerator == numerator) 1242 number = INTEGER(numerator); 1243 else { 1244 n_real real; 1245 mpr *bigr = XALLOC(mpr); 1246 1247 mpr_init(bigr); 1248 mpr_setd(bigr, numerator); 1249 real.type = N_BIGRATIO; 1250 real.data.bigratio = bigr; 1251 rbr_canonicalize(&real); 1252 number = make_real_object(&real); 1253 } 1254 } 1255 else { 1256 CHECK_REAL(number); 1257 } 1258 1259 return (number); 1260 } 1261 1262 LispObj * 1263 Lisp_Rationalp(LispBuiltin *builtin) 1264 /* 1265 rationalp object 1266 */ 1267 { 1268 LispObj *object; 1269 1270 object = ARGUMENT(0); 1271 1272 return (RATIONALP(object) ? T : NIL); 1273 } 1274 1275 LispObj * 1276 Lisp_Realpart(LispBuiltin *builtin) 1277 /* 1278 realpart number 1279 */ 1280 { 1281 LispObj *number; 1282 1283 number = ARGUMENT(0); 1284 1285 if (COMPLEXP(number)) 1286 return (OCXR(number)); 1287 else { 1288 CHECK_REAL(number); 1289 } 1290 1291 return (number); 1292 } 1293 1294 LispObj * 1295 Lisp_Rem(LispBuiltin *builtin) 1296 /* 1297 rem number divisor 1298 */ 1299 { 1300 LispObj *result; 1301 1302 LispObj *number, *divisor; 1303 1304 divisor = ARGUMENT(1); 1305 number = ARGUMENT(0); 1306 1307 if (INTEGERP(number) && INTEGERP(divisor)) { 1308 n_real real; 1309 1310 set_real_object(&real, number); 1311 rem_real_object(&real, divisor); 1312 result = make_real_object(&real); 1313 } 1314 else { 1315 n_number num; 1316 1317 set_number_object(&num, number); 1318 divide_number_object(&num, divisor, NDIVIDE_TRUNC, 0); 1319 result = make_real_object(&(num.imag)); 1320 clear_real(&(num.real)); 1321 } 1322 1323 return (result); 1324 } 1325 1326 LispObj * 1327 Lisp_Sqrt(LispBuiltin *builtin) 1328 /* 1329 sqrt number 1330 */ 1331 { 1332 n_number num; 1333 LispObj *number; 1334 1335 number = ARGUMENT(0); 1336 1337 set_number_object(&num, number); 1338 sqrt_number(&num); 1339 1340 return (make_number_object(&num)); 1341 } 1342 1343 LispObj * 1344 Lisp_Zerop(LispBuiltin *builtin) 1345 /* 1346 zerop number 1347 */ 1348 { 1349 LispObj *result, *number; 1350 1351 number = ARGUMENT(0); 1352 1353 switch (OBJECT_TYPE(number)) { 1354 case LispFixnum_t: 1355 case LispInteger_t: 1356 case LispBignum_t: 1357 case LispDFloat_t: 1358 case LispRatio_t: 1359 case LispBigratio_t: 1360 result = cmp_real_object(&zero, number) == 0 ? T : NIL; 1361 break; 1362 case LispComplex_t: 1363 result = cmp_real_object(&zero, OCXR(number)) == 0 && 1364 cmp_real_object(&zero, OCXI(number)) == 0 ? T : NIL; 1365 break; 1366 default: 1367 fatal_builtin_object_error(builtin, number, NOT_A_NUMBER); 1368 /*NOTREACHED*/ 1369 result = NIL; 1370 } 1371 1372 return (result); 1373 } 1374 1375 static LispObj * 1376 LispDivide(LispBuiltin *builtin, int fun, int flo) 1377 { 1378 n_number num; 1379 LispObj *number, *divisor; 1380 1381 divisor = ARGUMENT(1); 1382 number = ARGUMENT(0); 1383 1384 RETURN_COUNT = 1; 1385 1386 if (cmp_real_object(&zero, number) == 0) { 1387 if (divisor != NIL) { 1388 CHECK_REAL(divisor); 1389 } 1390 1391 return (RETURN(0) = obj_zero); 1392 } 1393 1394 if (divisor == UNSPEC) 1395 divisor = obj_one; 1396 1397 set_number_object(&num, number); 1398 if (num.complex) 1399 fatal_builtin_object_error(builtin, divisor, NOT_A_REAL_NUMBER); 1400 1401 divide_number_object(&num, divisor, fun, flo); 1402 RETURN(0) = make_real_object(&(num.imag)); 1403 1404 return (make_real_object(&(num.real))); 1405 } 1406 1407 LispObj * 1408 Lisp_Ceiling(LispBuiltin *builtin) 1409 /* 1410 ceiling number &optional divisor 1411 */ 1412 { 1413 return (LispDivide(builtin, NDIVIDE_CEIL, 0)); 1414 } 1415 1416 LispObj * 1417 Lisp_Fceiling(LispBuiltin *builtin) 1418 /* 1419 fceiling number &optional divisor 1420 */ 1421 { 1422 return (LispDivide(builtin, NDIVIDE_CEIL, 1)); 1423 } 1424 1425 LispObj * 1426 Lisp_Floor(LispBuiltin *builtin) 1427 /* 1428 floor number &optional divisor 1429 */ 1430 { 1431 return (LispDivide(builtin, NDIVIDE_FLOOR, 0)); 1432 } 1433 1434 LispObj * 1435 Lisp_Ffloor(LispBuiltin *builtin) 1436 /* 1437 ffloor number &optional divisor 1438 */ 1439 { 1440 return (LispDivide(builtin, NDIVIDE_FLOOR, 1)); 1441 } 1442 1443 LispObj * 1444 Lisp_Round(LispBuiltin *builtin) 1445 /* 1446 round number &optional divisor 1447 */ 1448 { 1449 return (LispDivide(builtin, NDIVIDE_ROUND, 0)); 1450 } 1451 1452 LispObj * 1453 Lisp_Fround(LispBuiltin *builtin) 1454 /* 1455 fround number &optional divisor 1456 */ 1457 { 1458 return (LispDivide(builtin, NDIVIDE_ROUND, 1)); 1459 } 1460 1461 LispObj * 1462 Lisp_Truncate(LispBuiltin *builtin) 1463 /* 1464 truncate number &optional divisor 1465 */ 1466 { 1467 return (LispDivide(builtin, NDIVIDE_TRUNC, 0)); 1468 } 1469 1470 LispObj * 1471 Lisp_Ftruncate(LispBuiltin *builtin) 1472 /* 1473 ftruncate number &optional divisor 1474 */ 1475 { 1476 return (LispDivide(builtin, NDIVIDE_TRUNC, 1)); 1477 } 1478
Indexes created Wed Jul 01 00:25:26 UTC 2026