X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/3a9809dfdee081cc8f0897b2360bd91eae729c28..fc85d095600162567fd0aa563eed9e6eada3e889:/libguile/numbers.c diff --git a/libguile/numbers.c b/libguile/numbers.c index 0b08131f8..5e86a5441 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,4 +1,8 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 Free Software Foundation, Inc. + * + * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories + * and Bellcore. See scm_divide. + * * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -39,74 +43,67 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ - -#include #include +#include +#include #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/ports.h" #include "libguile/root.h" #include "libguile/smob.h" #include "libguile/strings.h" -#include "libguile/vectors.h" #include "libguile/validate.h" #include "libguile/numbers.h" +#include "libguile/deprecation.h" -static SCM scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes); +static SCM scm_divbigbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, int sgn, int modes); static SCM scm_divbigint (SCM x, long z, int sgn, int mode); -#define DIGITS '0':case '1':case '2':case '3':case '4':\ - case '5':case '6':case '7':case '8':case '9' - - -#define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0) - - -#if (SCM_DEBUG_DEPRECATED == 1) /* not defined in header yet? */ -/* SCM_FIXABLE is non-0 if its long argument can be encoded in an SCM_INUM. - */ -#define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM) -#define SCM_NEGFIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM) -#define SCM_UNEGFIXABLE(n) ((n) <= -SCM_MOST_NEGATIVE_FIXNUM) -#define SCM_FIXABLE(n) (SCM_POSFIXABLE(n) && SCM_NEGFIXABLE(n)) +#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0) -/* SCM_FLOBUFLEN is the maximum number of characters neccessary for the +/* FLOBUFLEN is the maximum number of characters neccessary for the * printed or scm_string representation of an inexact number. */ -#define SCM_FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) -#endif +#define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) +#if defined (SCO) +#if ! defined (HAVE_ISNAN) +#define HAVE_ISNAN +static int +isnan (double x) +{ + return (IsNANorINF (x) && NaN (x) && ! IsINF (x)) ? 1 : 0; +} +#endif +#if ! defined (HAVE_ISINF) +#define HAVE_ISINF +static int +isinf (double x) +{ + return (IsNANorINF (x) && IsINF (x)) ? 1 : 0; +} -/* IS_INF tests its floating point number for infiniteness - Dirk:FIXME:: This test does not work if x == 0 - */ -#ifndef IS_INF -#define IS_INF(x) ((x) == (x) / 2) +#endif #endif + -/* Return true if X is not infinite and is not a NaN - Dirk:FIXME:: Since IS_INF is broken, this test does not work if x == 0 - */ -#ifndef isfinite -#define isfinite(x) (!IS_INF (x) && (x) == (x)) -#endif +static SCM abs_most_negative_fixnum; SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, (SCM x), - "Return #t if X is an exact number, #f otherwise.") + "Return @code{#t} if @var{x} is an exact number, @code{#f}\n" + "otherwise.") #define FUNC_NAME s_scm_exact_p { if (SCM_INUMP (x)) { @@ -122,13 +119,16 @@ SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, (SCM n), - "Return #t if N is an odd number, #f otherwise.") + "Return @code{#t} if @var{n} is an odd number, @code{#f}\n" + "otherwise.") #define FUNC_NAME s_scm_odd_p { if (SCM_INUMP (n)) { return SCM_BOOL ((4 & SCM_UNPACK (n)) != 0); } else if (SCM_BIGP (n)) { return SCM_BOOL ((1 & SCM_BDIGITS (n) [0]) != 0); + } else if (scm_inf_p (n)) { + return SCM_BOOL_T; } else { SCM_WRONG_TYPE_ARG (1, n); } @@ -138,22 +138,160 @@ SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, (SCM n), - "Return #t if N is an even number, #f otherwise.") + "Return @code{#t} if @var{n} is an even number, @code{#f}\n" + "otherwise.") #define FUNC_NAME s_scm_even_p { if (SCM_INUMP (n)) { return SCM_BOOL ((4 & SCM_UNPACK (n)) == 0); } else if (SCM_BIGP (n)) { return SCM_BOOL ((1 & SCM_BDIGITS (n) [0]) == 0); + } else if (scm_inf_p (n)) { + return SCM_BOOL_T; } else { SCM_WRONG_TYPE_ARG (1, n); } } #undef FUNC_NAME +static int +xisinf (double x) +{ +#if defined (HAVE_ISINF) + return isinf (x); +#elif defined (HAVE_FINITE) && defined (HAVE_ISNAN) + return (! (finite (x) || isnan (x))); +#else + return 0; +#endif +} -SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs); +static int +xisnan (double x) +{ +#if defined (HAVE_ISNAN) + return isnan (x); +#else + return 0; +#endif +} + +#define isfinite(x) (! xisinf (x)) + +SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0, + (SCM n), + "Return @code{#t} if @var{n} is infinite, @code{#f}\n" + "otherwise.") +#define FUNC_NAME s_scm_inf_p +{ + if (SCM_REALP (n)) { + return SCM_BOOL (xisinf (SCM_REAL_VALUE (n))); + } else if (SCM_COMPLEXP (n)) { + return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n)) + || xisinf (SCM_COMPLEX_IMAG (n))); + } else { + return SCM_BOOL_F; + } +} +#undef FUNC_NAME + +SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0, + (SCM n), + "Return @code{#t} if @var{n} is a NaN, @code{#f}\n" + "otherwise.") +#define FUNC_NAME s_scm_nan_p +{ + if (SCM_REALP (n)) { + return SCM_BOOL (xisnan (SCM_REAL_VALUE (n))); + } else if (SCM_COMPLEXP (n)) { + return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n)) + || xisnan (SCM_COMPLEX_IMAG (n))); + } else { + return SCM_BOOL_F; + } +} +#undef FUNC_NAME + +/* Guile's idea of infinity. */ +static double guile_Inf; + +/* Guile's idea of not a number. */ +static double guile_NaN; + +static void +guile_ieee_init (void) +{ +#if defined (HAVE_ISINF) || defined (HAVE_FINITE) + +/* Some version of gcc on some old version of Linux used to crash when + trying to make Inf and NaN. */ + +#if defined (SCO) + double tmp = 1.0; + guile_Inf = 1.0 / (tmp - tmp); +#elif defined (__alpha__) && ! defined (linux) + extern unsigned int DINFINITY[2]; + guile_Inf = (*(X_CAST(double *, DINFINITY))); +#else + double tmp = 1e+10; + guile_Inf = tmp; + for (;;) + { + guile_Inf *= 1e+10; + if (guile_Inf == tmp) + break; + tmp = guile_Inf; + } +#endif + +#endif + +#if defined (HAVE_ISNAN) +#if defined (__alpha__) && ! defined (linux) + extern unsigned int DQNAN[2]; + guile_NaN = (*(X_CAST(double *, DQNAN))); +#else + guile_NaN = guile_Inf / guile_Inf; +#endif + +#endif +} + +SCM_DEFINE (scm_inf, "inf", 0, 0, 0, + (void), + "Return Inf.") +#define FUNC_NAME s_scm_inf +{ + static int initialized = 0; + if (! initialized) + { + guile_ieee_init (); + initialized = 1; + } + return scm_make_real (guile_Inf); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_nan, "nan", 0, 0, 0, + (void), + "Return NaN.") +#define FUNC_NAME s_scm_nan +{ + static int initialized = 0; + if (! initialized) + { + guile_ieee_init (); + initialized = 1; + } + return scm_make_real (guile_NaN); +} +#undef FUNC_NAME + + +SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs); +/* "Return the absolute value of @var{x}." + */ SCM scm_abs (SCM x) { @@ -165,7 +303,7 @@ scm_abs (SCM x) return SCM_MAKINUM (-xx); } else { #ifdef SCM_BIGDIG - return scm_long2big (-xx); + return scm_i_long2big (-xx); #else scm_num_overflow (s_abs); #endif @@ -174,7 +312,7 @@ scm_abs (SCM x) if (!SCM_BIGSIGN (x)) { return x; } else { - return scm_copybig (x, 0); + return scm_i_copybig (x, 0); } } else if (SCM_REALP (x)) { return scm_make_real (fabs (SCM_REAL_VALUE (x))); @@ -185,7 +323,8 @@ scm_abs (SCM x) SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient); - +/* "Return the quotient of the numbers @var{x} and @var{y}." + */ SCM scm_quotient (SCM x, SCM y) { @@ -201,14 +340,21 @@ scm_quotient (SCM x, SCM y) return SCM_MAKINUM (z); } else { #ifdef SCM_BIGDIG - return scm_long2big (z); + return scm_i_long2big (z); #else scm_num_overflow (s_quotient); #endif } } } else if (SCM_BIGP (y)) { - return SCM_INUM0; + if (SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM + && scm_bigcomp (abs_most_negative_fixnum, y) == 0) + { + /* Special case: x == fixnum-min && y == abs (fixnum-min) */ + return SCM_MAKINUM (-1); + } + else + return SCM_MAKINUM (0); } else { SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); } @@ -223,9 +369,9 @@ scm_quotient (SCM x, SCM y) long z = yy < 0 ? -yy : yy; if (z < SCM_BIGRAD) { - SCM sw = scm_copybig (x, SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)); + SCM sw = scm_i_copybig (x, SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)); scm_divbigdig (SCM_BDIGITS (sw), SCM_NUMDIGS (sw), (SCM_BIGDIG) z); - return scm_normbig (sw); + return scm_i_normbig (sw); } else { #ifndef SCM_DIGSTOOBIG long w = scm_pseudolong (z); @@ -255,7 +401,12 @@ scm_quotient (SCM x, SCM y) SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder); - +/* "Return the remainder of the numbers @var{x} and @var{y}.\n" + * "@lisp\n" + * "(remainder 13 4) @result{} 1\n" + * "(remainder -13 4) @result{} -1\n" + * "@end lisp" + */ SCM scm_remainder (SCM x, SCM y) { @@ -265,15 +416,18 @@ scm_remainder (SCM x, SCM y) if (yy == 0) { scm_num_overflow (s_remainder); } else { -#if (__TURBOC__ == 1) - long z = SCM_INUM (x) % (yy < 0 ? -yy : yy); -#else long z = SCM_INUM (x) % yy; -#endif return SCM_MAKINUM (z); } } else if (SCM_BIGP (y)) { - return x; + if (SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM + && scm_bigcomp (abs_most_negative_fixnum, y) == 0) + { + /* Special case: x == fixnum-min && y == abs (fixnum-min) */ + return SCM_MAKINUM (0); + } + else + return x; } else { SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); } @@ -299,7 +453,12 @@ scm_remainder (SCM x, SCM y) SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo); - +/* "Return the modulo of the numbers @var{x} and @var{y}.\n" + * "@lisp\n" + * "(modulo 13 4) @result{} 1\n" + * "(modulo -13 4) @result{} 3\n" + * "@end lisp" + */ SCM scm_modulo (SCM x, SCM y) { @@ -310,11 +469,7 @@ scm_modulo (SCM x, SCM y) if (yy == 0) { scm_num_overflow (s_modulo); } else { -#if (__TURBOC__ == 1) - long z = ((yy < 0) ? -xx : xx) % yy; -#else long z = xx % yy; -#endif return SCM_MAKINUM (((yy < 0) ? (z > 0) : (z < 0)) ? z + yy : z); } } else if (SCM_BIGP (y)) { @@ -346,7 +501,9 @@ scm_modulo (SCM x, SCM y) SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd); - +/* "Return the greatest common divisor of all arguments.\n" + * "If called without arguments, 0 is returned." + */ SCM scm_gcd (SCM x, SCM y) { @@ -372,7 +529,7 @@ scm_gcd (SCM x, SCM y) } else if (yy == 0) { result = u; } else { - int k = 1; + long k = 1; long t; /* Determine a common factor 2^k */ @@ -406,7 +563,7 @@ scm_gcd (SCM x, SCM y) return SCM_MAKINUM (result); } else { #ifdef SCM_BIGDIG - return scm_long2big (result); + return scm_i_long2big (result); #else scm_num_overflow (s_gcd); #endif @@ -420,7 +577,7 @@ scm_gcd (SCM x, SCM y) } else if (SCM_BIGP (x)) { big_gcd: if (SCM_BIGSIGN (x)) - x = scm_copybig (x, 0); + x = scm_i_copybig (x, 0); newy: if (SCM_INUMP (y)) { if (SCM_EQ_P (y, SCM_INUM0)) { @@ -430,7 +587,7 @@ scm_gcd (SCM x, SCM y) } } else if (SCM_BIGP (y)) { if (SCM_BIGSIGN (y)) - y = scm_copybig (y, 0); + y = scm_i_copybig (y, 0); switch (scm_bigcomp (x, y)) { case -1: /* x > y */ @@ -459,7 +616,9 @@ scm_gcd (SCM x, SCM y) SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm); - +/* "Return the least common multiple of the arguments.\n" + * "If called without arguments, 1 is returned." + */ SCM scm_lcm (SCM n1, SCM n2) { @@ -538,18 +697,18 @@ scm_lcm (SCM n1, SCM n2) #ifdef SCM_BIGDIG SCM scm_copy_big_dec(SCM b, int sign); -SCM scm_copy_smaller(SCM_BIGDIG *x, scm_sizet nx, int zsgn); -SCM scm_big_ior(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy); -SCM scm_big_xor(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy); -SCM scm_big_and(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int zsgn); -SCM scm_big_test(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy); +SCM scm_copy_smaller(SCM_BIGDIG *x, size_t nx, int zsgn); +SCM scm_big_ior(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy); +SCM scm_big_xor(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy); +SCM scm_big_and(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy, int zsgn); +SCM scm_big_test(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy); SCM scm_copy_big_dec(SCM b, int sign) { long num = -1; - scm_sizet nx = SCM_NUMDIGS(b); - scm_sizet i = 0; - SCM ans = scm_mkbig(nx, sign); + size_t nx = SCM_NUMDIGS(b); + size_t i = 0; + SCM ans = scm_i_mkbig(nx, sign); SCM_BIGDIG *src = SCM_BDIGITS(b), *dst = SCM_BDIGITS(ans); if SCM_BIGSIGN(b) do { num += src[i]; @@ -561,11 +720,11 @@ SCM scm_copy_big_dec(SCM b, int sign) return ans; } -SCM scm_copy_smaller(SCM_BIGDIG *x, scm_sizet nx, int zsgn) +SCM scm_copy_smaller(SCM_BIGDIG *x, size_t nx, int zsgn) { long num = -1; - scm_sizet i = 0; - SCM z = scm_mkbig(nx, zsgn); + size_t i = 0; + SCM z = scm_i_mkbig(nx, zsgn); SCM_BIGDIG *zds = SCM_BDIGITS(z); if (zsgn) do { num += x[i]; @@ -576,12 +735,12 @@ SCM scm_copy_smaller(SCM_BIGDIG *x, scm_sizet nx, int zsgn) return z; } -SCM scm_big_ior(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) +SCM scm_big_ior(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy) /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ { long num = -1; - scm_sizet i = 0, ny = SCM_NUMDIGS(bigy); + size_t i = 0, ny = SCM_NUMDIGS(bigy); SCM z = scm_copy_big_dec (bigy, xsgn & SCM_BIGSIGN (bigy)); SCM_BIGDIG *zds = SCM_BDIGITS(z); if (xsgn) { @@ -598,7 +757,7 @@ SCM scm_big_ior(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) num = SCM_BIGDN(num); if (!num) return z; } - scm_adjbig(z, 1 + ny); /* OOPS, overflowed into next digit. */ + scm_i_adjbig(z, 1 + ny); /* OOPS, overflowed into next digit. */ SCM_BDIGITS(z)[ny] = 1; return z; } @@ -606,12 +765,12 @@ SCM scm_big_ior(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) return z; } -SCM scm_big_xor(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) +SCM scm_big_xor(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy) /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ { long num = -1; - scm_sizet i = 0, ny = SCM_NUMDIGS(bigy); + size_t i = 0, ny = SCM_NUMDIGS(bigy); SCM z = scm_copy_big_dec(bigy, xsgn ^ SCM_BIGSIGN(bigy)); SCM_BIGDIG *zds = SCM_BDIGITS(z); if (xsgn) do { @@ -630,19 +789,19 @@ SCM scm_big_xor(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) num += zds[i]; zds[i++] = SCM_BIGLO(num); num = SCM_BIGDN(num); - if (!num) return scm_normbig(z); + if (!num) return scm_i_normbig(z); } } - return scm_normbig(z); + return scm_i_normbig(z); } -SCM scm_big_and(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int zsgn) +SCM scm_big_and(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy, int zsgn) /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ /* return sign equals either 0 or SCM_BIGSIGNFLAG */ { long num = -1; - scm_sizet i = 0; + size_t i = 0; SCM z; SCM_BIGDIG *zds; if (xsgn==zsgn) { @@ -666,24 +825,26 @@ SCM scm_big_and(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int zsgn) num += zds[i]; zds[i++] = SCM_BIGLO(num); num = SCM_BIGDN(num); - if (!num) return scm_normbig(z); + if (!num) return scm_i_normbig(z); } } - else if (xsgn) do { - num += x[i]; - if (num < 0) {zds[i] &= num + SCM_BIGRAD; num = -1;} - else {zds[i] &= ~SCM_BIGLO(num); num = 0;} - } while (++i < nx); - else do zds[i] = zds[i] & x[i]; while (++i < nx); - return scm_normbig(z); + else if (xsgn) { + unsigned long int carry = 1; + do { + unsigned long int mask = (SCM_BIGDIG) ~x[i] + carry; + zds[i] = zds[i] & (SCM_BIGDIG) mask; + carry = (mask >= SCM_BIGRAD) ? 1 : 0; + } while (++i < nx); + } else do zds[i] = zds[i] & x[i]; while (++i < nx); + return scm_i_normbig(z); } -SCM scm_big_test(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) +SCM scm_big_test(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy) /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ { SCM_BIGDIG *y; - scm_sizet i = 0; + size_t i = 0; long num = -1; if (SCM_BIGSIGN(bigy) & xsgn) return SCM_BOOL_T; if (SCM_NUMDIGS(bigy) != nx && xsgn) return SCM_BOOL_T; @@ -720,15 +881,14 @@ SCM scm_big_test(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) #endif - SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, (SCM n1, SCM n2), - "Returns the integer which is the bit-wise AND of the two integer\n" - "arguments.\n\n" - "Example:\n" + "Return the bitwise AND of the integer arguments.\n\n" "@lisp\n" - "(number->string (logand #b1100 #b1010) 2)\n" - " @result{} \"1000\"") + "(logand) @result{} -1\n" + "(logand 7) @result{} 7\n" + "(logand #b111 #b011 #\b001) @result{} 1\n" + "@end lisp") #define FUNC_NAME s_scm_logand { long int nn1; @@ -738,15 +898,10 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, return SCM_MAKINUM (-1); } else if (!SCM_NUMBERP (n1)) { SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); -#ifndef SCM_RECKLESS } else if (SCM_NUMBERP (n1)) { return n1; } else { SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); -#else - } else { - return n1; -#endif } } @@ -809,13 +964,12 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, (SCM n1, SCM n2), - "Returns the integer which is the bit-wise OR of the two integer\n" - "arguments.\n\n" - "Example:\n" + "Return the bitwise OR of the integer arguments.\n\n" "@lisp\n" - "(number->string (logior #b1100 #b1010) 2)\n" - " @result{} \"1110\"\n" - "@end lisp") + "(logior) @result{} 0\n" + "(logior 7) @result{} 7\n" + "(logior #b000 #b001 #b011) @result{} 3\n" + "@end lisp") #define FUNC_NAME s_scm_logior { long int nn1; @@ -823,15 +977,10 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) { return SCM_INUM0; -#ifndef SCM_RECKLESS } else if (SCM_NUMBERP (n1)) { return n1; } else { SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); -#else - } else { - return n1; -#endif } } @@ -853,7 +1002,7 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2, SCM_BIGSIGNFLAG); } # else - BIGDIG zdigs [DIGSPERLONG]; + SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; scm_longdigs (nn1, zdigs); if ((!(nn1 < 0)) && !SCM_BIGSIGN (n2)) { return scm_big_ior (zdigs, SCM_DIGSPERLONG, @@ -895,13 +1044,14 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr, (SCM n1, SCM n2), - "Returns the integer which is the bit-wise XOR of the two integer\n" - "arguments.\n\n" - "Example:\n" + "Return the bitwise XOR of the integer arguments. A bit is\n" + "set in the result if it is set in an odd number of arguments.\n" "@lisp\n" - "(number->string (logxor #b1100 #b1010) 2)\n" - " @result{} \"110\"\n" - "@end lisp") + "(logxor) @result{} 0\n" + "(logxor 7) @result{} 7\n" + "(logxor #b000 #b001 #b011) @result{} 2\n" + "(logxor #b000 #b001 #b011 #b011) @result{} 1\n" + "@end lisp") #define FUNC_NAME s_scm_logxor { long int nn1; @@ -909,15 +1059,10 @@ SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr, if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) { return SCM_INUM0; -#ifndef SCM_RECKLESS } else if (SCM_NUMBERP (n1)) { return n1; } else { SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); -#else - } else { - return n1; -#endif } } @@ -965,54 +1110,54 @@ SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr, SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0, - (SCM n1, SCM n2), - "@example\n" + (SCM j, SCM k), + "@lisp\n" "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n" "(logtest #b0100 #b1011) @result{} #f\n" "(logtest #b0100 #b0111) @result{} #t\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_logtest { - long int nn1; - - if (SCM_INUMP (n1)) { - nn1 = SCM_INUM (n1); - if (SCM_INUMP (n2)) { - long nn2 = SCM_INUM (n2); - return SCM_BOOL (nn1 & nn2); - } else if (SCM_BIGP (n2)) { + long int nj; + + if (SCM_INUMP (j)) { + nj = SCM_INUM (j); + if (SCM_INUMP (k)) { + long nk = SCM_INUM (k); + return SCM_BOOL (nj & nk); + } else if (SCM_BIGP (k)) { intbig: { # ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong (nn1); + long z = scm_pseudolong (nj); return scm_big_test ((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); + (nj < 0) ? SCM_BIGSIGNFLAG : 0, k); # else SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; - scm_longdigs (nn1, zdigs); + scm_longdigs (nj, zdigs); return scm_big_test (zdigs, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); + (nj < 0) ? SCM_BIGSIGNFLAG : 0, k); # endif } } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + SCM_WRONG_TYPE_ARG (SCM_ARG2, k); } - } else if (SCM_BIGP (n1)) { - if (SCM_INUMP (n2)) { - SCM_SWAP (n1, n2); - nn1 = SCM_INUM (n1); + } else if (SCM_BIGP (j)) { + if (SCM_INUMP (k)) { + SCM_SWAP (j, k); + nj = SCM_INUM (j); goto intbig; - } else if (SCM_BIGP (n2)) { - if (SCM_NUMDIGS (n1) > SCM_NUMDIGS (n2)) { - SCM_SWAP (n1, n2); + } else if (SCM_BIGP (k)) { + if (SCM_NUMDIGS (j) > SCM_NUMDIGS (k)) { + SCM_SWAP (j, k); } - return scm_big_test (SCM_BDIGITS (n1), SCM_NUMDIGS (n1), - SCM_BIGSIGN (n1), n2); + return scm_big_test (SCM_BDIGITS (j), SCM_NUMDIGS (j), + SCM_BIGSIGN (j), k); } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + SCM_WRONG_TYPE_ARG (SCM_ARG2, k); } } else { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); + SCM_WRONG_TYPE_ARG (SCM_ARG1, j); } } #undef FUNC_NAME @@ -1020,55 +1165,63 @@ SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0, SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, (SCM index, SCM j), - "@example\n" + "@lisp\n" "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n" "(logbit? 0 #b1101) @result{} #t\n" "(logbit? 1 #b1101) @result{} #f\n" "(logbit? 2 #b1101) @result{} #t\n" "(logbit? 3 #b1101) @result{} #t\n" "(logbit? 4 #b1101) @result{} #f\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_logbit_p { - SCM_ASSERT(SCM_INUMP(index) && SCM_INUM(index) >= 0, index, SCM_ARG1, FUNC_NAME); -#ifdef SCM_BIGDIG - if SCM_NINUMP(j) { - SCM_ASSERT(SCM_BIGP (j), j, SCM_ARG2, FUNC_NAME); - if (SCM_NUMDIGS(j) * SCM_BITSPERDIG < SCM_INUM(index)) return SCM_BOOL_F; - else if SCM_BIGSIGN(j) { + unsigned long int iindex; + + SCM_VALIDATE_INUM_MIN (SCM_ARG1, index, 0); + iindex = (unsigned long int) SCM_INUM (index); + + if (SCM_INUMP (j)) { + return SCM_BOOL ((1L << iindex) & SCM_INUM (j)); + } else if (SCM_BIGP (j)) { + if (SCM_NUMDIGS (j) * SCM_BITSPERDIG < iindex) { + return SCM_BOOL_F; + } else if (SCM_BIGSIGN (j)) { long num = -1; - scm_sizet i = 0; - SCM_BIGDIG *x = SCM_BDIGITS(j); - scm_sizet nx = SCM_INUM(index)/SCM_BITSPERDIG; - while (!0) { + size_t i = 0; + SCM_BIGDIG * x = SCM_BDIGITS (j); + size_t nx = iindex / SCM_BITSPERDIG; + while (1) { num += x[i]; - if (nx==i++) - return ((1L << (SCM_INUM(index)%SCM_BITSPERDIG)) & num) ? SCM_BOOL_F : SCM_BOOL_T; - if (num < 0) num = -1; - else num = 0; + if (nx == i++) { + return SCM_BOOL (((1L << (iindex % SCM_BITSPERDIG)) & num) == 0); + } else if (num < 0) { + num = -1; + } else { + num = 0; + } } + } else { + return SCM_BOOL (SCM_BDIGITS (j) [iindex / SCM_BITSPERDIG] + & (1L << (iindex % SCM_BITSPERDIG))); } - else return (SCM_BDIGITS(j)[SCM_INUM(index)/SCM_BITSPERDIG] & - (1L << (SCM_INUM(index)%SCM_BITSPERDIG))) ? SCM_BOOL_T : SCM_BOOL_F; + } else { + SCM_WRONG_TYPE_ARG (SCM_ARG2, j); } -#else - SCM_ASSERT(SCM_INUMP(j), j, SCM_ARG2, FUNC_NAME); -#endif - return ((1L << SCM_INUM(index)) & SCM_INUM(j)) ? SCM_BOOL_T : SCM_BOOL_F; } #undef FUNC_NAME + SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0, (SCM n), - "Returns the integer which is the 2s-complement of the integer argument.\n\n" - "Example:\n" + "Return the integer which is the 2s-complement of the integer\n" + "argument.\n" + "\n" "@lisp\n" "(number->string (lognot #b10000000) 2)\n" " @result{} \"-10000001\"\n" "(number->string (lognot #b0) 2)\n" " @result{} \"-1\"\n" - "@end lisp\n" - "") + "@end lisp") #define FUNC_NAME s_scm_lognot { return scm_difference (SCM_MAKINUM (-1L), n); @@ -1077,8 +1230,9 @@ SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0, SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, (SCM n, SCM k), - "Returns @var{n} raised to the non-negative integer exponent @var{k}.\n\n" - "Example:\n" + "Return @var{n} raised to the non-negative integer exponent\n" + "@var{k}.\n" + "\n" "@lisp\n" "(integer-expt 2 5)\n" " @result{} 32\n" @@ -1090,12 +1244,21 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, SCM acc = SCM_MAKINUM (1L); int i2; #ifdef SCM_BIGDIG + /* 0^0 == 1 according to R5RS */ if (SCM_EQ_P (n, SCM_INUM0) || SCM_EQ_P (n, acc)) - return n; + return SCM_FALSEP (scm_zero_p(k)) ? n : acc; else if (SCM_EQ_P (n, SCM_MAKINUM (-1L))) return SCM_FALSEP (scm_even_p (k)) ? n : acc; #endif - SCM_VALIDATE_ULONG_COPY (2,k,i2); + if (SCM_REALP (k)) + { + double r = SCM_REAL_VALUE (k); + i2 = r; + if (i2 != r) + SCM_WRONG_TYPE_ARG (2, k); + } + else + SCM_VALIDATE_ULONG_COPY (2, k, i2); if (i2 < 0) { i2 = -i2; @@ -1117,20 +1280,20 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, SCM_DEFINE (scm_ash, "ash", 2, 0, 0, (SCM n, SCM cnt), - "The function ash performs an arithmetic shift left by CNT bits\n" - "(or shift right, if CNT is negative). 'Arithmetic' means, that\n" - "the function does not guarantee to keep the bit structure of N,\n" - "but rather guarantees that the result will always be rounded\n" - "towards minus infinity. Therefore, the results of ash and a\n" - "corresponding bitwise shift will differ if N is negative.\n\n" + "The function ash performs an arithmetic shift left by @var{cnt}\n" + "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n" + "means, that the function does not guarantee to keep the bit\n" + "structure of @var{n}, but rather guarantees that the result\n" + "will always be rounded towards minus infinity. Therefore, the\n" + "results of ash and a corresponding bitwise shift will differ if\n" + "@var{n} is negative.\n" + "\n" "Formally, the function returns an integer equivalent to\n" - "@code{(inexact->exact (floor (* N (expt 2 CNT))))}.@refill\n\n" - "Example:\n" + "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n" + "\n" "@lisp\n" - "(number->string (ash #b1 3) 2)\n" - " @result{} \"1000\"" - "(number->string (ash #b1010 -1) 2)" - " @result{} \"101\"" + "(number->string (ash #b1 3) 2) @result{} \"1000\"\n" + "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n" "@end lisp") #define FUNC_NAME s_scm_ash { @@ -1172,13 +1335,13 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, } #undef FUNC_NAME -/* GJB:FIXME: do not use SCMs as integers! */ + SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, (SCM n, SCM start, SCM end), - "Returns the integer composed of the @var{start} (inclusive) through\n" - "@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes\n" - "the 0-th bit in the result.@refill\n\n" - "Example:\n" + "Return the integer composed of the @var{start} (inclusive)\n" + "through @var{end} (exclusive) bits of @var{n}. The\n" + "@var{start}th bit becomes the 0-th bit in the result.\n" + "\n" "@lisp\n" "(number->string (bit-extract #b1101101010 0 4) 2)\n" " @result{} \"1010\"\n" @@ -1187,36 +1350,68 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, "@end lisp") #define FUNC_NAME s_scm_bit_extract { - int istart, iend; - SCM_VALIDATE_INUM (1,n); - SCM_VALIDATE_INUM_MIN_COPY (2,start,0,istart); + unsigned long int istart, iend; + SCM_VALIDATE_INUM_MIN_COPY (2, start,0, istart); SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend); SCM_ASSERT_RANGE (3, end, (iend >= istart)); -#ifdef SCM_BIGDIG - if (SCM_NINUMP (n)) - return - scm_logand (scm_difference (scm_integer_expt (SCM_MAKINUM (2), - SCM_MAKINUM (iend - istart)), - SCM_MAKINUM (1L)), - scm_ash (n, SCM_MAKINUM (-istart))); -#else - SCM_VALIDATE_INUM (1,n); -#endif - return SCM_MAKINUM ((SCM_INUM (n) >> istart) & ((1L << (iend - istart)) - 1)); + + if (SCM_INUMP (n)) { + long int in = SCM_INUM (n); + unsigned long int bits = iend - istart; + + if (in < 0 && bits >= SCM_I_FIXNUM_BIT) + { + /* Since we emulate two's complement encoded numbers, this special + * case requires us to produce a result that has more bits than can be + * stored in a fixnum. Thus, we fall back to the more general + * algorithm that is used for bignums. + */ + goto generalcase; + } + + if (istart < SCM_I_FIXNUM_BIT) + { + in = in >> istart; + if (bits < SCM_I_FIXNUM_BIT) + return SCM_MAKINUM (in & ((1L << bits) - 1)); + else /* we know: in >= 0 */ + return SCM_MAKINUM (in); + } + else if (in < 0) + { + return SCM_MAKINUM (-1L & ((1L << bits) - 1)); + } + else + { + return SCM_MAKINUM (0); + } + } else if (SCM_BIGP (n)) { + generalcase: + { + SCM num1 = SCM_MAKINUM (1L); + SCM num2 = SCM_MAKINUM (2L); + SCM bits = SCM_MAKINUM (iend - istart); + SCM mask = scm_difference (scm_integer_expt (num2, bits), num1); + return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart))); + } + } else { + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); + } } #undef FUNC_NAME + static const char scm_logtab[] = { 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4 }; SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0, (SCM n), - "Returns the number of bits in integer @var{n}. If integer is positive,\n" - "the 1-bits in its binary representation are counted. If negative, the\n" - "0-bits in its two's-complement binary representation are counted. If 0,\n" - "0 is returned.\n\n" - "Example:\n" + "Return the number of bits in integer @var{n}. If integer is\n" + "positive, the 1-bits in its binary representation are counted.\n" + "If negative, the 0-bits in its two's-complement binary\n" + "representation are counted. If 0, 0 is returned.\n" + "\n" "@lisp\n" "(logcount #b10101010)\n" " @result{} 4\n" @@ -1227,30 +1422,35 @@ SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_logcount { - register unsigned long c = 0; - register long nn; -#ifdef SCM_BIGDIG - if (SCM_NINUMP (n)) - { - scm_sizet i; - SCM_BIGDIG *ds, d; - SCM_VALIDATE_BIGINT (1,n); - if (SCM_BIGSIGN (n)) - return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n)); - ds = SCM_BDIGITS (n); - for (i = SCM_NUMDIGS (n); i--;) - for (d = ds[i]; d; d >>= 4) + if (SCM_INUMP (n)) { + unsigned long int c = 0; + long int nn = SCM_INUM (n); + if (nn < 0) { + nn = -1 - nn; + }; + while (nn) { + c += scm_logtab[15 & nn]; + nn >>= 4; + }; + return SCM_MAKINUM (c); + } else if (SCM_BIGP (n)) { + if (SCM_BIGSIGN (n)) { + return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n)); + } else { + unsigned long int c = 0; + size_t i = SCM_NUMDIGS (n); + SCM_BIGDIG * ds = SCM_BDIGITS (n); + while (i--) { + SCM_BIGDIG d; + for (d = ds[i]; d; d >>= 4) { c += scm_logtab[15 & d]; + } + } return SCM_MAKINUM (c); } -#else - SCM_VALIDATE_INUM (1,n); -#endif - if ((nn = SCM_INUM (n)) < 0) - nn = -1 - nn; - for (; nn; nn >>= 4) - c += scm_logtab[15 & nn]; - return SCM_MAKINUM (c); + } else { + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); + } } #undef FUNC_NAME @@ -1261,8 +1461,8 @@ static const char scm_ilentab[] = { SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0, (SCM n), - "Returns the number of bits neccessary to represent @var{n}.\n\n" - "Example:\n" + "Return the number of bits necessary to represent @var{n}.\n" + "\n" "@lisp\n" "(integer-length #b10101010)\n" " @result{} 8\n" @@ -1273,36 +1473,38 @@ SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_integer_length { - register unsigned long c = 0; - register long nn; - unsigned int l = 4; -#ifdef SCM_BIGDIG - if (SCM_NINUMP (n)) - { - SCM_BIGDIG *ds, d; - SCM_VALIDATE_BIGINT (1,n); - if (SCM_BIGSIGN (n)) - return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n)); - ds = SCM_BDIGITS (n); - d = ds[c = SCM_NUMDIGS (n) - 1]; - for (c *= SCM_BITSPERDIG; d; d >>= 4) - { - c += 4; - l = scm_ilentab[15 & d]; - } - return SCM_MAKINUM (c - 4 + l); - } -#else - SCM_VALIDATE_INUM (1,n); -#endif - if ((nn = SCM_INUM (n)) < 0) - nn = -1 - nn; - for (; nn; nn >>= 4) - { + if (SCM_INUMP (n)) { + unsigned long int c = 0; + unsigned int l = 4; + long int nn = SCM_INUM (n); + if (nn < 0) { + nn = -1 - nn; + }; + while (nn) { c += 4; - l = scm_ilentab[15 & nn]; + l = scm_ilentab [15 & nn]; + nn >>= 4; + }; + return SCM_MAKINUM (c - 4 + l); + } else if (SCM_BIGP (n)) { + if (SCM_BIGSIGN (n)) { + return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n)); + } else { + unsigned long int digs = SCM_NUMDIGS (n) - 1; + unsigned long int c = digs * SCM_BITSPERDIG; + unsigned int l = 4; + SCM_BIGDIG * ds = SCM_BDIGITS (n); + SCM_BIGDIG d = ds [digs]; + while (d) { + c += 4; + l = scm_ilentab [15 & d]; + d >>= 4; + }; + return SCM_MAKINUM (c - 4 + l); } - return SCM_MAKINUM (c - 4 + l); + } else { + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); + } } #undef FUNC_NAME @@ -1311,26 +1513,22 @@ SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0, static const char s_bignum[] = "bignum"; SCM -scm_mkbig (scm_sizet nlen, int sign) +scm_i_mkbig (size_t nlen, int sign) { SCM v; - /* Cast to long int to avoid signed/unsigned comparison warnings. */ - if ((( ((long int) nlen) << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) - != (long int) nlen) - scm_wta (SCM_MAKINUM (nlen), (char *) SCM_NALLOC, s_bignum); - - SCM_NEWCELL (v); - SCM_DEFER_INTS; - SCM_SETCHARS (v, scm_must_malloc ((long) (nlen * sizeof (SCM_BIGDIG)), - s_bignum)); - SCM_SETNUMDIGS (v, nlen, sign); - SCM_ALLOW_INTS; + SCM_BIGDIG *base; + + if (((nlen << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) != nlen) + scm_memory_error (s_bignum); + + base = scm_gc_malloc (nlen * sizeof (SCM_BIGDIG), s_bignum); + + v = scm_cell (SCM_MAKE_BIGNUM_TAG (nlen, sign), (scm_t_bits) base); return v; } - SCM -scm_big2inum (SCM b, scm_sizet l) +scm_i_big2inum (SCM b, size_t l) { unsigned long num = 0; SCM_BIGDIG *tmp = SCM_BDIGITS (b); @@ -1341,43 +1539,40 @@ scm_big2inum (SCM b, scm_sizet l) if (SCM_POSFIXABLE (num)) return SCM_MAKINUM (num); } - else if (SCM_UNEGFIXABLE (num)) + else if (num <= -SCM_MOST_NEGATIVE_FIXNUM) return SCM_MAKINUM (-num); return b; } - -static const char s_adjbig[] = "scm_adjbig"; +static const char s_adjbig[] = "scm_i_adjbig"; SCM -scm_adjbig (SCM b, scm_sizet nlen) +scm_i_adjbig (SCM b, size_t nlen) { - scm_sizet nsiz = nlen; + size_t nsiz = nlen; if (((nsiz << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) != nlen) - scm_wta (scm_ulong2num (nsiz), (char *) SCM_NALLOC, s_adjbig); + scm_memory_error (s_adjbig); SCM_DEFER_INTS; { SCM_BIGDIG *digits = ((SCM_BIGDIG *) - scm_must_realloc ((char *) SCM_CHARS (b), - (long) (SCM_NUMDIGS (b) * sizeof (SCM_BIGDIG)), - (long) (nsiz * sizeof (SCM_BIGDIG)), s_bignum)); + scm_gc_realloc (SCM_BDIGITS (b), + SCM_NUMDIGS (b) * sizeof (SCM_BIGDIG), + nsiz * sizeof (SCM_BIGDIG), s_bignum)); - SCM_SETCHARS (b, digits); + SCM_SET_BIGNUM_BASE (b, digits); SCM_SETNUMDIGS (b, nsiz, SCM_BIGSIGN (b)); } SCM_ALLOW_INTS; return b; } - - SCM -scm_normbig (SCM b) +scm_i_normbig (SCM b) { #ifndef _UNICOS - scm_sizet nlen = SCM_NUMDIGS (b); + size_t nlen = SCM_NUMDIGS (b); #else int nlen = SCM_NUMDIGS (b); /* unsigned nlen breaks on Cray when nlen => 0 */ #endif @@ -1385,143 +1580,36 @@ scm_normbig (SCM b) while (nlen-- && !zds[nlen]); nlen++; if (nlen * SCM_BITSPERDIG / SCM_CHAR_BIT <= sizeof (SCM)) - if (SCM_INUMP (b = scm_big2inum (b, (scm_sizet) nlen))) + if (SCM_INUMP (b = scm_i_big2inum (b, (size_t) nlen))) return b; if (SCM_NUMDIGS (b) == nlen) return b; - return scm_adjbig (b, (scm_sizet) nlen); + return scm_i_adjbig (b, (size_t) nlen); } - - SCM -scm_copybig (SCM b, int sign) +scm_i_copybig (SCM b, int sign) { - scm_sizet i = SCM_NUMDIGS (b); - SCM ans = scm_mkbig (i, sign); + size_t i = SCM_NUMDIGS (b); + SCM ans = scm_i_mkbig (i, sign); SCM_BIGDIG *src = SCM_BDIGITS (b), *dst = SCM_BDIGITS (ans); while (i--) dst[i] = src[i]; return ans; } - - -SCM -scm_long2big (long n) +int +scm_bigcomp (SCM x, SCM y) { - scm_sizet i = 0; - SCM_BIGDIG *digits; - SCM ans = scm_mkbig (SCM_DIGSPERLONG, n < 0); - digits = SCM_BDIGITS (ans); - if (n < 0) - n = -n; - while (i < SCM_DIGSPERLONG) - { - digits[i++] = SCM_BIGLO (n); - n = SCM_BIGDN ((unsigned long) n); - } - return ans; -} + int xsign = SCM_BIGSIGN (x); + int ysign = SCM_BIGSIGN (y); + size_t xlen, ylen; -#ifdef HAVE_LONG_LONGS - -SCM -scm_long_long2big (long_long n) -{ - scm_sizet i; - SCM_BIGDIG *digits; - SCM ans; - int n_digits; - - { - long tn; - tn = (long) n; - if ((long long) tn == n) - return scm_long2big (tn); - } - - { - long_long tn; - - for (tn = n, n_digits = 0; - tn; - ++n_digits, tn = SCM_BIGDN ((ulong_long) tn)) - ; - } - - i = 0; - ans = scm_mkbig (n_digits, n < 0); - digits = SCM_BDIGITS (ans); - if (n < 0) - n = -n; - while (i < n_digits) - { - digits[i++] = SCM_BIGLO (n); - n = SCM_BIGDN ((ulong_long) n); - } - return ans; -} -#endif - - -SCM -scm_2ulong2big (unsigned long *np) -{ - unsigned long n; - scm_sizet i; - SCM_BIGDIG *digits; - SCM ans; - - ans = scm_mkbig (2 * SCM_DIGSPERLONG, 0); - digits = SCM_BDIGITS (ans); - - n = np[0]; - for (i = 0; i < SCM_DIGSPERLONG; ++i) - { - digits[i] = SCM_BIGLO (n); - n = SCM_BIGDN ((unsigned long) n); - } - n = np[1]; - for (i = 0; i < SCM_DIGSPERLONG; ++i) - { - digits[i + SCM_DIGSPERLONG] = SCM_BIGLO (n); - n = SCM_BIGDN ((unsigned long) n); - } - return ans; -} - - - -SCM -scm_ulong2big (unsigned long n) -{ - scm_sizet i = 0; - SCM_BIGDIG *digits; - SCM ans = scm_mkbig (SCM_DIGSPERLONG, 0); - digits = SCM_BDIGITS (ans); - while (i < SCM_DIGSPERLONG) - { - digits[i++] = SCM_BIGLO (n); - n = SCM_BIGDN (n); - } - return ans; -} - - - -int -scm_bigcomp (SCM x, SCM y) -{ - int xsign = SCM_BIGSIGN (x); - int ysign = SCM_BIGSIGN (y); - scm_sizet xlen, ylen; - - /* Look at the signs, first. */ - if (ysign < xsign) - return 1; - if (ysign > xsign) - return -1; + /* Look at the signs, first. */ + if (ysign < xsign) + return 1; + if (ysign > xsign) + return -1; /* They're the same sign, so see which one has more digits. Note that, if they are negative, the longer number is the lesser. */ @@ -1560,7 +1648,7 @@ scm_pseudolong (long x) SCM_BIGDIG bd[SCM_DIGSPERLONG]; } p; - scm_sizet i = 0; + size_t i = 0; if (x < 0) x = -x; while (i < SCM_DIGSPERLONG) @@ -1578,7 +1666,7 @@ scm_pseudolong (long x) void scm_longdigs (long x, SCM_BIGDIG digs[]) { - scm_sizet i = 0; + size_t i = 0; if (x < 0) x = -x; while (i < SCM_DIGSPERLONG) @@ -1592,13 +1680,13 @@ scm_longdigs (long x, SCM_BIGDIG digs[]) SCM -scm_addbig (SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny) +scm_addbig (SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy, int sgny) { /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */ long num = 0; - scm_sizet i = 0, ny = SCM_NUMDIGS (bigy); - SCM z = scm_copybig (bigy, SCM_BIGSIGN (bigy) ^ sgny); + size_t i = 0, ny = SCM_NUMDIGS (bigy); + SCM z = scm_i_copybig (bigy, SCM_BIGSIGN (bigy) ^ sgny); SCM_BIGDIG *zds = SCM_BDIGITS (z); if (xsgn ^ SCM_BIGSIGN (z)) { @@ -1667,21 +1755,21 @@ scm_addbig (SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny) } if (num) { - z = scm_adjbig (z, ny + 1); + z = scm_i_adjbig (z, ny + 1); SCM_BDIGITS (z)[ny] = num; return z; } } - return scm_normbig (z); + return scm_i_normbig (z); } SCM -scm_mulbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn) +scm_mulbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, int sgn) { - scm_sizet i = 0, j = nx + ny; + size_t i = 0, j = nx + ny; unsigned long n = 0; - SCM z = scm_mkbig (j, sgn); + SCM z = scm_i_mkbig (j, sgn); SCM_BIGDIG *zds = SCM_BDIGITS (z); while (j--) zds[j] = 0; @@ -1705,12 +1793,12 @@ scm_mulbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn) } } while (++i < nx); - return scm_normbig (z); + return scm_i_normbig (z); } unsigned int -scm_divbigdig (SCM_BIGDIG * ds, scm_sizet h, SCM_BIGDIG div) +scm_divbigdig (SCM_BIGDIG * ds, size_t h, SCM_BIGDIG div) { register unsigned long t2 = 0; while (h--) @@ -1733,7 +1821,7 @@ scm_divbigint (SCM x, long z, int sgn, int mode) { register unsigned long t2 = 0; register SCM_BIGDIG *ds = SCM_BDIGITS (x); - scm_sizet nd = SCM_NUMDIGS (x); + size_t nd = SCM_NUMDIGS (x); while (nd--) t2 = (SCM_BIGUP (t2) + ds[nd]) % z; if (mode && t2) @@ -1758,14 +1846,14 @@ scm_divbigint (SCM x, long z, int sgn, int mode) static SCM -scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes) +scm_divbigbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, int sgn, int modes) { /* modes description 0 remainder 1 scm_modulo 2 quotient 3 quotient but returns SCM_UNDEFINED if division is not exact. */ - scm_sizet i = 0, j = 0; + size_t i = 0, j = 0; long num = 0; unsigned long t2 = 0; SCM z, newy; @@ -1775,7 +1863,7 @@ scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn switch (modes) { case 0: /* remainder -- just return x */ - z = scm_mkbig (nx, sgn); + z = scm_i_mkbig (nx, sgn); zds = SCM_BDIGITS (z); do { @@ -1784,7 +1872,7 @@ scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn while (++i < nx); return z; case 1: /* scm_modulo -- return y-x */ - z = scm_mkbig (ny, sgn); + z = scm_i_mkbig (ny, sgn); zds = SCM_BDIGITS (z); do { @@ -1822,7 +1910,7 @@ scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn return SCM_UNDEFINED; /* the division is not exact */ } - z = scm_mkbig (nx == ny ? nx + 2 : nx + 1, sgn); + z = scm_i_mkbig (nx == ny ? nx + 2 : nx + 1, sgn); zds = SCM_BDIGITS (z); if (nx == ny) zds[nx + 1] = 0; @@ -1831,7 +1919,7 @@ scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn if (y[ny - 1] < (SCM_BIGRAD >> 1)) { /* normalize operands */ d = SCM_BIGRAD / (y[ny - 1] + 1); - newy = scm_mkbig (ny, 0); + newy = scm_i_mkbig (ny, 0); yds = SCM_BDIGITS (newy); while (j < ny) { @@ -1945,9 +2033,9 @@ scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn doadj: for (j = ny; j && !zds[j - 1]; --j); if (j * SCM_BITSPERDIG <= sizeof (SCM) * SCM_CHAR_BIT) - if (SCM_INUMP (z = scm_big2inum (z, j))) + if (SCM_INUMP (z = scm_i_big2inum (z, j))) return z; - return scm_adjbig (z, j); + return scm_i_adjbig (z, j); } #endif @@ -1966,46 +2054,68 @@ static const double fx[] = -static scm_sizet +static size_t idbl2str (double f, char *a) { int efmt, dpt, d, i, wp = scm_dblprec; - scm_sizet ch = 0; + size_t ch = 0; int exp = 0; if (f == 0.0) - goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */ + { +#ifdef HAVE_COPYSIGN + double sgn = copysign (1.0, f); + + if (sgn < 0.0) + a[ch++] = '-'; +#endif + + goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */ + } + + if (xisinf (f)) + { + if (f < 0) + strcpy (a, "-inf.0"); + else + strcpy (a, "+inf.0"); + return ch+6; + } + else if (xisnan (f)) + { + strcpy (a, "+nan.0"); + return ch+6; + } + if (f < 0.0) { f = -f; a[ch++] = '-'; } - else if (f > 0.0); - else - goto funny; - if (IS_INF (f)) - { - if (ch == 0) - a[ch++] = '+'; - funny: - a[ch++] = '#'; - a[ch++] = '.'; - a[ch++] = '#'; - return ch; - } + #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from make-uniform-vector, from causing infinite loops. */ while (f < 1.0) { f *= 10.0; if (exp-- < DBL_MIN_10_EXP) - goto funny; + { + a[ch++] = '#'; + a[ch++] = '.'; + a[ch++] = '#'; + return ch; + } } while (f > 10.0) { f *= 0.10; if (exp++ > DBL_MAX_10_EXP) - goto funny; + { + a[ch++] = '#'; + a[ch++] = '.'; + a[ch++] = '#'; + return ch; + } } #else while (f < 1.0) @@ -2106,20 +2216,23 @@ idbl2str (double f, char *a) } -static scm_sizet +static size_t iflo2str (SCM flt, char *str) { - scm_sizet i; - if (SCM_SLOPPY_REALP (flt)) + size_t i; + if (SCM_REALP (flt)) i = idbl2str (SCM_REAL_VALUE (flt), str); else { i = idbl2str (SCM_COMPLEX_REAL (flt), str); if (SCM_COMPLEX_IMAG (flt) != 0.0) { - if (0 <= SCM_COMPLEX_IMAG (flt)) + double imag = SCM_COMPLEX_IMAG (flt); + /* Don't output a '+' for negative numbers or for Inf and + NaN. They will provide their own sign. */ + if (0 <= imag && !xisinf (imag) && !xisnan (imag)) str[i++] = '+'; - i += idbl2str (SCM_COMPLEX_IMAG (flt), &str[i]); + i += idbl2str (imag, &str[i]); str[i++] = 'i'; } } @@ -2130,11 +2243,11 @@ iflo2str (SCM flt, char *str) characters in the result. rad is output base p is destination: worst case (base 2) is SCM_INTBUFLEN */ -scm_sizet +size_t scm_iint2str (long num, int rad, char *p) { - scm_sizet j = 1; - scm_sizet i; + size_t j = 1; + size_t i; unsigned long n = (num < 0) ? -num : num; for (n /= rad; n > 0; n /= rad) @@ -2165,24 +2278,28 @@ scm_iint2str (long num, int rad, char *p) static SCM big2str (SCM b, unsigned int radix) { - SCM t = scm_copybig (b, 0); /* sign of temp doesn't matter */ + SCM t = scm_i_copybig (b, 0); /* sign of temp doesn't matter */ register SCM_BIGDIG *ds = SCM_BDIGITS (t); - scm_sizet i = SCM_NUMDIGS (t); - scm_sizet j = radix == 16 ? (SCM_BITSPERDIG * i) / 4 + 2 + size_t i = SCM_NUMDIGS (t); + size_t j = radix == 16 ? (SCM_BITSPERDIG * i) / 4 + 2 : radix >= 10 ? (SCM_BITSPERDIG * i * 241L) / 800 + 2 : (SCM_BITSPERDIG * i) + 2; - scm_sizet k = 0; - scm_sizet radct = 0; - scm_sizet ch; /* jeh */ + size_t k = 0; + size_t radct = 0; SCM_BIGDIG radpow = 1, radmod = 0; - SCM ss = scm_makstr ((long) j, 0); - char *s = SCM_CHARS (ss), c; + SCM ss = scm_allocate_string (j); + char *s = SCM_STRING_CHARS (ss), c; + + if (i == 0) + { + return scm_makfrom0str ("0"); + } + while ((long) radpow * radix < SCM_BIGRAD) { radpow *= radix; radct++; } - s[0] = SCM_BIGSIGN (b) ? '-' : '+'; while ((i || radmod) && j) { if (k == 0) @@ -2197,13 +2314,15 @@ big2str (SCM b, unsigned int radix) k--; s[--j] = c < 10 ? c + '0' : c + 'a' - 10; } - ch = s[0] == '-' ? 1 : 0; /* jeh */ - if (ch < j) - { /* jeh */ - for (i = j; j < SCM_LENGTH (ss); j++) - s[ch + j - i] = s[j]; /* jeh */ - scm_vector_set_length_x (ss, /* jeh */ - SCM_MAKINUM (ch + SCM_LENGTH (ss) - i)); + + if (SCM_BIGSIGN (b)) + s[--j] = '-'; + + if (j > 0) + { + /* The pre-reserved string length was too large. */ + unsigned long int length = SCM_STRING_LENGTH (ss); + ss = scm_substring (ss, SCM_MAKINUM (j), SCM_MAKINUM (length)); } return scm_return_first (ss, t); @@ -2214,8 +2333,8 @@ big2str (SCM b, unsigned int radix) SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, (SCM n, SCM radix), "Return a string holding the external representation of the\n" - "number N in the given RADIX. If N is inexact, a radix of 10\n" - "will be used.") + "number @var{n} in the given @var{radix}. If @var{n} is\n" + "inexact, a radix of 10 will be used.") #define FUNC_NAME s_scm_number_to_string { int base; @@ -2230,13 +2349,13 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, if (SCM_INUMP (n)) { char num_buf [SCM_INTBUFLEN]; - scm_sizet length = scm_iint2str (SCM_INUM (n), base, num_buf); - return scm_makfromstr (num_buf, length, 0); + size_t length = scm_iint2str (SCM_INUM (n), base, num_buf); + return scm_mem2string (num_buf, length); } else if (SCM_BIGP (n)) { return big2str (n, (unsigned int) base); } else if (SCM_INEXACTP (n)) { - char num_buf [SCM_FLOBUFLEN]; - return scm_makfromstr (num_buf, iflo2str (n, num_buf), 0); + char num_buf [FLOBUFLEN]; + return scm_mem2string (num_buf, iflo2str (n, num_buf)); } else { SCM_WRONG_TYPE_ARG (1, n); } @@ -2248,27 +2367,27 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, SCM_BIGDIG conditionals */ int -scm_print_real (SCM sexp, SCM port, scm_print_state *pstate) +scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) { - char num_buf[SCM_FLOBUFLEN]; + char num_buf[FLOBUFLEN]; scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port); return !0; } int -scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate) +scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) { - char num_buf[SCM_FLOBUFLEN]; + char num_buf[FLOBUFLEN]; scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port); return !0; } int -scm_bigprint (SCM exp, SCM port, scm_print_state *pstate) +scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { #ifdef SCM_BIGDIG exp = big2str (exp, (unsigned int) 10); - scm_lfwrite (SCM_CHARS (exp), (scm_sizet) SCM_LENGTH (exp), port); + scm_lfwrite (SCM_STRING_CHARS (exp), (size_t) SCM_STRING_LENGTH (exp), port); #else scm_ipruk ("bignum", exp, port); #endif @@ -2276,551 +2395,627 @@ scm_bigprint (SCM exp, SCM port, scm_print_state *pstate) } /*** END nums->strs ***/ + /*** STRINGS -> NUMBERS ***/ +/* The following functions implement the conversion from strings to numbers. + * The implementation somehow follows the grammar for numbers as it is given + * in R5RS. Thus, the functions resemble syntactic units (, + * , ...) that are used to build up numbers in the grammar. Some + * points should be noted about the implementation: + * * Each function keeps a local index variable 'idx' that points at the + * current position within the parsed string. The global index is only + * updated if the function could parse the corresponding syntactic unit + * successfully. + * * Similarly, the functions keep track of indicators of inexactness ('#', + * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the + * global exactness information is only updated after each part has been + * successfully parsed. + * * Sequences of digits are parsed into temporary variables holding fixnums. + * Only if these fixnums would overflow, the result variables are updated + * using the standard functions scm_add, scm_product, scm_divide etc. Then, + * the temporary variables holding the fixnums are cleared, and the process + * starts over again. If for example fixnums were able to store five decimal + * digits, a number 1234567890 would be parsed in two parts 12345 and 67890, + * and the result was computed as 12345 * 100000 + 67890. In other words, + * only every five digits two bignum operations were performed. + */ + +enum t_exactness {NO_EXACTNESS, INEXACT, EXACT}; + +/* R5RS, section 7.1.1, lexical structure of numbers: . */ + +/* In non ASCII-style encodings the following macro might not work. */ +#define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10) + static SCM -scm_small_istr2int (char *str, long len, long radix) +mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, + unsigned int radix, enum t_exactness *p_exactness) { - register long n = 0, ln; - register int c; - register int i = 0; - int lead_neg = 0; - if (0 >= len) - return SCM_BOOL_F; /* zero scm_length */ - switch (*str) - { /* leading sign */ - case '-': - lead_neg = 1; - case '+': - if (++i == len) - return SCM_BOOL_F; /* bad if lone `+' or `-' */ - } + unsigned int idx = *p_idx; + unsigned int hash_seen = 0; + scm_t_bits shift = 1; + scm_t_bits add = 0; + unsigned int digit_value; + SCM result; + char c; + + if (idx == len) + return SCM_BOOL_F; - do + c = mem[idx]; + if (!isxdigit (c)) + return SCM_BOOL_F; + digit_value = XDIGIT2UINT (c); + if (digit_value >= radix) + return SCM_BOOL_F; + + idx++; + result = SCM_MAKINUM (digit_value); + while (idx != len) { - switch (c = str[i++]) + char c = mem[idx]; + if (isxdigit (c)) { - case DIGITS: - c = c - '0'; - goto accumulate; - case 'A': - case 'B': - case 'C': - case 'D': - case 'E': - case 'F': - c = c - 'A' + 10; - goto accumulate; - case 'a': - case 'b': - case 'c': - case 'd': - case 'e': - case 'f': - c = c - 'a' + 10; - accumulate: - if (c >= radix) - return SCM_BOOL_F; /* bad digit for radix */ - ln = n; - n = n * radix - c; - /* Negation is a workaround for HP700 cc bug */ - if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM)) - goto ovfl; - break; - default: - return SCM_BOOL_F; /* not a digit */ + if (hash_seen) + break; + digit_value = XDIGIT2UINT (c); + if (digit_value >= radix) + break; } - } - while (i < len); - if (!lead_neg) - if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM) - goto ovfl; - return SCM_MAKINUM (n); - ovfl: /* overflow scheme integer */ - return SCM_BOOL_F; + else if (c == '#') + { + hash_seen = 1; + digit_value = 0; + } + else + break; + + idx++; + if (SCM_MOST_POSITIVE_FIXNUM / radix < shift) + { + result = scm_product (result, SCM_MAKINUM (shift)); + if (add > 0) + result = scm_sum (result, SCM_MAKINUM (add)); + + shift = radix; + add = digit_value; + } + else + { + shift = shift * radix; + add = add * radix + digit_value; + } + }; + + if (shift > 1) + result = scm_product (result, SCM_MAKINUM (shift)); + if (add > 0) + result = scm_sum (result, SCM_MAKINUM (add)); + + *p_idx = idx; + if (hash_seen) + *p_exactness = INEXACT; + + return result; } +/* R5RS, section 7.1.1, lexical structure of numbers: . Only + * covers the parts of the rules that start at a potential point. The value + * of the digits up to the point have been parsed by the caller and are given + * in variable result. The content of *p_exactness indicates, whether a hash + * has already been seen in the digits before the point. + */ -SCM -scm_istr2int (char *str, long len, long radix) +/* In non ASCII-style encodings the following macro might not work. */ +#define DIGIT2UINT(d) ((d) - '0') + +static SCM +mem2decimal_from_point (SCM result, const char* mem, size_t len, + unsigned int *p_idx, enum t_exactness *p_exactness) { - scm_sizet j; - register scm_sizet k, blen = 1; - scm_sizet i = 0; - int c; - SCM res; - register SCM_BIGDIG *ds; - register unsigned long t2; - - if (0 >= len) - return SCM_BOOL_F; /* zero scm_length */ - - /* Short numbers we parse directly into an int, to avoid the overhead - of creating a bignum. */ - if (len < 6) - return scm_small_istr2int (str, len, radix); - - if (16 == radix) - j = 1 + (4 * len * sizeof (char)) / (SCM_BITSPERDIG); - else if (10 <= radix) - j = 1 + (84 * len * sizeof (char)) / (SCM_BITSPERDIG * 25); - else - j = 1 + (len * sizeof (char)) / (SCM_BITSPERDIG); - switch (str[0]) - { /* leading sign */ - case '-': - case '+': - if (++i == (unsigned) len) - return SCM_BOOL_F; /* bad if lone `+' or `-' */ + unsigned int idx = *p_idx; + enum t_exactness x = *p_exactness; + + if (idx == len) + return result; + + if (mem[idx] == '.') + { + scm_t_bits shift = 1; + scm_t_bits add = 0; + unsigned int digit_value; + SCM big_shift = SCM_MAKINUM (1); + + idx++; + while (idx != len) + { + char c = mem[idx]; + if (isdigit (c)) + { + if (x == INEXACT) + return SCM_BOOL_F; + else + digit_value = DIGIT2UINT (c); + } + else if (c == '#') + { + x = INEXACT; + digit_value = 0; + } + else + break; + + idx++; + if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift) + { + big_shift = scm_product (big_shift, SCM_MAKINUM (shift)); + result = scm_product (result, SCM_MAKINUM (shift)); + if (add > 0) + result = scm_sum (result, SCM_MAKINUM (add)); + + shift = 10; + add = digit_value; + } + else + { + shift = shift * 10; + add = add * 10 + digit_value; + } + }; + + if (add > 0) + { + big_shift = scm_product (big_shift, SCM_MAKINUM (shift)); + result = scm_product (result, SCM_MAKINUM (shift)); + result = scm_sum (result, SCM_MAKINUM (add)); + } + + result = scm_divide (result, big_shift); + + /* We've seen a decimal point, thus the value is implicitly inexact. */ + x = INEXACT; } - res = scm_mkbig (j, '-' == str[0]); - ds = SCM_BDIGITS (res); - for (k = j; k--;) - ds[k] = 0; - do + + if (idx != len) { - switch (c = str[i++]) + int sign = 1; + unsigned int start; + char c; + int exponent; + SCM e; + + /* R5RS, section 7.1.1, lexical structure of numbers: */ + + switch (mem[idx]) { - case DIGITS: - c = c - '0'; - goto accumulate; - case 'A': - case 'B': - case 'C': - case 'D': - case 'E': - case 'F': - c = c - 'A' + 10; - goto accumulate; - case 'a': - case 'b': - case 'c': - case 'd': - case 'e': - case 'f': - c = c - 'a' + 10; - accumulate: - if (c >= radix) - return SCM_BOOL_F; /* bad digit for radix */ - k = 0; - t2 = c; - moretodo: - while (k < blen) + case 'd': case 'D': + case 'e': case 'E': + case 'f': case 'F': + case 'l': case 'L': + case 's': case 'S': + idx++; + start = idx; + c = mem[idx]; + if (c == '-') { -/* printf ("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]); */ - t2 += ds[k] * radix; - ds[k++] = SCM_BIGLO (t2); - t2 = SCM_BIGDN (t2); + idx++; + sign = -1; + c = mem[idx]; } - if (blen > j) - scm_num_overflow ("bignum"); - if (t2) + else if (c == '+') { - blen++; - goto moretodo; + idx++; + sign = 1; + c = mem[idx]; } + else + sign = 1; + + if (!isdigit (c)) + return SCM_BOOL_F; + + idx++; + exponent = DIGIT2UINT (c); + while (idx != len) + { + char c = mem[idx]; + if (isdigit (c)) + { + idx++; + if (exponent <= SCM_MAXEXP) + exponent = exponent * 10 + DIGIT2UINT (c); + } + else + break; + } + + if (exponent > SCM_MAXEXP) + { + size_t exp_len = idx - start; + SCM exp_string = scm_mem2string (&mem[start], exp_len); + SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED); + scm_out_of_range ("string->number", exp_num); + } + + e = scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent)); + if (sign == 1) + result = scm_product (result, e); + else + result = scm_divide (result, e); + + /* We've seen an exponent, thus the value is implicitly inexact. */ + x = INEXACT; + break; + default: - return SCM_BOOL_F; /* not a digit */ + break; } } - while (i < (unsigned) len); - if (blen * SCM_BITSPERDIG / SCM_CHAR_BIT <= sizeof (SCM)) - if (SCM_INUMP (res = scm_big2inum (res, blen))) - return res; - if (j == blen) - return res; - return scm_adjbig (res, blen); + + *p_idx = idx; + if (x == INEXACT) + *p_exactness = x; + + return result; } -SCM -scm_istr2flo (char *str, long len, long radix) + +/* R5RS, section 7.1.1, lexical structure of numbers: */ + +static SCM +mem2ureal (const char* mem, size_t len, unsigned int *p_idx, + unsigned int radix, enum t_exactness *p_exactness) { - register int c, i = 0; - double lead_sgn; - double res = 0.0, tmp = 0.0; - int flg = 0; - int point = 0; - SCM second; - - if (i >= len) - return SCM_BOOL_F; /* zero scm_length */ - - switch (*str) - { /* leading sign */ - case '-': - lead_sgn = -1.0; - i++; - break; - case '+': - lead_sgn = 1.0; - i++; - break; - default: - lead_sgn = 0.0; + unsigned int idx = *p_idx; + SCM result; + + if (idx == len) + return SCM_BOOL_F; + + if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5)) + { + *p_idx = idx+5; + return scm_inf (); } - if (i == len) - return SCM_BOOL_F; /* bad if lone `+' or `-' */ - - if (str[i] == 'i' || str[i] == 'I') - { /* handle `+i' and `-i' */ - if (lead_sgn == 0.0) - return SCM_BOOL_F; /* must have leading sign */ - if (++i < len) - return SCM_BOOL_F; /* `i' not last character */ - return scm_make_complex (0.0, lead_sgn); + + if (idx+4 < len && !strncmp (mem+idx, "nan.", 4)) + { + enum t_exactness x = EXACT; + + /* Cobble up the fraction. We might want to set the NaN's + mantissa from it. */ + idx += 4; + mem2uinteger (mem, len, &idx, 10, &x); + *p_idx = idx; + return scm_nan (); } - do - { /* check initial digits */ - switch (c = str[i]) + + if (mem[idx] == '.') + { + if (radix != 10) + return SCM_BOOL_F; + else if (idx + 1 == len) + return SCM_BOOL_F; + else if (!isdigit (mem[idx + 1])) + return SCM_BOOL_F; + else + result = mem2decimal_from_point (SCM_MAKINUM (0), mem, len, + p_idx, p_exactness); + } + else + { + enum t_exactness x = EXACT; + SCM uinteger; + + uinteger = mem2uinteger (mem, len, &idx, radix, &x); + if (SCM_FALSEP (uinteger)) + return SCM_BOOL_F; + + if (idx == len) + result = uinteger; + else if (mem[idx] == '/') { - case DIGITS: - c = c - '0'; - goto accum1; - case 'D': - case 'E': - case 'F': - if (radix == 10) - goto out1; /* must be exponent */ - case 'A': - case 'B': - case 'C': - c = c - 'A' + 10; - goto accum1; - case 'd': - case 'e': - case 'f': - if (radix == 10) - goto out1; - case 'a': - case 'b': - case 'c': - c = c - 'a' + 10; - accum1: - if (c >= radix) - return SCM_BOOL_F; /* bad digit for radix */ - res = res * radix + c; - flg = 1; /* res is valid */ - break; - default: - goto out1; + SCM divisor; + + idx++; + + divisor = mem2uinteger (mem, len, &idx, radix, &x); + if (SCM_FALSEP (divisor)) + return SCM_BOOL_F; + + result = scm_divide (uinteger, divisor); } + else if (radix == 10) + { + result = mem2decimal_from_point (uinteger, mem, len, &idx, &x); + if (SCM_FALSEP (result)) + return SCM_BOOL_F; + } + else + result = uinteger; + + *p_idx = idx; + if (x == INEXACT) + *p_exactness = x; } - while (++i < len); - out1: - /* if true, then we did see a digit above, and res is valid */ - if (i == len) - goto done; + /* When returning an inexact zero, make sure it is represented as a + floating point value so that we can change its sign. + */ + if (SCM_EQ_P (result, SCM_MAKINUM(0)) && *p_exactness == INEXACT) + result = scm_make_real (0.0); + + return result; +} - /* By here, must have seen a digit, - or must have next char be a `.' with radix==10 */ - if (!flg) - if (!(str[i] == '.' && radix == 10)) - return SCM_BOOL_F; - while (str[i] == '#') - { /* optional sharps */ - res *= radix; - if (++i == len) - goto done; +/* R5RS, section 7.1.1, lexical structure of numbers: */ + +static SCM +mem2complex (const char* mem, size_t len, unsigned int idx, + unsigned int radix, enum t_exactness *p_exactness) +{ + char c; + int sign = 0; + SCM ureal; + + if (idx == len) + return SCM_BOOL_F; + + c = mem[idx]; + if (c == '+') + { + idx++; + sign = 1; + } + else if (c == '-') + { + idx++; + sign = -1; } - if (str[i] == '/') + if (idx == len) + return SCM_BOOL_F; + + ureal = mem2ureal (mem, len, &idx, radix, p_exactness); + if (SCM_FALSEP (ureal)) { - while (++i < len) + /* input must be either +i or -i */ + + if (sign == 0) + return SCM_BOOL_F; + + if (mem[idx] == 'i' || mem[idx] == 'I') { - switch (c = str[i]) - { - case DIGITS: - c = c - '0'; - goto accum2; - case 'A': - case 'B': - case 'C': - case 'D': - case 'E': - case 'F': - c = c - 'A' + 10; - goto accum2; - case 'a': - case 'b': - case 'c': - case 'd': - case 'e': - case 'f': - c = c - 'a' + 10; - accum2: - if (c >= radix) - return SCM_BOOL_F; - tmp = tmp * radix + c; - break; - default: - goto out2; - } + idx++; + if (idx != len) + return SCM_BOOL_F; + + return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign)); } - out2: - if (tmp == 0.0) - return SCM_BOOL_F; /* `slash zero' not allowed */ - if (i < len) - while (str[i] == '#') - { /* optional sharps */ - tmp *= radix; - if (++i == len) - break; - } - res /= tmp; - goto done; + else + return SCM_BOOL_F; } + else + { + if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal))) + ureal = scm_difference (ureal, SCM_UNDEFINED); - if (str[i] == '.') - { /* decimal point notation */ - if (radix != 10) - return SCM_BOOL_F; /* must be radix 10 */ - while (++i < len) + if (idx == len) + return ureal; + + c = mem[idx]; + switch (c) { - switch (c = str[i]) + case 'i': case 'I': + /* either +i or -i */ + + idx++; + if (sign == 0) + return SCM_BOOL_F; + if (idx != len) + return SCM_BOOL_F; + return scm_make_rectangular (SCM_MAKINUM (0), ureal); + + case '@': + /* polar input: @. */ + + idx++; + if (idx == len) + return SCM_BOOL_F; + else { - case DIGITS: - point--; - res = res * 10.0 + c - '0'; - flg = 1; - break; - default: - goto out3; + int sign; + SCM angle; + SCM result; + + c = mem[idx]; + if (c == '+') + { + idx++; + sign = 1; + } + else if (c == '-') + { + idx++; + sign = -1; + } + else + sign = 1; + + angle = mem2ureal (mem, len, &idx, radix, p_exactness); + if (SCM_FALSEP (angle)) + return SCM_BOOL_F; + if (idx != len) + return SCM_BOOL_F; + + if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal))) + angle = scm_difference (angle, SCM_UNDEFINED); + + result = scm_make_polar (ureal, angle); + return result; } - } - out3: - if (!flg) - return SCM_BOOL_F; /* no digits before or after decimal point */ - if (i == len) - goto adjust; - while (str[i] == '#') - { /* ignore remaining sharps */ - if (++i == len) - goto adjust; - } - } + case '+': + case '-': + /* expecting input matching [+-]?i */ - switch (str[i]) - { /* exponent */ - case 'd': - case 'D': - case 'e': - case 'E': - case 'f': - case 'F': - case 'l': - case 'L': - case 's': - case 'S': - { - int expsgn = 1, expon = 0; - if (radix != 10) - return SCM_BOOL_F; /* only in radix 10 */ - if (++i == len) - return SCM_BOOL_F; /* bad exponent */ - switch (str[i]) - { - case '-': - expsgn = (-1); - case '+': - if (++i == len) - return SCM_BOOL_F; /* bad exponent */ - } - if (str[i] < '0' || str[i] > '9') - return SCM_BOOL_F; /* bad exponent */ - do - { - switch (c = str[i]) - { - case DIGITS: - expon = expon * 10 + c - '0'; - if (expon > SCM_MAXEXP) - return SCM_BOOL_F; /* exponent too large */ - break; - default: - goto out4; - } - } - while (++i < len); - out4: - point += expsgn * expon; - } - } + idx++; + if (idx == len) + return SCM_BOOL_F; + else + { + int sign = (c == '+') ? 1 : -1; + SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness); - adjust: - if (point >= 0) - while (point--) - res *= 10.0; - else -#ifdef _UNICOS - while (point++) - res *= 0.1; -#else - while (point++) - res /= 10.0; -#endif + if (SCM_FALSEP (imag)) + imag = SCM_MAKINUM (sign); + else if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal))) + imag = scm_difference (imag, SCM_UNDEFINED); - done: - /* at this point, we have a legitimate floating point result */ - if (lead_sgn == -1.0) - res = -res; - if (i == len) - return scm_make_real (res); - - if (str[i] == 'i' || str[i] == 'I') - { /* pure imaginary number */ - if (lead_sgn == 0.0) - return SCM_BOOL_F; /* must have leading sign */ - if (++i < len) - return SCM_BOOL_F; /* `i' not last character */ - return scm_make_complex (0.0, res); - } + if (idx == len) + return SCM_BOOL_F; + if (mem[idx] != 'i' && mem[idx] != 'I') + return SCM_BOOL_F; - switch (str[i++]) - { - case '-': - lead_sgn = -1.0; - break; - case '+': - lead_sgn = 1.0; - break; - case '@': - { /* polar input for complex number */ - /* get a `real' for scm_angle */ - second = scm_istr2flo (&str[i], (long) (len - i), radix); - if (!SCM_SLOPPY_INEXACTP (second)) - return SCM_BOOL_F; /* not `real' */ - if (SCM_SLOPPY_COMPLEXP (second)) - return SCM_BOOL_F; /* not `real' */ - tmp = SCM_REAL_VALUE (second); - return scm_make_complex (res * cos (tmp), res * sin (tmp)); - } - default: - return SCM_BOOL_F; - } + idx++; + if (idx != len) + return SCM_BOOL_F; - /* at this point, last char must be `i' */ - if (str[len - 1] != 'i' && str[len - 1] != 'I') - return SCM_BOOL_F; - /* handles `x+i' and `x-i' */ - if (i == (len - 1)) - return scm_make_complex (res, lead_sgn); - /* get a `ureal' for complex part */ - second = scm_istr2flo (&str[i], (long) ((len - i) - 1), radix); - if (!SCM_INEXACTP (second)) - return SCM_BOOL_F; /* not `ureal' */ - if (SCM_SLOPPY_COMPLEXP (second)) - return SCM_BOOL_F; /* not `ureal' */ - tmp = SCM_REAL_VALUE (second); - if (tmp < 0.0) - return SCM_BOOL_F; /* not `ureal' */ - return scm_make_complex (res, (lead_sgn * tmp)); + return scm_make_rectangular (ureal, imag); + } + default: + return SCM_BOOL_F; + } + } } +/* R5RS, section 7.1.1, lexical structure of numbers: */ + +enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16}; SCM -scm_istring2number (char *str, long len, long radix) +scm_i_mem2number (const char* mem, size_t len, unsigned int default_radix) { - int i = 0; - char ex = 0; - char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */ - SCM res; - if (len == 1) - if (*str == '+' || *str == '-') /* Catches lone `+' and `-' for speed */ - return SCM_BOOL_F; - - while ((len - i) >= 2 && str[i] == '#' && ++i) - switch (str[i++]) - { - case 'b': - case 'B': - if (rx_p++) - return SCM_BOOL_F; - radix = 2; - break; - case 'o': - case 'O': - if (rx_p++) - return SCM_BOOL_F; - radix = 8; - break; - case 'd': - case 'D': - if (rx_p++) - return SCM_BOOL_F; - radix = 10; - break; - case 'x': - case 'X': - if (rx_p++) - return SCM_BOOL_F; - radix = 16; - break; - case 'i': - case 'I': - if (ex_p++) - return SCM_BOOL_F; - ex = 2; - break; - case 'e': - case 'E': - if (ex_p++) - return SCM_BOOL_F; - ex = 1; - break; - default: - return SCM_BOOL_F; - } + unsigned int idx = 0; + unsigned int radix = NO_RADIX; + enum t_exactness forced_x = NO_EXACTNESS; + enum t_exactness implicit_x = EXACT; + SCM result; + + /* R5RS, section 7.1.1, lexical structure of numbers: */ + while (idx + 2 < len && mem[idx] == '#') + { + switch (mem[idx + 1]) + { + case 'b': case 'B': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = DUAL; + break; + case 'd': case 'D': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = DEC; + break; + case 'i': case 'I': + if (forced_x != NO_EXACTNESS) + return SCM_BOOL_F; + forced_x = INEXACT; + break; + case 'e': case 'E': + if (forced_x != NO_EXACTNESS) + return SCM_BOOL_F; + forced_x = EXACT; + break; + case 'o': case 'O': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = OCT; + break; + case 'x': case 'X': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = HEX; + break; + default: + return SCM_BOOL_F; + } + idx += 2; + } + + /* R5RS, section 7.1.1, lexical structure of numbers: */ + if (radix == NO_RADIX) + result = mem2complex (mem, len, idx, default_radix, &implicit_x); + else + result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x); + + if (SCM_FALSEP (result)) + return SCM_BOOL_F; - switch (ex) + switch (forced_x) { - case 1: - return scm_istr2int (&str[i], len - i, radix); - case 0: - res = scm_istr2int (&str[i], len - i, radix); - if (SCM_NFALSEP (res)) - return res; - case 2: - return scm_istr2flo (&str[i], len - i, radix); + case EXACT: + if (SCM_INEXACTP (result)) + /* FIXME: This may change the value. */ + return scm_inexact_to_exact (result); + else + return result; + case INEXACT: + if (SCM_INEXACTP (result)) + return result; + else + return scm_exact_to_inexact (result); + case NO_EXACTNESS: + default: + if (implicit_x == INEXACT) + { + if (SCM_INEXACTP (result)) + return result; + else + return scm_exact_to_inexact (result); + } + else + return result; } - return SCM_BOOL_F; } SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, (SCM string, SCM radix), - "Returns a number of the maximally precise representation\n" - "expressed by the given STRING. RADIX must be an exact integer,\n" - "either 2, 8, 10, or 16. If supplied, RADIX is a default radix\n" - "that may be overridden by an explicit radix prefix in STRING\n" - "(e.g. \"#o177\"). If RADIX is not supplied, then the default\n" - "radix is 10. If string is not a syntactically valid notation\n" - "for a number, then `string->number' returns #f. (r5rs)") + "Return a number of the maximally precise representation\n" + "expressed by the given @var{string}. @var{radix} must be an\n" + "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n" + "is a default radix that may be overridden by an explicit radix\n" + "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n" + "supplied, then the default radix is 10. If string is not a\n" + "syntactically valid notation for a number, then\n" + "@code{string->number} returns @code{#f}.") #define FUNC_NAME s_scm_string_to_number { SCM answer; int base; - SCM_VALIDATE_ROSTRING (1,string); - SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix,2,10,base); - answer = scm_istring2number (SCM_ROCHARS (string), - SCM_ROLENGTH (string), - base); + SCM_VALIDATE_STRING (1, string); + SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix,2,10, base); + answer = scm_i_mem2number (SCM_STRING_CHARS (string), + SCM_STRING_LENGTH (string), + base); return scm_return_first (answer, string); } #undef FUNC_NAME + + /*** END strs->nums ***/ SCM scm_make_real (double x) { - SCM z; - SCM_NEWCELL2 (z); - SCM_SET_CELL_TYPE (z, scm_tc16_real); + SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0); + SCM_REAL_VALUE (z) = x; return z; } @@ -2833,7 +3028,8 @@ scm_make_complex (double x, double y) return scm_make_real (x); } else { SCM z; - SCM_NEWSMOB (z, scm_tc16_complex, scm_must_malloc (2L * sizeof (double), "complex")); + SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (2*sizeof (double), + "complex")); SCM_COMPLEX_REAL (z) = x; SCM_COMPLEX_IMAG (z) = y; return z; @@ -2867,13 +3063,18 @@ scm_complex_equalp (SCM x, SCM y) SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p); - +/* "Return @code{#t} if @var{x} is a number, @code{#f}\n" + * "else. Note that the sets of complex, real, rational and\n" + * "integer values form subsets of the set of numbers, i. e. the\n" + * "predicate will be fulfilled for any number." + */ SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0, (SCM x), - "Return #t if X is a complex number, #f else. Note that the\n" - "sets of real, rational and integer values form subsets of the\n" - "set of complex numbers, i. e. the predicate will also be\n" - "fulfilled if X is a real, rational or integer number.") + "Return @code{#t} if @var{x} is a complex number, @code{#f}\n" + "otherwise. Note that the sets of real, rational and integer\n" + "values form subsets of the set of complex numbers, i. e. the\n" + "predicate will also be fulfilled if @var{x} is a real,\n" + "rational or integer number.") #define FUNC_NAME s_scm_number_p { return SCM_BOOL (SCM_NUMBERP (x)); @@ -2882,20 +3083,26 @@ SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0, SCM_REGISTER_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p); - +/* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n" + * "Note that the sets of integer and rational values form a subset\n" + * "of the set of real numbers, i. e. the predicate will also\n" + * "be fulfilled if @var{x} is an integer or a rational number." + */ SCM_DEFINE (scm_real_p, "rational?", 1, 0, 0, (SCM x), - "Return #t if X is a rational number, #f else. Note that the\n" - "set of integer values forms a subset of the set of rational\n" - "numbers, i. e. the predicate will also be fulfilled if X is an\n" - "integer number.") + "Return @code{#t} if @var{x} is a rational number, @code{#f}\n" + "otherwise. Note that the set of integer values forms a subset of\n" + "the set of rational numbers, i. e. the predicate will also be\n" + "fulfilled if @var{x} is an integer number. Real numbers\n" + "will also satisfy this predicate, because of their limited\n" + "precision.") #define FUNC_NAME s_scm_real_p { if (SCM_INUMP (x)) { return SCM_BOOL_T; } else if (SCM_IMP (x)) { return SCM_BOOL_F; - } else if (SCM_SLOPPY_REALP (x)) { + } else if (SCM_REALP (x)) { return SCM_BOOL_T; } else if (SCM_BIGP (x)) { return SCM_BOOL_T; @@ -2908,7 +3115,8 @@ SCM_DEFINE (scm_real_p, "rational?", 1, 0, 0, SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, (SCM x), - "Return #t if X is an integer number, #f else.") + "Return @code{#t} if @var{x} is an integer number, @code{#f}\n" + "else.") #define FUNC_NAME s_scm_integer_p { double r; @@ -2918,9 +3126,9 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, return SCM_BOOL_F; if (SCM_BIGP (x)) return SCM_BOOL_T; - if (!SCM_SLOPPY_INEXACTP (x)) + if (!SCM_INEXACTP (x)) return SCM_BOOL_F; - if (SCM_SLOPPY_COMPLEXP (x)) + if (SCM_COMPLEXP (x)) return SCM_BOOL_F; r = SCM_REAL_VALUE (x); if (r == floor (r)) @@ -2932,7 +3140,8 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0, (SCM x), - "Return #t if X is an inexact number, #f else.") + "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n" + "else.") #define FUNC_NAME s_scm_inexact_p { return SCM_BOOL (SCM_INEXACTP (x)); @@ -2941,7 +3150,7 @@ SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0, SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p); - +/* "Return @code{#t} if all parameters are numerically equal." */ SCM scm_num_eq_p (SCM x, SCM y) { @@ -2966,9 +3175,9 @@ scm_num_eq_p (SCM x, SCM y) } else if (SCM_BIGP (y)) { return SCM_BOOL (0 == scm_bigcomp (x, y)); } else if (SCM_REALP (y)) { - return SCM_BOOL (scm_big2dbl (x) == SCM_REAL_VALUE (y)); + return SCM_BOOL (scm_i_big2dbl (x) == SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { - return SCM_BOOL ((scm_big2dbl (x) == SCM_COMPLEX_REAL (y)) + return SCM_BOOL ((scm_i_big2dbl (x) == SCM_COMPLEX_REAL (y)) && (0.0 == SCM_COMPLEX_IMAG (y))); } else { SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); @@ -2977,7 +3186,7 @@ scm_num_eq_p (SCM x, SCM y) if (SCM_INUMP (y)) { return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y)); } else if (SCM_BIGP (y)) { - return SCM_BOOL (SCM_REAL_VALUE (x) == scm_big2dbl (y)); + return SCM_BOOL (SCM_REAL_VALUE (x) == scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { @@ -2991,7 +3200,7 @@ scm_num_eq_p (SCM x, SCM y) return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y)) && (SCM_COMPLEX_IMAG (x) == 0.0)); } else if (SCM_BIGP (y)) { - return SCM_BOOL ((SCM_COMPLEX_REAL (x) == scm_big2dbl (y)) + return SCM_BOOL ((SCM_COMPLEX_REAL (x) == scm_i_big2dbl (y)) && (SCM_COMPLEX_IMAG (x) == 0.0)); } else if (SCM_REALP (y)) { return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)) @@ -3009,7 +3218,9 @@ scm_num_eq_p (SCM x, SCM y) SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p); - +/* "Return @code{#t} if the list of parameters is monotonically\n" + * "increasing." + */ SCM scm_less_p (SCM x, SCM y) { @@ -3031,7 +3242,7 @@ scm_less_p (SCM x, SCM y) } else if (SCM_BIGP (y)) { return SCM_BOOL (1 == scm_bigcomp (x, y)); } else if (SCM_REALP (y)) { - return SCM_BOOL (scm_big2dbl (x) < SCM_REAL_VALUE (y)); + return SCM_BOOL (scm_i_big2dbl (x) < SCM_REAL_VALUE (y)); } else { SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } @@ -3039,7 +3250,7 @@ scm_less_p (SCM x, SCM y) if (SCM_INUMP (y)) { return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y)); } else if (SCM_BIGP (y)) { - return SCM_BOOL (SCM_REAL_VALUE (x) < scm_big2dbl (y)); + return SCM_BOOL (SCM_REAL_VALUE (x) < scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)); } else { @@ -3051,41 +3262,68 @@ scm_less_p (SCM x, SCM y) } -SCM_DEFINE1 (scm_gr_p, ">", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return #t if the list of parameters is monotonically\n" - "increasing.") +SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p); +/* "Return @code{#t} if the list of parameters is monotonically\n" + * "decreasing." + */ #define FUNC_NAME s_scm_gr_p +SCM +scm_gr_p (SCM x, SCM y) { - return scm_less_p (y, x); + if (!SCM_NUMBERP (x)) + SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME); + else if (!SCM_NUMBERP (y)) + SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME); + else + return scm_less_p (y, x); } #undef FUNC_NAME -SCM_DEFINE1 (scm_leq_p, "<=", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return #t if the list of parameters is monotonically\n" - "non-decreasing.") +SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p); +/* "Return @code{#t} if the list of parameters is monotonically\n" + * "non-decreasing." + */ #define FUNC_NAME s_scm_leq_p +SCM +scm_leq_p (SCM x, SCM y) { - return SCM_BOOL_NOT (scm_less_p (y, x)); + if (!SCM_NUMBERP (x)) + SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME); + else if (!SCM_NUMBERP (y)) + SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME); + else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y))) + return SCM_BOOL_F; + else + return SCM_BOOL_NOT (scm_less_p (y, x)); } #undef FUNC_NAME -SCM_DEFINE1 (scm_geq_p, ">=", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return #t if the list of parameters is monotonically\n" - "non-increasing.") +SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p); +/* "Return @code{#t} if the list of parameters is monotonically\n" + * "non-increasing." + */ #define FUNC_NAME s_scm_geq_p +SCM +scm_geq_p (SCM x, SCM y) { - return SCM_BOOL_NOT (scm_less_p (x, y)); + if (!SCM_NUMBERP (x)) + SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME); + else if (!SCM_NUMBERP (y)) + SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME); + else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y))) + return SCM_BOOL_F; + else + return SCM_BOOL_NOT (scm_less_p (x, y)); } #undef FUNC_NAME SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p); - +/* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n" + * "zero." + */ SCM scm_zero_p (SCM z) { @@ -3105,7 +3343,9 @@ scm_zero_p (SCM z) SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p); - +/* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n" + * "zero." + */ SCM scm_positive_p (SCM x) { @@ -3122,7 +3362,9 @@ scm_positive_p (SCM x) SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p); - +/* "Return @code{#t} if @var{x} is an exact or inexact number less than\n" + * "zero." + */ SCM scm_negative_p (SCM x) { @@ -3139,13 +3381,14 @@ scm_negative_p (SCM x) SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max); - +/* "Return the maximum of all parameter values." + */ SCM scm_max (SCM x, SCM y) { if (SCM_UNBNDP (y)) { if (SCM_UNBNDP (x)) { - SCM_WTA_DISPATCH_0 (g_max, x, SCM_ARG1, s_max); + SCM_WTA_DISPATCH_0 (g_max, s_max); } else if (SCM_NUMBERP (x)) { return x; } else { @@ -3172,7 +3415,7 @@ scm_max (SCM x, SCM y) } else if (SCM_BIGP (y)) { return (1 == scm_bigcomp (x, y)) ? y : x; } else if (SCM_REALP (y)) { - double z = scm_big2dbl (x); + double z = scm_i_big2dbl (x); return (z <= SCM_REAL_VALUE (y)) ? y : scm_make_real (z); } else { SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); @@ -3182,7 +3425,7 @@ scm_max (SCM x, SCM y) double z = SCM_INUM (y); return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x; } else if (SCM_BIGP (y)) { - double z = scm_big2dbl (y); + double z = scm_i_big2dbl (y); return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x; } else if (SCM_REALP (y)) { return (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)) ? y : x; @@ -3196,13 +3439,14 @@ scm_max (SCM x, SCM y) SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min); - +/* "Return the minium of all parameter values." + */ SCM scm_min (SCM x, SCM y) { if (SCM_UNBNDP (y)) { if (SCM_UNBNDP (x)) { - SCM_WTA_DISPATCH_0 (g_min, x, SCM_ARG1, s_min); + SCM_WTA_DISPATCH_0 (g_min, s_min); } else if (SCM_NUMBERP (x)) { return x; } else { @@ -3229,7 +3473,7 @@ scm_min (SCM x, SCM y) } else if (SCM_BIGP (y)) { return (-1 == scm_bigcomp (x, y)) ? y : x; } else if (SCM_REALP (y)) { - double z = scm_big2dbl (x); + double z = scm_i_big2dbl (x); return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y; } else { SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); @@ -3239,7 +3483,7 @@ scm_min (SCM x, SCM y) double z = SCM_INUM (y); return (SCM_REAL_VALUE (x) <= z) ? x : scm_make_real (z); } else if (SCM_BIGP (y)) { - double z = scm_big2dbl (y); + double z = scm_i_big2dbl (y); return (SCM_REAL_VALUE (x) <= z) ? x : scm_make_real (z); } else if (SCM_REALP (y)) { return (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)) ? x : y; @@ -3253,7 +3497,9 @@ scm_min (SCM x, SCM y) SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum); - +/* "Return the sum of all parameter values. Return 0 if called without\n" + * "any parameters." + */ SCM scm_sum (SCM x, SCM y) { @@ -3276,7 +3522,7 @@ scm_sum (SCM x, SCM y) return SCM_MAKINUM (z); } else { #ifdef SCM_BIGDIG - return scm_long2big (z); + return scm_i_long2big (z); #else /* SCM_BIGDIG */ return scm_make_real ((double) z); #endif /* SCM_BIGDIG */ @@ -3315,9 +3561,9 @@ scm_sum (SCM x, SCM y) return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x), y, 0); } else if (SCM_REALP (y)) { - return scm_make_real (scm_big2dbl (x) + SCM_REAL_VALUE (y)); + return scm_make_real (scm_i_big2dbl (x) + SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { - return scm_make_complex (scm_big2dbl (x) + SCM_COMPLEX_REAL (y), + return scm_make_complex (scm_i_big2dbl (x) + SCM_COMPLEX_REAL (y), SCM_COMPLEX_IMAG (y)); } else { SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); @@ -3326,7 +3572,7 @@ scm_sum (SCM x, SCM y) if (SCM_INUMP (y)) { return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y)); } else if (SCM_BIGP (y)) { - return scm_make_real (SCM_REAL_VALUE (x) + scm_big2dbl (y)); + return scm_make_real (SCM_REAL_VALUE (x) + scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { return scm_make_real (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { @@ -3340,7 +3586,7 @@ scm_sum (SCM x, SCM y) return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y), SCM_COMPLEX_IMAG (x)); } else if (SCM_BIGP (y)) { - return scm_make_complex (SCM_COMPLEX_REAL (x) + scm_big2dbl (y), + return scm_make_complex (SCM_COMPLEX_REAL (x) + scm_i_big2dbl (y), SCM_COMPLEX_IMAG (x)); } else if (SCM_REALP (y)) { return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y), @@ -3358,27 +3604,32 @@ scm_sum (SCM x, SCM y) SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference); - +/* If called with one argument @var{z1}, -@var{z1} returned. Otherwise + * the sum of all but the first argument are subtracted from the first + * argument. */ +#define FUNC_NAME s_difference SCM scm_difference (SCM x, SCM y) { if (SCM_UNBNDP (y)) { - if (SCM_INUMP (x)) { + if (SCM_UNBNDP (x)) { + SCM_WTA_DISPATCH_0 (g_difference, s_difference); + } else if (SCM_INUMP (x)) { long xx = -SCM_INUM (x); if (SCM_FIXABLE (xx)) { return SCM_MAKINUM (xx); } else { #ifdef SCM_BIGDIG - return scm_long2big (xx); + return scm_i_long2big (xx); #else return scm_make_real ((double) xx); #endif } } else if (SCM_BIGP (x)) { - SCM z = scm_copybig (x, !SCM_BIGSIGN (x)); + SCM z = scm_i_copybig (x, !SCM_BIGSIGN (x)); unsigned int digs = SCM_NUMDIGS (z); unsigned int size = digs * SCM_BITSPERDIG / SCM_CHAR_BIT; - return size <= sizeof (SCM) ? scm_big2inum (z, digs) : z; + return size <= sizeof (SCM) ? scm_i_big2inum (z, digs) : z; } else if (SCM_REALP (x)) { return scm_make_real (-SCM_REAL_VALUE (x)); } else if (SCM_COMPLEXP (x)) { @@ -3397,7 +3648,7 @@ scm_difference (SCM x, SCM y) return SCM_MAKINUM (z); } else { #ifdef SCM_BIGDIG - return scm_long2big (z); + return scm_i_long2big (z); #else return scm_make_real ((double) z); #endif @@ -3441,9 +3692,9 @@ scm_difference (SCM x, SCM y) : scm_addbig (SCM_BDIGITS (y), SCM_NUMDIGS (y), SCM_BIGSIGN (y) ^ SCM_BIGSIGNFLAG, x, 0); } else if (SCM_REALP (y)) { - return scm_make_real (scm_big2dbl (x) - SCM_REAL_VALUE (y)); + return scm_make_real (scm_i_big2dbl (x) - SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { - return scm_make_complex (scm_big2dbl (x) - SCM_COMPLEX_REAL (y), + return scm_make_complex (scm_i_big2dbl (x) - SCM_COMPLEX_REAL (y), - SCM_COMPLEX_IMAG (y)); } else { SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); @@ -3452,7 +3703,7 @@ scm_difference (SCM x, SCM y) if (SCM_INUMP (y)) { return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y)); } else if (SCM_BIGP (y)) { - return scm_make_real (SCM_REAL_VALUE (x) - scm_big2dbl (y)); + return scm_make_real (SCM_REAL_VALUE (x) - scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { @@ -3466,7 +3717,7 @@ scm_difference (SCM x, SCM y) return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y), SCM_COMPLEX_IMAG (x)); } else if (SCM_BIGP (y)) { - return scm_make_complex (SCM_COMPLEX_REAL (x) - scm_big2dbl (y), + return scm_make_complex (SCM_COMPLEX_REAL (x) - scm_i_big2dbl (y), SCM_COMPLEX_IMAG (x)); } else if (SCM_REALP (y)) { return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y), @@ -3481,10 +3732,12 @@ scm_difference (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference); } } - +#undef FUNC_NAME SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product); - +/* "Return the product of all arguments. If called without arguments,\n" + * "1 is returned." + */ SCM scm_product (SCM x, SCM y) { @@ -3567,9 +3820,9 @@ scm_product (SCM x, SCM y) SCM_BDIGITS (y), SCM_NUMDIGS (y), SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y)); } else if (SCM_REALP (y)) { - return scm_make_real (scm_big2dbl (x) * SCM_REAL_VALUE (y)); + return scm_make_real (scm_i_big2dbl (x) * SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { - double z = scm_big2dbl (x); + double z = scm_i_big2dbl (x); return scm_make_complex (z * SCM_COMPLEX_REAL (y), z * SCM_COMPLEX_IMAG (y)); } else { @@ -3579,7 +3832,7 @@ scm_product (SCM x, SCM y) if (SCM_INUMP (y)) { return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x)); } else if (SCM_BIGP (y)) { - return scm_make_real (scm_big2dbl (y) * SCM_REAL_VALUE (x)); + return scm_make_real (scm_i_big2dbl (y) * SCM_REAL_VALUE (x)); } else if (SCM_REALP (y)) { return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { @@ -3593,7 +3846,7 @@ scm_product (SCM x, SCM y) return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x), SCM_INUM (y) * SCM_COMPLEX_IMAG (x)); } else if (SCM_BIGP (y)) { - double z = scm_big2dbl (y); + double z = scm_i_big2dbl (y); return scm_make_complex (z * SCM_COMPLEX_REAL (x), z * SCM_COMPLEX_IMAG (x)); } else if (SCM_REALP (y)) { @@ -3620,7 +3873,7 @@ scm_num2dbl (SCM a, const char *why) if (SCM_INUMP (a)) { return (double) SCM_INUM (a); } else if (SCM_BIGP (a)) { - return scm_big2dbl (a); + return scm_i_big2dbl (a); } else if (SCM_REALP (a)) { return (SCM_REAL_VALUE (a)); } else { @@ -3629,9 +3882,44 @@ scm_num2dbl (SCM a, const char *why) } #undef FUNC_NAME +#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \ + || (defined (HAVE_FINITE) && defined (HAVE_ISNAN))) +#define ALLOW_DIVIDE_BY_ZERO +/* #define ALLOW_DIVIDE_BY_EXACT_ZERO */ +#endif + +/* The code below for complex division is adapted from the GNU + libstdc++, which adapted it from f2c's libF77, and is subject to + this copyright: */ + +/**************************************************************** +Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); - +/* Divide the first argument by the product of the remaining + arguments. If called with one argument @var{z1}, 1/@var{z1} is + returned. */ +#define FUNC_NAME s_divide SCM scm_divide (SCM x, SCM y) { @@ -3639,22 +3927,40 @@ scm_divide (SCM x, SCM y) if (SCM_UNBNDP (y)) { if (SCM_UNBNDP (x)) { - SCM_WTA_DISPATCH_0 (g_divide, x, SCM_ARG1, s_divide); + SCM_WTA_DISPATCH_0 (g_divide, s_divide); } else if (SCM_INUMP (x)) { - if (SCM_EQ_P (x, SCM_MAKINUM (1L)) || SCM_EQ_P (x, SCM_MAKINUM (-1L))) { + long xx = SCM_INUM (x); + if (xx == 1 || xx == -1) { return x; +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO + } else if (xx == 0) { + scm_num_overflow (s_divide); +#endif } else { - return scm_make_real (1.0 / (double) SCM_INUM (x)); + return scm_make_real (1.0 / (double) xx); } } else if (SCM_BIGP (x)) { - return scm_make_real (1.0 / scm_big2dbl (x)); + return scm_make_real (1.0 / scm_i_big2dbl (x)); } else if (SCM_REALP (x)) { - return scm_make_real (1.0 / SCM_REAL_VALUE (x)); + double xx = SCM_REAL_VALUE (x); +#ifndef ALLOW_DIVIDE_BY_ZERO + if (xx == 0.0) + scm_num_overflow (s_divide); + else +#endif + return scm_make_real (1.0 / xx); } else if (SCM_COMPLEXP (x)) { double r = SCM_COMPLEX_REAL (x); double i = SCM_COMPLEX_IMAG (x); - double d = r * r + i * i; - return scm_make_complex (r / d, -i / d); + if (r <= i) { + double t = r / i; + double d = i * (1.0 + t * t); + return scm_make_complex (t / d, -1.0 / d); + } else { + double t = i / r; + double d = r * (1.0 + t * t); + return scm_make_complex (1.0 / d, -t / d); + } } else { SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); } @@ -3665,7 +3971,11 @@ scm_divide (SCM x, SCM y) if (SCM_INUMP (y)) { long yy = SCM_INUM (y); if (yy == 0) { +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO scm_num_overflow (s_divide); +#else + return scm_make_real ((double) xx / (double) yy); +#endif } else if (xx % yy != 0) { return scm_make_real ((double) xx / (double) yy); } else { @@ -3674,24 +3984,37 @@ scm_divide (SCM x, SCM y) return SCM_MAKINUM (z); } else { #ifdef SCM_BIGDIG - return scm_long2big (z); + return scm_i_long2big (z); #else return scm_make_real ((double) xx / (double) yy); #endif } } } else if (SCM_BIGP (y)) { - return scm_make_real ((double) xx / scm_big2dbl (y)); + return scm_make_real ((double) xx / scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { - return scm_make_real ((double) xx / SCM_REAL_VALUE (y)); + double yy = SCM_REAL_VALUE (y); +#ifndef ALLOW_DIVIDE_BY_ZERO + if (yy == 0.0) + scm_num_overflow (s_divide); + else +#endif + 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); - double d = r * r + i * i; - return scm_make_complex ((a * r) / d, (-a * i) / d); + 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); + } } } else { SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); @@ -3700,17 +4023,24 @@ scm_divide (SCM x, SCM y) if (SCM_INUMP (y)) { long int yy = SCM_INUM (y); if (yy == 0) { +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO scm_num_overflow (s_divide); +#else + if (scm_bigcomp (x, scm_i_int2big (0)) == 0) + return scm_nan (); + else + return scm_inf (); +#endif } else if (yy == 1) { return x; } else { long z = yy < 0 ? -yy : yy; if (z < SCM_BIGRAD) { - SCM w = scm_copybig (x, SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)); + SCM w = scm_i_copybig (x, SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)); return scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w), (SCM_BIGDIG) z) - ? scm_make_real (scm_big2dbl (x) / (double) yy) - : scm_normbig (w); + ? scm_make_real (scm_i_big2dbl (x) / (double) yy) + : scm_i_normbig (w); } else { SCM w; #ifndef SCM_DIGSTOOBIG @@ -3727,7 +4057,7 @@ scm_divide (SCM x, SCM y) #endif return (!SCM_UNBNDP (w)) ? w - : scm_make_real (scm_big2dbl (x) / (double) yy); + : scm_make_real (scm_i_big2dbl (x) / (double) yy); } } } else if (SCM_BIGP (y)) { @@ -3736,11 +4066,17 @@ scm_divide (SCM x, SCM y) SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3); return (!SCM_UNBNDP (w)) ? w - : scm_make_real (scm_big2dbl (x) / scm_big2dbl (y)); + : scm_make_real (scm_i_big2dbl (x) / scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { - return scm_make_real (scm_big2dbl (x) / SCM_REAL_VALUE (y)); + double yy = SCM_REAL_VALUE (y); +#ifndef ALLOW_DIVIDE_BY_ZERO + if (yy == 0.0) + scm_num_overflow (s_divide); + else +#endif + return scm_make_real (scm_i_big2dbl (x) / yy); } else if (SCM_COMPLEXP (y)) { - a = scm_big2dbl (x); + a = scm_i_big2dbl (x); goto complex_div; } else { SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); @@ -3748,11 +4084,23 @@ scm_divide (SCM x, SCM y) } else if (SCM_REALP (x)) { double rx = SCM_REAL_VALUE (x); if (SCM_INUMP (y)) { - return scm_make_real (rx / (double) SCM_INUM (y)); + long int yy = SCM_INUM (y); +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO + if (yy == 0) + scm_num_overflow (s_divide); + else +#endif + return scm_make_real (rx / (double) yy); } else if (SCM_BIGP (y)) { - return scm_make_real (rx / scm_big2dbl (y)); + return scm_make_real (rx / scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { - return scm_make_real (rx / SCM_REAL_VALUE (y)); + double yy = SCM_REAL_VALUE (y); +#ifndef ALLOW_DIVIDE_BY_ZERO + if (yy == 0.0) + scm_num_overflow (s_divide); + else +#endif + return scm_make_real (rx / yy); } else if (SCM_COMPLEXP (y)) { a = rx; goto complex_div; @@ -3763,20 +4111,39 @@ scm_divide (SCM x, SCM y) double rx = SCM_COMPLEX_REAL (x); double ix = SCM_COMPLEX_IMAG (x); if (SCM_INUMP (y)) { - double d = SCM_INUM (y); - return scm_make_complex (rx / d, ix / d); + long int yy = SCM_INUM (y); +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO + if (yy == 0) + scm_num_overflow (s_divide); + else +#endif + { + double d = yy; + return scm_make_complex (rx / d, ix / d); + } } else if (SCM_BIGP (y)) { - double d = scm_big2dbl (y); + double d = scm_i_big2dbl (y); return scm_make_complex (rx / d, ix / d); } else if (SCM_REALP (y)) { - double d = SCM_REAL_VALUE (y); - return scm_make_complex (rx / d, ix / d); + double yy = SCM_REAL_VALUE (y); +#ifndef ALLOW_DIVIDE_BY_ZERO + if (yy == 0.0) + scm_num_overflow (s_divide); + else +#endif + return scm_make_complex (rx / yy, ix / yy); } else if (SCM_COMPLEXP (y)) { double ry = SCM_COMPLEX_REAL (y); double iy = SCM_COMPLEX_IMAG (y); - double d = ry * ry + iy * iy; - return scm_make_complex ((rx * ry + ix * iy) / d, - (ix * ry - rx * iy) / d); + if (ry <= iy) { + double t = ry / iy; + double d = iy * (1.0 + t * t); + return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d); + } else { + double t = iy / ry; + double d = ry * (1.0 + t * t); + return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d); + } } else { SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } @@ -3784,10 +4151,11 @@ scm_divide (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide); } } - +#undef FUNC_NAME SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh, g_asinh); - +/* "Return the inverse hyperbolic sine of @var{x}." + */ double scm_asinh (double x) { @@ -3798,7 +4166,8 @@ scm_asinh (double x) SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh, g_acosh); - +/* "Return the inverse hyperbolic cosine of @var{x}." + */ double scm_acosh (double x) { @@ -3809,7 +4178,8 @@ scm_acosh (double x) SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh, g_atanh); - +/* "Return the inverse hyperbolic tangent of @var{x}." + */ double scm_atanh (double x) { @@ -3820,7 +4190,8 @@ scm_atanh (double x) SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate, g_truncate); - +/* "Round the inexact number @var{x} towards zero." + */ double scm_truncate (double x) { @@ -3832,7 +4203,9 @@ scm_truncate (double x) SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round, g_round); - +/* "Round the inexact number @var{x}. If @var{x} is halfway between two\n" + * "numbers, round towards even." + */ double scm_round (double x) { @@ -3844,86 +4217,111 @@ scm_round (double x) } - -SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact, g_exact_to_inexact); - -double -scm_exact_to_inexact (double z) -{ - return z; -} - - SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor); +/* "Round the number @var{x} towards minus infinity." + */ SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil); +/* "Round the number @var{x} towards infinity." + */ SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt); +/* "Return the square root of the real number @var{x}." + */ SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs, g_i_abs); +/* "Return the absolute value of the real number @var{x}." + */ SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp); +/* "Return the @var{x}th power of e." + */ SCM_GPROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log, g_i_log); +/* "Return the natural logarithm of the real number @var{x}." + */ SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin, g_i_sin); +/* "Return the sine of the real number @var{x}." + */ SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos, g_i_cos); +/* "Return the cosine of the real number @var{x}." + */ SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan, g_i_tan); +/* "Return the tangent of the real number @var{x}." + */ SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin, g_i_asin); +/* "Return the arc sine of the real number @var{x}." + */ SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos, g_i_acos); +/* "Return the arc cosine of the real number @var{x}." + */ SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan, g_i_atan); +/* "Return the arc tangent of the real number @var{x}." + */ SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh, g_i_sinh); +/* "Return the hyperbolic sine of the real number @var{x}." + */ SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh, g_i_cosh); +/* "Return the hyperbolic cosine of the real number @var{x}." + */ SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh, g_i_tanh); +/* "Return the hyperbolic tangent of the real number @var{x}." + */ struct dpair { double x, y; }; -static void scm_two_doubles (SCM z1, - SCM z2, +static void scm_two_doubles (SCM x, + SCM y, const char *sstring, struct dpair * xy); static void -scm_two_doubles (SCM z1, SCM z2, const char *sstring, struct dpair *xy) +scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy) { - if (SCM_INUMP (z1)) { - xy->x = SCM_INUM (z1); - } else if (SCM_BIGP (z1)) { - xy->x = scm_big2dbl (z1); - } else if (SCM_REALP (z1)) { - xy->x = SCM_REAL_VALUE (z1); + if (SCM_INUMP (x)) { + xy->x = SCM_INUM (x); + } else if (SCM_BIGP (x)) { + xy->x = scm_i_big2dbl (x); + } else if (SCM_REALP (x)) { + xy->x = SCM_REAL_VALUE (x); } else { - scm_wrong_type_arg (sstring, SCM_ARG1, z1); + scm_wrong_type_arg (sstring, SCM_ARG1, x); } - if (SCM_INUMP (z2)) { - xy->y = SCM_INUM (z2); - } else if (SCM_BIGP (z2)) { - xy->y = scm_big2dbl (z2); - } else if (SCM_REALP (z2)) { - xy->y = SCM_REAL_VALUE (z2); + if (SCM_INUMP (y)) { + xy->y = SCM_INUM (y); + } else if (SCM_BIGP (y)) { + xy->y = scm_i_big2dbl (y); + } else if (SCM_REALP (y)) { + xy->y = SCM_REAL_VALUE (y); } else { - scm_wrong_type_arg (sstring, SCM_ARG2, z2); + scm_wrong_type_arg (sstring, SCM_ARG2, y); } } SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0, - (SCM z1, SCM z2), - "") + (SCM x, SCM y), + "Return @var{x} raised to the power of @var{y}. This\n" + "procedure does not accept complex arguments.") #define FUNC_NAME s_scm_sys_expt { struct dpair xy; - scm_two_doubles (z1, z2, FUNC_NAME, &xy); + scm_two_doubles (x, y, FUNC_NAME, &xy); return scm_make_real (pow (xy.x, xy.y)); } #undef FUNC_NAME SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0, - (SCM z1, SCM z2), - "") + (SCM x, SCM y), + "Return the arc tangent of the two arguments @var{x} and\n" + "@var{y}. This is similar to calculating the arc tangent of\n" + "@var{x} / @var{y}, except that the signs of both arguments\n" + "are used to determine the quadrant of the result. This\n" + "procedure does not accept complex arguments.") #define FUNC_NAME s_scm_sys_atan2 { struct dpair xy; - scm_two_doubles (z1, z2, FUNC_NAME, &xy); + scm_two_doubles (x, y, FUNC_NAME, &xy); return scm_make_real (atan2 (xy.x, xy.y)); } #undef FUNC_NAME @@ -3931,8 +4329,8 @@ SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0, SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0, (SCM real, SCM imaginary), - "Return a complex number constructed of the given REAL and\n" - "IMAGINARY parts.") + "Return a complex number constructed of the given @var{real} and\n" + "@var{imaginary} parts.") #define FUNC_NAME s_scm_make_rectangular { struct dpair xy; @@ -3944,19 +4342,20 @@ SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0, SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0, - (SCM z1, SCM z2), - "Return the complex number Z1 * e^(i * Z2).") + (SCM x, SCM y), + "Return the complex number @var{x} * e^(i * @var{y}).") #define FUNC_NAME s_scm_make_polar { struct dpair xy; - scm_two_doubles (z1, z2, FUNC_NAME, &xy); + scm_two_doubles (x, y, FUNC_NAME, &xy); return scm_make_complex (xy.x * cos (xy.y), xy.x * sin (xy.y)); } #undef FUNC_NAME SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part); - +/* "Return the real part of the number @var{z}." + */ SCM scm_real_part (SCM z) { @@ -3975,7 +4374,8 @@ scm_real_part (SCM z) SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part); - +/* "Return the imaginary part of the number @var{z}." + */ SCM scm_imag_part (SCM z) { @@ -3994,7 +4394,9 @@ scm_imag_part (SCM z) SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude); - +/* "Return the magnitude of the number @var{z}. This is the same as\n" + * "@code{abs} for real arguments, but also allows complex numbers." + */ SCM scm_magnitude (SCM z) { @@ -4006,7 +4408,7 @@ scm_magnitude (SCM z) return SCM_MAKINUM (-zz); } else { #ifdef SCM_BIGDIG - return scm_long2big (-zz); + return scm_i_long2big (-zz); #else scm_num_overflow (s_magnitude); #endif @@ -4015,7 +4417,7 @@ scm_magnitude (SCM z) if (!SCM_BIGSIGN (z)) { return z; } else { - return scm_copybig (z, 0); + return scm_i_copybig (z, 0); } } else if (SCM_REALP (z)) { return scm_make_real (fabs (SCM_REAL_VALUE (z))); @@ -4030,7 +4432,8 @@ scm_magnitude (SCM z) SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle); - +/* "Return the angle of the complex number @var{z}." + */ SCM scm_angle (SCM z) { @@ -4056,9 +4459,26 @@ scm_angle (SCM z) } +SCM_GPROC (s_exact_to_inexact, "exact->inexact", 1, 0, 0, scm_exact_to_inexact, g_exact_to_inexact); +/* Convert the number @var{x} to its inexact representation.\n" + */ +SCM +scm_exact_to_inexact (SCM z) +{ + if (SCM_INUMP (z)) + return scm_make_real ((double) SCM_INUM (z)); + else if (SCM_BIGP (z)) + return scm_make_real (scm_i_big2dbl (z)); + else if (SCM_INEXACTP (z)) + return z; + else + SCM_WTA_DISPATCH_1 (g_exact_to_inexact, z, 1, s_exact_to_inexact); +} + + SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, (SCM z), - "Returns an exact number that is numerically closest to Z.") + "Return an exact number that is numerically closest to @var{z}.") #define FUNC_NAME s_scm_inexact_to_exact { if (SCM_INUMP (z)) { @@ -4071,8 +4491,8 @@ SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, if (SCM_FIXABLE (lu)) { return SCM_MAKINUM (lu); #ifdef SCM_BIGDIG - } else if (isfinite (u)) { - return scm_dbl2big (u); + } else if (isfinite (u) && !xisnan (u)) { + return scm_i_dbl2big (u); #endif } else { scm_num_overflow (s_scm_inexact_to_exact); @@ -4088,9 +4508,9 @@ SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, /* d must be integer */ SCM -scm_dbl2big (double d) +scm_i_dbl2big (double d) { - scm_sizet i = 0; + size_t i = 0; long c; SCM_BIGDIG *digits; SCM ans; @@ -4100,7 +4520,7 @@ scm_dbl2big (double d) u /= SCM_BIGRAD; i++; } - ans = scm_mkbig (i, d < 0); + ans = scm_i_mkbig (i, d < 0); digits = SCM_BDIGITS (ans); while (i--) { @@ -4109,20 +4529,16 @@ scm_dbl2big (double d) u -= c; digits[i] = c; } -#ifndef SCM_RECKLESS if (u != 0) scm_num_overflow ("dbl2big"); -#endif return ans; } - - double -scm_big2dbl (SCM b) +scm_i_big2dbl (SCM b) { double ans = 0.0; - scm_sizet i = SCM_NUMDIGS (b); + size_t i = SCM_NUMDIGS (b); SCM_BIGDIG *digits = SCM_BDIGITS (b); while (i--) ans = digits[i] + SCM_BIGRAD * ans; @@ -4130,207 +4546,269 @@ scm_big2dbl (SCM b) return - ans; return ans; } -#endif +#endif -SCM -scm_long2num (long sl) -{ - if (!SCM_FIXABLE (sl)) - { -#ifdef SCM_BIGDIG - return scm_long2big (sl); -#else - return scm_make_real ((double) sl); +#ifdef HAVE_LONG_LONGS +# ifndef LLONG_MAX +# define ULLONG_MAX ((unsigned long long) (-1)) +# define LLONG_MAX ((long long) (ULLONG_MAX >> 1)) +# define LLONG_MIN (~LLONG_MAX) +# endif #endif - } - return SCM_MAKINUM (sl); -} +/* Parameters for creating integer conversion routines. + + Define the following preprocessor macros before including + "libguile/num2integral.i.c": + + NUM2INTEGRAL - the name of the function for converting from a + Scheme object to the integral type. This function + will be defined when including "num2integral.i.c". + + INTEGRAL2NUM - the name of the function for converting from the + integral type to a Scheme object. This function + will be defined. + + INTEGRAL2BIG - the name of an internal function that createas a + bignum from the integral type. This function will + be defined. The name should start with "scm_i_". + + ITYPE - the name of the integral type. + + UNSIGNED - Define this when ITYPE is an unsigned type. Do not + define it otherwise. + + UNSIGNED_ITYPE + - the name of the the unsigned variant of the + integral type. If you don't define this, it defaults + to "unsigned ITYPE" for signed types and simply "ITYPE" + for unsigned ones. + + SIZEOF_ITYPE - an expression giving the size of the integral type in + bytes. This expression must be computable by the + preprocessor. If you don't know a value for this, + don't define it. The purpose of this parameter is + mainly to suppress some warnings. The generated + code will work correctly without it. +*/ + +#define NUM2INTEGRAL scm_num2short +#define INTEGRAL2NUM scm_short2num +#define INTEGRAL2BIG scm_i_short2big +#define ITYPE short +#define SIZEOF_ITYPE SIZEOF_SHORT +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2ushort +#define INTEGRAL2NUM scm_ushort2num +#define INTEGRAL2BIG scm_i_ushort2big +#define UNSIGNED +#define ITYPE unsigned short +#define SIZEOF_ITYPE SIZEOF_SHORT +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2int +#define INTEGRAL2NUM scm_int2num +#define INTEGRAL2BIG scm_i_int2big +#define ITYPE int +#define SIZEOF_ITYPE SIZEOF_INT +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2uint +#define INTEGRAL2NUM scm_uint2num +#define INTEGRAL2BIG scm_i_uint2big +#define UNSIGNED +#define ITYPE unsigned int +#define SIZEOF_ITYPE SIZEOF_INT +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2long +#define INTEGRAL2NUM scm_long2num +#define INTEGRAL2BIG scm_i_long2big +#define ITYPE long +#define SIZEOF_ITYPE SIZEOF_LONG +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2ulong +#define INTEGRAL2NUM scm_ulong2num +#define INTEGRAL2BIG scm_i_ulong2big +#define UNSIGNED +#define ITYPE unsigned long +#define SIZEOF_ITYPE SIZEOF_LONG +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2ptrdiff +#define INTEGRAL2NUM scm_ptrdiff2num +#define INTEGRAL2BIG scm_i_ptrdiff2big +#define ITYPE ptrdiff_t +#define UNSIGNED_ITYPE size_t +#define SIZEOF_ITYPE SIZEOF_PTRDIFF_T +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2size +#define INTEGRAL2NUM scm_size2num +#define INTEGRAL2BIG scm_i_size2big +#define UNSIGNED +#define ITYPE size_t +#define SIZEOF_ITYPE SIZEOF_SIZE_T +#include "libguile/num2integral.i.c" #ifdef HAVE_LONG_LONGS -SCM -scm_long_long2num (long_long sl) -{ - if (!SCM_FIXABLE (sl)) - { -#ifdef SCM_BIGDIG - return scm_long_long2big (sl); -#else - return scm_make_real ((double) sl); +#ifndef ULONG_LONG_MAX +#define ULONG_LONG_MAX (~0ULL) #endif - } - else - { - /* we know that sl fits into an inum */ - return SCM_MAKINUM ((scm_bits_t) sl); - } -} +#define NUM2INTEGRAL scm_num2long_long +#define INTEGRAL2NUM scm_long_long2num +#define INTEGRAL2BIG scm_i_long_long2big +#define ITYPE long long +#define SIZEOF_ITYPE SIZEOF_LONG_LONG +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2ulong_long +#define INTEGRAL2NUM scm_ulong_long2num +#define INTEGRAL2BIG scm_i_ulong_long2big +#define UNSIGNED +#define ITYPE unsigned long long +#define SIZEOF_ITYPE SIZEOF_LONG_LONG +#include "libguile/num2integral.i.c" + +#endif /* HAVE_LONG_LONGS */ + +#define NUM2FLOAT scm_num2float +#define FLOAT2NUM scm_float2num +#define FTYPE float +#include "libguile/num2float.i.c" + +#define NUM2FLOAT scm_num2double +#define FLOAT2NUM scm_double2num +#define FTYPE double +#include "libguile/num2float.i.c" + +#ifdef GUILE_DEBUG + +#ifndef SIZE_MAX +#define SIZE_MAX ((size_t) (-1)) #endif - - -SCM -scm_ulong2num (unsigned long sl) -{ - if (!SCM_POSFIXABLE (sl)) - { -#ifdef SCM_BIGDIG - return scm_ulong2big (sl); -#else - return scm_make_real ((double) sl); +#ifndef PTRDIFF_MIN +#define PTRDIFF_MIN \ + ((ptrdiff_t) ((ptrdiff_t) 1 << (sizeof (ptrdiff_t) * 8 - 1))) +#endif +#ifndef PTRDIFF_MAX +#define PTRDIFF_MAX (~ PTRDIFF_MIN) #endif - } - return SCM_MAKINUM (sl); -} +#define CHECK(type, v) \ + do { \ + if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \ + abort (); \ + } while (0); -long -scm_num2long (SCM num, char *pos, const char *s_caller) +static void +check_sanity () { - if (SCM_INUMP (num)) { - return SCM_INUM (num); - } else if (SCM_BIGP (num)) { - long int res; - /* can't use res directly in case num is -2^31. */ - unsigned long int pos_res = 0; - unsigned long int old_res = 0; - scm_sizet l; - - for (l = SCM_NUMDIGS (num); l--;) { - pos_res = SCM_BIGUP (pos_res) + SCM_BDIGITS (num)[l]; - if (pos_res >= old_res) { - old_res = pos_res; - } else { - /* overflow. */ - scm_out_of_range (s_caller, num); - } - } - if (SCM_BIGSIGN (num)) { - res = -pos_res; - if (res <= 0) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } else { - res = pos_res; - if (res >= 0) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } - } else if (SCM_REALP (num)) { - double u = SCM_REAL_VALUE (num); - long int res = u; - if ((double) res == u) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } else { - scm_wrong_type_arg (s_caller, (int) pos, num); - } + CHECK (short, 0); + CHECK (ushort, 0U); + CHECK (int, 0); + CHECK (uint, 0U); + CHECK (long, 0L); + CHECK (ulong, 0UL); + CHECK (size, 0); + CHECK (ptrdiff, 0); + + CHECK (short, -1); + CHECK (int, -1); + CHECK (long, -1L); + CHECK (ptrdiff, -1); + + CHECK (short, SHRT_MAX); + CHECK (short, SHRT_MIN); + CHECK (ushort, USHRT_MAX); + CHECK (int, INT_MAX); + CHECK (int, INT_MIN); + CHECK (uint, UINT_MAX); + CHECK (long, LONG_MAX); + CHECK (long, LONG_MIN); + CHECK (ulong, ULONG_MAX); + CHECK (size, SIZE_MAX); + CHECK (ptrdiff, PTRDIFF_MAX); + CHECK (ptrdiff, PTRDIFF_MIN); + +#ifdef HAVE_LONG_LONGS + CHECK (long_long, 0LL); + CHECK (ulong_long, 0ULL); + CHECK (long_long, -1LL); + CHECK (long_long, LLONG_MAX); + CHECK (long_long, LLONG_MIN); + CHECK (ulong_long, ULLONG_MAX); +#endif } +#undef CHECK -#ifdef HAVE_LONG_LONGS +#define CHECK \ + scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \ + if (!SCM_FALSEP (data)) abort(); -long_long -scm_num2long_long (SCM num, char *pos, const char *s_caller) +static SCM +check_body (void *data) { - if (SCM_INUMP (num)) { - return SCM_INUM (num); - } else if (SCM_BIGP (num)) { - long long res; - /* can't use res directly in case num is -2^63. */ - unsigned long long int pos_res = 0; - unsigned long long int old_res = 0; - scm_sizet l; - - for (l = SCM_NUMDIGS (num); l--;) { - pos_res = SCM_LONGLONGBIGUP (pos_res) + SCM_BDIGITS (num)[l]; - if (pos_res >= old_res) { - old_res = pos_res; - } else { - /* overflow. */ - scm_out_of_range (s_caller, num); - } - } - if (SCM_BIGSIGN (num)) { - res = -pos_res; - if (res <= 0) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } else { - res = pos_res; - if (res >= 0) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } - } else if (SCM_REALP (num)) { - double u = SCM_REAL_VALUE (num); - long long int res = u; - if ((double) res == u) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } else { - scm_wrong_type_arg (s_caller, (int) pos, num); - } + SCM num = *(SCM *) data; + scm_num2ulong (num, 1, NULL); + + return SCM_UNSPECIFIED; } -#endif - +static SCM +check_handler (void *data, SCM tag, SCM throw_args) +{ + SCM *num = (SCM *) data; + *num = SCM_BOOL_F; -unsigned long -scm_num2ulong (SCM num, char *pos, const char *s_caller) + return SCM_UNSPECIFIED; +} + +SCM_DEFINE (scm_sys_check_number_conversions, "%check-number-conversions", 0, 0, 0, + (void), + "Number conversion sanity checking.") +#define FUNC_NAME s_scm_sys_check_number_conversions { - if (SCM_INUMP (num)) { - long nnum = SCM_INUM (num); - if (nnum >= 0) { - return nnum; - } else { - scm_out_of_range (s_caller, num); - } - } else if (SCM_BIGP (num)) { - unsigned long int res = 0; - unsigned long int old_res = 0; - scm_sizet l; - - for (l = SCM_NUMDIGS (num); l--;) { - res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l]; - if (res >= old_res) { - old_res = res; - } else { - scm_out_of_range (s_caller, num); - } - } - return res; - } else if (SCM_REALP (num)) { - double u = SCM_REAL_VALUE (num); - unsigned long int res = u; - if ((double) res == u) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } else { - scm_wrong_type_arg (s_caller, (int) pos, num); - } + SCM data = SCM_MAKINUM (-1); + CHECK; + data = scm_int2num (INT_MIN); + CHECK; + data = scm_ulong2num (ULONG_MAX); + data = scm_difference (SCM_INUM0, data); + CHECK; + data = scm_ulong2num (ULONG_MAX); + data = scm_sum (SCM_MAKINUM (1), data); data = scm_difference (SCM_INUM0, data); + CHECK; + data = scm_int2num (-10000); data = scm_product (data, data); data = scm_product (data, data); + CHECK; + + return SCM_UNSPECIFIED; } +#undef FUNC_NAME +#endif void scm_init_numbers () { + abs_most_negative_fixnum = scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM); + scm_permanent_object (abs_most_negative_fixnum); + + /* It may be possible to tune the performance of some algorithms by using + * the following constants to avoid the creation of bignums. Please, before + * using these values, remember the two rules of program optimization: + * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */ + scm_c_define ("most-positive-fixnum", + SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); + scm_c_define ("most-negative-fixnum", + SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); + scm_add_feature ("complex"); scm_add_feature ("inexact"); scm_flo0 = scm_make_real (0.0); @@ -4351,6 +4829,11 @@ scm_init_numbers () scm_dblprec = scm_dblprec - 1; } #endif /* DBL_DIG */ + +#ifdef GUILE_DEBUG + check_sanity (); +#endif + #include "libguile/numbers.x" }