From 5caa12412e95390fd314026f4f4498c072fdd2eb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 12 Mar 2009 19:14:34 +0900 Subject: [PATCH] bugfixes --- debug.c | 2 +- eval.c | 71 ++++++++++++++++++++++++++------------------------------ eval.h | 2 -- init.scm | 2 ++ sexp.c | 2 +- 5 files changed, 37 insertions(+), 42 deletions(-) diff --git a/debug.c b/debug.c index 9871030e..391f456e 100644 --- a/debug.c +++ b/debug.c @@ -9,7 +9,7 @@ static const char* reverse_opcode_names[] = "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", "STACK-REF", "STACK-SET", "GLOBAL-REF", "GLOBAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "STRING-REF", "STRING-SET", "MAKE-PROCEDURE", - "MAKE-VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", + "MAKE-VECTOR", "PUSH", "DROP", "PAIRP", "NULLP", "VECTORP", "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", "OPORTP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "MOD", "NEG", "INV", "LT", "LE", "GT", "GE", "EQN", "EQ", diff --git a/eval.c b/eval.c index 716500fc..e4a94cc4 100644 --- a/eval.c +++ b/eval.c @@ -329,15 +329,12 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, if (tmp1 == 0) { errx(1, "opcode with no arguments: %s", op->name); } else if (tmp1 == 1) { + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); if (op->op_class == OPC_ARITHMETIC_INV) { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); emit(bc, i, op->op_inverse); - } else { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); - if (op->op_class != OPC_ARITHMETIC) { - emit(bc, i, op->op_name); - (*d)--; - } + (*d)++; + } else if (op->op_class != OPC_ARITHMETIC) { + emit(bc, i, op->op_name); } } else { for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); @@ -358,6 +355,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, emit(bc, i, OP_PARAMETER); emit_word(bc, i, (sexp_uint_t) op->data); (*d)++; + tmp1++; } for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) @@ -390,16 +388,18 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, /* sexp_write(sv, stderr); */ /* fprintf(stderr, "\n"); */ if ((tmp = sexp_list_index(params, obj)) >= 0) { - /* fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); */ o1 = env_cell(e, obj); + fprintf(stderr, "compiling local ref: "); + sexp_write(obj, cur_error_port); + fprintf(stderr, " => %d\n", *d - sexp_unbox_integer(SEXP_CDR(o1))); emit(bc, i, OP_STACK_REF); emit_word(bc, i, *d - sexp_unbox_integer(SEXP_CDR(o1))); } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { - /* fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); */ + fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); emit(bc, i, OP_CLOSURE_REF); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(tmp)); } else { - /* fprintf(stderr, "compiling global ref: %p\n", obj); */ + fprintf(stderr, "compiling global ref: %p\n", obj); emit(bc, i, OP_GLOBAL_REF); emit_word(bc, i, (sexp_uint_t) obj); } @@ -433,6 +433,8 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, emit(bc, i, OP_CALL); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); } + + (*d) -= (len); } sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { @@ -572,8 +574,8 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { /* determine internal defines */ if (e->parent) { for (ls=SEXP_NULL; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { - core = SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj)) - && core_code(e, SEXP_CAAR(obj)); + core = (SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj)) + ? core_code(e, SEXP_CAAR(obj)) : 0); if (core == CORE_BEGIN) { obj = sexp_cons(SEXP_CAR(obj), sexp_append(SEXP_CDAR(obj), SEXP_CDR(obj))); @@ -591,11 +593,11 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { } } obj = sexp_reverse(ls); -/* sexp_write_string("internals: ", cur_error_port); */ -/* sexp_write(internals, cur_error_port); */ -/* sexp_write_string("\n", cur_error_port); */ j = sexp_length(internals); if (SEXP_PAIRP(internals)) { +/* sexp_write_string("internals: ", cur_error_port); */ +/* sexp_write(internals, cur_error_port); */ +/* sexp_write_string("\n", cur_error_port); */ e = extend_env_closure(e, internals, 2); params = sexp_append(internals, params); for (ls=internals; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) @@ -608,6 +610,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { if (SEXP_PAIRP(SEXP_CDR(obj))) { analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 0); emit(&bc, &i, OP_DROP); + d--; } else { analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, (! done_p) && (! SEXP_PAIRP(internals))); @@ -654,6 +657,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { int i, j, k; loop: +/* print_stack(stack, top); */ /* fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); */ switch (*ip++) { case OP_NOOP: @@ -732,24 +736,16 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top++]=((sexp*)ip)[0]; ip += sizeof(sexp); break; - case OP_DUP: - stack[top]=stack[top-1]; - top++; - break; case OP_DROP: top--; break; - case OP_SWAP: - tmp1 = stack[top-2]; - stack[top-2]=stack[top-1]; - stack[top-1]=tmp1; - break; case OP_PARAMETER: stack[top] = *(sexp*)((sexp*)ip)[0]; top++; ip += sizeof(sexp); break; case OP_PAIRP: + /* print_stack(stack, top); */ stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_NULLP: stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; @@ -772,6 +768,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_EOFP: stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; break; case OP_CAR: + /* print_stack(stack, top); */ if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); stack[top-1]=SEXP_CAR(stack[top-1]); break; case OP_CDR: @@ -842,17 +839,16 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* fprintf(stderr, "tail call: depth=%d, i=%d, top=%d\n", j, i, top); */ /* print_stack(stack, top); */ /* save frame info */ - stack[top] = stack[top-i-j]; - stack[top+1] = stack[top-i-j+1]; + stack[top] = stack[top-j-2]; + stack[top+1] = stack[top-j-1]; /* copy new args into place */ for (k=top-i-1; ktag = SEXP_ENV; e->parent = NULL; e->bindings = SEXP_NULL; - for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) { + for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) env_define(e, sexp_intern(core_forms[i].name), (sexp)(&core_forms[i])); - } - for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) { + for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) env_define(e, sexp_intern(opcodes[i].name), (sexp)(&opcodes[i])); - } return e; } diff --git a/eval.h b/eval.h index c22a2054..f4204a8d 100644 --- a/eval.h +++ b/eval.h @@ -131,9 +131,7 @@ enum opcode_names { OP_MAKE_PROCEDURE, OP_MAKE_VECTOR, OP_PUSH, - OP_DUP, OP_DROP, - OP_SWAP, OP_PAIRP, OP_NULLP, OP_VECTORP, diff --git a/init.scm b/init.scm index af5a820e..e8c1a823 100644 --- a/init.scm +++ b/init.scm @@ -40,6 +40,8 @@ (mapn proc (cons ls lol) '()))) (define (map1 proc ls res) +;; (write ls) +;; (newline) (if (pair? ls) (map1 proc (cdr ls) (cons (proc (car ls)) res)) (reverse res))) diff --git a/sexp.c b/sexp.c index f20d4607..6fa9cb3e 100644 --- a/sexp.c +++ b/sexp.c @@ -406,7 +406,7 @@ void sexp_write (sexp obj, sexp out) { case SEXP_FLONUM: sexp_printf(out, "%g", sexp_flonum_value(obj)); break; case SEXP_PROCEDURE: - sexp_write_string("#", out); break; + sexp_printf(out, "#", obj); break; case SEXP_IPORT: sexp_write_string("#", out); break; case SEXP_OPORT: