mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-09 22:17:34 +02:00
initial complex number support
This commit is contained in:
Alex Shinn
parent
6202f9c1ff
commit
f5e07050ef
7 changed files with 349 additions and 24 deletions
67
eval.c
67
eval.c
|
|
@ -1177,23 +1177,53 @@ define_math_op(sexp_floor, floor)
|
|||
define_math_op(sexp_ceiling, ceil)
|
||||
|
||||
static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) {
|
||||
int negativep;
|
||||
double d, r;
|
||||
sexp_gc_var1(res);
|
||||
if (sexp_flonump(z))
|
||||
d = sexp_flonum_value(z);
|
||||
else if (sexp_fixnump(z))
|
||||
d = (double)sexp_unbox_fixnum(z);
|
||||
maybe_convert_bignum(z) /* XXXX add bignum sqrt */
|
||||
maybe_convert_ratio(z) /* XXXX add ratio sqrt */
|
||||
else
|
||||
return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
|
||||
sexp_gc_preserve1(ctx, res);
|
||||
#if SEXP_USE_COMPLEX
|
||||
if (d < 0) {
|
||||
negativep = 1;
|
||||
d = -d;
|
||||
}
|
||||
#endif
|
||||
r = sqrt(d);
|
||||
if (sexp_fixnump(z) && (((sexp_uint_t)r*(sexp_uint_t)r)==sexp_unbox_fixnum(z)))
|
||||
return sexp_make_fixnum(round(r));
|
||||
if (sexp_fixnump(z)
|
||||
&& (((sexp_uint_t)r*(sexp_uint_t)r)==abs(sexp_unbox_fixnum(z))))
|
||||
res = sexp_make_fixnum(round(r));
|
||||
else
|
||||
return sexp_make_flonum(ctx, r);
|
||||
res = sexp_make_flonum(ctx, r);
|
||||
#if SEXP_USE_COMPLEX
|
||||
if (negativep)
|
||||
res = sexp_make_complex(ctx, SEXP_ZERO, res);
|
||||
#endif
|
||||
sexp_gc_release1(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
#if SEXP_USE_RATIOS
|
||||
sexp sexp_generic_expt (sexp ctx, sexp x, sexp_sint_t e) {
|
||||
sexp_gc_var2(res, tmp);
|
||||
sexp_gc_preserve2(ctx, res, tmp);
|
||||
for (res = SEXP_ONE, tmp = x; e > 0; e >>= 1) {
|
||||
if (e&1) res = sexp_mul(ctx, res, tmp);
|
||||
tmp = sexp_mul(ctx, tmp, tmp);
|
||||
}
|
||||
sexp_gc_release2(ctx);
|
||||
return res;
|
||||
}
|
||||
#endif
|
||||
|
||||
static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
|
||||
long double f, x1, e1;
|
||||
sexp res;
|
||||
|
|
@ -1216,6 +1246,19 @@ static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
|
|||
#if SEXP_USE_FLONUMS
|
||||
else if (sexp_flonump(x))
|
||||
x1 = sexp_flonum_value(x);
|
||||
#endif
|
||||
#if SEXP_USE_RATIOS
|
||||
else if (sexp_ratiop(x)) {
|
||||
if (sexp_fixnump(e)) {
|
||||
return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e));
|
||||
} else {
|
||||
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);
|
||||
|
|
@ -1224,6 +1267,10 @@ static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
|
|||
#if SEXP_USE_FLONUMS
|
||||
else if (sexp_flonump(e))
|
||||
e1 = sexp_flonum_value(e);
|
||||
#endif
|
||||
#if SEXP_USE_RATIOS
|
||||
else if (sexp_ratiop(e))
|
||||
e1 = sexp_ratio_to_double(e);
|
||||
#endif
|
||||
else
|
||||
return sexp_type_exception(ctx, self, SEXP_FIXNUM, e);
|
||||
|
|
@ -1262,6 +1309,17 @@ static sexp sexp_ratio_denominator_op (sexp ctx sexp_api_params(self, n), sexp r
|
|||
}
|
||||
#endif
|
||||
|
||||
#if SEXP_USE_COMPLEX
|
||||
static sexp sexp_complex_real_op (sexp ctx sexp_api_params(self, n), sexp cpx) {
|
||||
sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx);
|
||||
return sexp_complex_real(cpx);
|
||||
}
|
||||
static sexp sexp_complex_imag_op (sexp ctx sexp_api_params(self, n), sexp cpx) {
|
||||
sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx);
|
||||
return sexp_complex_imag(cpx);
|
||||
}
|
||||
#endif
|
||||
|
||||
static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, sexp str2, sexp ci) {
|
||||
sexp_sint_t len1, len2, len, diff;
|
||||
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1);
|
||||
|
|
@ -1805,6 +1863,9 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
|
|||
#if SEXP_USE_AUTO_FORCE
|
||||
sexp_push(ctx, tmp, sym=sexp_intern(ctx, "auto-force", -1));
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
sexp_push(ctx, tmp, sym=sexp_intern(ctx, "complex", -1));
|
||||
#endif
|
||||
#if SEXP_USE_RATIOS
|
||||
sexp_push(ctx, tmp, sym=sexp_intern(ctx, "ratios", -1));
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -43,6 +43,10 @@ double sexp_ratio_to_double (sexp rat);
|
|||
sexp sexp_make_ratio (sexp ctx, sexp num, sexp den);
|
||||
sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in);
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
sexp sexp_make_complex (sexp ctx, sexp real, sexp image);
|
||||
sexp sexp_complex_normalize (sexp real);
|
||||
#endif
|
||||
|
||||
#endif /* ! SEXP_BIGNUM_H */
|
||||
|
||||
|
|
|
|||
|
|
@ -365,17 +365,16 @@
|
|||
#define SEXP_USE_RATIOS ! SEXP_USE_NO_FEATURES
|
||||
#endif
|
||||
|
||||
/* #ifndef SEXP_USE_COMPLEX */
|
||||
/* #define SEXP_USE_COMPLEX ! SEXP_USE_NO_FEATURES */
|
||||
/* #endif */
|
||||
#define SEXP_USE_COMPLEX 0
|
||||
#ifndef SEXP_USE_COMPLEX
|
||||
#define SEXP_USE_COMPLEX ! SEXP_USE_NO_FEATURES
|
||||
#endif
|
||||
|
||||
#ifndef SEXP_USE_BIGNUMS
|
||||
#define SEXP_USE_BIGNUMS (SEXP_USE_RATIOS || SEXP_USE_COMPLEX)
|
||||
#endif
|
||||
|
||||
#ifndef SEXP_USE_FLONUMS
|
||||
#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES
|
||||
#define SEXP_USE_FLONUMS (SEXP_USE_COMPLEX || ! SEXP_USE_NO_FEATURES)
|
||||
#endif
|
||||
|
||||
#ifndef SEXP_USE_INFINITIES
|
||||
|
|
|
|||
17
lib/init.scm
17
lib/init.scm
|
|
@ -961,10 +961,19 @@
|
|||
lo
|
||||
(lp (if (< (car ls) lo) (car ls) lo) (cdr ls)))))
|
||||
|
||||
(define (real-part z) z)
|
||||
(define (imag-part z) 0.0)
|
||||
(define magnitude abs)
|
||||
(define (angle z) (if (< z 0) 3.141592653589793 0))
|
||||
(cond-expand
|
||||
(complex
|
||||
(define (real-part z) (if (complex? z) (complex-real z) z))
|
||||
(define (imag-part z) (if (complex? z) (complex-imag z) 0.0))
|
||||
(define (magnitude z)
|
||||
(sqrt (+ (* (real-part z) (real-part z))
|
||||
(* (imag-part z) (imag-part z)))))
|
||||
(define (angle z) (atan (imag-part z) (real-part z))))
|
||||
(else
|
||||
(define (real-part z) z)
|
||||
(define (imag-part z) 0.0)
|
||||
(define magnitude abs)
|
||||
(define (angle z) (if (< z 0) 3.141592653589793 0))))
|
||||
|
||||
(define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -87,6 +87,11 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJ
|
|||
_FN1(_I(SEXP_FIXNUM), _I(SEXP_RATIO), "ratio-numerator", 0, sexp_ratio_numerator_op),
|
||||
_FN1(_I(SEXP_FIXNUM), _I(SEXP_RATIO), "ratio-denominator", 0, sexp_ratio_denominator_op),
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "complex?", _I(SEXP_COMPLEX), 0),
|
||||
_FN1(_I(SEXP_FLONUM), _I(SEXP_RATIO), "complex-real", 0, sexp_complex_real_op),
|
||||
_FN1(_I(SEXP_FLONUM), _I(SEXP_RATIO), "complex-imag", 0, sexp_complex_imag_op),
|
||||
#endif
|
||||
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "closure?", _I(SEXP_PROCEDURE), 0),
|
||||
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "opcode?", _I(SEXP_OPCODE), 0),
|
||||
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "input-port?", _I(SEXP_IPORT), 0),
|
||||
|
|
|
|||
162
opt/bignum.c
162
opt/bignum.c
|
|
@ -515,6 +515,62 @@ sexp sexp_ratio_compare (sexp ctx, sexp a, sexp b) {
|
|||
|
||||
#endif
|
||||
|
||||
/************************ complex numbers ****************************/
|
||||
|
||||
#if SEXP_USE_COMPLEX
|
||||
|
||||
sexp sexp_complex_add (sexp ctx, sexp a, sexp b) {
|
||||
sexp_gc_var3(res, real, imag);
|
||||
sexp_gc_preserve3(ctx, res, real, imag);
|
||||
real = sexp_add(ctx, sexp_complex_real(a), sexp_complex_real(b));
|
||||
imag = sexp_add(ctx, sexp_complex_imag(a), sexp_complex_imag(b));
|
||||
res = sexp_make_complex(ctx, real, imag);
|
||||
sexp_gc_release3(ctx);
|
||||
return sexp_complex_normalize(res);
|
||||
}
|
||||
|
||||
sexp sexp_complex_mul (sexp ctx, sexp a, sexp b) {
|
||||
sexp_gc_var3(res, real, imag);
|
||||
sexp_gc_preserve3(ctx, res, real, imag);
|
||||
real = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_real(b));
|
||||
res = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_imag(b));
|
||||
real = sexp_sub(ctx, real, res);
|
||||
imag = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_imag(b));
|
||||
res = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_real(b));
|
||||
imag = sexp_add(ctx, imag, res);
|
||||
res = sexp_make_complex(ctx, real, imag);
|
||||
sexp_gc_release3(ctx);
|
||||
return sexp_complex_normalize(res);
|
||||
}
|
||||
|
||||
/* (a + bi) (ac + bd) (bc - ad) */
|
||||
/* -------- = ----------- + ----------- i */
|
||||
/* (c + di) (c^2 + d^2) (c^2 + d^2) */
|
||||
|
||||
sexp sexp_complex_div (sexp ctx, sexp a, sexp b) {
|
||||
sexp_gc_var4(res, real, imag, denom);
|
||||
sexp_gc_preserve4(ctx, res, real, imag, denom);
|
||||
/* c^2 + d^2 */
|
||||
denom = sexp_mul(ctx, sexp_complex_real(b), sexp_complex_real(b));
|
||||
res = sexp_mul(ctx, sexp_complex_imag(b), sexp_complex_imag(b));
|
||||
denom = sexp_add(ctx, denom, res);
|
||||
/* ac + bd */
|
||||
real = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_real(b));
|
||||
res = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_imag(b));
|
||||
real = sexp_add(ctx, real, res);
|
||||
real = sexp_div(ctx, real, denom);
|
||||
/* bc - ad */
|
||||
imag = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_real(b));
|
||||
res = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_imag(b));
|
||||
imag = sexp_sub(ctx, imag, res);
|
||||
imag = sexp_div(ctx, imag, denom);
|
||||
res = sexp_make_complex(ctx, real, imag);
|
||||
sexp_gc_release4(ctx);
|
||||
return sexp_complex_normalize(res);
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
/****************** generic arithmetic ************************/
|
||||
|
||||
enum sexp_number_types {
|
||||
|
|
@ -613,6 +669,9 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
|
|||
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
|
||||
#if SEXP_USE_RATIOS
|
||||
case SEXP_NUM_NOT_RAT:
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_NOT_CPX:
|
||||
#endif
|
||||
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
|
||||
break;
|
||||
|
|
@ -645,6 +704,19 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
|
|||
case SEXP_NUM_RAT_RAT:
|
||||
r = sexp_ratio_add(ctx, a, b);
|
||||
break;
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_RAT_CPX:
|
||||
a = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
|
||||
/* ... FALLTHROUGH ... */
|
||||
case SEXP_NUM_FLO_CPX:
|
||||
case SEXP_NUM_FIX_CPX:
|
||||
case SEXP_NUM_BIG_CPX:
|
||||
a = tmp = sexp_make_complex(ctx, a, SEXP_ZERO);
|
||||
/* ... FALLTHROUGH ... */
|
||||
case SEXP_NUM_CPX_CPX:
|
||||
r = sexp_complex_add(ctx, a, b);
|
||||
break;
|
||||
#endif
|
||||
}
|
||||
sexp_gc_release1(ctx);
|
||||
|
|
@ -661,12 +733,18 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
|
|||
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
|
||||
#if SEXP_USE_RATIOS
|
||||
case SEXP_NUM_NOT_RAT:
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_NOT_CPX:
|
||||
#endif
|
||||
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
|
||||
break;
|
||||
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
|
||||
#if SEXP_USE_RATIOS
|
||||
case SEXP_NUM_RAT_NOT:
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_CPX_NOT:
|
||||
#endif
|
||||
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b);
|
||||
break;
|
||||
|
|
@ -729,6 +807,40 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
|
|||
}
|
||||
}
|
||||
break;
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_RAT_CPX:
|
||||
a = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
|
||||
goto complex_sub;
|
||||
case SEXP_NUM_CPX_RAT:
|
||||
b = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(b));
|
||||
/* ... FALLTHROUGH ... */
|
||||
case SEXP_NUM_CPX_FLO:
|
||||
case SEXP_NUM_CPX_FIX:
|
||||
case SEXP_NUM_CPX_BIG:
|
||||
tmp1 = a; a = b; b = tmp1;
|
||||
negatep = 1;
|
||||
/* ... FALLTHROUGH ... */
|
||||
case SEXP_NUM_FLO_CPX:
|
||||
case SEXP_NUM_FIX_CPX:
|
||||
case SEXP_NUM_BIG_CPX:
|
||||
a = tmp1 = sexp_make_complex(ctx, a, SEXP_ZERO);
|
||||
/* ... FALLTHROUGH ... */
|
||||
case SEXP_NUM_CPX_CPX:
|
||||
complex_sub:
|
||||
tmp2 = sexp_make_complex(ctx, sexp_complex_real(b), sexp_complex_imag(b));
|
||||
sexp_negate(sexp_complex_real(tmp2));
|
||||
sexp_negate(sexp_complex_imag(tmp2));
|
||||
r = sexp_complex_add(ctx, a, tmp2);
|
||||
if (negatep) {
|
||||
if (sexp_complexp(r)) {
|
||||
sexp_negate(sexp_complex_real(r));
|
||||
sexp_negate(sexp_complex_imag(r));
|
||||
} else {
|
||||
sexp_negate(r);
|
||||
}
|
||||
}
|
||||
break;
|
||||
#endif
|
||||
}
|
||||
sexp_gc_release2(ctx);
|
||||
|
|
@ -779,6 +891,18 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) {
|
|||
case SEXP_NUM_RAT_RAT:
|
||||
r = sexp_ratio_mul(ctx, a, b);
|
||||
break;
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_RAT_CPX:
|
||||
a = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
|
||||
case SEXP_NUM_FLO_CPX:
|
||||
case SEXP_NUM_FIX_CPX:
|
||||
case SEXP_NUM_BIG_CPX:
|
||||
a = tmp = sexp_make_complex(ctx, a, SEXP_ZERO);
|
||||
/* ... FALLTHROUGH ... */
|
||||
case SEXP_NUM_CPX_CPX:
|
||||
r = sexp_complex_mul(ctx, a, b);
|
||||
break;
|
||||
#endif
|
||||
}
|
||||
sexp_gc_release1(ctx);
|
||||
|
|
@ -857,6 +981,26 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
|
|||
case SEXP_NUM_RAT_RAT:
|
||||
r = sexp_ratio_div(ctx, a, b);
|
||||
break;
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_CPX_RAT:
|
||||
b = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(b));
|
||||
case SEXP_NUM_CPX_FLO:
|
||||
case SEXP_NUM_CPX_FIX:
|
||||
case SEXP_NUM_CPX_BIG:
|
||||
b = tmp = sexp_make_complex(ctx, b, SEXP_ZERO);
|
||||
case SEXP_NUM_RAT_CPX:
|
||||
if (sexp_ratiop(a))
|
||||
a = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
|
||||
case SEXP_NUM_FLO_CPX:
|
||||
case SEXP_NUM_FIX_CPX:
|
||||
case SEXP_NUM_BIG_CPX:
|
||||
if (!sexp_complexp(a))
|
||||
a = tmp = sexp_make_complex(ctx, a, SEXP_ZERO);
|
||||
/* ... FALLTHROUGH ... */
|
||||
case SEXP_NUM_CPX_CPX:
|
||||
r = sexp_complex_div(ctx, a, b);
|
||||
break;
|
||||
#endif
|
||||
}
|
||||
sexp_gc_release2(ctx);
|
||||
|
|
@ -880,12 +1024,19 @@ sexp sexp_quotient (sexp ctx, sexp a, sexp b) {
|
|||
#if SEXP_USE_RATIOS
|
||||
case SEXP_NUM_FLO_RAT: case SEXP_NUM_RAT_FIX: case SEXP_NUM_RAT_FLO:
|
||||
case SEXP_NUM_RAT_BIG: case SEXP_NUM_RAT_RAT:
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_FLO_CPX: case SEXP_NUM_CPX_FIX: case SEXP_NUM_CPX_FLO:
|
||||
case SEXP_NUM_CPX_BIG: case SEXP_NUM_CPX_RAT: case SEXP_NUM_CPX_CPX:
|
||||
#endif
|
||||
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
|
||||
break;
|
||||
case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO:
|
||||
#if SEXP_USE_RATIOS
|
||||
case SEXP_NUM_FIX_RAT: case SEXP_NUM_BIG_RAT:
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_FIX_CPX: case SEXP_NUM_BIG_CPX:
|
||||
#endif
|
||||
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
|
||||
break;
|
||||
|
|
@ -923,12 +1074,19 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
|
|||
#if SEXP_USE_RATIOS
|
||||
case SEXP_NUM_FLO_RAT: case SEXP_NUM_RAT_FIX: case SEXP_NUM_RAT_FLO:
|
||||
case SEXP_NUM_RAT_BIG: case SEXP_NUM_RAT_RAT:
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_FLO_CPX: case SEXP_NUM_CPX_FIX: case SEXP_NUM_CPX_FLO:
|
||||
case SEXP_NUM_CPX_BIG: case SEXP_NUM_CPX_RAT: case SEXP_NUM_CPX_CPX:
|
||||
#endif
|
||||
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
|
||||
break;
|
||||
case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO:
|
||||
#if SEXP_USE_RATIOS
|
||||
case SEXP_NUM_FIX_RAT: case SEXP_NUM_BIG_RAT:
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_FIX_CPX: case SEXP_NUM_BIG_CPX:
|
||||
#endif
|
||||
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
|
||||
break;
|
||||
|
|
@ -962,6 +1120,10 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
|
|||
switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
|
||||
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
|
||||
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
|
||||
#if SEXP_USE_COMPLEX
|
||||
case SEXP_NUM_CPX_CPX: case SEXP_NUM_CPX_FIX: case SEXP_NUM_CPX_RAT:
|
||||
case SEXP_NUM_CPX_FLO: case SEXP_NUM_CPX_BIG:
|
||||
#endif
|
||||
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
|
||||
break;
|
||||
case SEXP_NUM_FIX_FIX:
|
||||
|
|
|
|||
103
sexp.c
103
sexp.c
|
|
@ -1591,35 +1591,103 @@ sexp sexp_read_symbol (sexp ctx, sexp in, int init, int internp) {
|
|||
return res;
|
||||
}
|
||||
|
||||
#if SEXP_USE_COMPLEX
|
||||
sexp sexp_make_complex (sexp ctx, sexp real, sexp image) {
|
||||
sexp res = sexp_alloc_type(ctx, complex, SEXP_COMPLEX);
|
||||
sexp_complex_real(res) = real;
|
||||
sexp_complex_imag(res) = image;
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_complex_normalize (sexp cpx) {
|
||||
return sexp_complexp(cpx)
|
||||
&& (sexp_complex_imag(cpx) == SEXP_ZERO
|
||||
|| (sexp_flonump(sexp_complex_imag(cpx))
|
||||
&& sexp_flonum_value(sexp_complex_imag(cpx)) == 0.0))
|
||||
? sexp_complex_real(cpx) : cpx;
|
||||
}
|
||||
|
||||
sexp sexp_read_complex_tail (sexp ctx, sexp in, double real, int exactp) {
|
||||
int c = sexp_read_char(ctx, in), c2;
|
||||
sexp_gc_var1(res);
|
||||
sexp_gc_preserve1(ctx, res);
|
||||
if (c=='i' || c=='I') {
|
||||
trailing_i:
|
||||
c = sexp_read_char(ctx, in);
|
||||
if ((c!=EOF) && ! is_separator(c))
|
||||
res = sexp_read_error(ctx, "invalid complex numeric syntax", sexp_make_character(c), in);
|
||||
else
|
||||
sexp_push_char(ctx, c, in);
|
||||
if (!sexp_exceptionp(res)) {
|
||||
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
||||
sexp_complex_imag(res) = exactp ? sexp_make_fixnum(real) : sexp_make_flonum(ctx, real);
|
||||
}
|
||||
} else {
|
||||
c2 = sexp_read_char(ctx, in);
|
||||
if (c2=='i' || c2=='I') {
|
||||
real = 1.0;
|
||||
exactp = 1;
|
||||
goto trailing_i;
|
||||
} else {
|
||||
sexp_push_char(ctx, c2, in);
|
||||
}
|
||||
if (c=='-') sexp_push_char(ctx, c, in);
|
||||
res = sexp_read_number(ctx, in, 10);
|
||||
if (sexp_complexp(res)) {
|
||||
if (sexp_complex_real(res) == SEXP_ZERO)
|
||||
sexp_complex_real(res) = (exactp ? sexp_make_fixnum(real) : sexp_make_flonum(ctx, real));
|
||||
else
|
||||
res = sexp_read_error(ctx, "multiple real parts of complex", res, in);
|
||||
} else if ((res == SEXP_ZERO)
|
||||
|| (sexp_flonump(res) && sexp_flonum_value(res) == 0.0)) {
|
||||
res = sexp_make_complex(ctx, (exactp ? sexp_make_fixnum(real) : sexp_make_flonum(ctx, real)), res);
|
||||
} else {
|
||||
res = sexp_exceptionp(res) ? res
|
||||
: sexp_read_error(ctx, "missing imaginary part of complex", res, in);
|
||||
}
|
||||
}
|
||||
sexp_gc_release1(ctx);
|
||||
return sexp_complex_normalize(res);
|
||||
}
|
||||
#endif
|
||||
|
||||
sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) {
|
||||
sexp exponent=SEXP_VOID;
|
||||
double res=0.0, scale=0.1, e=0.0;
|
||||
double val=0.0, scale=0.1, e=0.0;
|
||||
int c;
|
||||
for (c=sexp_read_char(ctx, in);
|
||||
isdigit(c);
|
||||
c=sexp_read_char(ctx, in), scale*=0.1)
|
||||
res += digit_value(c)*scale;
|
||||
val += digit_value(c)*scale;
|
||||
#if SEXP_USE_PLACEHOLDER_DIGITS
|
||||
for (; c==SEXP_PLACEHOLDER_DIGIT; c=sexp_read_char(ctx, in), scale*=0.1)
|
||||
res += sexp_placeholder_digit_value(10)*scale;
|
||||
val += sexp_placeholder_digit_value(10)*scale;
|
||||
#endif
|
||||
if (c=='e' || c=='E') {
|
||||
exponent = sexp_read_number(ctx, in, 10);
|
||||
if (sexp_exceptionp(exponent)) return exponent;
|
||||
e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(exponent)
|
||||
: sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0);
|
||||
} else if ((c!=EOF) && ! is_separator(c)) {
|
||||
}
|
||||
val = (whole + val) * pow(10, e);
|
||||
if (negp) val *= -1;
|
||||
if (!(c=='e' || c=='E')) {
|
||||
#if SEXP_USE_COMPLEX
|
||||
if (c=='i' || c=='i' || c=='+' || c=='-') {
|
||||
sexp_push_char(ctx, c, in);
|
||||
return sexp_read_complex_tail(ctx, in, val, 0);
|
||||
} else
|
||||
#endif
|
||||
if ((c!=EOF) && ! is_separator(c))
|
||||
return sexp_read_error(ctx, "invalid numeric syntax",
|
||||
sexp_make_character(c), in);
|
||||
} else {
|
||||
else
|
||||
sexp_push_char(ctx, c, in);
|
||||
}
|
||||
#if SEXP_USE_FLONUMS
|
||||
res = (whole + res) * pow(10, e);
|
||||
if (negp) res *= -1;
|
||||
return sexp_make_flonum(ctx, res);
|
||||
return sexp_make_flonum(ctx, val);
|
||||
#else
|
||||
return sexp_make_fixnum((sexp_uint_t)whole);
|
||||
return sexp_make_fixnum((sexp_uint_t)val);
|
||||
#endif
|
||||
}
|
||||
|
||||
|
|
@ -1676,6 +1744,10 @@ sexp sexp_read_number (sexp ctx, sexp in, int base) {
|
|||
c = sexp_read_char(ctx, in);
|
||||
}
|
||||
|
||||
#if SEXP_USE_COMPLEX
|
||||
if (c == 'i' || c == 'I') whole = 1.0;
|
||||
#endif
|
||||
|
||||
for ( ; sexp_isxdigit(c); c=sexp_read_char(ctx, in)) {
|
||||
digit = digit_value(c);
|
||||
if ((digit < 0) || (digit >= base))
|
||||
|
|
@ -1733,6 +1805,13 @@ sexp sexp_read_number (sexp ctx, sexp in, int base) {
|
|||
#endif
|
||||
sexp_gc_release2(ctx);
|
||||
return res;
|
||||
#if SEXP_USE_COMPLEX
|
||||
} else if (c=='i' || c=='I' || c=='+' || c=='-') {
|
||||
if (base != 10)
|
||||
return sexp_read_error(ctx, "found non-base 10 complex", SEXP_NULL, in);
|
||||
sexp_push_char(ctx, c, in);
|
||||
return sexp_read_complex_tail(ctx, in, (negativep ? -val : val), 1);
|
||||
#endif
|
||||
} else {
|
||||
if ((c!=EOF) && ! is_separator(c))
|
||||
return sexp_read_error(ctx, "invalid numeric syntax",
|
||||
|
|
@ -2068,6 +2147,12 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
res = sexp_make_flonum(ctx, sexp_neg_infinity);
|
||||
else if (res == sexp_intern(ctx, "+nan.0", -1))
|
||||
res = sexp_make_flonum(ctx, sexp_nan);
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
if (res == sexp_intern(ctx, "+i", -1))
|
||||
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ONE);
|
||||
else if (res == sexp_intern(ctx, "-i", -1))
|
||||
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_NEG_ONE);
|
||||
#endif
|
||||
}
|
||||
break;
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue