From 6e9ee1bdbd3a449d7d864d52a42cbab630d57ca1 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 30 Jan 2011 09:52:51 -0500 Subject: [PATCH] Improve extensibility of core numeric procedures * libguile/numbers.c (scm_quotient, scm_remainder, scm_modulo, scm_zero_p, scm_positive_p, scm_negative_p, scm_real_part, scm_imag_part, scm_numerator, scm_denominator, scm_magnitude, scm_angle, scm_exact_to_inexact): Change from SCM_GPROC to SCM_PRIMITIVE_GENERIC. As a side effect, all of these procedures now have documentation strings. (scm_exact_p, scm_inexact_p, scm_odd_p, scm_even_p, scm_finite_p, scm_inf_p, scm_nan_p, scm_expt, scm_inexact_to_exact, scm_log, scm_log10, scm_exp, scm_sqrt): Change from SCM_DEFINE to SCM_PRIMITIVE_GENERIC, and make sure the code allows these functions to be extended in practice. (scm_real_part, scm_imag_part, scm_numerator, scm_denominator, scm_inexact_to_exact): Simplify type dispatch code. (scm_sqrt): Rename formal argument from x to z, since complex numbers are supported. (scm_abs): Fix empty FUNC_NAME. * libguile/numbers.h (scm_finite_p): Add missing prototype. (scm_inf_p, scm_nan_p): Rename formal parameter from n to x, since the domain is the real numbers. * test-suite/tests/numbers.test: Test for documentation strings. Change from `expect-fail' to `pass-if' for several of these, and add tests for others. Also add other tests for `real-part' and `imag-part', which previously had none. --- libguile/numbers.c | 416 ++++++++++++++++++++--------------------- libguile/numbers.h | 5 +- test-suite/tests/numbers.test | 69 +++++-- 3 files changed, 257 insertions(+), 233 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 875cd87..955404d 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -498,8 +498,8 @@ scm_i_fraction2double (SCM z) SCM_FRACTION_DENOMINATOR (z))); } -SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, - (SCM x), +SCM_PRIMITIVE_GENERIC (scm_exact_p, "exact?", 1, 0, 0, + (SCM x), "Return @code{#t} if @var{x} is an exact number, @code{#f}\n" "otherwise.") #define FUNC_NAME s_scm_exact_p @@ -509,12 +509,12 @@ SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, else if (SCM_NUMBERP (x)) return SCM_BOOL_T; else - SCM_WRONG_TYPE_ARG (1, x); + SCM_WTA_DISPATCH_1 (g_scm_exact_p, x, 1, s_scm_exact_p); } #undef FUNC_NAME -SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0, +SCM_PRIMITIVE_GENERIC (scm_inexact_p, "inexact?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n" "else.") @@ -525,12 +525,12 @@ SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0, else if (SCM_NUMBERP (x)) return SCM_BOOL_F; else - SCM_WRONG_TYPE_ARG (1, x); + SCM_WTA_DISPATCH_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p); } #undef FUNC_NAME -SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, +SCM_PRIMITIVE_GENERIC (scm_odd_p, "odd?", 1, 0, 0, (SCM n), "Return @code{#t} if @var{n} is an odd number, @code{#f}\n" "otherwise.") @@ -547,25 +547,24 @@ SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, scm_remember_upto_here_1 (n); return scm_from_bool (odd_p); } - else if (scm_is_true (scm_inf_p (n))) - SCM_WRONG_TYPE_ARG (1, n); else if (SCM_REALP (n)) { - double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0)); - if (rem == 1.0) - return SCM_BOOL_T; - else if (rem == 0.0) - return SCM_BOOL_F; - else - SCM_WRONG_TYPE_ARG (1, n); + double val = SCM_REAL_VALUE (n); + if (DOUBLE_IS_FINITE (val)) + { + double rem = fabs (fmod (val, 2.0)); + if (rem == 1.0) + return SCM_BOOL_T; + else if (rem == 0.0) + return SCM_BOOL_F; + } } - else - SCM_WRONG_TYPE_ARG (1, n); + SCM_WTA_DISPATCH_1 (g_scm_odd_p, n, 1, s_scm_odd_p); } #undef FUNC_NAME -SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, +SCM_PRIMITIVE_GENERIC (scm_even_p, "even?", 1, 0, 0, (SCM n), "Return @code{#t} if @var{n} is an even number, @code{#f}\n" "otherwise.") @@ -582,25 +581,24 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, scm_remember_upto_here_1 (n); return scm_from_bool (even_p); } - else if (scm_is_true (scm_inf_p (n))) - SCM_WRONG_TYPE_ARG (1, n); else if (SCM_REALP (n)) { - double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0)); - if (rem == 1.0) - return SCM_BOOL_F; - else if (rem == 0.0) - return SCM_BOOL_T; - else - SCM_WRONG_TYPE_ARG (1, n); + double val = SCM_REAL_VALUE (n); + if (DOUBLE_IS_FINITE (val)) + { + double rem = fabs (fmod (val, 2.0)); + if (rem == 1.0) + return SCM_BOOL_F; + else if (rem == 0.0) + return SCM_BOOL_T; + } } - else - SCM_WRONG_TYPE_ARG (1, n); + SCM_WTA_DISPATCH_1 (g_scm_even_p, n, 1, s_scm_even_p); } #undef FUNC_NAME -SCM_DEFINE (scm_finite_p, "finite?", 1, 0, 0, - (SCM x), +SCM_PRIMITIVE_GENERIC (scm_finite_p, "finite?", 1, 0, 0, + (SCM x), "Return @code{#t} if the real number @var{x} is neither\n" "infinite nor a NaN, @code{#f} otherwise.") #define FUNC_NAME s_scm_finite_p @@ -610,14 +608,14 @@ SCM_DEFINE (scm_finite_p, "finite?", 1, 0, 0, else if (scm_is_real (x)) return SCM_BOOL_T; else - SCM_WRONG_TYPE_ARG (1, x); + SCM_WTA_DISPATCH_1 (g_scm_finite_p, x, 1, s_scm_finite_p); } #undef FUNC_NAME -SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0, - (SCM x), - "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n" - "@samp{-inf.0}. Otherwise return @code{#f}.") +SCM_PRIMITIVE_GENERIC (scm_inf_p, "inf?", 1, 0, 0, + (SCM x), + "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n" + "@samp{-inf.0}. Otherwise return @code{#f}.") #define FUNC_NAME s_scm_inf_p { if (SCM_REALP (x)) @@ -625,12 +623,12 @@ SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0, else if (scm_is_real (x)) return SCM_BOOL_F; else - SCM_WRONG_TYPE_ARG (1, x); + SCM_WTA_DISPATCH_1 (g_scm_inf_p, x, 1, s_scm_inf_p); } #undef FUNC_NAME -SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0, - (SCM x), +SCM_PRIMITIVE_GENERIC (scm_nan_p, "nan?", 1, 0, 0, + (SCM x), "Return @code{#t} if the real number @var{x} is a NaN,\n" "or @code{#f} otherwise.") #define FUNC_NAME s_scm_nan_p @@ -640,7 +638,7 @@ SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0, else if (scm_is_real (x)) return SCM_BOOL_F; else - SCM_WRONG_TYPE_ARG (1, x); + SCM_WTA_DISPATCH_1 (g_scm_nan_p, x, 1, s_scm_nan_p); } #undef FUNC_NAME @@ -727,7 +725,7 @@ SCM_DEFINE (scm_nan, "nan", 0, 0, 0, SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, (SCM x), "Return the absolute value of @var{x}.") -#define FUNC_NAME +#define FUNC_NAME s_scm_abs { if (SCM_I_INUMP (x)) { @@ -769,11 +767,10 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, #undef FUNC_NAME -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) +SCM_PRIMITIVE_GENERIC (scm_quotient, "quotient", 2, 0, 0, + (SCM x, SCM y), + "Return the quotient of the numbers @var{x} and @var{y}.") +#define FUNC_NAME s_scm_quotient { if (SCM_LIKELY (SCM_I_INUMP (x))) { @@ -782,7 +779,7 @@ scm_quotient (SCM x, SCM y) { scm_t_inum yy = SCM_I_INUM (y); if (SCM_UNLIKELY (yy == 0)) - scm_num_overflow (s_quotient); + scm_num_overflow (s_scm_quotient); else { scm_t_inum z = xx / yy; @@ -806,7 +803,7 @@ scm_quotient (SCM x, SCM y) return SCM_INUM0; } else - SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); + SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient); } else if (SCM_BIGP (x)) { @@ -814,7 +811,7 @@ scm_quotient (SCM x, SCM y) { scm_t_inum yy = SCM_I_INUM (y); if (SCM_UNLIKELY (yy == 0)) - scm_num_overflow (s_quotient); + scm_num_overflow (s_scm_quotient); else if (SCM_UNLIKELY (yy == 1)) return x; else @@ -843,21 +840,21 @@ scm_quotient (SCM x, SCM y) return scm_i_normbig (result); } else - SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); + SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient); } else - SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG1, s_quotient); + SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient); } +#undef FUNC_NAME -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) +SCM_PRIMITIVE_GENERIC (scm_remainder, "remainder", 2, 0, 0, + (SCM x, SCM y), + "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") +#define FUNC_NAME s_scm_remainder { if (SCM_LIKELY (SCM_I_INUMP (x))) { @@ -865,7 +862,7 @@ scm_remainder (SCM x, SCM y) { scm_t_inum yy = SCM_I_INUM (y); if (SCM_UNLIKELY (yy == 0)) - scm_num_overflow (s_remainder); + scm_num_overflow (s_scm_remainder); else { /* C99 specifies that "%" is the remainder corresponding to a @@ -889,7 +886,7 @@ scm_remainder (SCM x, SCM y) return x; } else - SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); + SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder); } else if (SCM_BIGP (x)) { @@ -897,7 +894,7 @@ scm_remainder (SCM x, SCM y) { scm_t_inum yy = SCM_I_INUM (y); if (SCM_UNLIKELY (yy == 0)) - scm_num_overflow (s_remainder); + scm_num_overflow (s_scm_remainder); else { SCM result = scm_i_mkbig (); @@ -918,22 +915,22 @@ scm_remainder (SCM x, SCM y) return scm_i_normbig (result); } else - SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); + SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder); } else - SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG1, s_remainder); + SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder); } +#undef FUNC_NAME -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) +SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0, + (SCM x, SCM y), + "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") +#define FUNC_NAME s_scm_modulo { if (SCM_LIKELY (SCM_I_INUMP (x))) { @@ -942,7 +939,7 @@ scm_modulo (SCM x, SCM y) { scm_t_inum yy = SCM_I_INUM (y); if (SCM_UNLIKELY (yy == 0)) - scm_num_overflow (s_modulo); + scm_num_overflow (s_scm_modulo); else { /* C99 specifies that "%" is the remainder corresponding to a @@ -1008,7 +1005,7 @@ scm_modulo (SCM x, SCM y) } } else - SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); + SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo); } else if (SCM_BIGP (x)) { @@ -1016,7 +1013,7 @@ scm_modulo (SCM x, SCM y) { scm_t_inum yy = SCM_I_INUM (y); if (SCM_UNLIKELY (yy == 0)) - scm_num_overflow (s_modulo); + scm_num_overflow (s_scm_modulo); else { SCM result = scm_i_mkbig (); @@ -1049,11 +1046,12 @@ scm_modulo (SCM x, SCM y) return scm_i_normbig (result); } else - SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); + SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo); } else - SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo); + SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo); } +#undef FUNC_NAME static SCM scm_i_inexact_euclidean_quotient (double x, double y); static SCM scm_i_slow_exact_euclidean_quotient (SCM x, SCM y); @@ -3054,8 +3052,9 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, "Return @var{n} raised to the power @var{k}. @var{k} must be an\n" "exact integer, @var{n} can be any number.\n" "\n" - "Negative @var{k} is supported, and results in @math{1/n^abs(k)}\n" - "in the usual way. @math{@var{n}^0} is 1, as usual, and that\n" + "Negative @var{k} is supported, and results in\n" + "@math{1/@var{n}^abs(@var{k})} in the usual way.\n" + "@math{@var{n}^0} is 1, as usual, and that\n" "includes @math{0^0} is 1.\n" "\n" "@lisp\n" @@ -5038,12 +5037,11 @@ scm_geq_p (SCM x, SCM 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) +SCM_PRIMITIVE_GENERIC (scm_zero_p, "zero?", 1, 0, 0, + (SCM z), + "Return @code{#t} if @var{z} is an exact or inexact number equal to\n" + "zero.") +#define FUNC_NAME s_scm_zero_p { if (SCM_I_INUMP (z)) return scm_from_bool (scm_is_eq (z, SCM_INUM0)); @@ -5057,16 +5055,16 @@ scm_zero_p (SCM z) else if (SCM_FRACTIONP (z)) return SCM_BOOL_F; else - SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p); + SCM_WTA_DISPATCH_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p); } +#undef FUNC_NAME -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) +SCM_PRIMITIVE_GENERIC (scm_positive_p, "positive?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is an exact or inexact number greater than\n" + "zero.") +#define FUNC_NAME s_scm_positive_p { if (SCM_I_INUMP (x)) return scm_from_bool (SCM_I_INUM (x) > 0); @@ -5081,16 +5079,16 @@ scm_positive_p (SCM x) else if (SCM_FRACTIONP (x)) return scm_positive_p (SCM_FRACTION_NUMERATOR (x)); else - SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p); + SCM_WTA_DISPATCH_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p); } +#undef FUNC_NAME -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) +SCM_PRIMITIVE_GENERIC (scm_negative_p, "negative?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is an exact or inexact number less than\n" + "zero.") +#define FUNC_NAME s_scm_negative_p { if (SCM_I_INUMP (x)) return scm_from_bool (SCM_I_INUM (x) < 0); @@ -5105,8 +5103,9 @@ scm_negative_p (SCM x) else if (SCM_FRACTIONP (x)) return scm_negative_p (SCM_FRACTION_NUMERATOR (x)); else - SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p); + SCM_WTA_DISPATCH_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p); } +#undef FUNC_NAME /* scm_min and scm_max return an inexact when either argument is inexact, as @@ -6695,9 +6694,9 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0, Written by Jerry D. Hedden, (C) FSF. See the file `COPYING' for terms applying to this program. */ -SCM_DEFINE (scm_expt, "expt", 2, 0, 0, - (SCM x, SCM y), - "Return @var{x} raised to the power of @var{y}.") +SCM_PRIMITIVE_GENERIC (scm_expt, "expt", 2, 0, 0, + (SCM x, SCM y), + "Return @var{x} raised to the power of @var{y}.") #define FUNC_NAME s_scm_expt { if (scm_is_integer (y)) @@ -6727,8 +6726,12 @@ SCM_DEFINE (scm_expt, "expt", 2, 0, 0, { return scm_from_double (pow (scm_to_double (x), scm_to_double (y))); } - else + else if (scm_is_complex (x) && scm_is_complex (y)) return scm_exp (scm_product (scm_log (x), y)); + else if (scm_is_complex (x)) + SCM_WTA_DISPATCH_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt); + else + SCM_WTA_DISPATCH_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt); } #undef FUNC_NAME @@ -7054,90 +7057,76 @@ SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0, #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) +SCM_PRIMITIVE_GENERIC (scm_real_part, "real-part", 1, 0, 0, + (SCM z), + "Return the real part of the number @var{z}.") +#define FUNC_NAME s_scm_real_part { - if (SCM_I_INUMP (z)) - return z; - else if (SCM_BIGP (z)) - return z; - else if (SCM_REALP (z)) - return z; - else if (SCM_COMPLEXP (z)) + if (SCM_COMPLEXP (z)) return scm_from_double (SCM_COMPLEX_REAL (z)); - else if (SCM_FRACTIONP (z)) + else if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_REALP (z) || SCM_FRACTIONP (z)) return z; else - SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part); + SCM_WTA_DISPATCH_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part); } +#undef FUNC_NAME -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) +SCM_PRIMITIVE_GENERIC (scm_imag_part, "imag-part", 1, 0, 0, + (SCM z), + "Return the imaginary part of the number @var{z}.") +#define FUNC_NAME s_scm_imag_part { - if (SCM_I_INUMP (z)) - return SCM_INUM0; - else if (SCM_BIGP (z)) - return SCM_INUM0; + if (SCM_COMPLEXP (z)) + return scm_from_double (SCM_COMPLEX_IMAG (z)); else if (SCM_REALP (z)) return flo0; - else if (SCM_COMPLEXP (z)) - return scm_from_double (SCM_COMPLEX_IMAG (z)); - else if (SCM_FRACTIONP (z)) + else if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z)) return SCM_INUM0; else - SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part); + SCM_WTA_DISPATCH_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part); } +#undef FUNC_NAME -SCM_GPROC (s_numerator, "numerator", 1, 0, 0, scm_numerator, g_numerator); -/* "Return the numerator of the number @var{z}." - */ -SCM -scm_numerator (SCM z) +SCM_PRIMITIVE_GENERIC (scm_numerator, "numerator", 1, 0, 0, + (SCM z), + "Return the numerator of the number @var{z}.") +#define FUNC_NAME s_scm_numerator { - if (SCM_I_INUMP (z)) - return z; - else if (SCM_BIGP (z)) + if (SCM_I_INUMP (z) || SCM_BIGP (z)) return z; else if (SCM_FRACTIONP (z)) return SCM_FRACTION_NUMERATOR (z); else if (SCM_REALP (z)) return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z))); else - SCM_WTA_DISPATCH_1 (g_numerator, z, SCM_ARG1, s_numerator); + SCM_WTA_DISPATCH_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator); } +#undef FUNC_NAME -SCM_GPROC (s_denominator, "denominator", 1, 0, 0, scm_denominator, g_denominator); -/* "Return the denominator of the number @var{z}." - */ -SCM -scm_denominator (SCM z) +SCM_PRIMITIVE_GENERIC (scm_denominator, "denominator", 1, 0, 0, + (SCM z), + "Return the denominator of the number @var{z}.") +#define FUNC_NAME s_scm_denominator { - if (SCM_I_INUMP (z)) - return SCM_INUM1; - else if (SCM_BIGP (z)) + if (SCM_I_INUMP (z) || SCM_BIGP (z)) return SCM_INUM1; else if (SCM_FRACTIONP (z)) return SCM_FRACTION_DENOMINATOR (z); else if (SCM_REALP (z)) return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z))); else - SCM_WTA_DISPATCH_1 (g_denominator, z, SCM_ARG1, s_denominator); + SCM_WTA_DISPATCH_1 (g_scm_denominator, z, SCM_ARG1, s_scm_denominator); } +#undef FUNC_NAME -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) + +SCM_PRIMITIVE_GENERIC (scm_magnitude, "magnitude", 1, 0, 0, + (SCM z), + "Return the magnitude of the number @var{z}. This is the same as\n" + "@code{abs} for real arguments, but also allows complex numbers.") +#define FUNC_NAME s_scm_magnitude { if (SCM_I_INUMP (z)) { @@ -7170,15 +7159,15 @@ scm_magnitude (SCM z) SCM_FRACTION_DENOMINATOR (z)); } else - SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude); + SCM_WTA_DISPATCH_1 (g_scm_magnitude, z, SCM_ARG1, s_scm_magnitude); } +#undef FUNC_NAME -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) +SCM_PRIMITIVE_GENERIC (scm_angle, "angle", 1, 0, 0, + (SCM z), + "Return the angle of the complex number @var{z}.") +#define FUNC_NAME s_scm_angle { /* atan(0,-1) is pi and it'd be possible to have that as a constant like flo0 to save allocating a new flonum with scm_from_double each time. @@ -7216,15 +7205,15 @@ scm_angle (SCM z) else return scm_from_double (atan2 (0.0, -1.0)); } else - SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle); + SCM_WTA_DISPATCH_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle); } +#undef FUNC_NAME -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) +SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact, "exact->inexact", 1, 0, 0, + (SCM z), + "Convert the number @var{z} to its inexact representation.\n") +#define FUNC_NAME s_scm_exact_to_inexact { if (SCM_I_INUMP (z)) return scm_from_double ((double) SCM_I_INUM (z)); @@ -7235,22 +7224,21 @@ scm_exact_to_inexact (SCM z) else if (SCM_INEXACTP (z)) return z; else - SCM_WTA_DISPATCH_1 (g_exact_to_inexact, z, 1, s_exact_to_inexact); + SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact, z, 1, s_scm_exact_to_inexact); } +#undef FUNC_NAME -SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, - (SCM z), - "Return an exact number that is numerically closest to @var{z}.") +SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, + (SCM z), + "Return an exact number that is numerically closest to @var{z}.") #define FUNC_NAME s_scm_inexact_to_exact { - if (SCM_I_INUMP (z)) - return z; - else if (SCM_BIGP (z)) + if (SCM_I_INUMP (z) || SCM_BIGP (z)) return z; else if (SCM_REALP (z)) { - if (isinf (SCM_REAL_VALUE (z)) || isnan (SCM_REAL_VALUE (z))) + if (!DOUBLE_IS_FINITE (SCM_REAL_VALUE (z))) SCM_OUT_OF_RANGE (1, z); else { @@ -7272,7 +7260,7 @@ SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, else if (SCM_FRACTIONP (z)) return z; else - SCM_WRONG_TYPE_ARG (1, z); + SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact, z, 1, s_scm_inexact_to_exact); } #undef FUNC_NAME @@ -7712,9 +7700,9 @@ scm_is_number (SCM z) real-only case, and because we have to test SCM_COMPLEXP anyway so may as well use it to go straight to the applicable C func. */ -SCM_DEFINE (scm_log, "log", 1, 0, 0, - (SCM z), - "Return the natural logarithm of @var{z}.") +SCM_PRIMITIVE_GENERIC (scm_log, "log", 1, 0, 0, + (SCM z), + "Return the natural logarithm of @var{z}.") #define FUNC_NAME s_scm_log { if (SCM_COMPLEXP (z)) @@ -7728,7 +7716,7 @@ SCM_DEFINE (scm_log, "log", 1, 0, 0, atan2 (im, re)); #endif } - else + else if (SCM_NUMBERP (z)) { /* ENHANCE-ME: When z is a bignum the logarithm will fit a double although the value itself overflows. */ @@ -7739,13 +7727,15 @@ SCM_DEFINE (scm_log, "log", 1, 0, 0, else return scm_c_make_rectangular (l, M_PI); } + else + SCM_WTA_DISPATCH_1 (g_scm_log, z, 1, s_scm_log); } #undef FUNC_NAME -SCM_DEFINE (scm_log10, "log10", 1, 0, 0, - (SCM z), - "Return the base 10 logarithm of @var{z}.") +SCM_PRIMITIVE_GENERIC (scm_log10, "log10", 1, 0, 0, + (SCM z), + "Return the base 10 logarithm of @var{z}.") #define FUNC_NAME s_scm_log10 { if (SCM_COMPLEXP (z)) @@ -7763,7 +7753,7 @@ SCM_DEFINE (scm_log10, "log10", 1, 0, 0, M_LOG10E * atan2 (im, re)); #endif } - else + else if (SCM_NUMBERP (z)) { /* ENHANCE-ME: When z is a bignum the logarithm will fit a double although the value itself overflows. */ @@ -7774,14 +7764,16 @@ SCM_DEFINE (scm_log10, "log10", 1, 0, 0, else return scm_c_make_rectangular (l, M_LOG10E * M_PI); } + else + SCM_WTA_DISPATCH_1 (g_scm_log10, z, 1, s_scm_log10); } #undef FUNC_NAME -SCM_DEFINE (scm_exp, "exp", 1, 0, 0, - (SCM z), - "Return @math{e} to the power of @var{z}, where @math{e} is the\n" - "base of natural logarithms (2.71828@dots{}).") +SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0, + (SCM z), + "Return @math{e} to the power of @var{z}, where @math{e} is the\n" + "base of natural logarithms (2.71828@dots{}).") #define FUNC_NAME s_scm_exp { if (SCM_COMPLEXP (z)) @@ -7793,51 +7785,55 @@ SCM_DEFINE (scm_exp, "exp", 1, 0, 0, SCM_COMPLEX_IMAG (z)); #endif } - else + else if (SCM_NUMBERP (z)) { /* When z is a negative bignum the conversion to double overflows, giving -infinity, but that's ok, the exp is still 0.0. */ return scm_from_double (exp (scm_to_double (z))); } + else + SCM_WTA_DISPATCH_1 (g_scm_exp, z, 1, s_scm_exp); } #undef FUNC_NAME -SCM_DEFINE (scm_sqrt, "sqrt", 1, 0, 0, - (SCM x), - "Return the square root of @var{z}. Of the two possible roots\n" - "(positive and negative), the one with the a positive real part\n" - "is returned, or if that's zero then a positive imaginary part.\n" - "Thus,\n" - "\n" - "@example\n" - "(sqrt 9.0) @result{} 3.0\n" - "(sqrt -9.0) @result{} 0.0+3.0i\n" - "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n" - "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n" - "@end example") +SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, + (SCM z), + "Return the square root of @var{z}. Of the two possible roots\n" + "(positive and negative), the one with the a positive real part\n" + "is returned, or if that's zero then a positive imaginary part.\n" + "Thus,\n" + "\n" + "@example\n" + "(sqrt 9.0) @result{} 3.0\n" + "(sqrt -9.0) @result{} 0.0+3.0i\n" + "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n" + "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n" + "@end example") #define FUNC_NAME s_scm_sqrt { - if (SCM_COMPLEXP (x)) + if (SCM_COMPLEXP (z)) { #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \ && defined SCM_COMPLEX_VALUE - return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (x))); + return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z))); #else - double re = SCM_COMPLEX_REAL (x); - double im = SCM_COMPLEX_IMAG (x); + double re = SCM_COMPLEX_REAL (z); + double im = SCM_COMPLEX_IMAG (z); return scm_c_make_polar (sqrt (hypot (re, im)), 0.5 * atan2 (im, re)); #endif } - else + else if (SCM_NUMBERP (z)) { - double xx = scm_to_double (x); + double xx = scm_to_double (z); if (xx < 0) return scm_c_make_rectangular (0.0, sqrt (-xx)); else return scm_from_double (sqrt (xx)); } + else + SCM_WTA_DISPATCH_1 (g_scm_sqrt, z, 1, s_scm_sqrt); } #undef FUNC_NAME diff --git a/libguile/numbers.h b/libguile/numbers.h index 76d2972..2cf3fd7 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -169,8 +169,9 @@ typedef struct scm_t_complex SCM_API SCM scm_exact_p (SCM x); SCM_API SCM scm_odd_p (SCM n); SCM_API SCM scm_even_p (SCM n); -SCM_API SCM scm_inf_p (SCM n); -SCM_API SCM scm_nan_p (SCM n); +SCM_API SCM scm_finite_p (SCM x); +SCM_API SCM scm_inf_p (SCM x); +SCM_API SCM scm_nan_p (SCM x); SCM_API SCM scm_inf (void); SCM_API SCM scm_nan (void); SCM_API SCM scm_abs (SCM x); diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 9cf9202..01bccda 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -281,8 +281,7 @@ ;;; (with-test-prefix "exp" - (pass-if "documented?" - (documented? exp)) + (pass-if (documented? exp)) (pass-if-exception "no args" exception:wrong-num-args (exp)) @@ -426,9 +425,7 @@ ;;; (with-test-prefix "quotient" - - (expect-fail "documented?" - (documented? quotient)) + (pass-if (documented? quotient)) (with-test-prefix "0 / n" @@ -642,9 +639,7 @@ ;;; (with-test-prefix "remainder" - - (expect-fail "documented?" - (documented? remainder)) + (pass-if (documented? remainder)) (with-test-prefix "0 / n" @@ -837,9 +832,7 @@ ;;; (with-test-prefix "modulo" - - (expect-fail "documented?" - (documented? modulo)) + (pass-if (documented? modulo)) (with-test-prefix "0 % n" @@ -2354,7 +2347,7 @@ ;;; (with-test-prefix "zero?" - (expect-fail (documented? zero?)) + (pass-if (documented? zero?)) (pass-if (zero? 0)) (pass-if (not (zero? 7))) (pass-if (not (zero? -7))) @@ -2368,7 +2361,7 @@ ;;; (with-test-prefix "positive?" - (expect-fail (documented? positive?)) + (pass-if (documented? positive?)) (pass-if (positive? 1)) (pass-if (positive? (+ fixnum-max 1))) (pass-if (positive? 1.3)) @@ -2382,7 +2375,7 @@ ;;; (with-test-prefix "negative?" - (expect-fail (documented? negative?)) + (pass-if (documented? negative?)) (pass-if (not (negative? 1))) (pass-if (not (negative? (+ fixnum-max 1)))) (pass-if (not (negative? 1.3))) @@ -3118,6 +3111,7 @@ ;;; (with-test-prefix "expt" + (pass-if (documented? expt)) (pass-if-exception "non-numeric base" exception:wrong-type-arg (expt #t 0)) (pass-if (eqv? 1 (expt 0 0))) @@ -3199,15 +3193,32 @@ ;;; real-part ;;; +(with-test-prefix "real-part" + (pass-if (documented? real-part)) + (pass-if (eqv? 5.0 (real-part 5.0))) + (pass-if (eqv? 0.0 (real-part +5.0i))) + (pass-if (eqv? 5 (real-part 5))) + (pass-if (eqv? 1/5 (real-part 1/5))) + (pass-if (eqv? (1+ fixnum-max) (real-part (1+ fixnum-max))))) + ;;; ;;; imag-part ;;; +(with-test-prefix "imag-part" + (pass-if (documented? imag-part)) + (pass-if (eqv? 0.0 (imag-part 5.0))) + (pass-if (eqv? 5.0 (imag-part +5.0i))) + (pass-if (eqv? 0 (imag-part 5))) + (pass-if (eqv? 0 (imag-part 1/5))) + (pass-if (eqv? 0 (imag-part (1+ fixnum-max))))) + ;;; ;;; magnitude ;;; (with-test-prefix "magnitude" + (pass-if (documented? magnitude)) (pass-if (= 0 (magnitude 0))) (pass-if (= 1 (magnitude 1))) (pass-if (= 1 (magnitude -1))) @@ -3227,6 +3238,8 @@ (define (almost= x y) (> 0.01 (magnitude (- x y)))) + (pass-if (documented? angle)) + (pass-if "inum +ve" (= 0 (angle 1))) (pass-if "inum -ve" (almost= pi (angle -1))) @@ -3241,7 +3254,8 @@ ;;; (with-test-prefix "inexact->exact" - + (pass-if (documented? inexact->exact)) + (pass-if-exception "+inf" exception:out-of-range (inexact->exact +inf.0)) @@ -3263,6 +3277,7 @@ ;;; (with-test-prefix "integer-expt" + (pass-if (documented? integer-expt)) (pass-if-exception "non-numeric base" exception:wrong-type-arg (integer-expt #t 0)) @@ -3294,6 +3309,7 @@ ;;; (with-test-prefix "integer-length" + (pass-if (documented? integer-length)) (with-test-prefix "-2^i, ...11100..00" (do ((n -1 (ash n 1)) @@ -3321,8 +3337,7 @@ ;;; (with-test-prefix "log" - (pass-if "documented?" - (documented? log)) + (pass-if (documented? log)) (pass-if-exception "no args" exception:wrong-num-args (log)) @@ -3349,8 +3364,7 @@ ;;; (with-test-prefix "log10" - (pass-if "documented?" - (documented? log10)) + (pass-if (documented? log10)) (pass-if-exception "no args" exception:wrong-num-args (log10)) @@ -3377,6 +3391,8 @@ ;;; (with-test-prefix "logbit?" + (pass-if (documented? logbit?)) + (pass-if (eq? #f (logbit? 0 0))) (pass-if (eq? #f (logbit? 1 0))) (pass-if (eq? #f (logbit? 31 0))) @@ -3412,6 +3428,7 @@ ;;; (with-test-prefix "logcount" + (pass-if (documented? logcount)) (with-test-prefix "-2^i, meaning ...11100..00" (do ((n -1 (ash n 1)) @@ -3439,6 +3456,8 @@ ;;; (with-test-prefix "logior" + (pass-if (documented? logior)) + (pass-if (eqv? -1 (logior (ash -1 1) 1))) ;; check that bignum or bignum+inum args will reduce to an inum @@ -3468,6 +3487,8 @@ ;;; (with-test-prefix "lognot" + (pass-if (documented? lognot)) + (pass-if (= -1 (lognot 0))) (pass-if (= 0 (lognot -1))) (pass-if (= -2 (lognot 1))) @@ -3483,8 +3504,7 @@ ;;; (with-test-prefix "sqrt" - (pass-if "documented?" - (documented? sqrt)) + (pass-if (documented? sqrt)) (pass-if-exception "no args" exception:wrong-num-args (sqrt)) @@ -3626,6 +3646,13 @@ test-numerators)) test-denominators)) + (pass-if (documented? euclidean/)) + (pass-if (documented? euclidean-quotient)) + (pass-if (documented? euclidean-remainder)) + (pass-if (documented? centered/)) + (pass-if (documented? centered-quotient)) + (pass-if (documented? centered-remainder)) + (with-test-prefix "euclidean-quotient" (do-tests-1 'euclidean-quotient euclidean-quotient -- 1.5.6.5