mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-15 09:20:23 -07:00
Code Issues Projects Releases Packages Wiki Activity

Split +,-,*,/ into separate files with a slightly more compact dispatch

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2010-11-04 23:40:11 +01:00
parent 70a045f667
commit 729baa8935
8 changed files with 1175 additions and 665 deletions
Download patch file Download diff file Expand all files Collapse all files

4
msvc/c/Makefile
View file

@ -80,6 +80,10 @@ OBJS = main.obj symbol.obj package.obj list.obj\
numbers/cosh.o numbers/sinh.o numbers/tanh.o \
numbers/exp.o numbers/expt.o numbers/log.o \
numbers/sqrt.o numbers/abs.o \
numbers/zerop.o numbers/plusp.o numbers/minusp.o \
numbers/negate.o numbers/conjugate.o \
numbers/one_plus.o numbers/one_minus.o \
numbers/plus.o numbers/minus.o numbers/times.o numbers/divide.o \
predicate.obj big.obj number.obj\
num_pred.obj num_comp.obj num_arith.obj num_sfun.obj num_co.obj\
num_log.obj num_rand.obj array.obj sequence.obj cmpaux.obj\

1
src/c/Makefile.in
View file

@ -56,6 +56,7 @@ OBJS = main.o symbol.o package.o list.o\
numbers/zerop.o numbers/plusp.o numbers/minusp.o \
numbers/negate.o numbers/conjugate.o \
numbers/one_plus.o numbers/one_minus.o \
numbers/plus.o numbers/minus.o numbers/times.o numbers/divide.o \
typespec.o assignment.o \
predicate.o number.o\
num_pred.o num_comp.o num_arith.o num_co.o\

665
src/c/num_arith.d
View file

@ -18,671 +18,6 @@
#include <ecl/number.h>
#include <stdlib.h>
#pragma fenv_access on
/* (* ) */
@(defun * (&rest nums)
cl_object prod = MAKE_FIXNUM(1);
@
/* INV: type check in ecl_times() */
while (narg--)
prod = ecl_times(prod, cl_va_arg(nums));
@(return prod)
@)
cl_object
ecl_times(cl_object x, cl_object y)
{
cl_object z, z1;
switch (type_of(x)) {
case t_fixnum:
switch (type_of(y)) {
case t_fixnum:
return _ecl_fix_times_fix(fix(x),fix(y));
case t_bignum:
return _ecl_big_times_fix(y, fix(x));
case t_ratio:
z = ecl_times(x, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
case t_singlefloat:
return ecl_make_singlefloat(fix(x) * sf(y));
case t_doublefloat:
return ecl_make_doublefloat(fix(x) * df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(fix(x) * ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[*], 2, y, @[number]);
}
case t_bignum:
switch (type_of(y)) {
case t_fixnum:
return _ecl_big_times_fix(x, fix(y));
case t_bignum:
return _ecl_big_times_big(x, y);
case t_ratio:
z = ecl_times(x, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
case t_singlefloat:
return ecl_make_singlefloat(ecl_to_double(x) * sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) * df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
case t_bignum:
z = ecl_times(x->ratio.num, y);
return ecl_make_ratio(z, x->ratio.den);
case t_ratio:
z = ecl_times(x->ratio.num,y->ratio.num);
z1 = ecl_times(x->ratio.den,y->ratio.den);
return ecl_make_ratio(z, z1);
case t_singlefloat:
return ecl_make_singlefloat(ecl_to_double(x) * sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) * df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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: {
float fx = sf(x);
switch (type_of(y)) {
case t_fixnum:
return ecl_make_singlefloat(fx * fix(y));
case t_bignum:
case t_ratio:
return ecl_make_singlefloat(fx * ecl_to_double(y));
case t_singlefloat:
return ecl_make_singlefloat(fx * sf(y));
case t_doublefloat:
return ecl_make_doublefloat(fx * df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(fx * ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[*], 2, y, @[number]);
}
}
case t_doublefloat: {
switch (type_of(y)) {
case t_fixnum:
return ecl_make_doublefloat(df(x) * fix(y));
case t_bignum:
case t_ratio:
return ecl_make_doublefloat(df(x) * ecl_to_double(y));
case t_singlefloat:
return ecl_make_doublefloat(df(x) * sf(y));
case t_doublefloat:
return ecl_make_doublefloat(df(x) * df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(df(x) * ecl_long_float(y));
#endif
case t_complex: {
COMPLEX: /* INV: x is real, y is complex */
return ecl_make_complex(ecl_times(x, y->complex.real),
ecl_times(x, y->complex.imag));
}
default:
FEwrong_type_nth_arg(@[*], 2, y, @[number]);
}
}
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
long double lx = ecl_long_float(x);
switch (type_of(y)) {
case t_fixnum:
return ecl_make_longfloat(lx * fix(y));
case t_bignum:
case t_ratio:
return ecl_make_longfloat(lx * ecl_to_double(y));
case t_singlefloat:
return ecl_make_longfloat(lx * sf(y));
case t_doublefloat:
return ecl_make_longfloat(lx * df(y));
case t_longfloat:
return ecl_make_longfloat(lx * ecl_long_float(y));
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[*], 2, y, @[number]);
}
}
#endif
case t_complex:
{
cl_object z11, z12, z21, z22;
if (type_of(y) != t_complex) {
cl_object aux = x;
x = y; y = aux;
goto COMPLEX;
}
z11 = ecl_times(x->complex.real, y->complex.real);
z12 = ecl_times(x->complex.imag, y->complex.imag);
z21 = ecl_times(x->complex.imag, y->complex.real);
z22 = ecl_times(x->complex.real, y->complex.imag);
return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22));
}
default:
FEwrong_type_nth_arg(@[*], 1, x, @[number]);
}
}
/* (+ ) */
@(defun + (&rest nums)
cl_object sum = MAKE_FIXNUM(0);
@
/* INV: type check is in ecl_plus() */
while (narg--)
sum = ecl_plus(sum, cl_va_arg(nums));
@(return sum)
@)
cl_object
ecl_plus(cl_object x, cl_object y)
{
cl_fixnum i, j;
cl_object z, z1;
switch (type_of(x)) {
case t_fixnum:
switch (type_of(y)) {
case t_fixnum:
return ecl_make_integer(fix(x) + fix(y));
case t_bignum:
return _ecl_big_plus_fix(y, fix(x));
case t_ratio:
z = ecl_times(x, y->ratio.den);
z = ecl_plus(z, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
case t_singlefloat:
return ecl_make_singlefloat(fix(x) + sf(y));
case t_doublefloat:
return ecl_make_doublefloat(fix(x) + df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(fix(x) + ecl_long_float(y));
#endif
case t_complex:
COMPLEX: /* INV: x is real, y is complex */
return ecl_make_complex(ecl_plus(x, y->complex.real),
y->complex.imag);
default:
FEwrong_type_nth_arg(@[+], 2, y, @[number]);
}
case t_bignum:
switch (type_of(y)) {
case t_fixnum:
return _ecl_big_plus_fix(x, fix(y));
case t_bignum:
return _ecl_big_plus_big(x, y);
case t_ratio:
z = ecl_times(x, y->ratio.den);
z = ecl_plus(z, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
case t_singlefloat:
return ecl_make_singlefloat(ecl_to_double(x) + sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) + df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
case t_bignum:
z = ecl_times(x->ratio.den, y);
z = ecl_plus(x->ratio.num, z);
return ecl_make_ratio(z, x->ratio.den);
case t_ratio:
z1 = ecl_times(x->ratio.num,y->ratio.den);
z = ecl_times(x->ratio.den,y->ratio.num);
z = ecl_plus(z1, z);
z1 = ecl_times(x->ratio.den,y->ratio.den);
return ecl_make_ratio(z, z1);
case t_singlefloat:
return ecl_make_singlefloat(ecl_to_double(x) + sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) + df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
return ecl_make_singlefloat(sf(x) + fix(y));
case t_bignum:
case t_ratio:
return ecl_make_singlefloat(sf(x) + ecl_to_double(y));
case t_singlefloat:
return ecl_make_singlefloat(sf(x) + sf(y));
case t_doublefloat:
return ecl_make_doublefloat(sf(x) + df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(sf(x) + ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[+], 2, y, @[number]);
}
case t_doublefloat:
switch (type_of(y)) {
case t_fixnum:
return ecl_make_doublefloat(df(x) + fix(y));
case t_bignum:
case t_ratio:
return ecl_make_doublefloat(df(x) + ecl_to_double(y));
case t_singlefloat:
return ecl_make_doublefloat(df(x) + sf(y));
case t_doublefloat:
return ecl_make_doublefloat(df(x) + df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(df(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 (type_of(y)) {
case t_fixnum:
return ecl_make_longfloat(ecl_long_float(x) + fix(y));
case t_bignum:
case t_ratio:
return ecl_make_longfloat(ecl_long_float(x) + ecl_to_double(y));
case t_singlefloat:
return ecl_make_longfloat(ecl_long_float(x) + sf(y));
case t_doublefloat:
return ecl_make_longfloat(ecl_long_float(x) + df(y));
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y) != t_complex) {
cl_object aux = x;
x = y; y = aux;
goto COMPLEX;
}
z = ecl_plus(x->complex.real, y->complex.real);
z1 = ecl_plus(x->complex.imag, y->complex.imag);
return ecl_make_complex(z, z1);
default:
FEwrong_type_nth_arg(@[+], 1, x, @[number]);
}
}
/* (- ) */
@(defun - (num &rest nums)
cl_object diff;
@
/* INV: argument type check in number_{negate,minus}() */
if (narg == 1)
@(return ecl_negate(num))
for (diff = num; --narg; )
diff = ecl_minus(diff, cl_va_arg(nums));
@(return diff)
@)
cl_object
ecl_minus(cl_object x, cl_object y)
{
cl_fixnum i, j, k;
cl_object z, z1;
switch (type_of(x)) {
case t_fixnum:
switch(type_of(y)) {
case t_fixnum:
return ecl_make_integer(fix(x) - fix(y));
case t_bignum:
return _ecl_fix_minus_big(fix(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_singlefloat(fix(x) - sf(y));
case t_doublefloat:
return ecl_make_doublefloat(fix(x) - df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(fix(x) - ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[-], 2, y, @[number]);
}
case t_bignum:
switch (type_of(y)) {
case t_fixnum:
return _ecl_big_plus_fix(x, -fix(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_singlefloat(ecl_to_double(x) - sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) - df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_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_singlefloat(ecl_to_double(x) - sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) - df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
return ecl_make_singlefloat(sf(x) - fix(y));
case t_bignum:
case t_ratio:
return ecl_make_singlefloat(sf(x) - ecl_to_double(y));
case t_singlefloat:
return ecl_make_singlefloat(sf(x) - sf(y));
case t_doublefloat:
return ecl_make_doublefloat(sf(x) - df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(sf(x) - ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[-], 2, y, @[number]);
}
case t_doublefloat:
switch (type_of(y)) {
case t_fixnum:
return ecl_make_doublefloat(df(x) - fix(y));
case t_bignum:
case t_ratio:
return ecl_make_doublefloat(df(x) - ecl_to_double(y));
case t_singlefloat:
return ecl_make_doublefloat(df(x) - sf(y));
case t_doublefloat:
return ecl_make_doublefloat(df(x) - df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(df(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 (type_of(y)) {
case t_fixnum:
return ecl_make_longfloat(ecl_long_float(x) - fix(y));
case t_bignum:
case t_ratio:
return ecl_make_longfloat(ecl_long_float(x) - ecl_to_double(y));
case t_singlefloat:
return ecl_make_longfloat(ecl_long_float(x) - sf(y));
case t_doublefloat:
return ecl_make_longfloat(ecl_long_float(x) - df(y));
case t_longfloat:
return ecl_make_longfloat(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 (type_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]);
}
}
/* (/ ) */
@(defun / (num &rest nums)
@
/* INV: type check is in ecl_divide() */
if (narg == 0)
FEwrong_num_arguments(@[/]);
if (narg == 1)
@(return ecl_divide(MAKE_FIXNUM(1), num))
while (--narg)
num = ecl_divide(num, cl_va_arg(nums));
@(return num)
@)
cl_object
ecl_divide(cl_object x, cl_object y)
{
cl_object z, z1, z2;
switch (type_of(x)) {
case t_fixnum:
case t_bignum:
switch (type_of(y)) {
case t_fixnum:
if (y == 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_singlefloat(ecl_to_double(x) / sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) / df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
if (y == 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_singlefloat(ecl_to_double(x) / sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) / df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
return ecl_make_singlefloat(sf(x) / fix(y));
case t_bignum:
case t_ratio:
return ecl_make_singlefloat(sf(x) / ecl_to_double(y));
case t_singlefloat:
return ecl_make_singlefloat(sf(x) / sf(y));
case t_doublefloat:
return ecl_make_doublefloat(sf(x) / df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(sf(x) / ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[/], 2, y, @[number]);
}
case t_doublefloat:
switch (type_of(y)) {
case t_fixnum:
return ecl_make_doublefloat(df(x) / fix(y));
case t_bignum:
case t_ratio:
return ecl_make_doublefloat(df(x) / ecl_to_double(y));
case t_singlefloat:
return ecl_make_doublefloat(df(x) / sf(y));
case t_doublefloat:
return ecl_make_doublefloat(df(x) / df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(df(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 (type_of(y)) {
case t_fixnum:
return ecl_make_longfloat(ecl_long_float(x) / fix(y));
case t_bignum:
case t_ratio:
return ecl_make_longfloat(ecl_long_float(x) / ecl_to_double(y));
case t_singlefloat:
return ecl_make_longfloat(ecl_long_float(x) / sf(y));
case t_doublefloat:
return ecl_make_longfloat(ecl_long_float(x) / df(y));
case t_longfloat:
return ecl_make_longfloat(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 (type_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]);
}
}
cl_object
ecl_integer_divide(cl_object x, cl_object y)
{

174
src/c/numbers/divide.d Normal file
View file

@ -0,0 +1,174 @@
/* -*- mode: c; c-basic-offset: 8 -*- */
/*
divde.d -- Implementation of CL:/
*/
/*
Copyright (c) 2010, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../../Copyright' for full details.
*/
#include <ecl/ecl.h>
#include <ecl/impl/math_dispatch2.h>
@(defun / (num &rest nums)
@
/* INV: type check is in ecl_divide() */
if (narg == 0)
FEwrong_num_arguments(@[/]);
if (narg == 1)
@(return ecl_divide(MAKE_FIXNUM(1), num))
while (--narg)
num = ecl_divide(num, cl_va_arg(nums));
@(return num)
@)
cl_object
ecl_divide(cl_object x, cl_object y)
{
cl_object z, z1, z2;
switch (type_of(x)) {
case t_fixnum:
case t_bignum:
switch (type_of(y)) {
case t_fixnum:
if (y == 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_singlefloat(ecl_to_double(x) / sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) / df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
if (y == 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_singlefloat(ecl_to_double(x) / sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) / df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
return ecl_make_singlefloat(sf(x) / fix(y));
case t_bignum:
case t_ratio:
return ecl_make_singlefloat(sf(x) / ecl_to_double(y));
case t_singlefloat:
return ecl_make_singlefloat(sf(x) / sf(y));
case t_doublefloat:
return ecl_make_doublefloat(sf(x) / df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(sf(x) / ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[/], 2, y, @[number]);
}
case t_doublefloat:
switch (type_of(y)) {
case t_fixnum:
return ecl_make_doublefloat(df(x) / fix(y));
case t_bignum:
case t_ratio:
return ecl_make_doublefloat(df(x) / ecl_to_double(y));
case t_singlefloat:
return ecl_make_doublefloat(df(x) / sf(y));
case t_doublefloat:
return ecl_make_doublefloat(df(x) / df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(df(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 (type_of(y)) {
case t_fixnum:
return ecl_make_longfloat(ecl_long_float(x) / fix(y));
case t_bignum:
case t_ratio:
return ecl_make_longfloat(ecl_long_float(x) / ecl_to_double(y));
case t_singlefloat:
return ecl_make_longfloat(ecl_long_float(x) / sf(y));
case t_doublefloat:
return ecl_make_longfloat(ecl_long_float(x) / df(y));
case t_longfloat:
return ecl_make_longfloat(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 (type_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]);
}
}

337
src/c/numbers/minus.d Normal file
View file

@ -0,0 +1,337 @@
/* -*- mode: c; c-basic-offset: 8 -*- */
/*
minus.d -- Implementation of CL:-
*/
/*
Copyright (c) 2010, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../../Copyright' for full details.
*/
#include <ecl/ecl.h>
#include <ecl/impl/math_dispatch2.h>
@(defun - (num &rest nums)
cl_object diff;
@
/* INV: argument type check in number_{negate,minus}() */
if (narg == 1)
@(return ecl_negate(num))
for (diff = num; --narg; )
diff = ecl_minus(diff, cl_va_arg(nums));
@(return diff)
@)
#if 1
cl_object
ecl_minus(cl_object x, cl_object y)
{
MATH_DISPATCH2_BEGIN(x,y)
{
CASE_FIXNUM_FIXNUM {
return ecl_make_integer(fix(x) - fix(y));
}
CASE_FIXNUM_BIGNUM {
return _ecl_fix_minus_big(fix(x), y);
}
CASE_FIXNUM_RATIO;
CASE_BIGNUM_RATIO {
cl_object z = ecl_times(x, y->ratio.den);
z = ecl_minus(z, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
}
CASE_FIXNUM_SINGLE_FLOAT {
return ecl_make_singlefloat(fix(x) - ecl_single_float(y));
}
CASE_FIXNUM_DOUBLE_FLOAT {
return ecl_make_doublefloat(fix(x) - ecl_double_float(y));
}
CASE_BIGNUM_FIXNUM {
return _ecl_big_plus_fix(x, -fix(y));
}
CASE_BIGNUM_BIGNUM {
return _ecl_big_minus_big(x, y);
}
CASE_BIGNUM_SINGLE_FLOAT {
return ecl_make_singlefloat(ecl_to_float(x) - ecl_single_float(y));
}
CASE_BIGNUM_DOUBLE_FLOAT {
return ecl_make_doublefloat(ecl_to_double(x) - ecl_double_float(y));
}
CASE_RATIO_FIXNUM;
CASE_RATIO_BIGNUM {
cl_object z = ecl_times(x->ratio.den, y);
z = ecl_minus(x->ratio.num, z);
return ecl_make_ratio(z, x->ratio.den);
}
CASE_RATIO_RATIO {
cl_object z1 = ecl_times(x->ratio.num,y->ratio.den);
cl_object z = ecl_times(x->ratio.den,y->ratio.num);
z = ecl_minus(z1, z);
z1 = ecl_times(x->ratio.den,y->ratio.den);
return ecl_make_ratio(z, z1);
}
CASE_RATIO_SINGLE_FLOAT {
return ecl_make_singlefloat(ecl_to_float(x) - ecl_single_float(y));
}
CASE_RATIO_DOUBLE_FLOAT {
return ecl_make_doublefloat(ecl_to_double(x) - ecl_double_float(y));
}
CASE_SINGLE_FLOAT_FIXNUM {
return ecl_make_singlefloat(ecl_single_float(x) - fix(y));
}
CASE_SINGLE_FLOAT_BIGNUM;
CASE_SINGLE_FLOAT_RATIO {
return ecl_make_singlefloat(ecl_single_float(x) - ecl_to_float(y));
}
CASE_SINGLE_FLOAT_SINGLE_FLOAT {
return ecl_make_singlefloat(ecl_single_float(x) - ecl_single_float(y));
}
CASE_SINGLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_doublefloat(ecl_single_float(x) - ecl_double_float(y));
}
CASE_DOUBLE_FLOAT_FIXNUM {
return ecl_make_doublefloat(ecl_double_float(x) - fix(y));
}
CASE_DOUBLE_FLOAT_BIGNUM;
CASE_DOUBLE_FLOAT_RATIO {
return ecl_make_doublefloat(ecl_double_float(x) - ecl_to_double(y));
}
CASE_DOUBLE_FLOAT_SINGLE_FLOAT {
return ecl_make_doublefloat(ecl_double_float(x) - ecl_single_float(y));
}
CASE_DOUBLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_doublefloat(ecl_double_float(x) - ecl_double_float(y));
}
#ifdef ECL_LONG_FLOAT
CASE_FIXNUM_LONG_FLOAT {
return ecl_make_longfloat(fix(x) - ecl_long_float(y));
}
CASE_BIGNUM_LONG_FLOAT {
return ecl_make_longfloat(ecl_to_long_double(x) - ecl_long_float(y));
}
CASE_RATIO_LONG_FLOAT {
return ecl_make_longfloat(ecl_to_long_double(x) - ecl_long_float(y));
}
CASE_SINGLE_FLOAT_LONG_FLOAT {
return ecl_make_longfloat(ecl_single_float(x) - ecl_long_float(y));
}
CASE_DOUBLE_FLOAT_LONG_FLOAT {
return ecl_make_longfloat(ecl_double_float(x) - ecl_long_float(y));
}
CASE_LONG_FLOAT_FIXNUM {
return ecl_make_longfloat(ecl_long_float(x) - fix(y));
}
CASE_LONG_FLOAT_BIGNUM;
CASE_LONG_FLOAT_RATIO {
return ecl_make_longfloat(ecl_long_float(x) - ecl_to_double(y));
}
CASE_LONG_FLOAT_SINGLE_FLOAT {
return ecl_make_longfloat(ecl_long_float(x) - ecl_single_float(y));
}
CASE_LONG_FLOAT_DOUBLE_FLOAT {
return ecl_make_longfloat(ecl_long_float(x) - ecl_double_float(y));
}
CASE_LONG_FLOAT_LONG_FLOAT {
return ecl_make_longfloat(ecl_long_float(x) - ecl_long_float(y));
}
CASE_LONG_FLOAT_COMPLEX {
goto COMPLEX_Y;
}
CASE_COMPLEX_LONG_FLOAT; {
goto COMPLEX_X;
}
#endif
CASE_COMPLEX_FIXNUM;
CASE_COMPLEX_BIGNUM;
CASE_COMPLEX_RATIO;
CASE_COMPLEX_SINGLE_FLOAT;
CASE_COMPLEX_DOUBLE_FLOAT {
COMPLEX_X:
return ecl_make_complex(ecl_minus(x->complex.real, y),
x->complex.imag);
}
CASE_BIGNUM_COMPLEX;
CASE_RATIO_COMPLEX;
CASE_SINGLE_FLOAT_COMPLEX;
CASE_DOUBLE_FLOAT_COMPLEX;
CASE_FIXNUM_COMPLEX {
COMPLEX_Y:
return ecl_make_complex(ecl_minus(x, y->complex.real),
ecl_negate(y->complex.imag));
}
CASE_COMPLEX_COMPLEX {
cl_object z = ecl_minus(x->complex.real, y->complex.real);
cl_object z1 = ecl_minus(x->complex.imag, y->complex.imag);
return ecl_make_complex(z, z1);
}
CASE_UNKNOWN(@[-],x,y,@[number]);
}
MATH_DISPATCH2_END;
}
#else
cl_object
ecl_minus(cl_object x, cl_object y)
{
cl_fixnum i, j, k;
cl_object z, z1;
switch (type_of(x)) {
case t_fixnum:
switch(type_of(y)) {
case t_fixnum:
return ecl_make_integer(fix(x) - fix(y));
case t_bignum:
return _ecl_fix_minus_big(fix(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_singlefloat(fix(x) - sf(y));
case t_doublefloat:
return ecl_make_doublefloat(fix(x) - df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(fix(x) - ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[-], 2, y, @[number]);
}
case t_bignum:
switch (type_of(y)) {
case t_fixnum:
return _ecl_big_plus_fix(x, -fix(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_singlefloat(ecl_to_double(x) - sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) - df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_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_singlefloat(ecl_to_double(x) - sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) - df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
return ecl_make_singlefloat(sf(x) - fix(y));
case t_bignum:
case t_ratio:
return ecl_make_singlefloat(sf(x) - ecl_to_double(y));
case t_singlefloat:
return ecl_make_singlefloat(sf(x) - sf(y));
case t_doublefloat:
return ecl_make_doublefloat(sf(x) - df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(sf(x) - ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[-], 2, y, @[number]);
}
case t_doublefloat:
switch (type_of(y)) {
case t_fixnum:
return ecl_make_doublefloat(df(x) - fix(y));
case t_bignum:
case t_ratio:
return ecl_make_doublefloat(df(x) - ecl_to_double(y));
case t_singlefloat:
return ecl_make_doublefloat(df(x) - sf(y));
case t_doublefloat:
return ecl_make_doublefloat(df(x) - df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(df(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 (type_of(y)) {
case t_fixnum:
return ecl_make_longfloat(ecl_long_float(x) - fix(y));
case t_bignum:
case t_ratio:
return ecl_make_longfloat(ecl_long_float(x) - ecl_to_double(y));
case t_singlefloat:
return ecl_make_longfloat(ecl_long_float(x) - sf(y));
case t_doublefloat:
return ecl_make_longfloat(ecl_long_float(x) - df(y));
case t_longfloat:
return ecl_make_longfloat(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 (type_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

333
src/c/numbers/plus.d Normal file
View file

@ -0,0 +1,333 @@
/* -*- mode: c; c-basic-offset: 8 -*- */
/*
plus.d -- Implementation of CL:+
*/
/*
Copyright (c) 2010, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../../Copyright' for full details.
*/
#include <ecl/ecl.h>
#include <ecl/impl/math_dispatch2.h>
@(defun + (&rest nums)
cl_object sum = MAKE_FIXNUM(0);
@
/* INV: type check is in ecl_plus() */
while (narg--)
sum = ecl_plus(sum, cl_va_arg(nums));
@(return sum)
@)
#if 1
cl_object
ecl_plus(cl_object x, cl_object y)
{
MATH_DISPATCH2_BEGIN(x,y)
{
CASE_FIXNUM_FIXNUM {
return ecl_make_integer(fix(x) + fix(y));
}
CASE_FIXNUM_BIGNUM {
return _ecl_big_plus_fix(y, fix(x));
}
CASE_FIXNUM_RATIO;
CASE_BIGNUM_RATIO {
cl_object z = ecl_times(x, y->ratio.den);
z = ecl_plus(z, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
}
CASE_FIXNUM_SINGLE_FLOAT {
return ecl_make_singlefloat(fix(x) + ecl_single_float(y));
}
CASE_FIXNUM_DOUBLE_FLOAT {
return ecl_make_doublefloat(fix(x) + ecl_double_float(y));
}
CASE_BIGNUM_FIXNUM {
return _ecl_big_plus_fix(x, fix(y));
}
CASE_BIGNUM_BIGNUM {
return _ecl_big_plus_big(x, y);
}
CASE_BIGNUM_SINGLE_FLOAT {
return ecl_make_singlefloat(ecl_to_float(x) + ecl_single_float(y));
}
CASE_BIGNUM_DOUBLE_FLOAT {
return ecl_make_doublefloat(ecl_to_double(x) + ecl_double_float(y));
}
CASE_RATIO_FIXNUM;
CASE_RATIO_BIGNUM {
cl_object z = ecl_times(x->ratio.den, y);
z = ecl_plus(x->ratio.num, z);
return ecl_make_ratio(z, x->ratio.den);
}
CASE_RATIO_RATIO {
cl_object z1 = ecl_times(x->ratio.num,y->ratio.den);
cl_object z = ecl_times(x->ratio.den,y->ratio.num);
z = ecl_plus(z1, z);
z1 = ecl_times(x->ratio.den,y->ratio.den);
return ecl_make_ratio(z, z1);
}
CASE_RATIO_SINGLE_FLOAT {
return ecl_make_singlefloat(ecl_to_float(x) + ecl_single_float(y));
}
CASE_RATIO_DOUBLE_FLOAT {
return ecl_make_doublefloat(ecl_to_double(x) + ecl_double_float(y));
}
CASE_SINGLE_FLOAT_FIXNUM {
return ecl_make_singlefloat(ecl_single_float(x) + fix(y));
}
CASE_SINGLE_FLOAT_BIGNUM;
CASE_SINGLE_FLOAT_RATIO {
return ecl_make_singlefloat(ecl_single_float(x) + ecl_to_float(y));
}
CASE_SINGLE_FLOAT_SINGLE_FLOAT {
return ecl_make_singlefloat(ecl_single_float(x) + ecl_single_float(y));
}
CASE_SINGLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_doublefloat(ecl_single_float(x) + ecl_double_float(y));
}
CASE_DOUBLE_FLOAT_FIXNUM {
return ecl_make_doublefloat(ecl_double_float(x) + fix(y));
}
CASE_DOUBLE_FLOAT_BIGNUM;
CASE_DOUBLE_FLOAT_RATIO {
return ecl_make_doublefloat(ecl_double_float(x) + ecl_to_double(y));
}
CASE_DOUBLE_FLOAT_SINGLE_FLOAT {
return ecl_make_doublefloat(ecl_double_float(x) + ecl_single_float(y));
}
CASE_DOUBLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_doublefloat(ecl_double_float(x) + ecl_double_float(y));
}
#ifdef ECL_LONG_FLOAT
CASE_FIXNUM_LONG_FLOAT {
return ecl_make_longfloat(fix(x) + ecl_long_float(y));
}
CASE_BIGNUM_LONG_FLOAT {
return ecl_make_longfloat(ecl_to_long_double(x) + ecl_long_float(y));
}
CASE_RATIO_LONG_FLOAT {
return ecl_make_longfloat(ecl_to_long_double(x) + ecl_long_float(y));
}
CASE_SINGLE_FLOAT_LONG_FLOAT {
return ecl_make_longfloat(ecl_single_float(x) + ecl_long_float(y));
}
CASE_DOUBLE_FLOAT_LONG_FLOAT {
return ecl_make_longfloat(ecl_double_float(x) + ecl_long_float(y));
}
CASE_LONG_FLOAT_FIXNUM {
return ecl_make_longfloat(ecl_long_float(x) + fix(y));
}
CASE_LONG_FLOAT_BIGNUM;
CASE_LONG_FLOAT_RATIO {
return ecl_make_longfloat(ecl_long_float(x) + ecl_to_double(y));
}
CASE_LONG_FLOAT_SINGLE_FLOAT {
return ecl_make_longfloat(ecl_long_float(x) + ecl_single_float(y));
}
CASE_LONG_FLOAT_DOUBLE_FLOAT {
return ecl_make_longfloat(ecl_long_float(x) + ecl_double_float(y));
}
CASE_LONG_FLOAT_LONG_FLOAT {
return ecl_make_longfloat(ecl_long_float(x) + ecl_long_float(y));
}
CASE_LONG_FLOAT_COMPLEX {
goto COMPLEX_Y;
}
CASE_COMPLEX_LONG_FLOAT; {
goto COMPLEX_X;
}
#endif
CASE_COMPLEX_FIXNUM;
CASE_COMPLEX_BIGNUM;
CASE_COMPLEX_RATIO;
CASE_COMPLEX_SINGLE_FLOAT;
CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: {
cl_object aux = x;
x = y; y = aux;
goto COMPLEX_Y;
}
CASE_BIGNUM_COMPLEX;
CASE_RATIO_COMPLEX;
CASE_SINGLE_FLOAT_COMPLEX;
CASE_DOUBLE_FLOAT_COMPLEX;
CASE_FIXNUM_COMPLEX {
COMPLEX_Y:
return ecl_make_complex(ecl_plus(x, y->complex.real),
y->complex.imag);
}
CASE_COMPLEX_COMPLEX {
cl_object z = ecl_plus(x->complex.real, y->complex.real);
cl_object z1 = ecl_plus(x->complex.imag, y->complex.imag);
return ecl_make_complex(z, z1);
}
CASE_UNKNOWN(@[+],x,y,@[number]);
}
MATH_DISPATCH2_END;
}
#else
cl_object
ecl_plus(cl_object x, cl_object y)
{
cl_fixnum i, j;
cl_object z, z1;
switch (type_of(x)) {
case t_fixnum:
switch (type_of(y)) {
case t_fixnum:
return ecl_make_integer(fix(x) + fix(y));
case t_bignum:
return _ecl_big_plus_fix(y, fix(x));
case t_ratio:
z = ecl_times(x, y->ratio.den);
z = ecl_plus(z, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
case t_singlefloat:
return ecl_make_singlefloat(fix(x) + sf(y));
case t_doublefloat:
return ecl_make_doublefloat(fix(x) + df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(fix(x) + ecl_long_float(y));
#endif
case t_complex:
COMPLEX: /* INV: x is real, y is complex */
return ecl_make_complex(ecl_plus(x, y->complex.real),
y->complex.imag);
default:
FEwrong_type_nth_arg(@[+], 2, y, @[number]);
}
case t_bignum:
switch (type_of(y)) {
case t_fixnum:
return _ecl_big_plus_fix(x, fix(y));
case t_bignum:
return _ecl_big_plus_big(x, y);
case t_ratio:
z = ecl_times(x, y->ratio.den);
z = ecl_plus(z, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
case t_singlefloat:
return ecl_make_singlefloat(ecl_to_double(x) + sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) + df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
case t_bignum:
z = ecl_times(x->ratio.den, y);
z = ecl_plus(x->ratio.num, z);
return ecl_make_ratio(z, x->ratio.den);
case t_ratio:
z1 = ecl_times(x->ratio.num,y->ratio.den);
z = ecl_times(x->ratio.den,y->ratio.num);
z = ecl_plus(z1, z);
z1 = ecl_times(x->ratio.den,y->ratio.den);
return ecl_make_ratio(z, z1);
case t_singlefloat:
return ecl_make_singlefloat(ecl_to_double(x) + sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) + df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
return ecl_make_singlefloat(sf(x) + fix(y));
case t_bignum:
case t_ratio:
return ecl_make_singlefloat(sf(x) + ecl_to_double(y));
case t_singlefloat:
return ecl_make_singlefloat(sf(x) + sf(y));
case t_doublefloat:
return ecl_make_doublefloat(sf(x) + df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(sf(x) + ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[+], 2, y, @[number]);
}
case t_doublefloat:
switch (type_of(y)) {
case t_fixnum:
return ecl_make_doublefloat(df(x) + fix(y));
case t_bignum:
case t_ratio:
return ecl_make_doublefloat(df(x) + ecl_to_double(y));
case t_singlefloat:
return ecl_make_doublefloat(df(x) + sf(y));
case t_doublefloat:
return ecl_make_doublefloat(df(x) + df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(df(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 (type_of(y)) {
case t_fixnum:
return ecl_make_longfloat(ecl_long_float(x) + fix(y));
case t_bignum:
case t_ratio:
return ecl_make_longfloat(ecl_long_float(x) + ecl_to_double(y));
case t_singlefloat:
return ecl_make_longfloat(ecl_long_float(x) + sf(y));
case t_doublefloat:
return ecl_make_longfloat(ecl_long_float(x) + df(y));
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y) != t_complex) {
cl_object aux = x;
x = y; y = aux;
goto COMPLEX;
}
z = ecl_plus(x->complex.real, y->complex.real);
z1 = ecl_plus(x->complex.imag, y->complex.imag);
return ecl_make_complex(z, z1);
default:
FEwrong_type_nth_arg(@[+], 1, x, @[number]);
}
}
#endif

187
src/c/numbers/times.d Normal file
View file

@ -0,0 +1,187 @@
/* -*- mode: c; c-basic-offset: 8 -*- */
/*
times.d -- Implementation of CL:*
*/
/*
Copyright (c) 2010, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../../Copyright' for full details.
*/
#include <ecl/ecl.h>
#include <ecl/impl/math_dispatch2.h>
@(defun * (&rest nums)
cl_object prod = MAKE_FIXNUM(1);
@
/* INV: type check in ecl_times() */
while (narg--)
prod = ecl_times(prod, cl_va_arg(nums));
@(return prod)
@)
cl_object
ecl_times(cl_object x, cl_object y)
{
cl_object z, z1;
switch (type_of(x)) {
case t_fixnum:
switch (type_of(y)) {
case t_fixnum:
return _ecl_fix_times_fix(fix(x),fix(y));
case t_bignum:
return _ecl_big_times_fix(y, fix(x));
case t_ratio:
z = ecl_times(x, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
case t_singlefloat:
return ecl_make_singlefloat(fix(x) * sf(y));
case t_doublefloat:
return ecl_make_doublefloat(fix(x) * df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(fix(x) * ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[*], 2, y, @[number]);
}
case t_bignum:
switch (type_of(y)) {
case t_fixnum:
return _ecl_big_times_fix(x, fix(y));
case t_bignum:
return _ecl_big_times_big(x, y);
case t_ratio:
z = ecl_times(x, y->ratio.num);
return ecl_make_ratio(z, y->ratio.den);
case t_singlefloat:
return ecl_make_singlefloat(ecl_to_double(x) * sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) * df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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 (type_of(y)) {
case t_fixnum:
case t_bignum:
z = ecl_times(x->ratio.num, y);
return ecl_make_ratio(z, x->ratio.den);
case t_ratio:
z = ecl_times(x->ratio.num,y->ratio.num);
z1 = ecl_times(x->ratio.den,y->ratio.den);
return ecl_make_ratio(z, z1);
case t_singlefloat:
return ecl_make_singlefloat(ecl_to_double(x) * sf(y));
case t_doublefloat:
return ecl_make_doublefloat(ecl_to_double(x) * df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(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: {
float fx = sf(x);
switch (type_of(y)) {
case t_fixnum:
return ecl_make_singlefloat(fx * fix(y));
case t_bignum:
case t_ratio:
return ecl_make_singlefloat(fx * ecl_to_double(y));
case t_singlefloat:
return ecl_make_singlefloat(fx * sf(y));
case t_doublefloat:
return ecl_make_doublefloat(fx * df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(fx * ecl_long_float(y));
#endif
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[*], 2, y, @[number]);
}
}
case t_doublefloat: {
switch (type_of(y)) {
case t_fixnum:
return ecl_make_doublefloat(df(x) * fix(y));
case t_bignum:
case t_ratio:
return ecl_make_doublefloat(df(x) * ecl_to_double(y));
case t_singlefloat:
return ecl_make_doublefloat(df(x) * sf(y));
case t_doublefloat:
return ecl_make_doublefloat(df(x) * df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_make_longfloat(df(x) * ecl_long_float(y));
#endif
case t_complex: {
COMPLEX: /* INV: x is real, y is complex */
return ecl_make_complex(ecl_times(x, y->complex.real),
ecl_times(x, y->complex.imag));
}
default:
FEwrong_type_nth_arg(@[*], 2, y, @[number]);
}
}
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
long double lx = ecl_long_float(x);
switch (type_of(y)) {
case t_fixnum:
return ecl_make_longfloat(lx * fix(y));
case t_bignum:
case t_ratio:
return ecl_make_longfloat(lx * ecl_to_double(y));
case t_singlefloat:
return ecl_make_longfloat(lx * sf(y));
case t_doublefloat:
return ecl_make_longfloat(lx * df(y));
case t_longfloat:
return ecl_make_longfloat(lx * ecl_long_float(y));
case t_complex:
goto COMPLEX;
default:
FEwrong_type_nth_arg(@[*], 2, y, @[number]);
}
}
#endif
case t_complex:
{
cl_object z11, z12, z21, z22;
if (type_of(y) != t_complex) {
cl_object aux = x;
x = y; y = aux;
goto COMPLEX;
}
z11 = ecl_times(x->complex.real, y->complex.real);
z12 = ecl_times(x->complex.imag, y->complex.imag);
z21 = ecl_times(x->complex.imag, y->complex.real);
z22 = ecl_times(x->complex.real, y->complex.imag);
return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22));
}
default:
FEwrong_type_nth_arg(@[*], 1, x, @[number]);
}
}

139
src/h/impl/math_dispatch2.h Normal file
View file

@ -0,0 +1,139 @@
/* -*- mode: c; c-basic-offset: 4 -*- */
/*
math_dispatch.h -- fast dispatch for math functions
*/
/*
Copyright (c) 2010, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
#ifndef ECL_MATH_DISPATCH2_H
#define ECL_MATH_DISPATCH2_H
#include <ecl/internal.h> /* for unlikely_if */
#define MATH_DISPATCH2_LABEL(t1,t2) case ((t1)*(t_complex+1)+(t2)):
#define MATH_DISPATCH2_BEGIN(x,y) { \
int tx = type_of(x), ty = type_of(y); \
unlikely_if (ty > t_complex) { goto DISPATCH2_ERROR; } \
switch (tx * (t_complex+1) + ty)
#define MATH_DISPATCH2_END } (void)0
#define CASE_COMPLEX_FIXNUM \
MATH_DISPATCH2_LABEL(t_complex,t_fixnum)
#define CASE_COMPLEX_BIGNUM \
MATH_DISPATCH2_LABEL(t_complex,t_bignum)
#define CASE_COMPLEX_RATIO \
MATH_DISPATCH2_LABEL(t_complex,t_ratio)
#define CASE_COMPLEX_SINGLE_FLOAT \
MATH_DISPATCH2_LABEL(t_complex,t_singlefloat)
#define CASE_COMPLEX_DOUBLE_FLOAT \
MATH_DISPATCH2_LABEL(t_complex,t_doublefloat)
#define CASE_COMPLEX_LONG_FLOAT \
MATH_DISPATCH2_LABEL(t_complex,t_longfloat)
#define CASE_COMPLEX_COMPLEX \
MATH_DISPATCH2_LABEL(t_complex,t_complex)
#define CASE_LONG_FLOAT_FIXNUM \
MATH_DISPATCH2_LABEL(t_longfloat,t_fixnum)
#define CASE_LONG_FLOAT_BIGNUM \
MATH_DISPATCH2_LABEL(t_longfloat,t_bignum)
#define CASE_LONG_FLOAT_RATIO \
MATH_DISPATCH2_LABEL(t_longfloat,t_ratio)
#define CASE_LONG_FLOAT_SINGLE_FLOAT \
MATH_DISPATCH2_LABEL(t_longfloat,t_singlefloat)
#define CASE_LONG_FLOAT_DOUBLE_FLOAT \
MATH_DISPATCH2_LABEL(t_longfloat,t_doublefloat)
#define CASE_LONG_FLOAT_LONG_FLOAT \
MATH_DISPATCH2_LABEL(t_longfloat,t_longfloat)
#define CASE_LONG_FLOAT_COMPLEX \
MATH_DISPATCH2_LABEL(t_longfloat,t_complex)
#define CASE_DOUBLE_FLOAT_FIXNUM \
MATH_DISPATCH2_LABEL(t_doublefloat,t_fixnum)
#define CASE_DOUBLE_FLOAT_BIGNUM \
MATH_DISPATCH2_LABEL(t_doublefloat,t_bignum)
#define CASE_DOUBLE_FLOAT_RATIO \
MATH_DISPATCH2_LABEL(t_doublefloat,t_ratio)
#define CASE_DOUBLE_FLOAT_SINGLE_FLOAT \
MATH_DISPATCH2_LABEL(t_doublefloat,t_singlefloat)
#define CASE_DOUBLE_FLOAT_DOUBLE_FLOAT \
MATH_DISPATCH2_LABEL(t_doublefloat,t_doublefloat)
#define CASE_DOUBLE_FLOAT_LONG_FLOAT \
MATH_DISPATCH2_LABEL(t_doublefloat,t_longfloat)
#define CASE_DOUBLE_FLOAT_COMPLEX \
MATH_DISPATCH2_LABEL(t_doublefloat,t_complex)
#define CASE_SINGLE_FLOAT_FIXNUM \
MATH_DISPATCH2_LABEL(t_singlefloat,t_fixnum)
#define CASE_SINGLE_FLOAT_BIGNUM \
MATH_DISPATCH2_LABEL(t_singlefloat,t_bignum)
#define CASE_SINGLE_FLOAT_RATIO \
MATH_DISPATCH2_LABEL(t_singlefloat,t_ratio)
#define CASE_SINGLE_FLOAT_SINGLE_FLOAT \
MATH_DISPATCH2_LABEL(t_singlefloat,t_singlefloat)
#define CASE_SINGLE_FLOAT_DOUBLE_FLOAT \
MATH_DISPATCH2_LABEL(t_singlefloat,t_doublefloat)
#define CASE_SINGLE_FLOAT_LONG_FLOAT \
MATH_DISPATCH2_LABEL(t_singlefloat,t_longfloat)
#define CASE_SINGLE_FLOAT_COMPLEX \
MATH_DISPATCH2_LABEL(t_singlefloat,t_complex)
#define CASE_RATIO_FIXNUM \
MATH_DISPATCH2_LABEL(t_ratio,t_fixnum)
#define CASE_RATIO_BIGNUM \
MATH_DISPATCH2_LABEL(t_ratio,t_bignum)
#define CASE_RATIO_RATIO \
MATH_DISPATCH2_LABEL(t_ratio,t_ratio)
#define CASE_RATIO_SINGLE_FLOAT \
MATH_DISPATCH2_LABEL(t_ratio,t_singlefloat)
#define CASE_RATIO_DOUBLE_FLOAT \
MATH_DISPATCH2_LABEL(t_ratio,t_doublefloat)
#define CASE_RATIO_LONG_FLOAT \
MATH_DISPATCH2_LABEL(t_ratio,t_longfloat)
#define CASE_RATIO_COMPLEX \
MATH_DISPATCH2_LABEL(t_ratio,t_complex)
#define CASE_BIGNUM_FIXNUM \
MATH_DISPATCH2_LABEL(t_bignum,t_fixnum)
#define CASE_BIGNUM_BIGNUM \
MATH_DISPATCH2_LABEL(t_bignum,t_bignum)
#define CASE_BIGNUM_RATIO \
MATH_DISPATCH2_LABEL(t_bignum,t_ratio)
#define CASE_BIGNUM_SINGLE_FLOAT \
MATH_DISPATCH2_LABEL(t_bignum,t_singlefloat)
#define CASE_BIGNUM_DOUBLE_FLOAT \
MATH_DISPATCH2_LABEL(t_bignum,t_doublefloat)
#define CASE_BIGNUM_LONG_FLOAT \
MATH_DISPATCH2_LABEL(t_bignum,t_longfloat)
#define CASE_BIGNUM_COMPLEX \
MATH_DISPATCH2_LABEL(t_bignum,t_complex)
#define CASE_FIXNUM_FIXNUM \
MATH_DISPATCH2_LABEL(t_fixnum,t_fixnum)
#define CASE_FIXNUM_BIGNUM \
MATH_DISPATCH2_LABEL(t_fixnum,t_bignum)
#define CASE_FIXNUM_RATIO \
MATH_DISPATCH2_LABEL(t_fixnum,t_ratio)
#define CASE_FIXNUM_SINGLE_FLOAT \
MATH_DISPATCH2_LABEL(t_fixnum,t_singlefloat)
#define CASE_FIXNUM_DOUBLE_FLOAT \
MATH_DISPATCH2_LABEL(t_fixnum,t_doublefloat)
#define CASE_FIXNUM_LONG_FLOAT \
MATH_DISPATCH2_LABEL(t_fixnum,t_longfloat)
#define CASE_FIXNUM_COMPLEX \
MATH_DISPATCH2_LABEL(t_fixnum,t_complex)
#define CASE_UNKNOWN(routine,x,y,type) \
default: DISPATCH2_ERROR: \
if (!ecl_numberp(x)) \
FEwrong_type_nth_arg(routine, 1, x, type); \
else \
FEwrong_type_nth_arg(routine, 2, y, type)
#endif /* ECL_MATH_DISPATCH2_H */