libguile/numbers.c

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