libguile/numbers.c

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