libguile/numbers.c

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