diff --git a/eval.c b/eval.c index 871feb9d..7e599d5d 100644 --- a/eval.c +++ b/eval.c @@ -331,6 +331,7 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) { kar = sexp_strip_synclos(ctx, sexp_car(x)); kdr = sexp_strip_synclos(ctx, sexp_cdr(x)); res = sexp_cons(ctx, kar, kdr); + sexp_immutablep(res) = sexp_immutablep(x); } else { res = x; } @@ -1497,6 +1498,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_VECTOR_SET: if (! sexp_vectorp(_ARG1)) sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("vector-set!: immutable vector", sexp_list1(ctx, _ARG1)); sexp_vector_set(_ARG1, _ARG2, _ARG3); _ARG3 = SEXP_VOID; top-=2; @@ -1509,6 +1512,11 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case OP_STRING_SET: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-set!: not a string", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("string-set!: immutable string", sexp_list1(ctx, _ARG1)); + fprintf(stderr, "string-set! %p (immutable: %d)\n", _ARG1, sexp_immutablep(_ARG1)); sexp_string_set(_ARG1, _ARG2, _ARG3); _ARG3 = SEXP_VOID; top-=2; @@ -1557,6 +1565,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_SET_CAR: if (! sexp_pairp(_ARG1)) sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("set-car!: immutable pair", sexp_list1(ctx, _ARG1)); sexp_car(_ARG1) = _ARG2; _ARG2 = SEXP_VOID; top--; @@ -1564,6 +1574,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_SET_CDR: if (! sexp_pairp(_ARG1)) sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("set-cdr!: immutable pair", sexp_list1(ctx, _ARG1)); sexp_cdr(_ARG1) = _ARG2; _ARG2 = SEXP_VOID; top--; diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 8ab96d98..d1538cf2 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -286,6 +286,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_pointer_tag(x) ((x)->tag) #define sexp_gc_mark(x) ((x)->gc_mark) +#define sexp_immutablep(x) ((x)->immutablep) #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) diff --git a/sexp.c b/sexp.c index 9b909936..7d1d12d9 100644 --- a/sexp.c +++ b/sexp.c @@ -894,9 +894,10 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { else if (obj == sexp_make_character('\t')) sexp_write_string(ctx, "#\\tab", out); else if ((33 <= sexp_unbox_character(obj)) - && (sexp_unbox_character(obj) < 127)) + && (sexp_unbox_character(obj) < 127)) { + sexp_write_string(ctx, "#\\", out); sexp_write_char(ctx, sexp_unbox_character(obj), out); - else { + } else { sexp_write_string(ctx, "#\\x", out); sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)>>4), out); sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)&0xF), out); @@ -1156,9 +1157,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in); } } - if ((line >= 0) && sexp_pairp(res)) + if ((line >= 0) && sexp_pairp(res)) { sexp_pair_source(res) = sexp_cons(ctx, sexp_port_name(in), sexp_make_integer(line)); + } + if (sexp_port_sourcep(in)) + for (tmp=res; sexp_pairp(tmp); tmp=sexp_cdr(tmp)) + sexp_immutablep(tmp) = 1; break; case '#': switch (c1=sexp_read_char(ctx, in)) { @@ -1296,6 +1301,8 @@ sexp sexp_read_raw (sexp ctx, sexp in) { break; } + if (sexp_port_sourcep(in) && sexp_pointerp(res)) + sexp_immutablep(res) = 1; sexp_gc_release(ctx, res, s_res); return res; }