Commit a7c68205 authored by Marius Gerbershagen's avatar Marius Gerbershagen

Merge branch 'clean-math-3' into 'develop'

Clean math 3 (without float conversion changes)

Closes #486 und #497

See merge request !147
parents 299f9fb1 0fcf21b4
Pipeline #59811770 passed with stage
......@@ -428,6 +428,38 @@ MPZ_SOURCES = \
mpz\urandomm.c \
mpz\xor.c
MPQ_SOURCES = \
mpq\abs.c \
mpq\aors.c \
mpq\canonicalize.c \
mpq\clear.c \
mpq\cmp.c \
mpq\cmp_si.c \
mpq\cmp_ui.c \
mpq\div.c \
mpq\equal.c \
mpq\get_d.c \
mpq\get_den.c \
mpq\get_num.c \
mpq\get_str.c \
mpq\init.c \
mpq\inp_str.c \
mpq\inv.c \
mpq\md_2exp.c \
mpq\mul.c \
mpq\neg.c \
mpq\out_str.c \
mpq\set.c \
mpq\set_d.c \
mpq\set_den.c \
mpq\set_f.c \
mpq\set_num.c \
mpq\set_si.c \
mpq\set_str.c \
mpq\set_ui.c \
mpq\set_z.c \
mpq\swap.c
GMP_SOURCES = \
assert.c \
compat.c \
......@@ -533,9 +565,10 @@ MPN_P3_OBJS = $(MPN_P3_ASM_SOURCES:.asm=.obj) $(MPN_P3_C_SOURCES:.c=.obj)
MPN_P4_OBJS = $(MPN_P4_ASM_SOURCES:.asm=.obj) $(MPN_P4_C_SOURCES:.c=.obj)
MPN_AMD64_OBJS = $(MPN_AMD64_ASM_SOURCES:.asm=.obj) $(MPN_AMD64_C_SOURCES:.c=.obj) #
MPZ_OBJS = $(MPZ_SOURCES:.c=.obj)
MPQ_OBJS = $(MPQ_SOURCES:.c=.obj)
GMP_OBJS = $(GMP_SOURCES:.c=.obj)
GMP_ALL_OBJS = $(MPZ_OBJS) $(GMP_OBJS)
GMP_ALL_OBJS = $(MPZ_OBJS) $(MPQ_OBJS) $(GMP_OBJS)
AUTO_FILES = mp_bases.h mp_bases.c fac_ui.h fib_table.h fib_table.c perfsqr.h
......@@ -557,7 +590,7 @@ mpn_amd64.lib: msvc-build $(MPN_AMD64_OBJS)
link -lib /NOLOGO /OUT:$@ $(MPN_AMD64_OBJS)
gmp.lib: mpn_$(MPN_TYPE).lib $(GMP_ALL_OBJS)
link -lib /NOLOGO /OUT:$@ *.obj mpz\*.obj mpn_$(MPN_TYPE).lib
link -lib /NOLOGO /OUT:$@ *.obj mpz\*.obj mpq\*.obj mpn_$(MPN_TYPE).lib
#CFLAGS = $(CFLAGS_CONFIG) /nologo /W3 /EHsc /I "." /I $(srcdir) /I "$(srcdir)\mpn\generic" /D "WIN32" /D "_LIB" /D "_WIN32" /D "_MBCS"
CFLAGS = $(CFLAGS_CONFIG) /nologo /W3 /EHsc /I "." /I $(srcdir) /I "$(srcdir)\mpn\generic" /D "_LIB" /D "_MBCS" $(D_WIN64)
......@@ -566,12 +599,16 @@ CFLAGS = $(CFLAGS_CONFIG) /nologo /W3 /EHsc /I "." /I $(srcdir) /I "$(srcdir)\mp
cl -c $(CFLAGS) /Fo$@ $?
{.\mpz}.c{.\mpz}.obj:
cl -c $(CFLAGS) /Fo$@ $?
{.\mpq}.c{.\mpq}.obj:
cl -c $(CFLAGS) /Fo$@ $?
{$(srcdir)\mpn\generic}.c{mpn\generic}.obj:
cl -c $(CFLAGS) /Fo$@ $?
{$(srcdir)\mpn}.c{mpn}.obj:
cl -c $(CFLAGS) /Fo$@ $?
{$(srcdir)\mpz}.c{mpz}.obj:
cl -c $(CFLAGS) /Fo$@ $?
{$(srcdir)\mpq}.c{mpq}.obj:
cl -c $(CFLAGS) /Fo$@ $?
{$(srcdir)}.c{}.obj:
cl -c $(CFLAGS) /Fo$@ $?
......@@ -618,6 +655,7 @@ clean:
-erase mpn\amd64i\*.obj
-erase mpn\*.obj
-erase mpz\*.obj
-erase mpq\*.obj
-erase *.obj
-erase mpn_*.lib
-erase gmp.lib
......
dnl -*- autoconf -*-
dnl --------------------------------------------------------------
dnl check existence of long double and supporting functions
dnl check existence of long double
AC_DEFUN([ECL_LONG_DOUBLE],[
if test "$enable_longdouble" != "no" ; then
AC_CHECK_TYPES([long double],[enable_longdouble=yes],[enable_longdouble=no])
if test "$enable_longdouble" != "no" ; then
AC_CHECK_FUNCS([sinl cosl tanl logl expl powl ldexpl frexpl],[],[enable_longdouble=no; break])
if test "$enable_longdouble" != "no" ; then
AC_DEFINE([ECL_LONG_FLOAT], [], [ECL_LONG_FLOAT])
fi
fi
fi
])
if test "$enable_longdouble" != "no" ; then
AC_CHECK_TYPES([long double],
[enable_longdouble=yes, AC_DEFINE([ECL_LONG_FLOAT], [], [ECL_LONG_FLOAT])]
[enable_longdouble=no])
fi])
dnl --------------------------------------------------------------
dnl check for existence of complex float
AC_DEFUN([ECL_COMPLEX_C99],[
if test "$enable_c99complex" != "no" ; then
AC_CHECK_TYPES([float complex, double complex, long complex],
[enable_c99complex=yes, AC_DEFINE([ECL_COMPLEX_FLOAT], [], [ECL_COMPLEX_FLOAT])],
[enable_c99complex=no],
[#include <complex.h>])
fi])
dnl --------------------------------------------------------------
dnl http://autoconf-archive.cryp.to/ac_c_long_long_.html
......
......@@ -828,9 +828,15 @@ init_alloc(void)
cl_core.safety_region = 0;
}
#define init_tm(x,y,z,w) { \
type_info[x].size = (z); \
if ((w) == 0) { type_info[x].allocator = allocate_object_atomic; } }
#define init_tm(/* cl_type */ type, \
/* char* */ name, \
/* cl_index */ object_size, \
/* cl_index */ maxpage) { \
type_info[type].size = (object_size); \
if ((maxpage) == 0) { \
type_info[type].allocator = allocate_object_atomic; \
} \
}
for (i = 0; i < t_end; i++) {
type_info[i].t = i;
type_info[i].size = 0;
......
......@@ -14,35 +14,23 @@
#include <ecl/ecl.h>
#include <ecl/number.h>
#include <stdlib.h>
#include <ecl/impl/math_dispatch2.h>
cl_object
ecl_integer_divide(cl_object x, cl_object y)
{
cl_type tx, ty;
tx = ecl_t_of(x);
ty = ecl_t_of(y);
if (tx == t_fixnum) {
if (ty == t_fixnum) {
if (y == ecl_make_fixnum(0))
FEdivision_by_zero(x, y);
return ecl_make_fixnum(ecl_fixnum(x) / ecl_fixnum(y));
} else if (ty == t_bignum) {
return _ecl_fix_divided_by_big(ecl_fixnum(x), y);
} else {
FEwrong_type_nth_arg(@[round], 2, y, @[integer]);
}
}
if (tx == t_bignum) {
if (ty == t_bignum) {
return _ecl_big_divided_by_big(x, y);
} else if (ty == t_fixnum) {
return _ecl_big_divided_by_fix(x, ecl_fixnum(y));
} else {
FEwrong_type_nth_arg(@[round], 2, y, @[integer]);
MATH_DISPATCH2_BEGIN(x,y) {
CASE_FIXNUM_FIXNUM;
if (y == ecl_make_fixnum(0)) {
FEdivision_by_zero(x,y);
}
return ecl_make_fixnum(ecl_fixnum(x) / ecl_fixnum(y));
CASE_FIXNUM_BIGNUM return _ecl_fix_divided_by_big(ecl_fixnum(x), y);
CASE_BIGNUM_FIXNUM return _ecl_big_divided_by_fix(x, ecl_fixnum(y));
CASE_BIGNUM_BIGNUM return _ecl_big_divided_by_big(x, y);
CASE_UNKNOWN(@[round],x,y,@[integer]);
}
FEwrong_type_nth_arg(@[round], 1, x, @[integer]);
MATH_DISPATCH2_END;
}
@(defun gcd (&rest nums)
......
......@@ -28,8 +28,6 @@
@(return num);
@)
#ifdef MATH_DISPATCH2_BEGIN
static cl_object
complex_divide(cl_object ar, cl_object ai, cl_object br, cl_object bi)
{
......@@ -174,152 +172,3 @@ ecl_divide(cl_object x, cl_object y)
}
MATH_DISPATCH2_END;
}
#else
cl_object
ecl_divide(cl_object x, cl_object y)
{
cl_object z, z1, z2;
switch (ecl_t_of(x)) {
case t_fixnum:
case t_bignum:
switch (ecl_t_of(y)) {
case t_fixnum:
if (y == ecl_make_fixnum(0))
FEdivision_by_zero(x, y);
case t_bignum:
if (ecl_minusp(y) == TRUE) {
x = ecl_negate(x);
y = ecl_negate(y);
}
return ecl_make_ratio(x, y);
case t_ratio:
z = ecl_times(x, y->ratio.den);
return ecl_make_ratio(z, y->ratio.num);
case t_singlefloat:
return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y));
case t_doublefloat:
return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[/], 2, y, @[number]);
}
case t_ratio:
switch (ecl_t_of(y)) {
case t_fixnum:
if (y == ecl_make_fixnum(0))
FEdivision_by_zero(x, y);
case t_bignum:
z = ecl_times(x->ratio.den, y);
return ecl_make_ratio(x->ratio.num, z);
case t_ratio:
z = ecl_times(x->ratio.num,y->ratio.den);
z1 = ecl_times(x->ratio.den,y->ratio.num);
return ecl_make_ratio(z, z1);
case t_singlefloat:
return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y));
case t_doublefloat:
return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[/], 2, y, @[number]);
}
case t_singlefloat:
switch (ecl_t_of(y)) {
case t_fixnum:
return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y));
case t_bignum:
case t_ratio:
return ecl_make_single_float(ecl_single_float(x) / ecl_to_double(y));
case t_singlefloat:
return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y));
case t_doublefloat:
return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[/], 2, y, @[number]);
}
case t_doublefloat:
switch (ecl_t_of(y)) {
case t_fixnum:
return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y));
case t_bignum:
case t_ratio:
return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y));
case t_singlefloat:
return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y));
case t_doublefloat:
return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[/], 2, y, @[number]);
}
#ifdef ECL_LONG_FLOAT
case t_longfloat:
switch (ecl_t_of(y)) {
case t_fixnum:
return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y));
case t_bignum:
case t_ratio:
return ecl_make_long_float(ecl_long_float(x) / ecl_to_double(y));
case t_singlefloat:
return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y));
case t_doublefloat:
return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y));
case t_longfloat:
return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y));
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[/], 2, y, @[number]);
}
#endif
case t_complex:
if (ecl_t_of(y) != t_complex) {
z1 = ecl_divide(x->complex.real, y);
z2 = ecl_divide(x->complex.imag, y);
return ecl_make_complex(z1, z2);
} else if (1) {
/* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */
z1 = ecl_plus(ecl_times(x->complex.real, y->complex.real),
ecl_times(x->complex.imag, y->complex.imag));
z2 = ecl_minus(ecl_times(x->complex.imag, y->complex.real),
ecl_times(x->complex.real, y->complex.imag));
} else {
COMPLEX: /* INV: x is real, y is complex */
/* #C(z1 z2) = x * #C(yr -yi) */
z1 = ecl_times(x, y->complex.real);
z2 = ecl_negate(ecl_times(x, y->complex.imag));
}
z = ecl_plus(ecl_times(y->complex.real, y->complex.real),
ecl_times(y->complex.imag, y->complex.imag));
z = ecl_make_complex(ecl_divide(z1, z), ecl_divide(z2, z));
return(z);
default:
FEwrong_type_nth_arg(@[/], 1, x, @[number]);
}
}
#endif
......@@ -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)
......
......@@ -28,8 +28,6 @@
@(return diff);
@)
#ifdef MATH_DISPATCH2_BEGIN
cl_object
ecl_minus(cl_object x, cl_object y)
{
......@@ -173,163 +171,3 @@ ecl_minus(cl_object x, cl_object y)
}
MATH_DISPATCH2_END;
}
#else
cl_object
ecl_minus(cl_object x, cl_object y)
{
cl_fixnum i, j, k;
cl_object z, z1;
switch (ecl_t_of(x)) {
case t_fixnum:
switch(ecl_t_of(y)) {
case t_fixnum:
return ecl_make_integer(ecl_fixnum(x) - ecl_fixnum(y));
case t_bignum:
return _ecl_fix_minus_big(ecl_fixnum(x), y);
case t_ratio:
z = ecl_times(x, y->ratio.den);
z = ecl_minus(z, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
case t_singlefloat:
return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y));
case t_doublefloat:
return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[-], 2, y, @[number]);
}
case t_bignum:
switch (ecl_t_of(y)) {
case t_fixnum:
return _ecl_big_plus_fix(x, -ecl_fixnum(y));
case t_bignum:
return _ecl_big_minus_big(x, y);
case t_ratio:
z = ecl_times(x, y->ratio.den);
z = ecl_minus(z, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
case t_singlefloat:
return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y));
case t_doublefloat:
return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[-], 2, y, @[number]);
}
case t_ratio:
switch (ecl_t_of(y)) {
case t_fixnum:
case t_bignum:
z = ecl_times(x->ratio.den, y);
z = ecl_minus(x->ratio.num, z);
return ecl_make_ratio(z, x->ratio.den);
case t_ratio:
z = ecl_times(x->ratio.num,y->ratio.den);
z1 = ecl_times(x->ratio.den,y->ratio.num);
z = ecl_minus(z, z1);
z1 = ecl_times(x->ratio.den,y->ratio.den);
return ecl_make_ratio(z, z1);
case t_singlefloat:
return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y));
case t_doublefloat:
return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[-], 2, y, @[number]);
}
case t_singlefloat:
switch (ecl_t_of(y)) {
case t_fixnum:
return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y));
case t_bignum:
case t_ratio:
return ecl_make_single_float(ecl_single_float(x) - ecl_to_double(y));
case t_singlefloat:
return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y));
case t_doublefloat:
return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[-], 2, y, @[number]);
}
case t_doublefloat:
switch (ecl_t_of(y)) {
case t_fixnum:
return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y));
case t_bignum:
case t_ratio:
return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y));
case t_singlefloat:
return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y));
case t_doublefloat:
return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[-], 2, y, @[number]);
}
#ifdef ECL_LONG_FLOAT
case t_longfloat:
switch (ecl_t_of(y)) {
case t_fixnum:
return ecl_make_long_float(ecl_long_float(x) - fix(y));
case t_bignum:
case t_ratio:
return ecl_make_long_float(ecl_long_float(x) - ecl_to_double(y));
case t_singlefloat:
return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y));
case t_doublefloat:
return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y));
case t_longfloat:
return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y));
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[-], 2, y, @[number]);
}
#endif
COMPLEX:
return ecl_make_complex(ecl_minus(x, y->complex.real),
ecl_negate(y->complex.imag));
case t_complex:
if (ecl_t_of(y) != t_complex) {
z = ecl_minus(x->complex.real, y);
z1 = x->complex.imag;
} else {
z = ecl_minus(x->complex.real, y->complex.real);
z1 = ecl_minus(x->complex.imag, y->complex.imag);
}
return ecl_make_complex(z, z1);
default:
FEwrong_type_nth_arg(@[-], 1, x, @[number]);
}
}
#endif
......@@ -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));
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);
}
/* 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:
return long_double_fix_compare(ix, ecl_long_float(y));
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
default:
FEwrong_type_nth_arg(@[<], 2, y, @[real]);
}
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:
/* 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));
if (ecl_float_infinity_p(x))
return ecl_number_compare(x, ecl_make_fixnum(0));
#endif
y = cl_rational(y);
x = cl_rational(x);
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:
CASE_BIGNUM_SINGLE_FLOAT;
CASE_RATIO_SINGLE_FLOAT;
CASE_BIGNUM_DOUBLE_FLOAT;
CASE_RATIO_DOUBLE_FLOAT;
#ifdef ECL_LONG_FLOAT
case t_longfloat:
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));
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)));
#endif
x = cl_rational(x);
goto BEGIN;
case t_singlefloat:
dy = (double)(ecl_single_float(y));
break;
case t_doublefloat:
/* 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);