libguile/numbers.c

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