Mercurial > hg > xemacs-beta
annotate src/number.c @ 5935:d5eb0914ca1f cygwin
trial of E1 and UE1
author | Henry Thompson <ht@markup.co.uk> |
---|---|
date | Sat, 12 Dec 2015 21:49:31 +0000 |
parents | e2fae7783046 |
children | 574f0cded429 |
rev | line source |
---|---|
1983 | 1 /* Numeric types for XEmacs. |
2 Copyright (C) 2004 Jerry James. | |
5125 | 3 Copyright (C) 2010 Ben Wing. |
1983 | 4 |
5 This file is part of XEmacs. | |
6 | |
5405
2aa9cd456ae7
Move src/ to GPLv3.
Mike Sperber <sperber@deinprogramm.de>
parents:
5231
diff
changeset
|
7 XEmacs is free software: you can redistribute it and/or modify it |
1983 | 8 under the terms of the GNU General Public License as published by the |
5405
2aa9cd456ae7
Move src/ to GPLv3.
Mike Sperber <sperber@deinprogramm.de>
parents:
5231
diff
changeset
|
9 Free Software Foundation, either version 3 of the License, or (at your |
2aa9cd456ae7
Move src/ to GPLv3.
Mike Sperber <sperber@deinprogramm.de>
parents:
5231
diff
changeset
|
10 option) any later version. |
1983 | 11 |
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
15 for more details. | |
16 | |
17 You should have received a copy of the GNU General Public License | |
5405
2aa9cd456ae7
Move src/ to GPLv3.
Mike Sperber <sperber@deinprogramm.de>
parents:
5231
diff
changeset
|
18 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
1983 | 19 |
20 /* Synched up with: Not in FSF. */ | |
21 | |
22 #include <config.h> | |
23 #include <limits.h> | |
24 #include "lisp.h" | |
25 | |
2595 | 26 #ifdef HAVE_BIGFLOAT |
27 #define USED_IF_BIGFLOAT(decl) decl | |
28 #else | |
29 #define USED_IF_BIGFLOAT(decl) UNUSED (decl) | |
30 #endif | |
31 | |
2001 | 32 Lisp_Object Qrationalp, Qfloatingp, Qrealp; |
1983 | 33 Lisp_Object Vdefault_float_precision; |
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
34 |
1983 | 35 static Lisp_Object Qunsupported_type; |
36 static Lisp_Object Vbigfloat_max_prec; | |
37 static int number_initialized; | |
38 | |
39 #ifdef HAVE_BIGNUM | |
40 bignum scratch_bignum, scratch_bignum2; | |
41 #endif | |
42 #ifdef HAVE_RATIO | |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3391
diff
changeset
|
43 ratio scratch_ratio, scratch_ratio2; |
1983 | 44 #endif |
45 #ifdef HAVE_BIGFLOAT | |
46 bigfloat scratch_bigfloat, scratch_bigfloat2; | |
47 #endif | |
48 | |
49 /********************************* Bignums **********************************/ | |
50 #ifdef HAVE_BIGNUM | |
51 static void | |
2286 | 52 bignum_print (Lisp_Object obj, Lisp_Object printcharfun, |
53 int UNUSED (escapeflag)) | |
1983 | 54 { |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4883
diff
changeset
|
55 Ascbyte *bstr = bignum_to_string (XBIGNUM_DATA (obj), 10); |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4883
diff
changeset
|
56 write_ascstring (printcharfun, bstr); |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
57 xfree (bstr); |
1983 | 58 } |
59 | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
60 #ifdef NEW_GC |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
61 static void |
5141
0dcd22290039
fix issues with finalizers in number.c, postgresql, ldap
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
62 bignum_finalize (Lisp_Object obj) |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
63 { |
5141
0dcd22290039
fix issues with finalizers in number.c, postgresql, ldap
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
64 struct Lisp_Bignum *num = XBIGNUM (obj); |
5125 | 65 /* #### WARNING: It would be better to put some sort of check to make |
66 sure this doesn't happen more than once, just in case --- | |
67 e.g. checking if it's zero before finalizing and then setting it to | |
68 zero after finalizing. */ | |
69 bignum_fini (num->data); | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
70 } |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
71 #endif |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
72 |
1983 | 73 static int |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
74 bignum_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
75 int UNUSED (foldcase)) |
1983 | 76 { |
77 return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); | |
78 } | |
79 | |
80 static Hashcode | |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
81 bignum_hash (Lisp_Object obj, int UNUSED (depth), Boolint equalp) |
1983 | 82 { |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
83 if (equalp) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
84 { |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
85 return FLOAT_HASHCODE_FROM_DOUBLE (bignum_to_double (XBIGNUM_DATA (obj))); |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
86 } |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
87 else |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
88 { |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
89 return bignum_hashcode (XBIGNUM_DATA (obj)); |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
90 } |
1983 | 91 } |
92 | |
2551 | 93 static void |
94 bignum_convert (const void *object, void **data, Bytecount *size) | |
95 { | |
96 CIbyte *bstr = bignum_to_string (*(bignum *)object, 10); | |
97 *data = bstr; | |
98 *size = strlen(bstr)+1; | |
99 } | |
100 | |
101 static void | |
102 bignum_convfree (const void * UNUSED (object), void *data, | |
103 Bytecount UNUSED (size)) | |
104 { | |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
105 xfree (data); |
2551 | 106 } |
107 | |
108 static void * | |
109 bignum_deconvert (void *object, void *data, Bytecount UNUSED (size)) | |
110 { | |
111 bignum *b = (bignum *) object; | |
112 bignum_init(*b); | |
113 bignum_set_string(*b, (const char *) data, 10); | |
114 return object; | |
115 } | |
116 | |
117 static const struct opaque_convert_functions bignum_opc = { | |
118 bignum_convert, | |
119 bignum_convfree, | |
120 bignum_deconvert | |
121 }; | |
122 | |
1983 | 123 static const struct memory_description bignum_description[] = { |
2551 | 124 { XD_OPAQUE_DATA_CONVERTIBLE, offsetof (Lisp_Bignum, data), |
125 0, { &bignum_opc }, XD_FLAG_NO_KKCC }, | |
1983 | 126 { XD_END } |
127 }; | |
128 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
129 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("bignum", bignum, 0, bignum_print, |
5169
6c6d78781d59
cleanup of code related to xfree(), better KKCC backtrace capabilities, document XD_INLINE_LISP_OBJECT_BLOCK_PTR, fix some memory leaks, other code cleanup
Ben Wing <ben@xemacs.org>
parents:
5141
diff
changeset
|
130 IF_NEW_GC (bignum_finalize), |
6c6d78781d59
cleanup of code related to xfree(), better KKCC backtrace capabilities, document XD_INLINE_LISP_OBJECT_BLOCK_PTR, fix some memory leaks, other code cleanup
Ben Wing <ben@xemacs.org>
parents:
5141
diff
changeset
|
131 bignum_equal, bignum_hash, |
6c6d78781d59
cleanup of code related to xfree(), better KKCC backtrace capabilities, document XD_INLINE_LISP_OBJECT_BLOCK_PTR, fix some memory leaks, other code cleanup
Ben Wing <ben@xemacs.org>
parents:
5141
diff
changeset
|
132 bignum_description, Lisp_Bignum); |
2092 | 133 #endif /* HAVE_BIGNUM */ |
1983 | 134 |
135 Lisp_Object Qbignump; | |
136 | |
137 DEFUN ("bignump", Fbignump, 1, 1, 0, /* | |
138 Return t if OBJECT is a bignum, nil otherwise. | |
139 */ | |
140 (object)) | |
141 { | |
142 return BIGNUMP (object) ? Qt : Qnil; | |
143 } | |
144 | |
145 | |
146 /********************************** Ratios **********************************/ | |
147 #ifdef HAVE_RATIO | |
148 static void | |
2286 | 149 ratio_print (Lisp_Object obj, Lisp_Object printcharfun, |
150 int UNUSED (escapeflag)) | |
1983 | 151 { |
152 CIbyte *rstr = ratio_to_string (XRATIO_DATA (obj), 10); | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4883
diff
changeset
|
153 write_ascstring (printcharfun, rstr); |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
154 xfree (rstr); |
1983 | 155 } |
156 | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
157 #ifdef NEW_GC |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
158 static void |
5141
0dcd22290039
fix issues with finalizers in number.c, postgresql, ldap
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
159 ratio_finalize (Lisp_Object obj) |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
160 { |
5141
0dcd22290039
fix issues with finalizers in number.c, postgresql, ldap
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
161 struct Lisp_Ratio *num = XRATIO (obj); |
5125 | 162 /* #### WARNING: It would be better to put some sort of check to make |
163 sure this doesn't happen more than once, just in case --- | |
164 e.g. checking if it's zero before finalizing and then setting it to | |
165 zero after finalizing. */ | |
166 ratio_fini (num->data); | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
167 } |
5169
6c6d78781d59
cleanup of code related to xfree(), better KKCC backtrace capabilities, document XD_INLINE_LISP_OBJECT_BLOCK_PTR, fix some memory leaks, other code cleanup
Ben Wing <ben@xemacs.org>
parents:
5141
diff
changeset
|
168 #endif /* not NEW_GC */ |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
169 |
1983 | 170 static int |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
171 ratio_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
172 int UNUSED (foldcase)) |
1983 | 173 { |
174 return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
175 } | |
176 | |
177 static Hashcode | |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
178 ratio_hash (Lisp_Object obj, int UNUSED (depth), Boolint equalp) |
1983 | 179 { |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
180 if (equalp) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
181 { |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
182 return FLOAT_HASHCODE_FROM_DOUBLE (ratio_to_double (XRATIO_DATA (obj))); |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
183 } |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
184 else |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
185 { |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
186 return ratio_hashcode (XRATIO_DATA (obj)); |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
187 } |
1983 | 188 } |
189 | |
190 static const struct memory_description ratio_description[] = { | |
191 { XD_OPAQUE_PTR, offsetof (Lisp_Ratio, data) }, | |
192 { XD_END } | |
193 }; | |
194 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
195 DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("ratio", ratio, 0, ratio_print, |
5169
6c6d78781d59
cleanup of code related to xfree(), better KKCC backtrace capabilities, document XD_INLINE_LISP_OBJECT_BLOCK_PTR, fix some memory leaks, other code cleanup
Ben Wing <ben@xemacs.org>
parents:
5141
diff
changeset
|
196 IF_NEW_GC (ratio_finalize), |
6c6d78781d59
cleanup of code related to xfree(), better KKCC backtrace capabilities, document XD_INLINE_LISP_OBJECT_BLOCK_PTR, fix some memory leaks, other code cleanup
Ben Wing <ben@xemacs.org>
parents:
5141
diff
changeset
|
197 ratio_equal, ratio_hash, |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
198 ratio_description, Lisp_Ratio); |
1983 | 199 |
2092 | 200 #endif /* HAVE_RATIO */ |
1983 | 201 |
202 Lisp_Object Qratiop; | |
203 | |
204 DEFUN ("ratiop", Fratiop, 1, 1, 0, /* | |
205 Return t if OBJECT is a ratio, nil otherwise. | |
206 */ | |
207 (object)) | |
208 { | |
209 return RATIOP (object) ? Qt : Qnil; | |
210 } | |
211 | |
212 | |
213 /******************************** Rationals *********************************/ | |
214 DEFUN ("rationalp", Frationalp, 1, 1, 0, /* | |
215 Return t if OBJECT is a rational, nil otherwise. | |
216 */ | |
217 (object)) | |
218 { | |
219 return RATIONALP (object) ? Qt : Qnil; | |
220 } | |
221 | |
222 DEFUN ("numerator", Fnumerator, 1, 1, 0, /* | |
223 Return the numerator of the canonical form of RATIONAL. | |
224 If RATIONAL is an integer, RATIONAL is returned. | |
225 */ | |
226 (rational)) | |
227 { | |
228 CONCHECK_RATIONAL (rational); | |
229 #ifdef HAVE_RATIO | |
4883
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
230 if (RATIOP (rational)) |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
231 { |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
232 return |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
233 Fcanonicalize_number (make_bignum_bg (XRATIO_NUMERATOR (rational))); |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
234 } |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
235 #endif |
1983 | 236 return rational; |
237 } | |
238 | |
239 DEFUN ("denominator", Fdenominator, 1, 1, 0, /* | |
240 Return the denominator of the canonical form of RATIONAL. | |
241 If RATIONAL is an integer, 1 is returned. | |
242 */ | |
243 (rational)) | |
244 { | |
245 CONCHECK_RATIONAL (rational); | |
246 #ifdef HAVE_RATIO | |
4883
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
247 if (RATIOP (rational)) |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
248 { |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
249 return Fcanonicalize_number (make_bignum_bg |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
250 (XRATIO_DENOMINATOR (rational))); |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
251 } |
4892
d1d4ce10c7b4
Fix the build problem in number.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
4886
diff
changeset
|
252 #endif |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
253 return make_fixnum (1); |
1983 | 254 } |
255 | |
256 | |
257 /******************************** Bigfloats *********************************/ | |
258 #ifdef HAVE_BIGFLOAT | |
259 static void | |
2286 | 260 bigfloat_print (Lisp_Object obj, Lisp_Object printcharfun, |
261 int UNUSED (escapeflag)) | |
1983 | 262 { |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4883
diff
changeset
|
263 Ascbyte *fstr = bigfloat_to_string (XBIGFLOAT_DATA (obj), 10); |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4883
diff
changeset
|
264 write_ascstring (printcharfun, fstr); |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
265 xfree (fstr); |
1983 | 266 } |
267 | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
268 #ifdef NEW_GC |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
269 static void |
5141
0dcd22290039
fix issues with finalizers in number.c, postgresql, ldap
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
270 bigfloat_finalize (Lisp_Object obj) |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
271 { |
5141
0dcd22290039
fix issues with finalizers in number.c, postgresql, ldap
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
272 struct Lisp_Bigfloat *num = XBIGFLOAT (obj); |
5125 | 273 /* #### WARNING: It would be better to put some sort of check to make |
274 sure this doesn't happen more than once, just in case --- | |
275 e.g. checking if it's zero before finalizing and then setting it to | |
276 zero after finalizing. */ | |
277 bigfloat_fini (num->bf); | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
278 } |
5169
6c6d78781d59
cleanup of code related to xfree(), better KKCC backtrace capabilities, document XD_INLINE_LISP_OBJECT_BLOCK_PTR, fix some memory leaks, other code cleanup
Ben Wing <ben@xemacs.org>
parents:
5141
diff
changeset
|
279 #endif /* not NEW_GC */ |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
280 |
1983 | 281 static int |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
282 bigfloat_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
283 int UNUSED (foldcase)) |
1983 | 284 { |
285 return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); | |
286 } | |
287 | |
288 static Hashcode | |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
289 bigfloat_hash (Lisp_Object obj, int UNUSED (depth), Boolint equalp) |
1983 | 290 { |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
291 if (equalp) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
292 { |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
293 return |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
294 FLOAT_HASHCODE_FROM_DOUBLE (bigfloat_to_double (XBIGFLOAT_DATA (obj))); |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
295 } |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
296 else |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
297 { |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
298 return bigfloat_hashcode (XBIGFLOAT_DATA (obj)); |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5169
diff
changeset
|
299 } |
1983 | 300 } |
301 | |
302 static const struct memory_description bigfloat_description[] = { | |
303 { XD_OPAQUE_PTR, offsetof (Lisp_Bigfloat, bf) }, | |
304 { XD_END } | |
305 }; | |
306 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
307 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("bigfloat", bigfloat, 0, |
5169
6c6d78781d59
cleanup of code related to xfree(), better KKCC backtrace capabilities, document XD_INLINE_LISP_OBJECT_BLOCK_PTR, fix some memory leaks, other code cleanup
Ben Wing <ben@xemacs.org>
parents:
5141
diff
changeset
|
308 bigfloat_print, |
6c6d78781d59
cleanup of code related to xfree(), better KKCC backtrace capabilities, document XD_INLINE_LISP_OBJECT_BLOCK_PTR, fix some memory leaks, other code cleanup
Ben Wing <ben@xemacs.org>
parents:
5141
diff
changeset
|
309 IF_NEW_GC (bigfloat_finalize), |
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
310 bigfloat_equal, bigfloat_hash, |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
311 bigfloat_description, Lisp_Bigfloat); |
1983 | 312 |
2092 | 313 #endif /* HAVE_BIGFLOAT */ |
1983 | 314 |
315 Lisp_Object Qbigfloatp; | |
316 | |
317 DEFUN ("bigfloatp", Fbigfloatp, 1, 1, 0, /* | |
318 Return t if OBJECT is a bigfloat, nil otherwise. | |
319 */ | |
320 (object)) | |
321 { | |
322 return BIGFLOATP (object) ? Qt : Qnil; | |
323 } | |
324 | |
2092 | 325 DEFUN ("bigfloat-get-precision", Fbigfloat_get_precision, 1, 1, 0, /* |
326 Return the precision of bigfloat F as an integer. | |
327 */ | |
328 (f)) | |
329 { | |
330 CHECK_BIGFLOAT (f); | |
5602
c9e5612f5424
Support the MP library on recent FreeBSD, have it pass relevant tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
331 #ifdef HAVE_BIGFLOAT |
2092 | 332 #ifdef HAVE_BIGNUM |
333 bignum_set_ulong (scratch_bignum, XBIGFLOAT_GET_PREC (f)); | |
334 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
335 #else | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
336 return make_fixnum ((int) XBIGFLOAT_GET_PREC (f)); |
2092 | 337 #endif |
5602
c9e5612f5424
Support the MP library on recent FreeBSD, have it pass relevant tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
338 #endif |
2092 | 339 } |
340 | |
341 DEFUN ("bigfloat-set-precision", Fbigfloat_set_precision, 2, 2, 0, /* | |
342 Set the precision of F, a bigfloat, to PRECISION, a nonnegative integer. | |
343 The new precision of F is returned. Note that the return value may differ | |
344 from PRECISION if the underlying library is unable to support exactly | |
345 PRECISION bits of precision. | |
346 */ | |
347 (f, precision)) | |
348 { | |
349 unsigned long prec; | |
350 | |
351 CHECK_BIGFLOAT (f); | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
352 if (FIXNUMP (precision)) |
2092 | 353 { |
5935 | 354 prec = (XFIXNUM (precision) <= 0) ? UE1 : (EMACS_UINT) XFIXNUM (precision); |
2092 | 355 } |
356 #ifdef HAVE_BIGNUM | |
357 else if (BIGNUMP (precision)) | |
358 { | |
359 prec = bignum_fits_ulong_p (XBIGNUM_DATA (precision)) | |
360 ? bignum_to_ulong (XBIGNUM_DATA (precision)) | |
361 : UINT_MAX; | |
362 } | |
363 #endif | |
364 else | |
365 { | |
366 dead_wrong_type_argument (Qintegerp, f); | |
367 return Qnil; | |
368 } | |
5602
c9e5612f5424
Support the MP library on recent FreeBSD, have it pass relevant tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
369 #ifdef HAVE_BIGFLOAT |
2092 | 370 XBIGFLOAT_SET_PREC (f, prec); |
5602
c9e5612f5424
Support the MP library on recent FreeBSD, have it pass relevant tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
371 #endif |
2092 | 372 return Fbigfloat_get_precision (f); |
373 } | |
374 | |
1983 | 375 static int |
2286 | 376 default_float_precision_changed (Lisp_Object UNUSED (sym), Lisp_Object *val, |
377 Lisp_Object UNUSED (in_object), | |
378 int UNUSED (flags)) | |
1983 | 379 { |
380 unsigned long prec; | |
381 | |
382 CONCHECK_INTEGER (*val); | |
383 #ifdef HAVE_BIGFLOAT | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
384 if (FIXNUMP (*val)) |
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
385 prec = XFIXNUM (*val); |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
386 else |
1983 | 387 { |
388 if (!bignum_fits_ulong_p (XBIGNUM_DATA (*val))) | |
389 args_out_of_range_3 (*val, Qzero, Vbigfloat_max_prec); | |
390 prec = bignum_to_ulong (XBIGNUM_DATA (*val)); | |
391 } | |
392 if (prec != 0UL) | |
393 bigfloat_set_default_prec (prec); | |
394 #endif | |
395 return 0; | |
396 } | |
397 | |
398 | |
399 /********************************* Floating *********************************/ | |
400 Lisp_Object | |
401 make_floating (double d) | |
402 { | |
403 #ifdef HAVE_BIGFLOAT | |
404 if (ZEROP (Vdefault_float_precision)) | |
405 #endif | |
406 return make_float (d); | |
407 #ifdef HAVE_BIGFLOAT | |
408 else | |
409 return make_bigfloat (d, 0UL); | |
410 #endif | |
411 } | |
412 | |
413 DEFUN ("floatingp", Ffloatingp, 1, 1, 0, /* | |
414 Return t if OBJECT is a floating point number of any kind, nil otherwise. | |
415 */ | |
416 (object)) | |
417 { | |
418 return FLOATINGP (object) ? Qt : Qnil; | |
419 } | |
420 | |
421 | |
422 /********************************** Reals ***********************************/ | |
423 DEFUN ("realp", Frealp, 1, 1, 0, /* | |
424 Return t if OBJECT is a real, nil otherwise. | |
425 */ | |
426 (object)) | |
427 { | |
428 return REALP (object) ? Qt : Qnil; | |
429 } | |
430 | |
431 | |
432 /********************************* Numbers **********************************/ | |
433 DEFUN ("canonicalize-number", Fcanonicalize_number, 1, 1, 0, /* | |
434 Return the canonical form of NUMBER. | |
435 */ | |
436 (number)) | |
437 { | |
438 /* The tests should go in order from larger, more expressive, or more | |
439 complex types to smaller, less expressive, or simpler types so that a | |
440 number can cascade all the way down to the simplest type if | |
441 appropriate. */ | |
442 #ifdef HAVE_RATIO | |
443 if (RATIOP (number) && | |
444 bignum_fits_long_p (XRATIO_DENOMINATOR (number)) && | |
445 bignum_to_long (XRATIO_DENOMINATOR (number)) == 1L) | |
4883
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
446 number = Fcanonicalize_number (make_bignum_bg (XRATIO_NUMERATOR (number))); |
1983 | 447 #endif |
448 #ifdef HAVE_BIGNUM | |
3391 | 449 if (BIGNUMP (number) && bignum_fits_emacs_int_p (XBIGNUM_DATA (number))) |
1983 | 450 { |
3391 | 451 EMACS_INT n = bignum_to_emacs_int (XBIGNUM_DATA (number)); |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
452 if (NUMBER_FITS_IN_A_FIXNUM (n)) |
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
453 number = make_fixnum (n); |
1983 | 454 } |
455 #endif | |
456 return number; | |
457 } | |
458 | |
459 enum number_type | |
460 get_number_type (Lisp_Object arg) | |
461 { | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
462 if (FIXNUMP (arg)) |
1983 | 463 return FIXNUM_T; |
464 #ifdef HAVE_BIGNUM | |
465 if (BIGNUMP (arg)) | |
466 return BIGNUM_T; | |
467 #endif | |
468 #ifdef HAVE_RATIO | |
469 if (RATIOP (arg)) | |
470 return RATIO_T; | |
471 #endif | |
472 if (FLOATP (arg)) | |
473 return FLOAT_T; | |
474 #ifdef HAVE_BIGFLOAT | |
475 if (BIGFLOATP (arg)) | |
476 return BIGFLOAT_T; | |
477 #endif | |
478 /* Catch unintentional bad uses of this function */ | |
2500 | 479 ABORT (); |
1995 | 480 /* NOTREACHED */ |
481 return FIXNUM_T; | |
1983 | 482 } |
483 | |
484 /* Convert NUMBER to type TYPE. If TYPE is BIGFLOAT_T then use the indicated | |
485 PRECISION; otherwise, PRECISION is ignored. */ | |
486 static Lisp_Object | |
487 internal_coerce_number (Lisp_Object number, enum number_type type, | |
2286 | 488 #ifdef HAVE_BIGFLOAT |
489 unsigned long precision | |
490 #else | |
491 unsigned long UNUSED (precision) | |
492 #endif | |
493 ) | |
1983 | 494 { |
495 enum number_type current_type; | |
496 | |
497 if (CHARP (number)) | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
498 number = make_fixnum (XCHAR (number)); |
1983 | 499 else if (MARKERP (number)) |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
500 number = make_fixnum (marker_position (number)); |
1983 | 501 |
502 /* Note that CHECK_NUMBER ensures that NUMBER is a supported type. Hence, | |
2500 | 503 we ABORT() in the #else sections below, because it shouldn't be possible |
1983 | 504 to arrive there. */ |
505 CHECK_NUMBER (number); | |
506 current_type = get_number_type (number); | |
507 switch (current_type) | |
508 { | |
509 case FIXNUM_T: | |
510 switch (type) | |
511 { | |
512 case FIXNUM_T: | |
513 return number; | |
514 case BIGNUM_T: | |
515 #ifdef HAVE_BIGNUM | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
516 return make_bignum (XREALFIXNUM (number)); |
1983 | 517 #else |
2500 | 518 ABORT (); |
1983 | 519 #endif /* HAVE_BIGNUM */ |
520 case RATIO_T: | |
521 #ifdef HAVE_RATIO | |
5935 | 522 return make_ratio (XREALFIXNUM (number), UE1); |
1983 | 523 #else |
2500 | 524 ABORT (); |
1983 | 525 #endif /* HAVE_RATIO */ |
526 case FLOAT_T: | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
527 return make_float (XREALFIXNUM (number)); |
1983 | 528 case BIGFLOAT_T: |
529 #ifdef HAVE_BIGFLOAT | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
530 return make_bigfloat (XREALFIXNUM (number), precision); |
1983 | 531 #else |
2500 | 532 ABORT (); |
1983 | 533 #endif /* HAVE_BIGFLOAT */ |
534 } | |
535 case BIGNUM_T: | |
536 #ifdef HAVE_BIGNUM | |
537 switch (type) | |
538 { | |
539 case FIXNUM_T: | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
540 return make_fixnum (bignum_to_long (XBIGNUM_DATA (number))); |
1983 | 541 case BIGNUM_T: |
542 return number; | |
543 case RATIO_T: | |
544 #ifdef HAVE_RATIO | |
545 bignum_set_long (scratch_bignum, 1L); | |
546 return make_ratio_bg (XBIGNUM_DATA (number), scratch_bignum); | |
547 #else | |
2500 | 548 ABORT (); |
1983 | 549 #endif /* HAVE_RATIO */ |
550 case FLOAT_T: | |
551 return make_float (bignum_to_double (XBIGNUM_DATA (number))); | |
552 case BIGFLOAT_T: | |
553 #ifdef HAVE_BIGFLOAT | |
554 { | |
555 Lisp_Object temp; | |
556 temp = make_bigfloat (0.0, precision); | |
557 bigfloat_set_bignum (XBIGFLOAT_DATA (temp), XBIGNUM_DATA (number)); | |
558 return temp; | |
559 } | |
560 #else | |
2500 | 561 ABORT (); |
1983 | 562 #endif /* HAVE_BIGFLOAT */ |
563 } | |
564 #else | |
2500 | 565 ABORT (); |
1983 | 566 #endif /* HAVE_BIGNUM */ |
567 case RATIO_T: | |
568 #ifdef HAVE_RATIO | |
569 switch (type) | |
570 { | |
571 case FIXNUM_T: | |
572 bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), | |
573 XRATIO_DENOMINATOR (number)); | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
574 return make_fixnum (bignum_to_long (scratch_bignum)); |
1983 | 575 case BIGNUM_T: |
576 bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), | |
577 XRATIO_DENOMINATOR (number)); | |
578 return make_bignum_bg (scratch_bignum); | |
579 case RATIO_T: | |
580 return number; | |
581 case FLOAT_T: | |
582 return make_float (ratio_to_double (XRATIO_DATA (number))); | |
583 case BIGFLOAT_T: | |
584 #ifdef HAVE_BIGFLOAT | |
585 { | |
586 Lisp_Object temp; | |
587 temp = make_bigfloat (0.0, precision); | |
588 bigfloat_set_ratio (XBIGFLOAT_DATA (temp), XRATIO_DATA (number)); | |
589 return temp; | |
590 } | |
591 #else | |
2500 | 592 ABORT (); |
1983 | 593 #endif /* HAVE_BIGFLOAT */ |
594 } | |
595 #else | |
2500 | 596 ABORT (); |
1983 | 597 #endif /* HAVE_RATIO */ |
598 case FLOAT_T: | |
599 switch (type) | |
600 { | |
601 case FIXNUM_T: | |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3391
diff
changeset
|
602 return Ftruncate (number, Qnil); |
1983 | 603 case BIGNUM_T: |
604 #ifdef HAVE_BIGNUM | |
605 bignum_set_double (scratch_bignum, XFLOAT_DATA (number)); | |
606 return make_bignum_bg (scratch_bignum); | |
607 #else | |
2500 | 608 ABORT (); |
1983 | 609 #endif /* HAVE_BIGNUM */ |
610 case RATIO_T: | |
611 #ifdef HAVE_RATIO | |
612 ratio_set_double (scratch_ratio, XFLOAT_DATA (number)); | |
613 return make_ratio_rt (scratch_ratio); | |
614 #else | |
2500 | 615 ABORT (); |
1983 | 616 #endif /* HAVE_RATIO */ |
617 case FLOAT_T: | |
618 return number; | |
619 case BIGFLOAT_T: | |
620 #ifdef HAVE_BIGFLOAT | |
621 bigfloat_set_prec (scratch_bigfloat, precision); | |
622 bigfloat_set_double (scratch_bigfloat, XFLOAT_DATA (number)); | |
623 return make_bigfloat_bf (scratch_bigfloat); | |
624 #else | |
2500 | 625 ABORT (); |
1983 | 626 #endif /* HAVE_BIGFLOAT */ |
627 } | |
628 case BIGFLOAT_T: | |
629 #ifdef HAVE_BIGFLOAT | |
630 switch (type) | |
631 { | |
632 case FIXNUM_T: | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
633 return make_fixnum (bigfloat_to_long (XBIGFLOAT_DATA (number))); |
1983 | 634 case BIGNUM_T: |
635 #ifdef HAVE_BIGNUM | |
636 bignum_set_bigfloat (scratch_bignum, XBIGFLOAT_DATA (number)); | |
637 return make_bignum_bg (scratch_bignum); | |
638 #else | |
2500 | 639 ABORT (); |
1983 | 640 #endif /* HAVE_BIGNUM */ |
641 case RATIO_T: | |
642 #ifdef HAVE_RATIO | |
643 ratio_set_bigfloat (scratch_ratio, XBIGFLOAT_DATA (number)); | |
644 return make_ratio_rt (scratch_ratio); | |
645 #else | |
2500 | 646 ABORT (); |
1983 | 647 #endif |
648 case FLOAT_T: | |
649 return make_float (bigfloat_to_double (XBIGFLOAT_DATA (number))); | |
650 case BIGFLOAT_T: | |
651 /* FIXME: Do we need to change the precision? */ | |
652 return number; | |
653 } | |
654 #else | |
2500 | 655 ABORT (); |
1983 | 656 #endif /* HAVE_BIGFLOAT */ |
657 } | |
2500 | 658 ABORT (); |
1995 | 659 /* NOTREACHED */ |
660 return Qzero; | |
1983 | 661 } |
662 | |
663 /* This function promotes its arguments as necessary to make them both the | |
664 same type. It destructively modifies its arguments to do so. Characters | |
665 and markers are ALWAYS converted to integers. */ | |
666 enum number_type | |
667 promote_args (Lisp_Object *arg1, Lisp_Object *arg2) | |
668 { | |
669 enum number_type type1, type2; | |
670 | |
671 if (CHARP (*arg1)) | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
672 *arg1 = make_fixnum (XCHAR (*arg1)); |
1983 | 673 else if (MARKERP (*arg1)) |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
674 *arg1 = make_fixnum (marker_position (*arg1)); |
1983 | 675 if (CHARP (*arg2)) |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
676 *arg2 = make_fixnum (XCHAR (*arg2)); |
1983 | 677 else if (MARKERP (*arg2)) |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
678 *arg2 = make_fixnum (marker_position (*arg2)); |
1983 | 679 |
680 CHECK_NUMBER (*arg1); | |
681 CHECK_NUMBER (*arg2); | |
682 | |
683 type1 = get_number_type (*arg1); | |
684 type2 = get_number_type (*arg2); | |
685 | |
686 if (type1 < type2) | |
687 { | |
688 *arg1 = internal_coerce_number (*arg1, type2, | |
689 #ifdef HAVE_BIGFLOAT | |
690 type2 == BIGFLOAT_T | |
691 ? XBIGFLOAT_GET_PREC (*arg2) : | |
692 #endif | |
693 0UL); | |
694 return type2; | |
695 } | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
696 |
1983 | 697 if (type2 < type1) |
698 { | |
699 *arg2 = internal_coerce_number (*arg2, type1, | |
700 #ifdef HAVE_BIGFLOAT | |
701 type1 == BIGFLOAT_T | |
702 ? XBIGFLOAT_GET_PREC (*arg1) : | |
703 #endif | |
704 0UL); | |
705 return type1; | |
706 } | |
707 | |
708 /* No conversion necessary */ | |
709 return type1; | |
710 } | |
711 | |
712 DEFUN ("coerce-number", Fcoerce_number, 2, 3, 0, /* | |
713 Convert NUMBER to the indicated type, possibly losing information. | |
714 Do not call this function. Use `coerce' instead. | |
715 | |
3025 | 716 TYPE is one of the symbols `fixnum', `integer', `ratio', `float', or |
717 `bigfloat'. Not all of these types may be supported. | |
1983 | 718 |
719 PRECISION is the number of bits of precision to use when converting to | |
720 bigfloat; it is ignored otherwise. If nil, the default precision is used. | |
721 | |
722 Note that some conversions lose information. No error is signaled in such | |
723 cases; the information is silently lost. | |
724 */ | |
2595 | 725 (number, type, USED_IF_BIGFLOAT (precision))) |
1983 | 726 { |
727 CHECK_SYMBOL (type); | |
728 if (EQ (type, Qfixnum)) | |
729 return internal_coerce_number (number, FIXNUM_T, 0UL); | |
730 else if (EQ (type, Qinteger)) | |
731 { | |
732 /* If bignums are available, we always convert to one first, then | |
733 downgrade to a fixnum if possible. */ | |
734 #ifdef HAVE_BIGNUM | |
735 return Fcanonicalize_number | |
736 (internal_coerce_number (number, BIGNUM_T, 0UL)); | |
737 #else | |
738 return internal_coerce_number (number, FIXNUM_T, 0UL); | |
739 #endif | |
740 } | |
741 #ifdef HAVE_RATIO | |
742 else if (EQ (type, Qratio)) | |
743 return internal_coerce_number (number, RATIO_T, 0UL); | |
744 #endif | |
745 else if (EQ (type, Qfloat)) | |
746 return internal_coerce_number (number, FLOAT_T, 0UL); | |
747 #ifdef HAVE_BIGFLOAT | |
748 else if (EQ (type, Qbigfloat)) | |
749 { | |
750 unsigned long prec; | |
751 | |
752 if (NILP (precision)) | |
753 prec = bigfloat_get_default_prec (); | |
754 else | |
755 { | |
756 CHECK_INTEGER (precision); | |
757 #ifdef HAVE_BIGNUM | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
758 if (FIXNUMP (precision)) |
1983 | 759 #endif /* HAVE_BIGNUM */ |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
760 prec = (unsigned long) XREALFIXNUM (precision); |
1983 | 761 #ifdef HAVE_BIGNUM |
762 else | |
763 { | |
764 if (!bignum_fits_ulong_p (XBIGNUM_DATA (precision))) | |
765 args_out_of_range (precision, Vbigfloat_max_prec); | |
766 prec = bignum_to_ulong (XBIGNUM_DATA (precision)); | |
767 } | |
768 #endif /* HAVE_BIGNUM */ | |
769 } | |
770 return internal_coerce_number (number, BIGFLOAT_T, prec); | |
771 } | |
772 #endif /* HAVE_BIGFLOAT */ | |
773 | |
774 Fsignal (Qunsupported_type, type); | |
775 /* NOTREACHED */ | |
776 return Qnil; | |
777 } | |
778 | |
779 | |
780 void | |
781 syms_of_number (void) | |
782 { | |
783 #ifdef HAVE_BIGNUM | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
784 INIT_LISP_OBJECT (bignum); |
1983 | 785 #endif |
786 #ifdef HAVE_RATIO | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
787 INIT_LISP_OBJECT (ratio); |
1983 | 788 #endif |
789 #ifdef HAVE_BIGFLOAT | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
790 INIT_LISP_OBJECT (bigfloat); |
1983 | 791 #endif |
792 | |
793 /* Type predicates */ | |
794 DEFSYMBOL (Qrationalp); | |
795 DEFSYMBOL (Qfloatingp); | |
796 DEFSYMBOL (Qrealp); | |
797 DEFSYMBOL (Qbignump); | |
798 DEFSYMBOL (Qratiop); | |
799 DEFSYMBOL (Qbigfloatp); | |
800 | |
801 /* Functions */ | |
802 DEFSUBR (Fbignump); | |
803 DEFSUBR (Fratiop); | |
804 DEFSUBR (Frationalp); | |
805 DEFSUBR (Fnumerator); | |
806 DEFSUBR (Fdenominator); | |
807 DEFSUBR (Fbigfloatp); | |
2092 | 808 DEFSUBR (Fbigfloat_get_precision); |
809 DEFSUBR (Fbigfloat_set_precision); | |
2001 | 810 DEFSUBR (Ffloatingp); |
1983 | 811 DEFSUBR (Frealp); |
812 DEFSUBR (Fcanonicalize_number); | |
813 DEFSUBR (Fcoerce_number); | |
814 | |
815 /* Errors */ | |
816 DEFERROR_STANDARD (Qunsupported_type, Qwrong_type_argument); | |
817 } | |
818 | |
819 void | |
820 vars_of_number (void) | |
821 { | |
2051 | 822 /* These variables are Lisp variables rather than number variables so that |
823 we can put bignums in them. */ | |
1983 | 824 DEFVAR_LISP_MAGIC ("default-float-precision", &Vdefault_float_precision, /* |
825 The default floating-point precision for newly created floating point values. | |
2092 | 826 This should be 0 to create Lisp float types, or an unsigned integer no greater |
827 than `bigfloat-maximum-precision' to create Lisp bigfloat types with the | |
828 indicated precision. | |
1983 | 829 */ default_float_precision_changed); |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
830 Vdefault_float_precision = make_fixnum (0); |
1983 | 831 |
2092 | 832 DEFVAR_CONST_LISP ("bigfloat-maximum-precision", &Vbigfloat_max_prec /* |
1983 | 833 The maximum number of bits of precision a bigfloat can have. |
2092 | 834 This is determined by the underlying library used to implement bigfloats. |
1983 | 835 */); |
836 | |
2061 | 837 #ifdef HAVE_BIGFLOAT |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
838 /* Don't create a bignum here. Otherwise, we lose with NEW_GC + pdump. |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
839 See reinit_vars_of_number(). */ |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
840 Vbigfloat_max_prec = make_fixnum (MOST_POSITIVE_FIXNUM); |
2061 | 841 #else |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5405
diff
changeset
|
842 Vbigfloat_max_prec = make_fixnum (0); |
2051 | 843 #endif /* HAVE_BIGFLOAT */ |
844 | |
1983 | 845 Fprovide (intern ("number-types")); |
846 #ifdef HAVE_BIGNUM | |
847 Fprovide (intern ("bignum")); | |
848 #endif | |
849 #ifdef HAVE_RATIO | |
850 Fprovide (intern ("ratio")); | |
851 #endif | |
852 #ifdef HAVE_BIGFLOAT | |
853 Fprovide (intern ("bigfloat")); | |
854 #endif | |
855 } | |
856 | |
857 void | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
858 reinit_vars_of_number (void) |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
859 { |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
860 #if defined(HAVE_BIGFLOAT) && defined(HAVE_BIGNUM) |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
861 Vbigfloat_max_prec = make_bignum (0L); |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
862 bignum_set_ulong (XBIGNUM_DATA (Vbigfloat_max_prec), ULONG_MAX); |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
863 #endif |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
864 } |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
865 |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
866 void |
1983 | 867 init_number (void) |
868 { | |
869 if (!number_initialized) | |
870 { | |
871 number_initialized = 1; | |
872 | |
5739
a2912073be85
Support bignums with MPIR. Add documentation on the bignum, ratio,
Jerry James <james@xemacs.org>
parents:
5602
diff
changeset
|
873 #if defined(WITH_GMP) || defined(WITH_MPIR) |
1983 | 874 init_number_gmp (); |
875 #endif | |
876 #ifdef WITH_MP | |
877 init_number_mp (); | |
878 #endif | |
879 | |
880 #ifdef HAVE_BIGNUM | |
881 bignum_init (scratch_bignum); | |
882 bignum_init (scratch_bignum2); | |
883 #endif | |
884 | |
885 #ifdef HAVE_RATIO | |
886 ratio_init (scratch_ratio); | |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3391
diff
changeset
|
887 ratio_init (scratch_ratio2); |
1983 | 888 #endif |
889 | |
890 #ifdef HAVE_BIGFLOAT | |
891 bigfloat_init (scratch_bigfloat); | |
892 bigfloat_init (scratch_bigfloat2); | |
893 #endif | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
894 |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
895 #ifndef PDUMP |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
896 reinit_vars_of_number (); |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
897 #endif |
1983 | 898 } |
899 } |