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-float.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 obj)
  45 {
  46         return Qnil;
  47
  48         if (obj);
  49 }
  50
  51 static inline int
  52 float_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
  53 {
  54         return (ent_float(obj1) == ent_float(obj2));
  55
  56         if (depth);
  57 }
  58
  59 static inline unsigned long
  60 float_hash(Lisp_Object obj, int SXE_UNUSED(depth))
  61 {
  62 #if 1
  63         fpfloat h = 22.0/7.0*ent_float(obj);
  64         union {fpfloat h; long unsigned int hash;} u;
  65
  66         u.h = h;
  67         return (long unsigned int)u.hash;
  68 #else
  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);
  73 #endif
  74 }
  75
  76 static const struct lrecord_description float_description[] = {
  77         {XD_END}
  78 };
  79
  80 void inline
  81 print_float(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  82 {
  83         char pigbuf[350];       /* see comments in float_to_string */
  84
  85         float_to_string(pigbuf, XFLOAT_DATA(obj), sizeof(pigbuf));
  86         write_c_string(pigbuf, printcharfun);
  87 }
  88
  89 DEFINE_BASIC_LRECORD_IMPLEMENTATION("float", float,
  90                                     mark_float, print_float, 0, float_equal,
  91                                     float_hash, float_description, Lisp_Float);
  92
  93 \f
  94 static inline Lisp_Object
  95 ent_sum_FLOAT_T(Lisp_Object l, Lisp_Object r)
  96 {
  97         return make_float(XFLOAT_DATA(l) + XFLOAT_DATA(r));
  98 }
  99 static inline Lisp_Object
 100 ent_sum_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
 101 {
 102         return make_float(XFLOAT_DATA(l) + ent_int(r));
 103 }
 104 static inline Lisp_Object
 105 ent_sum_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
 106 {
 107         return make_float(ent_int(l) + XFLOAT_DATA(r));
 108 }
 109
 110 static inline Lisp_Object
 111 ent_diff_FLOAT_T(Lisp_Object l, Lisp_Object r)
 112 {
 113         return make_float(XFLOAT_DATA(l) - XFLOAT_DATA(r));
 114 }
 115 static inline Lisp_Object
 116 ent_diff_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
 117 {
 118         return make_float(XFLOAT_DATA(l) - ent_int(r));
 119 }
 120 static inline Lisp_Object
 121 ent_diff_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
 122 {
 123         return make_float(ent_int(l) - XFLOAT_DATA(r));
 124 }
 125
 126 static inline Lisp_Object
 127 ent_neg_FLOAT_T(Lisp_Object l)
 128 {
 129         return make_float(-XFLOAT_DATA(l));
 130 }
 131
 132 static inline Lisp_Object
 133 ent_prod_FLOAT_T(Lisp_Object l, Lisp_Object r)
 134 {
 135         return make_float(XFLOAT_DATA(l) * XFLOAT_DATA(r));
 136 }
 137 static inline Lisp_Object
 138 ent_prod_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
 139 {
 140         return make_float(ent_int(l) * XFLOAT_DATA(r));
 141 }
 142 static inline Lisp_Object
 143 ent_prod_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
 144 {
 145         return make_float(XFLOAT_DATA(l) * ent_int(r));
 146 }
 147
 148 static inline Lisp_Object
 149 ent_div_FLOAT_T(Lisp_Object l, Lisp_Object r)
 150 {
 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);
 156                 else
 157                         return make_indef(NOT_A_NUMBER);
 158         }
 159         return make_float(XFLOAT_DATA(l)/XFLOAT_DATA(r));
 160 }
 161 static inline Lisp_Object
 162 ent_div_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
 163 {
 164         if (XFLOAT_DATA(r) == 0.0f) {
 165                 EMACS_INT rl = ent_int(l);
 166                 if (rl > 0)
 167                         return make_indef(POS_INFINITY);
 168                 else if (rl < 0)
 169                         return make_indef(NEG_INFINITY);
 170                 else
 171                         return make_indef(NOT_A_NUMBER);
 172         }
 173         return make_float(ent_int(l)/XFLOAT_DATA(r));
 174 }
 175 static inline Lisp_Object
 176 ent_div_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
 177 {
 178         EMACS_INT rr = ent_int(r);
 179         if (rr == 0) {
 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);
 184                 else
 185                         return make_indef(NOT_A_NUMBER);
 186         }
 187         return make_float(XFLOAT_DATA(l)/rr);
 188 }
 189
 190 static inline Lisp_Object
 191 ent_rem_FLOAT_T(Lisp_Object l, Lisp_Object r)
 192 {
 193         if (l);
 194         return make_float(0.0);
 195 }
 196 static inline Lisp_Object
 197 ent_rem_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
 198 {
 199         if (l);
 200         return make_float(0.0);
 201 }
 202
 203 static inline Lisp_Object
 204 ent_mod_FLOAT_T(Lisp_Object l, Lisp_Object r)
 205 {
 206         fpfloat rem;
 207
 208         if (XFLOAT_DATA(r) == 0)
 209                 Fsignal(Qarith_error, Qnil);
 210         rem = fmod(XFLOAT_DATA(l), XFLOAT_DATA(r));
 211
 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);
 216 }
 217 static inline Lisp_Object
 218 ent_mod_FLOAT_T_INT_T(Lisp_Object l, Lisp_Object r)
 219 {
 220         fpfloat rem;
 221         EMACS_INT rr = ent_int(r);
 222
 223         if (rr == 0)
 224                 Fsignal(Qarith_error, Qnil);
 225         rem = fmod(XFLOAT_DATA(l), rr);
 226
 227         /* If the "remainder" comes out with the wrong sign, fix it.  */
 228         if (rr < 0 ? rem > 0 : rem < 0)
 229                 rem += rr;
 230         return make_float(rem);
 231 }
 232 static inline Lisp_Object
 233 ent_mod_INT_T_FLOAT_T(Lisp_Object l, Lisp_Object r)
 234 {
 235         fpfloat rem;
 236
 237         if (XFLOAT_DATA(r) == 0)
 238                 Fsignal(Qarith_error, Qnil);
 239         rem = fmod(ent_int(l), XFLOAT_DATA(r));
 240
 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);
 245 }
 246
 247 static inline Lisp_Object
 248 ent_inv_FLOAT_T(Lisp_Object l)
 249 {
 250         if (XFLOAT_DATA(l) == 0.0f) {
 251                 return make_indef(POS_INFINITY);
 252         }
 253         return make_float(1.0/XFLOAT_DATA(l));
 254 }
 255 static inline Lisp_Object
 256 ent_pow_FLOAT_T_integer(Lisp_Object l, Lisp_Object r)
 257 {
 258         fpfloat retval;
 259         fpfloat x = XFLOAT_DATA(l);
 260         EMACS_INT y = ent_int(r);
 261
 262         if (y < 0) {
 263                 if (x == 1.0)
 264                         retval = 1.0;
 265                 else if (x == -1.0)
 266                         retval = (y & 1) ? -1.0 : 1.0;
 267                 else
 268                         retval = 0.0;
 269         } else {
 270                 retval = 1.0;
 271                 while (y > 0) {
 272                         if (y & 1)
 273                                 retval *= x;
 274                         x *= x;
 275                         y = (EMACS_UINT) y >> 1;
 276                 }
 277         }
 278         return make_float(retval);
 279 }
 280 static inline Lisp_Object
 281 ent_pow_FLOAT_T_float(Lisp_Object l, Lisp_Object r)
 282 {
 283         fpfloat f1 = ent_float(l);
 284         fpfloat f2 = ent_float(r);
 285
 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);
 293         else
 294                 return make_float(pow(f1, f2));
 295
 296         return make_float(0.0);
 297 }
 298
 299 /* relations */
 300 static inline int
 301 ent_lt_float(Lisp_Object l, Lisp_Object r)
 302 {
 303         return (XFLOAT_DATA(l) < XFLOAT_DATA(r));
 304 }
 305 static inline int
 306 ent_lt_int_float(Lisp_Object l, Lisp_Object r)
 307 {
 308         return (ent_int(l) < XFLOAT_DATA(r));
 309 }
 310 static inline int
 311 ent_lt_float_int(Lisp_Object l, Lisp_Object r)
 312 {
 313         return (XFLOAT_DATA(l) < ent_int(r));
 314 }
 315
 316 static inline int
 317 ent_gt_float(Lisp_Object l, Lisp_Object r)
 318 {
 319         return (XFLOAT_DATA(l) > XFLOAT_DATA(r));
 320 }
 321 static inline int
 322 ent_gt_float_int(Lisp_Object l, Lisp_Object r)
 323 {
 324         return (XFLOAT_DATA(l) > ent_int(r));
 325 }
 326 static inline int
 327 ent_gt_int_float(Lisp_Object l, Lisp_Object r)
 328 {
 329         return (ent_int(l) > XFLOAT_DATA(r));
 330 }
 331
 332 static inline int
 333 ent_eq_float(Lisp_Object l, Lisp_Object r)
 334 {
 335 #if defined HAVE_CLEAN_FLOATOPS || 1    /* we wait until this breaks */
 336         return (XFLOAT_DATA(l) == XFLOAT_DATA(r));
 337 #else
 338         fpfloat diff;
 339
 340         diff = XFLOAT_DATA(l) - XFLOAT_DATA(r);
 341
 342         if (diff == (fpfloat)0.0)
 343                 return 1;
 344         else if (diff < (fpfloat)0.0 && diff > -XFLOAT_DATA(Vfloat_epsilon))
 345                 return 1;
 346         else if (diff > (fpfloat)0.0 && diff < XFLOAT_DATA(Vfloat_epsilon))
 347                 return 1;
 348         else
 349                 return 0;
 350 #endif
 351 }
 352 static inline int
 353 ent_eq_int_float(Lisp_Object l, Lisp_Object r)
 354 {
 355         return (ent_int(l) == XFLOAT_DATA(r));
 356 }
 357 static inline int
 358 ent_eq_float_int(Lisp_Object l, Lisp_Object r)
 359 {
 360         return (XFLOAT_DATA(l) == ent_int(r));
 361 }
 362
 363 static inline int
 364 ent_ne_float(Lisp_Object l, Lisp_Object r)
 365 {
 366         return (XFLOAT_DATA(l) != XFLOAT_DATA(r));
 367 }
 368 static inline int
 369 ent_ne_int_float(Lisp_Object l, Lisp_Object r)
 370 {
 371         return (ent_int(l) != XFLOAT_DATA(r));
 372 }
 373 static inline int
 374 ent_ne_float_int(Lisp_Object l, Lisp_Object r)
 375 {
 376         return (XFLOAT_DATA(l) != ent_int(r));
 377 }
 378
 379 \f
 380 static inline Lisp_Object
 381 ent_lift_INT_T_FLOAT_T(Lisp_Object number, unsigned long precision)
 382 {
 383         return make_float(ent_int(number));
 384 }
 385 static inline Lisp_Object
 386 _ent_lift_INT_T_FLOAT_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(unused))
 387 {
 388         return make_float(ent_int(number));
 389 }
 390
 391 static inline Lisp_Object
 392 ent_lift_FLOAT_T_INT_T(Lisp_Object number, unsigned long precision)
 393 {
 394         return Ftruncate(number);
 395 }
 396 static inline Lisp_Object
 397 _ent_lift_FLOAT_T_INT_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(unused))
 398 {
 399         return Ftruncate(number);
 400 }
 401
 402 static inline int
 403 ent_float_zerop(Lisp_Object l)
 404 {
 405         return (XFLOAT_DATA(l) == 0.0f);
 406 }
 407
 408 static inline int
 409 ent_float_onep(Lisp_Object l)
 410 {
 411         return (XFLOAT_DATA(l) == 1.0f);
 412 }
 413
 414 static inline int
 415 ent_float_unitp(Lisp_Object unused)
 416 {
 417         return 1;
 418 }
 419
 420 \f
 421 static ase_nullary_operation_f Qent_float_zero, Qent_float_one;
 422 static inline void
 423 ent_float_nullary_optable_init(void)
 424 {
 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);
 429
 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);
 432 }
 433
 434 static inline void
 435 ent_float_unary_optable_init(void)
 436 {
 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);
 439 }
 440
 441 static inline void
 442 ent_float_binary_optable_init(void)
 443 {
 444         /* sums */
 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);
 457
 458         /* products */
 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);
 477
 478         /* remainders */
 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);
 491         /* powers */
 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);
 496 }
 497
 498 static inline void
 499 ent_float_unary_reltable_init(void)
 500 {
 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);
 504 }
 505
 506 static inline void
 507 ent_float_binary_reltable_init(void)
 508 {
 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);
 533 }
 534
 535 static inline void
 536 ent_float_lifttable_init(void)
 537 {
 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);
 542 }
 543
 544 void init_optables_FLOAT_T(void)
 545 {
 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();
 552 }
 553
 554
 555 void init_ent_float(void)
 556 {
 557 }
 558
 559 void syms_of_ent_float(void)
 560 {
 561         INIT_LRECORD_IMPLEMENTATION(float);
 562 }
 563
 564 void vars_of_ent_float(void)
 565 {
 566         fpfloat f = 0.0, fp = 0.0;
 567
 568         f = 1.0;
 569         while ( (f > fp) &&
 570                 (f = 2.0 * (fp = f)) &&
 571                 ! ENT_FLOAT_INDEFINITE_P(f) );
 572
 573         DEFVAR_CONST_LISP("most-positive-float", &Vmost_positive_float /*
 574 The float closest in value to +infinity.
 575                                                                        */);
 576         Vmost_positive_float = make_float(fp);
 577
 578         f = -1.0;
 579         while ( (f < fp) &&
 580                 (f = 2.0 * (fp = f)) &&
 581                 ! ENT_FLOAT_INDEFINITE_P(f) );
 582
 583         DEFVAR_CONST_LISP("most-negative-float", &Vmost_negative_float /*
 584 The float closest in value to -infinity.
 585                                                                        */);
 586         Vmost_negative_float = make_float(fp);
 587
 588         {
 589                 char tmp[] = "1.0";
 590         /* let's compute the array we need to print such a float */
 591 #if fpfloat_double_p
 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);
 595 #endif
 596         }
 597         assert(max_float_print_size>0);
 598         max_float_print_size += 10;
 599
 600         DEFVAR_CONST_INT("max-float-print-size", &max_float_print_size /*
 601 The maximal string length of a printed float.
 602                                                                        */);
 603
 604         /* other stuff */
 605         f = 1.0;
 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.
 609                                                                        */);
 610         Vleast_positive_float = make_float(fp);
 611
 612         f = -1.0;
 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.
 616                                                                        */);
 617         Vleast_negative_float = make_float(fp);
 618
 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.
 623                                                             */);
 624         Vleast_positive_normalised_float = make_float(fp);
 625
 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.
 630                                                             */);
 631         Vleast_negative_normalised_float = make_float(fp);
 632
 633         DEFVAR_CONST_LISP("float-epsilon", &Vfloat_epsilon /*
 634 The least positive float which, added to 1, is still greater than 1.
 635                                                            */);
 636 #if defined DBL_EPSILON
 637         Vfloat_epsilon = make_float(DBL_EPSILON);
 638 #else  /* !DBL_EPSILON */
 639         f = 1.0;
 640         while ((f = (fp = f) / 2) + 1 != 1);
 641         Vfloat_epsilon = make_float(fp);
 642 #endif  /* DBL_EPSILON */
 643
 644         Fprovide(intern("fpfloat"));
 645         Fprovide(intern("lisp-float-type"));
 646 }
 647
 648 /* ent-float.c ends here */