Mercurial > hg > xemacs-beta

comparison src/floatfns.c @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 8626e4521993
children a86b2b5e0111
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
53 53
54 /* Need to define a differentiating symbol -- see sysfloat.h */ 54 /* Need to define a differentiating symbol -- see sysfloat.h */
55 #define THIS_FILENAME floatfns 55 #define THIS_FILENAME floatfns
56 #include "sysfloat.h" 56 #include "sysfloat.h"
57 57
58 #ifndef HAVE_RINT 58 /* The code uses emacs_rint, so that it works to undefine HAVE_RINT
59 if `rint' exists but does not work right. */
60 #ifdef HAVE_RINT
61 #define emacs_rint rint
62 #else
59 static double 63 static double
60 rint (double x) 64 emacs_rint (double x)
61 { 65 {
62 double r = floor (x + 0.5); 66 double r = floor (x + 0.5);
63 double diff = fabs (r - x); 67 double diff = fabs (r - x);
64 /* Round to even and correct for any roundoff errors. */ 68 /* Round to even and correct for any roundoff errors. */
65 if (diff >= 0.5 && (diff > 0.5 || r != 2.0 * floor (r / 2.0))) 69 if (diff >= 0.5 && (diff > 0.5 || r != 2.0 * floor (r / 2.0)))
73 static int in_float; 77 static int in_float;
74 78
75 /* If an argument is out of range for a mathematical function, 79 /* If an argument is out of range for a mathematical function,
76 here is the actual argument value to use in the error message. */ 80 here is the actual argument value to use in the error message. */
77 static Lisp_Object float_error_arg, float_error_arg2; 81 static Lisp_Object float_error_arg, float_error_arg2;
78 static CONST char *float_error_fn_name; 82 static const char *float_error_fn_name;
79 83
80 /* Evaluate the floating point expression D, recording NUM 84 /* Evaluate the floating point expression D, recording NUM
81 as the original argument for error messages. 85 as the original argument for error messages.
82 D is normally an assignment expression. 86 D is normally an assignment expression.
83 Handle errors which may result in signals or may set errno. 87 Handle errors which may result in signals or may set errno.
106 #define IN_FLOAT2(d, name, num, num2) (in_float = 2, (d), in_float = 0) 110 #define IN_FLOAT2(d, name, num, num2) (in_float = 2, (d), in_float = 0)
107 #endif 111 #endif
108 112
109 113
110 #define arith_error(op,arg) \ 114 #define arith_error(op,arg) \
111 Fsignal (Qarith_error, list2 (build_string ((op)), (arg))) 115 Fsignal (Qarith_error, list2 (build_string (op), arg))
112 #define range_error(op,arg) \ 116 #define range_error(op,arg) \
113 Fsignal (Qrange_error, list2 (build_string ((op)), (arg))) 117 Fsignal (Qrange_error, list2 (build_string (op), arg))
114 #define range_error2(op,a1,a2) \ 118 #define range_error2(op,a1,a2) \
115 Fsignal (Qrange_error, list3 (build_string ((op)), (a1), (a2))) 119 Fsignal (Qrange_error, list3 (build_string (op), a1, a2))
116 #define domain_error(op,arg) \ 120 #define domain_error(op,arg) \
117 Fsignal (Qdomain_error, list2 (build_string ((op)), (arg))) 121 Fsignal (Qdomain_error, list2 (build_string (op), arg))
118 #define domain_error2(op,a1,a2) \ 122 #define domain_error2(op,a1,a2) \
119 Fsignal (Qdomain_error, list3 (build_string ((op)), (a1), (a2))) 123 Fsignal (Qdomain_error, list3 (build_string (op), a1, a2))
120 124
121 125
122 /* Convert float to Lisp Integer if it fits, else signal a range 126 /* Convert float to Lisp Integer if it fits, else signal a range
123 error using the given arguments. */ 127 error using the given arguments. */
124 static Lisp_Object 128 static Lisp_Object
125 float_to_int (double x, CONST char *name, Lisp_Object num, Lisp_Object num2) 129 float_to_int (double x, const char *name, Lisp_Object num, Lisp_Object num2)
126 { 130 {
127 if (x >= ((EMACS_INT) 1 << (VALBITS-1)) 131 if (x >= ((EMACS_INT) 1 << (VALBITS-1))
128 || x <= - ((EMACS_INT) 1 << (VALBITS-1)) - (EMACS_INT) 1) 132 || x <= - ((EMACS_INT) 1 << (VALBITS-1)) - (EMACS_INT) 1)
129 { 133 {
130 if (!UNBOUNDP (num2)) 134 if (!UNBOUNDP (num2))
158 } 162 }
159 } 163 }
160 164
161 165
162 static Lisp_Object 166 static Lisp_Object
163 mark_float (Lisp_Object obj, void (*markobj) (Lisp_Object)) 167 mark_float (Lisp_Object obj)
164 { 168 {
165 return Qnil; 169 return Qnil;
166 } 170 }
167 171
168 static int 172 static int
177 /* mod the value down to 32-bit range */ 181 /* mod the value down to 32-bit range */
178 /* #### change for 64-bit machines */ 182 /* #### change for 64-bit machines */
179 return (unsigned long) fmod (extract_float (obj), 4e9); 183 return (unsigned long) fmod (extract_float (obj), 4e9);
180 } 184 }
181 185
186 static const struct lrecord_description float_description[] = {
187 { XD_END }
188 };
189
182 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("float", float, 190 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("float", float,
183 mark_float, print_float, 0, float_equal, 191 mark_float, print_float, 0, float_equal,
184 float_hash, struct Lisp_Float); 192 float_hash, float_description,
193 Lisp_Float);
185 194
186 /* Extract a Lisp number as a `double', or signal an error. */ 195 /* Extract a Lisp number as a `double', or signal an error. */
187 196
188 double 197 double
189 extract_float (Lisp_Object num) 198 extract_float (Lisp_Object num)
192 return XFLOAT_DATA (num); 201 return XFLOAT_DATA (num);
193 202
194 if (INTP (num)) 203 if (INTP (num))
195 return (double) XINT (num); 204 return (double) XINT (num);
196 205
197 return extract_float (wrong_type_argument (num, Qnumberp)); 206 return extract_float (wrong_type_argument (Qnumberp, num));
198 } 207 }
199 #endif /* LISP_FLOAT_TYPE */ 208 #endif /* LISP_FLOAT_TYPE */
200 209
201 210
202 /* Trig functions. */ 211 /* Trig functions. */
664 #endif /* LISP_FLOAT_TYPE */ 673 #endif /* LISP_FLOAT_TYPE */
665 674
666 if (INTP (arg)) 675 if (INTP (arg))
667 return (XINT (arg) >= 0) ? arg : make_int (- XINT (arg)); 676 return (XINT (arg) >= 0) ? arg : make_int (- XINT (arg));
668 677
669 return Fabs (wrong_type_argument (arg, Qnumberp)); 678 return Fabs (wrong_type_argument (Qnumberp, arg));
670 } 679 }
671 680
672 #ifdef LISP_FLOAT_TYPE 681 #ifdef LISP_FLOAT_TYPE
673 DEFUN ("float", Ffloat, 1, 1, 0, /* 682 DEFUN ("float", Ffloat, 1, 1, 0, /*
674 Return the floating point number equal to ARG. 683 Return the floating point number numerically equal to ARG.
675 */ 684 */
676 (arg)) 685 (arg))
677 { 686 {
678 if (INTP (arg)) 687 if (INTP (arg))
679 return make_float ((double) XINT (arg)); 688 return make_float ((double) XINT (arg));
680 689
681 if (FLOATP (arg)) /* give 'em the same float back */ 690 if (FLOATP (arg)) /* give 'em the same float back */
682 return arg; 691 return arg;
683 692
684 return Ffloat (wrong_type_argument (arg, Qnumberp)); 693 return Ffloat (wrong_type_argument (Qnumberp, arg));
685 } 694 }
686 #endif /* LISP_FLOAT_TYPE */ 695 #endif /* LISP_FLOAT_TYPE */
687 696
688 697
689 #ifdef LISP_FLOAT_TYPE 698 #ifdef LISP_FLOAT_TYPE
694 (arg)) 703 (arg))
695 { 704 {
696 double f = extract_float (arg); 705 double f = extract_float (arg);
697 706
698 if (f == 0.0) 707 if (f == 0.0)
699 return make_int (- (int)((((EMACS_UINT) 1) << (VALBITS - 1)))); /* most-negative-fixnum */ 708 return make_int (- (EMACS_INT)(((EMACS_UINT) 1) << (VALBITS - 1))); /* most-negative-fixnum */
700 #ifdef HAVE_LOGB 709 #ifdef HAVE_LOGB
701 { 710 {
702 Lisp_Object val; 711 Lisp_Object val;
703 IN_FLOAT (val = make_int ((int) logb (f)), "logb", arg); 712 IN_FLOAT (val = make_int ((EMACS_INT) logb (f)), "logb", arg);
704 return (val); 713 return val;
705 } 714 }
706 #else 715 #else
707 #ifdef HAVE_FREXP 716 #ifdef HAVE_FREXP
708 { 717 {
709 int exqp; 718 int exqp;
710 IN_FLOAT (frexp (f, &exqp), "logb", arg); 719 IN_FLOAT (frexp (f, &exqp), "logb", arg);
711 return (make_int (exqp - 1)); 720 return make_int (exqp - 1);
712 } 721 }
713 #else 722 #else
714 { 723 {
715 int i; 724 int i;
716 double d; 725 double d;
730 for (i = 1, d = 2.0; d * d <= f; i += i) 739 for (i = 1, d = 2.0; d * d <= f; i += i)
731 d *= d; 740 d *= d;
732 f /= d; 741 f /= d;
733 val += i; 742 val += i;
734 } 743 }
735 return (make_int (val)); 744 return make_int (val);
736 } 745 }
737 #endif /* ! HAVE_FREXP */ 746 #endif /* ! HAVE_FREXP */
738 #endif /* ! HAVE_LOGB */ 747 #endif /* ! HAVE_LOGB */
739 } 748 }
740 #endif /* LISP_FLOAT_TYPE */ 749 #endif /* LISP_FLOAT_TYPE */
755 #endif /* LISP_FLOAT_TYPE */ 764 #endif /* LISP_FLOAT_TYPE */
756 765
757 if (INTP (arg)) 766 if (INTP (arg))
758 return arg; 767 return arg;
759 768
760 return Fceiling (wrong_type_argument (arg, Qnumberp)); 769 return Fceiling (wrong_type_argument (Qnumberp, arg));
761 } 770 }
762 771
763 772
764 DEFUN ("floor", Ffloor, 1, 2, 0, /* 773 DEFUN ("floor", Ffloor, 1, 2, 0, /*
765 Return the largest integer no greater than ARG. (Round towards -inf.) 774 Return the largest integer no greater than ARG. (Round towards -inf.)
824 #ifdef LISP_FLOAT_TYPE 833 #ifdef LISP_FLOAT_TYPE
825 if (FLOATP (arg)) 834 if (FLOATP (arg))
826 { 835 {
827 double d; 836 double d;
828 /* Screw the prevailing rounding mode. */ 837 /* Screw the prevailing rounding mode. */
829 IN_FLOAT ((d = rint (XFLOAT_DATA (arg))), "round", arg); 838 IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (arg))), "round", arg);
830 return (float_to_int (d, "round", arg, Qunbound)); 839 return (float_to_int (d, "round", arg, Qunbound));
831 } 840 }
832 #endif /* LISP_FLOAT_TYPE */ 841 #endif /* LISP_FLOAT_TYPE */
833 842
834 if (INTP (arg)) 843 if (INTP (arg))
835 return arg; 844 return arg;
836 845
837 return Fround (wrong_type_argument (arg, Qnumberp)); 846 return Fround (wrong_type_argument (Qnumberp, arg));
838 } 847 }
839 848
840 DEFUN ("truncate", Ftruncate, 1, 1, 0, /* 849 DEFUN ("truncate", Ftruncate, 1, 1, 0, /*
841 Truncate a floating point number to an integer. 850 Truncate a floating point number to an integer.
842 Rounds the value toward zero. 851 Rounds the value toward zero.
849 #endif /* LISP_FLOAT_TYPE */ 858 #endif /* LISP_FLOAT_TYPE */
850 859
851 if (INTP (arg)) 860 if (INTP (arg))
852 return arg; 861 return arg;
853 862
854 return Ftruncate (wrong_type_argument (arg, Qnumberp)); 863 return Ftruncate (wrong_type_argument (Qnumberp, arg));
855 } 864 }
856 865
857 /* Float-rounding functions. */ 866 /* Float-rounding functions. */
858 #ifdef LISP_FLOAT_TYPE 867 #ifdef LISP_FLOAT_TYPE
859 /* #if 1 It's not clear these are worth adding... */ 868 /* #if 1 It's not clear these are worth adding... */
884 Return the nearest integer to ARG, as a float. 893 Return the nearest integer to ARG, as a float.
885 */ 894 */
886 (arg)) 895 (arg))
887 { 896 {
888 double d = extract_float (arg); 897 double d = extract_float (arg);
889 IN_FLOAT (d = rint (d), "fround", arg); 898 IN_FLOAT (d = emacs_rint (d), "fround", arg);
890 return make_float (d); 899 return make_float (d);
891 } 900 }
892 901
893 DEFUN ("ftruncate", Fftruncate, 1, 1, 0, /* 902 DEFUN ("ftruncate", Fftruncate, 1, 1, 0, /*
894 Truncate a floating point number to an integral float value. 903 Truncate a floating point number to an integral float value.