Mercurial > hg > xemacs-beta

comparison src/floatfns.c @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents a86b2b5e0111
children 41dbb7a9d5f2
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
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 /* The code uses emacs_rint, so that it works to undefine HAVE_RINT 58 #ifndef HAVE_RINT
59 if `rint' exists but does not work right. */
60 #ifdef HAVE_RINT
61 #define emacs_rint rint
62 #else
63 static double 59 static double
64 emacs_rint (double x) 60 rint (double x)
65 { 61 {
66 double r = floor (x + 0.5); 62 double r = floor (x + 0.5);
67 double diff = fabs (r - x); 63 double diff = fabs (r - x);
68 /* Round to even and correct for any roundoff errors. */ 64 /* Round to even and correct for any roundoff errors. */
69 if (diff >= 0.5 && (diff > 0.5 || r != 2.0 * floor (r / 2.0))) 65 if (diff >= 0.5 && (diff > 0.5 || r != 2.0 * floor (r / 2.0)))
77 static int in_float; 73 static int in_float;
78 74
79 /* If an argument is out of range for a mathematical function, 75 /* If an argument is out of range for a mathematical function,
80 here is the actual argument value to use in the error message. */ 76 here is the actual argument value to use in the error message. */
81 static Lisp_Object float_error_arg, float_error_arg2; 77 static Lisp_Object float_error_arg, float_error_arg2;
82 static const char *float_error_fn_name; 78 static CONST char *float_error_fn_name;
83 79
84 /* Evaluate the floating point expression D, recording NUM 80 /* Evaluate the floating point expression D, recording NUM
85 as the original argument for error messages. 81 as the original argument for error messages.
86 D is normally an assignment expression. 82 D is normally an assignment expression.
87 Handle errors which may result in signals or may set errno. 83 Handle errors which may result in signals or may set errno.
110 #define IN_FLOAT2(d, name, num, num2) (in_float = 2, (d), in_float = 0) 106 #define IN_FLOAT2(d, name, num, num2) (in_float = 2, (d), in_float = 0)
111 #endif 107 #endif
112 108
113 109
114 #define arith_error(op,arg) \ 110 #define arith_error(op,arg) \
115 Fsignal (Qarith_error, list2 (build_string (op), arg)) 111 Fsignal (Qarith_error, list2 (build_string ((op)), (arg)))
116 #define range_error(op,arg) \ 112 #define range_error(op,arg) \
117 Fsignal (Qrange_error, list2 (build_string (op), arg)) 113 Fsignal (Qrange_error, list2 (build_string ((op)), (arg)))
118 #define range_error2(op,a1,a2) \ 114 #define range_error2(op,a1,a2) \
119 Fsignal (Qrange_error, list3 (build_string (op), a1, a2)) 115 Fsignal (Qrange_error, list3 (build_string ((op)), (a1), (a2)))
120 #define domain_error(op,arg) \ 116 #define domain_error(op,arg) \
121 Fsignal (Qdomain_error, list2 (build_string (op), arg)) 117 Fsignal (Qdomain_error, list2 (build_string ((op)), (arg)))
122 #define domain_error2(op,a1,a2) \ 118 #define domain_error2(op,a1,a2) \
123 Fsignal (Qdomain_error, list3 (build_string (op), a1, a2)) 119 Fsignal (Qdomain_error, list3 (build_string ((op)), (a1), (a2)))
124 120
125 121
126 /* Convert float to Lisp Integer if it fits, else signal a range 122 /* Convert float to Lisp Integer if it fits, else signal a range
127 error using the given arguments. */ 123 error using the given arguments. */
128 static Lisp_Object 124 static Lisp_Object
129 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)
130 { 126 {
131 if (x >= ((EMACS_INT) 1 << (VALBITS-1)) 127 if (x >= ((EMACS_INT) 1 << (VALBITS-1))
132 || x <= - ((EMACS_INT) 1 << (VALBITS-1)) - (EMACS_INT) 1) 128 || x <= - ((EMACS_INT) 1 << (VALBITS-1)) - (EMACS_INT) 1)
133 { 129 {
134 if (!UNBOUNDP (num2)) 130 if (!UNBOUNDP (num2))
162 } 158 }
163 } 159 }
164 160
165 161
166 static Lisp_Object 162 static Lisp_Object
167 mark_float (Lisp_Object obj) 163 mark_float (Lisp_Object obj, void (*markobj) (Lisp_Object))
168 { 164 {
169 return Qnil; 165 return Qnil;
170 } 166 }
171 167
172 static int 168 static int
181 /* mod the value down to 32-bit range */ 177 /* mod the value down to 32-bit range */
182 /* #### change for 64-bit machines */ 178 /* #### change for 64-bit machines */
183 return (unsigned long) fmod (extract_float (obj), 4e9); 179 return (unsigned long) fmod (extract_float (obj), 4e9);
184 } 180 }
185 181
186 static const struct lrecord_description float_description[] = {
187 { XD_END }
188 };
189
190 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("float", float, 182 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("float", float,
191 mark_float, print_float, 0, float_equal, 183 mark_float, print_float, 0, float_equal,
192 float_hash, float_description, 184 float_hash, struct Lisp_Float);
193 Lisp_Float);
194 185
195 /* Extract a Lisp number as a `double', or signal an error. */ 186 /* Extract a Lisp number as a `double', or signal an error. */
196 187
197 double 188 double
198 extract_float (Lisp_Object num) 189 extract_float (Lisp_Object num)
703 (arg)) 694 (arg))
704 { 695 {
705 double f = extract_float (arg); 696 double f = extract_float (arg);
706 697
707 if (f == 0.0) 698 if (f == 0.0)
708 return make_int (- (EMACS_INT)(((EMACS_UINT) 1) << (VALBITS - 1))); /* most-negative-fixnum */ 699 return make_int (- (int)((((EMACS_UINT) 1) << (VALBITS - 1)))); /* most-negative-fixnum */
709 #ifdef HAVE_LOGB 700 #ifdef HAVE_LOGB
710 { 701 {
711 Lisp_Object val; 702 Lisp_Object val;
712 IN_FLOAT (val = make_int ((EMACS_INT) logb (f)), "logb", arg); 703 IN_FLOAT (val = make_int ((int) logb (f)), "logb", arg);
713 return val; 704 return (val);
714 } 705 }
715 #else 706 #else
716 #ifdef HAVE_FREXP 707 #ifdef HAVE_FREXP
717 { 708 {
718 int exqp; 709 int exqp;
719 IN_FLOAT (frexp (f, &exqp), "logb", arg); 710 IN_FLOAT (frexp (f, &exqp), "logb", arg);
720 return make_int (exqp - 1); 711 return (make_int (exqp - 1));
721 } 712 }
722 #else 713 #else
723 { 714 {
724 int i; 715 int i;
725 double d; 716 double d;
739 for (i = 1, d = 2.0; d * d <= f; i += i) 730 for (i = 1, d = 2.0; d * d <= f; i += i)
740 d *= d; 731 d *= d;
741 f /= d; 732 f /= d;
742 val += i; 733 val += i;
743 } 734 }
744 return make_int (val); 735 return (make_int (val));
745 } 736 }
746 #endif /* ! HAVE_FREXP */ 737 #endif /* ! HAVE_FREXP */
747 #endif /* ! HAVE_LOGB */ 738 #endif /* ! HAVE_LOGB */
748 } 739 }
749 #endif /* LISP_FLOAT_TYPE */ 740 #endif /* LISP_FLOAT_TYPE */
833 #ifdef LISP_FLOAT_TYPE 824 #ifdef LISP_FLOAT_TYPE
834 if (FLOATP (arg)) 825 if (FLOATP (arg))
835 { 826 {
836 double d; 827 double d;
837 /* Screw the prevailing rounding mode. */ 828 /* Screw the prevailing rounding mode. */
838 IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (arg))), "round", arg); 829 IN_FLOAT ((d = rint (XFLOAT_DATA (arg))), "round", arg);
839 return (float_to_int (d, "round", arg, Qunbound)); 830 return (float_to_int (d, "round", arg, Qunbound));
840 } 831 }
841 #endif /* LISP_FLOAT_TYPE */ 832 #endif /* LISP_FLOAT_TYPE */
842 833
843 if (INTP (arg)) 834 if (INTP (arg))
893 Return the nearest integer to ARG, as a float. 884 Return the nearest integer to ARG, as a float.
894 */ 885 */
895 (arg)) 886 (arg))
896 { 887 {
897 double d = extract_float (arg); 888 double d = extract_float (arg);
898 IN_FLOAT (d = emacs_rint (d), "fround", arg); 889 IN_FLOAT (d = rint (d), "fround", arg);
899 return make_float (d); 890 return make_float (d);
900 } 891 }
901 892
902 DEFUN ("ftruncate", Fftruncate, 1, 1, 0, /* 893 DEFUN ("ftruncate", Fftruncate, 1, 1, 0, /*
903 Truncate a floating point number to an integral float value. 894 Truncate a floating point number to an integral float value.
986 } 977 }
987 978
988 void 979 void
989 syms_of_floatfns (void) 980 syms_of_floatfns (void)
990 { 981 {
991 INIT_LRECORD_IMPLEMENTATION (float);
992 982
993 /* Trig functions. */ 983 /* Trig functions. */
994 984
995 #ifdef LISP_FLOAT_TYPE 985 #ifdef LISP_FLOAT_TYPE
996 DEFSUBR (Facos); 986 DEFSUBR (Facos);