libguile/numbers.c

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