From ffa984809d4227b21283f0b8fa8483632b66b6db Mon Sep 17 00:00:00 2001 From: jgarcia Date: Sun, 29 Oct 2006 10:34:32 +0000 Subject: [PATCH] New functions for type errors with error recovery (ecl_type_error, si:wrong-type-argument). Incorporated this facility to all functions in num_sfun.d and num_co.d, as well as to make_complex() --- src/CHANGELOG | 9 +- src/c/num_co.d | 161 ++++++++++++++--------- src/c/num_sfun.d | 319 ++++++++++++++++++++++++++------------------- src/c/number.d | 5 +- src/c/predicate.d | 6 +- src/h/external.h | 10 +- src/h/object.h | 2 +- src/lsp/assert.lsp | 9 +- 8 files changed, 314 insertions(+), 207 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index ae60bc2a0..59c357358 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -139,6 +139,12 @@ ECL 1.0: - The debugger now prints a list of available restarts. + - Added restarts to the errors signaled by these functions: SIN, COS, EXP, + EXPT, TAN, TANH, SINH, COSH, LOG, ATAN, RATIONAL, NUMERATOR, DENOMINATOR, + FLOOR, CEILING, ROUND, TRUNCATE, FLOAT-PRECISION, FLOAT-SIGN, DECODE-FLOAT, + SCALE-FLOAT, FLOAT-RADIX, FLOAT-DIGITS, INTEGER-DECODE-FLOAT, REALPART, + IMAGPART, COMPLEX. + - C functions which disappear: si_set_compiled_function_name(), si_extended_string_concatenate() @@ -149,7 +155,8 @@ ECL 1.0: ecl_type_error(). - Functions renamed: backup_fopen() -> ecl_backup_fopen() - char_code() -> ecl_char_code() + char_code() -> ecl_char_code(), cl_log1() -> ecl_log1(), + cl_log2() -> ecl_log2(), NUMBER_TYPE() -> ECL_NUMBER_TYPE_P() * Contributed code: diff --git a/src/c/num_co.d b/src/c/num_co.d index 57bf97744..2ba9054b7 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -57,14 +57,13 @@ number_remainder(cl_object x, cl_object y, cl_object q) otherwise coerce to same float type as second arg */ @(defun float (x &optional (y OBJNULL)) - cl_type t, tx; - double d; - /* TODO: LONG_FLOAT SHORT_FLOAT */ + cl_type ty, tx; @ + AGAIN: if (y != OBJNULL) { - t = type_of(y); + ty = type_of(y); } else { - t = t_singlefloat; + ty = t_singlefloat; } switch (tx = type_of(x)) { #ifdef ECL_SHORT_FLOAT @@ -75,12 +74,12 @@ number_remainder(cl_object x, cl_object y, cl_object q) #ifdef ECL_LONG_FLOAT case t_longfloat: #endif - if (y == OBJNULL || t == tx) + if (y == OBJNULL || ty == tx) break; case t_fixnum: case t_bignum: case t_ratio: - switch (t) { + switch (ty) { #ifdef ECL_SHORT_FLOAT case t_shortfloat: x = make_shortfloat(number_to_double(x)); break; @@ -90,18 +89,17 @@ number_remainder(cl_object x, cl_object y, cl_object q) case t_doublefloat: x = make_doublefloat(number_to_double(x)); break; #ifdef ECL_LONG_FLOAT - case t_longfloat: { - /* FIXME! We lose precision! */ - volatile double y = number_to_double(x); - x = make_longfloat(y); break; - } + case t_longfloat: + x = make_longfloat(number_to_long_double(x)); break; #endif default: - FEtype_error_float(y); + y = ecl_type_error(@'float',"prototype",y,@'float'); + goto AGAIN; } break; default: - FEtype_error_real(x); + x = ecl_type_error(@'float',"argument",x,@'real'); + goto AGAIN; } @(return x) @) @@ -109,44 +107,44 @@ number_remainder(cl_object x, cl_object y, cl_object q) cl_object cl_numerator(cl_object x) { - cl_object out; - + AGAIN: switch (type_of(x)) { case t_ratio: - out = x->ratio.num; + x = x->ratio.num; break; case t_fixnum: case t_bignum: - out = x; break; default: - FEwrong_type_argument(@'rational', x); + x = ecl_type_error(@'numerator',"argument",x,@'rational'); + goto AGAIN; } - @(return out) + @(return x) } cl_object cl_denominator(cl_object x) { - cl_object out; - + AGAIN: switch (type_of(x)) { case t_ratio: - out = x->ratio.den; + x = x->ratio.den; break; case t_fixnum: case t_bignum: - out = MAKE_FIXNUM(1); + x = MAKE_FIXNUM(1); break; default: - FEwrong_type_argument(@'rational', x); + x = ecl_type_error(@'numerator',"argument",x,@'rational'); + goto AGAIN; } - @(return out) + @(return x) } cl_object floor1(cl_object x) { + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: @@ -190,7 +188,8 @@ floor1(cl_object x) } #endif default: - FEtype_error_real(x); + x = ecl_type_error(@'floor',"argument",x,@'real'); + goto AGAIN; } NVALUES = 2; return VALUES(0); @@ -199,9 +198,14 @@ floor1(cl_object x) cl_object floor2(cl_object x, cl_object y) { + cl_type ty; + AGAIN: + while ((ty = type_of(y), !ECL_NUMBER_TYPE_P(ty))) { + y = ecl_type_error(@'floor',"divisor",y,@'real'); + } switch(type_of(x)) { case t_fixnum: - switch(type_of(y)) { + switch(ty) { case t_fixnum: { /* FIX / FIX */ cl_fixnum a = fix(x), b = fix(y); cl_fixnum q = a / b, r = a % b; @@ -275,11 +279,11 @@ floor2(cl_object x, cl_object y) } #endif default: - FEtype_error_real(y); + (void)0; /* Never reached */ } break; case t_bignum: - switch(type_of(y)) { + switch(ty) { case t_fixnum: { /* BIG / FIX */ cl_object q = big_register0_get(); cl_object r = big_register1_get(); @@ -349,11 +353,11 @@ floor2(cl_object x, cl_object y) } #endif default: - FEtype_error_real(y); + (void)0; /* Never reached */ } break; case t_ratio: - switch(type_of(y)) { + switch(ty) { case t_ratio: /* RAT / RAT */ floor2(number_times(x->ratio.num, y->ratio.den), number_times(x->ratio.den, y->ratio.num)); @@ -401,7 +405,8 @@ floor2(cl_object x, cl_object y) } #endif default: - FEtype_error_real(x); + x = ecl_type_error(@'floor',"argument",x,@'real'); + goto AGAIN; } NVALUES = 2; return VALUES(0); @@ -419,6 +424,7 @@ floor2(cl_object x, cl_object y) cl_object ceiling1(cl_object x) { + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: @@ -462,7 +468,8 @@ ceiling1(cl_object x) } #endif default: - FEtype_error_real(x); + x = ecl_type_error(@'ceiling',"argument",x,@'real'); + goto AGAIN; } NVALUES = 2; return VALUES(0); @@ -471,9 +478,14 @@ ceiling1(cl_object x) cl_object ceiling2(cl_object x, cl_object y) { + cl_type ty; + AGAIN: + while ((ty = type_of(y), !ECL_NUMBER_TYPE_P(ty))) { + y = ecl_type_error(@'ceiling',"divisor",y,@'real'); + } switch(type_of(x)) { case t_fixnum: - switch(type_of(y)) { + switch(ty) { case t_fixnum: { /* FIX / FIX */ cl_fixnum a = fix(x); cl_fixnum b = fix(y); cl_fixnum q = a / b; cl_fixnum r = a % b; @@ -547,7 +559,7 @@ ceiling2(cl_object x, cl_object y) } #endif default: - FEtype_error_real(y); + (void)0; /*Never reached */ } break; case t_bignum: @@ -621,7 +633,7 @@ ceiling2(cl_object x, cl_object y) } #endif default: - FEtype_error_real(y); + (void)0; /*Never reached */ } break; case t_ratio: @@ -673,7 +685,8 @@ ceiling2(cl_object x, cl_object y) } #endif default: - FEtype_error_real(x); + x = ecl_type_error(@'ceiling',"argument",x,@'real'); + goto AGAIN; } NVALUES = 2; return VALUES(0); @@ -691,6 +704,7 @@ ceiling2(cl_object x, cl_object y) cl_object truncate1(cl_object x) { + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: @@ -734,7 +748,8 @@ truncate1(cl_object x) } #endif default: - FEtype_error_real(x); + x = ecl_type_error(@'truncate',"argument",x,@'real'); + goto AGAIN; } NVALUES = 2; return VALUES(0); @@ -801,6 +816,7 @@ round_long_double(long double d) cl_object round1(cl_object x) { + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: @@ -840,7 +856,8 @@ round1(cl_object x) } #endif default: - FEtype_error_real(x); + x = ecl_type_error(@'round',"argument",x,@'real'); + goto AGAIN; } NVALUES = 2; return VALUES(0); @@ -916,7 +933,7 @@ cl_decode_float(cl_object x) cl_type tx = type_of(x); float f; double d; - + AGAIN: switch (tx) { #ifdef ECL_SHORT_FLOAT case t_shortfloat: @@ -963,7 +980,8 @@ cl_decode_float(cl_object x) } #endif default: - FEtype_error_float(x); + x = ecl_type_error(@'decode-float',"argument",x,@'float'); + goto AGAIN; } @(return x MAKE_FIXNUM(e) make_singlefloat(s)) } @@ -972,11 +990,13 @@ cl_object cl_scale_float(cl_object x, cl_object y) { cl_fixnum k; - - if (FIXNUMP(y)) + AGAIN: + if (FIXNUMP(y)) { k = fix(y); - else - FEerror("~S is an illegal exponent.", 1, y); + } else { + y = ecl_type_error(@'scale-float',"exponent",y,@'fixnum'); + goto AGAIN; + } switch (type_of(x)) { #ifdef ECL_SHORT_FLOAT case t_shortfloat: @@ -995,7 +1015,8 @@ cl_scale_float(cl_object x, cl_object y) break; #endif default: - FEtype_error_float(x); + x = ecl_type_error(@'scale-float',"argument",x,@'float'); + goto AGAIN; } @(return x) } @@ -1003,14 +1024,16 @@ cl_scale_float(cl_object x, cl_object y) cl_object cl_float_radix(cl_object x) { - if (cl_floatp(x) != Ct) - FEtype_error_float(x); + while (cl_floatp(x) != Ct) { + x = ecl_type_error(@'float-radix',"argument",x,@'float'); + } @(return MAKE_FIXNUM(FLT_RADIX)) } @(defun float_sign (x &optional (y x)) int negativep; @ + AGAIN: switch (type_of(x)) { #ifdef ECL_SHORT_FLOAT case t_shortfloat: @@ -1025,37 +1048,45 @@ cl_float_radix(cl_object x) negativep = ecl_long_float(x) < 0; break; #endif default: - FEtype_error_float(x); + x = ecl_type_error(@'float-sign',"argument",x,@'float'); + goto AGAIN; } switch (type_of(y)) { #ifdef ECL_SHORT_FLOAT case t_shortfloat: { float f = ecl_short_float(y); - @(return make_shortfloat(negativep? -fabsf(f) : fabsf(f))) + x = make_shortfloat(negativep? -fabsf(f) : fabsf(f)); + break; } #endif case t_singlefloat: { float f = sf(y); - @(return make_singlefloat(negativep? -fabsf(f) : fabsf(f))) + x = make_singlefloat(negativep? -fabsf(f) : fabsf(f)); + break; } case t_doublefloat: { double f = df(y); - @(return make_doublefloat(negativep? -fabs(f) : fabs(f))) + x = make_doublefloat(negativep? -fabs(f) : fabs(f)); + break; } #ifdef ECL_LONG_FLOAT case t_longfloat: { long double f = ecl_long_float(y); - @(return make_longfloat(negativep? -fabsl(f) : fabsl(f))) + x = make_longfloat(negativep? -fabsl(f) : fabsl(f)); + break; } #endif default: - FEtype_error_float(x); + y = ecl_type_error(@'float-sign',"prototype",y,@'float'); + goto AGAIN; } + @(return x); @) cl_object cl_float_digits(cl_object x) { + AGAIN: switch (type_of(x)) { #ifdef ECL_SHORT_FLOAT case t_shortfloat: @@ -1072,7 +1103,8 @@ cl_float_digits(cl_object x) break; #endif default: - FEtype_error_float(x); + x = ecl_type_error(@'float-digits',"argument",x,@'float'); + goto AGAIN; } @(return x) } @@ -1082,6 +1114,7 @@ cl_float_precision(cl_object x) { int precision; float f; double d; + AGAIN: switch (type_of(x)) { #ifdef ECL_SHORT_FLOAT case t_shortfloat: { @@ -1148,7 +1181,8 @@ cl_float_precision(cl_object x) } #endif default: - FEtype_error_float(x); + x = ecl_type_error(@'float-precision',"argument",x,@'float'); + goto AGAIN; } @(return MAKE_FIXNUM(precision)) } @@ -1157,7 +1191,7 @@ cl_object cl_integer_decode_float(cl_object x) { int e, s; - + AGAIN: switch (type_of(x)) { #ifdef ECL_LONG_FLOAT case t_longfloat: { @@ -1241,7 +1275,8 @@ cl_integer_decode_float(cl_object x) } #endif default: - FEtype_error_float(x); + x = ecl_type_error(@'integer-decode-float',"argument",x,@'float'); + goto AGAIN; } @(return x MAKE_FIXNUM(e) MAKE_FIXNUM(s)) } @@ -1255,6 +1290,7 @@ cl_integer_decode_float(cl_object x) cl_object cl_realpart(cl_object x) { + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: @@ -1272,7 +1308,8 @@ cl_realpart(cl_object x) x = x->complex.real; break; default: - FEtype_error_number(x); + x = ecl_type_error(@'realpart',"argument",x,@'number'); + goto AGAIN; } @(return x) } @@ -1280,6 +1317,7 @@ cl_realpart(cl_object x) cl_object cl_imagpart(cl_object x) { + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: @@ -1305,7 +1343,8 @@ cl_imagpart(cl_object x) x = x->complex.imag; break; default: - FEtype_error_number(x); + x = ecl_type_error(@'imagpart',"argument",x,@'number'); + goto AGAIN; } @(return x) } diff --git a/src/c/num_sfun.d b/src/c/num_sfun.d index ab845c7e8..520fa50f4 100644 --- a/src/c/num_sfun.d +++ b/src/c/num_sfun.d @@ -69,51 +69,57 @@ fixnum_expt(cl_fixnum x, cl_fixnum y) cl_object cl_exp(cl_object x) { + cl_object output; + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return1(make_singlefloat(expf(number_to_double(x)))); + output = make_singlefloat(expf(number_to_float(x))); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: - return1(make_shortfloat(expf(ecl_short_float(x)))); + output = make_shortfloat(expf(ecl_short_float(x))); break; #endif case t_singlefloat: - return1(make_singlefloat(expf(sf(x)))); - + output = make_singlefloat(expf(sf(x))); break; case t_doublefloat: - return1(make_doublefloat(exp(df(x)))); + output = make_doublefloat(exp(df(x))); break; #ifdef ECL_LONG_FLOAT case t_longfloat: - return1(make_longfloat(expl(ecl_long_float(x)))); + output = make_longfloat(expl(ecl_long_float(x))); break; #endif case t_complex: { cl_object y, y1; y = x->complex.imag; - x = x->complex.real; - x = cl_exp(x); + output = cl_exp(x->complex.real); y1 = cl_cos(y); y = cl_sin(y); y = make_complex(y1, y); - x = number_times(x, y); - return1(x); + output = number_times(output, y); + break; } - default: - FEtype_error_number(x); + x = ecl_type_error(@'exp',"exponent",x,@'number'); + goto AGAIN; } + @(return output) } cl_object cl_expt(cl_object x, cl_object y) { - cl_type ty = type_of(y); + cl_type ty, tx; cl_object z; - + AGAIN: + while ((ty = type_of(y), !ECL_NUMBER_TYPE_P(ty))) { + y = ecl_type_error(@'exp',"exponent",y,@'number'); + } + while ((tx = type_of(x), !ECL_NUMBER_TYPE_P(tx))) { + x = ecl_type_error(@'exp',"basis",x,@'number'); + } if (number_zerop(y)) { /* INV: The most specific numeric types come first. */ - cl_type tx = type_of(x); switch ((ty > tx)? ty : tx) { case t_fixnum: case t_bignum: @@ -137,14 +143,15 @@ cl_expt(cl_object x, cl_object y) z = make_complex(z, MAKE_FIXNUM(0)); break; default: - FEtype_error_number(x); + /* We will never reach this */ + (void)0; } } else if (number_zerop(x)) { if (!number_plusp(ty==t_complex?y->complex.real:y)) FEerror("Cannot raise zero to the power ~S.", 1, y); z = number_times(x, y); } else if (ty != t_fixnum && ty != t_bignum) { - z = cl_log1(x); + z = ecl_log1(x); z = number_times(z, y); z = cl_exp(z); } else if (number_minusp(y)) { @@ -162,103 +169,110 @@ cl_expt(cl_object x, cl_object y) x = number_times(x, x); } while (1); } - return1(z); + @(return z); +} + +static cl_object +ecl_log1_complex(cl_object r, cl_object i) +{ + cl_object a = number_times(r, r); + cl_object p = number_times(i, i); + a = number_plus(a, p); + a = ecl_log1(a); + a = number_divide(a, MAKE_FIXNUM(2)); + p = ecl_atan2(i, r); + return make_complex(a, p); } cl_object -cl_log1(cl_object x) +ecl_log1(cl_object x) { - cl_object r, i, a, p; - - if (type_of(x) == t_complex) { - r = x->complex.real; - i = x->complex.imag; - goto COMPLEX; + cl_type tx; + AGAIN: + tx = type_of(x); + if (!ECL_NUMBER_TYPE_P(tx)) { + x = ecl_type_error(@'log',"argument",x,@'number'); + goto AGAIN; } - if (number_zerop(x)) + if (tx == t_complex) { + return ecl_log1_complex(x->complex.real, x->complex.imag); + } else if (number_zerop(x)) { FEerror("Zero is the logarithmic singularity.", 0); - if (number_minusp(x)) { - r = x; - i = MAKE_FIXNUM(0); - goto COMPLEX; - } - switch (type_of(x)) { + } else if (number_minusp(x)) { + return ecl_log1_complex(x, MAKE_FIXNUM(0)); + } else switch (tx) { case t_fixnum: case t_bignum: case t_ratio: - return1(make_singlefloat(log(number_to_double(x)))); + return make_singlefloat(logf(number_to_float(x))); #ifdef ECL_SHORT_FLOAT case t_shortfloat: - return1(make_shortfloat(logf(ecl_short_float(x)))); + return make_shortfloat(logf(ecl_short_float(x))); #endif case t_singlefloat: - return1(make_singlefloat(logf(sf(x)))); + return make_singlefloat(logf(sf(x))); case t_doublefloat: - return1(make_doublefloat(log(df(x)))); + return make_doublefloat(log(df(x))); #ifdef ECL_LONG_FLOAT case t_longfloat: - return1(make_longfloat(logl(ecl_long_float(x)))); + return make_longfloat(logl(ecl_long_float(x))); #endif default: - FEtype_error_number(x); + /* We do not reach here */ + (void)0; } -COMPLEX: - a = number_times(r, r); - p = number_times(i, i); - a = number_plus(a, p); - a = cl_log1(a); - a = number_divide(a, MAKE_FIXNUM(2)); - p = cl_atan2(i, r); - x = make_complex(a, p); - return1(x); } cl_object -cl_log2(cl_object x, cl_object y) +ecl_log2(cl_object x, cl_object y) { if (number_zerop(y)) FEerror("Zero is the logarithmic singularity.", 0); - return1(number_divide(cl_log1(y), cl_log1(x))); + return number_divide(ecl_log1(y), ecl_log1(x)); } cl_object cl_sqrt(cl_object x) { cl_object z; - - if (type_of(x) == t_complex) - goto COMPLEX; - if (number_minusp(x)) - return1(make_complex(MAKE_FIXNUM(0), cl_sqrt(number_negate(x)))); - switch (type_of(x)) { + cl_type tx; + AGAIN: + tx = type_of(x); + if (!ECL_NUMBER_TYPE_P(tx)) { + x = ecl_type_error(@'sqrt',"argument",x,@'number'); + goto AGAIN; + } + if (tx == t_complex) { + z = make_ratio(MAKE_FIXNUM(1), MAKE_FIXNUM(2)); + z = cl_expt(x, z); + } else if (number_minusp(x)) { + z = make_complex(MAKE_FIXNUM(0), cl_sqrt(number_negate(x))); + } else switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return1(make_singlefloat(sqrtf(number_to_double(x)))); + z = make_singlefloat(sqrtf(number_to_float(x))); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: - return1(make_shortfloat(sqrtf(ecl_short_float(x)))); + z = make_shortfloat(sqrtf(ecl_short_float(x))); break;; #endif case t_singlefloat: - return1(make_singlefloat(sqrtf(sf(x)))); + z = make_singlefloat(sqrtf(sf(x))); break; case t_doublefloat: - return1(make_doublefloat(sqrt(df(x)))); + z = make_doublefloat(sqrt(df(x))); break; #ifdef ECL_LONG_FLOAT case t_longfloat: - return1(make_longfloat(sqrtl(ecl_long_float(x)))); + z = make_longfloat(sqrtl(ecl_long_float(x))); break; #endif default: - FEtype_error_number(x); + /* Never reaches this */ + (void)0; } - -COMPLEX: - z = make_ratio(MAKE_FIXNUM(1), MAKE_FIXNUM(2)); - z = cl_expt(x, z); - return1(z); + @(return z); } cl_object -cl_atan2(cl_object y, cl_object x) +ecl_atan2(cl_object y, cl_object x) { cl_object z; double dy, dx, dz; @@ -287,57 +301,57 @@ cl_atan2(cl_object y, cl_object x) else dz = -M_PI + atan(-dy / -dx); if (type_of(x) == t_doublefloat || type_of(y) == t_doublefloat) - z = make_doublefloat(dz); + return make_doublefloat(dz); else - z = make_singlefloat(dz); - return1(z); + return make_singlefloat(dz); } cl_object -cl_atan1(cl_object y) +ecl_atan1(cl_object y) { - cl_object z, z1; - if (type_of(y) == t_complex) { #if 0 /* FIXME! ANSI states it should be this first part */ z = number_times(cl_core.imag_unit, y); - z = cl_log1(one_plus(z)) + - cl_log1(number_minus(MAKE_FIXNUM(1), z)); + z = ecl_log1(one_plus(z)) + + ecl_log1(number_minus(MAKE_FIXNUM(1), z)); z = number_divide(z, number_times(MAKE_FIXNUM(2), cl_core.imag_unit)); #else - z = number_times(cl_core.imag_unit, y); + cl_object z1, z = number_times(cl_core.imag_unit, y); z = one_plus(z); z1 = number_times(y, y); z1 = one_plus(z1); z1 = cl_sqrt(z1); z = number_divide(z, z1); - z = cl_log1(z); + z = ecl_log1(z); z = number_times(cl_core.minus_imag_unit, z); #endif /* ANSI */ - return1(z); + return z; + } else { + return ecl_atan2(y, MAKE_FIXNUM(1)); } - return1(cl_atan2(y, MAKE_FIXNUM(1))); } cl_object cl_sin(cl_object x) { + cl_object output; + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return1(make_singlefloat(sinf(number_to_double(x)))); + output = make_singlefloat(sinf(number_to_float(x))); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: - return1(make_shortfloat(sinf(ecl_short_float(x)))); + output = make_shortfloat(sinf(ecl_short_float(x))); break; #endif case t_singlefloat: - return1(make_singlefloat(sinf(sf(x)))); + output = make_singlefloat(sinf(sf(x))); break; case t_doublefloat: - return1(make_doublefloat(sin(df(x)))); + output = make_doublefloat(sin(df(x))); break; #ifdef ECL_LONG_FLOAT case t_longfloat: - return1(make_longfloat(sinf(ecl_long_float(x)))); + output = make_longfloat(sinf(ecl_long_float(x))); break; #endif case t_complex: { /* @@ -350,33 +364,41 @@ cl_sin(cl_object x) double a = sin(dx) * cosh(dy); double b = cos(dx) * sinh(dy); if (type_of(x->complex.real) != t_doublefloat) - return1(make_complex(make_singlefloat(a), make_singlefloat(b))); - return1(make_complex(make_doublefloat(a), make_doublefloat(b))); + output = make_complex(make_singlefloat(a), + make_singlefloat(b)); + else + output = make_complex(make_doublefloat(a), + make_doublefloat(b)); + break; } default: - FEtype_error_number(x); + x = ecl_type_error(@'sin',"argument",x,@'number'); + goto AGAIN; } + @(return output) } cl_object cl_cos(cl_object x) { + cl_object output; + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return1(make_singlefloat(cosf(number_to_double(x)))); + output = make_singlefloat(cosf(number_to_float(x))); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: - return1(make_shortfloat(cosf(ecl_short_float(x)))); + output = make_shortfloat(cosf(ecl_short_float(x))); break; #endif case t_singlefloat: - return1(make_singlefloat(cosf(sf(x)))); + output = make_singlefloat(cosf(sf(x))); break; case t_doublefloat: - return1(make_doublefloat(cos(df(x)))); + output = make_doublefloat(cos(df(x))); break; #ifdef ECL_LONG_FLOAT case t_longfloat: - return1(make_longfloat(cosl(ecl_long_float(x)))); + output = make_longfloat(cosl(ecl_long_float(x))); break; #endif case t_complex: { /* @@ -388,64 +410,76 @@ cl_cos(cl_object x) double a = cos(dx) * cosh(dy); double b = -sin(dx) * sinh(dy); if (type_of(x->complex.real) != t_doublefloat) - return1(make_complex(make_singlefloat(a), make_singlefloat(b))); - return1(make_complex(make_doublefloat(a), make_doublefloat(b))); + output = make_complex(make_singlefloat(a), + make_singlefloat(b)); + else + output = make_complex(make_doublefloat(a), + make_doublefloat(b)); + break; } default: - FEtype_error_number(x); + x = ecl_type_error(@'cos',"argument",x,@'number'); + goto AGAIN; } + @(return output) } cl_object cl_tan(cl_object x) { + cl_object output; + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return1(make_singlefloat(tanf(number_to_double(x)))); + output = make_singlefloat(tanf(number_to_float(x))); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: - return1(make_shortfloat(tanf(ecl_short_float(x)))); + output = make_shortfloat(tanf(ecl_short_float(x))); break; #endif case t_singlefloat: - return1(make_singlefloat(tanf(sf(x)))); + output = make_singlefloat(tanf(sf(x))); break; case t_doublefloat: - return1(make_doublefloat(tan(df(x)))); + output = make_doublefloat(tan(df(x))); break; #ifdef ECL_LONG_FLOAT case t_longfloat: - return1(make_longfloat(tanl(ecl_long_float(x)))); + output = make_longfloat(tanl(ecl_long_float(x))); break; #endif case t_complex: { cl_object a = cl_sin(x); cl_object b = cl_cos(x); - return1(number_divide(a, b)); + output = number_divide(a, b); + break; } default: - FEtype_error_number(x); + x = ecl_type_error(@'tan',"argument",x,@'number'); + goto AGAIN; } + @(return output) } cl_object cl_sinh(cl_object x) { - + cl_object output; + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return1(make_singlefloat(sinhf(number_to_double(x)))); + output = make_singlefloat(sinhf(number_to_float(x))); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: - return1(make_shortfloat(sinhf(ecl_short_float(x)))); + output = make_shortfloat(sinhf(ecl_short_float(x))); break; #endif case t_singlefloat: - return1(make_singlefloat(sinhf(sf(x)))); + output = make_singlefloat(sinhf(sf(x))); break; case t_doublefloat: - return1(make_doublefloat(sinh(df(x)))); + output = make_doublefloat(sinh(df(x))); break; #ifdef ECL_LONG_FLOAT case t_longfloat: - return1(make_longfloat(sinhf(ecl_long_float(x)))); + output = make_longfloat(sinhf(ecl_long_float(x))); break; #endif case t_complex: { /* @@ -459,33 +493,41 @@ cl_sinh(cl_object x) double a = sinh(dx) * cos(dy); double b = cosh(dx) * sin(dy); if (type_of(x->complex.real) != t_doublefloat) - return1(make_complex(make_singlefloat(a), make_singlefloat(b))); - return1(make_complex(make_doublefloat(a), make_doublefloat(b))); + output = make_complex(make_singlefloat(a), + make_singlefloat(b)); + else + output = make_complex(make_doublefloat(a), + make_doublefloat(b)); + break; } default: - FEtype_error_number(x); + x = ecl_type_error(@'sinh',"argument",x,@'number'); + goto AGAIN; } + @(return output) } cl_object cl_cosh(cl_object x) { + cl_object output; + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return1(make_singlefloat(coshf(number_to_double(x)))); + output = make_singlefloat(coshf(number_to_float(x))); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: - return1(make_shortfloat(coshf(ecl_short_float(x)))); + output = make_shortfloat(coshf(ecl_short_float(x))); break; #endif case t_singlefloat: - return1(make_singlefloat(coshf(sf(x)))); + output = make_singlefloat(coshf(sf(x))); break; case t_doublefloat: - return1(make_doublefloat(cosh(df(x)))); + output = make_doublefloat(cosh(df(x))); break; #ifdef ECL_LONG_FLOAT case t_longfloat: - return1(make_longfloat(coshl(ecl_long_float(x)))); + output = make_longfloat(coshl(ecl_long_float(x))); break; #endif case t_complex: { /* @@ -499,54 +541,67 @@ cl_cosh(cl_object x) double a = cosh(dx) * cos(dy); double b = sinh(dx) * sin(dy); if (type_of(x->complex.real) != t_doublefloat) - return1(make_complex(make_singlefloat(a), make_singlefloat(b))); - return1(make_complex(make_doublefloat(a), make_doublefloat(b))); + output = make_complex(make_singlefloat(a), + make_singlefloat(b)); + else + output = make_complex(make_doublefloat(a), + make_doublefloat(b)); + break; } default: - FEtype_error_number(x); + x = ecl_type_error(@'cosh',"argument",x,@'number'); + goto AGAIN; } + @(return output) } cl_object cl_tanh(cl_object x) { + cl_object output; + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return1(make_singlefloat(tanhf(number_to_double(x)))); + output = make_singlefloat(tanhf(number_to_float(x))); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: - return1(make_shortfloat(tanhf(ecl_short_float(x)))); + output = make_shortfloat(tanhf(ecl_short_float(x))); break; #endif case t_singlefloat: - return1(make_singlefloat(tanhf(sf(x)))); + output = make_singlefloat(tanhf(sf(x))); break; case t_doublefloat: - return1(make_doublefloat(tanh(df(x)))); + output = make_doublefloat(tanh(df(x))); break; #ifdef ECL_LONG_FLOAT case t_longfloat: - return1(make_longfloat(coshl(ecl_long_float(x)))); + output = make_longfloat(coshl(ecl_long_float(x))); break; #endif case t_complex: { cl_object a = cl_sinh(x); cl_object b = cl_cosh(x); - return1(number_divide(a, b)); + output = number_divide(a, b); + break; } default: - FEtype_error_number(x); + x = ecl_type_error(@'tanh',"argument",x,@'number'); + goto AGAIN; } + @(return output) } @(defun log (x &optional (y OBJNULL)) -@ /* INV: type check in cl_log1() and cl_log2() */ +@ /* INV: type check in ecl_log1() and ecl_log2() */ if (y == OBJNULL) - @(return cl_log1(x)) - @(return cl_log2(y, x)) + @(return ecl_log1(x)) + @(return ecl_log2(y, x)) @) @(defun atan (x &optional (y OBJNULL)) -@ /* INV: type check in cl_atan() & cl_atan2() */ +@ /* INV: type check in ecl_atan() & ecl_atan2() */ + /* FIXME ecl_atan() and ecl_atan2() produce generic errors + without recovery and function information. */ if (y == OBJNULL) - @(return cl_atan1(x)) - @(return cl_atan2(x, y)) + @(return ecl_atan1(x)) + @(return ecl_atan2(x, y)) @) diff --git a/src/c/number.d b/src/c/number.d index b9fa864d2..d4ed30dc1 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -392,7 +392,7 @@ cl_object cl_rational(cl_object x) { double d; - + AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: @@ -441,7 +441,8 @@ cl_rational(cl_object x) } #endif default: - FEtype_error_number(x); + x = ecl_type_error(@'rational',"argument",x,@'number'); + goto AGAIN; } @(return x) } diff --git a/src/c/predicate.d b/src/c/predicate.d index 5be1e5093..91e343e50 100644 --- a/src/c/predicate.d +++ b/src/c/predicate.d @@ -56,14 +56,14 @@ cl_object cl_numberp(cl_object x) { cl_type t = type_of(x); - @(return (NUMBER_TYPE(t) ? Ct : Cnil)) + @(return (ECL_NUMBER_TYPE_P(t) ? Ct : Cnil)) } /* Used in compiled code */ bool numberp(cl_object x) { cl_type t = type_of(x); - return(NUMBER_TYPE(t)); + return ECL_NUMBER_TYPE_P(t); } cl_object @@ -442,7 +442,7 @@ BEGIN: case t_longfloat: #endif case t_complex: - if (NUMBER_TYPE(ty)) + if (ECL_NUMBER_TYPE_P(ty)) return number_equalp(x, y); else return FALSE; diff --git a/src/h/external.h b/src/h/external.h index f18a5092d..40751f751 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -859,6 +859,7 @@ extern cl_object make_complex(cl_object r, cl_object i); extern cl_object cl_rational(cl_object x); #define cl_rationalize cl_rational extern double number_to_double(cl_object x); +#define number_to_float(x) ((float)number_to_double(x)) #ifdef ECL_SHORT_FLOAT extern cl_object make_shortfloat(float f); extern float ecl_short_float(cl_object o); @@ -990,11 +991,7 @@ extern cl_object make_random_state(cl_object rs); extern cl_fixnum fixnum_expt(cl_fixnum x, cl_fixnum y); extern cl_object cl_exp(cl_object x); extern cl_object cl_expt(cl_object x, cl_object y); -extern cl_object cl_log1(cl_object x); -extern cl_object cl_log2(cl_object x, cl_object y); extern cl_object cl_sqrt(cl_object x); -extern cl_object cl_atan2(cl_object y, cl_object x); -extern cl_object cl_atan1(cl_object y); extern cl_object cl_sin(cl_object x); extern cl_object cl_cos(cl_object x); extern cl_object cl_tan(cl_object x); @@ -1004,6 +1001,11 @@ extern cl_object cl_tanh(cl_object x); extern cl_object cl_atan _ARGS((cl_narg narg, cl_object x, ...)); extern cl_object cl_log _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object ecl_log1(cl_object x); +extern cl_object ecl_log2(cl_object x, cl_object y); +extern cl_object ecl_atan2(cl_object y, cl_object x); +extern cl_object ecl_atan1(cl_object y); + /* package.c */ diff --git a/src/h/object.h b/src/h/object.h index ae313008b..df72911a4 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -72,7 +72,7 @@ typedef cl_object (*cl_objectfn_fixed)(); #define CHAR_CODE(obje) ((((cl_fixnum)(obje)) >> 2) & 0xff) #endif -#define NUMBER_TYPE(t) (t >= t_fixnum && t <= t_complex) +#define ECL_NUMBER_TYPE_P(t) (t >= t_fixnum && t <= t_complex) #define REAL_TYPE(t) (t >= t_fixnum && t < t_complex) #define ARRAY_TYPE(t) (t >= t_array && t <= t_bitvector) #define ARRAYP(x) ((IMMEDIATE(x) == 0) && (x)->d.t >= t_array && (x)->d.t <= t_bitvector) diff --git a/src/lsp/assert.lsp b/src/lsp/assert.lsp index 76167fe7c..153d4b9a9 100644 --- a/src/lsp/assert.lsp +++ b/src/lsp/assert.lsp @@ -19,10 +19,13 @@ (restart-case (error 'simple-type-error :format-control "In ~:[an anonymous function~;~:*function ~A~], ~:[found object~;~:*the value of ~A is~]~%~8t~S~%which is not of expected type ~A" - :format-arguments (list function place object type)) - (store-value (value) + :format-arguments (list function place object type) + :datum object + :expected-type type + ) + (use-value (value) :report (lambda (stream) - (format stream "Supply a new value ~@[of ~A~]." place)) + (format stream "Supply a new value of type ~A." type)) :interactive read-evaluated-form (setf object value) (unless (typep object type)