Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-11 06:57:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

making literals immutable

Browse source
This commit is contained in:
Alex Shinn 2009-06-28 19:07:19 +09:00
parent f1e7c3a2db
commit 78ceffdee4
3 changed files with 23 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
eval.c
View file

@ -331,6 +331,7 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) {
kar = sexp_strip_synclos(ctx, sexp_car(x)); kar = sexp_strip_synclos(ctx, sexp_car(x));
kdr = sexp_strip_synclos(ctx, sexp_cdr(x)); kdr = sexp_strip_synclos(ctx, sexp_cdr(x));
res = sexp_cons(ctx, kar, kdr); res = sexp_cons(ctx, kar, kdr);
sexp_immutablep(res) = sexp_immutablep(x);
} else { } else {
res = x; res = x;
} }
@ -1497,6 +1498,8 @@ sexp sexp_vm (sexp ctx, sexp proc) {
case OP_VECTOR_SET: case OP_VECTOR_SET:
if (! sexp_vectorp(_ARG1)) if (! sexp_vectorp(_ARG1))
sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _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); sexp_vector_set(_ARG1, _ARG2, _ARG3);
_ARG3 = SEXP_VOID; _ARG3 = SEXP_VOID;
top-=2; top-=2;
@ -1509,6 +1512,11 @@ sexp sexp_vm (sexp ctx, sexp proc) {
top--; top--;
break; break;
case OP_STRING_SET: 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); sexp_string_set(_ARG1, _ARG2, _ARG3);
_ARG3 = SEXP_VOID; _ARG3 = SEXP_VOID;
top-=2; top-=2;
@ -1557,6 +1565,8 @@ sexp sexp_vm (sexp ctx, sexp proc) {
case OP_SET_CAR: case OP_SET_CAR:
if (! sexp_pairp(_ARG1)) if (! sexp_pairp(_ARG1))
sexp_raise("set-car!: not a pair", sexp_list1(ctx, _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; sexp_car(_ARG1) = _ARG2;
_ARG2 = SEXP_VOID; _ARG2 = SEXP_VOID;
top--; top--;
@ -1564,6 +1574,8 @@ sexp sexp_vm (sexp ctx, sexp proc) {
case OP_SET_CDR: case OP_SET_CDR:
if (! sexp_pairp(_ARG1)) if (! sexp_pairp(_ARG1))
sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _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; sexp_cdr(_ARG1) = _ARG2;
_ARG2 = SEXP_VOID; _ARG2 = SEXP_VOID;
top--; top--;

1
include/chibi/sexp.h
View file

@ -286,6 +286,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
#define sexp_pointer_tag(x) ((x)->tag) #define sexp_pointer_tag(x) ((x)->tag)
#define sexp_gc_mark(x) ((x)->gc_mark) #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))) #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))

13
sexp.c
View file

@ -894,9 +894,10 @@ void sexp_write (sexp ctx, sexp obj, sexp out) {
else if (obj == sexp_make_character('\t')) else if (obj == sexp_make_character('\t'))
sexp_write_string(ctx, "#\\tab", out); sexp_write_string(ctx, "#\\tab", out);
else if ((33 <= sexp_unbox_character(obj)) 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); sexp_write_char(ctx, sexp_unbox_character(obj), out);
else { } else {
sexp_write_string(ctx, "#\\x", out); 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)>>4), out);
sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)&0xF), 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); 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_pair_source(res)
= sexp_cons(ctx, sexp_port_name(in), sexp_make_integer(line)); = 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; break;
case '#': case '#':
switch (c1=sexp_read_char(ctx, in)) { switch (c1=sexp_read_char(ctx, in)) {
@ -1296,6 +1301,8 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
break; break;
} }
if (sexp_port_sourcep(in) && sexp_pointerp(res))
sexp_immutablep(res) = 1;
sexp_gc_release(ctx, res, s_res); sexp_gc_release(ctx, res, s_res);
return res; return res;
} }