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));
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--;

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_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)))

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'))
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;
}