Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 06:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fixing complex parsing following ratios and bignums.

Browse source
This commit is contained in:
Alex Shinn 2011-12-18 15:35:34 +09:00
parent 5e4158a390
commit ea1e22d2f0
4 changed files with 87 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
doc/lib/chibi/match.html
View file

@ -28,7 +28,7 @@ span.paren5 { color: #222222; background-color: inherit; }
span.paren6 { color: #000000; background-color: inherit; } span.paren6 { color: #000000; background-color: inherit; }
</style> </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) ...) </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> 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> package by Andrew Wright, written in fully portable <code><span>syntax-rules</span></code>
and thus preserving hygiene. 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, 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, 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, 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 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 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 the body with all match variables in scope. Raises an error if
any of the expressions fail to match. Syntax analogous to named any of the expressions fail to match. Syntax analogous to named
let can also be used for recursive functions which match on their 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> 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> 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 matches and binds the variables in sequence, with preceding match

15
include/chibi/sexp.h
View file

@ -599,9 +599,21 @@ sexp sexp_make_flonum(sexp ctx, double f);
#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR)) #define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR))
#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) #define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT))
#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) #define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT))
#if SEXP_USE_BIGNUMS
#define sexp_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) #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)) #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)) #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_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER))
#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION)) #define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION))
#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE)) #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_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_symbol (sexp ctx, sexp in, int init, int internp);
SEXP_API sexp sexp_read_number (sexp ctx, sexp in, int base); 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_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_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); SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len);

6
opt/bignum.c
View file

@ -229,6 +229,12 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
res = sexp_make_ratio(ctx, res, SEXP_ONE); res = sexp_make_ratio(ctx, res, SEXP_ONE);
sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10); sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10);
res = sexp_ratio_normalize(ctx, res, in); 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 #endif
} else if ((c!=EOF) && ! is_separator(c)) { } else if ((c!=EOF) && ! is_separator(c)) {
res = sexp_read_error(ctx, "invalid numeric syntax", res = sexp_read_error(ctx, "invalid numeric syntax",

72
sexp.c
View file

@ -1581,6 +1581,9 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
sexp_write(ctx, sexp_complex_real(obj), out); sexp_write(ctx, sexp_complex_real(obj), out);
if (!sexp_negativep(sexp_complex_imag(obj))) if (!sexp_negativep(sexp_complex_imag(obj)))
sexp_write_char(ctx, '+', out); sexp_write_char(ctx, '+', 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(ctx, sexp_complex_imag(obj), out);
sexp_write_char(ctx, 'i', out); sexp_write_char(ctx, 'i', out);
break; break;
@ -1864,55 +1867,57 @@ sexp sexp_complex_normalize (sexp cpx) {
? sexp_complex_real(cpx) : 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; int c = sexp_read_char(ctx, in), c2;
sexp default_real = SEXP_ZERO;
sexp_gc_var1(res); sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res); sexp_gc_preserve1(ctx, res);
res = SEXP_VOID; res = SEXP_VOID;
if (c=='i' || c=='I') { if (c=='i' || c=='I') { /* trailing i, no sign */
trailing_i: trailing_i:
c = sexp_read_char(ctx, in); c = sexp_read_char(ctx, in);
if ((c!=EOF) && ! is_separator(c)) if ((c!=EOF) && ! is_separator(c))
res = sexp_read_error(ctx, "invalid complex numeric syntax", sexp_make_character(c), in); res = sexp_read_error(ctx, "invalid complex numeric syntax", sexp_make_character(c), in);
else else
sexp_push_char(ctx, c, in); sexp_push_char(ctx, c, in);
if (!sexp_exceptionp(res)) { if (!sexp_exceptionp(res))
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO); res = sexp_make_complex(ctx, default_real, real); /* NNNNi has 0 real */
sexp_complex_imag(res) = exactp ? sexp_make_fixnum(real) : sexp_make_flonum(ctx, real); } else { /* trailing + or - */
}
} else {
c2 = sexp_read_char(ctx, in); c2 = sexp_read_char(ctx, in);
if (c2=='i' || c2=='I') { if (c2=='i' || c2=='I') {
real = 1.0; default_real = real;
exactp = 1; real = (c=='-') ? SEXP_NEG_ONE : SEXP_ONE;
goto trailing_i; goto trailing_i;
} else { } else {
sexp_push_char(ctx, c2, in); sexp_push_char(ctx, c2, in);
} /* read imaginary part */
if (c=='-') sexp_push_char(ctx, c, in); if (c=='-') sexp_push_char(ctx, c, in);
res = sexp_read_number(ctx, in, 10); res = sexp_read_number(ctx, in, 10);
if (sexp_complexp(res)) { if (sexp_complexp(res)) {
if (sexp_complex_real(res) == SEXP_ZERO) if (sexp_complex_real(res) == SEXP_ZERO)
sexp_complex_real(res) = (exactp ? sexp_make_fixnum(real) : sexp_make_flonum(ctx, real)); sexp_complex_real(res) = real;
else else
res = sexp_read_error(ctx, "multiple real parts of complex", res, in); res = sexp_read_error(ctx, "multiple real parts of complex", res, in);
} else if ((res == SEXP_ZERO) } else if ((res == SEXP_ZERO)
|| (sexp_flonump(res) && sexp_flonum_value(res) == 0.0)) { || (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); res = sexp_make_complex(ctx, real, res);
} else { } else { /* found trailing +/-NNNN with no i */
res = sexp_exceptionp(res) ? res res = sexp_exceptionp(res) ? res
: sexp_read_error(ctx, "missing imaginary part of complex", res, in); : sexp_read_error(ctx, "missing imaginary part of complex", res, in);
} }
} }
}
sexp_gc_release1(ctx); sexp_gc_release1(ctx);
return sexp_complex_normalize(res); return sexp_complex_normalize(res);
} }
#endif #endif
sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) { sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) {
int c;
sexp exponent=SEXP_VOID; sexp exponent=SEXP_VOID;
double val=0.0, scale=0.1, e=0.0; 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); for (c=sexp_read_char(ctx, in); sexp_isdigit(c);
c=sexp_read_char(ctx, in), scale*=0.1) c=sexp_read_char(ctx, in), scale*=0.1)
val += digit_value(c)*scale; 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); val = (whole + val) * pow(10, e);
if (negp) val *= -1; 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 (!(c=='e' || c=='E')) {
#if SEXP_USE_COMPLEX #if SEXP_USE_COMPLEX
if (c=='i' || c=='i' || c=='+' || c=='-') { if (c=='i' || c=='i' || c=='+' || c=='-') {
sexp_push_char(ctx, c, in); sexp_push_char(ctx, c, in);
return sexp_read_complex_tail(ctx, in, val, 0); res = sexp_read_complex_tail(ctx, in, res);
} else } else
#endif #endif
if ((c!=EOF) && ! is_separator(c)) if ((c!=EOF) && ! is_separator(c))
return sexp_read_error(ctx, "invalid numeric syntax", res = sexp_read_error(ctx, "invalid numeric syntax",
sexp_make_character(c), in); sexp_make_character(c), in);
else else
sexp_push_char(ctx, c, in); sexp_push_char(ctx, c, in);
} }
#if SEXP_USE_FLONUMS sexp_gc_release1(ctx);
return sexp_make_flonum(ctx, val); return res;
#else
return sexp_make_fixnum((sexp_uint_t)val);
#endif
} }
#if SEXP_USE_RATIOS #if SEXP_USE_RATIOS
@ -2050,16 +2057,33 @@ sexp sexp_read_number (sexp ctx, sexp in, int base) {
} else if (c=='/') { } else if (c=='/') {
sexp_gc_preserve2(ctx, res, den); sexp_gc_preserve2(ctx, res, den);
den = sexp_read_number(ctx, in, base); den = sexp_read_number(ctx, in, base);
if (! (sexp_fixnump(den) || sexp_bignump(den))) if (! (sexp_fixnump(den) || sexp_bignump(den) || sexp_complexp(den)))
return (sexp_exceptionp(den) res = (sexp_exceptionp(den)
? den : sexp_read_error(ctx, "invalid rational syntax", den, in)); ? den : sexp_read_error(ctx, "invalid rational syntax", den, in));
else {
#if SEXP_USE_RATIOS #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_make_ratio(ctx, sexp_make_fixnum(negativep ? -val : val), den);
res = sexp_ratio_normalize(ctx, res, in); res = sexp_ratio_normalize(ctx, res, in);
} while (0);
#else #else
res = sexp_make_flonum(ctx, (double)(negativep ? -val : val) res = sexp_make_flonum(ctx, (double)(negativep ? -val : val)
/ (double)sexp_unbox_fixnum(den)); / (double)sexp_unbox_fixnum(den));
#endif #endif
}
sexp_gc_release2(ctx); sexp_gc_release2(ctx);
return res; return res;
#if SEXP_USE_COMPLEX #if SEXP_USE_COMPLEX
@ -2067,7 +2091,7 @@ sexp sexp_read_number (sexp ctx, sexp in, int base) {
if (base != 10) if (base != 10)
return sexp_read_error(ctx, "found non-base 10 complex", SEXP_NULL, in); return sexp_read_error(ctx, "found non-base 10 complex", SEXP_NULL, in);
sexp_push_char(ctx, c, 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 #endif
} else { } else {
if ((c!=EOF) && ! is_separator(c)) if ((c!=EOF) && ! is_separator(c))