/[guile]/guile/guile-core/libguile/numbers.c
ViewVC logotype

Diff of /guile/guile-core/libguile/numbers.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.193 by kryde, Tue Jul 8 00:27:03 2003 UTC revision 1.194 by mdj, Sun Jul 13 16:13:57 2003 UTC
# Line 143  scm_i_clonebig (SCM src_big, int same_si Line 143  scm_i_clonebig (SCM src_big, int same_si
143    /* Copy src_big's value, negate it if same_sign_p is false, and return. */    /* Copy src_big's value, negate it if same_sign_p is false, and return. */
144    SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);    SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
145    mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big));    mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big));
146    if (!same_sign_p) mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z));    if (!same_sign_p)
147        mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z));
148    return z;    return z;
149  }  }
150    
# Line 194  SCM_DEFINE (scm_exact_p, "exact?", 1, 0, Line 195  SCM_DEFINE (scm_exact_p, "exact?", 1, 0,
195              "otherwise.")              "otherwise.")
196  #define FUNC_NAME s_scm_exact_p  #define FUNC_NAME s_scm_exact_p
197  {  {
198    if (SCM_INUMP (x)) return SCM_BOOL_T;    if (SCM_INUMP (x))
199    if (SCM_BIGP (x)) return SCM_BOOL_T;      return SCM_BOOL_T;
200      if (SCM_BIGP (x))
201        return SCM_BOOL_T;
202    return SCM_BOOL_F;    return SCM_BOOL_F;
203  }  }
204  #undef FUNC_NAME  #undef FUNC_NAME
# Line 207  SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, Line 210  SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0,
210              "otherwise.")              "otherwise.")
211  #define FUNC_NAME s_scm_odd_p  #define FUNC_NAME s_scm_odd_p
212  {  {
213    if (SCM_INUMP (n)) {    if (SCM_INUMP (n))
214      long val = SCM_INUM (n);      {
215      return SCM_BOOL ((val & 1L) != 0);        long val = SCM_INUM (n);
216    } else if (SCM_BIGP (n)) {        return SCM_BOOL ((val & 1L) != 0);
217      int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n));      }
218      scm_remember_upto_here_1 (n);    else if (SCM_BIGP (n))
219      return SCM_BOOL (odd_p);      {
220    } else if (scm_inf_p (n)) {        int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n));
221          scm_remember_upto_here_1 (n);
222          return SCM_BOOL (odd_p);
223        }
224      else if (!SCM_FALSEP (scm_inf_p (n)))
225      return SCM_BOOL_T;      return SCM_BOOL_T;
226    } else {    else
227      SCM_WRONG_TYPE_ARG (1, n);      SCM_WRONG_TYPE_ARG (1, n);
   }  
228  }  }
229  #undef FUNC_NAME  #undef FUNC_NAME
230    
# Line 229  SCM_DEFINE (scm_even_p, "even?", 1, 0, 0 Line 235  SCM_DEFINE (scm_even_p, "even?", 1, 0, 0
235              "otherwise.")              "otherwise.")
236  #define FUNC_NAME s_scm_even_p  #define FUNC_NAME s_scm_even_p
237  {  {
238    if (SCM_INUMP (n)) {    if (SCM_INUMP (n))
239      long val = SCM_INUM (n);      {
240      return SCM_BOOL ((val & 1L) == 0);        long val = SCM_INUM (n);
241    } else if (SCM_BIGP (n)) {        return SCM_BOOL ((val & 1L) == 0);
242      int even_p = mpz_even_p (SCM_I_BIG_MPZ (n));      }
243      scm_remember_upto_here_1 (n);    else if (SCM_BIGP (n))
244      return SCM_BOOL (even_p);      {
245    } else if (scm_inf_p (n)) {        int even_p = mpz_even_p (SCM_I_BIG_MPZ (n));
246          scm_remember_upto_here_1 (n);
247          return SCM_BOOL (even_p);
248        }
249      else if (!SCM_FALSEP (scm_inf_p (n)))
250      return SCM_BOOL_T;      return SCM_BOOL_T;
251    } else {    else
252      SCM_WRONG_TYPE_ARG (1, n);      SCM_WRONG_TYPE_ARG (1, n);
   }  
253  }  }
254  #undef FUNC_NAME  #undef FUNC_NAME
255    
# Line 272  SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0, Line 281  SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0,
281              "otherwise.")              "otherwise.")
282  #define FUNC_NAME s_scm_inf_p  #define FUNC_NAME s_scm_inf_p
283  {  {
284    if (SCM_REALP (n)) {    if (SCM_REALP (n))
285      return SCM_BOOL (xisinf (SCM_REAL_VALUE (n)));      return SCM_BOOL (xisinf (SCM_REAL_VALUE (n)));
286    } else if (SCM_COMPLEXP (n)) {    else if (SCM_COMPLEXP (n))
287      return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n))      return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n))
288                       || xisinf (SCM_COMPLEX_IMAG (n)));                       || xisinf (SCM_COMPLEX_IMAG (n)));
289    } else {    else
290      return SCM_BOOL_F;      return SCM_BOOL_F;
   }  
291  }  }
292  #undef FUNC_NAME  #undef FUNC_NAME
293    
# Line 289  SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0, Line 297  SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0,
297              "otherwise.")              "otherwise.")
298  #define FUNC_NAME s_scm_nan_p  #define FUNC_NAME s_scm_nan_p
299  {  {
300    if (SCM_REALP (n)) {    if (SCM_REALP (n))
301      return SCM_BOOL (xisnan (SCM_REAL_VALUE (n)));      return SCM_BOOL (xisnan (SCM_REAL_VALUE (n)));
302    } else if (SCM_COMPLEXP (n)) {    else if (SCM_COMPLEXP (n))
303      return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n))      return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n))
304                       || xisnan (SCM_COMPLEX_IMAG (n)));                       || xisnan (SCM_COMPLEX_IMAG (n)));
305    } else {    else
306      return SCM_BOOL_F;      return SCM_BOOL_F;
   }  
307  }  }
308  #undef FUNC_NAME  #undef FUNC_NAME
309    
# Line 367  SCM_DEFINE (scm_nan, "nan", 0, 0, 0, Line 374  SCM_DEFINE (scm_nan, "nan", 0, 0, 0,
374  #define FUNC_NAME s_scm_nan  #define FUNC_NAME s_scm_nan
375  {  {
376    static int initialized = 0;    static int initialized = 0;
377    if (! initialized)    if (!initialized)
378      {      {
379        guile_ieee_init ();        guile_ieee_init ();
380        initialized = 1;        initialized = 1;
# Line 382  SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1 Line 389  SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1
389                         "Return the absolute value of @var{x}.")                         "Return the absolute value of @var{x}.")
390  #define FUNC_NAME  #define FUNC_NAME
391  {  {
392    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
393      long int xx = SCM_INUM (x);      {
394      if (xx >= 0) {        long int xx = SCM_INUM (x);
395        return x;        if (xx >= 0)
396      } else if (SCM_POSFIXABLE (-xx)) {          return x;
397        return SCM_MAKINUM (-xx);        else if (SCM_POSFIXABLE (-xx))
398      } else {          return SCM_MAKINUM (-xx);
399        return scm_i_long2big (-xx);        else
400      }          return scm_i_long2big (-xx);
401    } else if (SCM_BIGP (x)) {      }
402      const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));    else if (SCM_BIGP (x))
403      if (sgn < 0) {      {
404        return scm_i_clonebig (x, 0);        const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
405      } else {        if (sgn < 0)
406        return x;          return scm_i_clonebig (x, 0);
407          else
408            return x;
409      }      }
410    } else if (SCM_REALP (x)) {    else if (SCM_REALP (x))
411      return scm_make_real (fabs (SCM_REAL_VALUE (x)));      return scm_make_real (fabs (SCM_REAL_VALUE (x)));
412    } else {    else
413      SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs);      SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs);
   }  
414  }  }
415  #undef FUNC_NAME  #undef FUNC_NAME
416    
# Line 413  SCM_GPROC (s_quotient, "quotient", 2, 0, Line 421  SCM_GPROC (s_quotient, "quotient", 2, 0,
421  SCM  SCM
422  scm_quotient (SCM x, SCM y)  scm_quotient (SCM x, SCM y)
423  {  {
424    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
425      long xx = SCM_INUM (x);      {
426      if (SCM_INUMP (y)) {        long xx = SCM_INUM (x);
427        long yy = SCM_INUM (y);        if (SCM_INUMP (y))
428        if (yy == 0) {          {
429          scm_num_overflow (s_quotient);            long yy = SCM_INUM (y);
430        } else {            if (yy == 0)
431          long z = xx / yy;              scm_num_overflow (s_quotient);
432          if (SCM_FIXABLE (z)) {            else
433            return SCM_MAKINUM (z);              {
434          } else {                long z = xx / yy;
435            return scm_i_long2big (z);                if (SCM_FIXABLE (z))
436                    return SCM_MAKINUM (z);
437                  else
438                    return scm_i_long2big (z);
439                }
440          }          }
441        }        else if (SCM_BIGP (y))
     } else if (SCM_BIGP (y)) {  
       if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)  
           && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0))  
442          {          {
443            /* Special case:  x == fixnum-min && y == abs (fixnum-min) */            if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
444            return SCM_MAKINUM (-1);                && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0))
445                /* Special case:  x == fixnum-min && y == abs (fixnum-min) */
446                return SCM_MAKINUM (-1);
447              else
448                return SCM_MAKINUM (0);
449          }          }
450        else        else
451          return SCM_MAKINUM (0);          SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
     } else {  
       SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);  
452      }      }
453    } else if (SCM_BIGP (x)) {    else if (SCM_BIGP (x))
454      if (SCM_INUMP (y)) {      {
455        long yy = SCM_INUM (y);        if (SCM_INUMP (y))
456        if (yy == 0) {          {
457          scm_num_overflow (s_quotient);            long yy = SCM_INUM (y);
458        } else if (yy == 1) {            if (yy == 0)
459          return x;              scm_num_overflow (s_quotient);
460        } else {            else if (yy == 1)
461          SCM result = scm_i_mkbig ();              return x;
462          if (yy < 0) {            else
463            mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - yy);              {
464            mpz_neg(SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));                SCM result = scm_i_mkbig ();
465          } else {                if (yy < 0)
466            mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);                  {
467          }                    mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result),
468          scm_remember_upto_here_1 (x);                                   SCM_I_BIG_MPZ (x),
469          return scm_i_normbig (result);                                   - yy);
470        }                    mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
471      } else if (SCM_BIGP (y)) {                  }
472        SCM result = scm_i_mkbig ();                else
473        mpz_tdiv_q(SCM_I_BIG_MPZ (result),                  mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
474                   SCM_I_BIG_MPZ (x),                scm_remember_upto_here_1 (x);
475                   SCM_I_BIG_MPZ (y));                return scm_i_normbig (result);
476        scm_remember_upto_here_2 (x, y);              }
477        return scm_i_normbig (result);          }
478      } else {        else if (SCM_BIGP (y))
479        SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);          {
480              SCM result = scm_i_mkbig ();
481              mpz_tdiv_q (SCM_I_BIG_MPZ (result),
482                          SCM_I_BIG_MPZ (x),
483                          SCM_I_BIG_MPZ (y));
484              scm_remember_upto_here_2 (x, y);
485              return scm_i_normbig (result);
486            }
487          else
488            SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
489      }      }
490    } else {    else
491      SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG1, s_quotient);      SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG1, s_quotient);
   }  
492  }  }
493    
494  SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder);  SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder);
# Line 482  SCM_GPROC (s_remainder, "remainder", 2, Line 501  SCM_GPROC (s_remainder, "remainder", 2,
501  SCM  SCM
502  scm_remainder (SCM x, SCM y)  scm_remainder (SCM x, SCM y)
503  {  {
504    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
505      if (SCM_INUMP (y)) {      {
506        long yy = SCM_INUM (y);        if (SCM_INUMP (y))
507        if (yy == 0) {          {
508          scm_num_overflow (s_remainder);            long yy = SCM_INUM (y);
509        } else {            if (yy == 0)
510          long z = SCM_INUM (x) % yy;              scm_num_overflow (s_remainder);
511          return SCM_MAKINUM (z);            else
512        }              {
513      } else if (SCM_BIGP (y)) {                long z = SCM_INUM (x) % yy;
514        if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)                return SCM_MAKINUM (z);
515            && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0))              }
516            }
517          else if (SCM_BIGP (y))
518          {          {
519            /* Special case:  x == fixnum-min && y == abs (fixnum-min) */            if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
520            return SCM_MAKINUM (0);                && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0))
521                /* Special case:  x == fixnum-min && y == abs (fixnum-min) */
522                return SCM_MAKINUM (0);
523              else
524                return x;
525          }          }
526        else        else
527          return x;          SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
     } else {  
       SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);  
528      }      }
529    } else if (SCM_BIGP (x)) {    else if (SCM_BIGP (x))
530      if (SCM_INUMP (y)) {      {
531        long yy = SCM_INUM (y);        if (SCM_INUMP (y))
532        if (yy == 0) {          {
533          scm_num_overflow (s_remainder);            long yy = SCM_INUM (y);
534        } else {            if (yy == 0)
535          SCM result = scm_i_mkbig ();              scm_num_overflow (s_remainder);
536          if (yy < 0) yy = - yy;            else
537          mpz_tdiv_r_ui(SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ(x), yy);              {
538          scm_remember_upto_here_1(x);                SCM result = scm_i_mkbig ();
539          return scm_i_normbig (result);                if (yy < 0)
540        }                  yy = - yy;
541      } else if (SCM_BIGP (y)) {                mpz_tdiv_r_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ(x), yy);
542        SCM result = scm_i_mkbig ();                scm_remember_upto_here_1 (x);
543        mpz_tdiv_r (SCM_I_BIG_MPZ (result),                return scm_i_normbig (result);
544                    SCM_I_BIG_MPZ (x),              }
545                    SCM_I_BIG_MPZ (y));          }
546        scm_remember_upto_here_2(x, y);        else if (SCM_BIGP (y))
547        return scm_i_normbig (result);          {
548      } else {            SCM result = scm_i_mkbig ();
549        SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);            mpz_tdiv_r (SCM_I_BIG_MPZ (result),
550                          SCM_I_BIG_MPZ (x),
551                          SCM_I_BIG_MPZ (y));
552              scm_remember_upto_here_2 (x, y);
553              return scm_i_normbig (result);
554            }
555          else
556            SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
557      }      }
558    } else {    else
559      SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG1, s_remainder);      SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG1, s_remainder);
   }  
560  }  }
561    
562    
# Line 541  SCM_GPROC (s_modulo, "modulo", 2, 0, 0, Line 570  SCM_GPROC (s_modulo, "modulo", 2, 0, 0,
570  SCM  SCM
571  scm_modulo (SCM x, SCM y)  scm_modulo (SCM x, SCM y)
572  {  {
573    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
574      long xx = SCM_INUM (x);      {
575      if (SCM_INUMP (y)) {        long xx = SCM_INUM (x);
576        long yy = SCM_INUM (y);        if (SCM_INUMP (y))
577        if (yy == 0) {          {
578          scm_num_overflow (s_modulo);            long yy = SCM_INUM (y);
579        } else {            if (yy == 0)
580          /* FIXME: I think this may be a bug on some arches -- results              scm_num_overflow (s_modulo);
581             of % with negative second arg are undefined... */            else
582          long z = xx % yy;              {
583          long result;                /* FIXME: I think this may be a bug on some arches -- results
584                     of % with negative second arg are undefined... */
585          if (yy < 0) {                long z = xx % yy;
586            if (z > 0) result = z + yy;                long result;
           else result = z;  
         } else {  
           if (z < 0) result = z + yy;  
           else result = z;  
         }  
         return SCM_MAKINUM (result);  
       }  
     } else if (SCM_BIGP (y)) {  
       int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));  
587    
588        if (sgn_y == 0) {                if (yy < 0)
589          scm_num_overflow (s_modulo);                  {
590        } else {                    if (z > 0)
591          mpz_t z_x;                      result = z + yy;
592          SCM result;                    else
593                        result = z;
594          if (sgn_y < 0) {                  }
595            SCM pos_y = scm_i_clonebig (y, 0);                else
596            /* do this after the last scm_op */                  {
597            mpz_init_set_si (z_x, xx);                    if (z < 0)
598            result = pos_y; /* re-use this bignum */                      result = z + yy;
599            mpz_mod (SCM_I_BIG_MPZ (result), z_x, SCM_I_BIG_MPZ (pos_y));                            else
600            scm_remember_upto_here_1 (pos_y);                      result = z;
601          } else {                  }
602            result = scm_i_mkbig ();                return SCM_MAKINUM (result);
603            /* do this after the last scm_op */              }
604            mpz_init_set_si (z_x, xx);          }
605            mpz_mod (SCM_I_BIG_MPZ (result), z_x, SCM_I_BIG_MPZ (y));                else if (SCM_BIGP (y))
606            scm_remember_upto_here_1 (y);          {
607          }            int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
608    
609              if (sgn_y == 0)
610                scm_num_overflow (s_modulo);
611              else
612                {
613                  mpz_t z_x;
614                  SCM result;
615    
616                  if (sgn_y < 0)
617                    {
618                      SCM pos_y = scm_i_clonebig (y, 0);
619                      /* do this after the last scm_op */
620                      mpz_init_set_si (z_x, xx);
621                      result = pos_y; /* re-use this bignum */
622                      mpz_mod (SCM_I_BIG_MPZ (result),
623                               z_x,
624                               SCM_I_BIG_MPZ (pos_y));        
625                      scm_remember_upto_here_1 (pos_y);
626                    }
627                  else
628                    {
629                      result = scm_i_mkbig ();
630                      /* do this after the last scm_op */
631                      mpz_init_set_si (z_x, xx);
632                      mpz_mod (SCM_I_BIG_MPZ (result),
633                               z_x,
634                               SCM_I_BIG_MPZ (y));        
635                      scm_remember_upto_here_1 (y);
636                    }
637                    
638          if ((sgn_y < 0) && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0) {                if ((sgn_y < 0) && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)
639            mpz_add (SCM_I_BIG_MPZ (result),                  mpz_add (SCM_I_BIG_MPZ (result),
640                     SCM_I_BIG_MPZ (y),                           SCM_I_BIG_MPZ (y),
641                     SCM_I_BIG_MPZ (result));                           SCM_I_BIG_MPZ (result));
642          }                scm_remember_upto_here_1 (y);
643          scm_remember_upto_here_1 (y);                /* and do this before the next one */
644          /* and do this before the next one */                mpz_clear (z_x);
645          mpz_clear (z_x);                return scm_i_normbig (result);
646          return scm_i_normbig (result);              }
647        }          }
648      } else {        else
649        SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);          SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
650      }      }
651    } else if (SCM_BIGP (x)) {    else if (SCM_BIGP (x))
652      if (SCM_INUMP (y)) {      {
653        long yy = SCM_INUM (y);        if (SCM_INUMP (y))
654        if (yy == 0) {          {
655          scm_num_overflow (s_modulo);            long yy = SCM_INUM (y);
656        } else {            if (yy == 0)
657          SCM result = scm_i_mkbig ();              scm_num_overflow (s_modulo);
658          mpz_mod_ui (SCM_I_BIG_MPZ (result),            else
659                      SCM_I_BIG_MPZ (x),              {
660                      (yy < 0) ? - yy : yy);                SCM result = scm_i_mkbig ();
661          scm_remember_upto_here_1 (x);                mpz_mod_ui (SCM_I_BIG_MPZ (result),
662          if ((yy < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)) {                            SCM_I_BIG_MPZ (x),
663            mpz_sub_ui (SCM_I_BIG_MPZ (result),                            (yy < 0) ? - yy : yy);
664                        SCM_I_BIG_MPZ (result),                scm_remember_upto_here_1 (x);
665                        - yy);                if ((yy < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
666          }                  mpz_sub_ui (SCM_I_BIG_MPZ (result),
667          return scm_i_normbig (result);                              SCM_I_BIG_MPZ (result),
668        }                              - yy);
669      } else if (SCM_BIGP (y)) {                return scm_i_normbig (result);
670        int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));              }
671        if (sgn_y == 0) {          }
672          scm_num_overflow (s_modulo);        else if (SCM_BIGP (y))
673        } else {          {
674          SCM result = scm_i_mkbig ();            int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
675          int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y));            if (sgn_y == 0)
676          SCM pos_y = scm_i_clonebig (y, y_sgn >= 0);              scm_num_overflow (s_modulo);
677          mpz_mod (SCM_I_BIG_MPZ (result),            else
678                   SCM_I_BIG_MPZ (x),              {
679                   SCM_I_BIG_MPZ (pos_y));                SCM result = scm_i_mkbig ();
680                  int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
681                  SCM pos_y = scm_i_clonebig (y, y_sgn >= 0);
682                  mpz_mod (SCM_I_BIG_MPZ (result),
683                           SCM_I_BIG_MPZ (x),
684                           SCM_I_BIG_MPZ (pos_y));
685                    
686          scm_remember_upto_here_1 (x);                scm_remember_upto_here_1 (x);
687          if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)) {                if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
688            mpz_add (SCM_I_BIG_MPZ (result),                  mpz_add (SCM_I_BIG_MPZ (result),
689                     SCM_I_BIG_MPZ (y),                           SCM_I_BIG_MPZ (y),
690                     SCM_I_BIG_MPZ (result));                           SCM_I_BIG_MPZ (result));
691          }                scm_remember_upto_here_2 (y, pos_y);
692          scm_remember_upto_here_2 (y, pos_y);                return scm_i_normbig (result);
693          return scm_i_normbig (result);              }
694        }          }
695      } else {        else
696        SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);          SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
697      }      }
698    } else {    else
699      SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo);      SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo);
   }  
700  }  }
701    
702  SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);  SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
# Line 654  SCM Line 707  SCM
707  scm_gcd (SCM x, SCM y)  scm_gcd (SCM x, SCM y)
708  {  {
709    if (SCM_UNBNDP (y))    if (SCM_UNBNDP (y))
710      return (SCM_UNBNDP (x)) ? SCM_INUM0 : x;      return SCM_UNBNDP (x) ? SCM_INUM0 : x;
711        
712    if (SCM_INUMP (x))    if (SCM_INUMP (x))
713      {      {
# Line 665  scm_gcd (SCM x, SCM y) Line 718  scm_gcd (SCM x, SCM y)
718            long u = xx < 0 ? -xx : xx;            long u = xx < 0 ? -xx : xx;
719            long v = yy < 0 ? -yy : yy;            long v = yy < 0 ? -yy : yy;
720            long result;            long result;
721            if (xx == 0) {            if (xx == 0)
722              result = v;              result = v;
723            } else if (yy == 0) {            else if (yy == 0)
724              result = u;              result = u;
725            } else {            else
726              long k = 1;              {
727              long t;                long k = 1;
728              /* Determine a common factor 2^k */                long t;
729              while (!(1 & (u | v)))                /* Determine a common factor 2^k */
730                {                while (!(1 & (u | v)))
731                  k <<= 1;                  {
732                  u >>= 1;                    k <<= 1;
733                  v >>= 1;                    u >>= 1;
734                }                    v >>= 1;
735              /* Now, any factor 2^n can be eliminated */                  }
736              if (u & 1)                /* Now, any factor 2^n can be eliminated */
737                t = -v;                if (u & 1)
738              else                  t = -v;
739                {                else
740                  t = u;                  {
741                b3:                    t = u;
742                  t = SCM_SRS (t, 1);                  b3:
743                }                    t = SCM_SRS (t, 1);
744              if (!(1 & t))                  }
745                goto b3;                if (!(1 & t))
746              if (t > 0)                  goto b3;
747                u = t;                if (t > 0)
748              else                  u = t;
749                v = -t;                else
750              t = u - v;                  v = -t;
751              if (t != 0)                t = u - v;
752                goto b3;                if (t != 0)
753              result = u * k;                  goto b3;
754            }                result = u * k;
755            return SCM_POSFIXABLE (result) \              }
756              ? SCM_MAKINUM (result) : scm_i_long2big (result);            return (SCM_POSFIXABLE (result)
757                      ? SCM_MAKINUM (result)
758                      : scm_i_long2big (result));
759          }          }
760        else if (SCM_BIGP (y))        else if (SCM_BIGP (y))
761          {          {
762            SCM result = scm_i_mkbig ();            SCM result = scm_i_mkbig ();
763            SCM mx = scm_i_mkbig ();            SCM mx = scm_i_mkbig ();
764            mpz_set_si(SCM_I_BIG_MPZ (mx), SCM_INUM (x));            mpz_set_si (SCM_I_BIG_MPZ (mx), SCM_INUM (x));
765            scm_remember_upto_here_1 (x);            scm_remember_upto_here_1 (x);
766            mpz_gcd(SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (mx), SCM_I_BIG_MPZ (y));            mpz_gcd (SCM_I_BIG_MPZ (result),
767            scm_remember_upto_here_2(mx, y);                     SCM_I_BIG_MPZ (mx),
768                       SCM_I_BIG_MPZ (y));
769              scm_remember_upto_here_2 (mx, y);
770            return scm_i_normbig (result);            return scm_i_normbig (result);
771          }          }
772        else        else
# Line 723  scm_gcd (SCM x, SCM y) Line 780  scm_gcd (SCM x, SCM y)
780            long yy = SCM_INUM (y);            long yy = SCM_INUM (y);
781            if (yy == 0)            if (yy == 0)
782              return scm_abs (x);              return scm_abs (x);
783            if (yy < 0) yy = -yy;            if (yy < 0)
784                yy = -yy;
785            result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy);            result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy);
786            scm_remember_upto_here_1 (x);            scm_remember_upto_here_1 (x);
787            return SCM_POSFIXABLE (result) \            return (SCM_POSFIXABLE (result)
788              ? SCM_MAKINUM (result) : scm_ulong2num (result);                    ? SCM_MAKINUM (result)
789                      : scm_ulong2num (result));
790          }          }
791        else if (SCM_BIGP (y))        else if (SCM_BIGP (y))
792          {          {
793            SCM result = scm_i_mkbig ();            SCM result = scm_i_mkbig ();
794            mpz_gcd(SCM_I_BIG_MPZ (result),            mpz_gcd (SCM_I_BIG_MPZ (result),
795                    SCM_I_BIG_MPZ (x),                     SCM_I_BIG_MPZ (x),
796                    SCM_I_BIG_MPZ (y));                     SCM_I_BIG_MPZ (y));
797            scm_remember_upto_here_2(x, y);            scm_remember_upto_here_2 (x, y);
798            return scm_i_normbig (result);            return scm_i_normbig (result);
799          }          }
800        else        else
# Line 864  SCM_DEFINE1 (scm_logand, "logand", scm_t Line 923  SCM_DEFINE1 (scm_logand, "logand", scm_t
923  {  {
924    long int nn1;    long int nn1;
925    
926    if (SCM_UNBNDP (n2)) {    if (SCM_UNBNDP (n2))
927      if (SCM_UNBNDP (n1)) {      {
928        return SCM_MAKINUM (-1);        if (SCM_UNBNDP (n1))
929      } else if (!SCM_NUMBERP (n1)) {          return SCM_MAKINUM (-1);
930        SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);        else if (!SCM_NUMBERP (n1))
931      } else if (SCM_NUMBERP (n1)) {          SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
932        return n1;        else if (SCM_NUMBERP (n1))
933      } else {          return n1;
934        SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);        else
935            SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
936      }      }
   }  
937    
938    if (SCM_INUMP (n1)) {    if (SCM_INUMP (n1))
939      nn1 = SCM_INUM (n1);      {
     if (SCM_INUMP (n2)) {  
       long nn2 = SCM_INUM (n2);  
       return SCM_MAKINUM (nn1 & nn2);  
     } else if SCM_BIGP (n2) {  
     intbig:  
       if (n1 == 0) return SCM_INUM0;  
       {  
         SCM result_z = scm_i_mkbig ();  
         mpz_t nn1_z;  
         mpz_init_set_si (nn1_z, nn1);  
         mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));  
         scm_remember_upto_here_1 (n2);  
         mpz_clear (nn1_z);  
         return scm_i_normbig (result_z);  
       }  
     } else {  
       SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);  
     }  
   } else if (SCM_BIGP (n1)) {  
     if (SCM_INUMP (n2)) {  
       SCM_SWAP (n1, n2);  
940        nn1 = SCM_INUM (n1);        nn1 = SCM_INUM (n1);
941        goto intbig;        if (SCM_INUMP (n2))
942      } else if (SCM_BIGP (n2)) {          {
943        SCM result_z = scm_i_mkbig ();            long nn2 = SCM_INUM (n2);
944        mpz_and (SCM_I_BIG_MPZ (result_z),            return SCM_MAKINUM (nn1 & nn2);
945                 SCM_I_BIG_MPZ (n1),          }
946                 SCM_I_BIG_MPZ (n2));        else if SCM_BIGP (n2)
947        scm_remember_upto_here_2 (n1, n2);          {
948        return scm_i_normbig (result_z);          intbig:
949      } else {            if (n1 == 0)
950        SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);              return SCM_INUM0;
951              {
952                SCM result_z = scm_i_mkbig ();
953                mpz_t nn1_z;
954                mpz_init_set_si (nn1_z, nn1);
955                mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
956                scm_remember_upto_here_1 (n2);
957                mpz_clear (nn1_z);
958                return scm_i_normbig (result_z);
959              }
960            }
961          else
962            SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
963      }      }
964    } else {    else if (SCM_BIGP (n1))
965        {
966          if (SCM_INUMP (n2))
967            {
968              SCM_SWAP (n1, n2);
969              nn1 = SCM_INUM (n1);
970              goto intbig;
971            }
972          else if (SCM_BIGP (n2))
973            {
974              SCM result_z = scm_i_mkbig ();
975              mpz_and (SCM_I_BIG_MPZ (result_z),
976                       SCM_I_BIG_MPZ (n1),
977                       SCM_I_BIG_MPZ (n2));
978              scm_remember_upto_here_2 (n1, n2);
979              return scm_i_normbig (result_z);
980            }
981          else
982            SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
983        }
984      else
985      SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);      SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
   }  
986  }  }
987  #undef FUNC_NAME  #undef FUNC_NAME
988    
# Line 930  SCM_DEFINE1 (scm_logior, "logior", scm_t Line 999  SCM_DEFINE1 (scm_logior, "logior", scm_t
999  {  {
1000    long int nn1;    long int nn1;
1001    
1002    if (SCM_UNBNDP (n2)) {    if (SCM_UNBNDP (n2))
1003      if (SCM_UNBNDP (n1)) {      {
1004        return SCM_INUM0;        if (SCM_UNBNDP (n1))
1005      } else if (SCM_NUMBERP (n1)) {          return SCM_INUM0;
1006        return n1;        else if (SCM_NUMBERP (n1))
1007      } else {          return n1;
1008        SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);        else
1009            SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
1010      }      }
   }  
1011    
1012    if (SCM_INUMP (n1)) {    if (SCM_INUMP (n1))
1013      nn1 = SCM_INUM (n1);      {
     if (SCM_INUMP (n2)) {  
       long nn2 = SCM_INUM (n2);  
       return SCM_MAKINUM (nn1 | nn2);  
     } else if (SCM_BIGP (n2)) {  
     intbig:  
       if (nn1 == 0) return n2;  
       {  
         SCM result_z = scm_i_mkbig ();  
         mpz_t nn1_z;  
         mpz_init_set_si (nn1_z, nn1);  
         mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));  
         scm_remember_upto_here_1 (n2);  
         mpz_clear (nn1_z);  
         return result_z;  
       }  
     } else {  
       SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);  
     }  
   } else if (SCM_BIGP (n1)) {  
     if (SCM_INUMP (n2)) {  
       SCM_SWAP (n1, n2);  
1014        nn1 = SCM_INUM (n1);        nn1 = SCM_INUM (n1);
1015        goto intbig;        if (SCM_INUMP (n2))
1016      } else if (SCM_BIGP (n2)) {          {
1017        SCM result_z = scm_i_mkbig ();            long nn2 = SCM_INUM (n2);
1018        mpz_ior (SCM_I_BIG_MPZ (result_z),            return SCM_MAKINUM (nn1 | nn2);
1019                 SCM_I_BIG_MPZ (n1),          }
1020                 SCM_I_BIG_MPZ (n2));        else if (SCM_BIGP (n2))
1021        scm_remember_upto_here_2 (n1, n2);          {
1022        return result_z;          intbig:
1023      } else {            if (nn1 == 0)
1024        SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);              return n2;
1025              {
1026                SCM result_z = scm_i_mkbig ();
1027                mpz_t nn1_z;
1028                mpz_init_set_si (nn1_z, nn1);
1029                mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
1030                scm_remember_upto_here_1 (n2);
1031                mpz_clear (nn1_z);
1032                return result_z;
1033              }
1034            }
1035          else
1036            SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1037      }      }
1038    } else {    else if (SCM_BIGP (n1))
1039        {
1040          if (SCM_INUMP (n2))
1041            {
1042              SCM_SWAP (n1, n2);
1043              nn1 = SCM_INUM (n1);
1044              goto intbig;
1045            }
1046          else if (SCM_BIGP (n2))
1047            {
1048              SCM result_z = scm_i_mkbig ();
1049              mpz_ior (SCM_I_BIG_MPZ (result_z),
1050                       SCM_I_BIG_MPZ (n1),
1051                       SCM_I_BIG_MPZ (n2));
1052              scm_remember_upto_here_2 (n1, n2);
1053              return result_z;
1054            }
1055          else
1056            SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1057        }
1058      else
1059      SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);      SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
   }  
1060  }  }
1061  #undef FUNC_NAME  #undef FUNC_NAME
1062    
# Line 996  SCM_DEFINE1 (scm_logxor, "logxor", scm_t Line 1075  SCM_DEFINE1 (scm_logxor, "logxor", scm_t
1075  {  {
1076    long int nn1;    long int nn1;
1077    
1078    if (SCM_UNBNDP (n2)) {    if (SCM_UNBNDP (n2))
1079      if (SCM_UNBNDP (n1)) {      {
1080        return SCM_INUM0;        if (SCM_UNBNDP (n1))
1081      } else if (SCM_NUMBERP (n1)) {          return SCM_INUM0;
1082        return n1;        else if (SCM_NUMBERP (n1))
1083      } else {          return n1;
1084        SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);        else
1085            SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
1086      }      }
   }  
1087    
1088    if (SCM_INUMP (n1)) {    if (SCM_INUMP (n1))
1089      nn1 = SCM_INUM (n1);      {
     if (SCM_INUMP (n2)) {  
       long nn2 = SCM_INUM (n2);  
       return SCM_MAKINUM (nn1 ^ nn2);  
     } else if (SCM_BIGP (n2)) {  
     intbig:  
       {  
         SCM result_z = scm_i_mkbig ();  
         mpz_t nn1_z;  
         mpz_init_set_si (nn1_z, nn1);  
         mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));  
         scm_remember_upto_here_1 (n2);  
         mpz_clear (nn1_z);  
         return scm_i_normbig (result_z);  
       }  
     } else {  
       SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);  
     }  
   } else if (SCM_BIGP (n1)) {  
     if (SCM_INUMP (n2)) {  
       SCM_SWAP (n1, n2);  
1090        nn1 = SCM_INUM (n1);        nn1 = SCM_INUM (n1);
1091        goto intbig;        if (SCM_INUMP (n2))
1092      } else if (SCM_BIGP (n2)) {          {
1093        SCM result_z = scm_i_mkbig ();            long nn2 = SCM_INUM (n2);
1094        mpz_xor (SCM_I_BIG_MPZ (result_z),            return SCM_MAKINUM (nn1 ^ nn2);
1095                 SCM_I_BIG_MPZ (n1),          }
1096                 SCM_I_BIG_MPZ (n2));        else if (SCM_BIGP (n2))
1097        scm_remember_upto_here_2 (n1, n2);          {
1098        return scm_i_normbig (result_z);          intbig:
1099      } else {            {
1100        SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);              SCM result_z = scm_i_mkbig ();
1101                mpz_t nn1_z;
1102                mpz_init_set_si (nn1_z, nn1);
1103                mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
1104                scm_remember_upto_here_1 (n2);
1105                mpz_clear (nn1_z);
1106                return scm_i_normbig (result_z);
1107              }
1108            }
1109          else
1110            SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1111      }      }
1112    } else {    else if (SCM_BIGP (n1))
1113        {
1114          if (SCM_INUMP (n2))
1115            {
1116              SCM_SWAP (n1, n2);
1117              nn1 = SCM_INUM (n1);
1118              goto intbig;
1119            }
1120          else if (SCM_BIGP (n2))
1121            {
1122              SCM result_z = scm_i_mkbig ();
1123              mpz_xor (SCM_I_BIG_MPZ (result_z),
1124                       SCM_I_BIG_MPZ (n1),
1125                       SCM_I_BIG_MPZ (n2));
1126              scm_remember_upto_here_2 (n1, n2);
1127              return scm_i_normbig (result_z);
1128            }
1129          else
1130            SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1131        }
1132      else
1133      SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);      SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
   }  
1134  }  }
1135  #undef FUNC_NAME  #undef FUNC_NAME
1136    
# Line 1058  SCM_DEFINE (scm_logtest, "logtest", 2, 0 Line 1146  SCM_DEFINE (scm_logtest, "logtest", 2, 0
1146  {  {
1147    long int nj;    long int nj;
1148    
1149    if (SCM_INUMP (j)) {    if (SCM_INUMP (j))
1150      nj = SCM_INUM (j);      {
     if (SCM_INUMP (k)) {  
       long nk = SCM_INUM (k);  
       return SCM_BOOL (nj & nk);  
     } else if (SCM_BIGP (k)) {  
     intbig:  
       if (nj == 0) return SCM_BOOL_F;  
       {  
         SCM result;  
         mpz_t nj_z;  
         mpz_init_set_si (nj_z, nj);  
         mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k));  
         scm_remember_upto_here_1 (k);  
         result = SCM_BOOL (mpz_sgn (nj_z) != 0);  
         mpz_clear (nj_z);  
         return result;  
       }  
     } else {  
       SCM_WRONG_TYPE_ARG (SCM_ARG2, k);  
     }  
   } else if (SCM_BIGP (j)) {  
     if (SCM_INUMP (k)) {  
       SCM_SWAP (j, k);  
1151        nj = SCM_INUM (j);        nj = SCM_INUM (j);
1152        goto intbig;        if (SCM_INUMP (k))
1153      } else if (SCM_BIGP (k)) {          {
1154        SCM result;            long nk = SCM_INUM (k);
1155        mpz_t result_z;            return SCM_BOOL (nj & nk);
1156        mpz_init (result_z);          }
1157        mpz_and (result_z,        else if (SCM_BIGP (k))
1158                 SCM_I_BIG_MPZ (j),          {
1159                 SCM_I_BIG_MPZ (k));          intbig:
1160        scm_remember_upto_here_2 (j, k);            if (nj == 0)
1161        result = SCM_BOOL (mpz_sgn (result_z) != 0);              return SCM_BOOL_F;
1162        mpz_clear (result_z);            {
1163        return result;              SCM result;
1164      } else {              mpz_t nj_z;
1165        SCM_WRONG_TYPE_ARG (SCM_ARG2, k);              mpz_init_set_si (nj_z, nj);
1166                mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k));
1167                scm_remember_upto_here_1 (k);
1168                result = SCM_BOOL (mpz_sgn (nj_z) != 0);
1169                mpz_clear (nj_z);
1170                return result;
1171              }
1172            }
1173          else
1174            SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
1175        }
1176      else if (SCM_BIGP (j))
1177        {
1178          if (SCM_INUMP (k))
1179            {
1180              SCM_SWAP (j, k);
1181              nj = SCM_INUM (j);
1182              goto intbig;
1183            }
1184          else if (SCM_BIGP (k))
1185            {
1186              SCM result;
1187              mpz_t result_z;
1188              mpz_init (result_z);
1189              mpz_and (result_z,
1190                       SCM_I_BIG_MPZ (j),
1191                       SCM_I_BIG_MPZ (k));
1192              scm_remember_upto_here_2 (j, k);
1193              result = SCM_BOOL (mpz_sgn (result_z) != 0);
1194              mpz_clear (result_z);
1195              return result;
1196            }
1197          else
1198            SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
1199      }      }
1200    } else {    else
1201      SCM_WRONG_TYPE_ARG (SCM_ARG1, j);      SCM_WRONG_TYPE_ARG (SCM_ARG1, j);
   }  
1202  }  }
1203  #undef FUNC_NAME  #undef FUNC_NAME
1204    
# Line 1122  SCM_DEFINE (scm_logbit_p, "logbit?", 2, Line 1220  SCM_DEFINE (scm_logbit_p, "logbit?", 2,
1220    SCM_VALIDATE_INUM_MIN (SCM_ARG1, index, 0);    SCM_VALIDATE_INUM_MIN (SCM_ARG1, index, 0);
1221    iindex = (unsigned long int) SCM_INUM (index);    iindex = (unsigned long int) SCM_INUM (index);
1222    
1223    if (SCM_INUMP (j)) {    if (SCM_INUMP (j))
1224      return SCM_BOOL ((1L << iindex) & SCM_INUM (j));      return SCM_BOOL ((1L << iindex) & SCM_INUM (j));
1225    } else if (SCM_BIGP (j)) {    else if (SCM_BIGP (j))
1226      int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex);      {
1227      scm_remember_upto_here_1 (j);        int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex);
1228      return SCM_BOOL (val);        scm_remember_upto_here_1 (j);
1229    } else {        return SCM_BOOL (val);
1230        }
1231      else
1232      SCM_WRONG_TYPE_ARG (SCM_ARG2, j);      SCM_WRONG_TYPE_ARG (SCM_ARG2, j);
   }  
1233  }  }
1234  #undef FUNC_NAME  #undef FUNC_NAME
1235    
# Line 1316  SCM_DEFINE (scm_bit_extract, "bit-extrac Line 1415  SCM_DEFINE (scm_bit_extract, "bit-extrac
1415    SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend);    SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend);
1416    SCM_ASSERT_RANGE (3, end, (iend >= istart));    SCM_ASSERT_RANGE (3, end, (iend >= istart));
1417    
1418    if (SCM_INUMP (n)) {    if (SCM_INUMP (n))
1419      long int in = SCM_INUM (n);      {
1420      unsigned long int bits = iend - istart;        long int in = SCM_INUM (n);
1421          unsigned long int bits = iend - istart;
1422    
1423      if (in < 0 && bits >= SCM_I_FIXNUM_BIT)        if (in < 0 && bits >= SCM_I_FIXNUM_BIT)
1424        {          {
1425          /* Since we emulate two's complement encoded numbers, this special            /* Since we emulate two's complement encoded numbers, this
1426           * case requires us to produce a result that has more bits than can be             * special case requires us to produce a result that has
1427           * stored in a fixnum.  Thus, we fall back to the more general             * more bits than can be stored in a fixnum.  Thus, we fall
1428           * algorithm that is used for bignums.               * back to the more general algorithm that is used for
1429           */             * bignums.
1430          goto generalcase;             */
1431        }            goto generalcase;
1432            }
1433    
1434      if (istart < SCM_I_FIXNUM_BIT)        if (istart < SCM_I_FIXNUM_BIT)
1435        {          {
1436          in = in >> istart;            in = in >> istart;
1437          if (bits < SCM_I_FIXNUM_BIT)            if (bits < SCM_I_FIXNUM_BIT)
1438            return SCM_MAKINUM (in & ((1L << bits) - 1));              return SCM_MAKINUM (in & ((1L << bits) - 1));
1439          else /* we know: in >= 0 */            else /* we know: in >= 0 */
1440            return SCM_MAKINUM (in);              return SCM_MAKINUM (in);
1441        }          }
1442      else if (in < 0)        else if (in < 0)
       {  
1443          return SCM_MAKINUM (-1L & ((1L << bits) - 1));          return SCM_MAKINUM (-1L & ((1L << bits) - 1));
1444        }        else
     else  
       {  
1445          return SCM_MAKINUM (0);          return SCM_MAKINUM (0);
1446        }      }
1447    } else if (SCM_BIGP (n)) {    else if (SCM_BIGP (n))
   generalcase:  
1448      {      {
1449        SCM num1 = SCM_MAKINUM (1L);      generalcase:
1450        SCM num2 = SCM_MAKINUM (2L);        {
1451        SCM bits = SCM_MAKINUM (iend - istart);          SCM num1 = SCM_MAKINUM (1L);
1452        SCM mask  = scm_difference (scm_integer_expt (num2, bits), num1);          SCM num2 = SCM_MAKINUM (2L);
1453        return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart)));          SCM bits = SCM_MAKINUM (iend - istart);
1454            SCM mask  = scm_difference (scm_integer_expt (num2, bits), num1);
1455            return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart)));
1456          }
1457      }      }
1458    } else {    else
1459      SCM_WRONG_TYPE_ARG (SCM_ARG1, n);      SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
   }  
1460  }  }
1461  #undef FUNC_NAME  #undef FUNC_NAME
1462    
# Line 1430  SCM_DEFINE (scm_integer_length, "integer Line 1529  SCM_DEFINE (scm_integer_length, "integer
1529              "@end lisp")              "@end lisp")
1530  #define FUNC_NAME s_scm_integer_length  #define FUNC_NAME s_scm_integer_length
1531  {  {
1532    if (SCM_INUMP (n)) {    if (SCM_INUMP (n))
1533      unsigned long int c = 0;      {
1534      unsigned int l = 4;        unsigned long int c = 0;
1535      long int nn = SCM_INUM (n);        unsigned int l = 4;
1536      if (nn < 0) {        long int nn = SCM_INUM (n);
1537        nn = -1 - nn;        if (nn < 0)
1538      };          nn = -1 - nn;
1539      while (nn) {        while (nn)
1540        c += 4;          {
1541        l = scm_ilentab [15 & nn];            c += 4;
1542        nn >>= 4;            l = scm_ilentab [15 & nn];
1543      };            nn >>= 4;
1544      return SCM_MAKINUM (c - 4 + l);          }
1545    } else if (SCM_BIGP (n)) {        return SCM_MAKINUM (c - 4 + l);
1546      /* mpz_sizeinbase looks at the absolute value of negatives, whereas we      }
1547         want a ones-complement.  If n is ...111100..00 then mpz_sizeinbase is    else if (SCM_BIGP (n))
1548         1 too big, so check for that and adjust.  */      {
1549      size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2);        /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
1550      if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0           want a ones-complement.  If n is ...111100..00 then mpz_sizeinbase is
1551          && mpz_scan0 (SCM_I_BIG_MPZ (n),  /* no 0 bits above the lowest 1 */           1 too big, so check for that and adjust.  */
1552                        mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX)        size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2);
1553        size--;        if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0
1554      scm_remember_upto_here_1 (n);            && mpz_scan0 (SCM_I_BIG_MPZ (n),  /* no 0 bits above the lowest 1 */
1555      return SCM_MAKINUM (size);                          mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX)
1556    } else {          size--;
1557          scm_remember_upto_here_1 (n);
1558          return SCM_MAKINUM (size);
1559        }
1560      else
1561      SCM_WRONG_TYPE_ARG (SCM_ARG1, n);      SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
   }  
1562  }  }
1563  #undef FUNC_NAME  #undef FUNC_NAME
1564    
# Line 1696  SCM_DEFINE (scm_number_to_string, "numbe Line 1798  SCM_DEFINE (scm_number_to_string, "numbe
1798  {  {
1799    int base;    int base;
1800    
1801    if (SCM_UNBNDP (radix)) {    if (SCM_UNBNDP (radix))
1802      base = 10;      base = 10;
1803    } else {    else
1804      SCM_VALIDATE_INUM (2, radix);      {
1805      base = SCM_INUM (radix);        SCM_VALIDATE_INUM (2, radix);
1806      /* FIXME: ask if range limit was OK, and if so, document */        base = SCM_INUM (radix);
1807      SCM_ASSERT_RANGE (2, radix, (base >= 2) && (base <= 36));        /* FIXME: ask if range limit was OK, and if so, document */
1808    }        SCM_ASSERT_RANGE (2, radix, (base >= 2) && (base <= 36));
1809        }
1810    
1811    if (SCM_INUMP (n)) {    if (SCM_INUMP (n))
1812      char num_buf [SCM_INTBUFLEN];      {
1813      size_t length = scm_iint2str (SCM_INUM (n), base, num_buf);        char num_buf [SCM_INTBUFLEN];
1814      return scm_mem2string (num_buf, length);        size_t length = scm_iint2str (SCM_INUM (n), base, num_buf);
1815    } else if (SCM_BIGP (n)) {        return scm_mem2string (num_buf, length);
1816      char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));      }
1817      scm_remember_upto_here_1 (n);    else if (SCM_BIGP (n))
1818      return scm_take0str (str);      {
1819    } else if (SCM_INEXACTP (n)) {        char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
1820      char num_buf [FLOBUFLEN];        scm_remember_upto_here_1 (n);
1821      return scm_mem2string (num_buf, iflo2str (n, num_buf));        return scm_take0str (str);
1822    } else {      }
1823      else if (SCM_INEXACTP (n))
1824        {
1825          char num_buf [FLOBUFLEN];
1826          return scm_mem2string (num_buf, iflo2str (n, num_buf));
1827        }
1828      else
1829      SCM_WRONG_TYPE_ARG (1, n);      SCM_WRONG_TYPE_ARG (1, n);
   }  
1830  }  }
1831  #undef FUNC_NAME  #undef FUNC_NAME
1832    
# Line 2382  scm_make_real (double x) Line 2490  scm_make_real (double x)
2490  SCM  SCM
2491  scm_make_complex (double x, double y)  scm_make_complex (double x, double y)
2492  {  {
2493    if (y == 0.0) {    if (y == 0.0)
2494      return scm_make_real (x);      return scm_make_real (x);
2495    } else {    else
2496      SCM z;      {
2497      SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (2*sizeof (double),        SCM z;
2498                                                       "complex"));        SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (2*sizeof (double),
2499      SCM_COMPLEX_REAL (z) = x;                                                         "complex"));
2500      SCM_COMPLEX_IMAG (z) = y;        SCM_COMPLEX_REAL (z) = x;
2501      return z;        SCM_COMPLEX_IMAG (z) = y;
2502    }        return z;
2503        }
2504  }  }
2505    
2506    
# Line 2454  SCM_DEFINE (scm_real_p, "rational?", 1, Line 2563  SCM_DEFINE (scm_real_p, "rational?", 1,
2563              "precision.")              "precision.")
2564  #define FUNC_NAME s_scm_real_p  #define FUNC_NAME s_scm_real_p
2565  {  {
2566    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
2567      return SCM_BOOL_T;      return SCM_BOOL_T;
2568    } else if (SCM_IMP (x)) {    else if (SCM_IMP (x))
2569      return SCM_BOOL_F;      return SCM_BOOL_F;
2570    } else if (SCM_REALP (x)) {    else if (SCM_REALP (x))
2571      return SCM_BOOL_T;      return SCM_BOOL_T;
2572    } else if (SCM_BIGP (x)) {    else if (SCM_BIGP (x))
2573      return SCM_BOOL_T;      return SCM_BOOL_T;
2574    } else {    else
2575      return SCM_BOOL_F;      return SCM_BOOL_F;
   }  
2576  }  }
2577  #undef FUNC_NAME  #undef FUNC_NAME
2578    
# Line 2510  SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, Line 2618  SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr,
2618  SCM  SCM
2619  scm_num_eq_p (SCM x, SCM y)  scm_num_eq_p (SCM x, SCM y)
2620  {  {
2621    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
2622      long xx = SCM_INUM (x);      {
2623      if (SCM_INUMP (y)) {        long xx = SCM_INUM (x);
2624        long yy = SCM_INUM (y);        if (SCM_INUMP (y))
2625        return SCM_BOOL (xx == yy);          {
2626      } else if (SCM_BIGP (y)) {            long yy = SCM_INUM (y);
2627        return SCM_BOOL_F;            return SCM_BOOL (xx == yy);
2628      } else if (SCM_REALP (y)) {          }
2629        return SCM_BOOL ((double) xx == SCM_REAL_VALUE (y));        else if (SCM_BIGP (y))
2630      } else if (SCM_COMPLEXP (y)) {          return SCM_BOOL_F;
2631        return SCM_BOOL (((double) xx == SCM_COMPLEX_REAL (y))        else if (SCM_REALP (y))
2632                         && (0.0 == SCM_COMPLEX_IMAG (y)));          return SCM_BOOL ((double) xx == SCM_REAL_VALUE (y));
2633      } else {        else if (SCM_COMPLEXP (y))
2634        SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);          return SCM_BOOL (((double) xx == SCM_COMPLEX_REAL (y))
2635      }                           && (0.0 == SCM_COMPLEX_IMAG (y)));
2636    } else if (SCM_BIGP (x)) {        else
2637      if (SCM_INUMP (y)) {          SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
2638        return SCM_BOOL_F;      }
2639      } else if (SCM_BIGP (y)) {    else if (SCM_BIGP (x))
2640        int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));      {
2641        scm_remember_upto_here_2 (x, y);        if (SCM_INUMP (y))
2642        return SCM_BOOL (0 == cmp);          return SCM_BOOL_F;
2643      } else if (SCM_REALP (y)) {        else if (SCM_BIGP (y))
2644        int cmp;          {
2645        if (xisnan (SCM_REAL_VALUE (y))) return SCM_BOOL_F;            int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2646        cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));            scm_remember_upto_here_2 (x, y);
2647        scm_remember_upto_here_1 (x);            return SCM_BOOL (0 == cmp);
2648        return SCM_BOOL (0 == cmp);          }
2649      } else if (SCM_COMPLEXP (y)) {        else if (SCM_REALP (y))
2650        int cmp;          {
2651        if (0.0 != SCM_COMPLEX_IMAG (y)) return SCM_BOOL_F;            int cmp;
2652        if (xisnan (SCM_COMPLEX_REAL (y))) return SCM_BOOL_F;            if (xisnan (SCM_REAL_VALUE (y)))
2653        cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y));              return SCM_BOOL_F;
2654        scm_remember_upto_here_1 (x);            cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
2655        return SCM_BOOL (0 == cmp);            scm_remember_upto_here_1 (x);
2656      } else {            return SCM_BOOL (0 == cmp);
2657        SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);          }
2658      }        else if (SCM_COMPLEXP (y))
2659    } else if (SCM_REALP (x)) {          {
2660      if (SCM_INUMP (y)) {            int cmp;
2661        return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y));            if (0.0 != SCM_COMPLEX_IMAG (y))
2662      } else if (SCM_BIGP (y)) {              return SCM_BOOL_F;
2663        int cmp;            if (xisnan (SCM_COMPLEX_REAL (y)))
2664        if (xisnan (SCM_REAL_VALUE (x))) return SCM_BOOL_F;              return SCM_BOOL_F;
2665        cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));            cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y));
2666        scm_remember_upto_here_1 (y);            scm_remember_upto_here_1 (x);
2667        return SCM_BOOL (0 == cmp);            return SCM_BOOL (0 == cmp);
2668      } else if (SCM_REALP (y)) {          }
2669        return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));        else
2670      } else if (SCM_COMPLEXP (y)) {          SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
2671        return SCM_BOOL ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))      }
2672                         && (0.0 == SCM_COMPLEX_IMAG (y)));    else if (SCM_REALP (x))
2673      } else {      {
2674        SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);        if (SCM_INUMP (y))
2675      }          return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y));
2676    } else if (SCM_COMPLEXP (x)) {        else if (SCM_BIGP (y))
2677      if (SCM_INUMP (y)) {          {
2678        return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y))            int cmp;
2679                         && (SCM_COMPLEX_IMAG (x) == 0.0));            if (xisnan (SCM_REAL_VALUE (x)))
2680      } else if (SCM_BIGP (y)) {              return SCM_BOOL_F;
2681        int cmp;            cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
2682        if (0.0 != SCM_COMPLEX_IMAG (x)) return SCM_BOOL_F;            scm_remember_upto_here_1 (y);
2683        if (xisnan (SCM_COMPLEX_REAL (x))) return SCM_BOOL_F;            return SCM_BOOL (0 == cmp);
2684        cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x));          }
2685        scm_remember_upto_here_1 (y);        else if (SCM_REALP (y))
2686        return SCM_BOOL (0 == cmp);          return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
2687      } else if (SCM_REALP (y)) {        else if (SCM_COMPLEXP (y))
2688        return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))          return SCM_BOOL ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))
2689                         && (SCM_COMPLEX_IMAG (x) == 0.0));                           && (0.0 == SCM_COMPLEX_IMAG (y)));
2690      } else if (SCM_COMPLEXP (y)) {        else
2691        return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))          SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
                        && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));  
     } else {  
       SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);  
2692      }      }
2693    } else {    else if (SCM_COMPLEXP (x))
2694        {
2695          if (SCM_INUMP (y))
2696            return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y))
2697                             && (SCM_COMPLEX_IMAG (x) == 0.0));
2698          else if (SCM_BIGP (y))
2699            {
2700              int cmp;
2701              if (0.0 != SCM_COMPLEX_IMAG (x))
2702                return SCM_BOOL_F;
2703              if (xisnan (SCM_COMPLEX_REAL (x)))
2704                return SCM_BOOL_F;
2705              cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x));
2706              scm_remember_upto_here_1 (y);
2707              return SCM_BOOL (0 == cmp);
2708            }
2709          else if (SCM_REALP (y))
2710            return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
2711                             && (SCM_COMPLEX_IMAG (x) == 0.0));
2712          else if (SCM_COMPLEXP (y))
2713            return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
2714                             && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
2715          else
2716            SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
2717        }
2718      else
2719      SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);      SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
   }  
2720  }  }
2721    
2722    
# Line 2598  SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsub Line 2727  SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsub
2727  SCM  SCM
2728  scm_less_p (SCM x, SCM y)  scm_less_p (SCM x, SCM y)
2729  {  {
2730    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
2731      long xx = SCM_INUM (x);      {
2732      if (SCM_INUMP (y)) {        long xx = SCM_INUM (x);
2733        long yy = SCM_INUM (y);        if (SCM_INUMP (y))
2734        return SCM_BOOL (xx < yy);          {
2735      } else if (SCM_BIGP (y)) {            long yy = SCM_INUM (y);
2736        int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));            return SCM_BOOL (xx < yy);
2737        scm_remember_upto_here_1 (y);          }
2738        return SCM_BOOL (sgn > 0);        else if (SCM_BIGP (y))
2739      } else if (SCM_REALP (y)) {          {
2740        return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y));            int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
2741      } else {            scm_remember_upto_here_1 (y);
2742        SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);            return SCM_BOOL (sgn > 0);
2743            }
2744          else if (SCM_REALP (y))
2745            return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y));
2746          else
2747            SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
2748      }      }
2749    } else if (SCM_BIGP (x)) {    else if (SCM_BIGP (x))
2750      if (SCM_INUMP (y)) {      {
2751        int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));        if (SCM_INUMP (y))
2752        scm_remember_upto_here_1 (x);          {
2753        return SCM_BOOL (sgn < 0);            int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2754      } else if (SCM_BIGP (y)) {            scm_remember_upto_here_1 (x);
2755        int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));            return SCM_BOOL (sgn < 0);
2756        scm_remember_upto_here_2 (x, y);          }
2757        return SCM_BOOL (cmp < 0);        else if (SCM_BIGP (y))
2758      } else if (SCM_REALP (y)) {          {
2759        int cmp;            int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2760        if (xisnan (SCM_REAL_VALUE (y))) return SCM_BOOL_F;            scm_remember_upto_here_2 (x, y);
2761        cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));            return SCM_BOOL (cmp < 0);
2762        scm_remember_upto_here_1 (x);          }
2763        return SCM_BOOL (cmp < 0);        else if (SCM_REALP (y))
2764      } else {          {
2765        SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);            int cmp;
2766      }            if (xisnan (SCM_REAL_VALUE (y)))
2767    } else if (SCM_REALP (x)) {              return SCM_BOOL_F;
2768      if (SCM_INUMP (y)) {            cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
2769        return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y));            scm_remember_upto_here_1 (x);
2770      } else if (SCM_BIGP (y)) {            return SCM_BOOL (cmp < 0);
2771        int cmp;          }
2772        if (xisnan (SCM_REAL_VALUE (x))) return SCM_BOOL_F;        else
2773        cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));          SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
       scm_remember_upto_here_1 (y);  
       return SCM_BOOL (cmp > 0);  
     } else if (SCM_REALP (y)) {  
       return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));  
     } else {  
       SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);  
2774      }      }
2775    } else {    else if (SCM_REALP (x))
2776        {
2777          if (SCM_INUMP (y))
2778            return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y));
2779          else if (SCM_BIGP (y))
2780            {
2781              int cmp;
2782              if (xisnan (SCM_REAL_VALUE (x)))
2783                return SCM_BOOL_F;
2784              cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
2785              scm_remember_upto_here_1 (y);
2786              return SCM_BOOL (cmp > 0);
2787            }
2788          else if (SCM_REALP (y))
2789            return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
2790          else
2791            SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
2792        }
2793      else
2794      SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);      SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
   }  
2795  }  }
2796    
2797    
# Line 2715  SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, s Line 2860  SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, s
2860  SCM  SCM
2861  scm_zero_p (SCM z)  scm_zero_p (SCM z)
2862  {  {
2863    if (SCM_INUMP (z)) {    if (SCM_INUMP (z))
2864      return SCM_BOOL (SCM_EQ_P (z, SCM_INUM0));      return SCM_BOOL (SCM_EQ_P (z, SCM_INUM0));
2865    } else if (SCM_BIGP (z)) {    else if (SCM_BIGP (z))
2866      return SCM_BOOL_F;      return SCM_BOOL_F;
2867    } else if (SCM_REALP (z)) {    else if (SCM_REALP (z))
2868      return SCM_BOOL (SCM_REAL_VALUE (z) == 0.0);      return SCM_BOOL (SCM_REAL_VALUE (z) == 0.0);
2869    } else if (SCM_COMPLEXP (z)) {    else if (SCM_COMPLEXP (z))
2870      return SCM_BOOL (SCM_COMPLEX_REAL (z) == 0.0      return SCM_BOOL (SCM_COMPLEX_REAL (z) == 0.0
2871                       && SCM_COMPLEX_IMAG (z) == 0.0);                       && SCM_COMPLEX_IMAG (z) == 0.0);
2872    } else {    else
2873      SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);      SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);
   }  
2874  }  }
2875    
2876    
# Line 2737  SCM_GPROC (s_positive_p, "positive?", 1, Line 2881  SCM_GPROC (s_positive_p, "positive?", 1,
2881  SCM  SCM
2882  scm_positive_p (SCM x)  scm_positive_p (SCM x)
2883  {  {
2884    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
2885      return SCM_BOOL (SCM_INUM (x) > 0);      return SCM_BOOL (SCM_INUM (x) > 0);
2886    } else if (SCM_BIGP (x)) {    else if (SCM_BIGP (x))
2887      int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));      {
2888      scm_remember_upto_here_1 (x);        int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2889      return SCM_BOOL (sgn > 0);        scm_remember_upto_here_1 (x);
2890    } else if (SCM_REALP (x)) {        return SCM_BOOL (sgn > 0);
2891        }
2892      else if (SCM_REALP (x))
2893      return SCM_BOOL(SCM_REAL_VALUE (x) > 0.0);      return SCM_BOOL(SCM_REAL_VALUE (x) > 0.0);
2894    } else {    else
2895      SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);      SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);
   }  
2896  }  }
2897    
2898    
# Line 2758  SCM_GPROC (s_negative_p, "negative?", 1, Line 2903  SCM_GPROC (s_negative_p, "negative?", 1,
2903  SCM  SCM
2904  scm_negative_p (SCM x)  scm_negative_p (SCM x)
2905  {  {
2906    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
2907      return SCM_BOOL (SCM_INUM (x) < 0);      return SCM_BOOL (SCM_INUM (x) < 0);
2908    } else if (SCM_BIGP (x)) {    else if (SCM_BIGP (x))
2909      int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));      {
2910      scm_remember_upto_here_1 (x);        int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2911      return SCM_BOOL (sgn < 0);        scm_remember_upto_here_1 (x);
2912    } else if (SCM_REALP (x)) {        return SCM_BOOL (sgn < 0);
2913        }
2914      else if (SCM_REALP (x))
2915      return SCM_BOOL(SCM_REAL_VALUE (x) < 0.0);      return SCM_BOOL(SCM_REAL_VALUE (x) < 0.0);
2916    } else {    else
2917      SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);      SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);
   }  
2918  }  }
2919    
2920    
# Line 2778  SCM_GPROC1 (s_max, "max", scm_tc7_asubr, Line 2924  SCM_GPROC1 (s_max, "max", scm_tc7_asubr,
2924  SCM  SCM
2925  scm_max (SCM x, SCM y)  scm_max (SCM x, SCM y)
2926  {  {
2927    if (SCM_UNBNDP (y)) {    if (SCM_UNBNDP (y))
2928      if (SCM_UNBNDP (x)) {      {
2929        SCM_WTA_DISPATCH_0 (g_max, s_max);        if (SCM_UNBNDP (x))
2930      } else if (SCM_NUMBERP (x)) {          SCM_WTA_DISPATCH_0 (g_max, s_max);
2931        return x;        else if (SCM_NUMBERP (x))
2932      } else {          return x;
2933        SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);        else
2934            SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);
2935      }      }
   }  
2936        
2937    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
2938      long xx = SCM_INUM (x);      {
2939      if (SCM_INUMP (y)) {        long xx = SCM_INUM (x);
2940        long yy = SCM_INUM (y);        if (SCM_INUMP (y))
2941        return (xx < yy) ? y : x;          {
2942      } else if (SCM_BIGP (y)) {            long yy = SCM_INUM (y);
2943        int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));            return (xx < yy) ? y : x;
2944        scm_remember_upto_here_1 (y);          }
2945        return (sgn < 0) ? x : y;        else if (SCM_BIGP (y))
2946      } else if (SCM_REALP (y)) {          {
2947        double z = xx;            int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
2948        /* if y==NaN then ">" is false and we return NaN */            scm_remember_upto_here_1 (y);
2949        return (z > SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;            return (sgn < 0) ? x : y;
2950      } else {          }
2951        SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);        else if (SCM_REALP (y))
2952            {
2953              double z = xx;
2954              /* if y==NaN then ">" is false and we return NaN */
2955              return (z > SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;
2956            }
2957          else
2958            SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
2959      }      }
2960    } else if (SCM_BIGP (x)) {    else if (SCM_BIGP (x))
2961      if (SCM_INUMP (y)) {      {
2962        int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));        if (SCM_INUMP (y))
2963        scm_remember_upto_here_1 (x);          {
2964        return (sgn < 0) ? y : x;            int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2965      } else if (SCM_BIGP (y)) {            scm_remember_upto_here_1 (x);
2966        int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));            return (sgn < 0) ? y : x;
2967        scm_remember_upto_here_2 (x, y);          }
2968        return (cmp > 0) ? x : y;        else if (SCM_BIGP (y))
2969      } else if (SCM_REALP (y)) {          {
2970        double yy = SCM_REAL_VALUE (y);            int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2971        int cmp;            scm_remember_upto_here_2 (x, y);
2972        if (xisnan (yy))            return (cmp > 0) ? x : y;
2973          return y;          }
2974        cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);        else if (SCM_REALP (y))
2975        scm_remember_upto_here_1 (x);          {
2976        return (cmp > 0) ? x : y;            double yy = SCM_REAL_VALUE (y);
2977      } else {            int cmp;
2978        SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);            if (xisnan (yy))
2979      }              return y;
2980    } else if (SCM_REALP (x)) {            cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
2981      if (SCM_INUMP (y)) {            scm_remember_upto_here_1 (x);
2982        double z = SCM_INUM (y);            return (cmp > 0) ? x : y;
2983        /* if x==NaN then "<" is false and we return NaN */          }
2984        return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x;        else
2985      } else if (SCM_BIGP (y)) {          SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
2986        double xx = SCM_REAL_VALUE (x);      }
2987        int cmp;    else if (SCM_REALP (x))
2988        if (xisnan (xx))      {
2989          return x;        if (SCM_INUMP (y))
2990        cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);          {
2991        scm_remember_upto_here_1 (y);            double z = SCM_INUM (y);
2992        return (cmp < 0) ? x : y;            /* if x==NaN then "<" is false and we return NaN */
2993      } else if (SCM_REALP (y)) {            return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x;
2994        /* if x==NaN then our explicit check means we return NaN          }
2995           if y==NaN then ">" is false and we return NaN        else if (SCM_BIGP (y))
2996           calling isnan is unavoidable, since it's the only way to know          {
2997           which of x or y causes any compares to be false */            double xx = SCM_REAL_VALUE (x);
2998        double xx = SCM_REAL_VALUE (x);            int cmp;
2999        return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y;            if (xisnan (xx))
3000      } else {              return x;
3001        SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);            cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3002              scm_remember_upto_here_1 (y);
3003              return (cmp < 0) ? x : y;
3004            }
3005          else if (SCM_REALP (y))
3006            {
3007              /* if x==NaN then our explicit check means we return NaN
3008                 if y==NaN then ">" is false and we return NaN
3009                 calling isnan is unavoidable, since it's the only way to know
3010                 which of x or y causes any compares to be false */
3011              double xx = SCM_REAL_VALUE (x);
3012              return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y;
3013            }
3014          else
3015            SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3016      }      }
3017    } else {    else
3018      SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);      SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
   }  
3019  }  }
3020    
3021    
# Line 2859  SCM_GPROC1 (s_min, "min", scm_tc7_asubr, Line 3025  SCM_GPROC1 (s_min, "min", scm_tc7_asubr,
3025  SCM  SCM
3026  scm_min (SCM x, SCM y)  scm_min (SCM x, SCM y)
3027  {  {
3028    if (SCM_UNBNDP (y)) {    if (SCM_UNBNDP (y))
3029      if (SCM_UNBNDP (x)) {      {
3030        SCM_WTA_DISPATCH_0 (g_min, s_min);        if (SCM_UNBNDP (x))
3031      } else if (SCM_NUMBERP (x)) {          SCM_WTA_DISPATCH_0 (g_min, s_min);
3032        return x;        else if (SCM_NUMBERP (x))
3033      } else {          return x;
3034        SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);        else
3035            SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);
3036      }      }
   }  
3037        
3038    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
3039      long xx = SCM_INUM (x);      {
3040      if (SCM_INUMP (y)) {        long xx = SCM_INUM (x);
3041        long yy = SCM_INUM (y);        if (SCM_INUMP (y))
3042        return (xx < yy) ? x : y;          {
3043      } else if (SCM_BIGP (y)) {            long yy = SCM_INUM (y);
3044        int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));            return (xx < yy) ? x : y;
3045        scm_remember_upto_here_1 (y);          }
3046        return (sgn < 0) ? y : x;        else if (SCM_BIGP (y))
3047      } else if (SCM_REALP (y)) {          {
3048        double z = xx;            int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
3049        /* if y==NaN then "<" is false and we return NaN */            scm_remember_upto_here_1 (y);
3050        return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;            return (sgn < 0) ? y : x;
3051      } else {          }
3052        SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);        else if (SCM_REALP (y))
3053            {
3054              double z = xx;
3055              /* if y==NaN then "<" is false and we return NaN */
3056              return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;
3057            }
3058          else
3059            SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
3060      }      }
3061    } else if (SCM_BIGP (x)) {    else if (SCM_BIGP (x))
3062      if (SCM_INUMP (y)) {      {
3063        int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));        if (SCM_INUMP (y))
3064        scm_remember_upto_here_1 (x);          {
3065        return (sgn < 0) ? x : y;            int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3066      } else if (SCM_BIGP (y)) {            scm_remember_upto_here_1 (x);
3067        int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));            return (sgn < 0) ? x : y;
3068        scm_remember_upto_here_2 (x, y);          }
3069        return (cmp > 0) ? y : x;        else if (SCM_BIGP (y))
3070      } else if (SCM_REALP (y)) {          {
3071        double yy = SCM_REAL_VALUE (y);            int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3072        int cmp;            scm_remember_upto_here_2 (x, y);
3073        if (xisnan (yy))            return (cmp > 0) ? y : x;
3074          return y;          }
3075        cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);        else if (SCM_REALP (y))
3076        scm_remember_upto_here_1 (x);          {
3077        return (cmp > 0) ? y : x;            double yy = SCM_REAL_VALUE (y);
3078      } else {            int cmp;
3079        SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);            if (xisnan (yy))
3080      }              return y;
3081    } else if (SCM_REALP (x)) {            cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
3082      if (SCM_INUMP (y)) {            scm_remember_upto_here_1 (x);
3083        double z = SCM_INUM (y);            return (cmp > 0) ? y : x;
3084        /* if x==NaN then "<" is false and we return NaN */          }
3085        return (z < SCM_REAL_VALUE (x)) ? scm_make_real (z) : x;        else
3086      } else if (SCM_BIGP (y)) {          SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
       double xx = SCM_REAL_VALUE (x);  
       int cmp;  
       if (xisnan (xx))  
         return x;  
       cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);  
       scm_remember_upto_here_1 (y);  
       return (cmp < 0) ? y : x;  
     } else if (SCM_REALP (y)) {  
       /* if x==NaN then our explicit check means we return NaN  
          if y==NaN then "<" is false and we return NaN  
          calling isnan is unavoidable, since it's the only way to know  
          which of x or y causes any compares to be false */  
       double xx = SCM_REAL_VALUE (x);  
       return (xisnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y;  
     } else {  
       SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);  
3087      }      }
3088    } else {    else if (SCM_REALP (x))
3089        {
3090          if (SCM_INUMP (y))
3091            {
3092              double z = SCM_INUM (y);
3093              /* if x==NaN then "<" is false and we return NaN */
3094              return (z < SCM_REAL_VALUE (x)) ? scm_make_real (z) : x;
3095            }
3096          else if (SCM_BIGP (y))
3097            {
3098              double xx = SCM_REAL_VALUE (x);
3099              int cmp;
3100              if (xisnan (xx))
3101                return x;
3102              cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3103              scm_remember_upto_here_1 (y);
3104              return (cmp < 0) ? y : x;
3105            }
3106          else if (SCM_REALP (y))
3107            {
3108              /* if x==NaN then our explicit check means we return NaN
3109                 if y==NaN then "<" is false and we return NaN
3110                 calling isnan is unavoidable, since it's the only way to know
3111                 which of x or y causes any compares to be false */
3112              double xx = SCM_REAL_VALUE (x);
3113              return (xisnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y;
3114            }
3115          else
3116            SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
3117        }
3118      else
3119      SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);      SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
   }  
3120  }  }
3121    
3122    
# Line 2975  scm_sum (SCM x, SCM y) Line 3161  scm_sum (SCM x, SCM y)
3161          }          }
3162        else        else
3163          SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);          SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3164      } else if (SCM_BIGP (x)) {      } else if (SCM_BIGP (x))
3165      if (SCM_INUMP (y)) {        {
3166        long int inum;          if (SCM_INUMP (y))
3167        int bigsgn;            {
3168      add_big_inum:              long int inum;
3169        inum = SCM_INUM (y);                    int bigsgn;
3170        if (inum == 0) return x;            add_big_inum:
3171        bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x));              inum = SCM_INUM (y);      
3172        if (inum < 0) {              if (inum == 0)
3173          SCM result = scm_i_mkbig ();                return x;
3174          mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum);              bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3175          scm_remember_upto_here_1 (x);              if (inum < 0)
3176          /* we know the result will have to be a bignum */                {
3177          if (bigsgn == -1) return result;                  SCM result = scm_i_mkbig ();
3178          return scm_i_normbig (result);                  mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum);
3179        } else {                  scm_remember_upto_here_1 (x);
3180          SCM result = scm_i_mkbig ();                  /* we know the result will have to be a bignum */
3181          mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum);                  if (bigsgn == -1)
3182          scm_remember_upto_here_1 (x);                    return result;
3183          /* we know the result will have to be a bignum */                  return scm_i_normbig (result);
3184          if (bigsgn == 1) return result;                }
3185          return result;              else
3186          return scm_i_normbig (result);                        {
3187                    SCM result = scm_i_mkbig ();
3188                    mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum);
3189                    scm_remember_upto_here_1 (x);
3190                    /* we know the result will have to be a bignum */
3191                    if (bigsgn == 1)
3192                      return result;
3193                    return scm_i_normbig (result);        
3194                  }
3195              }
3196            else if (SCM_BIGP (y))
3197              {
3198                SCM result = scm_i_mkbig ();
3199                int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3200                int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3201                mpz_add (SCM_I_BIG_MPZ (result),
3202                         SCM_I_BIG_MPZ (x),
3203                         SCM_I_BIG_MPZ (y));
3204                scm_remember_upto_here_2 (x, y);
3205                /* we know the result will have to be a bignum */
3206                if (sgn_x == sgn_y)
3207                  return result;
3208                return scm_i_normbig (result);
3209              }
3210            else if (SCM_REALP (y))
3211              {
3212                double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);
3213                scm_remember_upto_here_1 (x);
3214                return scm_make_real (result);
3215              }
3216            else if (SCM_COMPLEXP (y))
3217              {
3218                double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
3219                                    + SCM_COMPLEX_REAL (y));
3220                scm_remember_upto_here_1 (x);
3221                return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));
3222              }
3223            else
3224              SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3225        }        }
3226      else if (SCM_REALP (x))
3227        {
3228          if (SCM_INUMP (y))
3229            return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y));
3230          else if (SCM_BIGP (y))
3231            {
3232              double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);
3233              scm_remember_upto_here_1 (y);
3234              return scm_make_real (result);
3235            }
3236          else if (SCM_REALP (y))
3237            return scm_make_real (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
3238          else if (SCM_COMPLEXP (y))
3239            return scm_make_complex (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),
3240                                     SCM_COMPLEX_IMAG (y));
3241          else
3242            SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3243      }      }
3244      else if (SCM_BIGP (y)) {    else if (SCM_COMPLEXP (x))
3245        SCM result = scm_i_mkbig ();      {
3246        int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));        if (SCM_INUMP (y))
3247        int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));          return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y),
3248        mpz_add (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));                                   SCM_COMPLEX_IMAG (x));
3249        scm_remember_upto_here_2 (x, y);        else if (SCM_BIGP (y))
3250        /* we know the result will have to be a bignum */          {
3251        if (sgn_x == sgn_y) return result;            double real_part = (mpz_get_d (SCM_I_BIG_MPZ (y))
3252        return scm_i_normbig (result);                                + SCM_COMPLEX_REAL (x));
3253      }            scm_remember_upto_here_1 (y);
3254      else if (SCM_REALP (y)) {            return scm_make_complex (real_part, SCM_COMPLEX_IMAG (x));
3255        double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);          }
3256        scm_remember_upto_here_1 (x);        else if (SCM_REALP (y))
3257        return scm_make_real (result);          return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y),
3258      }                                   SCM_COMPLEX_IMAG (x));
3259      else if (SCM_COMPLEXP (y)) {        else if (SCM_COMPLEXP (y))
3260        double real_part = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_COMPLEX_REAL (y);          return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y),
3261        scm_remember_upto_here_1 (x);                                   SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y));
3262        return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));        else
3263      }          SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
     else SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);  
   } else if (SCM_REALP (x)) {  
     if (SCM_INUMP (y)) {  
       return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y));  
     } else if (SCM_BIGP (y)) {  
       double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);  
       scm_remember_upto_here_1 (y);  
       return scm_make_real (result);  
     } else if (SCM_REALP (y)) {  
       return scm_make_real (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));  
     } else if (SCM_COMPLEXP (y)) {  
       return scm_make_complex (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),  
                                SCM_COMPLEX_IMAG (y));  
     } else {  
       SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);  
     }  
   } else if (SCM_COMPLEXP (x)) {  
     if (SCM_INUMP (y)) {  
       return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y),  
                                SCM_COMPLEX_IMAG (x));  
     } else if (SCM_BIGP (y)) {  
       double real_part = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_COMPLEX_REAL (x);  
       scm_remember_upto_here_1 (y);  
       return scm_make_complex (real_part, SCM_COMPLEX_IMAG (x));  
     } else if (SCM_REALP (y)) {  
       return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y),  
                                SCM_COMPLEX_IMAG (x));  
     } else if (SCM_COMPLEXP (y)) {  
       return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y),  
                                SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y));  
     } else {  
       SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);  
3264      }      }
3265    } else {    else
3266      SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);      SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
   }  
3267  }  }
3268    
3269    
# Line 3092  scm_difference (SCM x, SCM y) Line 3300  scm_difference (SCM x, SCM y)
3300            SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);            SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
3301      }      }
3302        
3303    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
3304      if (SCM_INUMP (y)) {      {
3305        long int xx = SCM_INUM (x);        if (SCM_INUMP (y))
3306        long int yy = SCM_INUM (y);          {
3307        long int z = xx - yy;            long int xx = SCM_INUM (x);
3308        if (SCM_FIXABLE (z)) {            long int yy = SCM_INUM (y);
3309          return SCM_MAKINUM (z);            long int z = xx - yy;
3310        } else {            if (SCM_FIXABLE (z))
3311          return scm_i_long2big (z);              return SCM_MAKINUM (z);
3312        }            else
3313      } else if (SCM_BIGP (y)) {                    return scm_i_long2big (z);
3314        /* inum-x - big-y */          }
3315        long xx = SCM_INUM (x);        else if (SCM_BIGP (y))
3316            {
3317        if (xx == 0)            /* inum-x - big-y */
3318          return scm_i_clonebig (y, 0);            long xx = SCM_INUM (x);
       else  
         {  
           int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));  
           SCM result = scm_i_mkbig ();  
3319    
3320            if (xx >= 0)            if (xx == 0)
3321              mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y));              return scm_i_clonebig (y, 0);
3322            else            else
3323              {              {
3324                /* x - y == -(y + -x) */                int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3325                mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx);                SCM result = scm_i_mkbig ();
               mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));  
             }  
           scm_remember_upto_here_1 (y);  
3326    
3327            if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0))                if (xx >= 0)
3328              /* we know the result will have to be a bignum */                  mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y));
3329              return result;                else
3330            else                  {
3331              return scm_i_normbig (result);                    /* x - y == -(y + -x) */
3332          }                    mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx);
3333      } else if (SCM_REALP (y)) {                    mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
3334        long int xx = SCM_INUM (x);                  }
3335        return scm_make_real (xx - SCM_REAL_VALUE (y));                scm_remember_upto_here_1 (y);
     } else if (SCM_COMPLEXP (y)) {  
       long int xx = SCM_INUM (x);  
       return scm_make_complex (xx - SCM_COMPLEX_REAL (y),  
                                -SCM_COMPLEX_IMAG (y));  
     } else {  
       SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);  
     }  
   } else if (SCM_BIGP (x)) {  
     if (SCM_INUMP (y)) {  
       /* big-x - inum-y */  
       long yy = SCM_INUM (y);  
       int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));  
3336    
3337        scm_remember_upto_here_1 (x);                if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0))
3338        if (sgn_x == 0)                  /* we know the result will have to be a bignum */
3339          return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-yy);                  return result;
3340                  else
3341                    return scm_i_normbig (result);
3342                }
3343            }
3344          else if (SCM_REALP (y))
3345            {
3346              long int xx = SCM_INUM (x);
3347              return scm_make_real (xx - SCM_REAL_VALUE (y));
3348            }
3349          else if (SCM_COMPLEXP (y))
3350            {
3351              long int xx = SCM_INUM (x);
3352              return scm_make_complex (xx - SCM_COMPLEX_REAL (y),
3353                                       - SCM_COMPLEX_IMAG (y));
3354            }
3355        else        else
3356          {          SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3357            SCM result = scm_i_mkbig ();      }
3358      else if (SCM_BIGP (x))
3359        {
3360          if (SCM_INUMP (y))
3361            {
3362              /* big-x - inum-y */
3363              long yy = SCM_INUM (y);
3364              int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3365    
3366              scm_remember_upto_here_1 (x);
3367              if (sgn_x == 0)
3368                return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-yy);
3369              else
3370                {
3371                  SCM result = scm_i_mkbig ();
3372    
3373            mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);                mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
3374            scm_remember_upto_here_1 (x);                scm_remember_upto_here_1 (x);
3375    
3376            if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0))                if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0))
3377              /* we know the result will have to be a bignum */                  /* we know the result will have to be a bignum */
3378              return result;                  return result;
3379            else                else
3380              return scm_i_normbig (result);                  return scm_i_normbig (result);
3381          }              }
3382      }          }
3383      else if (SCM_BIGP (y))        else if (SCM_BIGP (y))
3384        {          {
3385          int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));            int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3386          int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));            int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3387          SCM result = scm_i_mkbig ();            SCM result = scm_i_mkbig ();
3388          mpz_sub (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));            mpz_sub (SCM_I_BIG_MPZ (result),
3389          scm_remember_upto_here_2 (x, y);                     SCM_I_BIG_MPZ (x),
3390          /* we know the result will have to be a bignum */                     SCM_I_BIG_MPZ (y));
3391          if ((sgn_x == 1) && (sgn_y == -1)) return result;            scm_remember_upto_here_2 (x, y);
3392          if ((sgn_x == -1) && (sgn_y == 1)) return result;            /* we know the result will have to be a bignum */
3393          return scm_i_normbig (result);            if ((sgn_x == 1) && (sgn_y == -1))
3394        }              return result;
3395      else if (SCM_REALP (y)) {            if ((sgn_x == -1) && (sgn_y == 1))
3396        double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);              return result;
3397        scm_remember_upto_here_1 (x);            return scm_i_normbig (result);
3398        return scm_make_real (result);          }
3399          else if (SCM_REALP (y))
3400            {
3401              double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);
3402              scm_remember_upto_here_1 (x);
3403              return scm_make_real (result);
3404            }
3405          else if (SCM_COMPLEXP (y))
3406            {
3407              double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
3408                                  - SCM_COMPLEX_REAL (y));
3409              scm_remember_upto_here_1 (x);
3410              return scm_make_complex (real_part, - SCM_COMPLEX_IMAG (y));      
3411            }
3412          else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3413      }      }
3414      else if (SCM_COMPLEXP (y)) {    else if (SCM_REALP (x))
3415        double real_part = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_COMPLEX_REAL (y);      {
3416        scm_remember_upto_here_1 (x);        if (SCM_INUMP (y))
3417        return scm_make_complex (real_part, - SCM_COMPLEX_IMAG (y));                return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y));
3418          else if (SCM_BIGP (y))
3419            {
3420              double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
3421              scm_remember_upto_here_1 (x);
3422              return scm_make_real (result);      
3423            }
3424          else if (SCM_REALP (y))
3425            return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
3426          else if (SCM_COMPLEXP (y))
3427            return scm_make_complex (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),
3428                                     -SCM_COMPLEX_IMAG (y));
3429          else
3430            SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3431      }      }
3432      else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);    else if (SCM_COMPLEXP (x))
3433    } else if (SCM_REALP (x)) {      {
3434      if (SCM_INUMP (y)) {        if (SCM_INUMP (y))
3435        return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y));          return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y),
3436      } else if (SCM_BIGP (y)) {                                   SCM_COMPLEX_IMAG (x));
3437        double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));        else if (SCM_BIGP (y))
3438        scm_remember_upto_here_1 (x);          {
3439        return scm_make_real (result);                  double real_part = (SCM_COMPLEX_REAL (x)
3440      } else if (SCM_REALP (y)) {                                - mpz_get_d (SCM_I_BIG_MPZ (y)));
3441        return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));            scm_remember_upto_here_1 (x);
3442      } else if (SCM_COMPLEXP (y)) {            return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));      
3443        return scm_make_complex (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),          }
3444                                 -SCM_COMPLEX_IMAG (y));        else if (SCM_REALP (y))
3445      } else {          return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y),
3446        SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);                                   SCM_COMPLEX_IMAG (x));
3447      }        else if (SCM_COMPLEXP (y))
3448    } else if (SCM_COMPLEXP (x)) {          return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y),
3449      if (SCM_INUMP (y)) {                                   SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y));
3450        return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y),        else
3451                                 SCM_COMPLEX_IMAG (x));          SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
     } else if (SCM_BIGP (y)) {  
       double real_part = SCM_COMPLEX_REAL (x) - mpz_get_d (SCM_I_BIG_MPZ (y));  
       scm_remember_upto_here_1 (x);  
       return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));        
     } else if (SCM_REALP (y)) {  
       return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y),  
                                SCM_COMPLEX_IMAG (x));  
     } else if (SCM_COMPLEXP (y)) {  
       return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y),  
                                SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y));  
     } else {  
       SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);  
3452      }      }
3453    } else {    else
3454      SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);      SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
   }  
3455  }  }
3456  #undef FUNC_NAME  #undef FUNC_NAME
3457    
# Line 3231  SCM_GPROC1 (s_product, "*", scm_tc7_asub Line 3463  SCM_GPROC1 (s_product, "*", scm_tc7_asub
3463  SCM  SCM
3464  scm_product (SCM x, SCM y)  scm_product (SCM x, SCM y)
3465  {  {
3466    if (SCM_UNBNDP (y)) {    if (SCM_UNBNDP (y))
3467      if (SCM_UNBNDP (x)) {      {
3468        return SCM_MAKINUM (1L);        if (SCM_UNBNDP (x))
3469      } else if (SCM_NUMBERP (x)) {          return SCM_MAKINUM (1L);
3470        return x;        else if (SCM_NUMBERP (x))
3471      } else {          return x;
3472        SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);        else
3473            SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);
3474      }      }
   }  
3475        
3476    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
3477      long xx;      {
3478          long xx;
3479    
3480    intbig:      intbig:
3481      xx = SCM_INUM (x);        xx = SCM_INUM (x);
3482    
3483      switch (xx)        switch (xx)
3484        {          {
3485          case 0: return x; break;          case 0: return x; break;
3486          case 1: return y; break;          case 1: return y; break;
3487        }          }
3488    
3489      if (SCM_INUMP (y)) {        if (SCM_INUMP (y))
3490        long yy = SCM_INUM (y);          {
3491        long kk = xx * yy;            long yy = SCM_INUM (y);
3492        SCM k = SCM_MAKINUM (kk);            long kk = xx * yy;
3493        if ((kk == SCM_INUM (k)) && (kk / xx == yy)) {            SCM k = SCM_MAKINUM (kk);
3494          return k;            if ((kk == SCM_INUM (k)) && (kk / xx == yy))
3495        } else {              return k;
3496          SCM result = scm_i_long2big (xx);            else
3497          mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);              {
3498          return scm_i_normbig (result);                SCM result = scm_i_long2big (xx);
3499        }                mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
3500      } else if (SCM_BIGP (y)) {                return scm_i_normbig (result);
3501        SCM result = scm_i_mkbig ();              }
3502        mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);          }
3503        scm_remember_upto_here_1 (y);        else if (SCM_BIGP (y))
3504        return result;          {
3505      } else if (SCM_REALP (y)) {            SCM result = scm_i_mkbig ();
3506        return scm_make_real (xx * SCM_REAL_VALUE (y));            mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);
3507      } else if (SCM_COMPLEXP (y)) {            scm_remember_upto_here_1 (y);
3508        return scm_make_complex (xx * SCM_COMPLEX_REAL (y),            return result;
3509                                 xx * SCM_COMPLEX_IMAG (y));          }
3510      } else {        else if (SCM_REALP (y))
3511        SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);          return scm_make_real (xx * SCM_REAL_VALUE (y));
3512      }        else if (SCM_COMPLEXP (y))
3513    } else if (SCM_BIGP (x)) {          return scm_make_complex (xx * SCM_COMPLEX_REAL (y),
3514      if (SCM_INUMP (y)) {                                   xx * SCM_COMPLEX_IMAG (y));
3515        SCM_SWAP (x, y);        else
3516        goto intbig;          SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3517      } else if (SCM_BIGP (y)) {      }
3518        SCM result = scm_i_mkbig ();    else if (SCM_BIGP (x))
3519        mpz_mul (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));      {
3520        scm_remember_upto_here_2 (x, y);        if (SCM_INUMP (y))
3521        return result;          {
3522      } else if (SCM_REALP (y)) {            SCM_SWAP (x, y);
3523        double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);            goto intbig;
3524        scm_remember_upto_here_1 (x);          }
3525        return scm_make_real (result);        else if (SCM_BIGP (y))
3526      } else if (SCM_COMPLEXP (y)) {          {
3527        double z = mpz_get_d (SCM_I_BIG_MPZ (x));            SCM result = scm_i_mkbig ();
3528        scm_remember_upto_here_1 (x);            mpz_mul (SCM_I_BIG_MPZ (result),
3529        return scm_make_complex (z * SCM_COMPLEX_REAL (y),                     SCM_I_BIG_MPZ (x),
3530                                 z * SCM_COMPLEX_IMAG (y));                     SCM_I_BIG_MPZ (y));
3531      } else {            scm_remember_upto_here_2 (x, y);
3532        SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);            return result;
3533      }          }
3534    } else if (SCM_REALP (x)) {        else if (SCM_REALP (y))
3535      if (SCM_INUMP (y)) {          {
3536        return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x));            double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
3537      } else if (SCM_BIGP (y)) {            scm_remember_upto_here_1 (x);
3538        double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);            return scm_make_real (result);
3539        scm_remember_upto_here_1 (y);          }
3540        return scm_make_real (result);        else if (SCM_COMPLEXP (y))
3541      } else if (SCM_REALP (y)) {          {
3542        return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));            double z = mpz_get_d (SCM_I_BIG_MPZ (x));
3543      } else if (SCM_COMPLEXP (y)) {            scm_remember_upto_here_1 (x);
3544        return scm_make_complex (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),            return scm_make_complex (z * SCM_COMPLEX_REAL (y),
3545                                 SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));                                     z * SCM_COMPLEX_IMAG (y));
3546      } else {          }
3547        SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);        else
3548      }          SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3549    } else if (SCM_COMPLEXP (x)) {      }
3550      if (SCM_INUMP (y)) {    else if (SCM_REALP (x))
3551        return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x),      {
3552                                 SCM_INUM (y) * SCM_COMPLEX_IMAG (x));        if (SCM_INUMP (y))
3553      } else if (SCM_BIGP (y)) {          return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x));
3554        double z = mpz_get_d (SCM_I_BIG_MPZ (y));        else if (SCM_BIGP (y))
3555        scm_remember_upto_here_1 (y);          {
3556        return scm_make_complex (z * SCM_COMPLEX_REAL (y),            double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
3557                                 z * SCM_COMPLEX_IMAG (y));            scm_remember_upto_here_1 (y);
3558      } else if (SCM_REALP (y)) {            return scm_make_real (result);
3559        return scm_make_complex (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),          }
3560                                 SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));        else if (SCM_REALP (y))
3561      } else if (SCM_COMPLEXP (y)) {          return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
3562        return scm_make_complex (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)        else if (SCM_COMPLEXP (y))
3563                                 - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),          return scm_make_complex (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
3564                                 SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)                                   SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
3565                                 + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));        else
3566      } else {          SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3567        SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);      }
3568      else if (SCM_COMPLEXP (x))
3569        {
3570          if (SCM_INUMP (y))
3571            return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x),
3572                                     SCM_INUM (y) * SCM_COMPLEX_IMAG (x));
3573          else if (SCM_BIGP (y))
3574            {
3575              double z = mpz_get_d (SCM_I_BIG_MPZ (y));
3576              scm_remember_upto_here_1 (y);
3577              return scm_make_complex (z * SCM_COMPLEX_REAL (y),
3578                                       z * SCM_COMPLEX_IMAG (y));
3579            }
3580          else if (SCM_REALP (y))
3581            return scm_make_complex (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),
3582                                     SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));
3583          else if (SCM_COMPLEXP (y))
3584            {
3585              return scm_make_complex (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)
3586                                       - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),
3587                                       SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)
3588                                       + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));
3589            }
3590          else
3591            SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3592      }      }
3593    } else {    else
3594      SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);      SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
   }  
3595  }  }
3596    
3597  double  double
3598  scm_num2dbl (SCM a, const char *why)  scm_num2dbl (SCM a, const char *why)
3599  #define FUNC_NAME why  #define FUNC_NAME why
3600  {  {
3601    if (SCM_INUMP (a)) {    if (SCM_INUMP (a))
3602      return (double) SCM_INUM (a);      return (double) SCM_INUM (a);
3603    } else if (SCM_BIGP (a)) {    else if (SCM_BIGP (a))
3604      double result = mpz_get_d (SCM_I_BIG_MPZ (a));      {
3605      scm_remember_upto_here_1 (a);        double result = mpz_get_d (SCM_I_BIG_MPZ (a));
3606      return result;        scm_remember_upto_here_1 (a);
3607    } else if (SCM_REALP (a)) {        return result;
3608        }
3609      else if (SCM_REALP (a))
3610      return (SCM_REAL_VALUE (a));      return (SCM_REAL_VALUE (a));
3611    } else {    else
3612      SCM_WRONG_TYPE_ARG (SCM_ARGn, a);      SCM_WRONG_TYPE_ARG (SCM_ARGn, a);
   }  
3613  }  }
3614  #undef FUNC_NAME  #undef FUNC_NAME
3615    
# Line 3399  scm_divide (SCM x, SCM y) Line 3656  scm_divide (SCM x, SCM y)
3656  {  {
3657    double a;    double a;
3658    
3659    if (SCM_UNBNDP (y)) {    if (SCM_UNBNDP (y))
3660      if (SCM_UNBNDP (x)) {      {
3661        SCM_WTA_DISPATCH_0 (g_divide, s_divide);        if (SCM_UNBNDP (x))
3662      } else if (SCM_INUMP (x)) {          SCM_WTA_DISPATCH_0 (g_divide, s_divide);
3663        long xx = SCM_INUM (x);        else if (SCM_INUMP (x))
3664        if (xx == 1 || xx == -1) {          {
3665          return x;            long xx = SCM_INUM (x);
3666              if (xx == 1 || xx == -1)
3667                return x;
3668  #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO  #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3669        } else if (xx == 0) {            else if (xx == 0)
3670          scm_num_overflow (s_divide);              scm_num_overflow (s_divide);
3671  #endif  #endif
3672        } else {            else
3673          return scm_make_real (1.0 / (double) xx);              return scm_make_real (1.0 / (double) xx);
3674        }          }
3675      } else if (SCM_BIGP (x)) {        else if (SCM_BIGP (x))
3676        return scm_make_real (1.0 / scm_i_big2dbl (x));          return scm_make_real (1.0 / scm_i_big2dbl (x));
3677      } else if (SCM_REALP (x)) {        else if (SCM_REALP (x))
3678        double xx = SCM_REAL_VALUE (x);          {
3679              double xx = SCM_REAL_VALUE (x);
3680  #ifndef ALLOW_DIVIDE_BY_ZERO  #ifndef ALLOW_DIVIDE_BY_ZERO
3681        if (xx == 0.0)            if (xx == 0.0)
3682          scm_num_overflow (s_divide);              scm_num_overflow (s_divide);
3683        else            else
3684  #endif  #endif
3685          return scm_make_real (1.0 / xx);              return scm_make_real (1.0 / xx);
3686      } else if (SCM_COMPLEXP (x)) {          }
3687        double r = SCM_COMPLEX_REAL (x);        else if (SCM_COMPLEXP (x))
3688        double i = SCM_COMPLEX_IMAG (x);          {
3689        if (r <= i) {            double r = SCM_COMPLEX_REAL (x);
3690          double t = r / i;            double i = SCM_COMPLEX_IMAG (x);
3691          double d = i * (1.0 + t * t);            if (r <= i)
3692          return scm_make_complex (t / d, -1.0 / d);              {
3693        } else {                double t = r / i;
3694          double t = i / r;                double d = i * (1.0 + t * t);
3695          double d = r * (1.0 + t * t);                return scm_make_complex (t / d, -1.0 / d);
3696          return scm_make_complex (1.0 / d, -t / d);              }
3697        }            else
3698      } else {              {
3699        SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);                double t = i / r;
3700                  double d = r * (1.0 + t * t);
3701                  return scm_make_complex (1.0 / d, -t / d);
3702                }
3703            }
3704          else
3705            SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
3706      }      }
   }  
3707    
3708    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
3709      long xx = SCM_INUM (x);      {
3710      if (SCM_INUMP (y)) {        long xx = SCM_INUM (x);
3711        long yy = SCM_INUM (y);        if (SCM_INUMP (y))
3712        if (yy == 0) {          {
3713              long yy = SCM_INUM (y);
3714              if (yy == 0)
3715                {
3716  #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO  #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3717          scm_num_overflow (s_divide);                scm_num_overflow (s_divide);
3718  #else  #else
3719          return scm_make_real ((double) xx / (double) yy);                return scm_make_real ((double) xx / (double) yy);
3720  #endif  #endif
3721        } else if (xx % yy != 0) {              }
3722          return scm_make_real ((double) xx / (double) yy);            else if (xx % yy != 0)
3723        } else {              return scm_make_real ((double) xx / (double) yy);
3724          long z = xx / yy;            else
3725          if (SCM_FIXABLE (z)) {              {
3726            return SCM_MAKINUM (z);                long z = xx / yy;
3727          } else {                if (SCM_FIXABLE (z))
3728            return scm_i_long2big (z);                  return SCM_MAKINUM (z);
3729                  else
3730                    return scm_i_long2big (z);
3731                }
3732          }          }
3733        }        else if (SCM_BIGP (y))
3734      } else if (SCM_BIGP (y)) {          return scm_make_real ((double) xx / scm_i_big2dbl (y));
3735        return scm_make_real ((double) xx / scm_i_big2dbl (y));        else if (SCM_REALP (y))
3736      } else if (SCM_REALP (y)) {          {
3737        double yy = SCM_REAL_VALUE (y);            double yy = SCM_REAL_VALUE (y);
3738  #ifndef ALLOW_DIVIDE_BY_ZERO  #ifndef ALLOW_DIVIDE_BY_ZERO
3739        if (yy == 0.0)            if (yy == 0.0)
3740          scm_num_overflow (s_divide);              scm_num_overflow (s_divide);
3741        else            else
3742  #endif  #endif
3743          return scm_make_real ((double) xx / yy);              return scm_make_real ((double) xx / yy);
     } else if (SCM_COMPLEXP (y)) {  
       a = xx;  
     complex_div: /* y _must_ be a complex number */  
       {  
         double r = SCM_COMPLEX_REAL (y);  
         double i = SCM_COMPLEX_IMAG (y);  
         if (r <= i) {  
           double t = r / i;  
           double d = i * (1.0 + t * t);  
           return scm_make_complex ((a * t) / d,  -a / d);  
         } else {  
           double t = i / r;  
           double d = r * (1.0 + t * t);  
           return scm_make_complex (a / d,  -(a * t) / d);  
3744          }          }
3745        }        else if (SCM_COMPLEXP (y))
3746      } else {          {
3747        SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);            a = xx;
3748            complex_div: /* y _must_ be a complex number */
3749              {
3750                double r = SCM_COMPLEX_REAL (y);
3751                double i = SCM_COMPLEX_IMAG (y);
3752                if (r <= i)
3753                  {
3754                    double t = r / i;
3755                    double d = i * (1.0 + t * t);
3756                    return scm_make_complex ((a * t) / d,  -a / d);
3757                  }
3758                else
3759                  {
3760                    double t = i / r;
3761                    double d = r * (1.0 + t * t);
3762                    return scm_make_complex (a / d,  -(a * t) / d);
3763                  }
3764              }
3765            }
3766          else
3767            SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
3768      }      }
3769    } else if (SCM_BIGP (x)) {    else if (SCM_BIGP (x))
3770      if (SCM_INUMP (y)) {      {
3771        long int yy = SCM_INUM (y);        if (SCM_INUMP (y))
3772        if (yy == 0) {          {
3773              long int yy = SCM_INUM (y);
3774              if (yy == 0)
3775                {
3776  #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO  #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3777          scm_num_overflow (s_divide);                scm_num_overflow (s_divide);
3778  #else  #else
3779          int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));                int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3780          scm_remember_upto_here_1 (x);                scm_remember_upto_here_1 (x);
3781          return (sgn == 0) ? scm_nan () : scm_inf ();                return (sgn == 0) ? scm_nan () : scm_inf ();
3782  #endif  #endif
3783        } else if (yy == 1) {              }
3784          return x;            else if (yy == 1)
3785        } else {              return x;
3786          /* FIXME: HMM, what are the relative performance issues here?            else
3787             We need to test.  Is it faster on average to test              {
3788             divisible_p, then perform whichever operation, or is it                /* FIXME: HMM, what are the relative performance issues here?
3789             faster to perform the integer div opportunistically and                   We need to test.  Is it faster on average to test
3790             switch to real if there's a remainder?  For now we take the                   divisible_p, then perform whichever operation, or is it
3791             middle ground: test, then if divisible, use the faster div                   faster to perform the integer div opportunistically and
3792             func. */                   switch to real if there's a remainder?  For now we take the
3793                     middle ground: test, then if divisible, use the faster div
3794                     func. */
3795    
3796          long abs_yy = yy < 0 ? -yy : yy;                long abs_yy = yy < 0 ? -yy : yy;
3797          int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);                int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
3798    
3799          if (divisible_p) {                if (divisible_p)
3800            SCM result = scm_i_mkbig ();                  {
3801            mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy);                    SCM result = scm_i_mkbig ();
3802            scm_remember_upto_here_1 (x);                    mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy);
3803            if (yy < 0)                    scm_remember_upto_here_1 (x);
3804              mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));                    if (yy < 0)
3805            return scm_i_normbig (result);                      mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
3806          }                    return scm_i_normbig (result);
3807          else {                  }
3808            return scm_make_real (scm_i_big2dbl (x) / (double) yy);                else
3809          }                  return scm_make_real (scm_i_big2dbl (x) / (double) yy);
3810        }              }
3811      } else if (SCM_BIGP (y)) {          }
3812        int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0);        else if (SCM_BIGP (y))
3813        if (y_is_zero) {          {
3814              int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0);
3815              if (y_is_zero)
3816                {
3817  #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO  #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3818          scm_num_overflow (s_divide);                scm_num_overflow (s_divide);
3819  #else  #else
3820          int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));                int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3821          scm_remember_upto_here_1 (x);                scm_remember_upto_here_1 (x);
3822          return (sgn == 0) ? scm_nan () : scm_inf ();                return (sgn == 0) ? scm_nan () : scm_inf ();
3823  #endif  #endif
3824        } else {              }
3825          /* big_x / big_y */            else
3826          int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),              {
3827                                             SCM_I_BIG_MPZ (y));                /* big_x / big_y */
3828          if (divisible_p) {                int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
3829            SCM result = scm_i_mkbig ();                                                   SCM_I_BIG_MPZ (y));
3830            mpz_divexact (SCM_I_BIG_MPZ (result),                if (divisible_p)
3831                          SCM_I_BIG_MPZ (x),                  {
3832                          SCM_I_BIG_MPZ (y));                    SCM result = scm_i_mkbig ();
3833            scm_remember_upto_here_2 (x, y);                    mpz_divexact (SCM_I_BIG_MPZ (result),
3834            return scm_i_normbig (result);                                  SCM_I_BIG_MPZ (x),
3835          }                                  SCM_I_BIG_MPZ (y));
3836          else {                    scm_remember_upto_here_2 (x, y);
3837            double dbx = mpz_get_d (SCM_I_BIG_MPZ (x));                    return scm_i_normbig (result);
3838            double dby = mpz_get_d (SCM_I_BIG_MPZ (y));                  }
3839            scm_remember_upto_here_2 (x, y);                else
3840            return scm_make_real (dbx / dby);                  {
3841          }                    double dbx = mpz_get_d (SCM_I_BIG_MPZ (x));
3842        }                    double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
3843      } else if (SCM_REALP (y)) {                    scm_remember_upto_here_2 (x, y);
3844        double yy = SCM_REAL_VALUE (y);                    return scm_make_real (dbx / dby);
3845                    }
3846                }
3847            }
3848          else if (SCM_REALP (y))
3849            {
3850              double yy = SCM_REAL_VALUE (y);
3851  #ifndef ALLOW_DIVIDE_BY_ZERO  #ifndef ALLOW_DIVIDE_BY_ZERO
3852        if (yy == 0.0)            if (yy == 0.0)
3853          scm_num_overflow (s_divide);              scm_num_overflow (s_divide);
3854        else            else
3855  #endif  #endif
3856          return scm_make_real (scm_i_big2dbl (x) / yy);              return scm_make_real (scm_i_big2dbl (x) / yy);
3857      } else if (SCM_COMPLEXP (y)) {          }
3858        a = scm_i_big2dbl (x);        else if (SCM_COMPLEXP (y))
3859        goto complex_div;          {
3860      } else {            a = scm_i_big2dbl (x);
3861        SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);            goto complex_div;
3862      }          }
   } else if (SCM_REALP (x)) {  
     double rx = SCM_REAL_VALUE (x);  
     if (SCM_INUMP (y)) {  
       long int yy = SCM_INUM (y);  
 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO  
       if (yy == 0)  
         scm_num_overflow (s_divide);  
3863        else        else
3864            SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
3865        }
3866      else if (SCM_REALP (x))
3867        {
3868          double rx = SCM_REAL_VALUE (x);
3869          if (SCM_INUMP (y))
3870            {
3871              long int yy = SCM_INUM (y);
3872    #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3873              if (yy == 0)
3874                scm_num_overflow (s_divide);
3875              else
3876  #endif  #endif
3877          return scm_make_real (rx / (double) yy);              return scm_make_real (rx / (double) yy);
3878      } else if (SCM_BIGP (y)) {          }
3879        double dby = mpz_get_d (SCM_I_BIG_MPZ (y));        else if (SCM_BIGP (y))
3880        scm_remember_upto_here_1 (y);          {
3881        return scm_make_real (rx / dby);            double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
3882      } else if (SCM_REALP (y)) {            scm_remember_upto_here_1 (y);
3883        double yy = SCM_REAL_VALUE (y);            return scm_make_real (rx / dby);
3884            }
3885          else if (SCM_REALP (y))
3886            {
3887              double yy = SCM_REAL_VALUE (y);
3888  #ifndef ALLOW_DIVIDE_BY_ZERO  #ifndef ALLOW_DIVIDE_BY_ZERO
3889        if (yy == 0.0)            if (yy == 0.0)
3890          scm_num_overflow (s_divide);              scm_num_overflow (s_divide);
3891        else            else
3892  #endif  #endif
3893          return scm_make_real (rx / yy);              return scm_make_real (rx / yy);
3894      } else if (SCM_COMPLEXP (y)) {          }
3895        a = rx;        else if (SCM_COMPLEXP (y))
3896        goto complex_div;          {
3897      } else {            a = rx;
3898        SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);            goto complex_div;
3899      }          }
   } else if (SCM_COMPLEXP (x)) {  
     double rx = SCM_COMPLEX_REAL (x);  
     double ix = SCM_COMPLEX_IMAG (x);  
     if (SCM_INUMP (y)) {  
       long int yy = SCM_INUM (y);  
 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO  
       if (yy == 0)  
         scm_num_overflow (s_divide);  
3900        else        else
3901            SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
3902        }
3903      else if (SCM_COMPLEXP (x))
3904        {
3905          double rx = SCM_COMPLEX_REAL (x);
3906          double ix = SCM_COMPLEX_IMAG (x);
3907          if (SCM_INUMP (y))
3908            {
3909              long int yy = SCM_INUM (y);
3910    #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3911              if (yy == 0)
3912                scm_num_overflow (s_divide);
3913              else
3914  #endif  #endif
3915        {              {
3916          double d = yy;                double d = yy;
3917          return scm_make_complex (rx / d, ix / d);                return scm_make_complex (rx / d, ix / d);
3918        }              }
3919      } else if (SCM_BIGP (y)) {          }
3920        double dby = mpz_get_d (SCM_I_BIG_MPZ (y));        else if (SCM_BIGP (y))
3921        scm_remember_upto_here_1 (y);          {
3922        return scm_make_complex (rx / dby, ix / dby);            double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
3923      } else if (SCM_REALP (y)) {            scm_remember_upto_here_1 (y);
3924        double yy = SCM_REAL_VALUE (y);            return scm_make_complex (rx / dby, ix / dby);
3925            }
3926          else if (SCM_REALP (y))
3927            {
3928              double yy = SCM_REAL_VALUE (y);
3929  #ifndef ALLOW_DIVIDE_BY_ZERO  #ifndef ALLOW_DIVIDE_BY_ZERO
3930        if (yy == 0.0)            if (yy == 0.0)
3931          scm_num_overflow (s_divide);              scm_num_overflow (s_divide);
3932        else            else
3933  #endif  #endif
3934          return scm_make_complex (rx / yy, ix / yy);              return scm_make_complex (rx / yy, ix / yy);
3935      } else if (SCM_COMPLEXP (y)) {          }
3936        double ry = SCM_COMPLEX_REAL (y);        else if (SCM_COMPLEXP (y))
3937        double iy = SCM_COMPLEX_IMAG (y);          {
3938        if (ry <= iy) {            double ry = SCM_COMPLEX_REAL (y);
3939          double t = ry / iy;            double iy = SCM_COMPLEX_IMAG (y);
3940          double d = iy * (1.0 + t * t);            if (ry <= iy)
3941          return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d);              {
3942        } else {                double t = ry / iy;
3943          double t = iy / ry;                double d = iy * (1.0 + t * t);
3944          double d = ry * (1.0 + t * t);                return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d);
3945          return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d);              }
3946        }            else
3947      } else {              {
3948        SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);                double t = iy / ry;
3949                  double d = ry * (1.0 + t * t);
3950                  return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d);
3951                }
3952            }
3953          else
3954            SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
3955      }      }
3956    } else {    else
3957      SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);      SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
   }  
3958  }  }
3959  #undef FUNC_NAME  #undef FUNC_NAME
3960    
# Line 3717  scm_round (double x) Line 4031  scm_round (double x)
4031    double plus_half = x + 0.5;    double plus_half = x + 0.5;
4032    double result = floor (plus_half);    double result = floor (plus_half);
4033    /* Adjust so that the scm_round is towards even.  */    /* Adjust so that the scm_round is towards even.  */
4034    return (plus_half == result && plus_half / 2 != floor (plus_half / 2))    return ((plus_half == result && plus_half / 2 != floor (plus_half / 2))
4035      ? result - 1 : result;            ? result - 1
4036              : result);
4037  }  }
4038    
4039    
# Line 3781  static void scm_two_doubles (SCM x, Line 4096  static void scm_two_doubles (SCM x,
4096  static void  static void
4097  scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy)  scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy)
4098  {  {
4099    if (SCM_INUMP (x)) {    if (SCM_INUMP (x))
4100      xy->x = SCM_INUM (x);      xy->x = SCM_INUM (x);
4101    } else if (SCM_BIGP (x)) {    else if (SCM_BIGP (x))
4102      xy->x = scm_i_big2dbl (x);      xy->x = scm_i_big2dbl (x);
4103    } else if (SCM_REALP (x)) {    else if (SCM_REALP (x))
4104      xy->x = SCM_REAL_VALUE (x);      xy->x = SCM_REAL_VALUE (x);
4105    } else {    else
4106      scm_wrong_type_arg (sstring, SCM_ARG1, x);      scm_wrong_type_arg (sstring, SCM_ARG1, x);
   }  
4107    
4108    if (SCM_INUMP (y)) {    if (SCM_INUMP (y))
4109      xy->y = SCM_INUM (y);      xy->y = SCM_INUM (y);
4110    } else if (SCM_BIGP (y)) {    else if (SCM_BIGP (y))
4111      xy->y = scm_i_big2dbl (y);      xy->y = scm_i_big2dbl (y);
4112    } else if (SCM_REALP (y)) {    else if (SCM_REALP (y))
4113      xy->y = SCM_REAL_VALUE (y);      xy->y = SCM_REAL_VALUE (y);
4114    } else {    else
4115      scm_wrong_type_arg (sstring, SCM_ARG2, y);      scm_wrong_type_arg (sstring, SCM_ARG2, y);
   }  
4116  }  }
4117    
4118    
# Line 3871  SCM_GPROC (s_real_part, "real-part", 1, Line 4184  SCM_GPROC (s_real_part, "real-part", 1,
4184  SCM  SCM
4185  scm_real_part (SCM z)  scm_real_part (SCM z)
4186  {  {
4187    if (SCM_INUMP (z)) {    if (SCM_INUMP (z))
4188      return z;      return z;
4189    } else if (SCM_BIGP (z)) {    else if (SCM_BIGP (z))
4190      return z;      return z;
4191    } else if (SCM_REALP (z)) {    else if (SCM_REALP (z))
4192      return z;      return z;
4193    } else if (SCM_COMPLEXP (z)) {    else if (SCM_COMPLEXP (z))
4194      return scm_make_real (SCM_COMPLEX_REAL (z));      return scm_make_real (SCM_COMPLEX_REAL (z));
4195    } else {    else
4196      SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);      SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);
   }  
4197  }  }
4198    
4199    
# Line 3891  SCM_GPROC (s_imag_part, "imag-part", 1, Line 4203  SCM_GPROC (s_imag_part, "imag-part", 1,
4203  SCM  SCM
4204  scm_imag_part (SCM z)  scm_imag_part (SCM z)
4205  {  {
4206    if (SCM_INUMP (z)) {    if (SCM_INUMP (z))
4207      return SCM_INUM0;      return SCM_INUM0;
4208    } else if (SCM_BIGP (z)) {    else if (SCM_BIGP (z))
4209      return SCM_INUM0;      return SCM_INUM0;
4210    } else if (SCM_REALP (z)) {    else if (SCM_REALP (z))
4211      return scm_flo0;      return scm_flo0;
4212    } else if (SCM_COMPLEXP (z)) {    else if (SCM_COMPLEXP (z))
4213      return scm_make_real (SCM_COMPLEX_IMAG (z));      return scm_make_real (SCM_COMPLEX_IMAG (z));
4214    } else {    else
4215      SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);      SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);
   }  
4216  }  }
4217    
4218    
# Line 3912  SCM_GPROC (s_magnitude, "magnitude", 1, Line 4223  SCM_GPROC (s_magnitude, "magnitude", 1,
4223  SCM  SCM
4224  scm_magnitude (SCM z)  scm_magnitude (SCM z)
4225  {  {
4226    if (SCM_INUMP (z)) {    if (SCM_INUMP (z))
4227      long int zz = SCM_INUM (z);      {
4228      if (zz >= 0) {        long int zz = SCM_INUM (z);
4229        return z;        if (zz >= 0)
4230      } else if (SCM_POSFIXABLE (-zz)) {          return z;
4231        return SCM_MAKINUM (-zz);        else if (SCM_POSFIXABLE (-zz))
4232      } else {          return SCM_MAKINUM (-zz);
4233        return scm_i_long2big (-zz);        else
4234      }          return scm_i_long2big (-zz);
4235    } else if (SCM_BIGP (z)) {      }
4236      int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));    else if (SCM_BIGP (z))
4237      scm_remember_upto_here_1 (z);      {
4238      if (sgn < 0) {        int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
4239        return scm_i_clonebig (z, 0);        scm_remember_upto_here_1 (z);
4240      } else {        if (sgn < 0)
4241        return z;          return scm_i_clonebig (z, 0);
4242          else
4243            return z;
4244      }      }
4245    } else if (SCM_REALP (z)) {    else if (SCM_REALP (z))
4246      return scm_make_real (fabs (SCM_REAL_VALUE (z)));      return scm_make_real (fabs (SCM_REAL_VALUE (z)));
4247    } else if (SCM_COMPLEXP (z)) {    else if (SCM_COMPLEXP (z))
4248      return scm_make_real (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));      return scm_make_real (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));
4249    } else {    else
4250      SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);      SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
   }  
4251  }  }
4252    
4253    
# Line 3945  SCM_GPROC (s_angle, "angle", 1, 0, 0, sc Line 4257  SCM_GPROC (s_angle, "angle", 1, 0, 0, sc
4257  SCM  SCM
4258  scm_angle (SCM z)  scm_angle (SCM z)
4259  {  {
4260    if (SCM_INUMP (z)) {    if (SCM_INUMP (z))
4261      if (SCM_INUM (z) >= 0) {      {
4262        return scm_make_real (atan2 (0.0, 1.0));        if (SCM_INUM (z) >= 0)
4263      } else {          return scm_make_real (atan2 (0.0, 1.0));
4264        return scm_make_real (atan2 (0.0, -1.0));        else
4265      }          return scm_make_real (atan2 (0.0, -1.0));
   } else if (SCM_BIGP (z)) {  
     int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));  
     scm_remember_upto_here_1 (z);  
     if (sgn < 0) {  
       return scm_make_real (atan2 (0.0, -1.0));  
     } else {  
       return scm_make_real (atan2 (0.0, 1.0));  
4266      }      }
4267    } else if (SCM_REALP (z)) {    else if (SCM_BIGP (z))
4268        {
4269          int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
4270          scm_remember_upto_here_1 (z);
4271          if (sgn < 0)
4272            return scm_make_real (atan2 (0.0, -1.0));
4273          else
4274            return scm_make_real (atan2 (0.0, 1.0));
4275        }
4276      else if (SCM_REALP (z))
4277      return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z)));      return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z)));
4278    } else if (SCM_COMPLEXP (z)) {    else if (SCM_COMPLEXP (z))
4279      return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));      return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
4280    } else {    else
4281      SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);      SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
   }  
4282  }  }
4283    
4284    
# Line 3991  SCM_DEFINE (scm_inexact_to_exact, "inexa Line 4304  SCM_DEFINE (scm_inexact_to_exact, "inexa
4304              "Return an exact number that is numerically closest to @var{z}.")              "Return an exact number that is numerically closest to @var{z}.")
4305  #define FUNC_NAME s_scm_inexact_to_exact  #define FUNC_NAME s_scm_inexact_to_exact
4306  {  {
4307    if (SCM_INUMP (z)) {    if (SCM_INUMP (z))
4308      return z;      return z;
4309    } else if (SCM_BIGP (z)) {    else if (SCM_BIGP (z))
4310      return z;      return z;
4311    } else if (SCM_REALP (z)) {    else if (SCM_REALP (z))
4312      double u = floor (SCM_REAL_VALUE (z) + 0.5);      {
4313      long lu = (long) u;        double u = floor (SCM_REAL_VALUE (z) + 0.5);
4314      if (SCM_FIXABLE (lu)) {        long lu = (long) u;
4315        return SCM_MAKINUM (lu);        if (SCM_FIXABLE (lu))
4316      } else if (!xisinf (u) && !xisnan (u)) {          return SCM_MAKINUM (lu);
4317        return scm_i_dbl2big (u);        else if (!xisinf (u) && !xisnan (u))
4318      } else {          return scm_i_dbl2big (u);
4319        scm_num_overflow (s_scm_inexact_to_exact);        else
4320            scm_num_overflow (s_scm_inexact_to_exact);
4321      }      }
4322    } else {    else
4323      SCM_WRONG_TYPE_ARG (1, z);      SCM_WRONG_TYPE_ARG (1, z);
   }  
4324  }  }
4325  #undef FUNC_NAME  #undef FUNC_NAME
4326    
# Line 4166  SCM_DEFINE (scm_inexact_to_exact, "inexa Line 4479  SCM_DEFINE (scm_inexact_to_exact, "inexa
4479  #define PTRDIFF_MAX (~ PTRDIFF_MIN)  #define PTRDIFF_MAX (~ PTRDIFF_MIN)
4480  #endif  #endif
4481    
4482  #define CHECK(type, v) \  #define CHECK(type, v)                                                     \
4483    do { \    do                                                                       \
4484      if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \      {                                                                      \
4485        abort (); \        if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
4486    } while (0);          abort ();                                                          \
4487        }                                                                      \
4488      while (0)
4489    
4490  static void  static void
4491  check_sanity ()  check_sanity ()
# Line 4286  scm_init_numbers () Line 4601  scm_init_numbers ()
4601    {                             /* determine floating point precision */    {                             /* determine floating point precision */
4602      double f = 0.1;      double f = 0.1;
4603      double fsum = 1.0 + f;      double fsum = 1.0 + f;
4604      while (fsum != 1.0) {      while (fsum != 1.0)
4605        if (++scm_dblprec > 20) {        {
4606          fsum = 1.0;          if (++scm_dblprec > 20)
4607        } else {            fsum = 1.0;
4608          f /= 10.0;          else
4609          fsum = f + 1.0;            {
4610                f /= 10.0;
4611                fsum = f + 1.0;
4612              }
4613        }        }
     }  
4614      scm_dblprec = scm_dblprec - 1;      scm_dblprec = scm_dblprec - 1;
4615    }    }
4616  #endif /* DBL_DIG */  #endif /* DBL_DIG */

Legend:
Removed from v.1.193  
changed lines
  Added in v.1.194

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26