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