mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 06:09:18 +02:00
Fixing complex parsing following ratios and bignums.
This commit is contained in:
Alex Shinn
parent
5e4158a390
commit
ea1e22d2f0
4 changed files with 87 additions and 42 deletions
|
|
@ -28,7 +28,7 @@ span.paren5 { color: #222222; background-color: inherit; }
|
|||
span.paren6 { color: #000000; background-color: inherit; }
|
||||
</style>
|
||||
</head><body><div id="menu"><ol><li><a href="#h3_Patterns">Patterns</a></li><li><a href="#h3_Syntax">Syntax</a><ol><li><a href="#h4_(matchexpr(pattern.body)...)(matchexpr(pattern(=>failure).body)...)">(match expr (pattern . body) ...)
|
||||
(match expr (pattern (=> failure) . body) ...)</a></li><li><a href="#h4_match-lambda">(match-lambda (pattern . body) ...)</a></li><li><a href="#h4_match-lambda*">(match-lambda* (pattern . body) ...)</a></li><li><a href="#h4_match-let">(match-let ((var value) ...) . body)(match-let loop ((var init) ...) . body)</a></li><li><a href="#h4_match-letrec">(match-letrec ((var value) ...) . body)</a></li><li><a href="#h4_(match-let*((varvalue)...)body...)">(match-let* ((var value) ...) body ...)</a></li></ol></li></ol></div><div id="main"><h1>(chibi match)</h1><p>
|
||||
(match expr (pattern (=> failure) . body) ...)</a></li><li><a href="#h4_match-let">(match-verify-no-ellipses (x . y) sk)(match-verify-no-ellipses () sk)(match-verify-no-ellipses x sk)</a></li><li><a href="#h4_match-let*">(match-gen-search v p q g+s sk fk i ((id id-ls) ...))</a></li><li><a href="#h4_(match-let*((varvalue)...)body...)">(match-let* ((var value) ...) body ...)</a></li></ol></li></ol></div><div id="main"><h1>(chibi match)</h1><p>
|
||||
This is a full superset of the popular <a href="http://www.cs.indiana.edu/scheme-repository/code.match.html">match</a>
|
||||
package by Andrew Wright, written in fully portable <code><span>syntax-rules</span></code>
|
||||
and thus preserving hygiene.
|
||||
|
|
@ -173,15 +173,15 @@ and the result of the last expression is returned as the result
|
|||
of the entire <code><span>match</span></code>. If a <code>failure</code> is provided,
|
||||
then it is bound to a procedure of no arguments which continues,
|
||||
processing at the next <code>pattern</code>. If no <code>pattern</code> matches,
|
||||
an error is signalled.</p><div><a name="h4_match-lambda"></a><h4><code>(match-lambda (pattern . body) ...)</code></h4></div><p>Shortcut for <code><span>lambda</span></code> + <code><span>match</span></code>. Creates a
|
||||
an error is signalled.</p><div><a name="h4_match-let"></a><h4><code>(match-verify-no-ellipses (x . y) sk)<br></br>(match-verify-no-ellipses () sk)<br></br>(match-verify-no-ellipses x sk)</code></h4></div><div><a name="h4_match-let*"></a><h4><code>(match-gen-search v p q g+s sk fk i ((id id-ls) ...))</code></h4></div><p>Shortcut for <code><span>lambda</span></code> + <code><span>match</span></code>. Creates a
|
||||
procedure of one argument, and matches that argument against each
|
||||
clause.</p><div><a name="h4_match-lambda*"></a><h4><code>(match-lambda* (pattern . body) ...)</code></h4></div><p>Similar to <code><span>match-lambda</span></code>. Creates a procedure of any
|
||||
clause.Similar to <code><span>match-lambda</span></code>. Creates a procedure of any
|
||||
number of arguments, and matches the argument list against each
|
||||
clause.</p><div><a name="h4_match-let"></a><h4><code>(match-let ((var value) ...) . body)<br></br>(match-let loop ((var init) ...) . body)</code></h4></div><p>Matches each var to the corresponding expression, and evaluates
|
||||
clause.Matches each var to the corresponding expression, and evaluates
|
||||
the body with all match variables in scope. Raises an error if
|
||||
any of the expressions fail to match. Syntax analogous to named
|
||||
let can also be used for recursive functions which match on their
|
||||
arguments as in <code><span>match-lambda*</span></code>.</p><div><a name="h4_match-letrec"></a><h4><code>(match-letrec ((var value) ...) . body)</code></h4></div><p>Similar to <code><span>match-let</span></code>, but analogously to <code><span>letrec</span></code>
|
||||
arguments as in <code><span>match-lambda*</span></code>.Similar to <code><span>match-let</span></code>, but analogously to <code><span>letrec</span></code>
|
||||
matches and binds the variables with all match variables in scope.</p><div><a name="h4_(match-let*((varvalue)...)body...)"></a><h4><code>(match-let* ((var value) ...) body ...)</code></h4></div><p>
|
||||
Similar to <code><span>match-let</span></code>, but analogously to <code><span>let*</span></code>
|
||||
matches and binds the variables in sequence, with preceding match
|
||||
|
|
|
|||
|
|
@ -599,9 +599,21 @@ sexp sexp_make_flonum(sexp ctx, double f);
|
|||
#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR))
|
||||
#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT))
|
||||
#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT))
|
||||
#if SEXP_USE_BIGNUMS
|
||||
#define sexp_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM))
|
||||
#else
|
||||
#define sexp_bignump(x) 0
|
||||
#endif
|
||||
#if SEXP_USE_RATIOS
|
||||
#define sexp_ratiop(x) (sexp_check_tag(x, SEXP_RATIO))
|
||||
#else
|
||||
#define sexp_ratiop(x) 0
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
#define sexp_complexp(x) (sexp_check_tag(x, SEXP_COMPLEX))
|
||||
#else
|
||||
#define sexp_complexp(x) 0
|
||||
#endif
|
||||
#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER))
|
||||
#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION))
|
||||
#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE))
|
||||
|
|
@ -1217,6 +1229,9 @@ SEXP_API sexp sexp_flush_output_op (sexp ctx, sexp self, sexp_sint_t n, sexp out
|
|||
SEXP_API sexp sexp_read_string (sexp ctx, sexp in, int sentinel);
|
||||
SEXP_API sexp sexp_read_symbol (sexp ctx, sexp in, int init, int internp);
|
||||
SEXP_API sexp sexp_read_number (sexp ctx, sexp in, int base);
|
||||
#if SEXP_USE_COMPLEX
|
||||
SEXP_API sexp sexp_read_complex_tail(sexp ctx, sexp in, sexp res);
|
||||
#endif
|
||||
SEXP_API sexp sexp_read_raw (sexp ctx, sexp in);
|
||||
SEXP_API sexp sexp_read_op (sexp ctx, sexp self, sexp_sint_t n, sexp in);
|
||||
SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len);
|
||||
|
|
|
|||
|
|
@ -229,6 +229,12 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
|
|||
res = sexp_make_ratio(ctx, res, SEXP_ONE);
|
||||
sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10);
|
||||
res = sexp_ratio_normalize(ctx, res, in);
|
||||
#endif
|
||||
#if SEXP_USE_COMPLEX
|
||||
} else if (c=='i' || c=='i' || c=='+' || c=='-') {
|
||||
sexp_push_char(ctx, c, in);
|
||||
res = sexp_bignum_normalize(res);
|
||||
res = sexp_read_complex_tail(ctx, in, res);
|
||||
#endif
|
||||
} else if ((c!=EOF) && ! is_separator(c)) {
|
||||
res = sexp_read_error(ctx, "invalid numeric syntax",
|
||||
|
|
|
|||
98
sexp.c
98
sexp.c
|
|
@ -1581,7 +1581,10 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
|
|||
sexp_write(ctx, sexp_complex_real(obj), out);
|
||||
if (!sexp_negativep(sexp_complex_imag(obj)))
|
||||
sexp_write_char(ctx, '+', out);
|
||||
sexp_write(ctx, sexp_complex_imag(obj), out);
|
||||
if (sexp_complex_imag(obj) == SEXP_NEG_ONE)
|
||||
sexp_write_char(ctx, '-', out);
|
||||
else if (sexp_complex_imag(obj) != SEXP_ONE)
|
||||
sexp_write(ctx, sexp_complex_imag(obj), out);
|
||||
sexp_write_char(ctx, 'i', out);
|
||||
break;
|
||||
#endif
|
||||
|
|
@ -1864,44 +1867,44 @@ sexp sexp_complex_normalize (sexp cpx) {
|
|||
? sexp_complex_real(cpx) : cpx;
|
||||
}
|
||||
|
||||
sexp sexp_read_complex_tail (sexp ctx, sexp in, double real, int exactp) {
|
||||
sexp sexp_read_complex_tail (sexp ctx, sexp in, sexp real) {
|
||||
int c = sexp_read_char(ctx, in), c2;
|
||||
sexp default_real = SEXP_ZERO;
|
||||
sexp_gc_var1(res);
|
||||
sexp_gc_preserve1(ctx, res);
|
||||
res = SEXP_VOID;
|
||||
if (c=='i' || c=='I') {
|
||||
if (c=='i' || c=='I') { /* trailing i, no sign */
|
||||
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 {
|
||||
if (!sexp_exceptionp(res))
|
||||
res = sexp_make_complex(ctx, default_real, real); /* NNNNi has 0 real */
|
||||
} else { /* trailing + or - */
|
||||
c2 = sexp_read_char(ctx, in);
|
||||
if (c2=='i' || c2=='I') {
|
||||
real = 1.0;
|
||||
exactp = 1;
|
||||
default_real = real;
|
||||
real = (c=='-') ? SEXP_NEG_ONE : SEXP_ONE;
|
||||
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);
|
||||
/* read imaginary part */
|
||||
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) = 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, real, res);
|
||||
} else { /* found trailing +/-NNNN with no i */
|
||||
res = sexp_exceptionp(res) ? res
|
||||
: sexp_read_error(ctx, "missing imaginary part of complex", res, in);
|
||||
}
|
||||
}
|
||||
}
|
||||
sexp_gc_release1(ctx);
|
||||
|
|
@ -1910,9 +1913,11 @@ sexp sexp_read_complex_tail (sexp ctx, sexp in, double real, int exactp) {
|
|||
#endif
|
||||
|
||||
sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) {
|
||||
int c;
|
||||
sexp exponent=SEXP_VOID;
|
||||
double val=0.0, scale=0.1, e=0.0;
|
||||
int c;
|
||||
sexp_gc_var1(res);
|
||||
sexp_gc_preserve1(ctx, res);
|
||||
for (c=sexp_read_char(ctx, in); sexp_isdigit(c);
|
||||
c=sexp_read_char(ctx, in), scale*=0.1)
|
||||
val += digit_value(c)*scale;
|
||||
|
|
@ -1928,24 +1933,26 @@ sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) {
|
|||
}
|
||||
val = (whole + val) * pow(10, e);
|
||||
if (negp) val *= -1;
|
||||
#if SEXP_USE_FLONUMS
|
||||
res = sexp_make_flonum(ctx, val);
|
||||
#else
|
||||
res = sexp_make_fixnum((sexp_uint_t)val);
|
||||
#endif
|
||||
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);
|
||||
res = sexp_read_complex_tail(ctx, in, res);
|
||||
} else
|
||||
#endif
|
||||
if ((c!=EOF) && ! is_separator(c))
|
||||
return sexp_read_error(ctx, "invalid numeric syntax",
|
||||
sexp_make_character(c), in);
|
||||
res = sexp_read_error(ctx, "invalid numeric syntax",
|
||||
sexp_make_character(c), in);
|
||||
else
|
||||
sexp_push_char(ctx, c, in);
|
||||
}
|
||||
#if SEXP_USE_FLONUMS
|
||||
return sexp_make_flonum(ctx, val);
|
||||
#else
|
||||
return sexp_make_fixnum((sexp_uint_t)val);
|
||||
#endif
|
||||
sexp_gc_release1(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
#if SEXP_USE_RATIOS
|
||||
|
|
@ -2050,16 +2057,33 @@ sexp sexp_read_number (sexp ctx, sexp in, int base) {
|
|||
} else if (c=='/') {
|
||||
sexp_gc_preserve2(ctx, res, den);
|
||||
den = sexp_read_number(ctx, in, base);
|
||||
if (! (sexp_fixnump(den) || sexp_bignump(den)))
|
||||
return (sexp_exceptionp(den)
|
||||
? den : sexp_read_error(ctx, "invalid rational syntax", den, in));
|
||||
if (! (sexp_fixnump(den) || sexp_bignump(den) || sexp_complexp(den)))
|
||||
res = (sexp_exceptionp(den)
|
||||
? den : sexp_read_error(ctx, "invalid rational syntax", den, in));
|
||||
else {
|
||||
#if SEXP_USE_RATIOS
|
||||
#if SEXP_USE_COMPLEX
|
||||
if (sexp_complexp(den)) {
|
||||
res = sexp_make_fixnum(negativep ? -val : val);
|
||||
if (sexp_complex_real(den) == SEXP_ZERO) {
|
||||
res = sexp_make_ratio(ctx, res, sexp_complex_imag(den));
|
||||
sexp_complex_imag(den) = sexp_ratio_normalize(ctx, res, in);
|
||||
} else {
|
||||
res = sexp_make_ratio(ctx, res, sexp_complex_real(den));
|
||||
sexp_complex_real(den) = sexp_ratio_normalize(ctx, res, in);
|
||||
}
|
||||
res = den;
|
||||
} else
|
||||
#endif
|
||||
do {
|
||||
res = sexp_make_ratio(ctx, sexp_make_fixnum(negativep ? -val : val), den);
|
||||
res = sexp_ratio_normalize(ctx, res, in);
|
||||
} while (0);
|
||||
#else
|
||||
res = sexp_make_flonum(ctx, (double)(negativep ? -val : val)
|
||||
/ (double)sexp_unbox_fixnum(den));
|
||||
#endif
|
||||
}
|
||||
sexp_gc_release2(ctx);
|
||||
return res;
|
||||
#if SEXP_USE_COMPLEX
|
||||
|
|
@ -2067,7 +2091,7 @@ sexp sexp_read_number (sexp ctx, sexp in, int base) {
|
|||
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);
|
||||
return sexp_read_complex_tail(ctx, in, sexp_make_fixnum(negativep ? -val : val));
|
||||
#endif
|
||||
} else {
|
||||
if ((c!=EOF) && ! is_separator(c))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue