From f5e07050efa60460a3f81496291ea1aad907b713 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 31 Jul 2011 21:39:31 +0900 Subject: [PATCH] initial complex number support --- eval.c | 67 +++++++++++++++- include/chibi/bignum.h | 4 + include/chibi/features.h | 9 +-- lib/init.scm | 17 +++- opcodes.c | 5 ++ opt/bignum.c | 162 +++++++++++++++++++++++++++++++++++++++ sexp.c | 109 +++++++++++++++++++++++--- 7 files changed, 349 insertions(+), 24 deletions(-) diff --git a/eval.c b/eval.c index 47ba5042..a59e4254 100644 --- a/eval.c +++ b/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 diff --git a/include/chibi/bignum.h b/include/chibi/bignum.h index 03b416d4..8d75fe28 100644 --- a/include/chibi/bignum.h +++ b/include/chibi/bignum.h @@ -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 */ diff --git a/include/chibi/features.h b/include/chibi/features.h index 08bc157c..b519f51b 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.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 diff --git a/lib/init.scm b/lib/init.scm index 8ff79c19..06633044 100644 --- a/lib/init.scm +++ b/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))))) diff --git a/opcodes.c b/opcodes.c index 6f812e4e..8a3ae052 100644 --- a/opcodes.c +++ b/opcodes.c @@ -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), diff --git a/opt/bignum.c b/opt/bignum.c index b347706d..47f8aa21 100644 --- a/opt/bignum.c +++ b/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: diff --git a/sexp.c b/sexp.c index c1209c01..3bf5c0c4 100644 --- a/sexp.c +++ b/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)) { - return sexp_read_error(ctx, "invalid numeric syntax", - sexp_make_character(c), in); - } else { - sexp_push_char(ctx, c, in); + } + 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 + 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;