mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
fix reading circular refs inside vectors
This commit is contained in:
Alex Shinn
parent
97297221fa
commit
fb24b831b8
3 changed files with 38 additions and 21 deletions
11
eval.c
11
eval.c
|
|
@ -591,16 +591,17 @@ sexp sexp_syntactic_closure_expr_op (sexp ctx, sexp self, sexp_sint_t n, sexp x)
|
|||
return (sexp_synclop(x) ? sexp_synclo_expr(x) : x);
|
||||
}
|
||||
|
||||
sexp sexp_strip_synclos (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
||||
sexp sexp_strip_synclos_bound (sexp ctx, sexp x, int depth) {
|
||||
sexp_gc_var3(res, kar, kdr);
|
||||
if (depth <= 0) return x;
|
||||
sexp_gc_preserve3(ctx, res, kar, kdr);
|
||||
loop:
|
||||
if (sexp_synclop(x)) {
|
||||
x = sexp_synclo_expr(x);
|
||||
goto loop;
|
||||
} else if (sexp_pairp(x) && sexp_truep(sexp_length(ctx, x))) {
|
||||
kar = sexp_strip_synclos(ctx, self, n, sexp_car(x));
|
||||
kdr = sexp_strip_synclos(ctx, self, n, sexp_cdr(x));
|
||||
kar = sexp_strip_synclos_bound(ctx, sexp_car(x), depth-1);
|
||||
kdr = sexp_strip_synclos_bound(ctx, sexp_cdr(x), depth-1);
|
||||
res = sexp_cons(ctx, kar, kdr);
|
||||
sexp_pair_source(res) = sexp_pair_source(x);
|
||||
sexp_immutablep(res) = 1;
|
||||
|
|
@ -611,6 +612,10 @@ sexp sexp_strip_synclos (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
|||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_strip_synclos (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
||||
return sexp_strip_synclos_bound(ctx, x, SEXP_STRIP_SYNCLOS_BOUND);
|
||||
}
|
||||
|
||||
sexp sexp_identifier_eq_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp id1, sexp e2, sexp id2) {
|
||||
sexp cell1, cell2;
|
||||
cell1 = sexp_env_cell(ctx, e1, id1, 0);
|
||||
|
|
|
|||
|
|
@ -684,6 +684,10 @@
|
|||
#define SEXP_DEFAULT_EQUAL_BOUND 100000000
|
||||
#endif
|
||||
|
||||
#ifndef SEXP_STRIP_SYNCLOS_BOUND
|
||||
#define SEXP_STRIP_SYNCLOS_BOUND 10000
|
||||
#endif
|
||||
|
||||
#ifndef SEXP_POLL_SLEEP_TIME
|
||||
#define SEXP_POLL_SLEEP_TIME 5000
|
||||
#endif
|
||||
|
|
|
|||
44
sexp.c
44
sexp.c
|
|
@ -2627,6 +2627,8 @@ static int sexp_peek_char(sexp ctx, sexp in) {
|
|||
return c;
|
||||
}
|
||||
|
||||
sexp sexp_read_one (sexp ctx, sexp in, sexp *shares);
|
||||
|
||||
sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
|
||||
char *str;
|
||||
int c1, c2, line;
|
||||
|
|
@ -2653,23 +2655,23 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
|
|||
case '\r':
|
||||
goto scan_loop;
|
||||
case '\'':
|
||||
res = sexp_read(ctx, in);
|
||||
res = sexp_read_one(ctx, in, shares);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res);
|
||||
break;
|
||||
case '`':
|
||||
res = sexp_read(ctx, in);
|
||||
res = sexp_read_one(ctx, in, shares);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res);
|
||||
break;
|
||||
case ',':
|
||||
if ((c1 = sexp_read_char(ctx, in)) == '@') {
|
||||
res = sexp_read(ctx, in);
|
||||
res = sexp_read_one(ctx, in, shares);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res);
|
||||
} else {
|
||||
sexp_push_char(ctx, c1, in);
|
||||
res = sexp_read(ctx, in);
|
||||
res = sexp_read_one(ctx, in, shares);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL), res);
|
||||
}
|
||||
|
|
@ -2740,7 +2742,7 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
|
|||
for (c1=' '; isspace(c1); c1=sexp_read_char(ctx, in))
|
||||
;
|
||||
if (c1=='#') {
|
||||
tmp = sexp_read(ctx, in);
|
||||
tmp = sexp_read_one(ctx, in, shares);
|
||||
if (sexp_symbolp(tmp) && tmp == sexp_intern(ctx, "t", 1))
|
||||
tmp = SEXP_TRUE;
|
||||
else if (!sexp_fixnump(tmp))
|
||||
|
|
@ -2840,7 +2842,7 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
|
|||
/* ... FALLTHROUGH ... */
|
||||
case 'u': case 'U':
|
||||
if ((c1 = sexp_read_char(ctx, in)) == '8') {
|
||||
tmp = sexp_read(ctx, in);
|
||||
tmp = sexp_read_one(ctx, in, shares);
|
||||
if (!sexp_listp(ctx, tmp)) {
|
||||
res = sexp_exceptionp(tmp) ? tmp
|
||||
: sexp_read_error(ctx, "invalid syntax object after #u8", tmp, in);
|
||||
|
|
@ -2873,8 +2875,9 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
|
|||
if (c1 == '#') {
|
||||
if (!sexp_vectorp(*shares) ||
|
||||
tmp > sexp_vector_data(*shares)[sexp_vector_length(*shares)-1] ||
|
||||
sexp_vector_data(*shares)[c2] == SEXP_VOID)
|
||||
sexp_vector_data(*shares)[c2] == SEXP_VOID) {
|
||||
res = sexp_read_error(ctx, "unknown reader label", tmp, in);
|
||||
}
|
||||
else
|
||||
res = sexp_vector_data(*shares)[c2];
|
||||
} else if (c1 == '=') {
|
||||
|
|
@ -2895,7 +2898,7 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
|
|||
sexp_vector_data(*shares)[c2] = sexp_make_reader_label(c2);
|
||||
if (tmp > sexp_vector_data(*shares)[sexp_vector_length(*shares)-1])
|
||||
sexp_vector_data(*shares)[sexp_vector_length(*shares)-1] = tmp;
|
||||
res = sexp_read_raw(ctx, in, shares);
|
||||
res = sexp_read_one(ctx, in, shares);
|
||||
sexp_vector_data(*shares)[c2] = res;
|
||||
if (sexp_reader_labelp(res))
|
||||
res = sexp_read_error(ctx, "self reader label reference", tmp, in);
|
||||
|
|
@ -2908,7 +2911,7 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
|
|||
break;
|
||||
#endif
|
||||
case ';':
|
||||
tmp = sexp_read_raw(ctx, in, shares); /* discard */
|
||||
tmp = sexp_read_one(ctx, in, shares); /* discard */
|
||||
if (sexp_exceptionp(tmp))
|
||||
res = tmp;
|
||||
else
|
||||
|
|
@ -3002,7 +3005,7 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
|
|||
break;
|
||||
case '(':
|
||||
sexp_push_char(ctx, c1, in);
|
||||
res = sexp_read(ctx, in);
|
||||
res = sexp_read_one(ctx, in, shares);
|
||||
if (sexp_not(sexp_listp(ctx, res))) {
|
||||
if (! sexp_exceptionp(res)) {
|
||||
res = sexp_read_error(ctx, "dotted list not allowed in vector syntax",
|
||||
|
|
@ -3143,13 +3146,8 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
|
|||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_read_op (sexp ctx, sexp self, sexp_sint_t n, sexp in) {
|
||||
sexp res;
|
||||
sexp_gc_var1(shares);
|
||||
sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
|
||||
sexp_check_block_port(ctx, in, 0);
|
||||
sexp_gc_preserve1(ctx, shares);
|
||||
res = sexp_read_raw(ctx, in, &shares);
|
||||
sexp sexp_read_one (sexp ctx, sexp in, sexp *shares) {
|
||||
sexp res = sexp_read_raw(ctx, in, shares);
|
||||
if (res == SEXP_CLOSE)
|
||||
res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in);
|
||||
#if SEXP_USE_OBJECT_BRACE_LITERALS
|
||||
|
|
@ -3158,8 +3156,18 @@ sexp sexp_read_op (sexp ctx, sexp self, sexp_sint_t n, sexp in) {
|
|||
#endif
|
||||
else if (res == SEXP_RAWDOT)
|
||||
res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_read_op (sexp ctx, sexp self, sexp_sint_t n, sexp in) {
|
||||
sexp res;
|
||||
sexp_gc_var1(shares);
|
||||
sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
|
||||
sexp_check_block_port(ctx, in, 0);
|
||||
sexp_gc_preserve1(ctx, shares);
|
||||
res = sexp_read_one(ctx, in, &shares);
|
||||
#if SEXP_USE_READER_LABELS
|
||||
else if (!sexp_exceptionp(res) && sexp_vectorp(shares)) {
|
||||
if (!sexp_exceptionp(res) && sexp_vectorp(shares)) {
|
||||
res = sexp_fill_reader_labels(ctx, res, shares, 1); /* mark=1 */
|
||||
res = sexp_fill_reader_labels(ctx, res, shares, 0); /* mark=0 */
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue