Mercurial > hg > xemacs-beta

comparison src/floatfns.c @ 1983:9c872f33ecbe

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2004-04-05 22:49:31 by james] Add bignum, ratio, and bigfloat support.
author james
date Mon, 05 Apr 2004 22:50:11 +0000
parents e22b0213b713
children 4e6a63799f08
comparison
equal deleted inserted replaced
1982:a748951fd4fb 1983:9c872f33ecbe
117 #define domain_error2(op,a1,a2) \ 117 #define domain_error2(op,a1,a2) \
118 Fsignal (Qdomain_error, list3 (build_msg_string (op), a1, a2)) 118 Fsignal (Qdomain_error, list3 (build_msg_string (op), a1, a2))
119 119
120 120
121 /* Convert float to Lisp Integer if it fits, else signal a range 121 /* Convert float to Lisp Integer if it fits, else signal a range
122 error using the given arguments. */ 122 error using the given arguments. If bignums are available, range errors
123 are never signaled. */
123 static Lisp_Object 124 static Lisp_Object
124 float_to_int (double x, const char *name, Lisp_Object num, Lisp_Object num2) 125 float_to_int (double x, const char *name, Lisp_Object num, Lisp_Object num2)
125 { 126 {
127 #ifdef HAVE_BIGNUM
128 bignum_set_double (scratch_bignum, x);
129 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
130 #else
126 if (x >= ((EMACS_INT) 1 << (VALBITS-1)) 131 if (x >= ((EMACS_INT) 1 << (VALBITS-1))
127 || x <= - ((EMACS_INT) 1 << (VALBITS-1)) - (EMACS_INT) 1) 132 || x <= - ((EMACS_INT) 1 << (VALBITS-1)) - (EMACS_INT) 1)
128 { 133 {
129 if (!UNBOUNDP (num2)) 134 if (!UNBOUNDP (num2))
130 range_error2 (name, num, num2); 135 range_error2 (name, num, num2);
131 else 136 else
132 range_error (name, num); 137 range_error (name, num);
133 } 138 }
134 return (make_int ((EMACS_INT) x)); 139 return (make_int ((EMACS_INT) x));
140 #endif /* HAVE_BIGNUM */
135 } 141 }
136 142
137 143
138 static void 144 static void
139 in_float_error (void) 145 in_float_error (void)
197 return XFLOAT_DATA (num); 203 return XFLOAT_DATA (num);
198 204
199 if (INTP (num)) 205 if (INTP (num))
200 return (double) XINT (num); 206 return (double) XINT (num);
201 207
208 #ifdef HAVE_BIGNUM
209 if (BIGNUMP (num))
210 return bignum_to_double (XBIGNUM_DATA (num));
211 #endif
212
213 #ifdef HAVE_RATIO
214 if (RATIOP (num))
215 return ratio_to_double (XRATIO_DATA (num));
216 #endif
217
218 #ifdef HAVE_BIGFLOAT
219 if (BIGFLOATP (num))
220 return bigfloat_to_double (XBIGFLOAT_DATA (num));
221 #endif
222
202 return extract_float (wrong_type_argument (Qnumberp, num)); 223 return extract_float (wrong_type_argument (Qnumberp, num));
203 } 224 }
204 225
205 /* Trig functions. */ 226 /* Trig functions. */
206 227
419 DEFUN ("expt", Fexpt, 2, 2, 0, /* 440 DEFUN ("expt", Fexpt, 2, 2, 0, /*
420 Return the exponential NUMBER1 ** NUMBER2. 441 Return the exponential NUMBER1 ** NUMBER2.
421 */ 442 */
422 (number1, number2)) 443 (number1, number2))
423 { 444 {
445 #ifdef HAVE_BIGNUM
446 if (INTEGERP (number1) && INTP (number2))
447 {
448 if (INTP (number1))
449 {
450 bignum_set_long (scratch_bignum2, XREALINT (number1));
451 bignum_pow (scratch_bignum, scratch_bignum2, XREALINT (number2));
452 }
453 else
454 bignum_pow (scratch_bignum, XBIGNUM_DATA (number1),
455 XREALINT (number2));
456 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
457 }
458 #endif
459
424 if (INTP (number1) && /* common lisp spec */ 460 if (INTP (number1) && /* common lisp spec */
425 INTP (number2)) /* don't promote, if both are ints */ 461 INTP (number2)) /* don't promote, if both are ints */
426 { 462 {
427 EMACS_INT retval; 463 EMACS_INT retval;
428 EMACS_INT x = XINT (number1); 464 EMACS_INT x = XINT (number1);
449 } 485 }
450 } 486 }
451 return make_int (retval); 487 return make_int (retval);
452 } 488 }
453 489
490 #if defined(HAVE_BIGFLOAT) && defined(bigfloat_pow)
491 if (BIGFLOATP (number1) && INTEGERP (number2))
492 {
493 unsigned long exp;
494
495 #ifdef HAVE_BIGNUM
496 if (BIGNUMP (number2))
497 exp = bignum_to_ulong (XBIGNUM_DATA (number2));
498 else
499 #endif
500 exp = XUINT (number2);
501 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number1));
502 bigfloat_pow (scratch_bigfloat, XBIGFLOAT_DATA (number1), exp);
503 return make_bigfloat_bf (scratch_bigfloat);
504 }
505 #endif
506
454 { 507 {
455 double f1 = extract_float (number1); 508 double f1 = extract_float (number1);
456 double f2 = extract_float (number2); 509 double f2 = extract_float (number2);
457 /* Really should check for overflow, too */ 510 /* Really should check for overflow, too */
458 if (f1 == 0.0 && f2 == 0.0) 511 if (f1 == 0.0 && f2 == 0.0)
514 DEFUN ("sqrt", Fsqrt, 1, 1, 0, /* 567 DEFUN ("sqrt", Fsqrt, 1, 1, 0, /*
515 Return the square root of NUMBER. 568 Return the square root of NUMBER.
516 */ 569 */
517 (number)) 570 (number))
518 { 571 {
519 double d = extract_float (number); 572 double d;
573
574 #if defined(HAVE_BIGFLOAT) && defined(bigfloat_sqrt)
575 if (BIGFLOATP (number))
576 {
577 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
578 bigfloat_sqrt (scratch_bigfloat, XBIGFLOAT_DATA (number));
579 return make_bigfloat_bf (scratch_bigfloat);
580 }
581 #endif /* HAVE_BIGFLOAT */
582 d = extract_float (number);
520 #ifdef FLOAT_CHECK_DOMAIN 583 #ifdef FLOAT_CHECK_DOMAIN
521 if (d < 0.0) 584 if (d < 0.0)
522 domain_error ("sqrt", number); 585 domain_error ("sqrt", number);
523 #endif 586 #endif
524 IN_FLOAT (d = sqrt (d), "sqrt", number); 587 IN_FLOAT (d = sqrt (d), "sqrt", number);
646 "abs", number); 709 "abs", number);
647 return number; 710 return number;
648 } 711 }
649 712
650 if (INTP (number)) 713 if (INTP (number))
714 #ifdef HAVE_BIGNUM
715 /* The most negative Lisp fixnum will overflow */
716 return (XINT (number) >= 0) ? number : make_integer (- XINT (number));
717 #else
651 return (XINT (number) >= 0) ? number : make_int (- XINT (number)); 718 return (XINT (number) >= 0) ? number : make_int (- XINT (number));
719 #endif
720
721 #ifdef HAVE_BIGNUM
722 if (BIGNUMP (number))
723 {
724 if (bignum_sign (XBIGNUM_DATA (number)) >= 0)
725 return number;
726 bignum_abs (scratch_bignum, XBIGNUM_DATA (number));
727 return make_bignum_bg (scratch_bignum);
728 }
729 #endif
730
731 #ifdef HAVE_RATIO
732 if (RATIOP (number))
733 {
734 if (ratio_sign (XRATIO_DATA (number)) >= 0)
735 return number;
736 ratio_abs (scratch_ratio, XRATIO_DATA (number));
737 return make_ratio_rt (scratch_ratio);
738 }
739 #endif
740
741 #ifdef HAVE_BIGFLOAT
742 if (BIGFLOATP (number))
743 {
744 if (bigfloat_sign (XBIGFLOAT_DATA (number)) >= 0)
745 return number;
746 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
747 bigfloat_abs (scratch_bigfloat, XBIGFLOAT_DATA (number));
748 return make_bigfloat_bf (scratch_bigfloat);
749 }
750 #endif
652 751
653 return Fabs (wrong_type_argument (Qnumberp, number)); 752 return Fabs (wrong_type_argument (Qnumberp, number));
654 } 753 }
655 754
656 DEFUN ("float", Ffloat, 1, 1, 0, /* 755 DEFUN ("float", Ffloat, 1, 1, 0, /*
658 */ 757 */
659 (number)) 758 (number))
660 { 759 {
661 if (INTP (number)) 760 if (INTP (number))
662 return make_float ((double) XINT (number)); 761 return make_float ((double) XINT (number));
762
763 #ifdef HAVE_BIGNUM
764 if (BIGFLOATP (number))
765 {
766 #ifdef HAVE_BIGFLOAT
767 if (ZEROP (Vdefault_float_precision))
768 #endif
769 return make_float (bignum_to_double (XBIGNUM_DATA (number)));
770 #ifdef HAVE_BIGFLOAT
771 else
772 {
773 bigfloat_set_prec (scratch_bigfloat, bigfloat_get_default_prec ());
774 bigfloat_set_bignum (scratch_bigfloat, XBIGNUM_DATA (number));
775 return make_bigfloat_bf (scratch_bigfloat);
776 }
777 #endif /* HAVE_BIGFLOAT */
778 }
779 #endif /* HAVE_BIGNUM */
780
781 #ifdef HAVE_RATIO
782 if (RATIOP (number))
783 make_float (ratio_to_double (XRATIO_DATA (number)));
784 #endif
663 785
664 if (FLOATP (number)) /* give 'em the same float back */ 786 if (FLOATP (number)) /* give 'em the same float back */
665 return number; 787 return number;
666 788
667 return Ffloat (wrong_type_argument (Qnumberp, number)); 789 return Ffloat (wrong_type_argument (Qnumberp, number));
728 double d; 850 double d;
729 IN_FLOAT ((d = ceil (XFLOAT_DATA (number))), "ceiling", number); 851 IN_FLOAT ((d = ceil (XFLOAT_DATA (number))), "ceiling", number);
730 return (float_to_int (d, "ceiling", number, Qunbound)); 852 return (float_to_int (d, "ceiling", number, Qunbound));
731 } 853 }
732 854
855 #ifdef HAVE_BIGNUM
856 if (INTEGERP (number))
857 #else
733 if (INTP (number)) 858 if (INTP (number))
859 #endif
734 return number; 860 return number;
861
862 #ifdef HAVE_RATIO
863 if (RATIOP (number))
864 {
865 bignum_ceil (scratch_bignum, XRATIO_NUMERATOR (number),
866 XRATIO_DENOMINATOR (number));
867 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
868 }
869 #endif
870
871 #ifdef HAVE_BIGFLOAT
872 if (BIGFLOATP (number))
873 {
874 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
875 bigfloat_ceil (scratch_bigfloat, XBIGFLOAT_DATA (number));
876 #ifdef HAVE_BIGNUM
877 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
878 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
879 #else
880 return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
881 #endif /* HAVE_BIGNUM */
882 }
883 #endif /* HAVE_BIGFLOAT */
735 884
736 return Fceiling (wrong_type_argument (Qnumberp, number)); 885 return Fceiling (wrong_type_argument (Qnumberp, number));
737 } 886 }
738 887
739 888
742 With optional second argument DIVISOR, return the largest integer no 891 With optional second argument DIVISOR, return the largest integer no
743 greater than NUMBER/DIVISOR. 892 greater than NUMBER/DIVISOR.
744 */ 893 */
745 (number, divisor)) 894 (number, divisor))
746 { 895 {
896 #ifdef WITH_NUMBER_TYPES
897 CHECK_REAL (number);
898 if (NILP (divisor))
899 {
900 if (FLOATP (number))
901 {
902 double d;
903 IN_FLOAT ((d = floor (XFLOAT_DATA (number))), "floor", number);
904 return (float_to_int (d, "floor", number, Qunbound));
905 }
906 #ifdef HAVE_RATIO
907 else if (RATIOP (number))
908 {
909 bignum_floor (scratch_bignum, XRATIO_NUMERATOR (number),
910 XRATIO_DENOMINATOR (number));
911 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
912 }
913 #endif
914 #ifdef HAVE_BIGFLOAT
915 else if (BIGFLOATP (number))
916 {
917 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
918 bigfloat_floor (scratch_bigfloat, XBIGFLOAT_DATA (number));
919 return make_bigfloat_bf (scratch_bigfloat);
920 }
921 #endif
922 return number;
923 }
924 else
925 {
926 CHECK_REAL (divisor);
927 switch (promote_args (&number, &divisor))
928 {
929 case FIXNUM_T:
930 {
931 EMACS_INT i1 = XREALINT (number);
932 EMACS_INT i2 = XREALINT (divisor);
933
934 if (i2 == 0)
935 Fsignal (Qarith_error, Qnil);
936
937 /* With C's /, the result is implementation-defined if either
938 operand is negative, so use only nonnegative operands. */
939 i1 = (i2 < 0
940 ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2))
941 : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2));
942
943 return make_int (i1);
944 }
945 #ifdef HAVE_BIGNUM
946 case BIGNUM_T:
947 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0)
948 Fsignal (Qarith_error, Qnil);
949 bignum_floor (scratch_bignum, XBIGNUM_DATA (number),
950 XBIGNUM_DATA (divisor));
951 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
952 #endif
953 case FLOAT_T:
954 {
955 double f1 = extract_float (number);
956 double f2 = extract_float (divisor);
957
958 if (f2 == 0.0)
959 Fsignal (Qarith_error, Qnil);
960
961 IN_FLOAT2 (f1 = floor (f1 / f2), "floor", number, divisor);
962 return float_to_int (f1, "floor", number, divisor);
963 }
964 #ifdef HAVE_RATIO
965 case RATIO_T:
966 if (ratio_sign (XRATIO_DATA (divisor)) == 0)
967 Fsignal (Qarith_error, Qnil);
968 ratio_div (scratch_ratio, XRATIO_DATA (number),
969 XRATIO_DATA (divisor));
970 bignum_floor (scratch_bignum, ratio_numerator (scratch_ratio),
971 ratio_denominator (scratch_ratio));
972 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
973 #endif
974 #ifdef HAVE_BIGFLOAT
975 case BIGFLOAT_T:
976 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
977 Fsignal (Qarith_error, Qnil);
978 bigfloat_set_prec (scratch_bigfloat,
979 max (XBIGFLOAT_GET_PREC (number),
980 XBIGFLOAT_GET_PREC (divisor)));
981 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number),
982 XBIGFLOAT_DATA (divisor));
983 bigfloat_floor (scratch_bigfloat, scratch_bigfloat);
984 return make_bigfloat_bf (scratch_bigfloat);
985 #endif
986 }
987 }
988 #else /* !WITH_NUMBER_TYPES */
747 CHECK_INT_OR_FLOAT (number); 989 CHECK_INT_OR_FLOAT (number);
748 990
749 if (! NILP (divisor)) 991 if (! NILP (divisor))
750 { 992 {
751 EMACS_INT i1, i2; 993 EMACS_INT i1, i2;
785 IN_FLOAT ((d = floor (XFLOAT_DATA (number))), "floor", number); 1027 IN_FLOAT ((d = floor (XFLOAT_DATA (number))), "floor", number);
786 return (float_to_int (d, "floor", number, Qunbound)); 1028 return (float_to_int (d, "floor", number, Qunbound));
787 } 1029 }
788 1030
789 return number; 1031 return number;
1032 #endif /* WITH_NUMBER_TYPES */
790 } 1033 }
791 1034
792 DEFUN ("round", Fround, 1, 1, 0, /* 1035 DEFUN ("round", Fround, 1, 1, 0, /*
793 Return the nearest integer to NUMBER. 1036 Return the nearest integer to NUMBER.
794 */ 1037 */
800 /* Screw the prevailing rounding mode. */ 1043 /* Screw the prevailing rounding mode. */
801 IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (number))), "round", number); 1044 IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (number))), "round", number);
802 return (float_to_int (d, "round", number, Qunbound)); 1045 return (float_to_int (d, "round", number, Qunbound));
803 } 1046 }
804 1047
1048 #ifdef HAVE_BIGNUM
1049 if (INTEGERP (number))
1050 #else
805 if (INTP (number)) 1051 if (INTP (number))
1052 #endif
806 return number; 1053 return number;
1054
1055 #ifdef HAVE_RATIO
1056 if (RATIOP (number))
1057 {
1058 if (bignum_divisible_p (XRATIO_NUMERATOR (number),
1059 XRATIO_DENOMINATOR (number)))
1060 {
1061 bignum_div (scratch_bignum, XRATIO_NUMERATOR (number),
1062 XRATIO_DENOMINATOR (number));
1063 }
1064 else
1065 {
1066 bignum_add (scratch_bignum2, XRATIO_NUMERATOR (number),
1067 XRATIO_DENOMINATOR (number));
1068 bignum_div (scratch_bignum, scratch_bignum2,
1069 XRATIO_DENOMINATOR (number));
1070 }
1071 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
1072 }
1073 #endif
1074
1075 #ifdef HAVE_BIGFLOAT
1076 if (BIGFLOATP (number))
1077 {
1078 unsigned long prec = XBIGFLOAT_GET_PREC (number);
1079 bigfloat_set_prec (scratch_bigfloat, prec);
1080 bigfloat_set_prec (scratch_bigfloat2, prec);
1081 bigfloat_set_double (scratch_bigfloat2,
1082 bigfloat_sign (XBIGFLOAT_DATA (number)) * 0.5);
1083 bigfloat_floor (scratch_bigfloat, scratch_bigfloat2);
1084 #ifdef HAVE_BIGNUM
1085 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
1086 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
1087 #else
1088 return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
1089 #endif /* HAVE_BIGNUM */
1090 }
1091 #endif /* HAVE_BIGFLOAT */
807 1092
808 return Fround (wrong_type_argument (Qnumberp, number)); 1093 return Fround (wrong_type_argument (Qnumberp, number));
809 } 1094 }
810 1095
811 DEFUN ("truncate", Ftruncate, 1, 1, 0, /* 1096 DEFUN ("truncate", Ftruncate, 1, 1, 0, /*
815 (number)) 1100 (number))
816 { 1101 {
817 if (FLOATP (number)) 1102 if (FLOATP (number))
818 return float_to_int (XFLOAT_DATA (number), "truncate", number, Qunbound); 1103 return float_to_int (XFLOAT_DATA (number), "truncate", number, Qunbound);
819 1104
1105 #ifdef HAVE_BIGNUM
1106 if (INTEGERP (number))
1107 #else
820 if (INTP (number)) 1108 if (INTP (number))
1109 #endif
821 return number; 1110 return number;
1111
1112 #ifdef HAVE_RATIO
1113 if (RATIOP (number))
1114 {
1115 bignum_div (scratch_bignum, XRATIO_NUMERATOR (number),
1116 XRATIO_DENOMINATOR (number));
1117 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
1118 }
1119 #endif
1120
1121 #ifdef HAVE_BIGFLOAT
1122 if (BIGFLOATP (number))
1123 {
1124 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
1125 bigfloat_trunc (scratch_bigfloat, XBIGFLOAT_DATA (number));
1126 #ifdef HAVE_BIGNUM
1127 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
1128 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
1129 #else
1130 return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
1131 #endif /* HAVE_BIGNUM */
1132 }
1133 #endif /* HAVE_BIGFLOAT */
822 1134
823 return Ftruncate (wrong_type_argument (Qnumberp, number)); 1135 return Ftruncate (wrong_type_argument (Qnumberp, number));
824 } 1136 }
825 1137
826 /* Float-rounding functions. */ 1138 /* Float-rounding functions. */