mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-28 07:22:27 -08:00
Code Issues Projects Releases Packages Wiki Activity

numbers: test for appropriate argument type in unary ops

Browse source 
This touches minmax, equalp and comparison of numbers. We also replace
old nested switch in ecl_number_compare with fast dispatch. Fixes #486.
This commit is contained in:
Daniel Kochmański 2019-04-06 17:23:33 +02:00
parent 22865f0c55
commit 0bf83ed03d
3 changed files with 126 additions and 149 deletions
Download patch file Download diff file Expand all files Collapse all files

12
src/c/numbers/minmax.d
View file

@ -17,9 +17,11 @@
@(defun max (max &rest nums)
@
/* INV: type check occurs in ecl_number_compare() for the rest of
numbers, but for the first argument it happens in ecl_zerop(). */
numbers, but for an unary argument it happens here. */
if (narg-- == 1) {
ecl_zerop(max);
if (! ECL_REAL_TYPE_P(ecl_t_of(max))) {
FEwrong_type_nth_arg(@[max], 1, max, @[real]);
}
} else do {
cl_object numi = ecl_va_arg(nums);
if (ecl_number_compare(max, numi) < 0)
@ -31,9 +33,11 @@
@(defun min (min &rest nums)
@
/* INV: type check occurs in ecl_number_compare() for the rest of
numbers, but for the first argument it happens in ecl_zerop(). */
numbers, but for an unary argument it happens here. */
if (narg-- == 1) {
ecl_zerop(min);
if (! ECL_REAL_TYPE_P(ecl_t_of(min))) {
FEwrong_type_nth_arg(@[min], 1, min, @[real]);
}
} else do {
cl_object numi = ecl_va_arg(nums);
if (ecl_number_compare(min, numi) > 0)

252
src/c/numbers/number_compare.d
View file

@ -30,164 +30,127 @@
int
ecl_number_compare(cl_object x, cl_object y)
{
cl_fixnum ix, iy;
double dx, dy;
#ifdef ECL_LONG_FLOAT
long double ldx, ldy;
#endif
cl_type ty;
BEGIN:
ty = ecl_t_of(y);
switch (ecl_t_of(x)) {
case t_fixnum:
ix = ecl_fixnum(x);
switch (ty) {
case t_fixnum:
iy = ecl_fixnum(y);
if (ix < iy)
return(-1);
else return(ix != iy);
case t_bignum:
/* INV: (= x y) can't be zero since fixnum != bignum */
return _ecl_big_sign(y) < 0? 1 : -1;
case t_ratio:
x = ecl_times(x, y->ratio.den);
y = y->ratio.num;
return(ecl_number_compare(x, y));
case t_singlefloat:
return double_fix_compare(ix, ecl_single_float(y));
case t_doublefloat:
return double_fix_compare(ix, ecl_double_float(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return long_double_fix_compare(ix, ecl_long_float(y));
#endif
default:
FEwrong_type_nth_arg(@[<], 2, y, @[real]);
MATH_DISPATCH2_BEGIN(x,y) {
/* rational x rational */
CASE_FIXNUM_FIXNUM {
cl_fixnum
ix = ecl_fixnum(x),
iy = ecl_fixnum(y);
if (ix < iy) return -1;
else return (ix != iy);
}
case t_bignum:
switch (ty) {
case t_fixnum:
return _ecl_big_sign(x) < 0 ? -1 : 1;
case t_bignum:
return(_ecl_big_compare(x, y));
case t_ratio:
x = ecl_times(x, y->ratio.den);
y = y->ratio.num;
return(ecl_number_compare(x, y));
case t_singlefloat:
case t_doublefloat:
/* INV: (= x y) can't be zero since fixnum != bignum */
CASE_FIXNUM_BIGNUM { return _ecl_big_sign(y) < 0 ? 1 : -1; }
CASE_BIGNUM_FIXNUM { return _ecl_big_sign(x) < 0 ? -1 : 1; }
CASE_BIGNUM_BIGNUM { return _ecl_big_compare(x, y); }
CASE_FIXNUM_RATIO;
CASE_BIGNUM_RATIO { return ecl_number_compare(ecl_times(x, y->ratio.den), y->ratio.num); }
CASE_RATIO_FIXNUM;
CASE_RATIO_BIGNUM { return ecl_number_compare(x->ratio.num, ecl_times(y, x->ratio.den)); }
CASE_RATIO_RATIO { return ecl_number_compare(ecl_times(x->ratio.num, y->ratio.den),
ecl_times(y->ratio.num, x->ratio.den)); }
/* float x fixnum */
CASE_SINGLE_FLOAT_FIXNUM { return -double_fix_compare(ecl_fixnum(y), ecl_single_float(x)); }
CASE_FIXNUM_SINGLE_FLOAT { return double_fix_compare(ecl_fixnum(x), ecl_single_float(y)); }
CASE_DOUBLE_FLOAT_FIXNUM { return -double_fix_compare(ecl_fixnum(y), ecl_double_float(x)); }
CASE_FIXNUM_DOUBLE_FLOAT { return double_fix_compare(ecl_fixnum(x), ecl_double_float(y)); }
#ifdef ECL_LONG_FLOAT
case t_longfloat:
CASE_LONG_FLOAT_FIXNUM { return -long_double_fix_compare(ecl_fixnum(y), ecl_long_float(x)); }
CASE_FIXNUM_LONG_FLOAT { return long_double_fix_compare(ecl_fixnum(x), ecl_long_float(y)); }
#endif
#ifdef ECL_IEEE_FP
if (ecl_float_infinity_p(y))
return(ecl_number_compare(ecl_make_fixnum(0), y));
#endif
y = cl_rational(y);
goto BEGIN;
default:
FEwrong_type_nth_arg(@[<], 2, y, @[real]);
}
case t_ratio:
switch (ty) {
case t_fixnum:
case t_bignum:
y = ecl_times(y, x->ratio.den);
x = x->ratio.num;
return(ecl_number_compare(x, y));
case t_ratio:
return(ecl_number_compare(ecl_times(x->ratio.num,
y->ratio.den),
ecl_times(y->ratio.num,
x->ratio.den)));
case t_singlefloat:
case t_doublefloat:
/* float x [bignum,ratio] */
CASE_SINGLE_FLOAT_BIGNUM;
CASE_SINGLE_FLOAT_RATIO;
CASE_DOUBLE_FLOAT_BIGNUM;
CASE_DOUBLE_FLOAT_RATIO;
#ifdef ECL_LONG_FLOAT
case t_longfloat:
CASE_LONG_FLOAT_BIGNUM;
CASE_LONG_FLOAT_RATIO;
#endif
#ifdef ECL_IEEE_FP
if (ecl_float_infinity_p(y))
return(ecl_number_compare(ecl_make_fixnum(0), y));
#endif
y = cl_rational(y);
goto BEGIN;
default:
FEwrong_type_nth_arg(@[<], 2, y, @[real]);
}
case t_singlefloat:
dx = (double)(ecl_single_float(x));
goto DOUBLEFLOAT0;
case t_doublefloat:
dx = ecl_double_float(x);
DOUBLEFLOAT0:
switch (ty) {
case t_fixnum:
return -double_fix_compare(ecl_fixnum(y), dx);
case t_bignum:
case t_ratio:
{
#ifdef ECL_IEEE_FP
if (ecl_float_infinity_p(x))
return(ecl_number_compare(x, ecl_make_fixnum(0)));
return ecl_number_compare(x, ecl_make_fixnum(0));
#endif
x = cl_rational(x);
goto BEGIN;
case t_singlefloat:
dy = (double)(ecl_single_float(y));
break;
case t_doublefloat:
dy = ecl_double_float(y);
break;
}
CASE_BIGNUM_SINGLE_FLOAT;
CASE_RATIO_SINGLE_FLOAT;
CASE_BIGNUM_DOUBLE_FLOAT;
CASE_RATIO_DOUBLE_FLOAT;
#ifdef ECL_LONG_FLOAT
case t_longfloat:
ldx = dx;
CASE_BIGNUM_LONG_FLOAT;
CASE_RATIO_LONG_FLOAT;
#endif
{
#ifdef ECL_IEEE_FP
if (ecl_float_infinity_p(y))
return ecl_number_compare(ecl_make_fixnum(0), y);
#endif
y = cl_rational(y);
goto BEGIN;
}
/* float x float */
CASE_SINGLE_FLOAT_SINGLE_FLOAT {
dx = ecl_single_float(x);
dy = ecl_single_float(y);
goto DOUBLEFLOAT;
}
CASE_SINGLE_FLOAT_DOUBLE_FLOAT {
dx = ecl_single_float(x);
dy = ecl_double_float(y);
goto DOUBLEFLOAT;
}
CASE_DOUBLE_FLOAT_SINGLE_FLOAT {
dx = ecl_double_float(x);
dy = ecl_single_float(y);
goto DOUBLEFLOAT;
}
CASE_DOUBLE_FLOAT_DOUBLE_FLOAT {
dx = ecl_double_float(x);
dy = ecl_double_float(y);
DOUBLEFLOAT:
if (dx == dy) return 0;
else return (dx < dy) ? -1 : 1;
}
#ifdef ECL_LONG_FLOAT
CASE_SINGLE_FLOAT_LONG_FLOAT {
ldx = ecl_single_float(x);
ldy = ecl_long_float(y);
goto LONGFLOAT;
#endif
default:
FEwrong_type_nth_arg(@[<], 2, y, @[real]);
}
DOUBLEFLOAT:
if (dx == dy)
return(0);
else if (dx < dy)
return(-1);
else
return(1);
#ifdef ECL_LONG_FLOAT
case t_longfloat:
ldx = ecl_long_float(x);
switch (ty) {
case t_fixnum:
return -long_double_fix_compare(ecl_fixnum(y), ldx);
case t_bignum:
case t_ratio:
x = cl_rational(x);
goto BEGIN;
case t_singlefloat:
CASE_LONG_FLOAT_SINGLE_FLOAT {
ldx = ecl_long_float(x);
ldy = ecl_single_float(y);
break;
case t_doublefloat:
ldy = ecl_double_float(y);
break;
case t_longfloat:
ldy = ecl_long_float(y);
break;
default:
FEwrong_type_nth_arg(@[<], 2, y, @[real]);
goto LONGFLOAT;
}
CASE_DOUBLE_FLOAT_LONG_FLOAT {
ldx = ecl_double_float(x);
ldy = ecl_long_float(y);
goto LONGFLOAT;
}
CASE_LONG_FLOAT_DOUBLE_FLOAT {
ldx = ecl_long_float(x);
ldy = ecl_double_float(y);
goto LONGFLOAT;
}
CASE_LONG_FLOAT_LONG_FLOAT {
ldx = ecl_long_float(x);
ldy = ecl_long_float(y);
LONGFLOAT:
if (ldx == ldy) return 0;
else return (ldx < ldy) ? -1 : 1;
}
LONGFLOAT:
if (ldx == ldy)
return 0;
else if (ldx < ldy)
return -1;
else
return 1;
break;
#endif
default:
FEwrong_type_nth_arg(@[<], 1, x, @[real]);
CASE_UNKNOWN(@[<],x,y,@[real]);
}
MATH_DISPATCH2_END;
}
static cl_object
@ -195,8 +158,16 @@ monotonic(int s, int t, int narg, ecl_va_list nums)
{
cl_object c, d;
if (narg == 0)
if (narg == 0) {
FEwrong_num_arguments_anonym();
}
if (narg == 1) {
c = ecl_va_arg(nums);
if (ECL_REAL_TYPE_P(ecl_t_of(c))) {
return1(ECL_T);
}
FEwrong_type_nth_arg(@[<], 1, c, @[real]);
}
/* INV: type check occurs in ecl_number_compare() */
for (c = ecl_va_arg(nums); --narg; c = d) {
d = ecl_va_arg(nums);
@ -212,8 +183,7 @@ monotonic(int s, int t, int narg, ecl_va_list nums)
ecl_va_end(nums); \
return result; }
cl_object @<= MONOTONIC( 1, 0)
cl_object @>= MONOTONIC(-1, 0)
cl_object @< MONOTONIC( 1, 1)
cl_object @> MONOTONIC(-1, 1)
cl_object @<= MONOTONIC( 1, 0);
cl_object @>= MONOTONIC(-1, 0);
cl_object @< MONOTONIC( 1, 1);
cl_object @> MONOTONIC(-1, 1);

11
src/c/numbers/number_equalp.d
View file

@ -20,11 +20,14 @@
@(defun = (num &rest nums)
int i;
@
/* ANSI: Need not signal error for 1 argument */
/* INV: For >= 2 arguments, ecl_number_equalp() performs checks */
for (i = 1; i < narg; i++)
if (!ecl_number_equalp(num, ecl_va_arg(nums))) {
@(return ECL_NIL);
if (!ECL_NUMBER_TYPE_P(ecl_t_of(num))) {
FEwrong_type_nth_arg(@[=], 1, num, @[number]);
}
for (i = 1; i < narg; i++) {
if (!ecl_number_equalp(num, ecl_va_arg(nums))) {
@(return ECL_NIL);
}
}
@(return ECL_T);
@)