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