Mercurial > hg > xemacs-beta

comparison src/number.c @ 5125:b5df3737028a ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge
author Ben Wing <ben@xemacs.org>
date Wed, 24 Feb 2010 01:58:04 -0600
parents 623d57b7fbe8 16112448d484
children 0dcd22290039
comparison
equal deleted inserted replaced
5124:623d57b7fbe8 5125:b5df3737028a
1 /* Numeric types for XEmacs. 1 /* Numeric types for XEmacs.
2 Copyright (C) 2004 Jerry James. 2 Copyright (C) 2004 Jerry James.
3 Copyright (C) 2010 Ben Wing.
3 4
4 This file is part of XEmacs. 5 This file is part of XEmacs.
5 6
6 XEmacs is free software; you can redistribute it and/or modify it 7 XEmacs is free software; you can redistribute it and/or modify it
7 under the terms of the GNU General Public License as published by the 8 under the terms of the GNU General Public License as published by the
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
14 for more details. 15 for more details.
15 16
16 You should have received a copy of the GNU General Public License 17 You should have received a copy of the GNU General Public License
17 along with XEmacs; see the file COPYING. If not, write to 18 along with XEmacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 19 the Free Software Foundation, Inc., 51 Franklin St - Fifth Floor,
19 Boston, MA 02111-1307, USA. */ 20 Boston, MA 02111-1301, USA. */
20 21
21 /* Synched up with: Not in FSF. */ 22 /* Synched up with: Not in FSF. */
22 23
23 #include <config.h> 24 #include <config.h>
24 #include <limits.h> 25 #include <limits.h>
30 #define USED_IF_BIGFLOAT(decl) UNUSED (decl) 31 #define USED_IF_BIGFLOAT(decl) UNUSED (decl)
31 #endif 32 #endif
32 33
33 Lisp_Object Qrationalp, Qfloatingp, Qrealp; 34 Lisp_Object Qrationalp, Qfloatingp, Qrealp;
34 Lisp_Object Vdefault_float_precision; 35 Lisp_Object Vdefault_float_precision;
35 Fixnum Vmost_negative_fixnum, Vmost_positive_fixnum; 36
36 static Lisp_Object Qunsupported_type; 37 static Lisp_Object Qunsupported_type;
37 static Lisp_Object Vbigfloat_max_prec; 38 static Lisp_Object Vbigfloat_max_prec;
38 static int number_initialized; 39 static int number_initialized;
39 40
40 #ifdef HAVE_BIGNUM 41 #ifdef HAVE_BIGNUM
51 #ifdef HAVE_BIGNUM 52 #ifdef HAVE_BIGNUM
52 static void 53 static void
53 bignum_print (Lisp_Object obj, Lisp_Object printcharfun, 54 bignum_print (Lisp_Object obj, Lisp_Object printcharfun,
54 int UNUSED (escapeflag)) 55 int UNUSED (escapeflag))
55 { 56 {
56 CIbyte *bstr = bignum_to_string (XBIGNUM_DATA (obj), 10); 57 Ascbyte *bstr = bignum_to_string (XBIGNUM_DATA (obj), 10);
57 write_c_string (printcharfun, bstr); 58 write_ascstring (printcharfun, bstr);
58 xfree (bstr, CIbyte *); 59 xfree (bstr);
59 } 60 }
61
62 #ifdef NEW_GC
63 static void
64 bignum_finalize (void *header)
65 {
66 struct Lisp_Bignum *num = (struct Lisp_Bignum *) header;
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);
72 }
73 #define BIGNUM_FINALIZE bignum_finalize
74 #else
75 #define BIGNUM_FINALIZE 0
76 #endif
60 77
61 static int 78 static int
62 bignum_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) 79 bignum_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth),
80 int UNUSED (foldcase))
63 { 81 {
64 return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); 82 return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2));
65 } 83 }
66 84
67 static Hashcode 85 static Hashcode
80 98
81 static void 99 static void
82 bignum_convfree (const void * UNUSED (object), void *data, 100 bignum_convfree (const void * UNUSED (object), void *data,
83 Bytecount UNUSED (size)) 101 Bytecount UNUSED (size))
84 { 102 {
85 xfree (data, void *); 103 xfree (data);
86 } 104 }
87 105
88 static void * 106 static void *
89 bignum_deconvert (void *object, void *data, Bytecount UNUSED (size)) 107 bignum_deconvert (void *object, void *data, Bytecount UNUSED (size))
90 { 108 {
105 0, { &bignum_opc }, XD_FLAG_NO_KKCC }, 123 0, { &bignum_opc }, XD_FLAG_NO_KKCC },
106 { XD_END } 124 { XD_END }
107 }; 125 };
108 126
109 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("bignum", bignum, 0, bignum_print, 127 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("bignum", bignum, 0, bignum_print,
110 0, bignum_equal, bignum_hash, 128 BIGNUM_FINALIZE, bignum_equal,
111 bignum_description, Lisp_Bignum); 129 bignum_hash, bignum_description,
130 Lisp_Bignum);
112 131
113 #endif /* HAVE_BIGNUM */ 132 #endif /* HAVE_BIGNUM */
114 133
115 Lisp_Object Qbignump; 134 Lisp_Object Qbignump;
116 135
118 Return t if OBJECT is a bignum, nil otherwise. 137 Return t if OBJECT is a bignum, nil otherwise.
119 */ 138 */
120 (object)) 139 (object))
121 { 140 {
122 return BIGNUMP (object) ? Qt : Qnil; 141 return BIGNUMP (object) ? Qt : Qnil;
123 }
124
125
126 /********************************* Integers *********************************/
127 DEFUN ("integerp", Fintegerp, 1, 1, 0, /*
128 Return t if OBJECT is an integer, nil otherwise.
129 */
130 (object))
131 {
132 return INTEGERP (object) ? Qt : Qnil;
133 }
134
135 DEFUN ("evenp", Fevenp, 1, 1, 0, /*
136 Return t if INTEGER is even, nil otherwise.
137 */
138 (integer))
139 {
140 CONCHECK_INTEGER (integer);
141 return (BIGNUMP (integer)
142 ? bignum_evenp (XBIGNUM_DATA (integer))
143 : XTYPE (integer) == Lisp_Type_Int_Even) ? Qt : Qnil;
144 }
145
146 DEFUN ("oddp", Foddp, 1, 1, 0, /*
147 Return t if INTEGER is odd, nil otherwise.
148 */
149 (integer))
150 {
151 CONCHECK_INTEGER (integer);
152 return (BIGNUMP (integer)
153 ? bignum_oddp (XBIGNUM_DATA (integer))
154 : XTYPE (integer) == Lisp_Type_Int_Odd) ? Qt : Qnil;
155 } 142 }
156 143
157 144
158 /********************************** Ratios **********************************/ 145 /********************************** Ratios **********************************/
159 #ifdef HAVE_RATIO 146 #ifdef HAVE_RATIO
160 static void 147 static void
161 ratio_print (Lisp_Object obj, Lisp_Object printcharfun, 148 ratio_print (Lisp_Object obj, Lisp_Object printcharfun,
162 int UNUSED (escapeflag)) 149 int UNUSED (escapeflag))
163 { 150 {
164 CIbyte *rstr = ratio_to_string (XRATIO_DATA (obj), 10); 151 CIbyte *rstr = ratio_to_string (XRATIO_DATA (obj), 10);
165 write_c_string (printcharfun, rstr); 152 write_ascstring (printcharfun, rstr);
166 xfree (rstr, CIbyte *); 153 xfree (rstr);
167 } 154 }
155
156 #ifdef NEW_GC
157 static void
158 ratio_finalize (void *header)
159 {
160 struct Lisp_Ratio *num = (struct Lisp_Ratio *) header;
161 /* #### WARNING: It would be better to put some sort of check to make
162 sure this doesn't happen more than once, just in case ---
163 e.g. checking if it's zero before finalizing and then setting it to
164 zero after finalizing. */
165 ratio_fini (num->data);
166 }
167 #define RATIO_FINALIZE ratio_finalize
168 #else
169 #define RATIO_FINALIZE 0
170 #endif
168 171
169 static int 172 static int
170 ratio_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) 173 ratio_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth),
174 int UNUSED (foldcase))
171 { 175 {
172 return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); 176 return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2));
173 } 177 }
174 178
175 static Hashcode 179 static Hashcode
182 { XD_OPAQUE_PTR, offsetof (Lisp_Ratio, data) }, 186 { XD_OPAQUE_PTR, offsetof (Lisp_Ratio, data) },
183 { XD_END } 187 { XD_END }
184 }; 188 };
185 189
186 DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("ratio", ratio, 0, ratio_print, 190 DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("ratio", ratio, 0, ratio_print,
187 0, ratio_equal, ratio_hash, 191 RATIO_FINALIZE, ratio_equal, ratio_hash,
188 ratio_description, Lisp_Ratio); 192 ratio_description, Lisp_Ratio);
189 193
190 #endif /* HAVE_RATIO */ 194 #endif /* HAVE_RATIO */
191 195
192 Lisp_Object Qratiop; 196 Lisp_Object Qratiop;
215 */ 219 */
216 (rational)) 220 (rational))
217 { 221 {
218 CONCHECK_RATIONAL (rational); 222 CONCHECK_RATIONAL (rational);
219 #ifdef HAVE_RATIO 223 #ifdef HAVE_RATIO
220 return RATIOP (rational) 224 if (RATIOP (rational))
221 ? make_bignum_bg (XRATIO_NUMERATOR (rational)) 225 {
222 : rational; 226 return
223 #else 227 Fcanonicalize_number (make_bignum_bg (XRATIO_NUMERATOR (rational)));
228 }
229 #endif
224 return rational; 230 return rational;
225 #endif
226 } 231 }
227 232
228 DEFUN ("denominator", Fdenominator, 1, 1, 0, /* 233 DEFUN ("denominator", Fdenominator, 1, 1, 0, /*
229 Return the denominator of the canonical form of RATIONAL. 234 Return the denominator of the canonical form of RATIONAL.
230 If RATIONAL is an integer, 1 is returned. 235 If RATIONAL is an integer, 1 is returned.
231 */ 236 */
232 (rational)) 237 (rational))
233 { 238 {
234 CONCHECK_RATIONAL (rational); 239 CONCHECK_RATIONAL (rational);
235 #ifdef HAVE_RATIO 240 #ifdef HAVE_RATIO
236 return RATIOP (rational) 241 if (RATIOP (rational))
237 ? make_bignum_bg (XRATIO_DENOMINATOR (rational)) 242 {
238 : make_int (1); 243 return Fcanonicalize_number (make_bignum_bg
239 #else 244 (XRATIO_DENOMINATOR (rational)));
240 return rational; 245 }
241 #endif 246 #endif
247 return make_int (1);
242 } 248 }
243 249
244 250
245 /******************************** Bigfloats *********************************/ 251 /******************************** Bigfloats *********************************/
246 #ifdef HAVE_BIGFLOAT 252 #ifdef HAVE_BIGFLOAT
247 static void 253 static void
248 bigfloat_print (Lisp_Object obj, Lisp_Object printcharfun, 254 bigfloat_print (Lisp_Object obj, Lisp_Object printcharfun,
249 int UNUSED (escapeflag)) 255 int UNUSED (escapeflag))
250 { 256 {
251 CIbyte *fstr = bigfloat_to_string (XBIGFLOAT_DATA (obj), 10); 257 Ascbyte *fstr = bigfloat_to_string (XBIGFLOAT_DATA (obj), 10);
252 write_c_string (printcharfun, fstr); 258 write_ascstring (printcharfun, fstr);
253 xfree (fstr, CIbyte *); 259 xfree (fstr);
254 } 260 }
261
262 #ifdef NEW_GC
263 static void
264 bigfloat_finalize (void *header)
265 {
266 struct Lisp_Bigfloat *num = (struct Lisp_Bigfloat *) header;
267 /* #### WARNING: It would be better to put some sort of check to make
268 sure this doesn't happen more than once, just in case ---
269 e.g. checking if it's zero before finalizing and then setting it to
270 zero after finalizing. */
271 bigfloat_fini (num->bf);
272 }
273 #define BIGFLOAT_FINALIZE bigfloat_finalize
274 #else
275 #define BIGFLOAT_FINALIZE 0
276 #endif
255 277
256 static int 278 static int
257 bigfloat_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) 279 bigfloat_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth),
280 int UNUSED (foldcase))
258 { 281 {
259 return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); 282 return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2));
260 } 283 }
261 284
262 static Hashcode 285 static Hashcode
269 { XD_OPAQUE_PTR, offsetof (Lisp_Bigfloat, bf) }, 292 { XD_OPAQUE_PTR, offsetof (Lisp_Bigfloat, bf) },
270 { XD_END } 293 { XD_END }
271 }; 294 };
272 295
273 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("bigfloat", bigfloat, 0, 296 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("bigfloat", bigfloat, 0,
274 bigfloat_print, 0, 297 bigfloat_print, BIGFLOAT_FINALIZE,
275 bigfloat_equal, bigfloat_hash, 298 bigfloat_equal, bigfloat_hash,
276 bigfloat_description, Lisp_Bigfloat); 299 bigfloat_description, Lisp_Bigfloat);
277 300
278 #endif /* HAVE_BIGFLOAT */ 301 #endif /* HAVE_BIGFLOAT */
279 302
343 366
344 CONCHECK_INTEGER (*val); 367 CONCHECK_INTEGER (*val);
345 #ifdef HAVE_BIGFLOAT 368 #ifdef HAVE_BIGFLOAT
346 if (INTP (*val)) 369 if (INTP (*val))
347 prec = XINT (*val); 370 prec = XINT (*val);
348 else 371 else
349 { 372 {
350 if (!bignum_fits_ulong_p (XBIGNUM_DATA (*val))) 373 if (!bignum_fits_ulong_p (XBIGNUM_DATA (*val)))
351 args_out_of_range_3 (*val, Qzero, Vbigfloat_max_prec); 374 args_out_of_range_3 (*val, Qzero, Vbigfloat_max_prec);
352 prec = bignum_to_ulong (XBIGNUM_DATA (*val)); 375 prec = bignum_to_ulong (XBIGNUM_DATA (*val));
353 } 376 }
403 appropriate. */ 426 appropriate. */
404 #ifdef HAVE_RATIO 427 #ifdef HAVE_RATIO
405 if (RATIOP (number) && 428 if (RATIOP (number) &&
406 bignum_fits_long_p (XRATIO_DENOMINATOR (number)) && 429 bignum_fits_long_p (XRATIO_DENOMINATOR (number)) &&
407 bignum_to_long (XRATIO_DENOMINATOR (number)) == 1L) 430 bignum_to_long (XRATIO_DENOMINATOR (number)) == 1L)
408 number = make_bignum_bg (XRATIO_NUMERATOR (number)); 431 number = Fcanonicalize_number (make_bignum_bg (XRATIO_NUMERATOR (number)));
409 #endif 432 #endif
410 #ifdef HAVE_BIGNUM 433 #ifdef HAVE_BIGNUM
411 if (BIGNUMP (number) && bignum_fits_emacs_int_p (XBIGNUM_DATA (number))) 434 if (BIGNUMP (number) && bignum_fits_emacs_int_p (XBIGNUM_DATA (number)))
412 { 435 {
413 EMACS_INT n = bignum_to_emacs_int (XBIGNUM_DATA (number)); 436 EMACS_INT n = bignum_to_emacs_int (XBIGNUM_DATA (number));
653 ? XBIGFLOAT_GET_PREC (*arg2) : 676 ? XBIGFLOAT_GET_PREC (*arg2) :
654 #endif 677 #endif
655 0UL); 678 0UL);
656 return type2; 679 return type2;
657 } 680 }
658 681
659 if (type2 < type1) 682 if (type2 < type1)
660 { 683 {
661 *arg2 = internal_coerce_number (*arg2, type1, 684 *arg2 = internal_coerce_number (*arg2, type1,
662 #ifdef HAVE_BIGFLOAT 685 #ifdef HAVE_BIGFLOAT
663 type1 == BIGFLOAT_T 686 type1 == BIGFLOAT_T
760 DEFSYMBOL (Qratiop); 783 DEFSYMBOL (Qratiop);
761 DEFSYMBOL (Qbigfloatp); 784 DEFSYMBOL (Qbigfloatp);
762 785
763 /* Functions */ 786 /* Functions */
764 DEFSUBR (Fbignump); 787 DEFSUBR (Fbignump);
765 DEFSUBR (Fintegerp);
766 DEFSUBR (Fevenp);
767 DEFSUBR (Foddp);
768 DEFSUBR (Fratiop); 788 DEFSUBR (Fratiop);
769 DEFSUBR (Frationalp); 789 DEFSUBR (Frationalp);
770 DEFSUBR (Fnumerator); 790 DEFSUBR (Fnumerator);
771 DEFSUBR (Fdenominator); 791 DEFSUBR (Fdenominator);
772 DEFSUBR (Fbigfloatp); 792 DEFSUBR (Fbigfloatp);
798 The maximum number of bits of precision a bigfloat can have. 818 The maximum number of bits of precision a bigfloat can have.
799 This is determined by the underlying library used to implement bigfloats. 819 This is determined by the underlying library used to implement bigfloats.
800 */); 820 */);
801 821
802 #ifdef HAVE_BIGFLOAT 822 #ifdef HAVE_BIGFLOAT
803 #ifdef HAVE_BIGNUM 823 /* Don't create a bignum here. Otherwise, we lose with NEW_GC + pdump.
824 See reinit_vars_of_number(). */
825 Vbigfloat_max_prec = make_int (EMACS_INT_MAX);
826 #else
827 Vbigfloat_max_prec = make_int (0);
828 #endif /* HAVE_BIGFLOAT */
829
830 Fprovide (intern ("number-types"));
831 #ifdef HAVE_BIGNUM
832 Fprovide (intern ("bignum"));
833 #endif
834 #ifdef HAVE_RATIO
835 Fprovide (intern ("ratio"));
836 #endif
837 #ifdef HAVE_BIGFLOAT
838 Fprovide (intern ("bigfloat"));
839 #endif
840 }
841
842 void
843 reinit_vars_of_number (void)
844 {
845 #if defined(HAVE_BIGFLOAT) && defined(HAVE_BIGNUM)
804 Vbigfloat_max_prec = make_bignum (0L); 846 Vbigfloat_max_prec = make_bignum (0L);
805 bignum_set_ulong (XBIGNUM_DATA (Vbigfloat_max_prec), ULONG_MAX); 847 bignum_set_ulong (XBIGNUM_DATA (Vbigfloat_max_prec), ULONG_MAX);
806 #else
807 Vbigfloat_max_prec = make_int (EMACS_INT_MAX);
808 #endif
809 #else
810 Vbigfloat_max_prec = make_int (0);
811 #endif /* HAVE_BIGFLOAT */
812
813 DEFVAR_CONST_INT ("most-negative-fixnum", &Vmost_negative_fixnum /*
814 The fixnum closest in value to negative infinity.
815 */);
816 Vmost_negative_fixnum = EMACS_INT_MIN;
817
818 DEFVAR_CONST_INT ("most-positive-fixnum", &Vmost_positive_fixnum /*
819 The fixnum closest in value to positive infinity.
820 */);
821 Vmost_positive_fixnum = EMACS_INT_MAX;
822
823 Fprovide (intern ("number-types"));
824 #ifdef HAVE_BIGNUM
825 Fprovide (intern ("bignum"));
826 #endif
827 #ifdef HAVE_RATIO
828 Fprovide (intern ("ratio"));
829 #endif
830 #ifdef HAVE_BIGFLOAT
831 Fprovide (intern ("bigfloat"));
832 #endif 848 #endif
833 } 849 }
834 850
835 void 851 void
836 init_number (void) 852 init_number (void)
858 874
859 #ifdef HAVE_BIGFLOAT 875 #ifdef HAVE_BIGFLOAT
860 bigfloat_init (scratch_bigfloat); 876 bigfloat_init (scratch_bigfloat);
861 bigfloat_init (scratch_bigfloat2); 877 bigfloat_init (scratch_bigfloat2);
862 #endif 878 #endif
863 } 879
864 } 880 #ifndef PDUMP
881 reinit_vars_of_number ();
882 #endif
883 }
884 }