libguile/numbers.c

   1 /*      Copyright (C) 1995,1996,1997,1998, 1999 Free Software Foundation, Inc.
   2
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include <math.h>
  49 #include "_scm.h"
  50 #include "genio.h"
  51 #include "unif.h"
  52 #include "feature.h"
  53 #include "smob.h"
  54
  55 #include "scm_validate.h"
  56 #include "numbers.h"
  57 \f
  58 #define DIGITS '0':case '1':case '2':case '3':case '4':\
  59  case '5':case '6':case '7':case '8':case '9'
  60
  61
  62 /* IS_INF tests its floating point number for infiniteness
  63  */
  64 #ifndef IS_INF
  65 #define IS_INF(x) ((x) == (x) / 2)
  66 #endif
  67
  68 /* Return true if X is not infinite and is not a NaN
  69  */
  70 #ifndef isfinite
  71 #define isfinite(x) (!IS_INF (x) && (x) == (x))
  72 #endif
  73
  74 /* MAXEXP is the maximum double precision expontent
  75  * FLTMAX is less than or scm_equal the largest single precision float
  76  */
  77
  78 #ifdef SCM_FLOATS
  79 #ifdef STDC_HEADERS
  80 #ifndef GO32
  81 #include <float.h>
  82 #endif /* ndef GO32 */
  83 #endif /* def STDC_HEADERS */
  84 #ifdef DBL_MAX_10_EXP
  85 #define MAXEXP DBL_MAX_10_EXP
  86 #else
  87 #define MAXEXP 308              /* IEEE doubles */
  88 #endif /* def DBL_MAX_10_EXP */
  89 #ifdef FLT_MAX
  90 #define FLTMAX FLT_MAX
  91 #else
  92 #define FLTMAX 1e+23
  93 #endif /* def FLT_MAX */
  94 #endif /* def SCM_FLOATS */
  95 \f
  96
  97
  98 SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0,
  99             (SCM x),
 100 "")
 101 #define FUNC_NAME s_scm_exact_p
 102 {
 103   if (SCM_INUMP (x))
 104     return SCM_BOOL_T;
 105 #ifdef SCM_BIGDIG
 106   if (SCM_BIGP (x))
 107     return SCM_BOOL_T;
 108 #endif
 109   return SCM_BOOL_F;
 110 }
 111 #undef FUNC_NAME
 112
 113 SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0,
 114             (SCM n),
 115 "")
 116 #define FUNC_NAME s_scm_odd_p
 117 {
 118 #ifdef SCM_BIGDIG
 119   if (SCM_NINUMP (n))
 120     {
 121       SCM_VALIDATE_BIGINT(1,n);
 122       return SCM_BOOL(1 & SCM_BDIGITS (n)[0]);
 123     }
 124 #else
 125   SCM_VALIDATE_INUM(1,n);
 126 #endif
 127   return SCM_BOOL(4 & (int) n);
 128 }
 129 #undef FUNC_NAME
 130
 131 SCM_DEFINE (scm_even_p, "even?", 1, 0, 0,
 132             (SCM n),
 133 "")
 134 #define FUNC_NAME s_scm_even_p
 135 {
 136 #ifdef SCM_BIGDIG
 137   if (SCM_NINUMP (n))
 138     {
 139       SCM_VALIDATE_BIGINT(1,n);
 140       return SCM_NEGATE_BOOL(1 & SCM_BDIGITS (n)[0]);
 141     }
 142 #else
 143   SCM_VALIDATE_INUM(1,n);
 144 #endif
 145   return SCM_NEGATE_BOOL(4 & (int) n);
 146 }
 147 #undef FUNC_NAME
 148
 149 SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs);
 150
 151 SCM
 152 scm_abs (SCM x)
 153 {
 154 #ifdef SCM_BIGDIG
 155   if (SCM_NINUMP (x))
 156     {
 157       SCM_GASSERT1 (SCM_BIGP (x), g_abs, x, SCM_ARG1, s_abs);
 158       if (SCM_TYP16 (x) == scm_tc16_bigpos)
 159         return x;
 160       return scm_copybig (x, 0);
 161     }
 162 #else
 163   SCM_GASSERT1 (SCM_INUMP (x), g_abs, x, SCM_ARG1, s_abs);
 164 #endif
 165   if (SCM_INUM (x) >= 0)
 166     return x;
 167   x = - SCM_INUM (x);
 168   if (!SCM_POSFIXABLE (x))
 169 #ifdef SCM_BIGDIG
 170     return scm_long2big (x);
 171 #else
 172   scm_num_overflow (s_abs);
 173 #endif
 174   return SCM_MAKINUM (x);
 175 }
 176
 177 SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient);
 178
 179 SCM
 180 scm_quotient (SCM x, SCM y)
 181 {
 182   register long z;
 183 #ifdef SCM_BIGDIG
 184   if (SCM_NINUMP (x))
 185     {
 186       long w;
 187       SCM_GASSERT2 (SCM_BIGP (x),
 188                     g_quotient, x, y, SCM_ARG1, s_quotient);
 189       if (SCM_NINUMP (y))
 190         {
 191           SCM_ASRTGO (SCM_BIGP (y), bady);
 192           return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
 193                                 SCM_BDIGITS (y), SCM_NUMDIGS (y),
 194                                 SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 2);
 195         }
 196       z = SCM_INUM (y);
 197       SCM_ASRTGO (z, ov);
 198       if (1 == z)
 199         return x;
 200       if (z < 0)
 201         z = -z;
 202       if (z < SCM_BIGRAD)
 203         {
 204           w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0));
 205           scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w), (SCM_BIGDIG) z);
 206           return scm_normbig (w);
 207         }
 208 #ifndef SCM_DIGSTOOBIG
 209       w = scm_pseudolong (z);
 210       return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
 211                             (SCM_BIGDIG *) & w, SCM_DIGSPERLONG,
 212                             SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2);
 213 #else
 214       {
 215         SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
 216         scm_longdigs (z, zdigs);
 217         return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
 218                               zdigs, SCM_DIGSPERLONG,
 219                               SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2);
 220       }
 221 #endif
 222     }
 223   if (SCM_NINUMP (y))
 224     {
 225       if (!SCM_BIGP (y))
 226         {
 227         bady:
 228           SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
 229         }
 230       return SCM_INUM0;
 231     }
 232 #else
 233   SCM_GASSERT2 (SCM_INUMP (x), g_quotient, x, y, SCM_ARG1, s_quotient);
 234   SCM_GASSERT2 (SCM_INUMP (y), g_quotient, x, y, SCM_ARG2, s_quotient);
 235 #endif
 236   if ((z = SCM_INUM (y)) == 0)
 237     {
 238     ov:
 239       scm_num_overflow (s_quotient);
 240     }
 241   z = SCM_INUM (x) / z;
 242 #ifdef BADIVSGNS
 243   {
 244 #if (__TURBOC__ == 1)
 245     long t = ((y < 0) ? -SCM_INUM (x) : SCM_INUM (x)) % SCM_INUM (y);
 246 #else
 247     long t = SCM_INUM (x) % SCM_INUM (y);
 248 #endif
 249     if (t == 0);
 250     else if (t < 0)
 251       if (x < 0);
 252       else
 253         z--;
 254     else if (x < 0)
 255       z++;
 256   }
 257 #endif
 258   if (!SCM_FIXABLE (z))
 259 #ifdef SCM_BIGDIG
 260     return scm_long2big (z);
 261 #else
 262   scm_num_overflow (s_quotient);
 263 #endif
 264   return SCM_MAKINUM (z);
 265 }
 266
 267 SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder);
 268
 269 SCM
 270 scm_remainder (SCM x, SCM y)
 271 {
 272   register long z;
 273 #ifdef SCM_BIGDIG
 274   if (SCM_NINUMP (x))
 275     {
 276       SCM_GASSERT2 (SCM_BIGP (x),
 277                     g_remainder, x, y, SCM_ARG1, s_remainder);
 278       if (SCM_NINUMP (y))
 279         {
 280           SCM_ASRTGO (SCM_BIGP (y), bady);
 281           return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
 282                                 SCM_BDIGITS (y), SCM_NUMDIGS (y),
 283                                 SCM_BIGSIGN (x), 0);
 284         }
 285       if (!(z = SCM_INUM (y)))
 286         goto ov;
 287       return scm_divbigint (x, z, SCM_BIGSIGN (x), 0);
 288     }
 289   if (SCM_NINUMP (y))
 290     {
 291       if (!SCM_BIGP (y))
 292         {
 293         bady:
 294           SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
 295         }
 296       return x;
 297     }
 298 #else
 299   SCM_GASSERT2 (SCM_INUMP (x), g_remainder, x, y, SCM_ARG1, s_remainder);
 300   SCM_GASSERT2 (SCM_INUMP (y), g_remainder, x, y, SCM_ARG2, s_remainder);
 301 #endif
 302   if (!(z = SCM_INUM (y)))
 303     {
 304     ov:
 305       scm_num_overflow (s_remainder);
 306     }
 307 #if (__TURBOC__ == 1)
 308   if (z < 0)
 309     z = -z;
 310 #endif
 311   z = SCM_INUM (x) % z;
 312 #ifdef BADIVSGNS
 313   if (!z);
 314   else if (z < 0)
 315     if (x < 0);
 316     else
 317       z += SCM_INUM (y);
 318   else if (x < 0)
 319     z -= SCM_INUM (y);
 320 #endif
 321   return SCM_MAKINUM (z);
 322 }
 323
 324 SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo);
 325
 326 SCM
 327 scm_modulo (SCM x, SCM y)
 328 {
 329   register long yy, z;
 330 #ifdef SCM_BIGDIG
 331   if (SCM_NINUMP (x))
 332     {
 333       SCM_GASSERT2 (SCM_BIGP (x),
 334                     g_modulo, x, y, SCM_ARG1, s_modulo);
 335       if (SCM_NINUMP (y))
 336         {
 337           SCM_ASRTGO (SCM_BIGP (y), bady);
 338           return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
 339                                 SCM_BDIGITS (y), SCM_NUMDIGS (y),
 340                                 SCM_BIGSIGN (y),
 341                                 (SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y)) ? 1 : 0);
 342         }
 343       if (!(z = SCM_INUM (y)))
 344         goto ov;
 345       return scm_divbigint (x, z, y < 0,
 346                             (SCM_BIGSIGN (x) ? (y > 0) : (y < 0)) ? 1 : 0);
 347     }
 348   if (SCM_NINUMP (y))
 349     {
 350       if (!SCM_BIGP (y))
 351         {
 352         bady:
 353           SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
 354         }
 355       return (SCM_BIGSIGN (y) ? (x > 0) : (x < 0)) ? scm_sum (x, y) : x;
 356     }
 357 #else
 358   SCM_GASSERT1 (SCM_INUMP (x), g_modulo, x, y, SCM_ARG1, s_modulo);
 359   SCM_GASSERT2 (SCM_INUMP (y), g_modulo, x, y, SCM_ARG2, s_modulo);
 360 #endif
 361   if (!(yy = SCM_INUM (y)))
 362     {
 363     ov:
 364       scm_num_overflow (s_modulo);
 365     }
 366 #if (__TURBOC__==1)
 367   z = SCM_INUM (x);
 368   z = ((yy < 0) ? -z : z) % yy;
 369 #else
 370   z = SCM_INUM (x) % yy;
 371 #endif
 372   return SCM_MAKINUM (((yy < 0) ? (z > 0) : (z < 0)) ? z + yy : z);
 373 }
 374
 375 SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
 376
 377 SCM
 378 scm_gcd (SCM x, SCM y)
 379 {
 380   register long u, v, k, t;
 381   if (SCM_UNBNDP (y))
 382     return SCM_UNBNDP (x) ? SCM_INUM0 : x;
 383  tailrec:
 384 #ifdef SCM_BIGDIG
 385   if (SCM_NINUMP (x))
 386     {
 387     big_gcd:
 388       SCM_GASSERT2 (SCM_BIGP (x),
 389                     g_gcd, x, y, SCM_ARG1, s_gcd);
 390       if (SCM_BIGSIGN (x))
 391         x = scm_copybig (x, 0);
 392     newy:
 393       if (SCM_NINUMP (y))
 394         {
 395           SCM_GASSERT2 (SCM_BIGP (y),
 396                         g_gcd, x, y, SCM_ARGn, s_gcd);
 397           if (SCM_BIGSIGN (y))
 398             y = scm_copybig (y, 0);
 399           switch (scm_bigcomp (x, y))
 400             {
 401             case -1:
 402             swaprec:
 403             t = scm_remainder (x, y);
 404             x = y;
 405             y = t;
 406             goto tailrec;
 407             case 0:
 408               return x;
 409             case 1:
 410               y = scm_remainder (y, x);
 411               goto newy;
 412             }
 413           /* instead of the switch, we could just
 414              return scm_gcd (y, scm_modulo (x, y)); */
 415         }
 416       if (SCM_INUM0 == y)
 417         return x;
 418       goto swaprec;
 419     }
 420   if (SCM_NINUMP (y))
 421     {
 422       t = x;
 423       x = y;
 424       y = t;
 425       goto big_gcd;
 426     }
 427 #else
 428   SCM_GASSERT2 (SCM_INUMP (x), g_gcd, x, y, SCM_ARG1, s_gcd);
 429   SCM_GASSERT2 (SCM_INUMP (y), g_gcd, x, y, SCM_ARGn, s_gcd);
 430 #endif
 431   u = SCM_INUM (x);
 432   if (u < 0)
 433     u = -u;
 434   v = SCM_INUM (y);
 435   if (v < 0)
 436     v = -v;
 437   else if (0 == v)
 438     goto getout;
 439   if (0 == u)
 440     {
 441       u = v;
 442       goto getout;
 443     }
 444   for (k = 1; !(1 & ((int) u | (int) v)); k <<= 1, u >>= 1, v >>= 1);
 445   if (1 & (int) u)
 446     t = -v;
 447   else
 448     {
 449       t = u;
 450     b3:
 451       t = SCM_SRS (t, 1);
 452     }
 453   if (!(1 & (int) t))
 454     goto b3;
 455   if (t > 0)
 456     u = t;
 457   else
 458     v = -t;
 459   if ((t = u - v))
 460     goto b3;
 461   u = u * k;
 462  getout:
 463   if (!SCM_POSFIXABLE (u))
 464 #ifdef SCM_BIGDIG
 465     return scm_long2big (u);
 466 #else
 467   scm_num_overflow (s_gcd);
 468 #endif
 469   return SCM_MAKINUM (u);
 470 }
 471
 472 SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm);
 473
 474 SCM
 475 scm_lcm (SCM n1, SCM n2)
 476 {
 477   SCM d;
 478 #ifndef SCM_BIGDIG
 479   SCM_GASSERT2 (SCM_INUMP (n1) || SCM_UNBNDP (n1),
 480                 g_lcm, n1, n2, SCM_ARG1, s_lcm);
 481   SCM_GASSERT2 (SCM_INUMP (n2) || SCM_UNBNDP (n2),
 482                 g_lcm, n1, n2, SCM_ARGn, s_lcm);
 483 #else
 484   SCM_GASSERT2 (SCM_INUMP (n1)
 485                 || SCM_UNBNDP (n1)
 486                 || (SCM_BIGP (n1)),
 487                 g_lcm, n1, n2, SCM_ARG1, s_lcm);
 488   SCM_GASSERT2 (SCM_INUMP (n2)
 489                 || SCM_UNBNDP (n2)
 490                 || (SCM_BIGP (n2)),
 491                 g_lcm, n1, n2, SCM_ARGn, s_lcm);
 492 #endif
 493   if (SCM_UNBNDP (n2))
 494     {
 495       n2 = SCM_MAKINUM (1L);
 496       if (SCM_UNBNDP (n1))
 497         return n2;
 498     }
 499
 500   d = scm_gcd (n1, n2);
 501   if (SCM_INUM0 == d)
 502     return d;
 503   return scm_abs (scm_product (n1, scm_quotient (n2, d)));
 504 }
 505
 506 #ifndef SCM_BIGDIG
 507 #ifndef SCM_FLOATS
 508 #define scm_long2num SCM_MAKINUM
 509 #endif
 510 #endif
 511
 512 #ifndef scm_long2num
 513 GUILE_PROC1 (scm_logand, "logand", scm_tc7_asubr,
 514              (SCM n1, SCM n2),
 515 "Returns the integer which is the bit-wise AND of the two integer
 516 arguments.
 517
 518 Example:
 519 @lisp
 520 (number->string (logand #b1100 #b1010) 2)
 521    @result{} \"1000\"")
 522 #define FUNC_NAME s_scm_logand
 523 {
 524   int i1, i2;
 525   if (SCM_UNBNDP (n2))
 526     {
 527       if (SCM_UNBNDP (n1))
 528         return SCM_MAKINUM (-1);
 529       return n1;
 530     }
 531   SCM_VALIDATE_INUM_COPY(1,n1,i1);
 532   SCM_VALIDATE_INUM_COPY(2,n2,i2);
 533   return scm_ulong2num (i1 & i2);
 534 }
 535 #undef FUNC_NAME
 536
 537 GUILE_PROC1 (scm_logior, "logior", scm_tc7_asubr,
 538              (SCM n1, SCM n2),
 539 "Returns the integer which is the bit-wise OR of the two integer
 540 arguments.
 541
 542 Example:
 543 @lisp
 544 (number->string (logior #b1100 #b1010) 2)
 545    @result{} \"1110\"
 546 @end lisp")
 547 #define FUNC_NAME s_scm_logior
 548 {
 549   int i1, i2;
 550   if (SCM_UNBNDP (n2))
 551     {
 552       if (SCM_UNBNDP (n1))
 553         return SCM_INUM0;
 554       return n1;
 555     }
 556   SCM_VALIDATE_INUM_COPY(1,n1,i1);
 557   SCM_VALIDATE_INUM_COPY(2,n2,i2);
 558   return scm_ulong2num (i1 | i2);
 559 }
 560 #undef FUNC_NAME
 561
 562 GUILE_PROC1 (scm_logxor, "logxor", scm_tc7_asubr,
 563              (SCM n1, SCM n2),
 564 "Returns the integer which is the bit-wise XOR of the two integer
 565 arguments.
 566
 567 Example:
 568 @lisp
 569 (number->string (logxor #b1100 #b1010) 2)
 570    @result{} \"110\"
 571 @end lisp")
 572 #define FUNC_NAME s_scm_logxor
 573 {
 574   int i1, i2;
 575   if (SCM_UNBNDP (n2))
 576     {
 577       if (SCM_UNBNDP (n1))
 578         return SCM_INUM0;
 579       return n1;
 580     }
 581   SCM_VALIDATE_INUM_COPY(1,n1,i1);
 582   SCM_VALIDATE_INUM_COPY(2,n2,i2);
 583   return scm_ulong2num (i1 ^ i2);
 584 }
 585 #undef FUNC_NAME
 586
 587 SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0,
 588             (SCM n1, SCM n2),
 589 "")
 590 #define FUNC_NAME s_scm_logtest
 591 {
 592   int i1, i2;
 593   SCM_VALIDATE_INUM_COPY(1,n1,i1);
 594   SCM_VALIDATE_INUM_COPY(2,n2,i2);
 595   return SCM_BOOL(i1 & i2);
 596 }
 597 #undef FUNC_NAME
 598
 599
 600 SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0,
 601             (SCM n1, SCM n2),
 602 "")
 603 #define FUNC_NAME s_scm_logbit_p
 604 {
 605   int i1, i2;
 606   SCM_VALIDATE_INUM_COPY(1,n1,i1);
 607   SCM_VALIDATE_INUM_COPY(2,n2,i2);
 608   return SCM_BOOL((1 << i1) & i2);
 609 }
 610 #undef FUNC_NAME
 611
 612 #else
 613
 614 GUILE_PROC1 (scm_logand, "logand", scm_tc7_asubr,
 615              (SCM n1, SCM n2),
 616 "")
 617 #define FUNC_NAME s_scm_logand
 618 {
 619   int i1, i2;
 620   if (SCM_UNBNDP (n2))
 621     {
 622       if (SCM_UNBNDP (n1))
 623         return SCM_MAKINUM (-1);
 624       return n1;
 625     }
 626   SCM_VALIDATE_INUM_COPY(1,n1,i1);
 627   SCM_VALIDATE_INUM_COPY(2,n2,i2);
 628   return SCM_MAKINUM (i1 & i2);
 629 }
 630 #undef FUNC_NAME
 631
 632 GUILE_PROC1 (scm_logior, "logior", scm_tc7_asubr,
 633              (SCM n1, SCM n2),
 634 "")
 635 #define FUNC_NAME s_scm_logior
 636 {
 637   int i1, i2;
 638   if (SCM_UNBNDP (n2))
 639     {
 640       if (SCM_UNBNDP (n1))
 641         return SCM_INUM0;
 642       return n1;
 643     }
 644   SCM_VALIDATE_INUM_COPY(1,n1,i1);
 645   SCM_VALIDATE_INUM_COPY(2,n2,i2);
 646   return SCM_MAKINUM (i1 | i2);
 647 }
 648 #undef FUNC_NAME
 649
 650 GUILE_PROC1 (scm_logxor, "logxor", scm_tc7_asubr,
 651              (SCM n1, SCM n2),
 652 "")
 653 #define FUNC_NAME s_scm_logxor
 654 {
 655   int i1, i2;
 656   if (SCM_UNBNDP (n2))
 657     {
 658       if (SCM_UNBNDP (n1))
 659         return SCM_INUM0;
 660       return n1;
 661     }
 662   SCM_VALIDATE_INUM_COPY(1,n1,i1);
 663   SCM_VALIDATE_INUM_COPY(2,n2,i2);
 664   return SCM_MAKINUM (i1 ^ i2);
 665 }
 666 #undef FUNC_NAME
 667
 668 SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0,
 669             (SCM n1, SCM n2),
 670 "@example
 671 (logtest j k) @equiv{} (not (zero? (logand j k)))
 672
 673 (logtest #b0100 #b1011) @result{} #f
 674 (logtest #b0100 #b0111) @result{} #t
 675 @end example")
 676 #define FUNC_NAME s_scm_logtest
 677 {
 678   int i1, i2;
 679   SCM_VALIDATE_INUM_COPY(1,n1,i1);
 680   SCM_VALIDATE_INUM_COPY(2,n2,i2);
 681   return SCM_BOOL(i1 & i2);
 682 }
 683 #undef FUNC_NAME
 684
 685 SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0,
 686             (SCM n1, SCM n2),
 687 "@example
 688 (logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)
 689
 690 (logbit? 0 #b1101) @result{} #t
 691 (logbit? 1 #b1101) @result{} #f
 692 (logbit? 2 #b1101) @result{} #t
 693 (logbit? 3 #b1101) @result{} #t
 694 (logbit? 4 #b1101) @result{} #f
 695 @end example")
 696 #define FUNC_NAME s_scm_logbit_p
 697 {
 698   int i1, i2;
 699   SCM_VALIDATE_INUM_MIN_COPY(1,n1,0,i1);
 700   SCM_VALIDATE_INUM_COPY(2,n2,i2);
 701   return SCM_BOOL((1 << i1) & i2);
 702 }
 703 #undef FUNC_NAME
 704 #endif
 705
 706 SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0,
 707             (SCM n),
 708 "Returns the integer which is the 2s-complement of the integer argument.
 709
 710 Example:
 711 @lisp
 712 (number->string (lognot #b10000000) 2)
 713    @result{} \"-10000001\"
 714 (number->string (lognot #b0) 2)
 715    @result{} \"-1\"
 716 @end lisp
 717 ")
 718 #define FUNC_NAME s_scm_lognot
 719 {
 720   SCM_VALIDATE_INUM(1,n);
 721   return scm_difference (SCM_MAKINUM (-1L), n);
 722 }
 723 #undef FUNC_NAME
 724
 725 SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
 726             (SCM z1, SCM z2),
 727 "Returns @var{n} raised to the non-negative integer exponent @var{k}.
 728
 729 Example:
 730 @lisp
 731 (integer-expt 2 5)
 732    @result{} 32
 733 (integer-expt -3 3)
 734    @result{} -27
 735 @end lisp")
 736 #define FUNC_NAME s_scm_integer_expt
 737 {
 738   SCM acc = SCM_MAKINUM (1L);
 739   int i2;
 740 #ifdef SCM_BIGDIG
 741   if (SCM_INUM0 == z1 || acc == z1)
 742     return z1;
 743   else if (SCM_MAKINUM (-1L) == z1)
 744     return SCM_BOOL_F == scm_even_p (z2) ? z1 : acc;
 745 #endif
 746   SCM_VALIDATE_INUM_COPY(2,z2,i2);
 747   if (i2 < 0)
 748     {
 749       i2 = -i2;
 750       z1 = scm_divide (z1, SCM_UNDEFINED);
 751     }
 752   while (1)
 753     {
 754       if (0 == i2)
 755         return acc;
 756       if (1 == i2)
 757         return scm_product (acc, z1);
 758       if (i2 & 1)
 759         acc = scm_product (acc, z1);
 760       z1 = scm_product (z1, z1);
 761       i2 >>= 1;
 762     }
 763 }
 764 #undef FUNC_NAME
 765
 766 SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
 767             (SCM n, SCM cnt),
 768 "Returns an integer equivalent to
 769 @code{(inexact->exact (floor (* @var{int} (expt 2 @var{count}))))}.@refill
 770
 771 Example:
 772 @lisp
 773 (number->string (ash #b1 3) 2)
 774    @result{} "1000"
 775 (number->string (ash #b1010 -1) 2)
 776    @result{} "101"
 777 @end lisp")
 778 #define FUNC_NAME s_scm_ash
 779 {
 780   /* GJB:FIXME:: what is going on here? */
 781   SCM res = SCM_INUM (n);
 782   SCM_VALIDATE_INUM(2,cnt);
 783 #ifdef SCM_BIGDIG
 784   if (cnt < 0)
 785     {
 786       res = scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-SCM_INUM (cnt)));
 787       if (SCM_NFALSEP (scm_negative_p (n)))
 788         return scm_sum (SCM_MAKINUM (-1L),
 789                         scm_quotient (scm_sum (SCM_MAKINUM (1L), n), res));
 790       else
 791         return scm_quotient (n, res);
 792     }
 793   else
 794     return scm_product (n, scm_integer_expt (SCM_MAKINUM (2), cnt));
 795 #else
 796   SCM_VALIDATE_INUM(1,n)
 797   cnt = SCM_INUM (cnt);
 798   if (cnt < 0)
 799     return SCM_MAKINUM (SCM_SRS (res, -cnt));
 800   res = SCM_MAKINUM (res << cnt);
 801   if (SCM_INUM (res) >> cnt != SCM_INUM (n))
 802     scm_num_overflow (FUNC_NAME);
 803   return res;
 804 #endif
 805 }
 806 #undef FUNC_NAME
 807
 808 /* GJB:FIXME: do not use SCMs as integers! */
 809 SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
 810             (SCM n, SCM start, SCM end),
 811 "Returns the integer composed of the @var{start} (inclusive) through
 812 @var{end} (exclusive) bits of @var{n}.  The @var{start}th bit becomes
 813 the 0-th bit in the result.@refill
 814
 815 Example:
 816 @lisp
 817 (number->string (bit-extract #b1101101010 0 4) 2)
 818    @result{} \"1010\"
 819 (number->string (bit-extract #b1101101010 4 9) 2)
 820    @result{} \"10110\"
 821 @end lisp")
 822 #define FUNC_NAME s_scm_bit_extract
 823 {
 824   SCM_VALIDATE_INUM(1,n);
 825   SCM_VALIDATE_INUM_MIN(2,start,0);
 826   SCM_VALIDATE_INUM_MIN(3,end,0);
 827   start = SCM_INUM (start);
 828   end = SCM_INUM (end);
 829   SCM_ASSERT (end >= start, SCM_MAKINUM (end), SCM_OUTOFRANGE, FUNC_NAME);
 830 #ifdef SCM_BIGDIG
 831   if (SCM_NINUMP (n))
 832     return
 833       scm_logand (scm_difference (scm_integer_expt (SCM_MAKINUM (2),
 834                                                     SCM_MAKINUM (end - start)),
 835                                   SCM_MAKINUM (1L)),
 836                   scm_ash (n, SCM_MAKINUM (-start)));
 837 #else
 838   SCM_VALIDATE_INUM(1,n);
 839 #endif
 840   return SCM_MAKINUM ((SCM_INUM (n) >> start) & ((1L << (end - start)) - 1));
 841 }
 842 #undef FUNC_NAME
 843
 844 static const char scm_logtab[] = {
 845   0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
 846 };
 847
 848 SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0,
 849             (SCM n),
 850 "Returns the number of bits in integer @var{n}.  If integer is positive,
 851 the 1-bits in its binary representation are counted.  If negative, the
 852 0-bits in its two's-complement binary representation are counted.  If 0,
 853 0 is returned.
 854
 855 Example:
 856 @lisp
 857 (logcount #b10101010)
 858    @result{} 4
 859 (logcount 0)
 860    @result{} 0
 861 (logcount -2)
 862    @result{} 1
 863 @end lisp")
 864 #define FUNC_NAME s_scm_logcount
 865 {
 866   register unsigned long c = 0;
 867   register long nn;
 868 #ifdef SCM_BIGDIG
 869   if (SCM_NINUMP (n))
 870     {
 871       scm_sizet i;
 872       SCM_BIGDIG *ds, d;
 873       SCM_VALIDATE_BIGINT(1,n);
 874       if (SCM_BIGSIGN (n))
 875         return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n));
 876       ds = SCM_BDIGITS (n);
 877       for (i = SCM_NUMDIGS (n); i--;)
 878         for (d = ds[i]; d; d >>= 4)
 879           c += scm_logtab[15 & d];
 880       return SCM_MAKINUM (c);
 881     }
 882 #else
 883   SCM_VALIDATE_INUM(1,n);
 884 #endif
 885   if ((nn = SCM_INUM (n)) < 0)
 886     nn = -1 - nn;
 887   for (; nn; nn >>= 4)
 888     c += scm_logtab[15 & nn];
 889   return SCM_MAKINUM (c);
 890 }
 891 #undef FUNC_NAME
 892
 893
 894 static const char scm_ilentab[] = {
 895   0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
 896 };
 897
 898 SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0,
 899             (SCM n),
 900 "Returns the number of bits neccessary to represent @var{n}.
 901
 902 Example:
 903 @lisp
 904 (integer-length #b10101010)
 905    @result{} 8
 906 (integer-length 0)
 907    @result{} 0
 908 (integer-length #b1111)
 909    @result{} 4
 910 @end lisp")
 911 #define FUNC_NAME s_scm_integer_length
 912 {
 913   register unsigned long c = 0;
 914   register long nn;
 915   unsigned int l = 4;
 916 #ifdef SCM_BIGDIG
 917   if (SCM_NINUMP (n))
 918     {
 919       SCM_BIGDIG *ds, d;
 920       SCM_VALIDATE_BIGINT(1,n);
 921       if (SCM_BIGSIGN (n))
 922         return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n));
 923       ds = SCM_BDIGITS (n);
 924       d = ds[c = SCM_NUMDIGS (n) - 1];
 925       for (c *= SCM_BITSPERDIG; d; d >>= 4)
 926         {
 927           c += 4;
 928           l = scm_ilentab[15 & d];
 929         }
 930       return SCM_MAKINUM (c - 4 + l);
 931     }
 932 #else
 933   SCM_VALIDATE_INUM(1,n);
 934 #endif
 935   if ((nn = SCM_INUM (n)) < 0)
 936     nn = -1 - nn;
 937   for (; nn; nn >>= 4)
 938     {
 939       c += 4;
 940       l = scm_ilentab[15 & nn];
 941     }
 942   return SCM_MAKINUM (c - 4 + l);
 943 }
 944 #undef FUNC_NAME
 945
 946
 947 #ifdef SCM_BIGDIG
 948 static const char s_bignum[] = "bignum";
 949
 950 SCM
 951 scm_mkbig (scm_sizet nlen, int sign)
 952 {
 953   SCM v = nlen;
 954   /* Cast to SCM to avoid signed/unsigned comparison warnings.  */
 955   if (((v << 16) >> 16) != (SCM) nlen)
 956     scm_wta (SCM_MAKINUM (nlen), (char *) SCM_NALLOC, s_bignum);
 957   SCM_NEWCELL (v);
 958   SCM_DEFER_INTS;
 959   SCM_SETCHARS (v, scm_must_malloc ((long) (nlen * sizeof (SCM_BIGDIG)),
 960                                     s_bignum));
 961   SCM_SETNUMDIGS (v, nlen, sign ? scm_tc16_bigneg : scm_tc16_bigpos);
 962   SCM_ALLOW_INTS;
 963   return v;
 964 }
 965
 966
 967 SCM
 968 scm_big2inum (SCM b, scm_sizet l)
 969 {
 970   unsigned long num = 0;
 971   SCM_BIGDIG *tmp = SCM_BDIGITS (b);
 972   while (l--)
 973     num = SCM_BIGUP (num) + tmp[l];
 974   if (SCM_TYP16 (b) == scm_tc16_bigpos)
 975     {
 976       if (SCM_POSFIXABLE (num))
 977         return SCM_MAKINUM (num);
 978     }
 979   else if (SCM_UNEGFIXABLE (num))
 980     return SCM_MAKINUM (-num);
 981   return b;
 982 }
 983
 984
 985 static const char s_adjbig[] = "scm_adjbig";
 986
 987 SCM
 988 scm_adjbig (SCM b, scm_sizet nlen)
 989 {
 990   scm_sizet nsiz = nlen;
 991   if (((nsiz << 16) >> 16) != nlen)
 992     scm_wta (scm_ulong2num (nsiz), (char *) SCM_NALLOC, s_adjbig);
 993
 994   SCM_DEFER_INTS;
 995   {
 996     SCM_BIGDIG *digits
 997       = ((SCM_BIGDIG *)
 998          scm_must_realloc ((char *) SCM_CHARS (b),
 999                            (long) (SCM_NUMDIGS (b) * sizeof (SCM_BIGDIG)),
1000                            (long) (nsiz * sizeof (SCM_BIGDIG)), s_adjbig));
1001
1002     SCM_SETCHARS (b, digits);
1003     SCM_SETNUMDIGS (b, nsiz, SCM_TYP16 (b));
1004   }
1005   SCM_ALLOW_INTS;
1006   return b;
1007 }
1008
1009
1010
1011 SCM
1012 scm_normbig (SCM b)
1013 {
1014 #ifndef _UNICOS
1015   scm_sizet nlen = SCM_NUMDIGS (b);
1016 #else
1017   int nlen = SCM_NUMDIGS (b); /* unsigned nlen breaks on Cray when nlen => 0 */
1018 #endif
1019   SCM_BIGDIG *zds = SCM_BDIGITS (b);
1020   while (nlen-- && !zds[nlen]);
1021   nlen++;
1022   if (nlen * SCM_BITSPERDIG / SCM_CHAR_BIT <= sizeof (SCM))
1023     if (SCM_INUMP (b = scm_big2inum (b, (scm_sizet) nlen)))
1024       return b;
1025   if (SCM_NUMDIGS (b) == nlen)
1026     return b;
1027   return scm_adjbig (b, (scm_sizet) nlen);
1028 }
1029
1030
1031
1032 SCM
1033 scm_copybig (SCM b, int sign)
1034 {
1035   scm_sizet i = SCM_NUMDIGS (b);
1036   SCM ans = scm_mkbig (i, sign);
1037   SCM_BIGDIG *src = SCM_BDIGITS (b), *dst = SCM_BDIGITS (ans);
1038   while (i--)
1039     dst[i] = src[i];
1040   return ans;
1041 }
1042
1043
1044
1045 SCM
1046 scm_long2big (long n)
1047 {
1048   scm_sizet i = 0;
1049   SCM_BIGDIG *digits;
1050   SCM ans = scm_mkbig (SCM_DIGSPERLONG, n < 0);
1051   digits = SCM_BDIGITS (ans);
1052   if (n < 0)
1053     n = -n;
1054   while (i < SCM_DIGSPERLONG)
1055     {
1056       digits[i++] = SCM_BIGLO (n);
1057       n = SCM_BIGDN ((unsigned long) n);
1058     }
1059   return ans;
1060 }
1061
1062 #ifdef HAVE_LONG_LONGS
1063
1064 SCM
1065 scm_long_long2big (long_long n)
1066 {
1067   scm_sizet i;
1068   SCM_BIGDIG *digits;
1069   SCM ans;
1070   int n_digits;
1071
1072   {
1073     long tn;
1074     tn = (long) n;
1075     if ((long long) tn == n)
1076       return scm_long2big (tn);
1077   }
1078
1079   {
1080     long_long tn;
1081
1082     for (tn = n, n_digits = 0;
1083          tn;
1084          ++n_digits, tn = SCM_BIGDN ((ulong_long) tn))
1085       ;
1086   }
1087
1088   i = 0;
1089   ans = scm_mkbig (n_digits, n < 0);
1090   digits = SCM_BDIGITS (ans);
1091   if (n < 0)
1092     n = -n;
1093   while (i < n_digits)
1094     {
1095       digits[i++] = SCM_BIGLO (n);
1096       n = SCM_BIGDN ((ulong_long) n);
1097     }
1098   return ans;
1099 }
1100 #endif
1101
1102
1103 SCM
1104 scm_2ulong2big (unsigned long *np)
1105 {
1106   unsigned long n;
1107   scm_sizet i;
1108   SCM_BIGDIG *digits;
1109   SCM ans;
1110
1111   ans = scm_mkbig (2 * SCM_DIGSPERLONG, 0);
1112   digits = SCM_BDIGITS (ans);
1113
1114   n = np[0];
1115   for (i = 0; i < SCM_DIGSPERLONG; ++i)
1116     {
1117       digits[i] = SCM_BIGLO (n);
1118       n = SCM_BIGDN ((unsigned long) n);
1119     }
1120   n = np[1];
1121   for (i = 0; i < SCM_DIGSPERLONG; ++i)
1122     {
1123       digits[i + SCM_DIGSPERLONG] = SCM_BIGLO (n);
1124       n = SCM_BIGDN ((unsigned long) n);
1125     }
1126   return ans;
1127 }
1128
1129
1130
1131 SCM
1132 scm_ulong2big (unsigned long n)
1133 {
1134   scm_sizet i = 0;
1135   SCM_BIGDIG *digits;
1136   SCM ans = scm_mkbig (SCM_DIGSPERLONG, 0);
1137   digits = SCM_BDIGITS (ans);
1138   while (i < SCM_DIGSPERLONG)
1139     {
1140       digits[i++] = SCM_BIGLO (n);
1141       n = SCM_BIGDN (n);
1142     }
1143   return ans;
1144 }
1145
1146
1147
1148 int
1149 scm_bigcomp (SCM x, SCM y)
1150 {
1151   int xsign = SCM_BIGSIGN (x);
1152   int ysign = SCM_BIGSIGN (y);
1153   scm_sizet xlen, ylen;
1154
1155   /* Look at the signs, first.  */
1156   if (ysign < xsign)
1157     return 1;
1158   if (ysign > xsign)
1159     return -1;
1160
1161   /* They're the same sign, so see which one has more digits.  Note
1162      that, if they are negative, the longer number is the lesser.  */
1163   ylen = SCM_NUMDIGS (y);
1164   xlen = SCM_NUMDIGS (x);
1165   if (ylen > xlen)
1166     return (xsign) ? -1 : 1;
1167   if (ylen < xlen)
1168     return (xsign) ? 1 : -1;
1169
1170   /* They have the same number of digits, so find the most significant
1171      digit where they differ.  */
1172   while (xlen)
1173     {
1174       --xlen;
1175       if (SCM_BDIGITS (y)[xlen] != SCM_BDIGITS (x)[xlen])
1176         /* Make the discrimination based on the digit that differs.  */
1177         return ((SCM_BDIGITS (y)[xlen] > SCM_BDIGITS (x)[xlen])
1178                 ? (xsign ? -1 :  1)
1179                 : (xsign ?  1 : -1));
1180     }
1181
1182   /* The numbers are identical.  */
1183   return 0;
1184 }
1185
1186 #ifndef SCM_DIGSTOOBIG
1187
1188
1189 long
1190 scm_pseudolong (long x)
1191 {
1192   union
1193   {
1194     long l;
1195     SCM_BIGDIG bd[SCM_DIGSPERLONG];
1196   }
1197   p;
1198   scm_sizet i = 0;
1199   if (x < 0)
1200     x = -x;
1201   while (i < SCM_DIGSPERLONG)
1202     {
1203       p.bd[i++] = SCM_BIGLO (x);
1204       x = SCM_BIGDN (x);
1205     }
1206   /*  p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1207   return p.l;
1208 }
1209
1210 #else
1211
1212
1213 void
1214 scm_longdigs (long x, SCM_BIGDIG digs[])
1215 {
1216   scm_sizet i = 0;
1217   if (x < 0)
1218     x = -x;
1219   while (i < SCM_DIGSPERLONG)
1220     {
1221       digs[i++] = SCM_BIGLO (x);
1222       x = SCM_BIGDN (x);
1223     }
1224 }
1225 #endif
1226
1227
1228
1229 SCM
1230 scm_addbig (SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny)
1231 {
1232   /* Assumes nx <= SCM_NUMDIGS(bigy) */
1233   /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */
1234   long num = 0;
1235   scm_sizet i = 0, ny = SCM_NUMDIGS (bigy);
1236   SCM z = scm_copybig (bigy, SCM_BIGSIGN (bigy) ^ sgny);
1237   SCM_BIGDIG *zds = SCM_BDIGITS (z);
1238   if (xsgn ^ SCM_BIGSIGN (z))
1239     {
1240       do
1241         {
1242           num += (long) zds[i] - x[i];
1243           if (num < 0)
1244             {
1245               zds[i] = num + SCM_BIGRAD;
1246               num = -1;
1247             }
1248           else
1249             {
1250               zds[i] = SCM_BIGLO (num);
1251               num = 0;
1252             }
1253         }
1254       while (++i < nx);
1255       if (num && nx == ny)
1256         {
1257           num = 1;
1258           i = 0;
1259           SCM_SETCAR (z, SCM_CAR (z) ^ 0x0100);
1260           do
1261             {
1262               num += (SCM_BIGRAD - 1) - zds[i];
1263               zds[i++] = SCM_BIGLO (num);
1264               num = SCM_BIGDN (num);
1265             }
1266           while (i < ny);
1267         }
1268       else
1269         while (i < ny)
1270           {
1271             num += zds[i];
1272             if (num < 0)
1273               {
1274                 zds[i++] = num + SCM_BIGRAD;
1275                 num = -1;
1276               }
1277             else
1278               {
1279                 zds[i++] = SCM_BIGLO (num);
1280                 num = 0;
1281               }
1282           }
1283     }
1284   else
1285     {
1286       do
1287         {
1288           num += (long) zds[i] + x[i];
1289           zds[i++] = SCM_BIGLO (num);
1290           num = SCM_BIGDN (num);
1291         }
1292       while (i < nx);
1293       if (!num)
1294         return z;
1295       while (i < ny)
1296         {
1297           num += zds[i];
1298           zds[i++] = SCM_BIGLO (num);
1299           num = SCM_BIGDN (num);
1300           if (!num)
1301             return z;
1302         }
1303       if (num)
1304         {
1305           z = scm_adjbig (z, ny + 1);
1306           SCM_BDIGITS (z)[ny] = num;
1307           return z;
1308         }
1309     }
1310   return scm_normbig (z);
1311 }
1312
1313
1314 SCM
1315 scm_mulbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn)
1316 {
1317   scm_sizet i = 0, j = nx + ny;
1318   unsigned long n = 0;
1319   SCM z = scm_mkbig (j, sgn);
1320   SCM_BIGDIG *zds = SCM_BDIGITS (z);
1321   while (j--)
1322     zds[j] = 0;
1323   do
1324     {
1325       j = 0;
1326       if (x[i])
1327         {
1328           do
1329             {
1330               n += zds[i + j] + ((unsigned long) x[i] * y[j]);
1331               zds[i + j++] = SCM_BIGLO (n);
1332               n = SCM_BIGDN (n);
1333             }
1334           while (j < ny);
1335           if (n)
1336             {
1337               zds[i + j] = n;
1338               n = 0;
1339             }
1340         }
1341     }
1342   while (++i < nx);
1343   return scm_normbig (z);
1344 }
1345
1346
1347 /* Sun's compiler complains about the fact that this function has an
1348    ANSI prototype in numbers.h, but a K&R declaration here, and the
1349    two specify different promotions for the third argument.  I'm going
1350    to turn this into an ANSI declaration, and see if anyone complains
1351    about it not being K&R.  */
1352
1353 unsigned int
1354 scm_divbigdig (SCM_BIGDIG * ds,
1355                scm_sizet h,
1356                SCM_BIGDIG div)
1357 {
1358   register unsigned long t2 = 0;
1359   while (h--)
1360     {
1361       t2 = SCM_BIGUP (t2) + ds[h];
1362       ds[h] = t2 / div;
1363       t2 %= div;
1364     }
1365   return t2;
1366 }
1367
1368
1369
1370 SCM
1371 scm_divbigint (SCM x, long z, int sgn, int mode)
1372 {
1373   if (z < 0)
1374     z = -z;
1375   if (z < SCM_BIGRAD)
1376     {
1377       register unsigned long t2 = 0;
1378       register SCM_BIGDIG *ds = SCM_BDIGITS (x);
1379       scm_sizet nd = SCM_NUMDIGS (x);
1380       while (nd--)
1381         t2 = (SCM_BIGUP (t2) + ds[nd]) % z;
1382       if (mode && t2)
1383         t2 = z - t2;
1384       return SCM_MAKINUM (sgn ? -t2 : t2);
1385     }
1386   {
1387 #ifndef SCM_DIGSTOOBIG
1388     unsigned long t2 = scm_pseudolong (z);
1389     return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
1390                           (SCM_BIGDIG *) & t2, SCM_DIGSPERLONG,
1391                           sgn, mode);
1392 #else
1393     SCM_BIGDIG t2[SCM_DIGSPERLONG];
1394     scm_longdigs (z, t2);
1395     return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
1396                           t2, SCM_DIGSPERLONG,
1397                           sgn, mode);
1398 #endif
1399   }
1400 }
1401
1402
1403 SCM
1404 scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes)
1405 {
1406   /* modes description
1407      0  remainder
1408      1  scm_modulo
1409      2  quotient
1410      3  quotient but returns 0 if division is not exact. */
1411   scm_sizet i = 0, j = 0;
1412   long num = 0;
1413   unsigned long t2 = 0;
1414   SCM z, newy;
1415   SCM_BIGDIG d = 0, qhat, *zds, *yds;
1416   /* algorithm requires nx >= ny */
1417   if (nx < ny)
1418     switch (modes)
1419       {
1420       case 0:                   /* remainder -- just return x */
1421         z = scm_mkbig (nx, sgn);
1422         zds = SCM_BDIGITS (z);
1423         do
1424           {
1425             zds[i] = x[i];
1426           }
1427         while (++i < nx);
1428         return z;
1429       case 1:                   /* scm_modulo -- return y-x */
1430         z = scm_mkbig (ny, sgn);
1431         zds = SCM_BDIGITS (z);
1432         do
1433           {
1434             num += (long) y[i] - x[i];
1435             if (num < 0)
1436               {
1437                 zds[i] = num + SCM_BIGRAD;
1438                 num = -1;
1439               }
1440             else
1441               {
1442                 zds[i] = num;
1443                 num = 0;
1444               }
1445           }
1446         while (++i < nx);
1447         while (i < ny)
1448           {
1449             num += y[i];
1450             if (num < 0)
1451               {
1452                 zds[i++] = num + SCM_BIGRAD;
1453                 num = -1;
1454               }
1455             else
1456               {
1457                 zds[i++] = num;
1458                 num = 0;
1459               }
1460           }
1461         goto doadj;
1462       case 2:
1463         return SCM_INUM0;       /* quotient is zero */
1464       case 3:
1465         return 0;               /* the division is not exact */
1466       }
1467
1468   z = scm_mkbig (nx == ny ? nx + 2 : nx + 1, sgn);
1469   zds = SCM_BDIGITS (z);
1470   if (nx == ny)
1471     zds[nx + 1] = 0;
1472   while (!y[ny - 1])
1473     ny--;                       /* in case y came in as a psuedolong */
1474   if (y[ny - 1] < (SCM_BIGRAD >> 1))
1475     {                           /* normalize operands */
1476       d = SCM_BIGRAD / (y[ny - 1] + 1);
1477       newy = scm_mkbig (ny, 0);
1478       yds = SCM_BDIGITS (newy);
1479       while (j < ny)
1480         {
1481           t2 += (unsigned long) y[j] * d;
1482           yds[j++] = SCM_BIGLO (t2);
1483           t2 = SCM_BIGDN (t2);
1484         }
1485       y = yds;
1486       j = 0;
1487       t2 = 0;
1488       while (j < nx)
1489         {
1490           t2 += (unsigned long) x[j] * d;
1491           zds[j++] = SCM_BIGLO (t2);
1492           t2 = SCM_BIGDN (t2);
1493         }
1494       zds[j] = t2;
1495     }
1496   else
1497     {
1498       zds[j = nx] = 0;
1499       while (j--)
1500         zds[j] = x[j];
1501     }
1502   j = nx == ny ? nx + 1 : nx;   /* dividend needs more digits than divisor */
1503   do
1504     {                           /* loop over digits of quotient */
1505       if (zds[j] == y[ny - 1])
1506         qhat = SCM_BIGRAD - 1;
1507       else
1508         qhat = (SCM_BIGUP (zds[j]) + zds[j - 1]) / y[ny - 1];
1509       if (!qhat)
1510         continue;
1511       i = 0;
1512       num = 0;
1513       t2 = 0;
1514       do
1515         {                       /* multiply and subtract */
1516           t2 += (unsigned long) y[i] * qhat;
1517           num += zds[j - ny + i] - SCM_BIGLO (t2);
1518           if (num < 0)
1519             {
1520               zds[j - ny + i] = num + SCM_BIGRAD;
1521               num = -1;
1522             }
1523           else
1524             {
1525               zds[j - ny + i] = num;
1526               num = 0;
1527             }
1528           t2 = SCM_BIGDN (t2);
1529         }
1530       while (++i < ny);
1531       num += zds[j - ny + i] - t2; /* borrow from high digit; don't update */
1532       while (num)
1533         {                       /* "add back" required */
1534           i = 0;
1535           num = 0;
1536           qhat--;
1537           do
1538             {
1539               num += (long) zds[j - ny + i] + y[i];
1540               zds[j - ny + i] = SCM_BIGLO (num);
1541               num = SCM_BIGDN (num);
1542             }
1543           while (++i < ny);
1544           num--;
1545         }
1546       if (modes & 2)
1547         zds[j] = qhat;
1548     }
1549   while (--j >= ny);
1550   switch (modes)
1551     {
1552     case 3:                     /* check that remainder==0 */
1553       for (j = ny; j && !zds[j - 1]; --j);
1554       if (j)
1555         return 0;
1556     case 2:                     /* move quotient down in z */
1557       j = (nx == ny ? nx + 2 : nx + 1) - ny;
1558       for (i = 0; i < j; i++)
1559         zds[i] = zds[i + ny];
1560       ny = i;
1561       break;
1562     case 1:                     /* subtract for scm_modulo */
1563       i = 0;
1564       num = 0;
1565       j = 0;
1566       do
1567         {
1568           num += y[i] - zds[i];
1569           j = j | zds[i];
1570           if (num < 0)
1571             {
1572               zds[i] = num + SCM_BIGRAD;
1573               num = -1;
1574             }
1575           else
1576             {
1577               zds[i] = num;
1578               num = 0;
1579             }
1580         }
1581       while (++i < ny);
1582       if (!j)
1583         return SCM_INUM0;
1584     case 0:                     /* just normalize remainder */
1585       if (d)
1586         scm_divbigdig (zds, ny, d);
1587     }
1588  doadj:
1589   for (j = ny; j && !zds[j - 1]; --j);
1590   if (j * SCM_BITSPERDIG <= sizeof (SCM) * SCM_CHAR_BIT)
1591     if (SCM_INUMP (z = scm_big2inum (z, j)))
1592       return z;
1593   return scm_adjbig (z, j);
1594 }
1595 #endif
1596 \f
1597
1598
1599
1600
1601 /*** NUMBERS -> STRINGS ***/
1602 #ifdef SCM_FLOATS
1603 int scm_dblprec;
1604 static const double fx[] =
1605 {  0.0,  5e-1,  5e-2,  5e-3,   5e-4, 5e-5,
1606   5e-6,  5e-7,  5e-8,  5e-9,  5e-10,
1607  5e-11, 5e-12, 5e-13, 5e-14,  5e-15,
1608  5e-16, 5e-17, 5e-18, 5e-19,  5e-20};
1609
1610
1611
1612
1613 static scm_sizet
1614 idbl2str (double f, char *a)
1615 {
1616   int efmt, dpt, d, i, wp = scm_dblprec;
1617   scm_sizet ch = 0;
1618   int exp = 0;
1619
1620   if (f == 0.0)
1621     goto zero;                  /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1622   if (f < 0.0)
1623     {
1624       f = -f;
1625       a[ch++] = '-';
1626     }
1627   else if (f > 0.0);
1628   else
1629     goto funny;
1630   if (IS_INF (f))
1631     {
1632       if (ch == 0)
1633         a[ch++] = '+';
1634     funny:
1635       a[ch++] = '#';
1636       a[ch++] = '.';
1637       a[ch++] = '#';
1638       return ch;
1639     }
1640 #ifdef DBL_MIN_10_EXP  /* Prevent unnormalized values, as from
1641                           make-uniform-vector, from causing infinite loops. */
1642   while (f < 1.0)
1643     {
1644       f *= 10.0;
1645       if (exp-- < DBL_MIN_10_EXP)
1646         goto funny;
1647     }
1648   while (f > 10.0)
1649     {
1650       f *= 0.10;
1651       if (exp++ > DBL_MAX_10_EXP)
1652         goto funny;
1653     }
1654 #else
1655   while (f < 1.0)
1656     {
1657       f *= 10.0;
1658       exp--;
1659     }
1660   while (f > 10.0)
1661     {
1662       f /= 10.0;
1663       exp++;
1664     }
1665 #endif
1666   if (f + fx[wp] >= 10.0)
1667     {
1668       f = 1.0;
1669       exp++;
1670     }
1671  zero:
1672 #ifdef ENGNOT
1673   dpt = (exp + 9999) % 3;
1674   exp -= dpt++;
1675   efmt = 1;
1676 #else
1677   efmt = (exp < -3) || (exp > wp + 2);
1678   if (!efmt)
1679     {
1680       if (exp < 0)
1681         {
1682           a[ch++] = '0';
1683           a[ch++] = '.';
1684           dpt = exp;
1685           while (++dpt)
1686             a[ch++] = '0';
1687         }
1688       else
1689         dpt = exp + 1;
1690     }
1691   else
1692     dpt = 1;
1693 #endif
1694
1695   do
1696     {
1697       d = f;
1698       f -= d;
1699       a[ch++] = d + '0';
1700       if (f < fx[wp])
1701         break;
1702       if (f + fx[wp] >= 1.0)
1703         {
1704           a[ch - 1]++;
1705           break;
1706         }
1707       f *= 10.0;
1708       if (!(--dpt))
1709         a[ch++] = '.';
1710     }
1711   while (wp--);
1712
1713   if (dpt > 0)
1714     {
1715 #ifndef ENGNOT
1716       if ((dpt > 4) && (exp > 6))
1717         {
1718           d = (a[0] == '-' ? 2 : 1);
1719           for (i = ch++; i > d; i--)
1720             a[i] = a[i - 1];
1721           a[d] = '.';
1722           efmt = 1;
1723         }
1724       else
1725 #endif
1726         {
1727           while (--dpt)
1728             a[ch++] = '0';
1729           a[ch++] = '.';
1730         }
1731     }
1732   if (a[ch - 1] == '.')
1733     a[ch++] = '0';              /* trailing zero */
1734   if (efmt && exp)
1735     {
1736       a[ch++] = 'e';
1737       if (exp < 0)
1738         {
1739           exp = -exp;
1740           a[ch++] = '-';
1741         }
1742       for (i = 10; i <= exp; i *= 10);
1743       for (i /= 10; i; i /= 10)
1744         {
1745           a[ch++] = exp / i + '0';
1746           exp %= i;
1747         }
1748     }
1749   return ch;
1750 }
1751
1752
1753 static scm_sizet
1754 iflo2str (SCM flt, char *str)
1755 {
1756   scm_sizet i;
1757 #ifdef SCM_SINGLES
1758   if (SCM_SINGP (flt))
1759     i = idbl2str (SCM_FLO (flt), str);
1760   else
1761 #endif
1762     i = idbl2str (SCM_REAL (flt), str);
1763   if (SCM_CPLXP (flt))
1764     {
1765       if (0 <= SCM_IMAG (flt))  /* jeh */
1766         str[i++] = '+';         /* jeh */
1767       i += idbl2str (SCM_IMAG (flt), &str[i]);
1768       str[i++] = 'i';
1769     }
1770   return i;
1771 }
1772 #endif /* SCM_FLOATS */
1773
1774 /* convert a long to a string (unterminated).  returns the number of
1775    characters in the result.
1776    rad is output base
1777    p is destination: worst case (base 2) is SCM_INTBUFLEN  */
1778 scm_sizet
1779 scm_iint2str (long num, int rad, char *p)
1780 {
1781   scm_sizet j = 1;
1782   scm_sizet i;
1783   unsigned long n = (num < 0) ? -num : num;
1784
1785   for (n /= rad; n > 0; n /= rad)
1786     j++;
1787
1788   i = j;
1789   if (num < 0)
1790     {
1791       *p++ = '-';
1792       j++;
1793       n = -num;
1794     }
1795   else
1796     n = num;
1797   while (i--)
1798     {
1799       int d = n % rad;
1800
1801       n /= rad;
1802       p[i] = d + ((d < 10) ? '0' : 'a' - 10);
1803     }
1804   return j;
1805 }
1806
1807
1808 #ifdef SCM_BIGDIG
1809
1810 static SCM
1811 big2str (SCM b, unsigned int radix)
1812 {
1813   SCM t = scm_copybig (b, 0);   /* sign of temp doesn't matter */
1814   register SCM_BIGDIG *ds = SCM_BDIGITS (t);
1815   scm_sizet i = SCM_NUMDIGS (t);
1816   scm_sizet j = radix == 16 ? (SCM_BITSPERDIG * i) / 4 + 2
1817     : radix >= 10 ? (SCM_BITSPERDIG * i * 241L) / 800 + 2
1818     : (SCM_BITSPERDIG * i) + 2;
1819   scm_sizet k = 0;
1820   scm_sizet radct = 0;
1821   scm_sizet ch;                 /* jeh */
1822   SCM_BIGDIG radpow = 1, radmod = 0;
1823   SCM ss = scm_makstr ((long) j, 0);
1824   char *s = SCM_CHARS (ss), c;
1825   while ((long) radpow * radix < SCM_BIGRAD)
1826     {
1827       radpow *= radix;
1828       radct++;
1829     }
1830   s[0] = scm_tc16_bigneg == SCM_TYP16 (b) ? '-' : '+';
1831   while ((i || radmod) && j)
1832     {
1833       if (k == 0)
1834         {
1835           radmod = (SCM_BIGDIG) scm_divbigdig (ds, i, radpow);
1836           k = radct;
1837           if (!ds[i - 1])
1838             i--;
1839         }
1840       c = radmod % radix;
1841       radmod /= radix;
1842       k--;
1843       s[--j] = c < 10 ? c + '0' : c + 'a' - 10;
1844     }
1845   ch = s[0] == '-' ? 1 : 0;     /* jeh */
1846   if (ch < j)
1847     {                           /* jeh */
1848       for (i = j; j < SCM_LENGTH (ss); j++)
1849         s[ch + j - i] = s[j];   /* jeh */
1850       scm_vector_set_length_x (ss, /* jeh */
1851                                (SCM) SCM_MAKINUM (ch + SCM_LENGTH (ss) - i));
1852     }
1853
1854   return scm_return_first (ss, t);
1855 }
1856 #endif
1857
1858
1859 SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
1860             (SCM x, SCM radix),
1861 "")
1862 #define FUNC_NAME s_scm_number_to_string
1863 {
1864   int base;
1865   SCM_VALIDATE_INUM_MIN_DEF_COPY(2,radix,2,10,base);
1866 #ifdef SCM_FLOATS
1867   if (SCM_NINUMP (x))
1868     {
1869       char num_buf[SCM_FLOBUFLEN];
1870 #ifdef SCM_BIGDIG
1871       SCM_ASRTGO (SCM_NIMP (x), badx);
1872       if (SCM_BIGP (x))
1873         return big2str (x, (unsigned int) base);
1874 #ifndef SCM_RECKLESS
1875       if (!SCM_INEXP (x))
1876         {
1877         badx:
1878           SCM_WTA (1, x);
1879         }
1880 #endif
1881 #else
1882       SCM_ASSERT (SCM_INEXP (x),
1883                   x, SCM_ARG1, s_number_to_string);
1884 #endif
1885       return scm_makfromstr (num_buf, iflo2str (x, num_buf), 0);
1886     }
1887 #else
1888 #ifdef SCM_BIGDIG
1889   if (SCM_NINUMP (x))
1890     {
1891       SCM_ASSERT (SCM_BIGP (x),
1892                   x, SCM_ARG1, s_number_to_string);
1893       return big2str (x, (unsigned int) base);
1894     }
1895 #else
1896   SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_number_to_string);
1897 #endif
1898 #endif
1899   {
1900     char num_buf[SCM_INTBUFLEN];
1901     return scm_makfromstr (num_buf,
1902                            scm_iint2str (SCM_INUM (x),
1903                                          base,
1904                                          num_buf),
1905                            0);
1906   }
1907 }
1908 #undef FUNC_NAME
1909
1910
1911 /* These print routines are stubbed here so that scm_repl.c doesn't need
1912    SCM_FLOATS or SCM_BIGDIGs conditionals */
1913
1914 int
1915 scm_floprint (SCM sexp, SCM port, scm_print_state *pstate)
1916 {
1917 #ifdef SCM_FLOATS
1918   char num_buf[SCM_FLOBUFLEN];
1919   scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port);
1920 #else
1921   scm_ipruk ("float", sexp, port);
1922 #endif
1923   return !0;
1924 }
1925
1926
1927
1928 int
1929 scm_bigprint (SCM exp, SCM port, scm_print_state *pstate)
1930 {
1931 #ifdef SCM_BIGDIG
1932   exp = big2str (exp, (unsigned int) 10);
1933   scm_lfwrite (SCM_CHARS (exp), (scm_sizet) SCM_LENGTH (exp), port);
1934 #else
1935   scm_ipruk ("bignum", exp, port);
1936 #endif
1937   return !0;
1938 }
1939 /*** END nums->strs ***/
1940
1941 /*** STRINGS -> NUMBERS ***/
1942
1943 static SCM
1944 scm_small_istr2int (char *str, long len, long radix)
1945 {
1946   register long n = 0, ln;
1947   register int c;
1948   register int i = 0;
1949   int lead_neg = 0;
1950   if (0 >= len)
1951     return SCM_BOOL_F;          /* zero scm_length */
1952   switch (*str)
1953     {                           /* leading sign */
1954     case '-':
1955       lead_neg = 1;
1956     case '+':
1957       if (++i == len)
1958         return SCM_BOOL_F;      /* bad if lone `+' or `-' */
1959     }
1960
1961   do
1962     {
1963       switch (c = str[i++])
1964         {
1965         case DIGITS:
1966           c = c - '0';
1967           goto accumulate;
1968         case 'A':
1969         case 'B':
1970         case 'C':
1971         case 'D':
1972         case 'E':
1973         case 'F':
1974           c = c - 'A' + 10;
1975           goto accumulate;
1976         case 'a':
1977         case 'b':
1978         case 'c':
1979         case 'd':
1980         case 'e':
1981         case 'f':
1982           c = c - 'a' + 10;
1983         accumulate:
1984           if (c >= radix)
1985             return SCM_BOOL_F;  /* bad digit for radix */
1986           ln = n;
1987           n = n * radix - c;
1988           /* Negation is a workaround for HP700 cc bug */
1989           if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM))
1990             goto ovfl;
1991           break;
1992         default:
1993           return SCM_BOOL_F;    /* not a digit */
1994         }
1995     }
1996   while (i < len);
1997   if (!lead_neg)
1998     if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM)
1999       goto ovfl;
2000   return SCM_MAKINUM (n);
2001  ovfl:                          /* overflow scheme integer */
2002   return SCM_BOOL_F;
2003 }
2004
2005
2006
2007 SCM
2008 scm_istr2int (char *str, long len, long radix)
2009 {
2010   scm_sizet j;
2011   register scm_sizet k, blen = 1;
2012   scm_sizet i = 0;
2013   int c;
2014   SCM res;
2015   register SCM_BIGDIG *ds;
2016   register unsigned long t2;
2017
2018   if (0 >= len)
2019     return SCM_BOOL_F;          /* zero scm_length */
2020
2021   /* Short numbers we parse directly into an int, to avoid the overhead
2022      of creating a bignum.  */
2023   if (len < 6)
2024     return scm_small_istr2int (str, len, radix);
2025
2026   if (16 == radix)
2027     j = 1 + (4 * len * sizeof (char)) / (SCM_BITSPERDIG);
2028   else if (10 <= radix)
2029     j = 1 + (84 * len * sizeof (char)) / (SCM_BITSPERDIG * 25);
2030   else
2031     j = 1 + (len * sizeof (char)) / (SCM_BITSPERDIG);
2032   switch (str[0])
2033     {                           /* leading sign */
2034     case '-':
2035     case '+':
2036       if (++i == (unsigned) len)
2037         return SCM_BOOL_F;      /* bad if lone `+' or `-' */
2038     }
2039   res = scm_mkbig (j, '-' == str[0]);
2040   ds = SCM_BDIGITS (res);
2041   for (k = j; k--;)
2042     ds[k] = 0;
2043   do
2044     {
2045       switch (c = str[i++])
2046         {
2047         case DIGITS:
2048           c = c - '0';
2049           goto accumulate;
2050         case 'A':
2051         case 'B':
2052         case 'C':
2053         case 'D':
2054         case 'E':
2055         case 'F':
2056           c = c - 'A' + 10;
2057           goto accumulate;
2058         case 'a':
2059         case 'b':
2060         case 'c':
2061         case 'd':
2062         case 'e':
2063         case 'f':
2064           c = c - 'a' + 10;
2065         accumulate:
2066           if (c >= radix)
2067             return SCM_BOOL_F;  /* bad digit for radix */
2068           k = 0;
2069           t2 = c;
2070         moretodo:
2071           while (k < blen)
2072             {
2073 /* printf ("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]); */
2074               t2 += ds[k] * radix;
2075               ds[k++] = SCM_BIGLO (t2);
2076               t2 = SCM_BIGDN (t2);
2077             }
2078           if (blen > j)
2079             scm_num_overflow ("bignum");
2080           if (t2)
2081             {
2082               blen++;
2083               goto moretodo;
2084             }
2085           break;
2086         default:
2087           return SCM_BOOL_F;    /* not a digit */
2088         }
2089     }
2090   while (i < (unsigned) len);
2091   if (blen * SCM_BITSPERDIG / SCM_CHAR_BIT <= sizeof (SCM))
2092     if (SCM_INUMP (res = scm_big2inum (res, blen)))
2093       return res;
2094   if (j == blen)
2095     return res;
2096   return scm_adjbig (res, blen);
2097 }
2098
2099 #ifdef SCM_FLOATS
2100
2101 SCM
2102 scm_istr2flo (char *str, long len, long radix)
2103 {
2104   register int c, i = 0;
2105   double lead_sgn;
2106   double res = 0.0, tmp = 0.0;
2107   int flg = 0;
2108   int point = 0;
2109   SCM second;
2110
2111   if (i >= len)
2112     return SCM_BOOL_F;          /* zero scm_length */
2113
2114   switch (*str)
2115     {                           /* leading sign */
2116     case '-':
2117       lead_sgn = -1.0;
2118       i++;
2119       break;
2120     case '+':
2121       lead_sgn = 1.0;
2122       i++;
2123       break;
2124     default:
2125       lead_sgn = 0.0;
2126     }
2127   if (i == len)
2128     return SCM_BOOL_F;          /* bad if lone `+' or `-' */
2129
2130   if (str[i] == 'i' || str[i] == 'I')
2131     {                           /* handle `+i' and `-i'   */
2132       if (lead_sgn == 0.0)
2133         return SCM_BOOL_F;      /* must have leading sign */
2134       if (++i < len)
2135         return SCM_BOOL_F;      /* `i' not last character */
2136       return scm_makdbl (0.0, lead_sgn);
2137     }
2138   do
2139     {                           /* check initial digits */
2140       switch (c = str[i])
2141         {
2142         case DIGITS:
2143           c = c - '0';
2144           goto accum1;
2145         case 'D':
2146         case 'E':
2147         case 'F':
2148           if (radix == 10)
2149             goto out1;          /* must be exponent */
2150         case 'A':
2151         case 'B':
2152         case 'C':
2153           c = c - 'A' + 10;
2154           goto accum1;
2155         case 'd':
2156         case 'e':
2157         case 'f':
2158           if (radix == 10)
2159             goto out1;
2160         case 'a':
2161         case 'b':
2162         case 'c':
2163           c = c - 'a' + 10;
2164         accum1:
2165           if (c >= radix)
2166             return SCM_BOOL_F;  /* bad digit for radix */
2167           res = res * radix + c;
2168           flg = 1;              /* res is valid */
2169           break;
2170         default:
2171           goto out1;
2172         }
2173     }
2174   while (++i < len);
2175  out1:
2176
2177   /* if true, then we did see a digit above, and res is valid */
2178   if (i == len)
2179     goto done;
2180
2181   /* By here, must have seen a digit,
2182      or must have next char be a `.' with radix==10 */
2183   if (!flg)
2184     if (!(str[i] == '.' && radix == 10))
2185       return SCM_BOOL_F;
2186
2187   while (str[i] == '#')
2188     {                           /* optional sharps */
2189       res *= radix;
2190       if (++i == len)
2191         goto done;
2192     }
2193
2194   if (str[i] == '/')
2195     {
2196       while (++i < len)
2197         {
2198           switch (c = str[i])
2199             {
2200             case DIGITS:
2201               c = c - '0';
2202               goto accum2;
2203             case 'A':
2204             case 'B':
2205             case 'C':
2206             case 'D':
2207             case 'E':
2208             case 'F':
2209               c = c - 'A' + 10;
2210               goto accum2;
2211             case 'a':
2212             case 'b':
2213             case 'c':
2214             case 'd':
2215             case 'e':
2216             case 'f':
2217               c = c - 'a' + 10;
2218             accum2:
2219               if (c >= radix)
2220                 return SCM_BOOL_F;
2221               tmp = tmp * radix + c;
2222               break;
2223             default:
2224               goto out2;
2225             }
2226         }
2227     out2:
2228       if (tmp == 0.0)
2229         return SCM_BOOL_F;      /* `slash zero' not allowed */
2230       if (i < len)
2231         while (str[i] == '#')
2232           {                     /* optional sharps */
2233             tmp *= radix;
2234             if (++i == len)
2235               break;
2236           }
2237       res /= tmp;
2238       goto done;
2239     }
2240
2241   if (str[i] == '.')
2242     {                           /* decimal point notation */
2243       if (radix != 10)
2244         return SCM_BOOL_F;      /* must be radix 10 */
2245       while (++i < len)
2246         {
2247           switch (c = str[i])
2248             {
2249             case DIGITS:
2250               point--;
2251               res = res * 10.0 + c - '0';
2252               flg = 1;
2253               break;
2254             default:
2255               goto out3;
2256             }
2257         }
2258     out3:
2259       if (!flg)
2260         return SCM_BOOL_F;      /* no digits before or after decimal point */
2261       if (i == len)
2262         goto adjust;
2263       while (str[i] == '#')
2264         {                       /* ignore remaining sharps */
2265           if (++i == len)
2266             goto adjust;
2267         }
2268     }
2269
2270   switch (str[i])
2271     {                           /* exponent */
2272     case 'd':
2273     case 'D':
2274     case 'e':
2275     case 'E':
2276     case 'f':
2277     case 'F':
2278     case 'l':
2279     case 'L':
2280     case 's':
2281     case 'S':
2282       {
2283         int expsgn = 1, expon = 0;
2284         if (radix != 10)
2285           return SCM_BOOL_F;    /* only in radix 10 */
2286         if (++i == len)
2287           return SCM_BOOL_F;    /* bad exponent */
2288         switch (str[i])
2289           {
2290           case '-':
2291             expsgn = (-1);
2292           case '+':
2293             if (++i == len)
2294               return SCM_BOOL_F;        /* bad exponent */
2295           }
2296         if (str[i] < '0' || str[i] > '9')
2297           return SCM_BOOL_F;    /* bad exponent */
2298         do
2299           {
2300             switch (c = str[i])
2301               {
2302               case DIGITS:
2303                 expon = expon * 10 + c - '0';
2304                 if (expon > MAXEXP)
2305                   return SCM_BOOL_F;    /* exponent too large */
2306                 break;
2307               default:
2308                 goto out4;
2309               }
2310           }
2311         while (++i < len);
2312       out4:
2313         point += expsgn * expon;
2314       }
2315     }
2316
2317  adjust:
2318   if (point >= 0)
2319     while (point--)
2320       res *= 10.0;
2321   else
2322 #ifdef _UNICOS
2323     while (point++)
2324       res *= 0.1;
2325 #else
2326   while (point++)
2327     res /= 10.0;
2328 #endif
2329
2330  done:
2331   /* at this point, we have a legitimate floating point result */
2332   if (lead_sgn == -1.0)
2333     res = -res;
2334   if (i == len)
2335     return scm_makdbl (res, 0.0);
2336
2337   if (str[i] == 'i' || str[i] == 'I')
2338     {                           /* pure imaginary number  */
2339       if (lead_sgn == 0.0)
2340         return SCM_BOOL_F;      /* must have leading sign */
2341       if (++i < len)
2342         return SCM_BOOL_F;      /* `i' not last character */
2343       return scm_makdbl (0.0, res);
2344     }
2345
2346   switch (str[i++])
2347     {
2348     case '-':
2349       lead_sgn = -1.0;
2350       break;
2351     case '+':
2352       lead_sgn = 1.0;
2353       break;
2354     case '@':
2355       {                         /* polar input for complex number */
2356         /* get a `real' for scm_angle */
2357         second = scm_istr2flo (&str[i], (long) (len - i), radix);
2358         if (!SCM_INEXP (second))
2359           return SCM_BOOL_F;    /* not `real' */
2360         if (SCM_CPLXP (second))
2361           return SCM_BOOL_F;    /* not `real' */
2362         tmp = SCM_REALPART (second);
2363         return scm_makdbl (res * cos (tmp), res * sin (tmp));
2364       }
2365     default:
2366       return SCM_BOOL_F;
2367     }
2368
2369   /* at this point, last char must be `i' */
2370   if (str[len - 1] != 'i' && str[len - 1] != 'I')
2371     return SCM_BOOL_F;
2372   /* handles `x+i' and `x-i' */
2373   if (i == (len - 1))
2374     return scm_makdbl (res, lead_sgn);
2375   /* get a `ureal' for complex part */
2376   second = scm_istr2flo (&str[i], (long) ((len - i) - 1), radix);
2377   if (!SCM_INEXP (second))
2378     return SCM_BOOL_F;          /* not `ureal' */
2379   if (SCM_CPLXP (second))
2380     return SCM_BOOL_F;          /* not `ureal' */
2381   tmp = SCM_REALPART (second);
2382   if (tmp < 0.0)
2383     return SCM_BOOL_F;          /* not `ureal' */
2384   return scm_makdbl (res, (lead_sgn * tmp));
2385 }
2386 #endif /* SCM_FLOATS */
2387
2388
2389
2390 SCM
2391 scm_istring2number (char *str, long len, long radix)
2392 {
2393   int i = 0;
2394   char ex = 0;
2395   char ex_p = 0, rx_p = 0;      /* Only allow 1 exactness and 1 radix prefix */
2396   SCM res;
2397   if (len == 1)
2398     if (*str == '+' || *str == '-')    /* Catches lone `+' and `-' for speed */
2399       return SCM_BOOL_F;
2400
2401   while ((len - i) >= 2 && str[i] == '#' && ++i)
2402     switch (str[i++])
2403       {
2404       case 'b':
2405       case 'B':
2406         if (rx_p++)
2407           return SCM_BOOL_F;
2408         radix = 2;
2409         break;
2410       case 'o':
2411       case 'O':
2412         if (rx_p++)
2413           return SCM_BOOL_F;
2414         radix = 8;
2415         break;
2416       case 'd':
2417       case 'D':
2418         if (rx_p++)
2419           return SCM_BOOL_F;
2420         radix = 10;
2421         break;
2422       case 'x':
2423       case 'X':
2424         if (rx_p++)
2425           return SCM_BOOL_F;
2426         radix = 16;
2427         break;
2428       case 'i':
2429       case 'I':
2430         if (ex_p++)
2431           return SCM_BOOL_F;
2432         ex = 2;
2433         break;
2434       case 'e':
2435       case 'E':
2436         if (ex_p++)
2437           return SCM_BOOL_F;
2438         ex = 1;
2439         break;
2440       default:
2441         return SCM_BOOL_F;
2442       }
2443
2444   switch (ex)
2445     {
2446     case 1:
2447       return scm_istr2int (&str[i], len - i, radix);
2448     case 0:
2449       res = scm_istr2int (&str[i], len - i, radix);
2450       if (SCM_NFALSEP (res))
2451         return res;
2452 #ifdef SCM_FLOATS
2453     case 2:
2454       return scm_istr2flo (&str[i], len - i, radix);
2455 #endif
2456     }
2457   return SCM_BOOL_F;
2458 }
2459
2460
2461 SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
2462             (SCM str, SCM radix),
2463 "")
2464 #define FUNC_NAME s_scm_string_to_number
2465 {
2466   SCM answer;
2467   int base;
2468   SCM_VALIDATE_ROSTRING(1,str);
2469   SCM_VALIDATE_INUM_MIN_DEF_COPY(2,radix,2,10,base);
2470   answer = scm_istring2number (SCM_ROCHARS (str),
2471                                SCM_ROLENGTH (str),
2472                                base);
2473   return scm_return_first (answer, str);
2474 }
2475 #undef FUNC_NAME
2476 /*** END strs->nums ***/
2477
2478 #ifdef SCM_FLOATS
2479
2480 SCM
2481 scm_makdbl (double x, double y)
2482 {
2483   SCM z;
2484   if ((y == 0.0) && (x == 0.0))
2485     return scm_flo0;
2486   SCM_DEFER_INTS;
2487   if (y == 0.0)
2488     {
2489 #ifdef SCM_SINGLES
2490       float fx = x;
2491 #ifndef SCM_SINGLESONLY
2492       if ((-FLTMAX < x) && (x < FLTMAX) && (fx == x))
2493 #endif
2494         {
2495           SCM_NEWSMOB(z,scm_tc_flo,NULL);
2496           SCM_FLO (z) = x;
2497           SCM_ALLOW_INTS;
2498           return z;
2499         }
2500 #endif /* def SCM_SINGLES */
2501       SCM_NEWSMOB(z,scm_tc_dblr,scm_must_malloc (1L * sizeof (double), "real"));
2502     }
2503   else
2504     {
2505       SCM_NEWSMOB(z,scm_tc_dblc,scm_must_malloc (2L * sizeof (double), "comkplex"));
2506       SCM_IMAG (z) = y;
2507     }
2508   SCM_REAL (z) = x;
2509   SCM_ALLOW_INTS;
2510   return z;
2511 }
2512 #endif
2513
2514
2515
2516 SCM
2517 scm_bigequal (SCM x, SCM y)
2518 {
2519 #ifdef SCM_BIGDIG
2520   if (0 == scm_bigcomp (x, y))
2521     return SCM_BOOL_T;
2522 #endif
2523   return SCM_BOOL_F;
2524 }
2525
2526
2527
2528 SCM
2529 scm_floequal (SCM x, SCM y)
2530 {
2531 #ifdef SCM_FLOATS
2532   if (SCM_REALPART (x) != SCM_REALPART (y))
2533     return SCM_BOOL_F;
2534   if (!(SCM_CPLXP (x) && (SCM_IMAG (x) != SCM_IMAG (y))))
2535     return SCM_BOOL_T;
2536 #endif
2537   return SCM_BOOL_F;
2538 }
2539
2540
2541
2542
2543 SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p);
2544
2545 SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0,
2546             (SCM x),
2547 "")
2548 #define FUNC_NAME s_scm_number_p
2549 {
2550   if (SCM_INUMP (x))
2551     return SCM_BOOL_T;
2552 #ifdef SCM_FLOATS
2553   if (SCM_NUMP (x))
2554     return SCM_BOOL_T;
2555 #else
2556 #ifdef SCM_BIGDIG
2557   if (SCM_NUMP (x))
2558     return SCM_BOOL_T;
2559 #endif
2560 #endif
2561   return SCM_BOOL_F;
2562 }
2563 #undef FUNC_NAME
2564
2565
2566
2567 #ifdef SCM_FLOATS
2568 SCM_REGISTER_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p);
2569
2570
2571 SCM_DEFINE (scm_real_p, "rational?", 1, 0, 0,
2572             (SCM x),
2573 "")
2574 #define FUNC_NAME s_scm_real_p
2575 {
2576   if (SCM_INUMP (x))
2577     return SCM_BOOL_T;
2578   if (SCM_IMP (x))
2579     return SCM_BOOL_F;
2580   if (SCM_REALP (x))
2581     return SCM_BOOL_T;
2582 #ifdef SCM_BIGDIG
2583   if (SCM_BIGP (x))
2584     return SCM_BOOL_T;
2585 #endif
2586   return SCM_BOOL_F;
2587 }
2588 #undef FUNC_NAME
2589
2590
2591
2592 SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
2593             (SCM x),
2594 "")
2595 #define FUNC_NAME s_scm_integer_p
2596 {
2597   double r;
2598   if (SCM_INUMP (x))
2599     return SCM_BOOL_T;
2600   if (SCM_IMP (x))
2601     return SCM_BOOL_F;
2602 #ifdef SCM_BIGDIG
2603   if (SCM_BIGP (x))
2604     return SCM_BOOL_T;
2605 #endif
2606   if (!SCM_INEXP (x))
2607     return SCM_BOOL_F;
2608   if (SCM_CPLXP (x))
2609     return SCM_BOOL_F;
2610   r = SCM_REALPART (x);
2611   if (r == floor (r))
2612     return SCM_BOOL_T;
2613   return SCM_BOOL_F;
2614 }
2615 #undef FUNC_NAME
2616
2617
2618
2619 #endif /* SCM_FLOATS */
2620
2621 SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0,
2622             (SCM x),
2623 "")
2624 #define FUNC_NAME s_scm_inexact_p
2625 {
2626 #ifdef SCM_FLOATS
2627   if (SCM_INEXP (x))
2628     return SCM_BOOL_T;
2629 #endif
2630   return SCM_BOOL_F;
2631 }
2632 #undef FUNC_NAME
2633
2634
2635
2636
2637 SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
2638
2639 SCM
2640 scm_num_eq_p (SCM x, SCM y)
2641 {
2642 #ifdef SCM_FLOATS
2643   SCM t;
2644   if (SCM_NINUMP (x))
2645     {
2646 #ifdef SCM_BIGDIG
2647       if (!SCM_NIMP (x))
2648         {
2649         badx:
2650           SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
2651         }
2652       if (SCM_BIGP (x))
2653         {
2654           if (SCM_INUMP (y))
2655             return SCM_BOOL_F;
2656           SCM_ASRTGO (SCM_NIMP (y), bady);
2657           if (SCM_BIGP (y))
2658             return SCM_BOOL(0 == scm_bigcomp (x, y));
2659           SCM_ASRTGO (SCM_INEXP (y), bady);
2660         bigreal:
2661           return ((SCM_REALP (y) && (scm_big2dbl (x) == SCM_REALPART (y)))
2662                   ? SCM_BOOL_T
2663                   : SCM_BOOL_F);
2664         }
2665       SCM_ASRTGO (SCM_INEXP (x), badx);
2666 #else
2667       SCM_GASSERT2 (SCM_INEXP (x),
2668                     g_eq_p, x, y, SCM_ARG1, s_eq_p);
2669 #endif
2670       if (SCM_INUMP (y))
2671         {
2672           t = x;
2673           x = y;
2674           y = t;
2675           goto realint;
2676         }
2677 #ifdef SCM_BIGDIG
2678       SCM_ASRTGO (SCM_NIMP (y), bady);
2679       if (SCM_BIGP (y))
2680         {
2681           t = x;
2682           x = y;
2683           y = t;
2684           goto bigreal;
2685         }
2686       SCM_ASRTGO (SCM_INEXP (y), bady);
2687 #else
2688       SCM_ASRTGO (SCM_INEXP (y), bady);
2689 #endif
2690       if (SCM_REALPART (x) != SCM_REALPART (y))
2691         return SCM_BOOL_F;
2692       if (SCM_CPLXP (x))
2693         return ((SCM_CPLXP (y) && (SCM_IMAG (x) == SCM_IMAG (y)))
2694                 ? SCM_BOOL_T
2695                 : SCM_BOOL_F);
2696       return SCM_NEGATE_BOOL(SCM_CPLXP (y));
2697     }
2698   if (SCM_NINUMP (y))
2699     {
2700 #ifdef SCM_BIGDIG
2701       SCM_ASRTGO (SCM_NIMP (y), bady);
2702       if (SCM_BIGP (y))
2703         return SCM_BOOL_F;
2704       if (!SCM_INEXP (y))
2705         {
2706         bady:
2707           SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
2708         }
2709 #else
2710       if (!SCM_INEXP (y))
2711         {
2712         bady:
2713           SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
2714         }
2715 #endif
2716     realint:
2717       return ((SCM_REALP (y) && (((double) SCM_INUM (x)) == SCM_REALPART (y)))
2718               ? SCM_BOOL_T
2719               : SCM_BOOL_F);
2720     }
2721 #else
2722 #ifdef SCM_BIGDIG
2723   if (SCM_NINUMP (x))
2724     {
2725       SCM_GASSERT2 (SCM_BIGP (x),
2726                     g_eq_p, x, y, SCM_ARG1, s_eq_p);
2727       if (SCM_INUMP (y))
2728         return SCM_BOOL_F;
2729       SCM_ASRTGO (SCM_BIGP (y), bady);
2730       return SCM_BOOL(0 == scm_bigcomp (x, y));
2731     }
2732   if (SCM_NINUMP (y))
2733     {
2734       if (!SCM_BIGP (y))
2735         {
2736         bady:
2737           SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
2738         }
2739       return SCM_BOOL_F;
2740     }
2741 #else
2742   SCM_GASSERT2 (SCM_INUMP (x), g_eq_p, x, y, SCM_ARG1, s_eq_p);
2743   SCM_GASSERT2 (SCM_INUMP (y), g_eq_p, x, y, SCM_ARGn, s_eq_p);
2744 #endif
2745 #endif
2746   return SCM_BOOL((long) x == (long) y);
2747 }
2748
2749
2750
2751 SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
2752
2753 SCM
2754 scm_less_p (SCM x, SCM y)
2755 {
2756 #ifdef SCM_FLOATS
2757   if (SCM_NINUMP (x))
2758     {
2759 #ifdef SCM_BIGDIG
2760       if (!SCM_NIMP (x))
2761         {
2762         badx:
2763           SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
2764         }
2765       if (SCM_BIGP (x))
2766         {
2767           if (SCM_INUMP (y))
2768             return SCM_BOOL(SCM_BIGSIGN (x));
2769           SCM_ASRTGO (SCM_NIMP (y), bady);
2770           if (SCM_BIGP (y))
2771             return SCM_BOOL(1 == scm_bigcomp (x, y));
2772           SCM_ASRTGO (SCM_REALP (y), bady);
2773           return ((scm_big2dbl (x) < SCM_REALPART (y))
2774                   ? SCM_BOOL_T
2775                   : SCM_BOOL_F);
2776         }
2777       SCM_ASRTGO (SCM_REALP (x), badx);
2778 #else
2779       SCM_GASSERT2 (SCM_REALP (x),
2780                     g_less_p, x, y, SCM_ARG1, s_less_p);
2781 #endif
2782       if (SCM_INUMP (y))
2783         return ((SCM_REALPART (x) < ((double) SCM_INUM (y)))
2784                 ? SCM_BOOL_T
2785                 : SCM_BOOL_F);
2786 #ifdef SCM_BIGDIG
2787       SCM_ASRTGO (SCM_NIMP (y), bady);
2788       if (SCM_BIGP (y))
2789         return SCM_BOOL(SCM_REALPART (x) < scm_big2dbl (y));
2790       SCM_ASRTGO (SCM_REALP (y), bady);
2791 #else
2792       SCM_ASRTGO (SCM_REALP (y), bady);
2793 #endif
2794       return SCM_BOOL(SCM_REALPART (x) < SCM_REALPART (y));
2795     }
2796   if (SCM_NINUMP (y))
2797     {
2798 #ifdef SCM_BIGDIG
2799       SCM_ASRTGO (SCM_NIMP (y), bady);
2800       if (SCM_BIGP (y))
2801         return SCM_NEGATE_BOOL(SCM_BIGSIGN (y));
2802       if (!SCM_REALP (y))
2803         {
2804         bady:
2805           SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
2806         }
2807 #else
2808       if (!SCM_REALP (y))
2809         {
2810         bady:
2811           SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
2812         }
2813 #endif
2814       return ((((double) SCM_INUM (x)) < SCM_REALPART (y))
2815               ? SCM_BOOL_T
2816               : SCM_BOOL_F);
2817     }
2818 #else
2819 #ifdef SCM_BIGDIG
2820   if (SCM_NINUMP (x))
2821     {
2822       SCM_GASSERT2 (SCM_BIGP (x),
2823                     g_less_p, x, y, SCM_ARG1, s_less_p);
2824       if (SCM_INUMP (y))
2825         return SCM_BOOL(SCM_BIGSIGN (x));
2826       SCM_ASRTGO (SCM_BIGP (y), bady);
2827       return SCM_BOOL(1 == scm_bigcomp (x, y));
2828     }
2829   if (SCM_NINUMP (y))
2830     {
2831       if (!SCM_BIGP (y))
2832         {
2833         bady:
2834           SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
2835         }
2836       return SCM_NEGATE_BOOL(SCM_BIGSIGN (y));
2837     }
2838 #else
2839   SCM_GASSERT2 (SCM_INUMP (x), g_less_p, x, y, SCM_ARG1, s_less_p);
2840   SCM_GASSERT2 (SCM_INUMP (y), g_less_p, x, y, SCM_ARGn, s_less_p);
2841 #endif
2842 #endif
2843   return SCM_BOOL((long) x < (long) y);
2844 }
2845
2846
2847 GUILE_PROC1 (scm_gr_p, ">", scm_tc7_rpsubr,
2848              (SCM x, SCM y),
2849 "")
2850 #define FUNC_NAME s_scm_gr_p
2851 {
2852   return scm_less_p (y, x);
2853 }
2854 #undef FUNC_NAME
2855
2856
2857
2858 GUILE_PROC1 (scm_leq_p, "<=", scm_tc7_rpsubr,
2859              (SCM x, SCM y),
2860 "")
2861 #define FUNC_NAME s_scm_leq_p
2862 {
2863   return SCM_BOOL_NOT (scm_less_p (y, x));
2864 }
2865 #undef FUNC_NAME
2866
2867
2868
2869 GUILE_PROC1 (scm_geq_p, ">=", scm_tc7_rpsubr,
2870              (SCM x, SCM y),
2871 "")
2872 #define FUNC_NAME s_scm_geq_p
2873 {
2874   return SCM_BOOL_NOT (scm_less_p (x, y));
2875 }
2876 #undef FUNC_NAME
2877
2878
2879
2880 SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p);
2881
2882 SCM
2883 scm_zero_p (SCM z)
2884 {
2885 #ifdef SCM_FLOATS
2886   if (SCM_NINUMP (z))
2887     {
2888 #ifdef SCM_BIGDIG
2889       SCM_ASRTGO (SCM_NIMP (z), badz);
2890       if (SCM_BIGP (z))
2891         return SCM_BOOL_F;
2892       if (!SCM_INEXP (z))
2893         {
2894         badz:
2895           SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);
2896         }
2897 #else
2898       SCM_GASSERT1 (SCM_INEXP (z),
2899                     g_zero_p, z, SCM_ARG1, s_zero_p);
2900 #endif
2901       return SCM_BOOL(z == scm_flo0);
2902     }
2903 #else
2904 #ifdef SCM_BIGDIG
2905   if (SCM_NINUMP (z))
2906     {
2907       SCM_GASSERT1 (SCM_BIGP (z),
2908                     g_zero_p, z, SCM_ARG1, s_zero_p);
2909       return SCM_BOOL_F;
2910     }
2911 #else
2912   SCM_GASSERT1 (SCM_INUMP (z), g_zero_p, z, SCM_ARG1, s_zero_p);
2913 #endif
2914 #endif
2915   return SCM_BOOL(z == SCM_INUM0);
2916 }
2917
2918
2919
2920 SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p);
2921
2922 SCM
2923 scm_positive_p (SCM x)
2924 {
2925 #ifdef SCM_FLOATS
2926   if (SCM_NINUMP (x))
2927     {
2928 #ifdef SCM_BIGDIG
2929       SCM_ASRTGO (SCM_NIMP (x), badx);
2930       if (SCM_BIGP (x))
2931         return SCM_BOOL(SCM_TYP16 (x) == scm_tc16_bigpos);
2932       if (!SCM_REALP (x))
2933         {
2934         badx:
2935           SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);
2936         }
2937 #else
2938       SCM_GASSERT1 (SCM_REALP (x),
2939                     g_positive_p, x, SCM_ARG1, s_positive_p);
2940 #endif
2941       return SCM_BOOL(SCM_REALPART (x) > 0.0);
2942     }
2943 #else
2944 #ifdef SCM_BIGDIG
2945   if (SCM_NINUMP (x))
2946     {
2947       SCM_GASSERT1 (SCM_BIGP (x),
2948                     g_positive_p, x, SCM_ARG1, s_positive_p);
2949       return SCM_BOOL(SCM_TYP16 (x) == scm_tc16_bigpos);
2950     }
2951 #else
2952   SCM_GASSERT1 (SCM_INUMP (x), g_positive_p, x, SCM_ARG1, s_positive_p);
2953 #endif
2954 #endif
2955   return SCM_BOOL(x > SCM_INUM0);
2956 }
2957
2958
2959
2960 SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p);
2961
2962 SCM
2963 scm_negative_p (SCM x)
2964 {
2965 #ifdef SCM_FLOATS
2966   if (SCM_NINUMP (x))
2967     {
2968 #ifdef SCM_BIGDIG
2969       SCM_ASRTGO (SCM_NIMP (x), badx);
2970       if (SCM_BIGP (x))
2971         return SCM_NEGATE_BOOL(SCM_TYP16 (x) == scm_tc16_bigpos);
2972       if (!(SCM_REALP (x)))
2973         {
2974         badx:
2975           SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);
2976         }
2977 #else
2978       SCM_GASSERT1 (SCM_REALP (x),
2979                     g_negative_p, x, SCM_ARG1, s_negative_p);
2980 #endif
2981       return SCM_BOOL(SCM_REALPART (x) < 0.0);
2982     }
2983 #else
2984 #ifdef SCM_BIGDIG
2985   if (SCM_NINUMP (x))
2986     {
2987       SCM_GASSERT1 (SCM_BIGP (x),
2988                     g_negative_p, x, SCM_ARG1, s_negative_p);
2989       return SCM_BOOL(SCM_TYP16 (x) == scm_tc16_bigneg);
2990     }
2991 #else
2992   SCM_GASSERT1 (SCM_INUMP (x), g_negative_p, x, SCM_ARG1, s_negative_p);
2993 #endif
2994 #endif
2995   return SCM_BOOL(x < SCM_INUM0);
2996 }
2997
2998
2999 SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
3000
3001 SCM
3002 scm_max (SCM x, SCM y)
3003 {
3004 #ifdef SCM_FLOATS
3005   double z;
3006 #endif
3007   if (SCM_UNBNDP (y))
3008     {
3009       SCM_GASSERT0 (!SCM_UNBNDP (x),
3010                     g_max, scm_makfrom0str (s_max), SCM_WNA, 0);
3011       SCM_GASSERT1 (SCM_NUMBERP (x), g_max, x, SCM_ARG1, s_max);
3012       return x;
3013     }
3014 #ifdef SCM_FLOATS
3015   if (SCM_NINUMP (x))
3016     {
3017 #ifdef SCM_BIGDIG
3018       if (!SCM_NIMP (x))
3019         {
3020         badx2:
3021           SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
3022         }
3023       if (SCM_BIGP (x))
3024         {
3025           if (SCM_INUMP (y))
3026             return SCM_BIGSIGN (x) ? y : x;
3027           SCM_ASRTGO (SCM_NIMP (y), bady);
3028           if (SCM_BIGP (y))
3029             return (1 == scm_bigcomp (x, y)) ? y : x;
3030           SCM_ASRTGO (SCM_REALP (y), bady);
3031           z = scm_big2dbl (x);
3032           return (z < SCM_REALPART (y)) ? y : scm_makdbl (z, 0.0);
3033         }
3034       SCM_ASRTGO (SCM_REALP (x), badx2);
3035 #else
3036       SCM_GASSERT2 (SCM_REALP (x),
3037                     g_max, x, y, SCM_ARG1, s_max);
3038 #endif
3039       if (SCM_INUMP (y))
3040         return ((SCM_REALPART (x) < (z = SCM_INUM (y)))
3041                 ? scm_makdbl (z, 0.0)
3042                 : x);
3043 #ifdef SCM_BIGDIG
3044       SCM_ASRTGO (SCM_NIMP (y), bady);
3045       if (SCM_BIGP (y))
3046         return ((SCM_REALPART (x) < (z = scm_big2dbl (y)))
3047                 ? scm_makdbl (z, 0.0)
3048                 : x);
3049       SCM_ASRTGO (SCM_REALP (y), bady);
3050 #else
3051       SCM_ASRTGO (SCM_REALP (y), bady);
3052 #endif
3053       return (SCM_REALPART (x) < SCM_REALPART (y)) ? y : x;
3054     }
3055   if (SCM_NINUMP (y))
3056     {
3057 #ifdef SCM_BIGDIG
3058       SCM_ASRTGO (SCM_NIMP (y), bady);
3059       if (SCM_BIGP (y))
3060         return SCM_BIGSIGN (y) ? x : y;
3061       if (!(SCM_REALP (y)))
3062         {
3063         bady:
3064           SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3065         }
3066 #else
3067       if (!SCM_REALP (y))
3068         {
3069         bady:
3070           SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3071         }
3072 #endif
3073       return (((z = SCM_INUM (x)) < SCM_REALPART (y))
3074               ? y
3075               : scm_makdbl (z, 0.0));
3076     }
3077 #else
3078 #ifdef SCM_BIGDIG
3079   if (SCM_NINUMP (x))
3080     {
3081       SCM_GASSERT2 (SCM_BIGP (x),
3082                     g_max, x, y, SCM_ARG1, s_max);
3083       if (SCM_INUMP (y))
3084         return SCM_BIGSIGN (x) ? y : x;
3085       SCM_ASRTGO (SCM_BIGP (y), bady);
3086       return (1 == scm_bigcomp (x, y)) ? y : x;
3087     }
3088   if (SCM_NINUMP (y))
3089     {
3090       if (!SCM_BIGP (y))
3091         {
3092         bady:
3093           SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3094         }
3095       return SCM_BIGSIGN (y) ? x : y;
3096     }
3097 #else
3098   SCM_GASSERT2 (SCM_INUMP (x), g_max, x, y, SCM_ARG1, s_max);
3099   SCM_GASSERT2 (SCM_INUMP (y), g_max, x, y, SCM_ARGn, s_max);
3100 #endif
3101 #endif
3102   return ((long) x < (long) y) ? y : x;
3103 }
3104
3105
3106
3107
3108 SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
3109
3110 SCM
3111 scm_min (SCM x, SCM y)
3112 {
3113 #ifdef SCM_FLOATS
3114   double z;
3115 #endif
3116   if (SCM_UNBNDP (y))
3117     {
3118       SCM_GASSERT0 (!SCM_UNBNDP (x),
3119                     g_min, scm_makfrom0str (s_min), SCM_WNA, 0);
3120       SCM_GASSERT1 (SCM_NUMBERP (x), g_min, x, SCM_ARG1, s_min);
3121       return x;
3122     }
3123 #ifdef SCM_FLOATS
3124   if (SCM_NINUMP (x))
3125     {
3126 #ifdef SCM_BIGDIG
3127       if (!SCM_NIMP (x))
3128         {
3129         badx2:
3130           SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
3131         }
3132       if (SCM_BIGP (x))
3133         {
3134           if (SCM_INUMP (y))
3135             return SCM_BIGSIGN (x) ? x : y;
3136           SCM_ASRTGO (SCM_NIMP (y), bady);
3137           if (SCM_BIGP (y))
3138             return (-1 == scm_bigcomp (x, y)) ? y : x;
3139           SCM_ASRTGO (SCM_REALP (y), bady);
3140           z = scm_big2dbl (x);
3141           return (z > SCM_REALPART (y)) ? y : scm_makdbl (z, 0.0);
3142         }
3143       SCM_ASRTGO (SCM_REALP (x), badx2);
3144 #else
3145       SCM_GASSERT2 (SCM_REALP (x),
3146                     g_min, x, y, SCM_ARG1, s_min);
3147 #endif
3148       if (SCM_INUMP (y))
3149         return ((SCM_REALPART (x) > (z = SCM_INUM (y)))
3150                 ? scm_makdbl (z, 0.0)
3151                 : x);
3152 #ifdef SCM_BIGDIG
3153       SCM_ASRTGO (SCM_NIMP (y), bady);
3154       if (SCM_BIGP (y))
3155         return ((SCM_REALPART (x) > (z = scm_big2dbl (y)))
3156                 ? scm_makdbl (z, 0.0)
3157                 : x);
3158       SCM_ASRTGO (SCM_REALP (y), bady);
3159 #else
3160       SCM_ASRTGO (SCM_REALP (y), bady);
3161 #endif
3162       return (SCM_REALPART (x) > SCM_REALPART (y)) ? y : x;
3163     }
3164   if (SCM_NINUMP (y))
3165     {
3166 #ifdef SCM_BIGDIG
3167       SCM_ASRTGO (SCM_NIMP (y), bady);
3168       if (SCM_BIGP (y))
3169         return SCM_BIGSIGN (y) ? y : x;
3170       if (!(SCM_REALP (y)))
3171         {
3172         bady:
3173           SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
3174         }
3175 #else
3176       if (!SCM_REALP (y))
3177         {
3178         bady:
3179           SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
3180         }
3181 #endif
3182       return (((z = SCM_INUM (x)) > SCM_REALPART (y))
3183               ? y
3184               : scm_makdbl (z, 0.0));
3185     }
3186 #else
3187 #ifdef SCM_BIGDIG
3188   if (SCM_NINUMP (x))
3189     {
3190       SCM_GASSERT2 (SCM_BIGP (x),
3191                     g_min, x, y, SCM_ARG1, s_min);
3192       if (SCM_INUMP (y))
3193         return SCM_BIGSIGN (x) ? x : y;
3194       SCM_ASRTGO (SCM_BIGP (y), bady);
3195       return (-1 == scm_bigcomp (x, y)) ? y : x;
3196     }
3197   if (SCM_NINUMP (y))
3198     {
3199       if (!SCM_BIGP (y))
3200         {
3201         bady:
3202           SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
3203         }
3204       return SCM_BIGSIGN (y) ? y : x;
3205     }
3206 #else
3207   SCM_GASSERT2 (SCM_INUMP (x), g_min, x, y, SCM_ARG1, s_min);
3208   SCM_GASSERT2 (SCM_INUMP (y), g_min, x, y, SCM_ARGn, s_min);
3209 #endif
3210 #endif
3211   return ((long) x > (long) y) ? y : x;
3212 }
3213
3214
3215
3216
3217 SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
3218
3219 SCM
3220 scm_sum (SCM x, SCM y)
3221 {
3222   if (SCM_UNBNDP (y))
3223     {
3224       if (SCM_UNBNDP (x))
3225         return SCM_INUM0;
3226       SCM_GASSERT1 (SCM_NUMBERP (x), g_sum, x, SCM_ARG1, s_sum);
3227       return x;
3228     }
3229 #ifdef SCM_FLOATS
3230   if (SCM_NINUMP (x))
3231     {
3232       SCM t;
3233 #ifdef SCM_BIGDIG
3234       if (!SCM_NIMP (x))
3235         {
3236         badx2:
3237           SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
3238         }
3239       if (SCM_BIGP (x))
3240         {
3241           if (SCM_INUMP (y))
3242             {
3243               t = x;
3244               x = y;
3245               y = t;
3246               goto intbig;
3247             }
3248           SCM_ASRTGO (SCM_NIMP (y), bady);
3249           if (SCM_BIGP (y))
3250             {
3251               if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y))
3252                 {
3253                   t = x;
3254                   x = y;
3255                   y = t;
3256                 }
3257               return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3258                                  SCM_BIGSIGN (x),
3259                                  y, 0);
3260             }
3261           SCM_ASRTGO (SCM_INEXP (y), bady);
3262         bigreal:
3263           return scm_makdbl (scm_big2dbl (x) + SCM_REALPART (y),
3264                              SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0);
3265         }
3266       SCM_ASRTGO (SCM_INEXP (x), badx2);
3267 #else
3268       SCM_ASRTGO (SCM_INEXP (x), badx2);
3269 #endif
3270       if (SCM_INUMP (y))
3271         {
3272           t = x;
3273           x = y;
3274           y = t;
3275           goto intreal;
3276         }
3277 #ifdef SCM_BIGDIG
3278       SCM_ASRTGO (SCM_NIMP (y), bady);
3279       if (SCM_BIGP (y))
3280         {
3281           t = x;
3282           x = y;
3283           y = t;
3284           goto bigreal;
3285         }
3286       else if (!SCM_INEXP (y))
3287         {
3288         bady:
3289           SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3290         }
3291 #else
3292       if (!SCM_INEXP (y))
3293         {
3294         bady:
3295           SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3296         }
3297 #endif
3298       {
3299         double i = 0.0;
3300         if (SCM_CPLXP (x))
3301           i = SCM_IMAG (x);
3302         if (SCM_CPLXP (y))
3303           i += SCM_IMAG (y);
3304         return scm_makdbl (SCM_REALPART (x) + SCM_REALPART (y), i);
3305       }
3306     }
3307   if (SCM_NINUMP (y))
3308     {
3309 #ifdef SCM_BIGDIG
3310       SCM_ASRTGO (SCM_NIMP (y), bady);
3311       if (SCM_BIGP (y))
3312         {
3313         intbig:
3314           {
3315 #ifndef SCM_DIGSTOOBIG
3316             long z = scm_pseudolong (SCM_INUM (x));
3317             return scm_addbig ((SCM_BIGDIG *) & z,
3318                                SCM_DIGSPERLONG,
3319                                (x < 0) ? 0x0100 : 0,
3320                                y, 0);
3321 #else
3322             SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3323             scm_longdigs (SCM_INUM (x), zdigs);
3324             return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3325                                y, 0);
3326 #endif
3327           }
3328         }
3329       SCM_ASRTGO (SCM_INEXP (y), bady);
3330 #else
3331       SCM_ASRTGO (SCM_INEXP (y), bady);
3332 #endif
3333     intreal:
3334       return scm_makdbl (SCM_INUM (x) + SCM_REALPART (y),
3335                          SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0);
3336     }
3337 #else
3338 #ifdef SCM_BIGDIG
3339   if (SCM_NINUMP (x))
3340     {
3341       SCM t;
3342       SCM_ASRTGO (SCM_BIGP (x), badx2);
3343       if (SCM_INUMP (y))
3344         {
3345           t = x;
3346           x = y;
3347           y = t;
3348           goto intbig;
3349         }
3350       SCM_ASRTGO (SCM_BIGP (y), bady);
3351       if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y))
3352         {
3353           t = x;
3354           x = y;
3355           y = t;
3356         }
3357       return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x),
3358                          y, 0);
3359     }
3360   if (SCM_NINUMP (y))
3361     {
3362       if (!SCM_BIGP (y))
3363         {
3364         bady:
3365           SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3366         }
3367     intbig:
3368       {
3369 #ifndef SCM_DIGSTOOBIG
3370         long z = scm_pseudolong (SCM_INUM (x));
3371         return scm_addbig (&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
3372 #else
3373         SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3374         scm_longdigs (SCM_INUM (x), zdigs);
3375         return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
3376 #endif
3377       }
3378     }
3379 #else
3380   SCM_ASRTGO (SCM_INUMP (x), badx2);
3381   SCM_GASSERT2 (SCM_INUMP (y), g_sum, x, y, SCM_ARGn, s_sum);
3382 #endif
3383 #endif
3384   x = SCM_INUM (x) + SCM_INUM (y);
3385   if (SCM_FIXABLE (x))
3386     return SCM_MAKINUM (x);
3387 #ifdef SCM_BIGDIG
3388   return scm_long2big (x);
3389 #else
3390 #ifdef SCM_FLOATS
3391   return scm_makdbl ((double) x, 0.0);
3392 #else
3393   scm_num_overflow (s_sum);
3394   return SCM_UNSPECIFIED;
3395 #endif
3396 #endif
3397 }
3398
3399
3400
3401
3402 SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
3403
3404 SCM
3405 scm_difference (SCM x, SCM y)
3406 {
3407 #ifdef SCM_FLOATS
3408   if (SCM_NINUMP (x))
3409     {
3410       if (!(SCM_NIMP (x)))
3411         {
3412           if (SCM_UNBNDP (y))
3413             {
3414               SCM_GASSERT0 (!SCM_UNBNDP (x), g_difference,
3415                             scm_makfrom0str (s_difference), SCM_WNA, 0);
3416             badx:
3417               SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
3418             }
3419           else
3420             {
3421             badx2:
3422               SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
3423             }
3424         }
3425       if (SCM_UNBNDP (y))
3426         {
3427 #ifdef SCM_BIGDIG
3428           if (SCM_BIGP (x))
3429             {
3430               x = scm_copybig (x, !SCM_BIGSIGN (x));
3431               return (SCM_NUMDIGS (x) * SCM_BITSPERDIG / SCM_CHAR_BIT
3432                       <= sizeof (SCM)
3433                       ? scm_big2inum (x, SCM_NUMDIGS (x))
3434                       : x);
3435             }
3436 #endif
3437           SCM_ASRTGO (SCM_INEXP (x), badx);
3438           return scm_makdbl (- SCM_REALPART (x),
3439                              SCM_CPLXP (x) ? -SCM_IMAG (x) : 0.0);
3440         }
3441       if (SCM_INUMP (y))
3442         return scm_sum (x, SCM_MAKINUM (- SCM_INUM (y)));
3443 #ifdef SCM_BIGDIG
3444       SCM_ASRTGO (SCM_NIMP (y), bady);
3445       if (SCM_BIGP (x))
3446         {
3447           if (SCM_BIGP (y))
3448             return ((SCM_NUMDIGS (x) < SCM_NUMDIGS (y))
3449                     ? scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3450                                   SCM_BIGSIGN (x),
3451                                   y, 0x0100)
3452                     : scm_addbig (SCM_BDIGITS (y), SCM_NUMDIGS (y),
3453                                   SCM_BIGSIGN (y) ^ 0x0100,
3454                                   x, 0));
3455           SCM_ASRTGO (SCM_INEXP (y), bady);
3456           return scm_makdbl (scm_big2dbl (x) - SCM_REALPART (y),
3457                              SCM_CPLXP (y) ? -SCM_IMAG (y) : 0.0);
3458         }
3459       SCM_ASRTGO (SCM_INEXP (x), badx2);
3460       if (SCM_BIGP (y))
3461         return scm_makdbl (SCM_REALPART (x) - scm_big2dbl (y),
3462                            SCM_CPLXP (x) ? SCM_IMAG (x) : 0.0);
3463       SCM_ASRTGO (SCM_INEXP (y), bady);
3464 #else
3465       SCM_ASRTGO (SCM_INEXP (x), badx2);
3466       SCM_ASRTGO (SCM_INEXP (y), bady);
3467 #endif
3468       if (SCM_CPLXP (x))
3469         {
3470           if (SCM_CPLXP (y))
3471             return scm_makdbl (SCM_REAL (x) - SCM_REAL (y),
3472                                SCM_IMAG (x) - SCM_IMAG (y));
3473           else
3474             return scm_makdbl (SCM_REAL (x) - SCM_REALPART (y), SCM_IMAG (x));
3475         }
3476       return scm_makdbl (SCM_REALPART (x) - SCM_REALPART (y),
3477                          SCM_CPLXP (y) ? - SCM_IMAG (y) : 0.0);
3478     }
3479   if (SCM_UNBNDP (y))
3480     {
3481       x = -SCM_INUM (x);
3482       goto checkx;
3483     }
3484   if (SCM_NINUMP (y))
3485     {
3486 #ifdef SCM_BIGDIG
3487       SCM_ASRTGO (SCM_NIMP (y), bady);
3488       if (SCM_BIGP (y))
3489         {
3490 #ifndef SCM_DIGSTOOBIG
3491           long z = scm_pseudolong (SCM_INUM (x));
3492           return scm_addbig ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
3493                              (x < 0) ? 0x0100 : 0,
3494                              y, 0x0100);
3495 #else
3496           SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3497           scm_longdigs (SCM_INUM (x), zdigs);
3498           return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3499                              y, 0x0100);
3500 #endif
3501         }
3502       if (!SCM_INEXP (y))
3503         {
3504         bady:
3505           SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3506         }
3507 #else
3508       if (!SCM_INEXP (y))
3509         {
3510         bady:
3511           SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3512         }
3513 #endif
3514       return scm_makdbl (SCM_INUM (x) - SCM_REALPART (y),
3515                          SCM_CPLXP (y) ? -SCM_IMAG (y) : 0.0);
3516     }
3517 #else
3518 #ifdef SCM_BIGDIG
3519   if (SCM_NINUMP (x))
3520     {
3521       SCM_GASSERT2 (SCM_BIGP (x),
3522                     g_difference, x, y, SCM_ARG1, s_difference);
3523       if (SCM_UNBNDP (y))
3524         {
3525           x = scm_copybig (x, !SCM_BIGSIGN (x));
3526           return (SCM_NUMDIGS (x) * SCM_BITSPERDIG / SCM_CHAR_BIT
3527                   <= sizeof (SCM)
3528                   ? scm_big2inum (x, SCM_NUMDIGS (x))
3529                   : x);
3530         }
3531       if (SCM_INUMP (y))
3532         {
3533 #ifndef SCM_DIGSTOOBIG
3534           long z = scm_pseudolong (SCM_INUM (y));
3535           return scm_addbig (&z, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
3536 #else
3537           SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3538           scm_longdigs (SCM_INUM (x), zdigs);
3539           return scm_addbig (zdigs, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100,
3540                              x, 0);
3541 #endif
3542         }
3543       SCM_ASRTGO (SCM_BIGP (y), bady);
3544       return (SCM_NUMDIGS (x) < SCM_NUMDIGS (y)) ?
3545         scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x),
3546                     y, 0x0100) :
3547         scm_addbig (SCM_BDIGITS (y), SCM_NUMDIGS (y), SCM_BIGSIGN (y) ^ 0x0100,
3548                     x, 0);
3549     }
3550   if (SCM_UNBNDP (y))
3551     {
3552       x = -SCM_INUM (x);
3553       goto checkx;
3554     }
3555   if (SCM_NINUMP (y))
3556     {
3557       if (!SCM_BIGP (y))
3558         {
3559         bady:
3560           SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3561         }
3562       {
3563 #ifndef SCM_DIGSTOOBIG
3564         long z = scm_pseudolong (SCM_INUM (x));
3565         return scm_addbig (&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3566                            y, 0x0100);
3567 #else
3568         SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3569         scm_longdigs (SCM_INUM (x), zdigs);
3570         return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3571                            y, 0x0100);
3572 #endif
3573       }
3574     }
3575 #else
3576   SCM_GASSERT2 (SCM_INUMP (x), g_difference, x, y, SCM_ARG1, s_difference);
3577   if (SCM_UNBNDP (y))
3578     {
3579       x = -SCM_INUM (x);
3580       goto checkx;
3581     }
3582   SCM_GASSERT2 (SCM_INUMP (y), g_difference, x, y, SCM_ARGn, s_difference);
3583 #endif
3584 #endif
3585   x = SCM_INUM (x) - SCM_INUM (y);
3586  checkx:
3587   if (SCM_FIXABLE (x))
3588     return SCM_MAKINUM (x);
3589 #ifdef SCM_BIGDIG
3590   return scm_long2big (x);
3591 #else
3592 #ifdef SCM_FLOATS
3593   return scm_makdbl ((double) x, 0.0);
3594 #else
3595   scm_num_overflow (s_difference);
3596   return SCM_UNSPECIFIED;
3597 #endif
3598 #endif
3599 }
3600
3601
3602
3603
3604 SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
3605
3606 SCM
3607 scm_product (SCM x, SCM y)
3608 {
3609   if (SCM_UNBNDP (y))
3610     {
3611       if (SCM_UNBNDP (x))
3612         return SCM_MAKINUM (1L);
3613       SCM_GASSERT1 (SCM_NUMBERP (x), g_product, x, SCM_ARG1, s_product);
3614       return x;
3615     }
3616 #ifdef SCM_FLOATS
3617   if (SCM_NINUMP (x))
3618     {
3619       SCM t;
3620 #ifdef SCM_BIGDIG
3621       if (!SCM_NIMP (x))
3622         {
3623         badx2:
3624           SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
3625         }
3626       if (SCM_BIGP (x))
3627         {
3628           if (SCM_INUMP (y))
3629             {
3630               t = x;
3631               x = y;
3632               y = t;
3633               goto intbig;
3634             }
3635           SCM_ASRTGO (SCM_NIMP (y), bady);
3636           if (SCM_BIGP (y))
3637             return scm_mulbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3638                                SCM_BDIGITS (y), SCM_NUMDIGS (y),
3639                                SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y));
3640           SCM_ASRTGO (SCM_INEXP (y), bady);
3641         bigreal:
3642           {
3643             double bg = scm_big2dbl (x);
3644             return scm_makdbl (bg * SCM_REALPART (y),
3645                                SCM_CPLXP (y) ? bg * SCM_IMAG (y) : 0.0);
3646           }
3647         }
3648       SCM_ASRTGO (SCM_INEXP (x), badx2);
3649 #else
3650       SCM_ASRTGO (SCM_INEXP (x), badx2);
3651 #endif
3652       if (SCM_INUMP (y))
3653         {
3654           t = x;
3655           x = y;
3656           y = t;
3657           goto intreal;
3658         }
3659 #ifdef SCM_BIGDIG
3660       SCM_ASRTGO (SCM_NIMP (y), bady);
3661       if (SCM_BIGP (y))
3662         {
3663           t = x;
3664           x = y;
3665           y = t;
3666           goto bigreal;
3667         }
3668       else if (!(SCM_INEXP (y)))
3669         {
3670         bady:
3671           SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3672         }
3673 #else
3674       if (!SCM_INEXP (y))
3675         {
3676         bady:
3677           SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3678         }
3679 #endif
3680       if (SCM_CPLXP (x))
3681         {
3682           if (SCM_CPLXP (y))
3683             return scm_makdbl (SCM_REAL (x) * SCM_REAL (y)
3684                                - SCM_IMAG (x) * SCM_IMAG (y),
3685                                SCM_REAL (x) * SCM_IMAG (y)
3686                                + SCM_IMAG (x) * SCM_REAL (y));
3687           else
3688             return scm_makdbl (SCM_REAL (x) * SCM_REALPART (y),
3689                                SCM_IMAG (x) * SCM_REALPART (y));
3690         }
3691       return scm_makdbl (SCM_REALPART (x) * SCM_REALPART (y),
3692                          SCM_CPLXP (y)
3693                          ? SCM_REALPART (x) * SCM_IMAG (y)
3694                          : 0.0);
3695     }
3696   if (SCM_NINUMP (y))
3697     {
3698 #ifdef SCM_BIGDIG
3699       SCM_ASRTGO (SCM_NIMP (y), bady);
3700       if (SCM_BIGP (y))
3701         {
3702         intbig:
3703           if (SCM_INUM0 == x)
3704             return x;
3705           if (SCM_MAKINUM (1L) == x)
3706             return y;
3707           {
3708 #ifndef SCM_DIGSTOOBIG
3709             long z = scm_pseudolong (SCM_INUM (x));
3710             return scm_mulbig ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
3711                                SCM_BDIGITS (y), SCM_NUMDIGS (y),
3712                                SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3713 #else
3714             SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3715             scm_longdigs (SCM_INUM (x), zdigs);
3716             return scm_mulbig (zdigs, SCM_DIGSPERLONG,
3717                                SCM_BDIGITS (y), SCM_NUMDIGS (y),
3718                                SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3719 #endif
3720           }
3721         }
3722       SCM_ASRTGO (SCM_INEXP (y), bady);
3723 #else
3724       SCM_ASRTGO (SCM_INEXP (y), bady);
3725 #endif
3726     intreal:
3727       return scm_makdbl (SCM_INUM (x) * SCM_REALPART (y),
3728                          SCM_CPLXP (y) ? SCM_INUM (x) * SCM_IMAG (y) : 0.0);
3729     }
3730 #else
3731 #ifdef SCM_BIGDIG
3732   if (SCM_NINUMP (x))
3733     {
3734       SCM_ASRTGO (SCM_BIGP (x), badx2);
3735       if (SCM_INUMP (y))
3736         {
3737           SCM t = x;
3738           x = y;
3739           y = t;
3740           goto intbig;
3741         }
3742       SCM_ASRTGO (SCM_BIGP (y), bady);
3743       return scm_mulbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3744                          SCM_BDIGITS (y), SCM_NUMDIGS (y),
3745                          SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y));
3746     }
3747   if (SCM_NINUMP (y))
3748     {
3749       if (!SCM_BIGP (y))
3750         {
3751         bady:
3752           SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3753         }
3754     intbig:
3755       if (SCM_INUM0 == x)
3756         return x;
3757       if (SCM_MAKINUM (1L) == x)
3758         return y;
3759       {
3760 #ifndef SCM_DIGSTOOBIG
3761         long z = scm_pseudolong (SCM_INUM (x));
3762         return scm_mulbig (&z, SCM_DIGSPERLONG,
3763                            SCM_BDIGITS (y), SCM_NUMDIGS (y),
3764                            SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3765 #else
3766         SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3767         scm_longdigs (SCM_INUM (x), zdigs);
3768         return scm_mulbig (zdigs, SCM_DIGSPERLONG,
3769                            SCM_BDIGITS (y), SCM_NUMDIGS (y),
3770                            SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3771 #endif
3772       }
3773     }
3774 #else
3775   SCM_ASRTGO (SCM_INUMP (x), badx2);
3776   SCM_GASSERT (SCM_INUMP (y), g_product, x, y, SCM_ARGn, s_product);
3777 #endif
3778 #endif
3779   {
3780     long i, j, k;
3781     i = SCM_INUM (x);
3782     if (0 == i)
3783       return x;
3784     j = SCM_INUM (y);
3785     k = i * j;
3786     y = SCM_MAKINUM (k);
3787     if (k != SCM_INUM (y) || k / i != j)
3788 #ifdef SCM_BIGDIG
3789       {
3790         int sgn = (i < 0) ^ (j < 0);
3791 #ifndef SCM_DIGSTOOBIG
3792         i = scm_pseudolong (i);
3793         j = scm_pseudolong (j);
3794         return scm_mulbig ((SCM_BIGDIG *) & i, SCM_DIGSPERLONG,
3795                            (SCM_BIGDIG *) & j, SCM_DIGSPERLONG, sgn);
3796 #else /* SCM_DIGSTOOBIG */
3797         SCM_BIGDIG idigs[SCM_DIGSPERLONG];
3798         SCM_BIGDIG jdigs[SCM_DIGSPERLONG];
3799         scm_longdigs (i, idigs);
3800         scm_longdigs (j, jdigs);
3801         return scm_mulbig (idigs, SCM_DIGSPERLONG,
3802                            jdigs, SCM_DIGSPERLONG,
3803                            sgn);
3804 #endif
3805       }
3806 #else
3807 #ifdef SCM_FLOATS
3808     return scm_makdbl (((double) i) * ((double) j), 0.0);
3809 #else
3810     scm_num_overflow (s_product);
3811 #endif
3812 #endif
3813     return y;
3814   }
3815 }
3816
3817
3818
3819 double
3820 scm_num2dbl (SCM a, const char *why)
3821 {
3822   if (SCM_INUMP (a))
3823     return (double) SCM_INUM (a);
3824 #ifdef SCM_FLOATS
3825   SCM_ASSERT (SCM_NIMP (a), a, "wrong type argument", why);
3826   if (SCM_REALP (a))
3827     return (SCM_REALPART (a));
3828 #endif
3829 #ifdef SCM_BIGDIG
3830   return scm_big2dbl (a);
3831 #endif
3832   SCM_ASSERT (0, a, "wrong type argument", why);
3833   return SCM_UNSPECIFIED;
3834 }
3835
3836
3837 SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
3838
3839 SCM
3840 scm_divide (SCM x, SCM y)
3841 {
3842 #ifdef SCM_FLOATS
3843   double d, r, i, a;
3844   if (SCM_NINUMP (x))
3845     {
3846       if (!(SCM_NIMP (x)))
3847         {
3848           if (SCM_UNBNDP (y))
3849             {
3850               SCM_GASSERT0 (!SCM_UNBNDP (x),
3851                             g_divide, scm_makfrom0str (s_divide), SCM_WNA, 0);
3852             badx:
3853               SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
3854             }
3855           else
3856             {
3857             badx2:
3858               SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
3859             }
3860         }
3861       if (SCM_UNBNDP (y))
3862         {
3863 #ifdef SCM_BIGDIG
3864           if (SCM_BIGP (x))
3865             return scm_makdbl (1.0 / scm_big2dbl (x), 0.0);
3866 #endif
3867           SCM_ASRTGO (SCM_INEXP (x), badx);
3868           if (SCM_REALP (x))
3869             return scm_makdbl (1.0 / SCM_REALPART (x), 0.0);
3870           r = SCM_REAL (x);
3871           i = SCM_IMAG (x);
3872           d = r * r + i * i;
3873           return scm_makdbl (r / d, -i / d);
3874         }
3875 #ifdef SCM_BIGDIG
3876       if (SCM_BIGP (x))
3877         {
3878           SCM z;
3879           if (SCM_INUMP (y))
3880             {
3881               z = SCM_INUM (y);
3882 #ifndef SCM_RECKLESS
3883               if (!z)
3884                 scm_num_overflow (s_divide);
3885 #endif
3886               if (1 == z)
3887                 return x;
3888               if (z < 0)
3889                 z = -z;
3890               if (z < SCM_BIGRAD)
3891                 {
3892                   SCM w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0));
3893                   return (scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w),
3894                                          (SCM_BIGDIG) z)
3895                           ? scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0)
3896                           : scm_normbig (w));
3897                 }
3898 #ifndef SCM_DIGSTOOBIG
3899               z = scm_pseudolong (z);
3900               z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3901                                  (SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
3902                                  SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
3903 #else
3904               {
3905                 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3906                 scm_longdigs (z, zdigs);
3907                 z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3908                                    zdigs, SCM_DIGSPERLONG,
3909                                    SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
3910               }
3911 #endif
3912               return z ? z : scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0);
3913             }
3914           SCM_ASRTGO (SCM_NIMP (y), bady);
3915           if (SCM_BIGP (y))
3916             {
3917               z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3918                                  SCM_BDIGITS (y), SCM_NUMDIGS (y),
3919                                  SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3);
3920               return z ? z : scm_makdbl (scm_big2dbl (x) / scm_big2dbl (y),
3921                                          0.0);
3922             }
3923           SCM_ASRTGO (SCM_INEXP (y), bady);
3924           if (SCM_REALP (y))
3925             return scm_makdbl (scm_big2dbl (x) / SCM_REALPART (y), 0.0);
3926           a = scm_big2dbl (x);
3927           goto complex_div;
3928         }
3929 #endif
3930       SCM_ASRTGO (SCM_INEXP (x), badx2);
3931       if (SCM_INUMP (y))
3932         {
3933           d = SCM_INUM (y);
3934           goto basic_div;
3935         }
3936 #ifdef SCM_BIGDIG
3937       SCM_ASRTGO (SCM_NIMP (y), bady);
3938       if (SCM_BIGP (y))
3939         {
3940           d = scm_big2dbl (y);
3941           goto basic_div;
3942         }
3943       SCM_ASRTGO (SCM_INEXP (y), bady);
3944 #else
3945       SCM_ASRTGO (SCM_INEXP (y), bady);
3946 #endif
3947       if (SCM_REALP (y))
3948         {
3949           d = SCM_REALPART (y);
3950         basic_div:
3951           return scm_makdbl (SCM_REALPART (x) / d,
3952                              SCM_CPLXP (x) ? SCM_IMAG (x) / d : 0.0);
3953         }
3954       a = SCM_REALPART (x);
3955       if (SCM_REALP (x))
3956         goto complex_div;
3957       r = SCM_REAL (y);
3958       i = SCM_IMAG (y);
3959       d = r * r + i * i;
3960       return scm_makdbl ((a * r + SCM_IMAG (x) * i) / d,
3961                          (SCM_IMAG (x) * r - a * i) / d);
3962     }
3963   if (SCM_UNBNDP (y))
3964     {
3965       if ((SCM_MAKINUM (1L) == x) || (SCM_MAKINUM (-1L) == x))
3966         return x;
3967       return scm_makdbl (1.0 / ((double) SCM_INUM (x)), 0.0);
3968     }
3969   if (SCM_NINUMP (y))
3970     {
3971 #ifdef SCM_BIGDIG
3972       SCM_ASRTGO (SCM_NIMP (y), bady);
3973       if (SCM_BIGP (y))
3974         return scm_makdbl (SCM_INUM (x) / scm_big2dbl (y), 0.0);
3975       if (!(SCM_INEXP (y)))
3976         {
3977         bady:
3978           SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
3979         }
3980 #else
3981       if (!SCM_INEXP (y))
3982         {
3983         bady:
3984           SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
3985         }
3986 #endif
3987       if (SCM_REALP (y))
3988         return scm_makdbl (SCM_INUM (x) / SCM_REALPART (y), 0.0);
3989       a = SCM_INUM (x);
3990     complex_div:
3991       r = SCM_REAL (y);
3992       i = SCM_IMAG (y);
3993       d = r * r + i * i;
3994       return scm_makdbl ((a * r) / d, (-a * i) / d);
3995     }
3996 #else
3997 #ifdef SCM_BIGDIG
3998   if (SCM_NINUMP (x))
3999     {
4000       SCM z;
4001       SCM_GASSERT2 (SCM_BIGP (x),
4002                     g_divide, x, y, SCM_ARG1, s_divide);
4003       if (SCM_UNBNDP (y))
4004         goto ov;
4005       if (SCM_INUMP (y))
4006         {
4007           z = SCM_INUM (y);
4008           if (!z)
4009             goto ov;
4010           if (1 == z)
4011             return x;
4012           if (z < 0)
4013             z = -z;
4014           if (z < SCM_BIGRAD)
4015             {
4016               SCM w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0));
4017               if (scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w),
4018                                  (SCM_BIGDIG) z))
4019                 goto ov;
4020               return w;
4021             }
4022 #ifndef SCM_DIGSTOOBIG
4023           z = scm_pseudolong (z);
4024           z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
4025                              &z, SCM_DIGSPERLONG,
4026                              SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
4027 #else
4028           {
4029             SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
4030             scm_longdigs (z, zdigs);
4031             z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
4032                                zdigs, SCM_DIGSPERLONG,
4033                                SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
4034           }
4035 #endif
4036         }
4037       else
4038         {
4039           SCM_ASRTGO (SCM_BIGP (y), bady);
4040           z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
4041                              SCM_BDIGITS (y), SCM_NUMDIGS (y),
4042                              SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3);
4043         }
4044       if (!z)
4045         goto ov;
4046       return z;
4047     }
4048   if (SCM_UNBNDP (y))
4049     {
4050       if ((SCM_MAKINUM (1L) == x) || (SCM_MAKINUM (-1L) == x))
4051         return x;
4052       goto ov;
4053     }
4054   if (SCM_NINUMP (y))
4055     {
4056       if (!SCM_BIGP (y))
4057         {
4058         bady:
4059           SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
4060         }
4061       goto ov;
4062     }
4063 #else
4064   SCM_GASSERT2 (SCM_INUMP (x), g_divide, x, y, SCM_ARG1, s_divide);
4065   if (SCM_UNBNDP (y))
4066     {
4067       if ((SCM_MAKINUM (1L) == x) || (SCM_MAKINUM (-1L) == x))
4068         return x;
4069       goto ov;
4070     }
4071   SCM_GASSERT2 (SCM_INUMP (y), g_divide, x, y, SCM_ARGn, s_divide);
4072 #endif
4073 #endif
4074   {
4075     long z = SCM_INUM (y);
4076     if ((0 == z) || SCM_INUM (x) % z)
4077       goto ov;
4078     z = SCM_INUM (x) / z;
4079     if (SCM_FIXABLE (z))
4080       return SCM_MAKINUM (z);
4081 #ifdef SCM_BIGDIG
4082     return scm_long2big (z);
4083 #endif
4084 #ifdef SCM_FLOATS
4085   ov:
4086     return scm_makdbl (((double) SCM_INUM (x)) / ((double) SCM_INUM (y)), 0.0);
4087 #else
4088   ov:
4089     scm_num_overflow (s_divide);
4090     return SCM_UNSPECIFIED;
4091 #endif
4092   }
4093 }
4094
4095
4096
4097
4098 #ifdef SCM_FLOATS
4099 SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh, g_asinh);
4100
4101 double
4102 scm_asinh (double x)
4103 {
4104   return log (x + sqrt (x * x + 1));
4105 }
4106
4107
4108
4109
4110 SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh, g_acosh);
4111
4112 double
4113 scm_acosh (double x)
4114 {
4115   return log (x + sqrt (x * x - 1));
4116 }
4117
4118
4119
4120
4121 SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh, g_atanh);
4122
4123 double
4124 scm_atanh (double x)
4125 {
4126   return 0.5 * log ((1 + x) / (1 - x));
4127 }
4128
4129
4130
4131
4132 SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate, g_truncate);
4133
4134 double
4135 scm_truncate (double x)
4136 {
4137   if (x < 0.0)
4138     return -floor (-x);
4139   return floor (x);
4140 }
4141
4142
4143
4144 SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round, g_round);
4145
4146 double
4147 scm_round (double x)
4148 {
4149   double plus_half = x + 0.5;
4150   double result = floor (plus_half);
4151   /* Adjust so that the scm_round is towards even.  */
4152   return (plus_half == result && plus_half / 2 != floor (plus_half / 2))
4153     ? result - 1 : result;
4154 }
4155
4156
4157
4158 SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact, g_exact_to_inexact);
4159
4160 double
4161 scm_exact_to_inexact (double z)
4162 {
4163   return z;
4164 }
4165
4166
4167 SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor);
4168 SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil);
4169 SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt);
4170 SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs, g_i_abs);
4171 SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp);
4172 SCM_GPROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log, g_i_log);
4173 SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin, g_i_sin);
4174 SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos, g_i_cos);
4175 SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan, g_i_tan);
4176 SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin, g_i_asin);
4177 SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos, g_i_acos);
4178 SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan, g_i_atan);
4179 SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh, g_i_sinh);
4180 SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh, g_i_cosh);
4181 SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh, g_i_tanh);
4182
4183 struct dpair
4184 {
4185   double x, y;
4186 };
4187
4188 static void scm_two_doubles (SCM z1,
4189                              SCM z2,
4190                              const char *sstring,
4191                              struct dpair * xy);
4192
4193 static void
4194 scm_two_doubles (SCM z1, SCM z2, const char *sstring, struct dpair *xy)
4195 {
4196   if (SCM_INUMP (z1))
4197     xy->x = SCM_INUM (z1);
4198   else
4199     {
4200 #ifdef SCM_BIGDIG
4201       SCM_ASRTGO (SCM_NIMP (z1), badz1);
4202       if (SCM_BIGP (z1))
4203         xy->x = scm_big2dbl (z1);
4204       else
4205         {
4206 #ifndef SCM_RECKLESS
4207           if (!SCM_REALP (z1))
4208             badz1:scm_wta (z1, (char *) SCM_ARG1, sstring);
4209 #endif
4210           xy->x = SCM_REALPART (z1);
4211         }
4212 #else
4213       {
4214         SCM_ASSERT (SCM_REALP (z1), z1, SCM_ARG1, sstring);
4215         xy->x = SCM_REALPART (z1);
4216       }
4217 #endif
4218     }
4219   if (SCM_INUMP (z2))
4220     xy->y = SCM_INUM (z2);
4221   else
4222     {
4223 #ifdef SCM_BIGDIG
4224       SCM_ASRTGO (SCM_NIMP (z2), badz2);
4225       if (SCM_BIGP (z2))
4226         xy->y = scm_big2dbl (z2);
4227       else
4228         {
4229 #ifndef SCM_RECKLESS
4230           if (!(SCM_REALP (z2)))
4231             badz2:scm_wta (z2, (char *) SCM_ARG2, sstring);
4232 #endif
4233           xy->y = SCM_REALPART (z2);
4234         }
4235 #else
4236       {
4237         SCM_ASSERT (SCM_REALP (z2), z2, SCM_ARG2, sstring);
4238         xy->y = SCM_REALPART (z2);
4239       }
4240 #endif
4241     }
4242 }
4243
4244
4245
4246
4247 SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0,
4248             (SCM z1, SCM z2),
4249 "")
4250 #define FUNC_NAME s_scm_sys_expt
4251 {
4252   struct dpair xy;
4253   scm_two_doubles (z1, z2, FUNC_NAME, &xy);
4254   return scm_makdbl (pow (xy.x, xy.y), 0.0);
4255 }
4256 #undef FUNC_NAME
4257
4258
4259
4260 SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0,
4261             (SCM z1, SCM z2),
4262 "")
4263 #define FUNC_NAME s_scm_sys_atan2
4264 {
4265   struct dpair xy;
4266   scm_two_doubles (z1, z2, FUNC_NAME, &xy);
4267   return scm_makdbl (atan2 (xy.x, xy.y), 0.0);
4268 }
4269 #undef FUNC_NAME
4270
4271
4272
4273 SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
4274             (SCM z1, SCM z2),
4275 "")
4276 #define FUNC_NAME s_scm_make_rectangular
4277 {
4278   struct dpair xy;
4279   scm_two_doubles (z1, z2, FUNC_NAME, &xy);
4280   return scm_makdbl (xy.x, xy.y);
4281 }
4282 #undef FUNC_NAME
4283
4284
4285
4286 SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0,
4287             (SCM z1, SCM z2),
4288 "")
4289 #define FUNC_NAME s_scm_make_polar
4290 {
4291   struct dpair xy;
4292   scm_two_doubles (z1, z2, FUNC_NAME, &xy);
4293   return scm_makdbl (xy.x * cos (xy.y), xy.x * sin (xy.y));
4294 }
4295 #undef FUNC_NAME
4296
4297
4298
4299
4300 SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part);
4301
4302 SCM
4303 scm_real_part (SCM z)
4304 {
4305   if (SCM_NINUMP (z))
4306     {
4307 #ifdef SCM_BIGDIG
4308       SCM_ASRTGO (SCM_NIMP (z), badz);
4309       if (SCM_BIGP (z))
4310         return z;
4311       if (!(SCM_INEXP (z)))
4312         {
4313         badz:
4314           SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);
4315         }
4316 #else
4317       SCM_GASSERT1 (SCM_INEXP (z),
4318                     g_real_part, z, SCM_ARG1, s_real_part);
4319 #endif
4320       if (SCM_CPLXP (z))
4321         return scm_makdbl (SCM_REAL (z), 0.0);
4322     }
4323   return z;
4324 }
4325
4326
4327
4328 SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part);
4329
4330 SCM
4331 scm_imag_part (SCM z)
4332 {
4333   if (SCM_INUMP (z))
4334     return SCM_INUM0;
4335 #ifdef SCM_BIGDIG
4336   SCM_ASRTGO (SCM_NIMP (z), badz);
4337   if (SCM_BIGP (z))
4338     return SCM_INUM0;
4339   if (!(SCM_INEXP (z)))
4340     {
4341     badz:
4342       SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);
4343     }
4344 #else
4345   SCM_GASSERT1 (SCM_INEXP (z),
4346                 g_imag_part, z, SCM_ARG1, s_imag_part);
4347 #endif
4348   if (SCM_CPLXP (z))
4349     return scm_makdbl (SCM_IMAG (z), 0.0);
4350   return scm_flo0;
4351 }
4352
4353
4354
4355 SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude);
4356
4357 SCM
4358 scm_magnitude (SCM z)
4359 {
4360   if (SCM_INUMP (z))
4361     return scm_abs (z);
4362 #ifdef SCM_BIGDIG
4363   SCM_ASRTGO (SCM_NIMP (z), badz);
4364   if (SCM_BIGP (z))
4365     return scm_abs (z);
4366   if (!(SCM_INEXP (z)))
4367     {
4368     badz:
4369       SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
4370     }
4371 #else
4372   SCM_GASSERT1 (SCM_INEXP (z),
4373                 g_magnitude, z, SCM_ARG1, s_magnitude);
4374 #endif
4375   if (SCM_CPLXP (z))
4376     {
4377       double i = SCM_IMAG (z), r = SCM_REAL (z);
4378       return scm_makdbl (sqrt (i * i + r * r), 0.0);
4379     }
4380   return scm_makdbl (fabs (SCM_REALPART (z)), 0.0);
4381 }
4382
4383
4384
4385
4386 SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle);
4387
4388 SCM
4389 scm_angle (SCM z)
4390 {
4391   double x, y = 0.0;
4392   if (SCM_INUMP (z))
4393     {
4394       x = (z >= SCM_INUM0) ? 1.0 : -1.0;
4395       goto do_angle;
4396     }
4397 #ifdef SCM_BIGDIG
4398   SCM_ASRTGO (SCM_NIMP (z), badz);
4399   if (SCM_BIGP (z))
4400     {
4401       x = (SCM_TYP16 (z) == scm_tc16_bigpos) ? 1.0 : -1.0;
4402       goto do_angle;
4403     }
4404   if (!(SCM_INEXP (z)))
4405     {
4406     badz:
4407       SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
4408     }
4409 #else
4410   SCM_GASSERT1 (SCM_INEXP (z), g_angle, z, SCM_ARG1, s_angle);
4411 #endif
4412   if (SCM_REALP (z))
4413     {
4414       x = SCM_REALPART (z);
4415       goto do_angle;
4416     }
4417   x = SCM_REAL (z);
4418   y = SCM_IMAG (z);
4419  do_angle:
4420   return scm_makdbl (atan2 (y, x), 0.0);
4421 }
4422
4423
4424 SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
4425             (SCM z),
4426 "")
4427 #define FUNC_NAME s_scm_inexact_to_exact
4428 {
4429   if (SCM_INUMP (z))
4430     return z;
4431 #ifdef SCM_BIGDIG
4432   SCM_ASRTGO (SCM_NIMP (z), badz);
4433   if (SCM_BIGP (z))
4434     return z;
4435 #ifndef SCM_RECKLESS
4436   if (!(SCM_REALP (z)))
4437     {
4438     badz:
4439       SCM_WTA (1, z);
4440     }
4441 #endif
4442 #else
4443   SCM_VALIDATE_REAL(1,z);
4444 #endif
4445 #ifdef SCM_BIGDIG
4446   {
4447     double u = floor (SCM_REALPART (z) + 0.5);
4448     if ((u <= SCM_MOST_POSITIVE_FIXNUM) && (-u <= -SCM_MOST_NEGATIVE_FIXNUM))
4449       {
4450         /* Negation is a workaround for HP700 cc bug */
4451         SCM ans = SCM_MAKINUM ((long) u);
4452         if (SCM_INUM (ans) == (long) u)
4453           return ans;
4454       }
4455     SCM_ASRTGO (isfinite (u), badz);    /* problem? */
4456     return scm_dbl2big (u);
4457   }
4458 #else
4459   return SCM_MAKINUM ((long) floor (SCM_REALPART (z) + 0.5));
4460 #endif
4461 }
4462 #undef FUNC_NAME
4463
4464
4465
4466 #else /* ~SCM_FLOATS */
4467 SCM_GPROC (s_trunc, "truncate", 1, 0, 0, scm_trunc, g_trunc);
4468
4469 SCM
4470 scm_trunc (SCM x)
4471 {
4472   SCM_GASSERT2 (SCM_INUMP (x), g_trunc, x, y, SCM_ARG1, s_truncate);
4473   return x;
4474 }
4475
4476
4477
4478 #endif /* SCM_FLOATS */
4479
4480 #ifdef SCM_BIGDIG
4481 #ifdef SCM_FLOATS
4482 /* d must be integer */
4483
4484 SCM
4485 scm_dbl2big (double d)
4486 {
4487   scm_sizet i = 0;
4488   long c;
4489   SCM_BIGDIG *digits;
4490   SCM ans;
4491   double u = (d < 0) ? -d : d;
4492   while (0 != floor (u))
4493     {
4494       u /= SCM_BIGRAD;
4495       i++;
4496     }
4497   ans = scm_mkbig (i, d < 0);
4498   digits = SCM_BDIGITS (ans);
4499   while (i--)
4500     {
4501       u *= SCM_BIGRAD;
4502       c = floor (u);
4503       u -= c;
4504       digits[i] = c;
4505     }
4506 #ifndef SCM_RECKLESS
4507   if (u != 0)
4508     scm_num_overflow ("dbl2big");
4509 #endif
4510   return ans;
4511 }
4512
4513
4514
4515 double
4516 scm_big2dbl (SCM b)
4517 {
4518   double ans = 0.0;
4519   scm_sizet i = SCM_NUMDIGS (b);
4520   SCM_BIGDIG *digits = SCM_BDIGITS (b);
4521   while (i--)
4522     ans = digits[i] + SCM_BIGRAD * ans;
4523   if (scm_tc16_bigneg == SCM_TYP16 (b))
4524     return -ans;
4525   return ans;
4526 }
4527 #endif
4528 #endif
4529
4530
4531 SCM
4532 scm_long2num (long sl)
4533 {
4534   if (!SCM_FIXABLE (sl))
4535     {
4536 #ifdef SCM_BIGDIG
4537       return scm_long2big (sl);
4538 #else
4539 #ifdef SCM_FLOATS
4540       return scm_makdbl ((double) sl, 0.0);
4541 #else
4542       return SCM_BOOL_F;
4543 #endif
4544 #endif
4545     }
4546   return SCM_MAKINUM (sl);
4547 }
4548
4549
4550 #ifdef HAVE_LONG_LONGS
4551
4552 SCM
4553 scm_long_long2num (long_long sl)
4554 {
4555   if (!SCM_FIXABLE (sl))
4556     {
4557 #ifdef SCM_BIGDIG
4558       return scm_long_long2big (sl);
4559 #else
4560 #ifdef SCM_FLOATS
4561       return scm_makdbl ((double) sl, 0.0);
4562 #else
4563       return SCM_BOOL_F;
4564 #endif
4565 #endif
4566     }
4567   return SCM_MAKINUM (sl);
4568 }
4569 #endif
4570
4571
4572
4573 SCM
4574 scm_ulong2num (unsigned long sl)
4575 {
4576   if (!SCM_POSFIXABLE (sl))
4577     {
4578 #ifdef SCM_BIGDIG
4579       return scm_ulong2big (sl);
4580 #else
4581 #ifdef SCM_FLOATS
4582       return scm_makdbl ((double) sl, 0.0);
4583 #else
4584       return SCM_BOOL_F;
4585 #endif
4586 #endif
4587     }
4588   return SCM_MAKINUM (sl);
4589 }
4590
4591
4592 long
4593 scm_num2long (SCM num, char *pos, const char *s_caller)
4594 {
4595   long res;
4596
4597   if (SCM_INUMP (num))
4598     {
4599       res = SCM_INUM (num);
4600       return res;
4601     }
4602   SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg);
4603 #ifdef SCM_FLOATS
4604   if (SCM_REALP (num))
4605     {
4606       volatile double u = SCM_REALPART (num);
4607
4608       res = u;
4609       if (res != u)
4610         goto out_of_range;
4611       return res;
4612     }
4613 #endif
4614 #ifdef SCM_BIGDIG
4615   if (SCM_BIGP (num))
4616     {
4617       unsigned long oldres = 0;
4618       scm_sizet l;
4619       /* can't use res directly in case num is -2^31.  */
4620       unsigned long pos_res = 0;
4621
4622       for (l = SCM_NUMDIGS (num); l--;)
4623         {
4624           pos_res = SCM_BIGUP (pos_res) + SCM_BDIGITS (num)[l];
4625           /* check for overflow.  */
4626           if (pos_res < oldres)
4627             goto out_of_range;
4628           oldres = pos_res;
4629         }
4630       if (SCM_TYP16 (num) == scm_tc16_bigpos)
4631         {
4632           res = pos_res;
4633           if (res < 0)
4634             goto out_of_range;
4635         }
4636       else
4637         {
4638           res = -pos_res;
4639           if (res > 0)
4640             goto out_of_range;
4641         }
4642       return res;
4643     }
4644 #endif
4645  wrong_type_arg:
4646   scm_wrong_type_arg (s_caller, (int) pos, num);
4647  out_of_range:
4648   scm_out_of_range (s_caller, num);
4649 }
4650
4651
4652
4653 #ifdef HAVE_LONG_LONGS
4654
4655 long_long
4656 scm_num2long_long (SCM num, char *pos, const char *s_caller)
4657 {
4658   long_long res;
4659
4660   if (SCM_INUMP (num))
4661     {
4662       res = SCM_INUM (num);
4663       return res;
4664     }
4665   SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg);
4666 #ifdef SCM_FLOATS
4667   if (SCM_REALP (num))
4668     {
4669       double u = SCM_REALPART (num);
4670
4671       res = u;
4672       if ((res < 0 && u > 0) || (res > 0 && u < 0)) /* check for overflow. */
4673         goto out_of_range;
4674
4675       return res;
4676     }
4677 #endif
4678 #ifdef SCM_BIGDIG
4679   if (SCM_BIGP (num))
4680     {
4681       unsigned long long oldres = 0;
4682       scm_sizet l;
4683       /* can't use res directly in case num is -2^63.  */
4684       unsigned long long pos_res = 0;
4685
4686       for (l = SCM_NUMDIGS (num); l--;)
4687         {
4688           pos_res = SCM_LONGLONGBIGUP (pos_res) + SCM_BDIGITS (num)[l];
4689           /* check for overflow.  */
4690           if (pos_res < oldres)
4691             goto out_of_range;
4692           oldres = pos_res;
4693         }
4694       if (SCM_TYP16 (num) == scm_tc16_bigpos)
4695         {
4696           res = pos_res;
4697           if (res < 0)
4698             goto out_of_range;
4699         }
4700       else
4701         {
4702           res = -pos_res;
4703           if (res > 0)
4704             goto out_of_range;
4705         }
4706       return res;
4707     }
4708 #endif
4709  wrong_type_arg:
4710   scm_wrong_type_arg (s_caller, (int) pos, num);
4711  out_of_range:
4712   scm_out_of_range (s_caller, num);
4713 }
4714 #endif
4715
4716
4717
4718 unsigned long
4719 scm_num2ulong (SCM num, char *pos, const char *s_caller)
4720 {
4721   unsigned long res;
4722
4723   if (SCM_INUMP (num))
4724     {
4725       if (SCM_INUM (num) < 0)
4726         goto out_of_range;
4727       res = SCM_INUM (num);
4728       return res;
4729     }
4730   SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg);
4731 #ifdef SCM_FLOATS
4732   if (SCM_REALP (num))
4733     {
4734       double u = SCM_REALPART (num);
4735
4736       res = u;
4737       if (res != u)
4738         goto out_of_range;
4739       return res;
4740     }
4741 #endif
4742 #ifdef SCM_BIGDIG
4743   if (SCM_BIGP (num))
4744     {
4745       unsigned long oldres = 0;
4746       scm_sizet l;
4747
4748       res = 0;
4749       for (l = SCM_NUMDIGS (num); l--;)
4750         {
4751           res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l];
4752           if (res < oldres)
4753             goto out_of_range;
4754           oldres = res;
4755         }
4756       return res;
4757     }
4758 #endif
4759  wrong_type_arg:
4760   scm_wrong_type_arg (s_caller, (int) pos, num);
4761  out_of_range:
4762   scm_out_of_range (s_caller, num);
4763 }
4764
4765
4766 #ifdef SCM_FLOATS
4767 #ifndef DBL_DIG
4768 static void
4769 add1 (double f, double *fsum)
4770 {
4771   *fsum = f + 1.0;
4772 }
4773 #endif
4774 #endif
4775
4776
4777
4778 void
4779 scm_init_numbers ()
4780 {
4781   scm_add_feature("complex");
4782 #ifdef SCM_FLOATS
4783   scm_add_feature("inexact");
4784 #ifdef SCM_SINGLES
4785   SCM_NEWSMOB(scm_flo0,scm_tc_flo,NULL);
4786 #else
4787   SCM_NEWSMOB(scm_flo0,scm_tc_dblr,scm_must_malloc (1L * sizeof (double), "real"));
4788   SCM_REAL (scm_flo0) = 0.0;
4789 #endif
4790 #ifdef DBL_DIG
4791   scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
4792 #else
4793   {                             /* determine floating point precision */
4794     double f = 0.1;
4795     double fsum = 1.0 + f;
4796     while (fsum != 1.0)
4797       {
4798         f /= 10.0;
4799         if (++scm_dblprec > 20)
4800           break;
4801         add1 (f, &fsum);
4802       }
4803     scm_dblprec = scm_dblprec - 1;
4804   }
4805 #endif /* DBL_DIG */
4806 #endif
4807 #include "numbers.x"
4808 }