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

fixing stack offsets for mutated variables

Browse source
This commit is contained in:
Alex Shinn 2009-03-16 19:26:06 +09:00
parent c830b498b7
commit 9af5279e6f
4 changed files with 34 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
eval.c
View file

@ -608,15 +608,14 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) {
} }
sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) {
sexp_uint_t i=0, d=0, define_ok=1, core; sexp_uint_t i=0, j=0, d=0, define_ok=1, core;
sexp_sint_t j=0;
sexp bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE); sexp bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE);
sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls;
bc->tag = SEXP_BYTECODE; bc->tag = SEXP_BYTECODE;
sexp_bytecode_length(bc) = INIT_BCODE_SIZE; sexp_bytecode_length(bc) = INIT_BCODE_SIZE;
/* box mutable vars */ /* box mutable vars */
for (ls=params; sexp_pairp(ls); ls=sexp_cdr(ls)) { for (ls=params, j=0; sexp_pairp(ls); ls=sexp_cdr(ls), j++) {
if ((j = sexp_list_index(sv2, sexp_car(ls))) >= 0) { if (sexp_list_index(sv2, sexp_car(ls)) >= 0) {
emit_push(&bc, &i, SEXP_NULL); emit_push(&bc, &i, SEXP_NULL);
emit(&bc, &i, OP_STACK_REF); emit(&bc, &i, OP_STACK_REF);
emit_word(&bc, &i, j+5); emit_word(&bc, &i, j+5);
@ -795,19 +794,21 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
case OP_EOFP: case OP_EOFP:
_ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break;
case OP_CAR: case OP_CAR:
if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(_ARG1));
_ARG1 = sexp_car(_ARG1); break; _ARG1 = sexp_car(_ARG1); break;
case OP_CDR: case OP_CDR:
if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); if (! sexp_pairp(_ARG1)) sexp_raise("cdr: not a pair", sexp_list1(_ARG1));
_ARG1 = sexp_cdr(_ARG1); break; _ARG1 = sexp_cdr(_ARG1); break;
case OP_SET_CAR: case OP_SET_CAR:
if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); if (! sexp_pairp(_ARG1))
sexp_raise("set-car!: not a pair", sexp_list1(_ARG1));
sexp_car(_ARG1) = _ARG2; sexp_car(_ARG1) = _ARG2;
_ARG2 = SEXP_UNDEF; _ARG2 = SEXP_UNDEF;
top--; top--;
break; break;
case OP_SET_CDR: case OP_SET_CDR:
if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); if (! sexp_pairp(_ARG1))
sexp_raise("set-cdr!: not a pair", sexp_list1(_ARG1));
sexp_cdr(_ARG1) = _ARG2; sexp_cdr(_ARG1) = _ARG2;
_ARG2 = SEXP_UNDEF; _ARG2 = SEXP_UNDEF;
top--; top--;
@ -827,7 +828,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_add(sexp_integer_to_flonum(_ARG1), _ARG2); _ARG2 = sexp_fp_add(sexp_integer_to_flonum(_ARG1), _ARG2);
#endif #endif
else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); else sexp_raise("+: not a number", sexp_list2(_ARG1, _ARG2));
top--; top--;
break; break;
case OP_SUB: case OP_SUB:
@ -841,7 +842,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_sub(sexp_integer_to_flonum(_ARG1), _ARG2); _ARG2 = sexp_fp_sub(sexp_integer_to_flonum(_ARG1), _ARG2);
#endif #endif
else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); else sexp_raise("-: not a number", sexp_list2(_ARG1, _ARG2));
top--; top--;
break; break;
case OP_MUL: case OP_MUL:
@ -855,7 +856,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_mul(sexp_integer_to_flonum(_ARG1), _ARG2); _ARG2 = sexp_fp_mul(sexp_integer_to_flonum(_ARG1), _ARG2);
#endif #endif
else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); else sexp_raise("*: not a number", sexp_list2(_ARG1, _ARG2));
top--; top--;
break; break;
case OP_DIV: case OP_DIV:
@ -870,7 +871,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1), _ARG2); _ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1), _ARG2);
#endif #endif
else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); else sexp_raise("/: not a number", sexp_list2(_ARG1, _ARG2));
top--; top--;
break; break;
case OP_QUOT: case OP_QUOT:
@ -878,14 +879,14 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
_ARG2 = sexp_fx_div(_ARG1, _ARG2); _ARG2 = sexp_fx_div(_ARG1, _ARG2);
top--; top--;
} }
else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); else sexp_raise("quotient: not a number", sexp_list2(_ARG1, _ARG2));
break; break;
case OP_MOD: case OP_MOD:
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) {
_ARG2 = sexp_fx_mod(_ARG1, _ARG2); _ARG2 = sexp_fx_mod(_ARG1, _ARG2);
top--; top--;
} }
else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); else sexp_raise("modulo: not a number", sexp_list2(_ARG1, _ARG2));
break; break;
case OP_NEG: case OP_NEG:
if (sexp_integerp(_ARG1)) if (sexp_integerp(_ARG1))
@ -894,7 +895,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
else if (sexp_flonump(_ARG1)) else if (sexp_flonump(_ARG1))
_ARG1 = sexp_make_flonum(-sexp_flonum_value(_ARG1)); _ARG1 = sexp_make_flonum(-sexp_flonum_value(_ARG1));
#endif #endif
else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); else sexp_raise("-: not a number", sexp_list1(_ARG1));
break; break;
case OP_LT: case OP_LT:
_ARG2 = sexp_make_boolean(_ARG1 < _ARG2); _ARG2 = sexp_make_boolean(_ARG1 < _ARG2);

20
sexp.c
View file

@ -92,7 +92,8 @@ sexp sexp_make_exception(sexp kind, sexp message, sexp irritants,
} }
sexp sexp_print_exception(sexp exn, sexp out) { sexp sexp_print_exception(sexp exn, sexp out) {
sexp_write_string("error", out); sexp ls;
sexp_write_string("ERROR", out);
if (sexp_integerp(sexp_exception_line(exn)) if (sexp_integerp(sexp_exception_line(exn))
&& sexp_exception_line(exn) > sexp_make_integer(0)) { && sexp_exception_line(exn) > sexp_make_integer(0)) {
sexp_write_string(" on line ", out); sexp_write_string(" on line ", out);
@ -104,11 +105,20 @@ sexp sexp_print_exception(sexp exn, sexp out) {
} }
sexp_write_string(": ", out); sexp_write_string(": ", out);
sexp_write_string(sexp_string_data(sexp_exception_message(exn)), out); sexp_write_string(sexp_string_data(sexp_exception_message(exn)), out);
sexp_write_string("\n", out);
if (sexp_pairp(sexp_exception_irritants(exn))) { if (sexp_pairp(sexp_exception_irritants(exn))) {
sexp_write_string(" irritants: ", out); if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) {
sexp_write(sexp_exception_irritants(exn), out); sexp_write_string(": ", out);
sexp_write_string("\n", out); sexp_write(sexp_car(sexp_exception_irritants(exn)), out);
sexp_write_string("\n", out);
} else {
sexp_write_string("\n", out);
for (ls=sexp_exception_irritants(exn);
sexp_pairp(ls); ls=sexp_cdr(ls)) {
sexp_write_string(" ", out);
sexp_write(sexp_car(ls), out);
sexp_write_string("\n", out);
}
}
} }
return SEXP_UNDEF; return SEXP_UNDEF;
} }

6
tests/test05-letrec.scm
View file

@ -16,11 +16,11 @@
((lambda (even? odd?) ((lambda (even? odd?)
(set! even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) (set! even? (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
(set! odd? (lambda (n) (if (zero? n) #f (even? (- n 1))))) (set! odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))
(write (even? 1000)) (write (even? 100))
(newline) (newline)
(write (even? 1001)) (write (even? 101))
(newline) (newline)
(write (odd? 1000)) (write (odd? 100))
(newline) (newline)
) )
'even 'odd) 'even 'odd)

1
tests/test06-mutation.scm
View file

@ -7,4 +7,3 @@
(set! e 10000) (set! e 10000)
(write (+ e (* c 1000) (* a 100) (* b 10) d)) (write (+ e (* c 1000) (* a 100) (* b 10) d))
(newline))) (newline)))