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 = \ ...@@ -428,6 +428,38 @@ MPZ_SOURCES = \
mpz\urandomm.c \ mpz\urandomm.c \
mpz\xor.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 = \ GMP_SOURCES = \
assert.c \ assert.c \
compat.c \ compat.c \
...@@ -533,9 +565,10 @@ MPN_P3_OBJS = $(MPN_P3_ASM_SOURCES:.asm=.obj) $(MPN_P3_C_SOURCES:.c=.obj) ...@@ -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_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) # MPN_AMD64_OBJS = $(MPN_AMD64_ASM_SOURCES:.asm=.obj) $(MPN_AMD64_C_SOURCES:.c=.obj) #
MPZ_OBJS = $(MPZ_SOURCES:.c=.obj) MPZ_OBJS = $(MPZ_SOURCES:.c=.obj)
MPQ_OBJS = $(MPQ_SOURCES:.c=.obj)
GMP_OBJS = $(GMP_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 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) ...@@ -557,7 +590,7 @@ mpn_amd64.lib: msvc-build $(MPN_AMD64_OBJS)
link -lib /NOLOGO /OUT:$@ $(MPN_AMD64_OBJS) link -lib /NOLOGO /OUT:$@ $(MPN_AMD64_OBJS)
gmp.lib: mpn_$(MPN_TYPE).lib $(GMP_ALL_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 "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) 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 ...@@ -566,12 +599,16 @@ CFLAGS = $(CFLAGS_CONFIG) /nologo /W3 /EHsc /I "." /I $(srcdir) /I "$(srcdir)\mp
cl -c $(CFLAGS) /Fo$@ $? cl -c $(CFLAGS) /Fo$@ $?
{.\mpz}.c{.\mpz}.obj: {.\mpz}.c{.\mpz}.obj:
cl -c $(CFLAGS) /Fo$@ $? cl -c $(CFLAGS) /Fo$@ $?
{.\mpq}.c{.\mpq}.obj:
cl -c $(CFLAGS) /Fo$@ $?
{$(srcdir)\mpn\generic}.c{mpn\generic}.obj: {$(srcdir)\mpn\generic}.c{mpn\generic}.obj:
cl -c $(CFLAGS) /Fo$@ $? cl -c $(CFLAGS) /Fo$@ $?
{$(srcdir)\mpn}.c{mpn}.obj: {$(srcdir)\mpn}.c{mpn}.obj:
cl -c $(CFLAGS) /Fo$@ $? cl -c $(CFLAGS) /Fo$@ $?
{$(srcdir)\mpz}.c{mpz}.obj: {$(srcdir)\mpz}.c{mpz}.obj:
cl -c $(CFLAGS) /Fo$@ $? cl -c $(CFLAGS) /Fo$@ $?
{$(srcdir)\mpq}.c{mpq}.obj:
cl -c $(CFLAGS) /Fo$@ $?
{$(srcdir)}.c{}.obj: {$(srcdir)}.c{}.obj:
cl -c $(CFLAGS) /Fo$@ $? cl -c $(CFLAGS) /Fo$@ $?
...@@ -618,6 +655,7 @@ clean: ...@@ -618,6 +655,7 @@ clean:
-erase mpn\amd64i\*.obj -erase mpn\amd64i\*.obj
-erase mpn\*.obj -erase mpn\*.obj
-erase mpz\*.obj -erase mpz\*.obj
-erase mpq\*.obj
-erase *.obj -erase *.obj
-erase mpn_*.lib -erase mpn_*.lib
-erase gmp.lib -erase gmp.lib
......
dnl -*- autoconf -*- dnl -*- autoconf -*-
dnl -------------------------------------------------------------- dnl --------------------------------------------------------------
dnl check existence of long double and supporting functions dnl check existence of long double
AC_DEFUN([ECL_LONG_DOUBLE],[ AC_DEFUN([ECL_LONG_DOUBLE],[
if test "$enable_longdouble" != "no" ; then if test "$enable_longdouble" != "no" ; then
AC_CHECK_TYPES([long double],[enable_longdouble=yes],[enable_longdouble=no]) AC_CHECK_TYPES([long double],
if test "$enable_longdouble" != "no" ; then [enable_longdouble=yes, AC_DEFINE([ECL_LONG_FLOAT], [], [ECL_LONG_FLOAT])]
AC_CHECK_FUNCS([sinl cosl tanl logl expl powl ldexpl frexpl],[],[enable_longdouble=no; break]) [enable_longdouble=no])
if test "$enable_longdouble" != "no" ; then fi])
AC_DEFINE([ECL_LONG_FLOAT], [], [ECL_LONG_FLOAT])
fi dnl --------------------------------------------------------------
fi dnl check for existence of complex float
fi 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 --------------------------------------------------------------
dnl http://autoconf-archive.cryp.to/ac_c_long_long_.html dnl http://autoconf-archive.cryp.to/ac_c_long_long_.html
......
...@@ -828,9 +828,15 @@ init_alloc(void) ...@@ -828,9 +828,15 @@ init_alloc(void)
cl_core.safety_region = 0; cl_core.safety_region = 0;
} }
#define init_tm(x,y,z,w) { \ #define init_tm(/* cl_type */ type, \
type_info[x].size = (z); \ /* char* */ name, \
if ((w) == 0) { type_info[x].allocator = allocate_object_atomic; } } /* 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++) { for (i = 0; i < t_end; i++) {
type_info[i].t = i; type_info[i].t = i;
type_info[i].size = 0; type_info[i].size = 0;
......
...@@ -14,35 +14,23 @@ ...@@ -14,35 +14,23 @@
#include <ecl/ecl.h> #include <ecl/ecl.h>
#include <ecl/number.h> #include <ecl/number.h>
#include <stdlib.h> #include <stdlib.h>
#include <ecl/impl/math_dispatch2.h>
cl_object cl_object
ecl_integer_divide(cl_object x, cl_object y) ecl_integer_divide(cl_object x, cl_object y)
{ {
cl_type tx, ty; MATH_DISPATCH2_BEGIN(x,y) {
CASE_FIXNUM_FIXNUM;
tx = ecl_t_of(x); if (y == ecl_make_fixnum(0)) {
ty = ecl_t_of(y); FEdivision_by_zero(x,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]);
} }
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) @(defun gcd (&rest nums)
......
...@@ -28,8 +28,6 @@ ...@@ -28,8 +28,6 @@
@(return num); @(return num);
@) @)
#ifdef MATH_DISPATCH2_BEGIN
static cl_object static cl_object
complex_divide(cl_object ar, cl_object ai, cl_object br, cl_object bi) 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) ...@@ -174,152 +172,3 @@ ecl_divide(cl_object x, cl_object y)
} }
MATH_DISPATCH2_END; 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 @@ ...@@ -17,9 +17,11 @@
@(defun max (max &rest nums) @(defun max (max &rest nums)
@ @
/* INV: type check occurs in ecl_number_compare() for the rest of /* 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) { 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 { } else do {
cl_object numi = ecl_va_arg(nums); cl_object numi = ecl_va_arg(nums);
if (ecl_number_compare(max, numi) < 0) if (ecl_number_compare(max, numi) < 0)
...@@ -31,9 +33,11 @@ ...@@ -31,9 +33,11 @@
@(defun min (min &rest nums) @(defun min (min &rest nums)
@ @
/* INV: type check occurs in ecl_number_compare() for the rest of /* 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) { 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 { } else do {
cl_object numi = ecl_va_arg(nums); cl_object numi = ecl_va_arg(nums);
if (ecl_number_compare(min, numi) > 0) if (ecl_number_compare(min, numi) > 0)
......
...@@ -28,8 +28,6 @@ ...@@ -28,8 +28,6 @@
@(return diff); @(return diff);
@) @)
#ifdef MATH_DISPATCH2_BEGIN
cl_object cl_object
ecl_minus(cl_object x, cl_object y) ecl_minus(cl_object x, cl_object y)
{ {
...@@ -173,163 +171,3 @@ ecl_minus(cl_object x, cl_object y) ...@@ -173,163 +171,3 @@ ecl_minus(cl_object x, cl_object y)
} }
MATH_DISPATCH2_END; 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 @@ ...@@ -30,164 +30,127 @@
int int
ecl_number_compare(cl_object x, cl_object y) ecl_number_compare(cl_object x, cl_object y)
{ {
cl_fixnum ix, iy;
double dx, dy; double dx, dy;
#ifdef ECL_LONG_FLOAT #ifdef ECL_LONG_FLOAT
long double ldx, ldy; long double ldx, ldy;
#endif #endif
cl_type ty;
BEGIN: BEGIN:
ty = ecl_t_of(y); MATH_DISPATCH2_BEGIN(x,y) {
switch (ecl_t_of(x)) { /* rational x rational */
case t_fixnum: CASE_FIXNUM_FIXNUM {
ix = ecl_fixnum(x); cl_fixnum
switch (ty) { ix = ecl_fixnum(x),
case t_fixnum: iy = ecl_fixnum(y);
iy = ecl_fixnum(y); if (ix < iy) return -1;
if (ix < iy) else return (ix != iy);
return(-1); }
else return(ix != iy); /* INV: (= x y) can't be zero since fixnum != bignum */
case t_bignum: CASE_FIXNUM_BIGNUM { return _ecl_big_sign(y) < 0 ? 1 : -1; }
/* INV: (= x y) can't be zero since fixnum != bignum */ CASE_BIGNUM_FIXNUM { return _ecl_big_sign(x) < 0 ? -1 : 1; }
return _ecl_big_sign(y) < 0? 1 : -1; CASE_BIGNUM_BIGNUM { return _ecl_big_compare(x, y); }
case t_ratio: CASE_FIXNUM_RATIO;
x = ecl_times(x, y->ratio.den); CASE_BIGNUM_RATIO { return ecl_number_compare(ecl_times(x, y->ratio.den), y->ratio.num); }
y = y->ratio.num; CASE_RATIO_FIXNUM;
return(ecl_number_compare(x, y)); CASE_RATIO_BIGNUM { return ecl_number_compare(x->ratio.num, ecl_times(y, x->ratio.den)); }
case t_singlefloat: CASE_RATIO_RATIO { return ecl_number_compare(ecl_times(x->ratio.num, y->ratio.den),
return double_fix_compare(ix, ecl_single_float(y)); ecl_times(y->ratio.num, x->ratio.den)); }
case t_doublefloat: /* float x fixnum */
return double_fix_compare(ix, ecl_double_float(y)); 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 #ifdef ECL_LONG_FLOAT
case t_longfloat: CASE_LONG_FLOAT_FIXNUM { return -long_double_fix_compare(ecl_fixnum(y), ecl_long_float(x)); }
return long_double_fix_compare(ix, ecl_long_float(y)); CASE_FIXNUM_LONG_FLOAT { return long_double_fix_compare(ecl_fixnum(x), ecl_long_float(y)); }
#endif #endif
default: /* float x [bignum,ratio] */
FEwrong_type_nth_arg(@[<], 2, y, @[real]); CASE_SINGLE_FLOAT_BIGNUM;
} CASE_SINGLE_FLOAT_RATIO;
case t_bignum: CASE_DOUBLE_FLOAT_BIGNUM;
switch (ty) { CASE_DOUBLE_FLOAT_RATIO;
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:
#ifdef ECL_LONG_FLOAT #ifdef ECL_LONG_FLOAT
case t_longfloat: CASE_LONG_FLOAT_BIGNUM;
CASE_LONG_FLOAT_RATIO;
#endif #endif
{
#ifdef ECL_IEEE_FP #ifdef ECL_IEEE_FP
if (ecl_float_infinity_p(y)) if (ecl_float_infinity_p(x))
return(ecl_number_compare(ecl_make_fixnum(0), y)); return ecl_number_compare(x, ecl_make_fixnum(0));
#endif #endif
y = cl_rational(y); x = cl_rational(x);
goto BEGIN;