diff --git a/src/c/Makefile.in b/src/c/Makefile.in index b42bc7a6f..3857160b4 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -50,7 +50,7 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h -BOOT_OBJS = boot.o escape.o +BOOT_OBJS = boot.o escape.o eql.o CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o diff --git a/src/c/eql.d b/src/c/eql.d new file mode 100644 index 000000000..1fd7748b5 --- /dev/null +++ b/src/c/eql.d @@ -0,0 +1,99 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* aux.c - early routines */ + +/* -- imports --------------------------------------------------------------- */ + +#include +#include +#include +#include + +#include + +/* + * EQL-comparison of floats. If we are using signed zeros and NaNs, + * numeric comparison of floating points is not equivalent to bit-wise + * equality. In particular every two NaNs always give false + * (= #1=(/ 0.0 0.0) #1#) => NIL + * and signed zeros always compare equal + * (= 0 -0.0) => T + * which is not the same as what EQL should return + * (EQL #1=(/ 0.0 0.0) #1#) => T + * (EQL 0 -0.0) => NIL + * + * Furthermore, we can not use bit comparisons because in some platforms + * long double has unused bits that makes two long floats be = but not eql. + */ +#if !defined(ECL_SIGNED_ZERO) && !defined(ECL_IEEE_FP) +#define FLOAT_EQL(name, type) \ + static bool name(type a, type b) { return a == b; } +#else +#define FLOAT_EQL(name, type) \ + static bool name(type a, type b) { \ + if (a == b) return signbit(a) == signbit(b); \ + if (isnan(a) || isnan(b)) return isnan(a) && isnan(b); \ + return 0; \ + } +#endif + +FLOAT_EQL(float_eql, float); +FLOAT_EQL(double_eql, double); +FLOAT_EQL(long_double_eql, long double); +#undef FLOAT_EQL + +/* To avoid linking GMP in nucleus we directly compare limbs. */ +static bool +_bignum_eql(cl_object x, cl_object y) +{ + cl_fixnum size; + size = ECL_BIGNUM_SIZE(x); + if(size != ECL_BIGNUM_SIZE(y)) return 0; + return !memcmp(ECL_BIGNUM_LIMBS(x), ECL_BIGNUM_LIMBS(y), + ((size>0) ? size : -size) * (ECL_BIGNUM_LIMB_BITS/8)); +} + +bool +ecl_eql(cl_object x, cl_object y) +{ + if (x == y) + return TRUE; + if (ECL_IMMEDIATE(x) || ECL_IMMEDIATE(y)) + return FALSE; + if (x->d.t != y->d.t) + return FALSE; + switch (x->d.t) { + case t_bignum: + return _bignum_eql(x, y); + case t_ratio: + return (ecl_eql(x->ratio.num, y->ratio.num) && + ecl_eql(x->ratio.den, y->ratio.den)); + case t_singlefloat: + return float_eql(ecl_single_float(x), ecl_single_float(y)); + case t_longfloat: + return long_double_eql(ecl_long_float(x), ecl_long_float(y)); + case t_doublefloat: + return double_eql(ecl_double_float(x), ecl_double_float(y)); + case t_complex: + return (ecl_eql(x->gencomplex.real, y->gencomplex.real) && + ecl_eql(x->gencomplex.imag, y->gencomplex.imag)); +#ifdef ECL_COMPLEX_FLOAT + case t_csfloat: + return (float_eql(crealf(ecl_csfloat(x)), crealf(ecl_csfloat(y))) && + float_eql(cimagf(ecl_csfloat(x)), cimagf(ecl_csfloat(y)))); + case t_cdfloat: + return (double_eql(creal(ecl_cdfloat(x)), creal(ecl_cdfloat(y))) && + double_eql(cimag(ecl_cdfloat(x)), cimag(ecl_cdfloat(y)))); + case t_clfloat: + return (long_double_eql(creall(ecl_clfloat(x)), creall(ecl_clfloat(y))) && + long_double_eql(cimagl(ecl_clfloat(x)), cimagl(ecl_clfloat(y)))); +#endif +#ifdef ECL_SSE2 + case t_sse_pack: + return !memcmp(x->sse.data.b8, y->sse.data.b8, 16); +#endif + default: + return FALSE; + } +} diff --git a/src/c/predicate.d b/src/c/predicate.d index bb71b225c..3e27b91d7 100644 --- a/src/c/predicate.d +++ b/src/c/predicate.d @@ -237,81 +237,6 @@ cl_eq(cl_object x, cl_object y) @(return ((x == y) ? ECL_T : ECL_NIL)); } -/* - * EQL-comparison of floats. If we are using signed zeros and NaNs, - * numeric comparison of floating points is not equivalent to bit-wise - * equality. In particular every two NaNs always give false - * (= #1=(/ 0.0 0.0) #1#) => NIL - * and signed zeros always compare equal - * (= 0 -0.0) => T - * which is not the same as what EQL should return - * (EQL #1=(/ 0.0 0.0) #1#) => T - * (EQL 0 -0.0) => NIL - * - * Furthermore, we can not use bit comparisons because in some platforms - * long double has unused bits that makes two long floats be = but not eql. - */ -#if !defined(ECL_SIGNED_ZERO) && !defined(ECL_IEEE_FP) -#define FLOAT_EQL(name, type) \ - static bool name(type a, type b) { return a == b; } -#else -#define FLOAT_EQL(name, type) \ - static bool name(type a, type b) { \ - if (a == b) return signbit(a) == signbit(b); \ - if (isnan(a) || isnan(b)) return isnan(a) && isnan(b); \ - return 0; \ - } -#endif - -FLOAT_EQL(float_eql, float); -FLOAT_EQL(double_eql, double); -FLOAT_EQL(long_double_eql, long double); -#undef FLOAT_EQL - -bool -ecl_eql(cl_object x, cl_object y) -{ - if (x == y) - return TRUE; - if (ECL_IMMEDIATE(x) || ECL_IMMEDIATE(y)) - return FALSE; - if (x->d.t != y->d.t) - return FALSE; - switch (x->d.t) { - case t_bignum: - return (_ecl_big_compare(x, y) == 0); - case t_ratio: - return (ecl_eql(x->ratio.num, y->ratio.num) && - ecl_eql(x->ratio.den, y->ratio.den)); - case t_singlefloat: - return float_eql(ecl_single_float(x), ecl_single_float(y)); - case t_longfloat: - return long_double_eql(ecl_long_float(x), ecl_long_float(y)); - case t_doublefloat: - return double_eql(ecl_double_float(x), ecl_double_float(y)); - case t_complex: - return (ecl_eql(x->gencomplex.real, y->gencomplex.real) && - ecl_eql(x->gencomplex.imag, y->gencomplex.imag)); -#ifdef ECL_COMPLEX_FLOAT - case t_csfloat: - return (float_eql(crealf(ecl_csfloat(x)), crealf(ecl_csfloat(y))) && - float_eql(cimagf(ecl_csfloat(x)), cimagf(ecl_csfloat(y)))); - case t_cdfloat: - return (double_eql(creal(ecl_cdfloat(x)), creal(ecl_cdfloat(y))) && - double_eql(cimag(ecl_cdfloat(x)), cimag(ecl_cdfloat(y)))); - case t_clfloat: - return (long_double_eql(creall(ecl_clfloat(x)), creall(ecl_clfloat(y))) && - long_double_eql(cimagl(ecl_clfloat(x)), cimagl(ecl_clfloat(y)))); -#endif -#ifdef ECL_SSE2 - case t_sse_pack: - return !memcmp(x->sse.data.b8, y->sse.data.b8, 16); -#endif - default: - return FALSE; - } -} - cl_object cl_eql(cl_object x, cl_object y) { @@ -344,39 +269,17 @@ ecl_equal(cl_object x, cl_object y) case t_fixnum: return FALSE; case t_bignum: - return (tx == ty) && (_ecl_big_compare(x,y) == 0); case t_ratio: - return (tx == ty) && ecl_eql(x->ratio.num, y->ratio.num) && - ecl_eql(x->ratio.den, y->ratio.den); - case t_singlefloat: { - if (tx != ty) return 0; - return float_eql(ecl_single_float(x), ecl_single_float(y)); - } - case t_doublefloat: { - if (tx != ty) return 0; - return double_eql(ecl_double_float(x), ecl_double_float(y)); - } - case t_longfloat: { - if (tx != ty) return 0; - return long_double_eql(ecl_long_float(x), ecl_long_float(y)); - } + case t_singlefloat: + case t_doublefloat: + case t_longfloat: case t_complex: - return (tx == ty) && ecl_eql(x->gencomplex.real, y->gencomplex.real) && - ecl_eql(x->gencomplex.imag, y->gencomplex.imag); #ifdef ECL_COMPLEX_FLOAT case t_csfloat: - if (tx != ty) return 0; - return (float_eql(crealf(ecl_csfloat(x)), crealf(ecl_csfloat(y))) && - float_eql(cimagf(ecl_csfloat(x)), cimagf(ecl_csfloat(y)))); case t_cdfloat: - if (tx != ty) return 0; - return (double_eql(creal(ecl_cdfloat(x)), creal(ecl_cdfloat(y))) && - double_eql(cimag(ecl_cdfloat(x)), cimag(ecl_cdfloat(y)))); case t_clfloat: - if (tx != ty) return 0; - return (long_double_eql(creall(ecl_clfloat(x)), creall(ecl_clfloat(y))) && - long_double_eql(cimagl(ecl_clfloat(x)), cimagl(ecl_clfloat(y)))); #endif + return ecl_eql(x, y); case t_character: return (tx == ty) && (ECL_CHAR_CODE(x) == ECL_CHAR_CODE(y)); case t_base_string: