annotate src/floatfns.c @ 4865:6c0bb4d2c23a

Always use our rint(), for rounding consistency with the bignum code. ChangeLog addition: 2010-01-16 Aidan Kehoe <kehoea@parhasard.net> * configure: Regenerate, now we no longer look for rint(). src/ChangeLog addition: 2010-01-16 Aidan Kehoe <kehoea@parhasard.net> * config.h.in: * floatfns.c (emacs_rint): Don't look for rint in configure, always use our own implementation that rounds to the even number in the case of ambiguity, for consistency with the bignum code.
author Aidan Kehoe <kehoea@parhasard.net>
date Sat, 16 Jan 2010 19:04:52 +0000
parents f31c12360354
children 6ef8256a020a 19a72041c5ed
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 /* Primitive operations on floating point for XEmacs Lisp interpreter.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2 Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4 This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 under the terms of the GNU General Public License as published by the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 Free Software Foundation; either version 2, or (at your option) any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 along with XEmacs; see the file COPYING. If not, write to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 Boston, MA 02111-1307, USA. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 /* Synched up with: FSF 19.30. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 /* ANSI C requires only these float functions:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25 frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27 Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 Define HAVE_CBRT if you have cbrt().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 If you don't define these, then the appropriate routines will be simulated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 Define HAVE_MATHERR if on a system supporting the SysV matherr() callback.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 (This should happen automatically.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34 Define FLOAT_CHECK_ERRNO if the float library routines set errno.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 This has no effect if HAVE_MATHERR is defined.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 (What systems actually do this? Let me know. -jwz)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
39
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40 Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41 either setting errno, or signalling SIGFPE/SIGILL. Otherwise, domain and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 range checking will happen before calling the float routines. This has
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 no effect if HAVE_MATHERR is defined (since matherr will be called when
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 a domain error occurs).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 #include <config.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 #include "lisp.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 #include "syssignal.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 #include "sysfloat.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51
4865
6c0bb4d2c23a Always use our rint(), for rounding consistency with the bignum code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4828
diff changeset
52 /* An implementation of rint that always rounds towards the even number in
6c0bb4d2c23a Always use our rint(), for rounding consistency with the bignum code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4828
diff changeset
53 the case of ambiguity. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 static double
430
a5df635868b2 Import from CVS: tag r21-2-23
cvs
parents: 428
diff changeset
55 emacs_rint (double x)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 double r = floor (x + 0.5);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 double diff = fabs (r - x);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 /* Round to even and correct for any roundoff errors. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 if (diff >= 0.5 && (diff > 0.5 || r != 2.0 * floor (r / 2.0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 r += r < x ? 1.0 : -1.0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 return r;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 /* Nonzero while executing in floating point.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 This tells float_error what to do. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 static int in_float;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 /* If an argument is out of range for a mathematical function,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 here is the actual argument value to use in the error message. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 static Lisp_Object float_error_arg, float_error_arg2;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
72 static const char *float_error_fn_name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 /* Evaluate the floating point expression D, recording NUM
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 as the original argument for error messages.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 D is normally an assignment expression.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 Handle errors which may result in signals or may set errno.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 Note that float_error may be declared to return void, so you can't
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 just cast the zero after the colon to (SIGTYPE) to make the types
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 check properly. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 #ifdef FLOAT_CHECK_ERRNO
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 #define IN_FLOAT(d, name, num) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 float_error_arg = num; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 float_error_fn_name = name; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 in_float = 1; errno = 0; (d); in_float = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 if (errno != 0) in_float_error (); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 #define IN_FLOAT2(d, name, num, num2) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 float_error_arg = num; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 float_error_arg2 = num2; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 float_error_fn_name = name; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 in_float = 2; errno = 0; (d); in_float = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 if (errno != 0) in_float_error (); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 #define IN_FLOAT2(d, name, num, num2) (in_float = 2, (d), in_float = 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 #define arith_error(op,arg) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 665
diff changeset
105 Fsignal (Qarith_error, list2 (build_msg_string (op), arg))
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
106 #define arith_error2(op,a1,a2) \
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
107 Fsignal (Qarith_error, list3 (build_msg_string (op), a1, a2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 #define range_error(op,arg) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 665
diff changeset
109 Fsignal (Qrange_error, list2 (build_msg_string (op), arg))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 #define range_error2(op,a1,a2) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 665
diff changeset
111 Fsignal (Qrange_error, list3 (build_msg_string (op), a1, a2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 #define domain_error(op,arg) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 665
diff changeset
113 Fsignal (Qdomain_error, list2 (build_msg_string (op), arg))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 #define domain_error2(op,a1,a2) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 665
diff changeset
115 Fsignal (Qdomain_error, list3 (build_msg_string (op), a1, a2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 /* Convert float to Lisp Integer if it fits, else signal a range
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
119 error using the given arguments. If bignums are available, range errors
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
120 are never signaled. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 static Lisp_Object
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2092
diff changeset
122 float_to_int (double x,
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2092
diff changeset
123 #ifdef HAVE_BIGNUM
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2092
diff changeset
124 const char *UNUSED (name), Lisp_Object UNUSED (num),
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2092
diff changeset
125 Lisp_Object UNUSED (num2)
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2092
diff changeset
126 #else
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2092
diff changeset
127 const char *name, Lisp_Object num, Lisp_Object num2
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2092
diff changeset
128 #endif
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2092
diff changeset
129 )
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
131 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
132 bignum_set_double (scratch_bignum, x);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
133 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
134 #else
2039
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1995
diff changeset
135 REGISTER EMACS_INT result = (EMACS_INT) x;
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1995
diff changeset
136
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1995
diff changeset
137 if (result > EMACS_INT_MAX || result < EMACS_INT_MIN)
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1995
diff changeset
138 {
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1995
diff changeset
139 if (!UNBOUNDP (num2))
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1995
diff changeset
140 range_error2 (name, num, num2);
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1995
diff changeset
141 else
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1995
diff changeset
142 range_error (name, num);
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1995
diff changeset
143 }
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1995
diff changeset
144 return make_int (result);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
145 #endif /* HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 in_float_error (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 switch (errno)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 case 0:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156 case EDOM:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 if (in_float == 2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 domain_error2 (float_error_fn_name, float_error_arg, float_error_arg2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 domain_error (float_error_fn_name, float_error_arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 case ERANGE:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 range_error (float_error_fn_name, float_error_arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 default:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 arith_error (float_error_fn_name, float_error_arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 static Lisp_Object
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2092
diff changeset
173 mark_float (Lisp_Object UNUSED (obj))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 static int
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2092
diff changeset
179 float_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 return (extract_float (obj1) == extract_float (obj2));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
184 static Hashcode
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2092
diff changeset
185 float_hash (Lisp_Object obj, int UNUSED (depth))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 /* mod the value down to 32-bit range */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 /* #### change for 64-bit machines */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 return (unsigned long) fmod (extract_float (obj), 4e9);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
192 static const struct memory_description float_description[] = {
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 771
diff changeset
196 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("float", float,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 771
diff changeset
197 1, /*dumpable-flag*/
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 771
diff changeset
198 mark_float, print_float, 0, float_equal,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 771
diff changeset
199 float_hash, float_description,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 771
diff changeset
200 Lisp_Float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 /* Extract a Lisp number as a `double', or signal an error. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 double
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 extract_float (Lisp_Object num)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 if (FLOATP (num))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 return XFLOAT_DATA (num);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 if (INTP (num))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 return (double) XINT (num);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
213 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
214 if (BIGNUMP (num))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
215 return bignum_to_double (XBIGNUM_DATA (num));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
216 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
217
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
218 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
219 if (RATIOP (num))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
220 return ratio_to_double (XRATIO_DATA (num));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
221 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
222
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
223 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
224 if (BIGFLOATP (num))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
225 return bigfloat_to_double (XBIGFLOAT_DATA (num));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
226 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
227
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 return extract_float (wrong_type_argument (Qnumberp, num));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 /* Trig functions. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 DEFUN ("acos", Facos, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
234 Return the inverse cosine of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
236 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
238 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 if (d > 1.0 || d < -1.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
241 domain_error ("acos", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 #endif
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
243 IN_FLOAT (d = acos (d), "acos", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 DEFUN ("asin", Fasin, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
248 Return the inverse sine of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
250 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
252 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 if (d > 1.0 || d < -1.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
255 domain_error ("asin", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 #endif
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
257 IN_FLOAT (d = asin (d), "asin", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 DEFUN ("atan", Fatan, 1, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
262 Return the inverse tangent of NUMBER.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
263 If optional second argument NUMBER2 is provided,
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
264 return atan2 (NUMBER, NUMBER2).
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
266 (number, number2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
268 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
270 if (NILP (number2))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
271 IN_FLOAT (d = atan (d), "atan", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
274 double d2 = extract_float (number2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 if (d == 0.0 && d2 == 0.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
277 domain_error2 ("atan", number, number2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 #endif
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
279 IN_FLOAT2 (d = atan2 (d, d2), "atan", number, number2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 DEFUN ("cos", Fcos, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
285 Return the cosine of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
287 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
289 double d = extract_float (number);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
290 IN_FLOAT (d = cos (d), "cos", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 DEFUN ("sin", Fsin, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
295 Return the sine of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
297 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
299 double d = extract_float (number);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
300 IN_FLOAT (d = sin (d), "sin", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 DEFUN ("tan", Ftan, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
305 Return the tangent of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
307 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
309 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 double c = cos (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 if (c == 0.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
313 domain_error ("tan", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 #endif
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
315 IN_FLOAT (d = (sin (d) / c), "tan", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319 /* Bessel functions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 #if 0 /* Leave these out unless we find there's a reason for them. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322 DEFUN ("bessel-j0", Fbessel_j0, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
323 Return the bessel function j0 of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
325 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
327 double d = extract_float (number);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
328 IN_FLOAT (d = j0 (d), "bessel-j0", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 DEFUN ("bessel-j1", Fbessel_j1, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
333 Return the bessel function j1 of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
335 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
337 double d = extract_float (number);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
338 IN_FLOAT (d = j1 (d), "bessel-j1", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 DEFUN ("bessel-jn", Fbessel_jn, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
343 Return the order N bessel function output jn of NUMBER.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
344 The first number (the order) is truncated to an integer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
346 (number1, number2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
348 int i1 = extract_float (number1);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
349 double f2 = extract_float (number2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
351 IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", number1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 return make_float (f2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 DEFUN ("bessel-y0", Fbessel_y0, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
356 Return the bessel function y0 of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
358 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
360 double d = extract_float (number);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
361 IN_FLOAT (d = y0 (d), "bessel-y0", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 DEFUN ("bessel-y1", Fbessel_y1, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
366 Return the bessel function y1 of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
368 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
370 double d = extract_float (number);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
371 IN_FLOAT (d = y1 (d), "bessel-y0", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 DEFUN ("bessel-yn", Fbessel_yn, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
376 Return the order N bessel function output yn of NUMBER.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
377 The first number (the order) is truncated to an integer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
379 (number1, number2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
381 int i1 = extract_float (number1);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
382 double f2 = extract_float (number2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
384 IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", number1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385 return make_float (f2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 #endif /* 0 (bessel functions) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 /* Error functions. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 #if 0 /* Leave these out unless we see they are worth having. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 DEFUN ("erf", Ferf, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
394 Return the mathematical error function of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
396 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
398 double d = extract_float (number);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
399 IN_FLOAT (d = erf (d), "erf", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 DEFUN ("erfc", Ferfc, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
404 Return the complementary error function of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
406 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
408 double d = extract_float (number);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
409 IN_FLOAT (d = erfc (d), "erfc", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 DEFUN ("log-gamma", Flog_gamma, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
414 Return the log gamma of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
416 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
418 double d = extract_float (number);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
419 IN_FLOAT (d = lgamma (d), "log-gamma", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 #endif /* 0 (error functions) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 /* Root and Log functions. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 DEFUN ("exp", Fexp, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
429 Return the exponential base e of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
431 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
433 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 if (d > 709.7827) /* Assume IEEE doubles here */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
436 range_error ("exp", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 else if (d < -709.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 return make_float (0.0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 #endif
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
441 IN_FLOAT (d = exp (d), "exp", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 DEFUN ("expt", Fexpt, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
446 Return the exponential NUMBER1 ** NUMBER2.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
448 (number1, number2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
450 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
451 if (INTEGERP (number1) && INTP (number2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
452 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
453 if (INTP (number1))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
454 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
455 bignum_set_long (scratch_bignum2, XREALINT (number1));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
456 bignum_pow (scratch_bignum, scratch_bignum2, XREALINT (number2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
457 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
458 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
459 bignum_pow (scratch_bignum, XBIGNUM_DATA (number1),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
460 XREALINT (number2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
461 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
462 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
463 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
464
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
465 if (INTP (number1) && /* common lisp spec */
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
466 INTP (number2)) /* don't promote, if both are ints */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 EMACS_INT retval;
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
469 EMACS_INT x = XINT (number1);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
470 EMACS_INT y = XINT (number2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 if (y < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 if (x == 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 retval = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 else if (x == -1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 retval = (y & 1) ? -1 : 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 retval = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 retval = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 while (y > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 if (y & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 retval *= x;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 x *= x;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 y = (EMACS_UINT) y >> 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 return make_int (retval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
495 #if defined(HAVE_BIGFLOAT) && defined(bigfloat_pow)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
496 if (BIGFLOATP (number1) && INTEGERP (number2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
497 {
2057
471242c84954 [xemacs-hg @ 2004-05-03 15:19:10 by james]
james
parents: 2039
diff changeset
498 unsigned long exponent;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
499
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
500 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
501 if (BIGNUMP (number2))
2057
471242c84954 [xemacs-hg @ 2004-05-03 15:19:10 by james]
james
parents: 2039
diff changeset
502 exponent = bignum_to_ulong (XBIGNUM_DATA (number2));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
503 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
504 #endif
2057
471242c84954 [xemacs-hg @ 2004-05-03 15:19:10 by james]
james
parents: 2039
diff changeset
505 exponent = XUINT (number2);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
506 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number1));
2057
471242c84954 [xemacs-hg @ 2004-05-03 15:19:10 by james]
james
parents: 2039
diff changeset
507 bigfloat_pow (scratch_bigfloat, XBIGFLOAT_DATA (number1), exponent);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
508 return make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
509 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
510 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
511
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
513 double f1 = extract_float (number1);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
514 double f2 = extract_float (number2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 /* Really should check for overflow, too */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 if (f1 == 0.0 && f2 == 0.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 f1 = 1.0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 # ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2)))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
520 domain_error2 ("expt", number1, number2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521 # endif /* FLOAT_CHECK_DOMAIN */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
522 IN_FLOAT2 (f1 = pow (f1, f2), "expt", number1, number2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 return make_float (f1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
527 DEFUN ("log", Flog, 1, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
528 Return the natural logarithm of NUMBER.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
529 If second optional argument BASE is given, return the logarithm of
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
530 NUMBER using that base.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
532 (number, base))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
534 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 if (d <= 0.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
537 domain_error2 ("log", number, base);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 if (NILP (base))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
540 IN_FLOAT (d = log (d), "log", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 double b = extract_float (base);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 if (b <= 0.0 || b == 1.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
546 domain_error2 ("log", number, base);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 if (b == 10.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
549 IN_FLOAT2 (d = log10 (d), "log", number, base);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 else
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
551 IN_FLOAT2 (d = (log (d) / log (b)), "log", number, base);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 DEFUN ("log10", Flog10, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
558 Return the logarithm base 10 of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
560 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
562 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 if (d <= 0.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
565 domain_error ("log10", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 #endif
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
567 IN_FLOAT (d = log10 (d), "log10", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 DEFUN ("sqrt", Fsqrt, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
573 Return the square root of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
575 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
577 double d;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
578
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
579 #if defined(HAVE_BIGFLOAT) && defined(bigfloat_sqrt)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
580 if (BIGFLOATP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
581 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
582 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
583 bigfloat_sqrt (scratch_bigfloat, XBIGFLOAT_DATA (number));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
584 return make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
585 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
586 #endif /* HAVE_BIGFLOAT */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
587 d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 if (d < 0.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
590 domain_error ("sqrt", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 #endif
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
592 IN_FLOAT (d = sqrt (d), "sqrt", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 DEFUN ("cube-root", Fcube_root, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
598 Return the cube root of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
600 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
602 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 #ifdef HAVE_CBRT
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
604 IN_FLOAT (d = cbrt (d), "cube-root", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 if (d >= 0.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
607 IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 else
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
609 IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 /* Inverse trig functions. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 DEFUN ("acosh", Facosh, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
617 Return the inverse hyperbolic cosine of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
619 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
621 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 if (d < 1.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
624 domain_error ("acosh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 #ifdef HAVE_INVERSE_HYPERBOLIC
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
627 IN_FLOAT (d = acosh (d), "acosh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 #else
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
629 IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 DEFUN ("asinh", Fasinh, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
635 Return the inverse hyperbolic sine of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
637 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
639 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 #ifdef HAVE_INVERSE_HYPERBOLIC
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
641 IN_FLOAT (d = asinh (d), "asinh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 #else
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
643 IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 DEFUN ("atanh", Fatanh, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
649 Return the inverse hyperbolic tangent of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
651 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
653 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 if (d >= 1.0 || d <= -1.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
656 domain_error ("atanh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 #ifdef HAVE_INVERSE_HYPERBOLIC
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
659 IN_FLOAT (d = atanh (d), "atanh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 #else
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
661 IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 DEFUN ("cosh", Fcosh, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
667 Return the hyperbolic cosine of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
669 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
671 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 if (d > 710.0 || d < -710.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
674 range_error ("cosh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 #endif
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
676 IN_FLOAT (d = cosh (d), "cosh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 DEFUN ("sinh", Fsinh, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
681 Return the hyperbolic sine of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
683 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
685 double d = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 #ifdef FLOAT_CHECK_DOMAIN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 if (d > 710.0 || d < -710.0)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
688 range_error ("sinh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 #endif
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
690 IN_FLOAT (d = sinh (d), "sinh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 DEFUN ("tanh", Ftanh, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
695 Return the hyperbolic tangent of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
697 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
699 double d = extract_float (number);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
700 IN_FLOAT (d = tanh (d), "tanh", number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 return make_float (d);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704 /* Rounding functions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 DEFUN ("abs", Fabs, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
707 Return the absolute value of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
709 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
711 if (FLOATP (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
713 IN_FLOAT (number = make_float (fabs (XFLOAT_DATA (number))),
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
714 "abs", number);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
715 return number;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
718 if (INTP (number))
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
719 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
720 /* The most negative Lisp fixnum will overflow */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
721 return (XINT (number) >= 0) ? number : make_integer (- XINT (number));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
722 #else
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
723 return (XINT (number) >= 0) ? number : make_int (- XINT (number));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
724 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
725
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
726 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
727 if (BIGNUMP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
728 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
729 if (bignum_sign (XBIGNUM_DATA (number)) >= 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
730 return number;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
731 bignum_abs (scratch_bignum, XBIGNUM_DATA (number));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
732 return make_bignum_bg (scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
733 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
734 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
735
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
736 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
737 if (RATIOP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
738 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
739 if (ratio_sign (XRATIO_DATA (number)) >= 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
740 return number;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
741 ratio_abs (scratch_ratio, XRATIO_DATA (number));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
742 return make_ratio_rt (scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
743 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
744 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
745
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
746 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
747 if (BIGFLOATP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
748 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
749 if (bigfloat_sign (XBIGFLOAT_DATA (number)) >= 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
750 return number;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
751 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
752 bigfloat_abs (scratch_bigfloat, XBIGFLOAT_DATA (number));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
753 return make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
754 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
755 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
757 return Fabs (wrong_type_argument (Qnumberp, number));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760 DEFUN ("float", Ffloat, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
761 Return the floating point number numerically equal to NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
763 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
765 if (INTP (number))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
766 return make_float ((double) XINT (number));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
768 #ifdef HAVE_BIGNUM
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
769 if (BIGNUMP (number))
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
770 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
771 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
772 if (ZEROP (Vdefault_float_precision))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
773 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
774 return make_float (bignum_to_double (XBIGNUM_DATA (number)));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
775 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
776 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
777 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
778 bigfloat_set_prec (scratch_bigfloat, bigfloat_get_default_prec ());
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
779 bigfloat_set_bignum (scratch_bigfloat, XBIGNUM_DATA (number));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
780 return make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
781 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
782 #endif /* HAVE_BIGFLOAT */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
783 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
784 #endif /* HAVE_BIGNUM */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
785
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
786 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
787 if (RATIOP (number))
2092
f557693c61de [xemacs-hg @ 2004-05-21 20:56:26 by james]
james
parents: 2057
diff changeset
788 return make_float (ratio_to_double (XRATIO_DATA (number)));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
789 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
790
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
791 if (FLOATP (number)) /* give 'em the same float back */
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
792 return number;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
794 return Ffloat (wrong_type_argument (Qnumberp, number));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
796
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 DEFUN ("logb", Flogb, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
798 Return largest integer <= the base 2 log of the magnitude of NUMBER.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799 This is the same as the exponent of a float.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
801 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
803 double f = extract_float (number);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 if (f == 0.0)
2039
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1995
diff changeset
806 return make_int (EMACS_INT_MIN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 #ifdef HAVE_LOGB
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 Lisp_Object val;
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
810 IN_FLOAT (val = make_int ((EMACS_INT) logb (f)), "logb", number);
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 430
diff changeset
811 return val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 #ifdef HAVE_FREXP
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 int exqp;
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
817 IN_FLOAT (frexp (f, &exqp), "logb", number);
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 430
diff changeset
818 return make_int (exqp - 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 double d;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 EMACS_INT val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 if (f < 0.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 f = -f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 val = -1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 while (f < 0.5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 for (i = 1, d = 0.5; d * d >= f; i += i)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 d *= d;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832 f /= d;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 val -= i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 while (f >= 1.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837 for (i = 1, d = 2.0; d * d <= f; i += i)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838 d *= d;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839 f /= d;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 val += i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 }
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 430
diff changeset
842 return make_int (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 #endif /* ! HAVE_FREXP */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 #endif /* ! HAVE_LOGB */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
848 #ifdef WITH_NUMBER_TYPES
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
849 #define ROUNDING_CONVERT(conversion, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
850 CONVERT_WITH_NUMBER_TYPES(conversion, return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
851 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
852 #define ROUNDING_CONVERT(conversion, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
853 CONVERT_WITHOUT_NUMBER_TYPES(conversion, return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
854 #endif
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
855
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
856 #define CONVERT_WITH_NUMBER_TYPES(conversion, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
857 if (!NILP (divisor)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
858 { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
859 switch (promote_args (&number, &divisor)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
860 { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
861 case FIXNUM_T: \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
862 return conversion##_two_fixnum (number, divisor, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
863 return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
864 MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
865 BIGNUM, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
866 return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
867 MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
868 RATIO, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
869 return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
870 MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
871 BIGFLOAT, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
872 return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
873 default: /* FLOAT_T */ \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
874 return conversion##_two_float (number,divisor, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
875 return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
876 } \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
877 } \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
878 \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
879 /* Try this first, the arg is probably a float: */ \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
880 if (FLOATP (number)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
881 return conversion##_one_float (number, return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
882 \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
883 MAYBE_ONE_ARG_WITH_NUMBER_TYPES (conversion, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
884 RATIO, return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
885 MAYBE_ONE_ARG_WITH_NUMBER_TYPES (conversion, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
886 BIGFLOAT, return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
887 return conversion##_one_mundane_arg (number, divisor, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
888 return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
889
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
890 #define CONVERT_WITHOUT_NUMBER_TYPES(conversion, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
891 if (!NILP (divisor)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
892 { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
893 /* The promote_args call if number types are available \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
894 does these conversions, we do them too for symmetry: */\
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
895 if (CHARP (number)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
896 { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
897 number = make_int (XCHAR (number)); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
898 } \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
899 else if (MARKERP (number)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
900 { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
901 number = make_int (marker_position (number)); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
902 } \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
903 \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
904 if (CHARP (divisor)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
905 { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
906 divisor = make_int (XCHAR (divisor)); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
907 } \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
908 else if (MARKERP (divisor)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
909 { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
910 divisor = make_int (marker_position (divisor)); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
911 } \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
912 \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
913 CHECK_INT_OR_FLOAT (divisor); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
914 if (INTP (number) && INTP (divisor)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
915 { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
916 return conversion##_two_fixnum (number, divisor, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
917 return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
918 } \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
919 else \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
920 { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
921 return conversion##_two_float (number, divisor, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
922 return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
923 } \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
924 } \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
925 \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
926 /* Try this first, the arg is probably a float: */ \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
927 if (FLOATP (number)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
928 return conversion##_one_float (number, return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
929 \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
930 return conversion##_one_mundane_arg (number, divisor, \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
931 return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
932
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
933 #ifdef WITH_NUMBER_TYPES
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
934
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
935 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
936 #define MAYBE_TWO_ARGS_BIGNUM(conversion, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
937 case BIGNUM_T: \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
938 return conversion##_two_bignum (number, divisor, return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
939
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
940 #define MAYBE_ONE_ARG_BIGNUM(converse, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
941 if (BIGNUM_P (number)) \
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
942 return conversion##_one_bignum (number, divisor, return_float)
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
943 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
944 #define MAYBE_TWO_ARGS_BIGNUM(conversion, return_float)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
945 #define MAYBE_ONE_ARG_BIGNUM(converse, return_float)
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
946 #endif
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
947
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
948 #ifdef HAVE_RATIO
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
949 #define MAYBE_TWO_ARGS_RATIO(conversion, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
950 case RATIO_T: \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
951 return conversion##_two_ratio (number, divisor, return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
952
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
953 #define MAYBE_ONE_ARG_RATIO(conversion, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
954 if (RATIOP (number)) \
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
955 return conversion##_one_ratio (number, divisor, return_float)
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
956 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
957 #define MAYBE_TWO_ARGS_RATIO(conversion, return_float)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
958 #define MAYBE_ONE_ARG_RATIO(converse, return_float)
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
959 #endif
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
960
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
961 #ifdef HAVE_BIGFLOAT
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
962 #define MAYBE_TWO_ARGS_BIGFLOAT(conversion, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
963 case BIGFLOAT_T: \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
964 return conversion##_two_bigfloat (number, divisor, return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
965
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
966 #define MAYBE_ONE_ARG_BIGFLOAT(conversion, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
967 if (BIGFLOATP (number)) \
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
968 return conversion##_one_bigfloat (number, divisor, return_float)
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
969 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
970 #define MAYBE_TWO_ARGS_BIGFLOAT(conversion, return_float)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
971 #define MAYBE_ONE_ARG_BIGFLOAT(converse, return_float)
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
972 #endif
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
973
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
974 #define MAYBE_TWO_ARGS_WITH_NUMBER_TYPES(convers, upcase, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
975 MAYBE_TWO_ARGS_##upcase(convers, return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
976
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
977 #define MAYBE_ONE_ARG_WITH_NUMBER_TYPES(convers, upcase, return_float) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
978 MAYBE_ONE_ARG_##upcase(convers, return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
979
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
980 #endif /* WITH_NUMBER_TYPES */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
981
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
982 #define MAYBE_EFF(str) (return_float ? "f" str : str)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
983
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
984 /* The WITH_NUMBER_TYPES code calls promote_args, which accepts chars and
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
985 markers as equivalent to ints. This block does the same for
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
986 single-argument calls. */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
987 #define MAYBE_CHAR_OR_MARKER(conversion) do { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
988 if (CHARP (number)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
989 { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
990 return conversion##_one_mundane_arg (make_int (XCHAR (number)), \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
991 divisor, return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
992 } \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
993 \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
994 if (MARKERP (number)) \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
995 { \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
996 return conversion##_one_mundane_arg (make_int \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
997 (marker_position(number)), \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
998 divisor, return_float); \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
999 } \
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1000 } while (0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1001
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1002
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1003 /* The guts of the implementations of the various rounding functions: */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1004
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1005 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1006 ceiling_two_fixnum (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1007 int return_float)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1009 EMACS_INT i1 = XREALINT (number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1010 EMACS_INT i2 = XREALINT (divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1011 EMACS_INT i3 = 0, i4 = 0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1012
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1013 if (i2 == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1014 return arith_error2 ("ceiling", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1015
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1016 /* With C89's integer /, the result is implementation-defined if either
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1017 operand is negative, so use only nonnegative operands. Here we do
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1018 basically the opposite of what floor_two_fixnum does, we add one in the
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1019 non-negative case: */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1020
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1021 /* Make sure we use the same signs for the modulus calculation as for the
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1022 quotient calculation: */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1023 if (i2 < 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1024 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1025 if (i1 <= 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1026 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1027 i3 = -i1 / -i2;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1028 /* Quotient is positive; add one to give the figure for
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1029 ceiling. */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1030 if (0 != (-i1 % -i2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1031 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1032 ++i3;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1033 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1034 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1035 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1036 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1037 /* Quotient is negative; no need to add one. */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1038 i3 = -(i1 / -i2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1039 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1040 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1041 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1042 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1043 if (i1 < 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1044 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1045 /* Quotient is negative; no need to add one. */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1046 i3 = -(-i1 / i2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1047 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1048 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1049 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1050 i3 = i1 / i2;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1051 /* Quotient is positive; add one to give the figure for
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1052 ceiling. */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1053 if (0 != (i1 % i2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1054 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1055 ++i3;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1056 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1057 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1058 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1059
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1060 i4 = i1 - (i3 * i2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1061
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1062 if (!return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1063 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1064 return values2 (make_int (i3), make_int (i4));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1065 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1066
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1067 return values2 (make_float ((double)i3),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1068 make_int (i4));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1069 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1070
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1071 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1072 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1073 ceiling_two_bignum (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1074 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1075 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1076 Lisp_Object res0, res1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1077
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1078 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1079 return arith_error2 ("ceiling", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1080
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1081 bignum_ceil (scratch_bignum, XBIGNUM_DATA (number), XBIGNUM_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1082
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1083 res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) :
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1084 Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1085
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1086 if (bignum_divisible_p (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1087 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1088 res1 = Qzero;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1089 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1090 else
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1091 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1092 bignum_mul (scratch_bignum, scratch_bignum, XBIGNUM_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1093 bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1094 res1 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1095 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1096
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1097 return values2 (res0, res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1098 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1099 #endif /* HAVE_BIGNUM */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1100
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1101 #ifdef HAVE_RATIO
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1102 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1103 ceiling_two_ratio (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1104 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1105 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1106 Lisp_Object res0, res1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1107
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1108 if (ratio_sign (XRATIO_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1109 return arith_error2 ("ceiling", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1110
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1111 ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1112
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1113 bignum_ceil (scratch_bignum, ratio_numerator (scratch_ratio),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1114 ratio_denominator (scratch_ratio));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1115
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1116 res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) :
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1117 Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1118
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1119 if (bignum_divisible_p (ratio_numerator (scratch_ratio),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1120 ratio_denominator (scratch_ratio)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1121 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1122 res1 = Qzero;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1123 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1124 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1125 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1126 ratio_set_bignum (scratch_ratio, scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1127 ratio_mul (scratch_ratio2, scratch_ratio, XRATIO_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1128 ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1129 res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1130 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1131
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1132 return values2 (res0, res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1133 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1134 #endif /* HAVE_RATIO */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1135
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1136 #ifdef HAVE_BIGFLOAT
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1137 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1138 ceiling_two_bigfloat (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1139 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1140 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1141 Lisp_Object res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1142
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1143 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1144 return arith_error2 ("ceiling", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1145
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1146 bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1147 XBIGFLOAT_GET_PREC (divisor)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1148 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1149 XBIGFLOAT_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1150 bigfloat_ceil (scratch_bigfloat, scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1151
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1152 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1153 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1154 res0 = make_bigfloat_bf (scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1155 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1156 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1157 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1158 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1159 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1160 res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1161 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1162 res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1163 #endif /* HAVE_BIGNUM */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1164 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1165
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1166 bigfloat_mul (scratch_bigfloat, scratch_bigfloat, XBIGFLOAT_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1167 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1168 return values2 (res0,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1169 Fcanonicalize_number (make_bigfloat_bf (scratch_bigfloat)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1170 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1171 #endif /* HAVE_BIGFLOAT */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1172
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1173 #ifdef HAVE_RATIO
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1174 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1175 ceiling_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1176 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1177 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1178 Lisp_Object res0, res1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1179
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1180 bignum_ceil (scratch_bignum, XRATIO_NUMERATOR (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1181 XRATIO_DENOMINATOR (number));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1182
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1183 res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) :
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1184 Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1185
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1186 if (bignum_divisible_p (XRATIO_NUMERATOR (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1187 XRATIO_DENOMINATOR (number)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1188 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1189 res1 = Qzero;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1190 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1191 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1192 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1193 ratio_set_bignum (scratch_ratio2, scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1194 ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1195 res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1196 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1197
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1198 return values2 (res0, res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1199 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1200 #endif /* HAVE_RATIO */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1201
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1202 #ifdef HAVE_BIGFLOAT
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1203 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1204 ceiling_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1205 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1206 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1207 Lisp_Object res0, res1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1208
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1209 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1210 bigfloat_ceil (scratch_bigfloat, XBIGFLOAT_DATA (number));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1211
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1212 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1213 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1214 res0 = make_bigfloat_bf (scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1215 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1216 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1217 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1218 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1219 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1220 res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1221 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1222 res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1223 #endif /* HAVE_BIGNUM */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1224 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1225
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1226 bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1227
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1228 res1 = make_bigfloat_bf (scratch_bigfloat2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1229 return values2 (res0, res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1230 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1231 #endif /* HAVE_BIGFLOAT */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1232
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1233 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1234 ceiling_two_float (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1235 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1236 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1237 double f1 = extract_float (number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1238 double f2 = extract_float (divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1239 double f0, remain;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1240 Lisp_Object res0;
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1241
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1242 if (f2 == 0.0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1243 return arith_error2 ("ceiling", number, divisor);
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1244
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1245 IN_FLOAT2 (f0 = ceil (f1 / f2), MAYBE_EFF("ceiling"), number, divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1246 IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF("ceiling"), number, divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1247
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1248 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1249 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1250 res0 = make_float(f0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1251 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1252 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1253 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1254 res0 = float_to_int (f0, MAYBE_EFF("ceiling"), number, divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1255 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1256
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1257 return values2 (res0, make_float (remain));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1258 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1259
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1260 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1261 ceiling_one_float (Lisp_Object number, int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1262 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1263 double d, remain;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1264 Lisp_Object res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1265
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1266 IN_FLOAT ((d = ceil (XFLOAT_DATA (number))), MAYBE_EFF("ceiling"), number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1267 IN_FLOAT ((remain = XFLOAT_DATA (number) - d), MAYBE_EFF("ceiling"), number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1268
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1269 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1270 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1271 res0 = make_float (d);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1272 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1273 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1274 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1275 res0 = float_to_int (d, MAYBE_EFF("ceiling"), number, Qunbound);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1276 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1277 return values2 (res0, make_float (remain));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1278 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1279
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1280 EXFUN (Fceiling, 2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1281 EXFUN (Ffceiling, 2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1282
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1283 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1284 ceiling_one_mundane_arg (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1285 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1286 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1287
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1288 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1289 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1290 if (INTP (number))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1291 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1292 return values2 (make_float ((double) XINT (number)), Qzero);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1293 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1294 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1295 else if (BIGNUMP (number))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1296 {
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1297 return values2 (make_float
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1298 (bignum_to_double (XBIGNUM_DATA (number))),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1299 Qzero);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1300 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1301 #endif
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1302 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1303 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1304 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1305 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1306 if (INTEGERP (number))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1307 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1308 if (INTP (number))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1309 #endif
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1310 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1311 return values2 (number, Qzero);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1312 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1313 }
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1314
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1315 MAYBE_CHAR_OR_MARKER (ceiling);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1316
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1317 return Ffceiling (wrong_type_argument (Qnumberp, number), divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1318 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1319
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1320 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1321 floor_two_fixnum (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1322 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1323 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1324 EMACS_INT i1 = XREALINT (number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1325 EMACS_INT i2 = XREALINT (divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1326 EMACS_INT i3 = 0, i4 = 0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1327 Lisp_Object res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1328
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1329 if (i2 == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1330 return arith_error2 ("floor", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1331
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1332 /* With C89's integer /, the result is implementation-defined if either
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1333 operand is negative, so use only nonnegative operands. Notice also that
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1334 we're forcing the quotient of any negative numbers towards minus
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1335 infinity. */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1336 i3 = (i2 < 0
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1337 ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1338 : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1339
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1340 i4 = i1 - (i3 * i2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1341
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1342 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1343 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1344 res0 = make_float ((double)i3);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1345 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1346 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1347 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1348 res0 = make_int (i3);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1349 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1350
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1351 return values2 (res0, make_int (i4));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1352 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1353
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1354 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1355 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1356 floor_two_bignum (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1357 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1358 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1359 Lisp_Object res0, res1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1360
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1361 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1362 return arith_error2 ("floor", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1363
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1364 bignum_floor (scratch_bignum, XBIGNUM_DATA (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1365 XBIGNUM_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1366
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1367 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1368 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1369 res0 = make_float (bignum_to_double (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1370 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1371 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1372 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1373 res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1374 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1375
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1376 if (bignum_divisible_p (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1377 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1378 res1 = Qzero;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1379 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1380 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1381 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1382 bignum_mul (scratch_bignum, scratch_bignum, XBIGNUM_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1383 bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1384 res1 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1385 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1386
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1387 return values2 (res0, res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1388 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1389 #endif /* HAVE_BIGNUM */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1390
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1391 #ifdef HAVE_RATIO
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1392 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1393 floor_two_ratio (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1394 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1395 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1396 Lisp_Object res0, res1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1397
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1398 if (ratio_sign (XRATIO_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1399 return arith_error2 ("floor", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1400
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1401 ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1402
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1403 bignum_floor (scratch_bignum, ratio_numerator (scratch_ratio),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1404 ratio_denominator (scratch_ratio));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1405
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1406 res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) :
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1407 Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1408
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1409 if (bignum_divisible_p (ratio_numerator (scratch_ratio),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1410 ratio_denominator (scratch_ratio)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1411 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1412 res1 = Qzero;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1413 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1414 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1415 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1416 ratio_set_bignum (scratch_ratio, scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1417 ratio_mul (scratch_ratio, scratch_ratio, XRATIO_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1418 ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1419 res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1420 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1421
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1422 return values2 (res0, res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1423 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1424 #endif /* HAVE_RATIO */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1425
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1426 #ifdef HAVE_BIGFLOAT
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1427 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1428 floor_two_bigfloat (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1429 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1430 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1431 Lisp_Object res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1432
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1433 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1434 return arith_error2 ("floor", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1435
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1436 bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1437 XBIGFLOAT_GET_PREC (divisor)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1438 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1439 XBIGFLOAT_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1440 bigfloat_floor (scratch_bigfloat, scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1441
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1442 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1443 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1444 res0 = make_bigfloat_bf (scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1445 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1446 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1447 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1448 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1449 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1450 res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1451 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1452 res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1453 #endif /* HAVE_BIGNUM */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1454 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1455
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1456 bigfloat_mul (scratch_bigfloat2, scratch_bigfloat,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1457 XBIGFLOAT_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1458 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1459
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1460 return values2 (res0, make_bigfloat_bf (scratch_bigfloat));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1461 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1462 #endif /* HAVE_BIGFLOAT */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1463
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1464 #ifdef HAVE_RATIO
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1465 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1466 floor_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1467 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1468 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1469 Lisp_Object res0, res1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1470
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1471 bignum_floor (scratch_bignum, XRATIO_NUMERATOR (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1472 XRATIO_DENOMINATOR (number));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1473
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1474 res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) :
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1475 Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1476
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1477 if (bignum_divisible_p (XRATIO_NUMERATOR (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1478 XRATIO_DENOMINATOR (number)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1479 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1480 res1 = Qzero;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1481 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1482 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1483 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1484 ratio_set_bignum (scratch_ratio2, scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1485 ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1486 res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1487 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1488
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1489 return values2 (res0, res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1490 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1491 #endif /* HAVE_RATIO */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1492
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1493 #ifdef HAVE_BIGFLOAT
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1494 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1495 floor_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1496 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1497 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1498 Lisp_Object res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1499
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1500 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1501 bigfloat_floor (scratch_bigfloat, XBIGFLOAT_DATA (number));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1502
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1503 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1504 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1505 res0 = make_bigfloat_bf (scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1506 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1507 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1508 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1509 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1510 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1511 res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1512 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1513 res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1514 #endif /* HAVE_BIGNUM */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1515 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1516
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1517 bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1518 return values2 (res0, make_bigfloat_bf (scratch_bigfloat2));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1519 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1520 #endif /* HAVE_BIGFLOAT */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1521
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1522 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1523 floor_two_float (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1524 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1525 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1526 double f1 = extract_float (number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1527 double f2 = extract_float (divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1528 double f0, remain;
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1529
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1530 if (f2 == 0.0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1531 return arith_error2 ("floor", number, divisor);
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1532
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1533 IN_FLOAT2 (f0 = floor (f1 / f2), MAYBE_EFF ("floor"), number, divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1534 IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("floor"), number, divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1535
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1536 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1537 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1538 return values2 (make_float (f0), make_float (remain));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1539 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1540
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1541 return values2 (float_to_int (f0, MAYBE_EFF ("floor"), number, divisor),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1542 make_float (remain));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1543 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1544
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1545 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1546 floor_one_float (Lisp_Object number, int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1547 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1548 double d, d1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1549
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1550 IN_FLOAT ((d = floor (XFLOAT_DATA (number))), MAYBE_EFF ("floor"), number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1551 IN_FLOAT ((d1 = XFLOAT_DATA (number) - d), MAYBE_EFF ("floor"), number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1552
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1553 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1554 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1555 return values2 (make_float (d), make_float (d1));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1556 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1557 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1558 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1559 return values2 (float_to_int (d, MAYBE_EFF ("floor"), number, Qunbound),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1560 make_float (d1));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1561 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1562 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1563
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1564 EXFUN (Ffloor, 2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1565 EXFUN (Fffloor, 2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1566
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1567 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1568 floor_one_mundane_arg (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1569 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1570 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1571 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1572 if (INTEGERP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1573 #else
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1574 if (INTP (number))
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1575 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1576 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1577 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1578 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1579 return values2 (make_float (extract_float (number)), Qzero);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1580 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1581 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1582 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1583 return values2 (number, Qzero);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1584 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1585 }
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1586
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1587 MAYBE_CHAR_OR_MARKER (floor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1588
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1589 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1590 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1591 return Fffloor (wrong_type_argument (Qnumberp, number), divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1592 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1593 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1594 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1595 return Ffloor (wrong_type_argument (Qnumberp, number), divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1596 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1597 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1598
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1599 /* Algorithm taken from cl-extra.el, now to be found as cl-round in
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1600 tests/automated/lisp-tests.el. */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1601 static Lisp_Object
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1602 round_two_fixnum (Lisp_Object number, Lisp_Object divisor, int return_float)
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1603 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1604 EMACS_INT i1 = XREALINT (number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1605 EMACS_INT i2 = XREALINT (divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1606 EMACS_INT i0, hi2, flooring, floored, flsecond;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1607
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1608 if (i2 == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1609 return arith_error2 ("round", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1610
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1611 hi2 = i2 < 0 ? -( -i2 / 2) : i2 / 2;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1612
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1613 flooring = hi2 + i1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1614
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1615 floored = (i2 < 0
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1616 ? (flooring <= 0 ? -flooring / -i2 : -1 - ((flooring - 1) / -i2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1617 : (flooring < 0 ? -1 - ((-1 - flooring) / i2) : flooring / i2));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1618
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1619 flsecond = flooring - (floored * i2);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1620
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1621 if (0 == flsecond
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1622 && (i2 == (hi2 + hi2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1623 && (0 != (floored % 2)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1624 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1625 i0 = floored - 1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1626 return values2 (return_float ? make_float ((double)i0) :
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1627 make_int (i0), make_int (hi2));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1628 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1629 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1630 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1631 return values2 (return_float ? make_float ((double)floored) :
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1632 make_int (floored),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1633 make_int (flsecond - hi2));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1634 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1635 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1636
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1637 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1638 static void
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1639 round_two_bignum_1 (bignum number, bignum divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1640 Lisp_Object *res, Lisp_Object *remain)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1641 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1642 bignum flooring, floored, hi2, flsecond;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1643
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1644 if (bignum_divisible_p (number, divisor))
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1645 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1646 bignum_div (scratch_bignum, number, divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1647 *res = make_bignum_bg (scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1648 *remain = Qzero;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1649 return;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1650 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1651
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1652 bignum_set_long (scratch_bignum, 2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1653
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1654 bignum_div (scratch_bignum2, divisor, scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1655
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1656 bignum_init (hi2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1657 bignum_set (hi2, scratch_bignum2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1658
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1659 bignum_add (scratch_bignum, scratch_bignum2, number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1660 bignum_init (flooring);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1661 bignum_set (flooring, scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1662
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1663 bignum_floor (scratch_bignum, flooring, divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1664 bignum_init (floored);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1665 bignum_set (floored, scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1666
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1667 bignum_mul (scratch_bignum2, scratch_bignum, divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1668 bignum_sub (scratch_bignum, flooring, scratch_bignum2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1669 bignum_init (flsecond);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1670 bignum_set (flsecond, scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1671
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1672 bignum_set_long (scratch_bignum, 2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1673 bignum_mul (scratch_bignum2, scratch_bignum, hi2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1674
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1675 if (bignum_sign (flsecond) == 0
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1676 && bignum_eql (divisor, scratch_bignum2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1677 && (1 == bignum_testbit (floored, 0)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1678 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1679 bignum_set_long (scratch_bignum, 1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1680 bignum_sub (floored, floored, scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1681 *res = make_bignum_bg (floored);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1682 *remain = make_bignum_bg (hi2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1683 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1684 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1685 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1686 bignum_sub (scratch_bignum, flsecond,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1687 hi2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1688 *res = make_bignum_bg (floored);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1689 *remain = make_bignum_bg (scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1690 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1691 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1692
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1693 static Lisp_Object
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1694 round_two_bignum (Lisp_Object number, Lisp_Object divisor, int return_float)
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1695 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1696 Lisp_Object res0, res1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1697
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1698 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1699 return arith_error2 ("round", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1700
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1701 round_two_bignum_1 (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1702 &res0, &res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1703
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1704 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1705 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1706 res0 = make_float (bignum_to_double (XBIGNUM_DATA (res0)));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1707 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1708 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1709 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1710 res0 = Fcanonicalize_number (res0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1711 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1712
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1713 return values2 (res0, Fcanonicalize_number (res1));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1714 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1715 #endif /* HAVE_BIGNUM */
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1716
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1717 #ifdef HAVE_RATIO
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1718 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1719 round_two_ratio (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1720 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1721 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1722 Lisp_Object res0, res1;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1723
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1724 if (ratio_sign (XRATIO_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1725 return arith_error2 ("round", number, divisor);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1726
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1727 ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor));
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1728
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1729 round_two_bignum_1 (ratio_numerator (scratch_ratio),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1730 ratio_denominator (scratch_ratio), &res0, &res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1731
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1732 if (!ZEROP (res1))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1733 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1734 /* The numerator and denominator don't round exactly, calculate a
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1735 ratio remainder: */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1736 ratio_set_bignum (scratch_ratio2, XBIGNUM_DATA (res0));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1737 ratio_mul (scratch_ratio, scratch_ratio2, XRATIO_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1738 ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio);
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1739
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1740 res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1741 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1742
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1743 res0 = return_float ?
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1744 make_float ((double)bignum_to_double(XBIGNUM_DATA (res0))) :
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1745 Fcanonicalize_number (res0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1746
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1747 return values2 (res0, res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1748 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1749 #endif /* HAVE_RATIO */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1750
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1751 #ifdef HAVE_BIGFLOAT
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1752 /* This is the logic of emacs_rint above, no more and no less. */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1753 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1754 round_one_bigfloat_1 (bigfloat number)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1755 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1756 Lisp_Object res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1757 unsigned long prec = bigfloat_get_prec (number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1758
4828
f31c12360354 fix warnings
Ben Wing <ben@xemacs.org>
parents: 4717
diff changeset
1759 #if 0
f31c12360354 fix warnings
Ben Wing <ben@xemacs.org>
parents: 4717
diff changeset
1760 /* This causes the following GCC warning:
f31c12360354 fix warnings
Ben Wing <ben@xemacs.org>
parents: 4717
diff changeset
1761
f31c12360354 fix warnings
Ben Wing <ben@xemacs.org>
parents: 4717
diff changeset
1762 /xemacs/latest-fix/src/floatfns.c:1764: warning: dereferencing type-punned pointer will break strict-aliasing rules
f31c12360354 fix warnings
Ben Wing <ben@xemacs.org>
parents: 4717
diff changeset
1763
f31c12360354 fix warnings
Ben Wing <ben@xemacs.org>
parents: 4717
diff changeset
1764 and furthermore, it's a useless assert, since `number' is stored on
f31c12360354 fix warnings
Ben Wing <ben@xemacs.org>
parents: 4717
diff changeset
1765 the stack and so its address can never be the same as `scratch_bigfloat'
f31c12360354 fix warnings
Ben Wing <ben@xemacs.org>
parents: 4717
diff changeset
1766 or `scratch_bigfloat2', which are stored in the data segment.
f31c12360354 fix warnings
Ben Wing <ben@xemacs.org>
parents: 4717
diff changeset
1767
f31c12360354 fix warnings
Ben Wing <ben@xemacs.org>
parents: 4717
diff changeset
1768 -- ben */
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1769 assert ((bigfloat *)(&number) != (bigfloat *)&scratch_bigfloat
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1770 && (bigfloat *)(&number) != (bigfloat *)(&scratch_bigfloat2));
4828
f31c12360354 fix warnings
Ben Wing <ben@xemacs.org>
parents: 4717
diff changeset
1771 #endif
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1772
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1773 bigfloat_set_prec (scratch_bigfloat, prec);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1774 bigfloat_set_prec (scratch_bigfloat2, prec);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1775
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1776 bigfloat_set_double (scratch_bigfloat, 0.5);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1777 bigfloat_add (scratch_bigfloat2, scratch_bigfloat, number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1778 bigfloat_floor (scratch_bigfloat, scratch_bigfloat2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1779 res0 = make_bigfloat_bf (scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1780
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1781 bigfloat_sub (scratch_bigfloat2, scratch_bigfloat, number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1782 bigfloat_abs (scratch_bigfloat, scratch_bigfloat2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1783
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1784 bigfloat_set_double (scratch_bigfloat2, 0.5);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1785
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1786 do {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1787 if (!bigfloat_ge (scratch_bigfloat, scratch_bigfloat2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1788 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1789 break;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1790 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1791
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1792 if (!bigfloat_gt (scratch_bigfloat, scratch_bigfloat2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1793 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1794 bigfloat_set_double (scratch_bigfloat2, 2.0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1795 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (res0),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1796 scratch_bigfloat2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1797 bigfloat_floor (scratch_bigfloat2, scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1798 bigfloat_set_double (scratch_bigfloat, 2.0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1799 bigfloat_mul (scratch_bigfloat2, scratch_bigfloat2,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1800 scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1801 if (bigfloat_eql (scratch_bigfloat2, XBIGFLOAT_DATA (res0)))
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
1802 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1803 break;
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
1804 }
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1805 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1806
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1807 if (bigfloat_lt (XBIGFLOAT_DATA (res0), number))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1808 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1809 bigfloat_set_double (scratch_bigfloat2, 1.0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1810 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1811 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1812 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1813 bigfloat_set_double (scratch_bigfloat2, -1.0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1814 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1815
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1816 bigfloat_set (scratch_bigfloat, XBIGFLOAT_DATA (res0));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1817
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1818 bigfloat_add (XBIGFLOAT_DATA (res0), scratch_bigfloat2,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1819 scratch_bigfloat);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1821 } while (0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1822
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1823 return res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1824 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1825
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1826 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1827 round_two_bigfloat (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1828 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1829 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1830 Lisp_Object res0, res1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1831 bigfloat divided;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1832
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1833 unsigned long prec = max (XBIGFLOAT_GET_PREC (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1834 XBIGFLOAT_GET_PREC (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1835
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1836 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1837 return arith_error2 ("round", number, divisor);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1838
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1839 bigfloat_init (divided);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1840 bigfloat_set_prec (divided, prec);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1841
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1842 bigfloat_div (divided, XBIGFLOAT_DATA (number), XBIGFLOAT_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1843
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1844 res0 = round_one_bigfloat_1 (divided);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1845
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1846 bigfloat_set_prec (scratch_bigfloat, prec);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1847 bigfloat_set_prec (scratch_bigfloat2, prec);
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1848
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1849 bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (res0),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1850 XBIGFLOAT_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1851 bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1852 scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1853
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1854 res1 = make_bigfloat_bf (scratch_bigfloat2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1855
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1856 if (!return_float)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1857 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1858 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1859 bignum_set_bigfloat (scratch_bignum, XBIGFLOAT_DATA (res0));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1860 res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1861 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1862 res0 = make_int ((EMACS_INT) bigfloat_to_long (XBIGFLOAT_DATA (res0)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1863 #endif /* HAVE_BIGNUM */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1864 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1865
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1866 return values2 (res0, res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1867 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1868 #endif /* HAVE_BIGFLOAT */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1869
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1870 #ifdef HAVE_RATIO
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1871 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1872 round_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1873 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1874 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1875 Lisp_Object res0, res1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1876
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1877 round_two_bignum_1 (XRATIO_NUMERATOR (number), XRATIO_DENOMINATOR (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1878 &res0, &res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1879
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1880 if (!ZEROP (res1))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1881 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1882 ratio_set_bignum (scratch_ratio2, XBIGNUM_DATA (res0));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1883 ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1884 res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1886
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1887 res0 = return_float ?
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1888 make_float ((double)bignum_to_double(XBIGNUM_DATA (res0))) :
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1889 Fcanonicalize_number (res0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1890
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1891 return values2 (res0, res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1892 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1893 #endif /* HAVE_RATIO */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1894
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1895 #ifdef HAVE_BIGFLOAT
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1896 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1897 round_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1898 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1899 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1900 Lisp_Object res0 = round_one_bigfloat_1 (XBIGFLOAT_DATA (number));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1901 Lisp_Object res1;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1902
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1903 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number),
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1904 XBIGFLOAT_DATA (res0));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1905
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1906 res1 = make_bigfloat_bf (scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1907
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1908 if (!return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1909 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1910 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1911 bignum_set_bigfloat (scratch_bignum, XBIGFLOAT_DATA (res0));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1912 res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1913 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1914 res0 = make_int ((EMACS_INT) bigfloat_to_long
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1915 (XBIGFLOAT_DATA (res0)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1916 #endif /* HAVE_BIGNUM */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1917 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1918
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1919 return values2 (res0, res1);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1920 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1921 #endif /* HAVE_BIGFLOAT */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1922
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1923 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1924 round_two_float (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1925 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1926 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1927 double f1 = extract_float (number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1928 double f2 = extract_float (divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1929 double f0, remain;
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1930
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1931 if (f2 == 0.0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1932 return arith_error2 ("round", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1933
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1934 IN_FLOAT2 ((f0 = emacs_rint (f1 / f2)), MAYBE_EFF ("round"), number,
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1935 divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1936 IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("round"), number, divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1937
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1938 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1939 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1940 return values2 (make_float (f0), make_float (remain));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1941 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1942 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1943 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1944 return values2 (float_to_int (f0, MAYBE_EFF("round"), number, divisor),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1945 make_float (remain));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1946 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1947 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1948
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1949 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1950 round_one_float (Lisp_Object number, int return_float)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1952 double d;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1953 /* Screw the prevailing rounding mode. */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1954 IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (number))), MAYBE_EFF ("round"),
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1955 number);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1956
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1957 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1958 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1959 return values2 (make_float (d), make_float (XFLOAT_DATA (number) - d));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1960 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1961 else
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1963 return values2 ((float_to_int (d, MAYBE_EFF ("round"), number,
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1964 Qunbound)),
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1965 make_float (XFLOAT_DATA (number) - d));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 }
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1967 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1968
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1969 EXFUN (Fround, 2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1970 EXFUN (Ffround, 2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1971
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1972 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1973 round_one_mundane_arg (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1974 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1975 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1976 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1977 if (INTEGERP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1978 #else
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1979 if (INTP (number))
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1980 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1981 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1982 if (return_float)
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1983 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1984 return values2 (make_float (extract_float (number)), Qzero);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1985 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1986 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1987 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1988 return values2 (number, Qzero);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
1989 }
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1990 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1991
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1992 MAYBE_CHAR_OR_MARKER (round);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1993
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1994 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1995 {
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
1996 return Ffround (wrong_type_argument (Qnumberp, number), divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1997 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1998 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
1999 {
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
2000 return Fround (wrong_type_argument (Qnumberp, number), divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2001 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2002 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2003
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2004 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2005 truncate_two_fixnum (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2006 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2007 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2008 EMACS_INT i1 = XREALINT (number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2009 EMACS_INT i2 = XREALINT (divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2010 EMACS_INT i0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2011
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2012 if (i2 == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
2013 return arith_error2 ("truncate", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2014
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2015 /* We're truncating towards zero, so apart from avoiding the C89
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2016 implementation-defined behaviour with truncation and negative numbers,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2017 we don't need to do anything further: */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2018 i0 = (i2 < 0
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2019 ? (i1 <= 0 ? -i1 / -i2 : -(i1 / -i2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2020 : (i1 < 0 ? -(-i1 / i2) : i1 / i2));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2021
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2022 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2023 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2024 return values2 (make_float ((double)i0), make_int (i1 - (i0 * i2)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2025 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2026 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2027 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2028 return values2 (make_int (i0), make_int (i1 - (i0 * i2)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2029 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2030 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2031
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2032 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2033 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2034 truncate_two_bignum (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2035 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2036 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2037 Lisp_Object res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2038
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2039 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
2040 return arith_error2 ("truncate", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2041
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2042 bignum_div (scratch_bignum, XBIGNUM_DATA (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2043 XBIGNUM_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2044
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2045 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2046 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2047 res0 = make_float (bignum_to_double (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2048 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2049 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2050 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2051 res0 = make_bignum_bg (scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2052 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2053
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2054 if (bignum_divisible_p (XBIGNUM_DATA (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2055 XBIGNUM_DATA (divisor)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2056 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2057 return values2 (Fcanonicalize_number (res0), Qzero);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2058 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2059
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2060 bignum_mul (scratch_bignum2, scratch_bignum, XBIGNUM_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2061 bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2062
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2063 return values2 (Fcanonicalize_number (res0),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2064 Fcanonicalize_number (make_bignum_bg (scratch_bignum)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2065 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2066 #endif /* HAVE_BIGNUM */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2067
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2068 #ifdef HAVE_RATIO
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2069 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2070 truncate_two_ratio (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2071 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2072 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2073 Lisp_Object res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2074
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2075 if (ratio_sign (XRATIO_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
2076 return arith_error2 ("truncate", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2077
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2078 ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2079
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2080 bignum_div (scratch_bignum, ratio_numerator (scratch_ratio),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2081 ratio_denominator (scratch_ratio));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2082
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2083 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2084 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2085 res0 = make_float (bignum_to_double (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2086 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2087 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2088 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2089 res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2090 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2091
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2092 if (bignum_divisible_p (ratio_numerator (scratch_ratio),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2093 ratio_denominator (scratch_ratio)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2094 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2095 return values2 (res0, Qzero);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2096 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2097
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2098 ratio_set_bignum (scratch_ratio2, scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2099 ratio_mul (scratch_ratio, scratch_ratio2, XRATIO_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2100 ratio_sub (scratch_ratio2, XRATIO_DATA (number), scratch_ratio);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2101
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2102 return values2 (res0, Fcanonicalize_number (make_ratio_rt(scratch_ratio2)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2103 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2104 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2105
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2106 #ifdef HAVE_BIGFLOAT
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2107 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2108 truncate_two_bigfloat (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2109 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2110 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2111 Lisp_Object res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2112 unsigned long prec = max (XBIGFLOAT_GET_PREC (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2113 XBIGFLOAT_GET_PREC (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2114
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2115 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
2116 return arith_error2 ("truncate", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2117
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2118 bigfloat_set_prec (scratch_bigfloat, prec);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2119 bigfloat_set_prec (scratch_bigfloat2, prec);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2120
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2121 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2122 XBIGFLOAT_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2123 bigfloat_trunc (scratch_bigfloat, scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2124
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2125 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2126 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2127 res0 = make_bigfloat_bf (scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2128 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2129 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2130 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2131 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2132 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2133 res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2134 #else
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2135 res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2136 #endif /* HAVE_BIGNUM */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2137 }
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
2138
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2139 bigfloat_mul (scratch_bigfloat2, scratch_bigfloat, XBIGFLOAT_DATA (divisor));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2140 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2141
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2142 return values2 (res0, make_bigfloat_bf (scratch_bigfloat));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2143 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2144 #endif /* HAVE_BIGFLOAT */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2145
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2146 #ifdef HAVE_RATIO
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2147 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2148 truncate_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2149 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2150 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2151 Lisp_Object res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2152
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2153 if (ratio_sign (XRATIO_DATA (number)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
2154 return Qzero;
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2155
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2156 bignum_div (scratch_bignum, XRATIO_NUMERATOR (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2157 XRATIO_DENOMINATOR (number));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2158 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2159 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2160 res0 = make_float (bignum_to_double (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2161 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2162 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2163 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2164 res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2165 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2166
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2167 if (bignum_divisible_p (XRATIO_NUMERATOR (number),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2168 XRATIO_DENOMINATOR (number)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2169 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2170 return values2 (res0, Qzero);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2171 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2172
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2173 ratio_set_bignum (scratch_ratio2, scratch_bignum);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2174 ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2175
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2176 return values2 (res0, Fcanonicalize_number (make_ratio_rt (scratch_ratio)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2177 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2178 #endif /* HAVE_RATIO */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2179
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2180 #ifdef HAVE_BIGFLOAT
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2181 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2182 truncate_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2183 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2184 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2185 Lisp_Object res0;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2186
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2187 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2188 bigfloat_set_prec (scratch_bigfloat2, XBIGFLOAT_GET_PREC (number));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2189 bigfloat_trunc (scratch_bigfloat, XBIGFLOAT_DATA (number));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2190
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2191 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2192 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2193 res0 = make_bigfloat_bf (scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2194 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2195 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2196 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2197 #ifdef HAVE_BIGNUM
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2198 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2199 res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2200 #else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2201 res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2202 #endif /* HAVE_BIGNUM */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2203 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2204
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2205 bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2206
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2207 return
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
2208 values2 (res0,
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2209 Fcanonicalize_number (make_bigfloat_bf (scratch_bigfloat2)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2210 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2211 #endif /* HAVE_BIGFLOAT */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2212
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2213 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2214 truncate_two_float (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2215 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2216 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2217 double f1 = extract_float (number);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2218 double f2 = extract_float (divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2219 double f0, remain;
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2220 Lisp_Object res0;
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
2221
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2222 if (f2 == 0.0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
2223 return arith_error2 ("truncate", number, divisor);
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2224
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2225 res0 = float_to_int (f1 / f2, MAYBE_EFF ("truncate"), number, Qunbound);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2226 f0 = extract_float (res0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2227
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2228 IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("truncate"), number, divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2229
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2230 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2231 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2232 res0 = make_float (f0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2233 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2234
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2235 return values2 (res0, make_float (remain));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2236 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2237
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2238 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2239 truncate_one_float (Lisp_Object number, int return_float)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2240 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2241 Lisp_Object res0
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2242 = float_to_int (XFLOAT_DATA (number), MAYBE_EFF ("truncate"),
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2243 number, Qunbound);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2244 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2245 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2246 res0 = make_float ((double)XINT(res0));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2247 return values2 (res0, make_float ((XFLOAT_DATA (number)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2248 - XFLOAT_DATA (res0))));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2249 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2250 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2251 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2252 return values2 (res0, make_float (XFLOAT_DATA (number)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2253 - XREALINT (res0)));
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2254 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2255 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2256
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2257 EXFUN (Fftruncate, 2);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2258
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2259 static Lisp_Object
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2260 truncate_one_mundane_arg (Lisp_Object number, Lisp_Object divisor,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2261 int return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2262 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2263 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2264 if (INTEGERP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2265 #else
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2266 if (INTP (number))
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2267 #endif
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2268 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2269 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2270 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2271 return values2 (make_float (extract_float (number)), Qzero);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2272 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2273 else
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2274 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2275 return values2 (number, Qzero);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2276 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2277 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2278
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2279 MAYBE_CHAR_OR_MARKER (truncate);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2280
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2281 if (return_float)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2282 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2283 return Fftruncate (wrong_type_argument (Qnumberp, number), divisor);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2284 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2285 else
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2286 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2287 return Ftruncate (wrong_type_argument (Qnumberp, number), divisor);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2288 }
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2289 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2290
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2291 /* Rounding functions that will not necessarily return floats: */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2292
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2293 DEFUN ("ceiling", Fceiling, 1, 2, 0, /*
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2294 Return the smallest integer no less than NUMBER. (Round toward +inf.)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2295
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2296 With optional argument DIVISOR, return the smallest integer no less than
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
2297 the quotient of NUMBER and DIVISOR.
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2298
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2299 This function returns multiple values; see `multiple-value-bind' and
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2300 `multiple-value-call'. The second returned value is the remainder in the
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2301 calculation, which will be one minus the fractional part of NUMBER if DIVISOR
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2302 is omitted or one.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2303 */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2304 (number, divisor))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2305 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2306 ROUNDING_CONVERT(ceiling, 0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2307 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2308
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2309 DEFUN ("floor", Ffloor, 1, 2, 0, /*
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2310 Return the largest integer no greater than NUMBER. (Round towards -inf.)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2311 With optional second argument DIVISOR, return the largest integer no
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2312 greater than the quotient of NUMBER and DIVISOR.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2313
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2314 This function returns multiple values; see `multiple-value-call' and
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2315 `multiple-value-bind'. The second returned value is the remainder in the
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2316 calculation, which will just be the fractional part if DIVISOR is omitted or
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2317 one.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2318 */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2319 (number, divisor))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2320 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2321 ROUNDING_CONVERT(floor, 0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2322 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2323
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2324 DEFUN ("round", Fround, 1, 2, 0, /*
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2325 Return the nearest integer to NUMBER.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2326 If NUMBER is exactly halfway between two integers, return the one that
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2327 is even.
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1204
diff changeset
2328
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2329 Optional argument DIVISOR means return the nearest integer to NUMBER
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2330 divided by DIVISOR.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2331
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2332 This function returns multiple values; see `multiple-value-call' and
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2333 `multiple-value-bind'. The second returned value is the remainder
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2334 in the calculation.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2335 */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2336 (number, divisor))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2337 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2338 ROUNDING_CONVERT(round, 0);
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2339 }
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2340
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2341 DEFUN ("truncate", Ftruncate, 1, 2, 0, /*
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2342 Truncate a floating point number to an integer.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2343 Rounds the value toward zero.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2344
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2345 Optional argument DIVISOR means truncate NUMBER divided by DIVISOR.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2346
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2347 This function returns multiple values; see `multiple-value-call' and
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2348 `multiple-value-bind'. The second returned value is the remainder.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2349 */
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2350 (number, divisor))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2351 {
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2352 ROUNDING_CONVERT(truncate, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2353 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2354
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2355 /* Float-rounding functions. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2356
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2357 DEFUN ("fceiling", Ffceiling, 1, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2358 Return the smallest integer no less than NUMBER, as a float.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2359 \(Round toward +inf.\)
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2360
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2361 With optional argument DIVISOR, return the smallest integer no less than the
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2362 quotient of NUMBER and DIVISOR, as a float.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2363
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2364 This function returns multiple values; the second value is the remainder in
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2365 the calculation.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2366 */
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2367 (number, divisor))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2368 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2369 ROUNDING_CONVERT(ceiling, 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2370 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2371
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2372 DEFUN ("ffloor", Fffloor, 1, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2373 Return the largest integer no greater than NUMBER, as a float.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2374 \(Round towards -inf.\)
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2375
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2376 With optional argument DIVISOR, return the largest integer no greater than
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2377 the quotient of NUMBER and DIVISOR, as a float.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2378
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2379 This function returns multiple values; the second value is the remainder in
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2380 the calculation.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2381 */
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2382 (number, divisor))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2383 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2384 ROUNDING_CONVERT(floor, 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2385 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2386
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2387 DEFUN ("fround", Ffround, 1, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2388 Return the nearest integer to NUMBER, as a float.
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2389 If NUMBER is exactly halfway between two integers, return the one that is
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2390 even.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2391
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2392 With optional argument DIVISOR, return the nearest integer to the quotient
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2393 of NUMBER and DIVISOR, as a float.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2394
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2395 This function returns multiple values; the second value is the remainder in
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2396 the calculation.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2397 */
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2398 (number, divisor))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2399 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2400 ROUNDING_CONVERT(round, 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2401 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2402
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2403 DEFUN ("ftruncate", Fftruncate, 1, 2, 0, /*
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2404 Truncate a floating point number to an integral float value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2405 Rounds the value toward zero.
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2406
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2407 With optional argument DIVISOR, truncate the quotient of NUMBER and DIVISOR,
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2408 to an integral float value.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2409
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2410 This function returns multiple values; the second value is the remainder in
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2411 the calculation.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2412 */
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2413 (number, divisor))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2414 {
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 2286
diff changeset
2415 ROUNDING_CONVERT(truncate, 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2416 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2417
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2418 #ifdef FLOAT_CATCH_SIGILL
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2419 static SIGTYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2420 float_error (int signo)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2421 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2422 if (! in_float)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2423 fatal_error_signal (signo);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2424
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2425 EMACS_REESTABLISH_SIGNAL (signo, arith_error);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2426 EMACS_UNBLOCK_SIGNAL (signo);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2428 in_float = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2429
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2430 /* Was Fsignal(), but it just doesn't make sense for an error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2431 occurring inside a signal handler to be restartable, considering
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2432 that anything could happen when the error is signaled and trapped
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2433 and considering the asynchronous nature of signal handlers. */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
2434 signal_error (Qarith_error, 0, float_error_arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2435 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2436
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2437 /* Another idea was to replace the library function `infnan'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2438 where SIGILL is signaled. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2439
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2440 #endif /* FLOAT_CATCH_SIGILL */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2441
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2442 /* In C++, it is impossible to determine what type matherr expects
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2443 without some more configure magic.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2444 We shouldn't be using matherr anyways - it's a non-standard SYSVism. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2445 #if defined (HAVE_MATHERR) && !defined(__cplusplus)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2446 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2447 matherr (struct exception *x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2448 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2449 Lisp_Object args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2450 if (! in_float)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2451 /* Not called from emacs-lisp float routines; do the default thing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2452 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2453
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2454 /* if (!strcmp (x->name, "pow")) x->name = "expt"; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2455
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2456 args = Fcons (build_string (x->name),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2457 Fcons (make_float (x->arg1),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2458 ((in_float == 2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2459 ? Fcons (make_float (x->arg2), Qnil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2460 : Qnil)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2461 switch (x->type)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2462 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2463 case DOMAIN: Fsignal (Qdomain_error, args); break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2464 case SING: Fsignal (Qsingularity_error, args); break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2465 case OVERFLOW: Fsignal (Qoverflow_error, args); break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2466 case UNDERFLOW: Fsignal (Qunderflow_error, args); break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2467 default: Fsignal (Qarith_error, args); break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2468 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2469 return 1; /* don't set errno or print a message */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2470 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2471 #endif /* HAVE_MATHERR */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2472
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2473 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2474 init_floatfns_very_early (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2475 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2476 # ifdef FLOAT_CATCH_SIGILL
613
023b83f4e54b [xemacs-hg @ 2001-06-10 10:42:16 by ben]
ben
parents: 563
diff changeset
2477 EMACS_SIGNAL (SIGILL, float_error);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2478 # endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2479 in_float = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2480 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2481
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2482 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2483 syms_of_floatfns (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2484 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2485 INIT_LRECORD_IMPLEMENTATION (float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2486
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2487 /* Trig functions. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2488
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2489 DEFSUBR (Facos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2490 DEFSUBR (Fasin);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2491 DEFSUBR (Fatan);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2492 DEFSUBR (Fcos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2493 DEFSUBR (Fsin);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2494 DEFSUBR (Ftan);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2495
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2496 /* Bessel functions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2497
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2498 #if 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2499 DEFSUBR (Fbessel_y0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2500 DEFSUBR (Fbessel_y1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2501 DEFSUBR (Fbessel_yn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2502 DEFSUBR (Fbessel_j0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2503 DEFSUBR (Fbessel_j1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2504 DEFSUBR (Fbessel_jn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2505 #endif /* 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2506
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2507 /* Error functions. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2508
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2509 #if 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2510 DEFSUBR (Ferf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2511 DEFSUBR (Ferfc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2512 DEFSUBR (Flog_gamma);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2513 #endif /* 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2514
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2515 /* Root and Log functions. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2516
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2517 DEFSUBR (Fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2518 DEFSUBR (Fexpt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2519 DEFSUBR (Flog);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2520 DEFSUBR (Flog10);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2521 DEFSUBR (Fsqrt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2522 DEFSUBR (Fcube_root);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2523
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2524 /* Inverse trig functions. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2525
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2526 DEFSUBR (Facosh);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2527 DEFSUBR (Fasinh);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2528 DEFSUBR (Fatanh);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2529 DEFSUBR (Fcosh);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2530 DEFSUBR (Fsinh);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2531 DEFSUBR (Ftanh);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2532
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2533 /* Rounding functions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2534
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2535 DEFSUBR (Fabs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2536 DEFSUBR (Ffloat);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2537 DEFSUBR (Flogb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2538 DEFSUBR (Fceiling);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2539 DEFSUBR (Ffloor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2540 DEFSUBR (Fround);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2541 DEFSUBR (Ftruncate);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2542
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2543 /* Float-rounding functions. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2544
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2545 DEFSUBR (Ffceiling);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2546 DEFSUBR (Fffloor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2547 DEFSUBR (Ffround);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2548 DEFSUBR (Fftruncate);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2549 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2550
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2551 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2552 vars_of_floatfns (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2553 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2554 Fprovide (intern ("lisp-float-type"));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2555 }