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     {
2454       SCM_ASSERT (SCM_INUMP (radix), radix, SCM_ARG2, s_string_to_number);
2455       SCM_ASSERT (SCM_INUM (radix) >= 2, radix, SCM_OUTOFRANGE,
2456                   s_number_to_string);
2457     }
2458   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str),
2459               str, SCM_ARG1, s_string_to_number);
2460   answer = scm_istring2number (SCM_ROCHARS (str),
2461                                SCM_ROLENGTH (str),
2462                                SCM_INUM (radix));
2463   return scm_return_first (answer, str);
2464 }
2465 /*** END strs->nums ***/
2466
2467 #ifdef SCM_FLOATS
2468
2469 SCM
2470 scm_makdbl (x, y)
2471      double x;
2472      double y;
2473 {
2474   SCM z;
2475   if ((y == 0.0) && (x == 0.0))
2476     return scm_flo0;
2477   SCM_DEFER_INTS;
2478   if (y == 0.0)
2479     {
2480 #ifdef SCM_SINGLES
2481       float fx = x;
2482 #ifndef SCM_SINGLESONLY
2483       if ((-FLTMAX < x) && (x < FLTMAX) && (fx == x))
2484 #endif
2485         {
2486           SCM_NEWSMOB(z,scm_tc_flo,NULL);
2487           SCM_FLO (z) = x;
2488           SCM_ALLOW_INTS;
2489           return z;
2490         }
2491 #endif /* def SCM_SINGLES */
2492       SCM_NEWSMOB(z,scm_tc_dblr,scm_must_malloc (1L * sizeof (double), "real"));
2493     }
2494   else
2495     {
2496       SCM_NEWSMOB(z,scm_tc_dblc,scm_must_malloc (2L * sizeof (double), "comkplex"));
2497       SCM_IMAG (z) = y;
2498     }
2499   SCM_REAL (z) = x;
2500   SCM_ALLOW_INTS;
2501   return z;
2502 }
2503 #endif
2504
2505
2506
2507 SCM
2508 scm_bigequal (x, y)
2509      SCM x;
2510      SCM y;
2511 {
2512 #ifdef SCM_BIGDIG
2513   if (0 == scm_bigcomp (x, y))
2514     return SCM_BOOL_T;
2515 #endif
2516   return SCM_BOOL_F;
2517 }
2518
2519
2520
2521 SCM
2522 scm_floequal (x, y)
2523      SCM x;
2524      SCM y;
2525 {
2526 #ifdef SCM_FLOATS
2527   if (SCM_REALPART (x) != SCM_REALPART (y))
2528     return SCM_BOOL_F;
2529   if (!(SCM_CPLXP (x) && (SCM_IMAG (x) != SCM_IMAG (y))))
2530     return SCM_BOOL_T;
2531 #endif
2532   return SCM_BOOL_F;
2533 }
2534
2535
2536
2537
2538 SCM_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p);
2539 SCM_PROC (s_complex_p, "complex?", 1, 0, 0, scm_number_p);
2540
2541 SCM
2542 scm_number_p (x)
2543      SCM x;
2544 {
2545   if (SCM_INUMP (x))
2546     return SCM_BOOL_T;
2547 #ifdef SCM_FLOATS
2548   if (SCM_NIMP (x) && SCM_NUMP (x))
2549     return SCM_BOOL_T;
2550 #else
2551 #ifdef SCM_BIGDIG
2552   if (SCM_NIMP (x) && SCM_NUMP (x))
2553     return SCM_BOOL_T;
2554 #endif
2555 #endif
2556   return SCM_BOOL_F;
2557 }
2558
2559
2560
2561 #ifdef SCM_FLOATS
2562 SCM_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p);
2563 SCM_PROC (s_rational_p, "rational?", 1, 0, 0, scm_real_p);
2564
2565 SCM
2566 scm_real_p (x)
2567      SCM x;
2568 {
2569   if (SCM_INUMP (x))
2570     return SCM_BOOL_T;
2571   if (SCM_IMP (x))
2572     return SCM_BOOL_F;
2573   if (SCM_REALP (x))
2574     return SCM_BOOL_T;
2575 #ifdef SCM_BIGDIG
2576   if (SCM_BIGP (x))
2577     return SCM_BOOL_T;
2578 #endif
2579   return SCM_BOOL_F;
2580 }
2581
2582
2583
2584 SCM_PROC (s_int_p, "integer?", 1, 0, 0, scm_integer_p);
2585
2586 SCM
2587 scm_integer_p (x)
2588      SCM x;
2589 {
2590   double r;
2591   if (SCM_INUMP (x))
2592     return SCM_BOOL_T;
2593   if (SCM_IMP (x))
2594     return SCM_BOOL_F;
2595 #ifdef SCM_BIGDIG
2596   if (SCM_BIGP (x))
2597     return SCM_BOOL_T;
2598 #endif
2599   if (!SCM_INEXP (x))
2600     return SCM_BOOL_F;
2601   if (SCM_CPLXP (x))
2602     return SCM_BOOL_F;
2603   r = SCM_REALPART (x);
2604   if (r == floor (r))
2605     return SCM_BOOL_T;
2606   return SCM_BOOL_F;
2607 }
2608
2609
2610
2611 #endif /* SCM_FLOATS */
2612
2613 SCM_PROC (s_inexact_p, "inexact?", 1, 0, 0, scm_inexact_p);
2614
2615 SCM
2616 scm_inexact_p (x)
2617      SCM x;
2618 {
2619 #ifdef SCM_FLOATS
2620   if (SCM_NIMP (x) && SCM_INEXP (x))
2621     return SCM_BOOL_T;
2622 #endif
2623   return SCM_BOOL_F;
2624 }
2625
2626
2627
2628
2629 SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
2630
2631 SCM
2632 scm_num_eq_p (x, y)
2633      SCM x;
2634      SCM y;
2635 {
2636 #ifdef SCM_FLOATS
2637   SCM t;
2638   if (SCM_NINUMP (x))
2639     {
2640 #ifdef SCM_BIGDIG
2641       if (!(SCM_NIMP (x)))
2642         {
2643         badx:
2644           SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
2645         }
2646       if (SCM_BIGP (x))
2647         {
2648           if (SCM_INUMP (y))
2649             return SCM_BOOL_F;
2650           SCM_ASRTGO (SCM_NIMP (y), bady);
2651           if (SCM_BIGP (y))
2652             return (0 == scm_bigcomp (x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
2653           SCM_ASRTGO (SCM_INEXP (y), bady);
2654         bigreal:
2655           return ((SCM_REALP (y) && (scm_big2dbl (x) == SCM_REALPART (y)))
2656                   ? SCM_BOOL_T
2657                   : SCM_BOOL_F);
2658         }
2659       SCM_ASRTGO (SCM_INEXP (x), badx);
2660 #else
2661       SCM_GASSERT2 (SCM_NIMP (x) && SCM_INEXP (x),
2662                     g_eq_p, x, y, SCM_ARG1, s_eq_p);
2663 #endif
2664       if (SCM_INUMP (y))
2665         {
2666           t = x;
2667           x = y;
2668           y = t;
2669           goto realint;
2670         }
2671 #ifdef SCM_BIGDIG
2672       SCM_ASRTGO (SCM_NIMP (y), bady);
2673       if (SCM_BIGP (y))
2674         {
2675           t = x;
2676           x = y;
2677           y = t;
2678           goto bigreal;
2679         }
2680       SCM_ASRTGO (SCM_INEXP (y), bady);
2681 #else
2682       SCM_ASRTGO (SCM_NIMP (y) && SCM_INEXP (y), bady);
2683 #endif
2684       if (SCM_REALPART (x) != SCM_REALPART (y))
2685         return SCM_BOOL_F;
2686       if (SCM_CPLXP (x))
2687         return ((SCM_CPLXP (y) && (SCM_IMAG (x) == SCM_IMAG (y)))
2688                 ? SCM_BOOL_T
2689                 : SCM_BOOL_F);
2690       return SCM_CPLXP (y) ? SCM_BOOL_F : SCM_BOOL_T;
2691     }
2692   if (SCM_NINUMP (y))
2693     {
2694 #ifdef SCM_BIGDIG
2695       SCM_ASRTGO (SCM_NIMP (y), bady);
2696       if (SCM_BIGP (y))
2697         return SCM_BOOL_F;
2698       if (!(SCM_INEXP (y)))
2699         {
2700         bady:
2701           SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
2702         }
2703 #else
2704       if (!(SCM_NIMP (y) && SCM_INEXP (y)))
2705         {
2706         bady:
2707           SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
2708         }
2709 #endif
2710     realint:
2711       return ((SCM_REALP (y) && (((double) SCM_INUM (x)) == SCM_REALPART (y)))
2712               ? SCM_BOOL_T
2713               : SCM_BOOL_F);
2714     }
2715 #else
2716 #ifdef SCM_BIGDIG
2717   if (SCM_NINUMP (x))
2718     {
2719       SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
2720                     g_eq_p, x, y, SCM_ARG1, s_eq_p);
2721       if (SCM_INUMP (y))
2722         return SCM_BOOL_F;
2723       SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
2724       return (0 == scm_bigcomp (x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
2725     }
2726   if (SCM_NINUMP (y))
2727     {
2728       if (!(SCM_NIMP (y) && SCM_BIGP (y)))
2729         {
2730         bady:
2731           SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
2732         }
2733       return SCM_BOOL_F;
2734     }
2735 #else
2736   SCM_GASSERT2 (SCM_INUMP (x), g_eq_p, x, y, SCM_ARG1, s_eq_p);
2737   SCM_GASSERT2 (SCM_INUMP (y), g_eq_p, x, y, SCM_ARGn, s_eq_p);
2738 #endif
2739 #endif
2740   return ((long) x == (long) y) ? SCM_BOOL_T : SCM_BOOL_F;
2741 }
2742
2743
2744
2745 SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
2746
2747 SCM
2748 scm_less_p (x, y)
2749      SCM x;
2750      SCM y;
2751 {
2752 #ifdef SCM_FLOATS
2753   if (SCM_NINUMP (x))
2754     {
2755 #ifdef SCM_BIGDIG
2756       if (!(SCM_NIMP (x)))
2757         {
2758         badx:
2759           SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
2760         }
2761       if (SCM_BIGP (x))
2762         {
2763           if (SCM_INUMP (y))
2764             return SCM_BIGSIGN (x) ? SCM_BOOL_T : SCM_BOOL_F;
2765           SCM_ASRTGO (SCM_NIMP (y), bady);
2766           if (SCM_BIGP (y))
2767             return (1 == scm_bigcomp (x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
2768           SCM_ASRTGO (SCM_REALP (y), bady);
2769           return ((scm_big2dbl (x) < SCM_REALPART (y))
2770                   ? SCM_BOOL_T
2771                   : SCM_BOOL_F);
2772         }
2773       SCM_ASRTGO (SCM_REALP (x), badx);
2774 #else
2775       SCM_GASSERT2 (SCM_NIMP (x) && SCM_REALP (x),
2776                     g_less_p, x, y, SCM_ARG1, s_less_p);
2777 #endif
2778       if (SCM_INUMP (y))
2779         return ((SCM_REALPART (x) < ((double) SCM_INUM (y)))
2780                 ? SCM_BOOL_T
2781                 : SCM_BOOL_F);
2782 #ifdef SCM_BIGDIG
2783       SCM_ASRTGO (SCM_NIMP (y), bady);
2784       if (SCM_BIGP (y))
2785         return (SCM_REALPART (x) < scm_big2dbl (y)) ? SCM_BOOL_T : SCM_BOOL_F;
2786       SCM_ASRTGO (SCM_REALP (y), bady);
2787 #else
2788       SCM_ASRTGO (SCM_NIMP (y) && SCM_REALP (y), bady);
2789 #endif
2790       return (SCM_REALPART (x) < SCM_REALPART (y)) ? SCM_BOOL_T : SCM_BOOL_F;
2791     }
2792   if (SCM_NINUMP (y))
2793     {
2794 #ifdef SCM_BIGDIG
2795       SCM_ASRTGO (SCM_NIMP (y), bady);
2796       if (SCM_BIGP (y))
2797         return SCM_BIGSIGN (y) ? SCM_BOOL_F : SCM_BOOL_T;
2798       if (!(SCM_REALP (y)))
2799         {
2800         bady:
2801           SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
2802         }
2803 #else
2804       if (!(SCM_NIMP (y) && SCM_REALP (y)))
2805         {
2806         bady:
2807           SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
2808         }
2809 #endif
2810       return ((((double) SCM_INUM (x)) < SCM_REALPART (y))
2811               ? SCM_BOOL_T
2812               : SCM_BOOL_F);
2813     }
2814 #else
2815 #ifdef SCM_BIGDIG
2816   if (SCM_NINUMP (x))
2817     {
2818       SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
2819                     g_less_p, x, y, SCM_ARG1, s_less_p);
2820       if (SCM_INUMP (y))
2821         return SCM_BIGSIGN (x) ? SCM_BOOL_T : SCM_BOOL_F;
2822       SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
2823       return (1 == scm_bigcomp (x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
2824     }
2825   if (SCM_NINUMP (y))
2826     {
2827       if (!(SCM_NIMP (y) && SCM_BIGP (y)))
2828         {
2829         bady:
2830           SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
2831         }
2832       return SCM_BIGSIGN (y) ? SCM_BOOL_F : SCM_BOOL_T;
2833     }
2834 #else
2835   SCM_GASSERT2 (SCM_INUMP (x), g_less_p, x, y, SCM_ARG1, s_less_p);
2836   SCM_GASSERT2 (SCM_INUMP (y), g_less_p, x, y, SCM_ARGn, s_less_p);
2837 #endif
2838 #endif
2839   return ((long) x < (long) y) ? SCM_BOOL_T : SCM_BOOL_F;
2840 }
2841
2842
2843 SCM_PROC1 (s_gr_p, ">", scm_tc7_rpsubr, scm_gr_p);
2844
2845 SCM
2846 scm_gr_p (x, y)
2847      SCM x;
2848      SCM y;
2849 {
2850   return scm_less_p (y, x);
2851 }
2852
2853
2854
2855 SCM_PROC1 (s_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p);
2856
2857 SCM
2858 scm_leq_p (x, y)
2859      SCM x;
2860      SCM y;
2861 {
2862   return SCM_BOOL_NOT (scm_less_p (y, x));
2863 }
2864
2865
2866
2867 SCM_PROC1 (s_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p);
2868
2869 SCM
2870 scm_geq_p (x, y)
2871      SCM x;
2872      SCM y;
2873 {
2874   return SCM_BOOL_NOT (scm_less_p (x, y));
2875 }
2876
2877
2878
2879 SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p);
2880
2881 SCM
2882 scm_zero_p (z)
2883      SCM z;
2884 {
2885 #ifdef SCM_FLOATS
2886   if (SCM_NINUMP (z))
2887     {
2888 #ifdef SCM_BIGDIG
2889       SCM_ASRTGO (SCM_NIMP (z), badz);
2890       if (SCM_BIGP (z))
2891         return SCM_BOOL_F;
2892       if (!(SCM_INEXP (z)))
2893         {
2894         badz:
2895           SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);
2896         }
2897 #else
2898       SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
2899                     g_zero_p, z, SCM_ARG1, s_zero_p);
2900 #endif
2901       return (z == scm_flo0) ? SCM_BOOL_T : SCM_BOOL_F;
2902     }
2903 #else
2904 #ifdef SCM_BIGDIG
2905   if (SCM_NINUMP (z))
2906     {
2907       SCM_GASSERT1 (SCM_NIMP (z) && SCM_BIGP (z),
2908                     g_zero_p, z, SCM_ARG1, s_zero_p);
2909       return SCM_BOOL_F;
2910     }
2911 #else
2912   SCM_GASSERT1 (SCM_INUMP (z), g_zero_p, z, SCM_ARG1, s_zero_p);
2913 #endif
2914 #endif
2915   return (z == SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
2916 }
2917
2918
2919
2920 SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p);
2921
2922 SCM
2923 scm_positive_p (x)
2924      SCM x;
2925 {
2926 #ifdef SCM_FLOATS
2927   if (SCM_NINUMP (x))
2928     {
2929 #ifdef SCM_BIGDIG
2930       SCM_ASRTGO (SCM_NIMP (x), badx);
2931       if (SCM_BIGP (x))
2932         return SCM_TYP16 (x) == scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F;
2933       if (!(SCM_REALP (x)))
2934         {
2935         badx:
2936           SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);
2937         }
2938 #else
2939       SCM_GASSERT1 (SCM_NIMP (x) && SCM_REALP (x),
2940                     g_positive_p, x, SCM_ARG1, s_positive_p);
2941 #endif
2942       return (SCM_REALPART (x) > 0.0) ? SCM_BOOL_T : SCM_BOOL_F;
2943     }
2944 #else
2945 #ifdef SCM_BIGDIG
2946   if (SCM_NINUMP (x))
2947     {
2948       SCM_GASSERT1 (SCM_NIMP (x) && SCM_BIGP (x),
2949                     g_positive_p, x, SCM_ARG1, s_positive_p);
2950       return SCM_TYP16 (x) == scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F;
2951     }
2952 #else
2953   SCM_GASSERT1 (SCM_INUMP (x), g_positive_p, x, SCM_ARG1, s_positive_p);
2954 #endif
2955 #endif
2956   return (x > SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
2957 }
2958
2959
2960
2961 SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p);
2962
2963 SCM
2964 scm_negative_p (x)
2965      SCM x;
2966 {
2967 #ifdef SCM_FLOATS
2968   if (SCM_NINUMP (x))
2969     {
2970 #ifdef SCM_BIGDIG
2971       SCM_ASRTGO (SCM_NIMP (x), badx);
2972       if (SCM_BIGP (x))
2973         return SCM_TYP16 (x) == scm_tc16_bigpos ? SCM_BOOL_F : SCM_BOOL_T;
2974       if (!(SCM_REALP (x)))
2975         {
2976         badx:
2977           SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);
2978         }
2979 #else
2980       SCM_GASSERT1 (SCM_NIMP (x) && SCM_REALP (x),
2981                     g_negative_p, x, SCM_ARG1, s_negative_p);
2982 #endif
2983       return (SCM_REALPART (x) < 0.0) ? SCM_BOOL_T : SCM_BOOL_F;
2984     }
2985 #else
2986 #ifdef SCM_BIGDIG
2987   if (SCM_NINUMP (x))
2988     {
2989       SCM_GASSERT1 (SCM_NIMP (x) && SCM_BIGP (x),
2990                     g_negative_p, x, SCM_ARG1, s_negative_p);
2991       return (SCM_TYP16 (x) == scm_tc16_bigneg) ? SCM_BOOL_T : SCM_BOOL_F;
2992     }
2993 #else
2994   SCM_GASSERT1 (SCM_INUMP (x), g_negative_p, x, SCM_ARG1, s_negative_p);
2995 #endif
2996 #endif
2997   return (x < SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
2998 }
2999
3000
3001 SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
3002
3003 SCM
3004 scm_max (x, y)
3005      SCM x;
3006      SCM y;
3007 {
3008 #ifdef SCM_FLOATS
3009   double z;
3010 #endif
3011   if (SCM_UNBNDP (y))
3012     {
3013       SCM_GASSERT0 (!SCM_UNBNDP (x),
3014                     g_max, scm_makfrom0str (s_max), SCM_WNA, 0);
3015       SCM_GASSERT1 (SCM_NUMBERP (x), g_max, x, SCM_ARG1, s_max);
3016       return x;
3017     }
3018 #ifdef SCM_FLOATS
3019   if (SCM_NINUMP (x))
3020     {
3021 #ifdef SCM_BIGDIG
3022       if (!SCM_NIMP (x))
3023         {
3024         badx2:
3025           SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
3026         }
3027       if (SCM_BIGP (x))
3028         {
3029           if (SCM_INUMP (y))
3030             return SCM_BIGSIGN (x) ? y : x;
3031           SCM_ASRTGO (SCM_NIMP (y), bady);
3032           if (SCM_BIGP (y))
3033             return (1 == scm_bigcomp (x, y)) ? y : x;
3034           SCM_ASRTGO (SCM_REALP (y), bady);
3035           z = scm_big2dbl (x);
3036           return (z < SCM_REALPART (y)) ? y : scm_makdbl (z, 0.0);
3037         }
3038       SCM_ASRTGO (SCM_REALP (x), badx2);
3039 #else
3040       SCM_GASSERT2 (SCM_NIMP (x) && SCM_REALP (x),
3041                     g_max, x, y, SCM_ARG1, s_max);
3042 #endif
3043       if (SCM_INUMP (y))
3044         return ((SCM_REALPART (x) < (z = SCM_INUM (y)))
3045                 ? scm_makdbl (z, 0.0)
3046                 : x);
3047 #ifdef SCM_BIGDIG
3048       SCM_ASRTGO (SCM_NIMP (y), bady);
3049       if (SCM_BIGP (y))
3050         return ((SCM_REALPART (x) < (z = scm_big2dbl (y)))
3051                 ? scm_makdbl (z, 0.0)
3052                 : x);
3053       SCM_ASRTGO (SCM_REALP (y), bady);
3054 #else
3055       SCM_ASRTGO (SCM_NIMP (y) && SCM_REALP (y), bady);
3056 #endif
3057       return (SCM_REALPART (x) < SCM_REALPART (y)) ? y : x;
3058     }
3059   if (SCM_NINUMP (y))
3060     {
3061 #ifdef SCM_BIGDIG
3062       SCM_ASRTGO (SCM_NIMP (y), bady);
3063       if (SCM_BIGP (y))
3064         return SCM_BIGSIGN (y) ? x : y;
3065       if (!(SCM_REALP (y)))
3066         {
3067         bady:
3068           SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3069         }
3070 #else
3071       if (!(SCM_NIMP (y) && SCM_REALP (y)))
3072         {
3073         bady:
3074           SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3075         }
3076 #endif
3077       return (((z = SCM_INUM (x)) < SCM_REALPART (y))
3078               ? y
3079               : scm_makdbl (z, 0.0));
3080     }
3081 #else
3082 #ifdef SCM_BIGDIG
3083   if (SCM_NINUMP (x))
3084     {
3085       SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
3086                     g_max, x, y, SCM_ARG1, s_max);
3087       if (SCM_INUMP (y))
3088         return SCM_BIGSIGN (x) ? y : x;
3089       SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
3090       return (1 == scm_bigcomp (x, y)) ? y : x;
3091     }
3092   if (SCM_NINUMP (y))
3093     {
3094       if (!(SCM_NIMP (y) && SCM_BIGP (y)))
3095         {
3096         bady:
3097           SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3098         }
3099       return SCM_BIGSIGN (y) ? x : y;
3100     }
3101 #else
3102   SCM_GASSERT2 (SCM_INUMP (x), g_max, x, y, SCM_ARG1, s_max);
3103   SCM_GASSERT2 (SCM_INUMP (y), g_max, x, y, SCM_ARGn, s_max);
3104 #endif
3105 #endif
3106   return ((long) x < (long) y) ? y : x;
3107 }
3108
3109
3110
3111
3112 SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
3113
3114 SCM
3115 scm_min (x, y)
3116      SCM x;
3117      SCM y;
3118 {
3119 #ifdef SCM_FLOATS
3120   double z;
3121 #endif
3122   if (SCM_UNBNDP (y))
3123     {
3124       SCM_GASSERT0 (!SCM_UNBNDP (x),
3125                     g_min, scm_makfrom0str (s_min), SCM_WNA, 0);
3126       SCM_GASSERT1 (SCM_NUMBERP (x), g_min, x, SCM_ARG1, s_min);
3127       return x;
3128     }
3129 #ifdef SCM_FLOATS
3130   if (SCM_NINUMP (x))
3131     {
3132 #ifdef SCM_BIGDIG
3133       if (!(SCM_NIMP (x)))
3134         {
3135         badx2:
3136           SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
3137         }
3138       if (SCM_BIGP (x))
3139         {
3140           if (SCM_INUMP (y))
3141             return SCM_BIGSIGN (x) ? x : y;
3142           SCM_ASRTGO (SCM_NIMP (y), bady);
3143           if (SCM_BIGP (y))
3144             return (-1 == scm_bigcomp (x, y)) ? y : x;
3145           SCM_ASRTGO (SCM_REALP (y), bady);
3146           z = scm_big2dbl (x);
3147           return (z > SCM_REALPART (y)) ? y : scm_makdbl (z, 0.0);
3148         }
3149       SCM_ASRTGO (SCM_REALP (x), badx2);
3150 #else
3151       SCM_GASSERT2 (SCM_NIMP (x) && SCM_REALP (x),
3152                     g_min, x, y, SCM_ARG1, s_min);
3153 #endif
3154       if (SCM_INUMP (y))
3155         return ((SCM_REALPART (x) > (z = SCM_INUM (y)))
3156                 ? scm_makdbl (z, 0.0)
3157                 : x);
3158 #ifdef SCM_BIGDIG
3159       SCM_ASRTGO (SCM_NIMP (y), bady);
3160       if (SCM_BIGP (y))
3161         return ((SCM_REALPART (x) > (z = scm_big2dbl (y)))
3162                 ? scm_makdbl (z, 0.0)
3163                 : x);
3164       SCM_ASRTGO (SCM_REALP (y), bady);
3165 #else
3166       SCM_ASRTGO (SCM_NIMP (y) && SCM_REALP (y), bady);
3167 #endif
3168       return (SCM_REALPART (x) > SCM_REALPART (y)) ? y : x;
3169     }
3170   if (SCM_NINUMP (y))
3171     {
3172 #ifdef SCM_BIGDIG
3173       SCM_ASRTGO (SCM_NIMP (y), bady);
3174       if (SCM_BIGP (y))
3175         return SCM_BIGSIGN (y) ? y : x;
3176       if (!(SCM_REALP (y)))
3177         {
3178         bady:
3179           SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
3180         }
3181 #else
3182       if (!(SCM_NIMP (y) && SCM_REALP (y)))
3183         {
3184         bady:
3185           SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
3186         }
3187 #endif
3188       return (((z = SCM_INUM (x)) > SCM_REALPART (y))
3189               ? y
3190               : scm_makdbl (z, 0.0));
3191     }
3192 #else
3193 #ifdef SCM_BIGDIG
3194   if (SCM_NINUMP (x))
3195     {
3196       SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
3197                     g_min, x, y, SCM_ARG1, s_min);
3198       if (SCM_INUMP (y))
3199         return SCM_BIGSIGN (x) ? x : y;
3200       SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
3201       return (-1 == scm_bigcomp (x, y)) ? y : x;
3202     }
3203   if (SCM_NINUMP (y))
3204     {
3205       if (!(SCM_NIMP (y) && SCM_BIGP (y)))
3206         {
3207         bady:
3208           SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
3209         }
3210       return SCM_BIGSIGN (y) ? y : x;
3211     }
3212 #else
3213   SCM_GASSERT2 (SCM_INUMP (x), g_min, x, y, SCM_ARG1, s_min);
3214   SCM_GASSERT2 (SCM_INUMP (y), g_min, x, y, SCM_ARGn, s_min);
3215 #endif
3216 #endif
3217   return ((long) x > (long) y) ? y : x;
3218 }
3219
3220
3221
3222
3223 SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
3224
3225 SCM
3226 scm_sum (x, y)
3227      SCM x;
3228      SCM y;
3229 {
3230   if (SCM_UNBNDP (y))
3231     {
3232       if (SCM_UNBNDP (x))
3233         return SCM_INUM0;
3234       SCM_GASSERT1 (SCM_NUMBERP (x), g_sum, x, SCM_ARG1, s_sum);
3235       return x;
3236     }
3237 #ifdef SCM_FLOATS
3238   if (SCM_NINUMP (x))
3239     {
3240       SCM t;
3241 #ifdef SCM_BIGDIG
3242       if (!SCM_NIMP (x))
3243         {
3244         badx2:
3245           SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
3246         }
3247       if (SCM_BIGP (x))
3248         {
3249           if (SCM_INUMP (y))
3250             {
3251               t = x;
3252               x = y;
3253               y = t;
3254               goto intbig;
3255             }
3256           SCM_ASRTGO (SCM_NIMP (y), bady);
3257           if (SCM_BIGP (y))
3258             {
3259               if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y))
3260                 {
3261                   t = x;
3262                   x = y;
3263                   y = t;
3264                 }
3265               return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3266                                  SCM_BIGSIGN (x),
3267                                  y, 0);
3268             }
3269           SCM_ASRTGO (SCM_INEXP (y), bady);
3270         bigreal:
3271           return scm_makdbl (scm_big2dbl (x) + SCM_REALPART (y),
3272                              SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0);
3273         }
3274       SCM_ASRTGO (SCM_INEXP (x), badx2);
3275 #else
3276       SCM_ASRTGO (SCM_NIMP (x) && SCM_INEXP (x), badx2);
3277 #endif
3278       if (SCM_INUMP (y))
3279         {
3280           t = x;
3281           x = y;
3282           y = t;
3283           goto intreal;
3284         }
3285 #ifdef SCM_BIGDIG
3286       SCM_ASRTGO (SCM_NIMP (y), bady);
3287       if (SCM_BIGP (y))
3288         {
3289           t = x;
3290           x = y;
3291           y = t;
3292           goto bigreal;
3293         }
3294       else if (!(SCM_INEXP (y)))
3295         {
3296         bady:
3297           SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3298         }
3299 #else
3300       if (!(SCM_NIMP (y) && SCM_INEXP (y)))
3301         {
3302         bady:
3303           SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3304         }
3305 #endif
3306       {
3307         double i = 0.0;
3308         if (SCM_CPLXP (x))
3309           i = SCM_IMAG (x);
3310         if (SCM_CPLXP (y))
3311           i += SCM_IMAG (y);
3312         return scm_makdbl (SCM_REALPART (x) + SCM_REALPART (y), i);
3313       }
3314     }
3315   if (SCM_NINUMP (y))
3316     {
3317 #ifdef SCM_BIGDIG
3318       SCM_ASRTGO (SCM_NIMP (y), bady);
3319       if (SCM_BIGP (y))
3320         {
3321         intbig:
3322           {
3323 #ifndef SCM_DIGSTOOBIG
3324             long z = scm_pseudolong (SCM_INUM (x));
3325             return scm_addbig ((SCM_BIGDIG *) & z,
3326                                SCM_DIGSPERLONG,
3327                                (x < 0) ? 0x0100 : 0,
3328                                y, 0);
3329 #else
3330             SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3331             scm_longdigs (SCM_INUM (x), zdigs);
3332             return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3333                                y, 0);
3334 #endif
3335           }
3336         }
3337       SCM_ASRTGO (SCM_INEXP (y), bady);
3338 #else
3339       SCM_ASRTGO (SCM_NIMP (y) && SCM_INEXP (y), bady);
3340 #endif
3341     intreal:
3342       return scm_makdbl (SCM_INUM (x) + SCM_REALPART (y),
3343                          SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0);
3344     }
3345 #else
3346 #ifdef SCM_BIGDIG
3347   if (SCM_NINUMP (x))
3348     {
3349       SCM t;
3350       SCM_ASRTGO (SCM_NIMP (x) && SCM_BIGP (x), badx2);
3351       if (SCM_INUMP (y))
3352         {
3353           t = x;
3354           x = y;
3355           y = t;
3356           goto intbig;
3357         }
3358       SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
3359       if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y))
3360         {
3361           t = x;
3362           x = y;
3363           y = t;
3364         }
3365       return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x),
3366                          y, 0);
3367     }
3368   if (SCM_NINUMP (y))
3369     {
3370       if (!(SCM_NIMP (y) && SCM_BIGP (y)))
3371         {
3372         bady:
3373           SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3374         }
3375     intbig:
3376       {
3377 #ifndef SCM_DIGSTOOBIG
3378         long z = scm_pseudolong (SCM_INUM (x));
3379         return scm_addbig (&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
3380 #else
3381         SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3382         scm_longdigs (SCM_INUM (x), zdigs);
3383         return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
3384 #endif
3385       }
3386     }
3387 #else
3388   SCM_ASRTGO (SCM_INUMP (x), badx2);
3389   SCM_GASSERT2 (SCM_INUMP (y), g_sum, x, y, SCM_ARGn, s_sum);
3390 #endif
3391 #endif
3392   x = SCM_INUM (x) + SCM_INUM (y);
3393   if (SCM_FIXABLE (x))
3394     return SCM_MAKINUM (x);
3395 #ifdef SCM_BIGDIG
3396   return scm_long2big (x);
3397 #else
3398 #ifdef SCM_FLOATS
3399   return scm_makdbl ((double) x, 0.0);
3400 #else
3401   scm_num_overflow (s_sum);
3402   return SCM_UNSPECIFIED;
3403 #endif
3404 #endif
3405 }
3406
3407
3408
3409
3410 SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
3411
3412 SCM
3413 scm_difference (x, y)
3414      SCM x;
3415      SCM y;
3416 {
3417 #ifdef SCM_FLOATS
3418   if (SCM_NINUMP (x))
3419     {
3420       if (!(SCM_NIMP (x)))
3421         {
3422           if (SCM_UNBNDP (y))
3423             {
3424               SCM_GASSERT0 (!SCM_UNBNDP (x), g_difference,
3425                             scm_makfrom0str (s_difference), SCM_WNA, 0);
3426             badx:
3427               SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
3428             }
3429           else
3430             {
3431             badx2:
3432               SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
3433             }
3434         }
3435       if (SCM_UNBNDP (y))
3436         {
3437 #ifdef SCM_BIGDIG
3438           if (SCM_BIGP (x))
3439             {
3440               x = scm_copybig (x, !SCM_BIGSIGN (x));
3441               return (SCM_NUMDIGS (x) * SCM_BITSPERDIG / SCM_CHAR_BIT
3442                       <= sizeof (SCM)
3443                       ? scm_big2inum (x, SCM_NUMDIGS (x))
3444                       : x);
3445             }
3446 #endif
3447           SCM_ASRTGO (SCM_INEXP (x), badx);
3448           return scm_makdbl (- SCM_REALPART (x),
3449                              SCM_CPLXP (x) ? -SCM_IMAG (x) : 0.0);
3450         }
3451       if (SCM_INUMP (y))
3452         return scm_sum (x, SCM_MAKINUM (- SCM_INUM (y)));
3453 #ifdef SCM_BIGDIG
3454       SCM_ASRTGO (SCM_NIMP (y), bady);
3455       if (SCM_BIGP (x))
3456         {
3457           if (SCM_BIGP (y))
3458             return ((SCM_NUMDIGS (x) < SCM_NUMDIGS (y))
3459                     ? scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3460                                   SCM_BIGSIGN (x),
3461                                   y, 0x0100)
3462                     : scm_addbig (SCM_BDIGITS (y), SCM_NUMDIGS (y),
3463                                   SCM_BIGSIGN (y) ^ 0x0100,
3464                                   x, 0));
3465           SCM_ASRTGO (SCM_INEXP (y), bady);
3466           return scm_makdbl (scm_big2dbl (x) - SCM_REALPART (y),
3467                              SCM_CPLXP (y) ? -SCM_IMAG (y) : 0.0);
3468         }
3469       SCM_ASRTGO (SCM_INEXP (x), badx2);
3470       if (SCM_BIGP (y))
3471         return scm_makdbl (SCM_REALPART (x) - scm_big2dbl (y),
3472                            SCM_CPLXP (x) ? SCM_IMAG (x) : 0.0);
3473       SCM_ASRTGO (SCM_INEXP (y), bady);
3474 #else
3475       SCM_ASRTGO (SCM_INEXP (x), badx2);
3476       SCM_ASRTGO (SCM_NIMP (y) && SCM_INEXP (y), bady);
3477 #endif
3478       if (SCM_CPLXP (x))
3479         {
3480           if (SCM_CPLXP (y))
3481             return scm_makdbl (SCM_REAL (x) - SCM_REAL (y),
3482                                SCM_IMAG (x) - SCM_IMAG (y));
3483           else
3484             return scm_makdbl (SCM_REAL (x) - SCM_REALPART (y), SCM_IMAG (x));
3485         }
3486       return scm_makdbl (SCM_REALPART (x) - SCM_REALPART (y),
3487                          SCM_CPLXP (y) ? - SCM_IMAG (y) : 0.0);
3488     }
3489   if (SCM_UNBNDP (y))
3490     {
3491       x = -SCM_INUM (x);
3492       goto checkx;
3493     }
3494   if (SCM_NINUMP (y))
3495     {
3496 #ifdef SCM_BIGDIG
3497       SCM_ASRTGO (SCM_NIMP (y), bady);
3498       if (SCM_BIGP (y))
3499         {
3500 #ifndef SCM_DIGSTOOBIG
3501           long z = scm_pseudolong (SCM_INUM (x));
3502           return scm_addbig ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
3503                              (x < 0) ? 0x0100 : 0,
3504                              y, 0x0100);
3505 #else
3506           SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3507           scm_longdigs (SCM_INUM (x), zdigs);
3508           return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3509                              y, 0x0100);
3510 #endif
3511         }
3512       if (!(SCM_INEXP (y)))
3513         {
3514         bady:
3515           SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3516         }
3517 #else
3518       if (!(SCM_NIMP (y) && SCM_INEXP (y)))
3519         {
3520         bady:
3521           SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3522         }
3523 #endif
3524       return scm_makdbl (SCM_INUM (x) - SCM_REALPART (y),
3525                          SCM_CPLXP (y) ? -SCM_IMAG (y) : 0.0);
3526     }
3527 #else
3528 #ifdef SCM_BIGDIG
3529   if (SCM_NINUMP (x))
3530     {
3531       SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
3532                     g_difference, x, y, SCM_ARG1, s_difference);
3533       if (SCM_UNBNDP (y))
3534         {
3535           x = scm_copybig (x, !SCM_BIGSIGN (x));
3536           return (SCM_NUMDIGS (x) * SCM_BITSPERDIG / SCM_CHAR_BIT
3537                   <= sizeof (SCM)
3538                   ? scm_big2inum (x, SCM_NUMDIGS (x))
3539                   : x);
3540         }
3541       if (SCM_INUMP (y))
3542         {
3543 #ifndef SCM_DIGSTOOBIG
3544           long z = scm_pseudolong (SCM_INUM (y));
3545           return scm_addbig (&z, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
3546 #else
3547           SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3548           scm_longdigs (SCM_INUM (x), zdigs);
3549           return scm_addbig (zdigs, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100,
3550                              x, 0);
3551 #endif
3552         }
3553       SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
3554       return (SCM_NUMDIGS (x) < SCM_NUMDIGS (y)) ?
3555         scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x),
3556                     y, 0x0100) :
3557         scm_addbig (SCM_BDIGITS (y), SCM_NUMDIGS (y), SCM_BIGSIGN (y) ^ 0x0100,
3558                     x, 0);
3559     }
3560   if (SCM_UNBNDP (y))
3561     {
3562       x = -SCM_INUM (x);
3563       goto checkx;
3564     }
3565   if (SCM_NINUMP (y))
3566     {
3567       if (!(SCM_NIMP (y) && SCM_BIGP (y)))
3568         {
3569         bady:
3570           SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3571         }
3572       {
3573 #ifndef SCM_DIGSTOOBIG
3574         long z = scm_pseudolong (SCM_INUM (x));
3575         return scm_addbig (&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3576                            y, 0x0100);
3577 #else
3578         SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3579         scm_longdigs (SCM_INUM (x), zdigs);
3580         return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3581                            y, 0x0100);
3582 #endif
3583       }
3584     }
3585 #else
3586   SCM_GASSERT2 (SCM_INUMP (x), g_difference, x, y, SCM_ARG1, s_difference);
3587   if (SCM_UNBNDP (y))
3588     {
3589       x = -SCM_INUM (x);
3590       goto checkx;
3591     }
3592   SCM_GASSERT2 (SCM_INUMP (y), g_difference, x, y, SCM_ARGn, s_difference);
3593 #endif
3594 #endif
3595   x = SCM_INUM (x) - SCM_INUM (y);
3596  checkx:
3597   if (SCM_FIXABLE (x))
3598     return SCM_MAKINUM (x);
3599 #ifdef SCM_BIGDIG
3600   return scm_long2big (x);
3601 #else
3602 #ifdef SCM_FLOATS
3603   return scm_makdbl ((double) x, 0.0);
3604 #else
3605   scm_num_overflow (s_difference);
3606   return SCM_UNSPECIFIED;
3607 #endif
3608 #endif
3609 }
3610
3611
3612
3613
3614 SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
3615
3616 SCM
3617 scm_product (x, y)
3618      SCM x;
3619      SCM y;
3620 {
3621   if (SCM_UNBNDP (y))
3622     {
3623       if (SCM_UNBNDP (x))
3624         return SCM_MAKINUM (1L);
3625       SCM_GASSERT1 (SCM_NUMBERP (x), g_product, x, SCM_ARG1, s_product);
3626       return x;
3627     }
3628 #ifdef SCM_FLOATS
3629   if (SCM_NINUMP (x))
3630     {
3631       SCM t;
3632 #ifdef SCM_BIGDIG
3633       if (!SCM_NIMP (x))
3634         {
3635         badx2:
3636           SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
3637         }
3638       if (SCM_BIGP (x))
3639         {
3640           if (SCM_INUMP (y))
3641             {
3642               t = x;
3643               x = y;
3644               y = t;
3645               goto intbig;
3646             }
3647           SCM_ASRTGO (SCM_NIMP (y), bady);
3648           if (SCM_BIGP (y))
3649             return scm_mulbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3650                                SCM_BDIGITS (y), SCM_NUMDIGS (y),
3651                                SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y));
3652           SCM_ASRTGO (SCM_INEXP (y), bady);
3653         bigreal:
3654           {
3655             double bg = scm_big2dbl (x);
3656             return scm_makdbl (bg * SCM_REALPART (y),
3657                                SCM_CPLXP (y) ? bg * SCM_IMAG (y) : 0.0);
3658           }
3659         }
3660       SCM_ASRTGO (SCM_INEXP (x), badx2);
3661 #else
3662       SCM_ASRTGO (SCM_NIMP (x) && SCM_INEXP (x), badx2);
3663 #endif
3664       if (SCM_INUMP (y))
3665         {
3666           t = x;
3667           x = y;
3668           y = t;
3669           goto intreal;
3670         }
3671 #ifdef SCM_BIGDIG
3672       SCM_ASRTGO (SCM_NIMP (y), bady);
3673       if (SCM_BIGP (y))
3674         {
3675           t = x;
3676           x = y;
3677           y = t;
3678           goto bigreal;
3679         }
3680       else if (!(SCM_INEXP (y)))
3681         {
3682         bady:
3683           SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3684         }
3685 #else
3686       if (!(SCM_NIMP (y) && SCM_INEXP (y)))
3687         {
3688         bady:
3689           SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3690         }
3691 #endif
3692       if (SCM_CPLXP (x))
3693         {
3694           if (SCM_CPLXP (y))
3695             return scm_makdbl (SCM_REAL (x) * SCM_REAL (y)
3696                                - SCM_IMAG (x) * SCM_IMAG (y),
3697                                SCM_REAL (x) * SCM_IMAG (y)
3698                                + SCM_IMAG (x) * SCM_REAL (y));
3699           else
3700             return scm_makdbl (SCM_REAL (x) * SCM_REALPART (y),
3701                                SCM_IMAG (x) * SCM_REALPART (y));
3702         }
3703       return scm_makdbl (SCM_REALPART (x) * SCM_REALPART (y),
3704                          SCM_CPLXP (y)
3705                          ? SCM_REALPART (x) * SCM_IMAG (y)
3706                          : 0.0);
3707     }
3708   if (SCM_NINUMP (y))
3709     {
3710 #ifdef SCM_BIGDIG
3711       SCM_ASRTGO (SCM_NIMP (y), bady);
3712       if (SCM_BIGP (y))
3713         {
3714         intbig:
3715           if (SCM_INUM0 == x)
3716             return x;
3717           if (SCM_MAKINUM (1L) == x)
3718             return y;
3719           {
3720 #ifndef SCM_DIGSTOOBIG
3721             long z = scm_pseudolong (SCM_INUM (x));
3722             return scm_mulbig ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
3723                                SCM_BDIGITS (y), SCM_NUMDIGS (y),
3724                                SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3725 #else
3726             SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3727             scm_longdigs (SCM_INUM (x), zdigs);
3728             return scm_mulbig (zdigs, SCM_DIGSPERLONG,
3729                                SCM_BDIGITS (y), SCM_NUMDIGS (y),
3730                                SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3731 #endif
3732           }
3733         }
3734       SCM_ASRTGO (SCM_INEXP (y), bady);
3735 #else
3736       SCM_ASRTGO (SCM_NIMP (y) && SCM_INEXP (y), bady);
3737 #endif
3738     intreal:
3739       return scm_makdbl (SCM_INUM (x) * SCM_REALPART (y),
3740                          SCM_CPLXP (y) ? SCM_INUM (x) * SCM_IMAG (y) : 0.0);
3741     }
3742 #else
3743 #ifdef SCM_BIGDIG
3744   if (SCM_NINUMP (x))
3745     {
3746       SCM_ASRTGO (SCM_NIMP (x) && SCM_BIGP (x), badx2);
3747       if (SCM_INUMP (y))
3748         {
3749           SCM t = x;
3750           x = y;
3751           y = t;
3752           goto intbig;
3753         }
3754       SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
3755       return scm_mulbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3756                          SCM_BDIGITS (y), SCM_NUMDIGS (y),
3757                          SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y));
3758     }
3759   if (SCM_NINUMP (y))
3760     {
3761       if (!(SCM_NIMP (y) && SCM_BIGP (y)))
3762         {
3763         bady:
3764           SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3765         }
3766     intbig:
3767       if (SCM_INUM0 == x)
3768         return x;
3769       if (SCM_MAKINUM (1L) == x)
3770         return y;
3771       {
3772 #ifndef SCM_DIGSTOOBIG
3773         long z = scm_pseudolong (SCM_INUM (x));
3774         return scm_mulbig (&z, SCM_DIGSPERLONG,
3775                            SCM_BDIGITS (y), SCM_NUMDIGS (y),
3776                            SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3777 #else
3778         SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3779         scm_longdigs (SCM_INUM (x), zdigs);
3780         return scm_mulbig (zdigs, SCM_DIGSPERLONG,
3781                            SCM_BDIGITS (y), SCM_NUMDIGS (y),
3782                            SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3783 #endif
3784       }
3785     }
3786 #else
3787   SCM_ASRTGO (SCM_INUMP (x), badx2);
3788   SCM_GASSERT (SCM_INUMP (y), g_product, x, y, SCM_ARGn, s_product);
3789 #endif
3790 #endif
3791   {
3792     long i, j, k;
3793     i = SCM_INUM (x);
3794     if (0 == i)
3795       return x;
3796     j = SCM_INUM (y);
3797     k = i * j;
3798     y = SCM_MAKINUM (k);
3799     if (k != SCM_INUM (y) || k / i != j)
3800 #ifdef SCM_BIGDIG
3801       {
3802         int sgn = (i < 0) ^ (j < 0);
3803 #ifndef SCM_DIGSTOOBIG
3804         i = scm_pseudolong (i);
3805         j = scm_pseudolong (j);
3806         return scm_mulbig ((SCM_BIGDIG *) & i, SCM_DIGSPERLONG,
3807                            (SCM_BIGDIG *) & j, SCM_DIGSPERLONG, sgn);
3808 #else /* SCM_DIGSTOOBIG */
3809         SCM_BIGDIG idigs[SCM_DIGSPERLONG];
3810         SCM_BIGDIG jdigs[SCM_DIGSPERLONG];
3811         scm_longdigs (i, idigs);
3812         scm_longdigs (j, jdigs);
3813         return scm_mulbig (idigs, SCM_DIGSPERLONG,
3814                            jdigs, SCM_DIGSPERLONG,
3815                            sgn);
3816 #endif
3817       }
3818 #else
3819 #ifdef SCM_FLOATS
3820     return scm_makdbl (((double) i) * ((double) j), 0.0);
3821 #else
3822     scm_num_overflow (s_product);
3823 #endif
3824 #endif
3825     return y;
3826   }
3827 }
3828
3829
3830
3831 double
3832 scm_num2dbl (a, why)
3833      SCM a;
3834      const char *why;
3835 {
3836   if (SCM_INUMP (a))
3837     return (double) SCM_INUM (a);
3838 #ifdef SCM_FLOATS
3839   SCM_ASSERT (SCM_NIMP (a), a, "wrong type argument", why);
3840   if (SCM_REALP (a))
3841     return (SCM_REALPART (a));
3842 #endif
3843 #ifdef SCM_BIGDIG
3844   return scm_big2dbl (a);
3845 #endif
3846   SCM_ASSERT (0, a, "wrong type argument", why);
3847   return SCM_UNSPECIFIED;
3848 }
3849
3850
3851 SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
3852
3853 SCM
3854 scm_divide (x, y)
3855      SCM x;
3856      SCM y;
3857 {
3858 #ifdef SCM_FLOATS
3859   double d, r, i, a;
3860   if (SCM_NINUMP (x))
3861     {
3862       if (!(SCM_NIMP (x)))
3863         {
3864           if (SCM_UNBNDP (y))
3865             {
3866               SCM_GASSERT0 (!SCM_UNBNDP (x),
3867                             g_divide, scm_makfrom0str (s_divide), SCM_WNA, 0);
3868             badx:
3869               SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
3870             }
3871           else
3872             {
3873             badx2:
3874               SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
3875             }
3876         }
3877       if (SCM_UNBNDP (y))
3878         {
3879 #ifdef SCM_BIGDIG
3880           if (SCM_BIGP (x))
3881             return scm_makdbl (1.0 / scm_big2dbl (x), 0.0);
3882 #endif
3883           SCM_ASRTGO (SCM_INEXP (x), badx);
3884           if (SCM_REALP (x))
3885             return scm_makdbl (1.0 / SCM_REALPART (x), 0.0);
3886           r = SCM_REAL (x);
3887           i = SCM_IMAG (x);
3888           d = r * r + i * i;
3889           return scm_makdbl (r / d, -i / d);
3890         }
3891 #ifdef SCM_BIGDIG
3892       if (SCM_BIGP (x))
3893         {
3894           SCM z;
3895           if (SCM_INUMP (y))
3896             {
3897               z = SCM_INUM (y);
3898 #ifndef SCM_RECKLESS
3899               if (!z)
3900                 scm_num_overflow (s_divide);
3901 #endif
3902               if (1 == z)
3903                 return x;
3904               if (z < 0)
3905                 z = -z;
3906               if (z < SCM_BIGRAD)
3907                 {
3908                   SCM w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0));
3909                   return (scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w),
3910                                          (SCM_BIGDIG) z)
3911                           ? scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0)
3912                           : scm_normbig (w));
3913                 }
3914 #ifndef SCM_DIGSTOOBIG
3915               z = scm_pseudolong (z);
3916               z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3917                                  (SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
3918                                  SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
3919 #else
3920               {
3921                 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3922                 scm_longdigs (z, zdigs);
3923                 z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3924                                    zdigs, SCM_DIGSPERLONG,
3925                                    SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
3926               }
3927 #endif
3928               return z ? z : scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0);
3929             }
3930           SCM_ASRTGO (SCM_NIMP (y), bady);
3931           if (SCM_BIGP (y))
3932             {
3933               z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3934                                  SCM_BDIGITS (y), SCM_NUMDIGS (y),
3935                                  SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3);
3936               return z ? z : scm_makdbl (scm_big2dbl (x) / scm_big2dbl (y),
3937                                          0.0);
3938             }
3939           SCM_ASRTGO (SCM_INEXP (y), bady);
3940           if (SCM_REALP (y))
3941             return scm_makdbl (scm_big2dbl (x) / SCM_REALPART (y), 0.0);
3942           a = scm_big2dbl (x);
3943           goto complex_div;
3944         }
3945 #endif
3946       SCM_ASRTGO (SCM_INEXP (x), badx2);
3947       if (SCM_INUMP (y))
3948         {
3949           d = SCM_INUM (y);
3950           goto basic_div;
3951         }
3952 #ifdef SCM_BIGDIG
3953       SCM_ASRTGO (SCM_NIMP (y), bady);
3954       if (SCM_BIGP (y))
3955         {
3956           d = scm_big2dbl (y);
3957           goto basic_div;
3958         }
3959       SCM_ASRTGO (SCM_INEXP (y), bady);
3960 #else
3961       SCM_ASRTGO (SCM_NIMP (y) && SCM_INEXP (y), bady);
3962 #endif
3963       if (SCM_REALP (y))
3964         {
3965           d = SCM_REALPART (y);
3966         basic_div:
3967           return scm_makdbl (SCM_REALPART (x) / d,
3968                              SCM_CPLXP (x) ? SCM_IMAG (x) / d : 0.0);
3969         }
3970       a = SCM_REALPART (x);
3971       if (SCM_REALP (x))
3972         goto complex_div;
3973       r = SCM_REAL (y);
3974       i = SCM_IMAG (y);
3975       d = r * r + i * i;
3976       return scm_makdbl ((a * r + SCM_IMAG (x) * i) / d,
3977                          (SCM_IMAG (x) * r - a * i) / d);
3978     }
3979   if (SCM_UNBNDP (y))
3980     {
3981       if ((SCM_MAKINUM (1L) == x) || (SCM_MAKINUM (-1L) == x))
3982         return x;
3983       return scm_makdbl (1.0 / ((double) SCM_INUM (x)), 0.0);
3984     }
3985   if (SCM_NINUMP (y))
3986     {
3987 #ifdef SCM_BIGDIG
3988       SCM_ASRTGO (SCM_NIMP (y), bady);
3989       if (SCM_BIGP (y))
3990         return scm_makdbl (SCM_INUM (x) / scm_big2dbl (y), 0.0);
3991       if (!(SCM_INEXP (y)))
3992         {
3993         bady:
3994           SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
3995         }
3996 #else
3997       if (!(SCM_NIMP (y) && SCM_INEXP (y)))
3998         {
3999         bady:
4000           SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
4001         }
4002 #endif
4003       if (SCM_REALP (y))
4004         return scm_makdbl (SCM_INUM (x) / SCM_REALPART (y), 0.0);
4005       a = SCM_INUM (x);
4006     complex_div:
4007       r = SCM_REAL (y);
4008       i = SCM_IMAG (y);
4009       d = r * r + i * i;
4010       return scm_makdbl ((a * r) / d, (-a * i) / d);
4011     }
4012 #else
4013 #ifdef SCM_BIGDIG
4014   if (SCM_NINUMP (x))
4015     {
4016       SCM z;
4017       SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
4018                     g_divide, x, y, SCM_ARG1, s_divide);
4019       if (SCM_UNBNDP (y))
4020         goto ov;
4021       if (SCM_INUMP (y))
4022         {
4023           z = SCM_INUM (y);
4024           if (!z)
4025             goto ov;
4026           if (1 == z)
4027             return x;
4028           if (z < 0)
4029             z = -z;
4030           if (z < SCM_BIGRAD)
4031             {
4032               SCM w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0));
4033               if (scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w),
4034                                  (SCM_BIGDIG) z))
4035                 goto ov;
4036               return w;
4037             }
4038 #ifndef SCM_DIGSTOOBIG
4039           z = scm_pseudolong (z);
4040           z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
4041                              &z, SCM_DIGSPERLONG,
4042                              SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
4043 #else
4044           {
4045             SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
4046             scm_longdigs (z, zdigs);
4047             z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
4048                                zdigs, SCM_DIGSPERLONG,
4049                                SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
4050           }
4051 #endif
4052         }
4053       else
4054         {
4055           SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
4056           z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
4057                              SCM_BDIGITS (y), SCM_NUMDIGS (y),
4058                              SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3);
4059         }
4060       if (!z)
4061         goto ov;
4062       return z;
4063     }
4064   if (SCM_UNBNDP (y))
4065     {
4066       if ((SCM_MAKINUM (1L) == x) || (SCM_MAKINUM (-1L) == x))
4067         return x;
4068       goto ov;
4069     }
4070   if (SCM_NINUMP (y))
4071     {
4072       if (!(SCM_NIMP (y) && SCM_BIGP (y)))
4073         {
4074         bady:
4075           SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
4076         }
4077       goto ov;
4078     }
4079 #else
4080   SCM_GASSERT2 (SCM_INUMP (x), g_divide, x, y, SCM_ARG1, s_divide);
4081   if (SCM_UNBNDP (y))
4082     {
4083       if ((SCM_MAKINUM (1L) == x) || (SCM_MAKINUM (-1L) == x))
4084         return x;
4085       goto ov;
4086     }
4087   SCM_GASSERT2 (SCM_INUMP (y), g_divide, x, y, SCM_ARGn, s_divide);
4088 #endif
4089 #endif
4090   {
4091     long z = SCM_INUM (y);
4092     if ((0 == z) || SCM_INUM (x) % z)
4093       goto ov;
4094     z = SCM_INUM (x) / z;
4095     if (SCM_FIXABLE (z))
4096       return SCM_MAKINUM (z);
4097 #ifdef SCM_BIGDIG
4098     return scm_long2big (z);
4099 #endif
4100 #ifdef SCM_FLOATS
4101   ov:
4102     return scm_makdbl (((double) SCM_INUM (x)) / ((double) SCM_INUM (y)), 0.0);
4103 #else
4104   ov:
4105     scm_num_overflow (s_divide);
4106     return SCM_UNSPECIFIED;
4107 #endif
4108   }
4109 }
4110
4111
4112
4113
4114 #ifdef SCM_FLOATS
4115 SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh, g_asinh);
4116
4117 double
4118 scm_asinh (x)
4119      double x;
4120 {
4121   return log (x + sqrt (x * x + 1));
4122 }
4123
4124
4125
4126
4127 SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh, g_acosh);
4128
4129 double
4130 scm_acosh (x)
4131      double x;
4132 {
4133   return log (x + sqrt (x * x - 1));
4134 }
4135
4136
4137
4138
4139 SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh, g_atanh);
4140
4141 double
4142 scm_atanh (x)
4143      double x;
4144 {
4145   return 0.5 * log ((1 + x) / (1 - x));
4146 }
4147
4148
4149
4150
4151 SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate, g_truncate);
4152
4153 double
4154 scm_truncate (x)
4155      double x;
4156 {
4157   if (x < 0.0)
4158     return -floor (-x);
4159   return floor (x);
4160 }
4161
4162
4163
4164 SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round, g_round);
4165
4166 double
4167 scm_round (x)
4168      double x;
4169 {
4170   double plus_half = x + 0.5;
4171   double result = floor (plus_half);
4172   /* Adjust so that the scm_round is towards even.  */
4173   return (plus_half == result && plus_half / 2 != floor (plus_half / 2))
4174     ? result - 1 : result;
4175 }
4176
4177
4178
4179 SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact, g_exact_to_inexact);
4180
4181 double
4182 scm_exact_to_inexact (z)
4183      double z;
4184 {
4185   return z;
4186 }
4187
4188
4189 SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor);
4190 SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil);
4191 SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt);
4192 SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs, g_i_abs);
4193 SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp);
4194 SCM_GPROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log, g_i_log);
4195 SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin, g_i_sin);
4196 SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos, g_i_cos);
4197 SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan, g_i_tan);
4198 SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin, g_i_asin);
4199 SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos, g_i_acos);
4200 SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan, g_i_atan);
4201 SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh, g_i_sinh);
4202 SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh, g_i_cosh);
4203 SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh, g_i_tanh);
4204
4205 struct dpair
4206 {
4207   double x, y;
4208 };
4209
4210 static void scm_two_doubles (SCM z1,
4211                              SCM z2,
4212                              const char *sstring,
4213                              struct dpair * xy);
4214
4215 static void
4216 scm_two_doubles (z1, z2, sstring, xy)
4217      SCM z1, z2;
4218      const char *sstring;
4219      struct dpair *xy;
4220 {
4221   if (SCM_INUMP (z1))
4222     xy->x = SCM_INUM (z1);
4223   else
4224     {
4225 #ifdef SCM_BIGDIG
4226       SCM_ASRTGO (SCM_NIMP (z1), badz1);
4227       if (SCM_BIGP (z1))
4228         xy->x = scm_big2dbl (z1);
4229       else
4230         {
4231 #ifndef SCM_RECKLESS
4232           if (!(SCM_REALP (z1)))
4233             badz1:scm_wta (z1, (char *) SCM_ARG1, sstring);
4234 #endif
4235           xy->x = SCM_REALPART (z1);
4236         }
4237 #else
4238       {
4239         SCM_ASSERT (SCM_NIMP (z1) && SCM_REALP (z1), z1, SCM_ARG1, sstring);
4240         xy->x = SCM_REALPART (z1);
4241       }
4242 #endif
4243     }
4244   if (SCM_INUMP (z2))
4245     xy->y = SCM_INUM (z2);
4246   else
4247     {
4248 #ifdef SCM_BIGDIG
4249       SCM_ASRTGO (SCM_NIMP (z2), badz2);
4250       if (SCM_BIGP (z2))
4251         xy->y = scm_big2dbl (z2);
4252       else
4253         {
4254 #ifndef SCM_RECKLESS
4255           if (!(SCM_REALP (z2)))
4256             badz2:scm_wta (z2, (char *) SCM_ARG2, sstring);
4257 #endif
4258           xy->y = SCM_REALPART (z2);
4259         }
4260 #else
4261       {
4262         SCM_ASSERT (SCM_NIMP (z2) && SCM_REALP (z2), z2, SCM_ARG2, sstring);
4263         xy->y = SCM_REALPART (z2);
4264       }
4265 #endif
4266     }
4267 }
4268
4269
4270
4271
4272 SCM_PROC (s_sys_expt, "$expt", 2, 0, 0, scm_sys_expt);
4273
4274 SCM
4275 scm_sys_expt (z1, z2)
4276      SCM z1;
4277      SCM z2;
4278 {
4279   struct dpair xy;
4280   scm_two_doubles (z1, z2, s_sys_expt, &xy);
4281   return scm_makdbl (pow (xy.x, xy.y), 0.0);
4282 }
4283
4284
4285
4286 SCM_PROC (s_sys_atan2, "$atan2", 2, 0, 0, scm_sys_atan2);
4287
4288 SCM
4289 scm_sys_atan2 (z1, z2)
4290      SCM z1;
4291      SCM z2;
4292 {
4293   struct dpair xy;
4294   scm_two_doubles (z1, z2, s_sys_atan2, &xy);
4295   return scm_makdbl (atan2 (xy.x, xy.y), 0.0);
4296 }
4297
4298
4299
4300 SCM_PROC (s_make_rectangular, "make-rectangular", 2, 0, 0, scm_make_rectangular);
4301
4302 SCM
4303 scm_make_rectangular (z1, z2)
4304      SCM z1;
4305      SCM z2;
4306 {
4307   struct dpair xy;
4308   scm_two_doubles (z1, z2, s_make_rectangular, &xy);
4309   return scm_makdbl (xy.x, xy.y);
4310 }
4311
4312
4313
4314 SCM_PROC (s_make_polar, "make-polar", 2, 0, 0, scm_make_polar);
4315
4316 SCM
4317 scm_make_polar (z1, z2)
4318      SCM z1;
4319      SCM z2;
4320 {
4321   struct dpair xy;
4322   scm_two_doubles (z1, z2, s_make_polar, &xy);
4323   return scm_makdbl (xy.x * cos (xy.y), xy.x * sin (xy.y));
4324 }
4325
4326
4327
4328
4329 SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part);
4330
4331 SCM
4332 scm_real_part (z)
4333      SCM z;
4334 {
4335   if (SCM_NINUMP (z))
4336     {
4337 #ifdef SCM_BIGDIG
4338       SCM_ASRTGO (SCM_NIMP (z), badz);
4339       if (SCM_BIGP (z))
4340         return z;
4341       if (!(SCM_INEXP (z)))
4342         {
4343         badz:
4344           SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);
4345         }
4346 #else
4347       SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
4348                     g_real_part, z, SCM_ARG1, s_real_part);
4349 #endif
4350       if (SCM_CPLXP (z))
4351         return scm_makdbl (SCM_REAL (z), 0.0);
4352     }
4353   return z;
4354 }
4355
4356
4357
4358 SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part);
4359
4360 SCM
4361 scm_imag_part (z)
4362      SCM z;
4363 {
4364   if (SCM_INUMP (z))
4365     return SCM_INUM0;
4366 #ifdef SCM_BIGDIG
4367   SCM_ASRTGO (SCM_NIMP (z), badz);
4368   if (SCM_BIGP (z))
4369     return SCM_INUM0;
4370   if (!(SCM_INEXP (z)))
4371     {
4372     badz:
4373       SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);
4374     }
4375 #else
4376   SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
4377                 g_imag_part, z, SCM_ARG1, s_imag_part);
4378 #endif
4379   if (SCM_CPLXP (z))
4380     return scm_makdbl (SCM_IMAG (z), 0.0);
4381   return scm_flo0;
4382 }
4383
4384
4385
4386 SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude);
4387
4388 SCM
4389 scm_magnitude (z)
4390      SCM z;
4391 {
4392   if (SCM_INUMP (z))
4393     return scm_abs (z);
4394 #ifdef SCM_BIGDIG
4395   SCM_ASRTGO (SCM_NIMP (z), badz);
4396   if (SCM_BIGP (z))
4397     return scm_abs (z);
4398   if (!(SCM_INEXP (z)))
4399     {
4400     badz:
4401       SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
4402     }
4403 #else
4404   SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
4405                 g_magnitude, z, SCM_ARG1, s_magnitude);
4406 #endif
4407   if (SCM_CPLXP (z))
4408     {
4409       double i = SCM_IMAG (z), r = SCM_REAL (z);
4410       return scm_makdbl (sqrt (i * i + r * r), 0.0);
4411     }
4412   return scm_makdbl (fabs (SCM_REALPART (z)), 0.0);
4413 }
4414
4415
4416
4417
4418 SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle);
4419
4420 SCM
4421 scm_angle (z)
4422      SCM z;
4423 {
4424   double x, y = 0.0;
4425   if (SCM_INUMP (z))
4426     {
4427       x = (z >= SCM_INUM0) ? 1.0 : -1.0;
4428       goto do_angle;
4429     }
4430 #ifdef SCM_BIGDIG
4431   SCM_ASRTGO (SCM_NIMP (z), badz);
4432   if (SCM_BIGP (z))
4433     {
4434       x = (SCM_TYP16 (z) == scm_tc16_bigpos) ? 1.0 : -1.0;
4435       goto do_angle;
4436     }
4437   if (!(SCM_INEXP (z)))
4438     {
4439     badz:
4440       SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
4441     }
4442 #else
4443   SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z), g_angle, z, SCM_ARG1, s_angle);
4444 #endif
4445   if (SCM_REALP (z))
4446     {
4447       x = SCM_REALPART (z);
4448       goto do_angle;
4449     }
4450   x = SCM_REAL (z);
4451   y = SCM_IMAG (z);
4452  do_angle:
4453   return scm_makdbl (atan2 (y, x), 0.0);
4454 }
4455
4456
4457 SCM_PROC (s_inexact_to_exact, "inexact->exact", 1, 0, 0, scm_inexact_to_exact);
4458
4459 SCM
4460 scm_inexact_to_exact (z)
4461      SCM z;
4462 {
4463   if (SCM_INUMP (z))
4464     return z;
4465 #ifdef SCM_BIGDIG
4466   SCM_ASRTGO (SCM_NIMP (z), badz);
4467   if (SCM_BIGP (z))
4468     return z;
4469 #ifndef SCM_RECKLESS
4470   if (!(SCM_REALP (z)))
4471     {
4472     badz:
4473       scm_wta (z, (char *) SCM_ARG1, s_inexact_to_exact);
4474     }
4475 #endif
4476 #else
4477   SCM_ASSERT (SCM_NIMP (z) && SCM_REALP (z), z, SCM_ARG1, s_inexact_to_exact);
4478 #endif
4479 #ifdef SCM_BIGDIG
4480   {
4481     double u = floor (SCM_REALPART (z) + 0.5);
4482     if ((u <= SCM_MOST_POSITIVE_FIXNUM) && (-u <= -SCM_MOST_NEGATIVE_FIXNUM))
4483       {
4484         /* Negation is a workaround for HP700 cc bug */
4485         SCM ans = SCM_MAKINUM ((long) u);
4486         if (SCM_INUM (ans) == (long) u)
4487           return ans;
4488       }
4489     SCM_ASRTGO (isfinite (u), badz);    /* problem? */
4490     return scm_dbl2big (u);
4491   }
4492 #else
4493   return SCM_MAKINUM ((long) floor (SCM_REALPART (z) + 0.5));
4494 #endif
4495 }
4496
4497
4498
4499 #else /* ~SCM_FLOATS */
4500 SCM_GPROC (s_trunc, "truncate", 1, 0, 0, scm_trunc, g_trunc);
4501
4502 SCM
4503 scm_trunc (x)
4504      SCM x;
4505 {
4506   SCM_GASSERT2 (SCM_INUMP (x), g_trunc, x, y, SCM_ARG1, s_truncate);
4507   return x;
4508 }
4509
4510
4511
4512 #endif /* SCM_FLOATS */
4513
4514 #ifdef SCM_BIGDIG
4515 #ifdef SCM_FLOATS
4516 /* d must be integer */
4517
4518 SCM
4519 scm_dbl2big (d)
4520      double d;
4521 {
4522   scm_sizet i = 0;
4523   long c;
4524   SCM_BIGDIG *digits;
4525   SCM ans;
4526   double u = (d < 0) ? -d : d;
4527   while (0 != floor (u))
4528     {
4529       u /= SCM_BIGRAD;
4530       i++;
4531     }
4532   ans = scm_mkbig (i, d < 0);
4533   digits = SCM_BDIGITS (ans);
4534   while (i--)
4535     {
4536       u *= SCM_BIGRAD;
4537       c = floor (u);
4538       u -= c;
4539       digits[i] = c;
4540     }
4541 #ifndef SCM_RECKLESS
4542   if (u != 0)
4543     scm_num_overflow ("dbl2big");
4544 #endif
4545   return ans;
4546 }
4547
4548
4549
4550 double
4551 scm_big2dbl (b)
4552      SCM b;
4553 {
4554   double ans = 0.0;
4555   scm_sizet i = SCM_NUMDIGS (b);
4556   SCM_BIGDIG *digits = SCM_BDIGITS (b);
4557   while (i--)
4558     ans = digits[i] + SCM_BIGRAD * ans;
4559   if (scm_tc16_bigneg == SCM_TYP16 (b))
4560     return -ans;
4561   return ans;
4562 }
4563 #endif
4564 #endif
4565
4566
4567 SCM
4568 scm_long2num (sl)
4569      long sl;
4570 {
4571   if (!SCM_FIXABLE (sl))
4572     {
4573 #ifdef SCM_BIGDIG
4574       return scm_long2big (sl);
4575 #else
4576 #ifdef SCM_FLOATS
4577       return scm_makdbl ((double) sl, 0.0);
4578 #else
4579       return SCM_BOOL_F;
4580 #endif
4581 #endif
4582     }
4583   return SCM_MAKINUM (sl);
4584 }
4585
4586
4587 #ifdef LONGLONGS
4588
4589 SCM
4590 scm_long_long2num (sl)
4591      long_long sl;
4592 {
4593   if (!SCM_FIXABLE (sl))
4594     {
4595 #ifdef SCM_BIGDIG
4596       return scm_long_long2big (sl);
4597 #else
4598 #ifdef SCM_FLOATS
4599       return scm_makdbl ((double) sl, 0.0);
4600 #else
4601       return SCM_BOOL_F;
4602 #endif
4603 #endif
4604     }
4605   return SCM_MAKINUM (sl);
4606 }
4607 #endif
4608
4609
4610
4611 SCM
4612 scm_ulong2num (sl)
4613      unsigned long sl;
4614 {
4615   if (!SCM_POSFIXABLE (sl))
4616     {
4617 #ifdef SCM_BIGDIG
4618       return scm_ulong2big (sl);
4619 #else
4620 #ifdef SCM_FLOATS
4621       return scm_makdbl ((double) sl, 0.0);
4622 #else
4623       return SCM_BOOL_F;
4624 #endif
4625 #endif
4626     }
4627   return SCM_MAKINUM (sl);
4628 }
4629
4630
4631 long
4632 scm_num2long (num, pos, s_caller)
4633      SCM num;
4634      char *pos;
4635      const char *s_caller;
4636 {
4637   long res;
4638   if (SCM_INUMP (num))
4639     {
4640       res = SCM_INUM (num);
4641       return res;
4642     }
4643   SCM_ASRTGO (SCM_NIMP (num), errout);
4644 #ifdef SCM_FLOATS
4645   if (SCM_REALP (num))
4646     {
4647       double u = SCM_REALPART (num);
4648       res = u;
4649       if ((double) res == u)
4650         {
4651           return res;
4652         }
4653     }
4654 #endif
4655 #ifdef SCM_BIGDIG
4656   if (SCM_BIGP (num))
4657     {
4658       long oldres;
4659       scm_sizet l;
4660       res = 0;
4661       oldres = 0;
4662       for (l = SCM_NUMDIGS (num); l--;)
4663         {
4664           res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l];
4665           if (res < oldres)
4666             goto errout;
4667           oldres = res;
4668         }
4669       if (SCM_TYP16 (num) == scm_tc16_bigpos)
4670         return res;
4671       else
4672         return -res;
4673     }
4674 #endif
4675  errout:
4676   scm_wta (num, pos, s_caller);
4677   return SCM_UNSPECIFIED;
4678 }
4679
4680
4681
4682 #ifdef LONGLONGS
4683
4684 long_long
4685 scm_num2long_long (num, pos, s_caller)
4686      SCM num;
4687      char *pos;
4688      const char *s_caller;
4689 {
4690   long_long res;
4691   if (SCM_INUMP (num))
4692     {
4693       res = SCM_INUM ((long_long) num);
4694       return res;
4695     }
4696   SCM_ASRTGO (SCM_NIMP (num), errout);
4697 #ifdef SCM_FLOATS
4698   if (SCM_REALP (num))
4699     {
4700       double u = SCM_REALPART (num);
4701       if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u)
4702           && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3)))
4703         {
4704           res = u;
4705           return res;
4706         }
4707     }
4708 #endif
4709 #ifdef SCM_BIGDIG
4710   if (SCM_BIGP (num))
4711     {
4712       scm_sizet l = SCM_NUMDIGS (num);
4713       SCM_ASRTGO (SCM_DIGSPERLONGLONG >= l, errout);
4714       res = 0;
4715       for (; l--;)
4716         res = SCM_LONGLONGBIGUP (res) + SCM_BDIGITS (num)[l];
4717       return res;
4718     }
4719 #endif
4720  errout:
4721   scm_wta (num, pos, s_caller);
4722   return SCM_UNSPECIFIED;
4723 }
4724 #endif
4725
4726
4727
4728 unsigned long
4729 scm_num2ulong (num, pos, s_caller)
4730      SCM num;
4731      char *pos;
4732      const char *s_caller;
4733 {
4734   unsigned long res;
4735   if (SCM_INUMP (num))
4736     {
4737       res = SCM_INUM ((unsigned long) num);
4738       return res;
4739     }
4740   SCM_ASRTGO (SCM_NIMP (num), errout);
4741 #ifdef SCM_FLOATS
4742   if (SCM_REALP (num))
4743     {
4744       double u = SCM_REALPART (num);
4745       if ((0 <= u) && (u <= (unsigned long) ~0L))
4746         {
4747           res = u;
4748           return res;
4749         }
4750     }
4751 #endif
4752 #ifdef SCM_BIGDIG
4753   if (SCM_BIGP (num))
4754     {
4755       unsigned long oldres;
4756       scm_sizet l;
4757       res = 0;
4758       oldres = 0;
4759       for (l = SCM_NUMDIGS (num); l--;)
4760         {
4761           res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l];
4762           if (res < oldres)
4763             goto errout;
4764           oldres = res;
4765         }
4766       return res;
4767     }
4768 #endif
4769  errout:
4770   scm_wta (num, pos, s_caller);
4771   return SCM_UNSPECIFIED;
4772 }
4773
4774
4775 #ifdef SCM_FLOATS
4776 #ifndef DBL_DIG
4777 static void add1 SCM_P ((double f, double *fsum));
4778 static void
4779 add1 (f, fsum)
4780      double f, *fsum;
4781 {
4782   *fsum = f + 1.0;
4783 }
4784 #endif
4785 #endif
4786
4787
4788
4789 void
4790 scm_init_numbers ()
4791 {
4792   scm_add_feature("complex");
4793 #ifdef SCM_FLOATS
4794   scm_add_feature("inexact");
4795 #ifdef SCM_SINGLES
4796   SCM_NEWSMOB(scm_flo0,scm_tc_flo,NULL);
4797 #else
4798   SCM_NEWSMOB(scm_flo0,scm_tc_dblr,scm_must_malloc (1L * sizeof (double), "real"));
4799   SCM_REAL (scm_flo0) = 0.0;
4800 #endif
4801 #ifdef DBL_DIG
4802   scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
4803 #else
4804   {                             /* determine floating point precision */
4805     double f = 0.1;
4806     double fsum = 1.0 + f;
4807     while (fsum != 1.0)
4808       {
4809         f /= 10.0;
4810         if (++scm_dblprec > 20)
4811           break;
4812         add1 (f, &fsum);
4813       }
4814     scm_dblprec = scm_dblprec - 1;
4815   }
4816 #endif /* DBL_DIG */
4817 #endif
4818 #include "numbers.x"
4819 }