libguile/numbers.c

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