mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 14:19:18 +02:00
More complex number additions.
This commit is contained in:
Alex Shinn
parent
0ebd1216cc
commit
ddb6f31d58
3 changed files with 80 additions and 24 deletions
45
eval.c
45
eval.c
|
|
@ -1150,13 +1150,14 @@ sexp sexp_register_optimization (sexp ctx sexp_api_params(self, n), sexp f, sexp
|
|||
#endif
|
||||
|
||||
#if SEXP_USE_COMPLEX
|
||||
#define maybe_convert_complex(z, f) \
|
||||
else if (sexp_complexp(z)) return sexp_complex_normalize(f(ctx, z));
|
||||
#define maybe_convert_complex(z, t, f) \
|
||||
else if (t && sexp_complexp(z)) return sexp_complex_normalize(f(ctx, z));
|
||||
#define sexp_complex_dummy(ctx, z) 0
|
||||
#else
|
||||
#define maybe_convert_complex(z, f)
|
||||
#define maybe_convert_complex(z, t, f)
|
||||
#endif
|
||||
|
||||
#define define_math_op(name, cname, complexf) \
|
||||
#define define_math_op(name, cname, t, f) \
|
||||
static sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \
|
||||
double d; \
|
||||
if (sexp_flonump(z)) \
|
||||
|
|
@ -1165,24 +1166,24 @@ sexp sexp_register_optimization (sexp ctx sexp_api_params(self, n), sexp f, sexp
|
|||
d = (double)sexp_unbox_fixnum(z); \
|
||||
maybe_convert_ratio(z) \
|
||||
maybe_convert_bignum(z) \
|
||||
maybe_convert_complex(z, complexf) \
|
||||
maybe_convert_complex(z, t, f) \
|
||||
else \
|
||||
return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \
|
||||
return sexp_make_flonum(ctx, cname(d)); \
|
||||
}
|
||||
|
||||
define_math_op(sexp_exp, exp, sexp_complex_exp)
|
||||
define_math_op(sexp_log, log, sexp_complex_log)
|
||||
define_math_op(sexp_sin, sin, sexp_complex_sin)
|
||||
define_math_op(sexp_cos, cos, sexp_complex_cos)
|
||||
define_math_op(sexp_tan, tan, sexp_complex_math_error)
|
||||
define_math_op(sexp_asin, asin, sexp_complex_asin)
|
||||
define_math_op(sexp_acos, acos, sexp_complex_acos)
|
||||
define_math_op(sexp_atan, atan, sexp_complex_math_error)
|
||||
define_math_op(sexp_round, round, sexp_complex_math_error)
|
||||
define_math_op(sexp_trunc, trunc, sexp_complex_math_error)
|
||||
define_math_op(sexp_floor, floor, sexp_complex_math_error)
|
||||
define_math_op(sexp_ceiling, ceil, sexp_complex_math_error)
|
||||
define_math_op(sexp_exp, exp, 1, sexp_complex_exp)
|
||||
define_math_op(sexp_log, log, 1, sexp_complex_log)
|
||||
define_math_op(sexp_sin, sin, 1, sexp_complex_sin)
|
||||
define_math_op(sexp_cos, cos, 1, sexp_complex_cos)
|
||||
define_math_op(sexp_tan, tan, 1, sexp_complex_tan)
|
||||
define_math_op(sexp_asin, asin, 1, sexp_complex_asin)
|
||||
define_math_op(sexp_acos, acos, 1, sexp_complex_acos)
|
||||
define_math_op(sexp_atan, atan, 1, sexp_complex_atan)
|
||||
define_math_op(sexp_round, round, 0, sexp_complex_dummy)
|
||||
define_math_op(sexp_trunc, trunc, 0, sexp_complex_dummy)
|
||||
define_math_op(sexp_floor, floor, 0, sexp_complex_dummy)
|
||||
define_math_op(sexp_ceiling, ceil, 0, sexp_complex_dummy)
|
||||
|
||||
static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) {
|
||||
int negativep = 0;
|
||||
|
|
@ -1194,7 +1195,7 @@ static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) {
|
|||
d = (double)sexp_unbox_fixnum(z);
|
||||
maybe_convert_bignum(z) /* XXXX add bignum sqrt */
|
||||
maybe_convert_ratio(z) /* XXXX add ratio sqrt */
|
||||
maybe_convert_complex(z, sexp_complex_sqrt)
|
||||
maybe_convert_complex(z, 1, sexp_complex_sqrt)
|
||||
else
|
||||
return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
|
||||
sexp_gc_preserve1(ctx, res);
|
||||
|
|
@ -1236,6 +1237,10 @@ sexp sexp_generic_expt (sexp ctx, sexp x, sexp_sint_t e) {
|
|||
static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
|
||||
long double f, x1, e1;
|
||||
sexp res;
|
||||
#if SEXP_USE_COMPLEX
|
||||
if (sexp_complexp(x) || sexp_complexp(e))
|
||||
return sexp_complex_expt(ctx, x, e);
|
||||
#endif
|
||||
#if SEXP_USE_BIGNUMS
|
||||
if (sexp_bignump(e)) { /* bignum exponent needs special handling */
|
||||
if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE))
|
||||
|
|
@ -1264,10 +1269,6 @@ static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
|
|||
x1 = sexp_ratio_to_double(x);
|
||||
}
|
||||
}
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
else if (sexp_complexp(x))
|
||||
return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e));
|
||||
#endif
|
||||
else
|
||||
return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
|
||||
|
|
|
|||
|
|
@ -49,11 +49,14 @@ sexp sexp_complex_normalize (sexp real);
|
|||
sexp sexp_complex_math_error (sexp ctx, sexp z);
|
||||
sexp sexp_complex_sqrt (sexp ctx, sexp z);
|
||||
sexp sexp_complex_exp (sexp ctx, sexp z);
|
||||
sexp sexp_complex_expt (sexp ctx, sexp a, sexp b);
|
||||
sexp sexp_complex_log (sexp ctx, sexp z);
|
||||
sexp sexp_complex_sin (sexp ctx, sexp z);
|
||||
sexp sexp_complex_cos (sexp ctx, sexp z);
|
||||
sexp sexp_complex_tan (sexp ctx, sexp z);
|
||||
sexp sexp_complex_asin (sexp ctx, sexp z);
|
||||
sexp sexp_complex_acos (sexp ctx, sexp z);
|
||||
sexp sexp_complex_atan (sexp ctx, sexp z);
|
||||
#endif
|
||||
|
||||
#endif /* ! SEXP_BIGNUM_H */
|
||||
|
|
|
|||
56
opt/bignum.c
56
opt/bignum.c
|
|
@ -597,8 +597,19 @@ static double sexp_to_double (sexp x) {
|
|||
return 0.0;
|
||||
}
|
||||
|
||||
sexp sexp_complex_math_error (sexp ctx, sexp z) {
|
||||
return sexp_type_exception(ctx, NULL, SEXP_NUMBER, z);
|
||||
static sexp sexp_to_complex (sexp ctx, sexp x) {
|
||||
sexp_gc_var1(tmp);
|
||||
if (sexp_flonump(x) || sexp_fixnump(x) || sexp_bignump(x)) {
|
||||
return sexp_make_complex(ctx, x, SEXP_ZERO);
|
||||
} else if (sexp_ratiop(x)) {
|
||||
sexp_gc_preserve1(ctx, tmp);
|
||||
tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
||||
sexp_complex_real(tmp) = sexp_make_flonum(ctx, sexp_to_double(x));
|
||||
sexp_gc_release1(ctx);
|
||||
return tmp;
|
||||
} else {
|
||||
return x;
|
||||
}
|
||||
}
|
||||
|
||||
sexp sexp_complex_sqrt (sexp ctx, sexp z) {
|
||||
|
|
@ -626,6 +637,17 @@ sexp sexp_complex_exp (sexp ctx, sexp z) {
|
|||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_complex_expt (sexp ctx, sexp a, sexp b) {
|
||||
sexp_gc_var1(res);
|
||||
sexp_gc_preserve1(ctx, res);
|
||||
res = sexp_to_complex(ctx, a);
|
||||
res = sexp_complex_log(ctx, res);
|
||||
res = sexp_mul(ctx, b, res);
|
||||
res = sexp_complex_exp(ctx, res);
|
||||
sexp_gc_release1(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_complex_log (sexp ctx, sexp z) {
|
||||
double x = sexp_to_double(sexp_complex_real(z)),
|
||||
y = sexp_to_double(sexp_complex_imag(z));
|
||||
|
|
@ -662,6 +684,17 @@ sexp sexp_complex_cos (sexp ctx, sexp z) {
|
|||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_complex_tan (sexp ctx, sexp z) {
|
||||
sexp res;
|
||||
sexp_gc_var2(sin, cos);
|
||||
sexp_gc_preserve2(ctx, sin, cos);
|
||||
sin = sexp_complex_sin(ctx, z);
|
||||
cos = sexp_complex_cos(ctx, z);
|
||||
res = sexp_complex_div(ctx, sin, cos);
|
||||
sexp_gc_release2(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_complex_asin (sexp ctx, sexp z) {
|
||||
sexp_gc_var2(res, tmp);
|
||||
sexp_gc_preserve2(ctx, res, tmp);
|
||||
|
|
@ -694,6 +727,25 @@ sexp sexp_complex_acos (sexp ctx, sexp z) {
|
|||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_complex_atan (sexp ctx, sexp z) {
|
||||
sexp_gc_var3(res, tmp1, tmp2);
|
||||
sexp_gc_preserve3(ctx, res, tmp1, tmp2);
|
||||
tmp1 = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ONE);
|
||||
tmp1 = sexp_complex_mul(ctx, z, tmp1);
|
||||
res = sexp_make_complex(ctx, SEXP_ONE, SEXP_ZERO);
|
||||
res = sexp_complex_sub(ctx, res, tmp1);
|
||||
res = sexp_complex_log(ctx, res);
|
||||
tmp2 = sexp_make_complex(ctx, SEXP_ONE, SEXP_ZERO);
|
||||
tmp2 = sexp_complex_add(ctx, tmp2, tmp1);
|
||||
tmp2 = sexp_complex_log(ctx, tmp2);
|
||||
res = sexp_complex_sub(ctx, res, tmp2);
|
||||
tmp1 = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ONE);
|
||||
sexp_complex_imag(tmp1) = sexp_make_flonum(ctx, 0.5);
|
||||
res = sexp_complex_mul(ctx, res, tmp1);
|
||||
sexp_gc_release2(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
#endif
|
||||
#endif
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue