cgit.sxemacs.org Git - sxemacs/blob - src/ent/ent-float.c

   1 /*
   2   ent-float.c -- Ordinary Floats for SXEmacs
   3   Copyright (C) 2005, 2006 Sebastian Freundt
   4
   5   Author:  Sebastian Freundt
   6
   7 This file is part of SXEmacs
   8
   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.
  13
  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.
  18
  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/>. */
  21
  22
  23 #include <config.h>
  24 #include <limits.h>
  25 #include <math.h>
  26 #include "lisp.h"
  27 #include "sysproc.h"    /* For qxe_getpid */
  28
  29 #include "ent.h"
  30
  31 \f
  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;
  39
  40 Fixnum max_float_print_size = 0;
  41
  42 \f
  43 static Lisp_Object
  44 mark_float(Lisp_Object SXE_UNUSED(obj))
  45 {
  46         return Qnil;
  47 }
  48
  49 static inline int
  50 float_equal(Lisp_Object obj1, Lisp_Object obj2, int SXE_UNUSED(depth))
  51 {
  52         return (ent_float(obj1) == ent_float(obj2));
  53 }
  54
  55 static inline unsigned long
  56 float_hash(Lisp_Object obj, int SXE_UNUSED(depth))
  57 {
  58 #if 1
  59         fpfloat h = 22.0/7.0*ent_float(obj);
  60         union {fpfloat h; long unsigned int hash;} u;
  61
  62         u.h = h;
  63         return (long unsigned int)u.hash;
  64 #else
  65         /* mod the value down to 32-bit range */
  66         /* #### change for 64-bit machines */
  67         /* WHAT THE FUCK!?! */
  68         return (long unsigned int)fmod(ent_float(obj), 4e9);
  69 #endif
  70 }
  71
  72 static const struct lrecord_description float_description[] = {
  73         {XD_END}
  74 };
  75
  76 void inline
  77 print_float(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  78 {
  79         char pigbuf[350];       /* see comments in float_to_string */
  80
  81         float_to_string(pigbuf, XFLOAT_DATA(obj), sizeof(pigbuf));
  82         write_c_string(pigbuf, printcharfun);
  83 }
  84
  85 DEFINE_BASIC_LRECORD_IMPLEMENTATION("float", float,
  86                                     mark_float, print_float, 0, float_equal,
  87                                     float_hash, float_description, Lisp_Float);
  88
  89 \f
  90 static inline Lisp_Object
  91 ent_sum_FLOAT_T(Lisp_Object l, Lisp_Object r)
  92 {
  93         return make_float(XFLOAT_DATA(l) + XFLOAT_DATA(r));
  94 }
  95 static inline Lisp_Object
  96 ent_sum_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
  97 {
  98         return make_float(XFLOAT_DATA(l) + ent_int(r));
  99 }
 100 static inline Lisp_Object
 101 ent_sum_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
 102 {
 103         return make_float(ent_int(l) + XFLOAT_DATA(r));
 104 }
 105
 106 static inline Lisp_Object
 107 ent_diff_FLOAT_T(Lisp_Object l, Lisp_Object r)
 108 {
 109         return make_float(XFLOAT_DATA(l) - XFLOAT_DATA(r));
 110 }
 111 static inline Lisp_Object
 112 ent_diff_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
 113 {
 114         return make_float(XFLOAT_DATA(l) - ent_int(r));
 115 }
 116 static inline Lisp_Object
 117 ent_diff_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
 118 {
 119         return make_float(ent_int(l) - XFLOAT_DATA(r));
 120 }
 121
 122 static inline Lisp_Object
 123 ent_neg_FLOAT_T(Lisp_Object l)
 124 {
 125         return make_float(-XFLOAT_DATA(l));
 126 }
 127
 128 static inline Lisp_Object
 129 ent_prod_FLOAT_T(Lisp_Object l, Lisp_Object r)
 130 {
 131         return make_float(XFLOAT_DATA(l) * XFLOAT_DATA(r));
 132 }
 133 static inline Lisp_Object
 134 ent_prod_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
 135 {
 136         return make_float(ent_int(l) * XFLOAT_DATA(r));
 137 }
 138 static inline Lisp_Object
 139 ent_prod_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
 140 {
 141         return make_float(XFLOAT_DATA(l) * ent_int(r));
 142 }
 143
 144 static inline Lisp_Object
 145 ent_div_FLOAT_T(Lisp_Object l, Lisp_Object r)
 146 {
 147         if (XFLOAT_DATA(r) == 0.0f) {
 148                 if (XFLOAT_DATA(l) > 0.0f)
 149                         return make_indef(POS_INFINITY);
 150                 else if (XFLOAT_DATA(l) < 0.0f)
 151                         return make_indef(NEG_INFINITY);
 152                 else
 153                         return make_indef(NOT_A_NUMBER);
 154         }
 155         return make_float(XFLOAT_DATA(l)/XFLOAT_DATA(r));
 156 }
 157 static inline Lisp_Object
 158 ent_div_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
 159 {
 160         if (XFLOAT_DATA(r) == 0.0f) {
 161                 EMACS_INT rl = ent_int(l);
 162                 if (rl > 0)
 163                         return make_indef(POS_INFINITY);
 164                 else if (rl < 0)
 165                         return make_indef(NEG_INFINITY);
 166                 else
 167                         return make_indef(NOT_A_NUMBER);
 168         }
 169         return make_float(ent_int(l)/XFLOAT_DATA(r));
 170 }
 171 static inline Lisp_Object
 172 ent_div_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
 173 {
 174         EMACS_INT rr = ent_int(r);
 175         if (rr == 0) {
 176                 if (XFLOAT_DATA(l) > 0.0f)
 177                         return make_indef(POS_INFINITY);
 178                 else if (XFLOAT_DATA(l) < 0.0f)
 179                         return make_indef(NEG_INFINITY);
 180                 else
 181                         return make_indef(NOT_A_NUMBER);
 182         }
 183         return make_float(XFLOAT_DATA(l)/rr);
 184 }
 185
 186 static inline Lisp_Object
 187 ent_rem_FLOAT_T(Lisp_Object SXE_UNUSED(l), Lisp_Object SXE_UNUSED(r))
 188 {
 189         return make_float(0.0);
 190 }
 191 static inline Lisp_Object
 192 ent_rem_FLOAT_T_INT_T(Lisp_Object SXE_UNUSED(l), Lisp_Object SXE_UNUSED(r))
 193 {
 194         return make_float(0.0);
 195 }
 196
 197 static inline Lisp_Object
 198 ent_mod_FLOAT_T(Lisp_Object l, Lisp_Object r)
 199 {
 200         fpfloat rem;
 201
 202         if (XFLOAT_DATA(r) == 0)
 203                 Fsignal(Qarith_error, Qnil);
 204         rem = fmod(XFLOAT_DATA(l), XFLOAT_DATA(r));
 205
 206         /* If the "remainder" comes out with the wrong sign, fix it.  */
 207         if (XFLOAT_DATA(r) < 0 ? rem > 0 : rem < 0)
 208                 rem += XFLOAT_DATA(r);
 209         return make_float(rem);
 210 }
 211 static inline Lisp_Object
 212 ent_mod_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
 213 {
 214         fpfloat rem;
 215         EMACS_INT rr = ent_int(r);
 216
 217         if (rr == 0)
 218                 Fsignal(Qarith_error, Qnil);
 219         rem = fmod(XFLOAT_DATA(l), rr);
 220
 221         /* If the "remainder" comes out with the wrong sign, fix it.  */
 222         if (rr < 0 ? rem > 0 : rem < 0)
 223                 rem += rr;
 224         return make_float(rem);
 225 }
 226 static inline Lisp_Object
 227 ent_mod_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
 228 {
 229         fpfloat rem;
 230
 231         if (XFLOAT_DATA(r) == 0)
 232                 Fsignal(Qarith_error, Qnil);
 233         rem = fmod(ent_int(l), XFLOAT_DATA(r));
 234
 235         /* If the "remainder" comes out with the wrong sign, fix it.  */
 236         if (XFLOAT_DATA(r) < 0.0f ? rem > 0.0f : rem < 0.f)
 237                 rem += XFLOAT_DATA(r);
 238         return make_float(rem);
 239 }
 240
 241 static inline Lisp_Object
 242 ent_inv_FLOAT_T(Lisp_Object l)
 243 {
 244         if (XFLOAT_DATA(l) == 0.0f) {
 245                 return make_indef(POS_INFINITY);
 246         }
 247         return make_float(1.0/XFLOAT_DATA(l));
 248 }
 249 static inline Lisp_Object
 250 ent_pow_FLOAT_T_integer(Lisp_Object l, Lisp_Object r)
 251 {
 252         fpfloat retval;
 253         fpfloat x = XFLOAT_DATA(l);
 254         EMACS_INT y = ent_int(r);
 255
 256         if (y < 0) {
 257                 if (x == 1.0)
 258                         retval = 1.0;
 259                 else if (x == -1.0)
 260                         retval = (y & 1) ? -1.0 : 1.0;
 261                 else
 262                         retval = 0.0;
 263         } else {
 264                 retval = 1.0;
 265                 while (y > 0) {
 266                         if (y & 1)
 267                                 retval *= x;
 268                         x *= x;
 269                         y = (EMACS_UINT) y >> 1;
 270                 }
 271         }
 272         return make_float(retval);
 273 }
 274 static inline Lisp_Object
 275 ent_pow_FLOAT_T_float(Lisp_Object l, Lisp_Object r)
 276 {
 277         fpfloat f1 = ent_float(l);
 278         fpfloat f2 = ent_float(r);
 279
 280         /* Really should check for overflow, too */
 281         if (f1 == 0.0 && f2 == 0.0)
 282                 return make_float(1.0);
 283         else if (f1 == 0.0 && f2 < 0.0)
 284                 Fsignal(Qarith_error, r);
 285         else if (f1 < 0 && f2 != floor(f2))
 286                 Fsignal(Qdomain_error, r);
 287         else
 288                 return make_float(pow(f1, f2));
 289
 290         return make_float(0.0);
 291 }
 292
 293 /* relations */
 294 static inline int
 295 ent_lt_float(Lisp_Object l, Lisp_Object r)
 296 {
 297         return (XFLOAT_DATA(l) < XFLOAT_DATA(r));
 298 }
 299 static inline int
 300 ent_lt_int_float(Lisp_Object l, Lisp_Object r)
 301 {
 302         return (ent_int(l) < XFLOAT_DATA(r));
 303 }
 304 static inline int
 305 ent_lt_float_int(Lisp_Object l, Lisp_Object r)
 306 {
 307         return (XFLOAT_DATA(l) < ent_int(r));
 308 }
 309
 310 static inline int
 311 ent_gt_float(Lisp_Object l, Lisp_Object r)
 312 {
 313         return (XFLOAT_DATA(l) > XFLOAT_DATA(r));
 314 }
 315 static inline int
 316 ent_gt_float_int(Lisp_Object l, Lisp_Object r)
 317 {
 318         return (XFLOAT_DATA(l) > ent_int(r));
 319 }
 320 static inline int
 321 ent_gt_int_float(Lisp_Object l, Lisp_Object r)
 322 {
 323         return (ent_int(l) > XFLOAT_DATA(r));
 324 }
 325
 326 static inline int
 327 ent_eq_float(Lisp_Object l, Lisp_Object r)
 328 {
 329 #if defined HAVE_CLEAN_FLOATOPS || 1    /* we wait until this breaks */
 330         return (XFLOAT_DATA(l) == XFLOAT_DATA(r));
 331 #else
 332         fpfloat diff;
 333
 334         diff = XFLOAT_DATA(l) - XFLOAT_DATA(r);
 335
 336         if (diff == (fpfloat)0.0)
 337                 return 1;
 338         else if (diff < (fpfloat)0.0 && diff > -XFLOAT_DATA(Vfloat_epsilon))
 339                 return 1;
 340         else if (diff > (fpfloat)0.0 && diff < XFLOAT_DATA(Vfloat_epsilon))
 341                 return 1;
 342         else
 343                 return 0;
 344 #endif
 345 }
 346 static inline int
 347 ent_eq_int_float(Lisp_Object l, Lisp_Object r)
 348 {
 349         return (ent_int(l) == XFLOAT_DATA(r));
 350 }
 351 static inline int
 352 ent_eq_float_int(Lisp_Object l, Lisp_Object r)
 353 {
 354         return (XFLOAT_DATA(l) == ent_int(r));
 355 }
 356
 357 static inline int
 358 ent_ne_float(Lisp_Object l, Lisp_Object r)
 359 {
 360         return (XFLOAT_DATA(l) != XFLOAT_DATA(r));
 361 }
 362 static inline int
 363 ent_ne_int_float(Lisp_Object l, Lisp_Object r)
 364 {
 365         return (ent_int(l) != XFLOAT_DATA(r));
 366 }
 367 static inline int
 368 ent_ne_float_int(Lisp_Object l, Lisp_Object r)
 369 {
 370         return (XFLOAT_DATA(l) != ent_int(r));
 371 }
 372
 373 \f
 374 static inline Lisp_Object
 375 ent_lift_INT_T_FLOAT_T(Lisp_Object number, unsigned long precision)
 376 {
 377         return make_float(ent_int(number));
 378 }
 379 static inline Lisp_Object
 380 _ent_lift_INT_T_FLOAT_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(unused))
 381 {
 382         return make_float(ent_int(number));
 383 }
 384
 385 static inline Lisp_Object
 386 ent_lift_FLOAT_T_INT_T(Lisp_Object number, unsigned long precision)
 387 {
 388         return Ftruncate(number);
 389 }
 390 static inline Lisp_Object
 391 _ent_lift_FLOAT_T_INT_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(unused))
 392 {
 393         return Ftruncate(number);
 394 }
 395
 396 static inline int
 397 ent_float_zerop(Lisp_Object l)
 398 {
 399         return (XFLOAT_DATA(l) == 0.0f);
 400 }
 401
 402 static inline int
 403 ent_float_onep(Lisp_Object l)
 404 {
 405         return (XFLOAT_DATA(l) == 1.0f);
 406 }
 407
 408 static inline int
 409 ent_float_unitp(Lisp_Object unused)
 410 {
 411         return 1;
 412 }
 413
 414 \f
 415 static ase_nullary_operation_f Qent_float_zero, Qent_float_one;
 416 static inline void
 417 ent_float_nullary_optable_init(void)
 418 {
 419         Qent_float_zero = make_float(0.0f);
 420         Qent_float_one = make_float(1.0f);
 421         staticpro(&Qent_float_zero);
 422         staticpro(&Qent_float_one);
 423
 424         ent_nullop_register(ASE_NULLARY_OP_ZERO, FLOAT_T, Qent_float_zero);
 425         ent_nullop_register(ASE_NULLARY_OP_ONE, FLOAT_T, Qent_float_one);
 426 }
 427
 428 static inline void
 429 ent_float_unary_optable_init(void)
 430 {
 431         ent_unop_register(ASE_UNARY_OP_NEG, FLOAT_T, ent_neg_FLOAT_T);
 432         ent_unop_register(ASE_UNARY_OP_INV, FLOAT_T, ent_inv_FLOAT_T);
 433 }
 434
 435 static inline void
 436 ent_float_binary_optable_init(void)
 437 {
 438         /* sums */
 439         ent_binop_register(ASE_BINARY_OP_SUM,
 440                            FLOAT_T, FLOAT_T, ent_sum_FLOAT_T);
 441         ent_binop_register(ASE_BINARY_OP_SUM,
 442                            FLOAT_T, INT_T, ent_sum_FLOAT_T_INT_T);
 443         ent_binop_register(ASE_BINARY_OP_SUM,
 444                            INT_T, FLOAT_T, ent_sum_INT_T_FLOAT_T);
 445         ent_binop_register(ASE_BINARY_OP_DIFF,
 446                            FLOAT_T, FLOAT_T, ent_diff_FLOAT_T);
 447         ent_binop_register(ASE_BINARY_OP_DIFF,
 448                            FLOAT_T, INT_T, ent_diff_FLOAT_T_INT_T);
 449         ent_binop_register(ASE_BINARY_OP_DIFF,
 450                            INT_T, FLOAT_T, ent_diff_INT_T_FLOAT_T);
 451
 452         /* products */
 453         ent_binop_register(ASE_BINARY_OP_PROD,
 454                            FLOAT_T, FLOAT_T, ent_prod_FLOAT_T);
 455         ent_binop_register(ASE_BINARY_OP_PROD,
 456                            FLOAT_T, INT_T, ent_prod_FLOAT_T_INT_T);
 457         ent_binop_register(ASE_BINARY_OP_PROD,
 458                            INT_T, FLOAT_T, ent_prod_INT_T_FLOAT_T);
 459         ent_binop_register(ASE_BINARY_OP_DIV,
 460                            FLOAT_T, FLOAT_T, ent_div_FLOAT_T);
 461         ent_binop_register(ASE_BINARY_OP_DIV,
 462                            FLOAT_T, INT_T, ent_div_FLOAT_T_INT_T);
 463         ent_binop_register(ASE_BINARY_OP_DIV,
 464                            INT_T, FLOAT_T, ent_div_INT_T_FLOAT_T);
 465         ent_binop_register(ASE_BINARY_OP_QUO,
 466                            FLOAT_T, FLOAT_T, ent_div_FLOAT_T);
 467         ent_binop_register(ASE_BINARY_OP_QUO,
 468                            FLOAT_T, INT_T, ent_div_FLOAT_T_INT_T);
 469         ent_binop_register(ASE_BINARY_OP_QUO,
 470                            INT_T, FLOAT_T, ent_div_INT_T_FLOAT_T);
 471
 472         /* remainders */
 473         ent_binop_register(ASE_BINARY_OP_REM,
 474                            FLOAT_T, FLOAT_T, ent_rem_FLOAT_T);
 475         ent_binop_register(ASE_BINARY_OP_REM,
 476                            FLOAT_T, INT_T, ent_rem_FLOAT_T_INT_T);
 477         ent_binop_register(ASE_BINARY_OP_REM,
 478                            INT_T, FLOAT_T, ent_rem_FLOAT_T);
 479         ent_binop_register(ASE_BINARY_OP_MOD,
 480                            FLOAT_T, FLOAT_T, ent_mod_FLOAT_T);
 481         ent_binop_register(ASE_BINARY_OP_MOD,
 482                            FLOAT_T, INT_T, ent_mod_FLOAT_T_INT_T);
 483         ent_binop_register(ASE_BINARY_OP_MOD,
 484                            INT_T, FLOAT_T, ent_mod_INT_T_FLOAT_T);
 485         /* powers */
 486         ent_binop_register(ASE_BINARY_OP_POW,
 487                            FLOAT_T, INT_T, ent_pow_FLOAT_T_integer);
 488         ent_binop_register(ASE_BINARY_OP_POW,
 489                            FLOAT_T, FLOAT_T, ent_pow_FLOAT_T_float);
 490 }
 491
 492 static inline void
 493 ent_float_unary_reltable_init(void)
 494 {
 495         ent_unrel_register(ASE_UNARY_REL_ZEROP, FLOAT_T, ent_float_zerop);
 496         ent_unrel_register(ASE_UNARY_REL_ONEP, FLOAT_T, ent_float_onep);
 497         ent_unrel_register(ASE_UNARY_REL_UNITP, FLOAT_T, ent_float_unitp);
 498 }
 499
 500 static inline void
 501 ent_float_binary_reltable_init(void)
 502 {
 503         ent_binrel_register(ASE_BINARY_REL_LESSP,
 504                             FLOAT_T, FLOAT_T, ent_lt_float);
 505         ent_binrel_register(ASE_BINARY_REL_LESSP,
 506                             FLOAT_T, INT_T, ent_lt_float_int);
 507         ent_binrel_register(ASE_BINARY_REL_LESSP,
 508                             INT_T, FLOAT_T, ent_lt_int_float);
 509         ent_binrel_register(ASE_BINARY_REL_GREATERP,
 510                             FLOAT_T, FLOAT_T, ent_gt_float);
 511         ent_binrel_register(ASE_BINARY_REL_GREATERP,
 512                             FLOAT_T, INT_T, ent_gt_float_int);
 513         ent_binrel_register(ASE_BINARY_REL_GREATERP,
 514                             INT_T, FLOAT_T, ent_gt_int_float);
 515         ent_binrel_register(ASE_BINARY_REL_EQUALP,
 516                             FLOAT_T, FLOAT_T, ent_eq_float);
 517         ent_binrel_register(ASE_BINARY_REL_EQUALP,
 518                             FLOAT_T, INT_T, ent_eq_float_int);
 519         ent_binrel_register(ASE_BINARY_REL_EQUALP,
 520                             INT_T, FLOAT_T, ent_eq_int_float);
 521         ent_binrel_register(ASE_BINARY_REL_NEQP,
 522                             FLOAT_T, FLOAT_T, ent_ne_float);
 523         ent_binrel_register(ASE_BINARY_REL_NEQP,
 524                             INT_T, FLOAT_T, ent_ne_int_float);
 525         ent_binrel_register(ASE_BINARY_REL_NEQP,
 526                             FLOAT_T, INT_T, ent_ne_float_int);
 527 }
 528
 529 static inline void
 530 ent_float_lifttable_init(void)
 531 {
 532         /* lift tables (coercion) */
 533         ent_lift_register(INT_T, FLOAT_T, _ent_lift_INT_T_FLOAT_T);
 534         ent_lift_register(FLOAT_T, INT_T, _ent_lift_FLOAT_T_INT_T);
 535         ent_lift_register(INDEF_T, FLOAT_T, ent_lift_INDEF_T_COMPARABLE);
 536 }
 537
 538 void init_optables_FLOAT_T(void)
 539 {
 540         ent_float_nullary_optable_init();
 541         ent_float_unary_optable_init();
 542         ent_float_binary_optable_init();
 543         ent_float_unary_reltable_init();
 544         ent_float_binary_reltable_init();
 545         ent_float_lifttable_init();
 546 }
 547
 548
 549 void init_ent_float(void)
 550 {
 551 }
 552
 553 void syms_of_ent_float(void)
 554 {
 555         INIT_LRECORD_IMPLEMENTATION(float);
 556 }
 557
 558 void vars_of_ent_float(void)
 559 {
 560         fpfloat f = 0.0, fp = 0.0;
 561
 562         f = 1.0;
 563         while ( (f > fp) &&
 564                 (f = 2.0 * (fp = f)) &&
 565                 ! ENT_FLOAT_INDEFINITE_P(f) );
 566
 567         DEFVAR_CONST_LISP("most-positive-float", &Vmost_positive_float /*
 568 The float closest in value to +infinity.
 569                                                                        */);
 570         Vmost_positive_float = make_float(fp);
 571
 572         f = -1.0;
 573         while ( (f < fp) &&
 574                 (f = 2.0 * (fp = f)) &&
 575                 ! ENT_FLOAT_INDEFINITE_P(f) );
 576
 577         DEFVAR_CONST_LISP("most-negative-float", &Vmost_negative_float /*
 578 The float closest in value to -infinity.
 579                                                                        */);
 580         Vmost_negative_float = make_float(fp);
 581
 582         {
 583                 char tmp[] = "1.0";
 584         /* let's compute the array we need to print such a float */
 585 #if fpfloat_double_p
 586                 max_float_print_size = snprintf(tmp, sizeof(tmp), "%f", fp);
 587 #elif fpfloat_long_double_p
 588                 max_float_print_size = snprintf(tmp, sizeof(tmp), "%Lf", fp);
 589 #endif
 590         }
 591         assert(max_float_print_size>0);
 592         max_float_print_size += 10;
 593
 594         DEFVAR_CONST_INT("max-float-print-size", &max_float_print_size /*
 595 The maximal string length of a printed float.
 596                                                                        */);
 597
 598         /* other stuff */
 599         f = 1.0;
 600         while ((f = (fp = f) / 2) != 0.0);
 601         DEFVAR_CONST_LISP("least-positive-float", &Vleast_positive_float /*
 602 The float closest in value to +0.
 603                                                                        */);
 604         Vleast_positive_float = make_float(fp);
 605
 606         f = -1.0;
 607         while ((f = (fp = f) / 2) != -0.0);
 608         DEFVAR_CONST_LISP("least-negative-float", &Vleast_negative_float /*
 609 The float closest in value to -0.
 610                                                                        */);
 611         Vleast_negative_float = make_float(fp);
 612
 613         for( f = fp = 1.0; (f /= 2) * 2 == fp && f != 0; fp = f );
 614         DEFVAR_CONST_LISP("least-positive-normalised-float",
 615                           &Vleast_positive_normalised_float /*
 616 The float closest in value to +0 without rounding errors.
 617                                                             */);
 618         Vleast_positive_normalised_float = make_float(fp);
 619
 620         for( f = fp = -1.0; ( f /= 2) * 2 == fp && f != 0; fp = f);
 621         DEFVAR_CONST_LISP("least-negative-normalised-float",
 622                           &Vleast_negative_normalised_float /*
 623 The float closest in value to -0 without rounding errors.
 624                                                             */);
 625         Vleast_negative_normalised_float = make_float(fp);
 626
 627         DEFVAR_CONST_LISP("float-epsilon", &Vfloat_epsilon /*
 628 The least positive float which, added to 1, is still greater than 1.
 629                                                            */);
 630 #if defined DBL_EPSILON
 631         Vfloat_epsilon = make_float(DBL_EPSILON);
 632 #else  /* !DBL_EPSILON */
 633         f = 1.0;
 634         while ((f = (fp = f) / 2) + 1 != 1);
 635         Vfloat_epsilon = make_float(fp);
 636 #endif  /* DBL_EPSILON */
 637
 638         Fprovide(intern("fpfloat"));
 639         Fprovide(intern("lisp-float-type"));
 640 }
 641
 642 /* ent-float.c ends here */