2 ent-float.c -- Ordinary Floats for SXEmacs
3 Copyright (C) 2005, 2006 Sebastian Freundt
5 Author: Sebastian Freundt
7 This file is part of SXEmacs
9 SXEmacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 SXEmacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with this program. If not, see <http://www.gnu.org/licenses/>. */
27 #include "sysproc.h" /* For qxe_getpid */
29 #include "ent-float.h"
32 Lisp_Object Vmost_positive_float;
33 Lisp_Object Vmost_negative_float;
34 Lisp_Object Vleast_positive_float;
35 Lisp_Object Vleast_negative_float;
36 Lisp_Object Vleast_positive_normalised_float;
37 Lisp_Object Vleast_negative_normalised_float;
38 Lisp_Object Vfloat_epsilon;
40 Fixnum max_float_print_size = 0;
44 mark_float(Lisp_Object obj)
52 float_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
54 return (ent_float(obj1) == ent_float(obj2));
59 static inline unsigned long
60 float_hash(Lisp_Object obj, int SXE_UNUSED(depth))
63 fpfloat h = 22.0/7.0*ent_float(obj);
64 union {fpfloat h; long unsigned int hash;} u;
67 return (long unsigned int)u.hash;
69 /* mod the value down to 32-bit range */
70 /* #### change for 64-bit machines */
71 /* WHAT THE FUCK!?! */
72 return (long unsigned int)fmod(ent_float(obj), 4e9);
76 static const struct lrecord_description float_description[] = {
81 print_float(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
83 char pigbuf[350]; /* see comments in float_to_string */
85 float_to_string(pigbuf, XFLOAT_DATA(obj), sizeof(pigbuf));
86 write_c_string(pigbuf, printcharfun);
89 DEFINE_BASIC_LRECORD_IMPLEMENTATION("float", float,
90 mark_float, print_float, 0, float_equal,
91 float_hash, float_description, Lisp_Float);
94 static inline Lisp_Object
95 ent_sum_FLOAT_T(Lisp_Object l, Lisp_Object r)
97 return make_float(XFLOAT_DATA(l) + XFLOAT_DATA(r));
99 static inline Lisp_Object
100 ent_sum_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
102 return make_float(XFLOAT_DATA(l) + ent_int(r));
104 static inline Lisp_Object
105 ent_sum_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
107 return make_float(ent_int(l) + XFLOAT_DATA(r));
110 static inline Lisp_Object
111 ent_diff_FLOAT_T(Lisp_Object l, Lisp_Object r)
113 return make_float(XFLOAT_DATA(l) - XFLOAT_DATA(r));
115 static inline Lisp_Object
116 ent_diff_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
118 return make_float(XFLOAT_DATA(l) - ent_int(r));
120 static inline Lisp_Object
121 ent_diff_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
123 return make_float(ent_int(l) - XFLOAT_DATA(r));
126 static inline Lisp_Object
127 ent_neg_FLOAT_T(Lisp_Object l)
129 return make_float(-XFLOAT_DATA(l));
132 static inline Lisp_Object
133 ent_prod_FLOAT_T(Lisp_Object l, Lisp_Object r)
135 return make_float(XFLOAT_DATA(l) * XFLOAT_DATA(r));
137 static inline Lisp_Object
138 ent_prod_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
140 return make_float(ent_int(l) * XFLOAT_DATA(r));
142 static inline Lisp_Object
143 ent_prod_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
145 return make_float(XFLOAT_DATA(l) * ent_int(r));
148 static inline Lisp_Object
149 ent_div_FLOAT_T(Lisp_Object l, Lisp_Object r)
151 if (XFLOAT_DATA(r) == 0.0f) {
152 if (XFLOAT_DATA(l) > 0.0f)
153 return make_indef(POS_INFINITY);
154 else if (XFLOAT_DATA(l) < 0.0f)
155 return make_indef(NEG_INFINITY);
157 return make_indef(NOT_A_NUMBER);
159 return make_float(XFLOAT_DATA(l)/XFLOAT_DATA(r));
161 static inline Lisp_Object
162 ent_div_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
164 if (XFLOAT_DATA(r) == 0.0f) {
165 EMACS_INT rl = ent_int(l);
167 return make_indef(POS_INFINITY);
169 return make_indef(NEG_INFINITY);
171 return make_indef(NOT_A_NUMBER);
173 return make_float(ent_int(l)/XFLOAT_DATA(r));
175 static inline Lisp_Object
176 ent_div_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
178 EMACS_INT rr = ent_int(r);
180 if (XFLOAT_DATA(l) > 0.0f)
181 return make_indef(POS_INFINITY);
182 else if (XFLOAT_DATA(l) < 0.0f)
183 return make_indef(NEG_INFINITY);
185 return make_indef(NOT_A_NUMBER);
187 return make_float(XFLOAT_DATA(l)/rr);
190 static inline Lisp_Object
191 ent_rem_FLOAT_T(Lisp_Object l, Lisp_Object r)
194 return make_float(0.0);
196 static inline Lisp_Object
197 ent_rem_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
200 return make_float(0.0);
203 static inline Lisp_Object
204 ent_mod_FLOAT_T(Lisp_Object l, Lisp_Object r)
208 if (XFLOAT_DATA(r) == 0)
209 Fsignal(Qarith_error, Qnil);
210 rem = fmod(XFLOAT_DATA(l), XFLOAT_DATA(r));
212 /* If the "remainder" comes out with the wrong sign, fix it. */
213 if (XFLOAT_DATA(r) < 0 ? rem > 0 : rem < 0)
214 rem += XFLOAT_DATA(r);
215 return make_float(rem);
217 static inline Lisp_Object
218 ent_mod_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
221 EMACS_INT rr = ent_int(r);
224 Fsignal(Qarith_error, Qnil);
225 rem = fmod(XFLOAT_DATA(l), rr);
227 /* If the "remainder" comes out with the wrong sign, fix it. */
228 if (rr < 0 ? rem > 0 : rem < 0)
230 return make_float(rem);
232 static inline Lisp_Object
233 ent_mod_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
237 if (XFLOAT_DATA(r) == 0)
238 Fsignal(Qarith_error, Qnil);
239 rem = fmod(ent_int(l), XFLOAT_DATA(r));
241 /* If the "remainder" comes out with the wrong sign, fix it. */
242 if (XFLOAT_DATA(r) < 0.0f ? rem > 0.0f : rem < 0.f)
243 rem += XFLOAT_DATA(r);
244 return make_float(rem);
247 static inline Lisp_Object
248 ent_inv_FLOAT_T(Lisp_Object l)
250 if (XFLOAT_DATA(l) == 0.0f) {
251 return make_indef(POS_INFINITY);
253 return make_float(1.0/XFLOAT_DATA(l));
255 static inline Lisp_Object
256 ent_pow_FLOAT_T_integer(Lisp_Object l, Lisp_Object r)
259 fpfloat x = XFLOAT_DATA(l);
260 EMACS_INT y = ent_int(r);
266 retval = (y & 1) ? -1.0 : 1.0;
275 y = (EMACS_UINT) y >> 1;
278 return make_float(retval);
280 static inline Lisp_Object
281 ent_pow_FLOAT_T_float(Lisp_Object l, Lisp_Object r)
283 fpfloat f1 = ent_float(l);
284 fpfloat f2 = ent_float(r);
286 /* Really should check for overflow, too */
287 if (f1 == 0.0 && f2 == 0.0)
288 return make_float(1.0);
289 else if (f1 == 0.0 && f2 < 0.0)
290 Fsignal(Qarith_error, r);
291 else if (f1 < 0 && f2 != floor(f2))
292 Fsignal(Qdomain_error, r);
294 return make_float(pow(f1, f2));
296 return make_float(0.0);
301 ent_lt_float(Lisp_Object l, Lisp_Object r)
303 return (XFLOAT_DATA(l) < XFLOAT_DATA(r));
306 ent_lt_int_float(Lisp_Object l, Lisp_Object r)
308 return (ent_int(l) < XFLOAT_DATA(r));
311 ent_lt_float_int(Lisp_Object l, Lisp_Object r)
313 return (XFLOAT_DATA(l) < ent_int(r));
317 ent_gt_float(Lisp_Object l, Lisp_Object r)
319 return (XFLOAT_DATA(l) > XFLOAT_DATA(r));
322 ent_gt_float_int(Lisp_Object l, Lisp_Object r)
324 return (XFLOAT_DATA(l) > ent_int(r));
327 ent_gt_int_float(Lisp_Object l, Lisp_Object r)
329 return (ent_int(l) > XFLOAT_DATA(r));
333 ent_eq_float(Lisp_Object l, Lisp_Object r)
335 #if defined HAVE_CLEAN_FLOATOPS || 1 /* we wait until this breaks */
336 return (XFLOAT_DATA(l) == XFLOAT_DATA(r));
340 diff = XFLOAT_DATA(l) - XFLOAT_DATA(r);
342 if (diff == (fpfloat)0.0)
344 else if (diff < (fpfloat)0.0 && diff > -XFLOAT_DATA(Vfloat_epsilon))
346 else if (diff > (fpfloat)0.0 && diff < XFLOAT_DATA(Vfloat_epsilon))
353 ent_eq_int_float(Lisp_Object l, Lisp_Object r)
355 return (ent_int(l) == XFLOAT_DATA(r));
358 ent_eq_float_int(Lisp_Object l, Lisp_Object r)
360 return (XFLOAT_DATA(l) == ent_int(r));
364 ent_ne_float(Lisp_Object l, Lisp_Object r)
366 return (XFLOAT_DATA(l) != XFLOAT_DATA(r));
369 ent_ne_int_float(Lisp_Object l, Lisp_Object r)
371 return (ent_int(l) != XFLOAT_DATA(r));
374 ent_ne_float_int(Lisp_Object l, Lisp_Object r)
376 return (XFLOAT_DATA(l) != ent_int(r));
380 static inline Lisp_Object
381 ent_lift_INT_T_FLOAT_T(Lisp_Object number, unsigned long precision)
383 return make_float(ent_int(number));
385 static inline Lisp_Object
386 _ent_lift_INT_T_FLOAT_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(unused))
388 return make_float(ent_int(number));
391 static inline Lisp_Object
392 ent_lift_FLOAT_T_INT_T(Lisp_Object number, unsigned long precision)
394 return Ftruncate(number);
396 static inline Lisp_Object
397 _ent_lift_FLOAT_T_INT_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(unused))
399 return Ftruncate(number);
403 ent_float_zerop(Lisp_Object l)
405 return (XFLOAT_DATA(l) == 0.0f);
409 ent_float_onep(Lisp_Object l)
411 return (XFLOAT_DATA(l) == 1.0f);
415 ent_float_unitp(Lisp_Object unused)
421 static ase_nullary_operation_f Qent_float_zero, Qent_float_one;
423 ent_float_nullary_optable_init(void)
425 Qent_float_zero = make_float(0.0f);
426 Qent_float_one = make_float(1.0f);
427 staticpro(&Qent_float_zero);
428 staticpro(&Qent_float_one);
430 ent_nullop_register(ASE_NULLARY_OP_ZERO, FLOAT_T, Qent_float_zero);
431 ent_nullop_register(ASE_NULLARY_OP_ONE, FLOAT_T, Qent_float_one);
435 ent_float_unary_optable_init(void)
437 ent_unop_register(ASE_UNARY_OP_NEG, FLOAT_T, ent_neg_FLOAT_T);
438 ent_unop_register(ASE_UNARY_OP_INV, FLOAT_T, ent_inv_FLOAT_T);
442 ent_float_binary_optable_init(void)
445 ent_binop_register(ASE_BINARY_OP_SUM,
446 FLOAT_T, FLOAT_T, ent_sum_FLOAT_T);
447 ent_binop_register(ASE_BINARY_OP_SUM,
448 FLOAT_T, INT_T, ent_sum_FLOAT_T_INT_T);
449 ent_binop_register(ASE_BINARY_OP_SUM,
450 INT_T, FLOAT_T, ent_sum_INT_T_FLOAT_T);
451 ent_binop_register(ASE_BINARY_OP_DIFF,
452 FLOAT_T, FLOAT_T, ent_diff_FLOAT_T);
453 ent_binop_register(ASE_BINARY_OP_DIFF,
454 FLOAT_T, INT_T, ent_diff_FLOAT_T_INT_T);
455 ent_binop_register(ASE_BINARY_OP_DIFF,
456 INT_T, FLOAT_T, ent_diff_INT_T_FLOAT_T);
459 ent_binop_register(ASE_BINARY_OP_PROD,
460 FLOAT_T, FLOAT_T, ent_prod_FLOAT_T);
461 ent_binop_register(ASE_BINARY_OP_PROD,
462 FLOAT_T, INT_T, ent_prod_FLOAT_T_INT_T);
463 ent_binop_register(ASE_BINARY_OP_PROD,
464 INT_T, FLOAT_T, ent_prod_INT_T_FLOAT_T);
465 ent_binop_register(ASE_BINARY_OP_DIV,
466 FLOAT_T, FLOAT_T, ent_div_FLOAT_T);
467 ent_binop_register(ASE_BINARY_OP_DIV,
468 FLOAT_T, INT_T, ent_div_FLOAT_T_INT_T);
469 ent_binop_register(ASE_BINARY_OP_DIV,
470 INT_T, FLOAT_T, ent_div_INT_T_FLOAT_T);
471 ent_binop_register(ASE_BINARY_OP_QUO,
472 FLOAT_T, FLOAT_T, ent_div_FLOAT_T);
473 ent_binop_register(ASE_BINARY_OP_QUO,
474 FLOAT_T, INT_T, ent_div_FLOAT_T_INT_T);
475 ent_binop_register(ASE_BINARY_OP_QUO,
476 INT_T, FLOAT_T, ent_div_INT_T_FLOAT_T);
479 ent_binop_register(ASE_BINARY_OP_REM,
480 FLOAT_T, FLOAT_T, ent_rem_FLOAT_T);
481 ent_binop_register(ASE_BINARY_OP_REM,
482 FLOAT_T, INT_T, ent_rem_FLOAT_T_INT_T);
483 ent_binop_register(ASE_BINARY_OP_REM,
484 INT_T, FLOAT_T, ent_rem_FLOAT_T);
485 ent_binop_register(ASE_BINARY_OP_MOD,
486 FLOAT_T, FLOAT_T, ent_mod_FLOAT_T);
487 ent_binop_register(ASE_BINARY_OP_MOD,
488 FLOAT_T, INT_T, ent_mod_FLOAT_T_INT_T);
489 ent_binop_register(ASE_BINARY_OP_MOD,
490 INT_T, FLOAT_T, ent_mod_INT_T_FLOAT_T);
492 ent_binop_register(ASE_BINARY_OP_POW,
493 FLOAT_T, INT_T, ent_pow_FLOAT_T_integer);
494 ent_binop_register(ASE_BINARY_OP_POW,
495 FLOAT_T, FLOAT_T, ent_pow_FLOAT_T_float);
499 ent_float_unary_reltable_init(void)
501 ent_unrel_register(ASE_UNARY_REL_ZEROP, FLOAT_T, ent_float_zerop);
502 ent_unrel_register(ASE_UNARY_REL_ONEP, FLOAT_T, ent_float_onep);
503 ent_unrel_register(ASE_UNARY_REL_UNITP, FLOAT_T, ent_float_unitp);
507 ent_float_binary_reltable_init(void)
509 ent_binrel_register(ASE_BINARY_REL_LESSP,
510 FLOAT_T, FLOAT_T, ent_lt_float);
511 ent_binrel_register(ASE_BINARY_REL_LESSP,
512 FLOAT_T, INT_T, ent_lt_float_int);
513 ent_binrel_register(ASE_BINARY_REL_LESSP,
514 INT_T, FLOAT_T, ent_lt_int_float);
515 ent_binrel_register(ASE_BINARY_REL_GREATERP,
516 FLOAT_T, FLOAT_T, ent_gt_float);
517 ent_binrel_register(ASE_BINARY_REL_GREATERP,
518 FLOAT_T, INT_T, ent_gt_float_int);
519 ent_binrel_register(ASE_BINARY_REL_GREATERP,
520 INT_T, FLOAT_T, ent_gt_int_float);
521 ent_binrel_register(ASE_BINARY_REL_EQUALP,
522 FLOAT_T, FLOAT_T, ent_eq_float);
523 ent_binrel_register(ASE_BINARY_REL_EQUALP,
524 FLOAT_T, INT_T, ent_eq_float_int);
525 ent_binrel_register(ASE_BINARY_REL_EQUALP,
526 INT_T, FLOAT_T, ent_eq_int_float);
527 ent_binrel_register(ASE_BINARY_REL_NEQP,
528 FLOAT_T, FLOAT_T, ent_ne_float);
529 ent_binrel_register(ASE_BINARY_REL_NEQP,
530 INT_T, FLOAT_T, ent_ne_int_float);
531 ent_binrel_register(ASE_BINARY_REL_NEQP,
532 FLOAT_T, INT_T, ent_ne_float_int);
536 ent_float_lifttable_init(void)
538 /* lift tables (coercion) */
539 ent_lift_register(INT_T, FLOAT_T, _ent_lift_INT_T_FLOAT_T);
540 ent_lift_register(FLOAT_T, INT_T, _ent_lift_FLOAT_T_INT_T);
541 ent_lift_register(INDEF_T, FLOAT_T, ent_lift_INDEF_T_COMPARABLE);
544 void init_optables_FLOAT_T(void)
546 ent_float_nullary_optable_init();
547 ent_float_unary_optable_init();
548 ent_float_binary_optable_init();
549 ent_float_unary_reltable_init();
550 ent_float_binary_reltable_init();
551 ent_float_lifttable_init();
555 void init_ent_float(void)
559 void syms_of_ent_float(void)
561 INIT_LRECORD_IMPLEMENTATION(float);
564 void vars_of_ent_float(void)
566 fpfloat f = 0.0, fp = 0.0;
570 (f = 2.0 * (fp = f)) &&
571 ! ENT_FLOAT_INDEFINITE_P(f) );
573 DEFVAR_CONST_LISP("most-positive-float", &Vmost_positive_float /*
574 The float closest in value to +infinity.
576 Vmost_positive_float = make_float(fp);
580 (f = 2.0 * (fp = f)) &&
581 ! ENT_FLOAT_INDEFINITE_P(f) );
583 DEFVAR_CONST_LISP("most-negative-float", &Vmost_negative_float /*
584 The float closest in value to -infinity.
586 Vmost_negative_float = make_float(fp);
590 /* let's compute the array we need to print such a float */
592 max_float_print_size = snprintf(tmp, sizeof(tmp), "%f", fp);
593 #elif fpfloat_long_double_p
594 max_float_print_size = snprintf(tmp, sizeof(tmp), "%Lf", fp);
597 assert(max_float_print_size>0);
598 max_float_print_size += 10;
600 DEFVAR_CONST_INT("max-float-print-size", &max_float_print_size /*
601 The maximal string length of a printed float.
606 while ((f = (fp = f) / 2) != 0.0);
607 DEFVAR_CONST_LISP("least-positive-float", &Vleast_positive_float /*
608 The float closest in value to +0.
610 Vleast_positive_float = make_float(fp);
613 while ((f = (fp = f) / 2) != -0.0);
614 DEFVAR_CONST_LISP("least-negative-float", &Vleast_negative_float /*
615 The float closest in value to -0.
617 Vleast_negative_float = make_float(fp);
619 for( f = fp = 1.0; (f /= 2) * 2 == fp && f != 0; fp = f );
620 DEFVAR_CONST_LISP("least-positive-normalised-float",
621 &Vleast_positive_normalised_float /*
622 The float closest in value to +0 without rounding errors.
624 Vleast_positive_normalised_float = make_float(fp);
626 for( f = fp = -1.0; ( f /= 2) * 2 == fp && f != 0; fp = f);
627 DEFVAR_CONST_LISP("least-negative-normalised-float",
628 &Vleast_negative_normalised_float /*
629 The float closest in value to -0 without rounding errors.
631 Vleast_negative_normalised_float = make_float(fp);
633 DEFVAR_CONST_LISP("float-epsilon", &Vfloat_epsilon /*
634 The least positive float which, added to 1, is still greater than 1.
636 #if defined DBL_EPSILON
637 Vfloat_epsilon = make_float(DBL_EPSILON);
638 #else /* !DBL_EPSILON */
640 while ((f = (fp = f) / 2) + 1 != 1);
641 Vfloat_epsilon = make_float(fp);
642 #endif /* DBL_EPSILON */
644 Fprovide(intern("fpfloat"));
645 Fprovide(intern("lisp-float-type"));
648 /* ent-float.c ends here */