diff --git a/include/picrin.h b/include/picrin.h index 30f1a707..6461dc38 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -26,7 +26,7 @@ typedef struct { pic_callinfo *ci; pic_callinfo *cibase, *ciend; - pic_value sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE; + pic_value sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG; pic_value sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING; pic_value sCONS, sCAR, sCDR, sNILP; pic_value sADD, sSUB, sMUL, sDIV; diff --git a/include/picrin/irep.h b/include/picrin/irep.h index 7cdbc41d..5b33711d 100644 --- a/include/picrin/irep.h +++ b/include/picrin/irep.h @@ -11,7 +11,9 @@ enum pic_opcode { OP_GREF, OP_GSET, OP_LREF, + OP_LSET, OP_CREF, + OP_CSET, OP_JMP, OP_JMPIF, OP_CALL, diff --git a/src/codegen.c b/src/codegen.c index 7601f317..eceb9d95 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -250,6 +250,42 @@ codegen(codegen_state *state, pic_value obj) irep->clen--; break; } + else if (pic_eq_p(pic, proc, pic->sSETBANG)) { + codegen_scope *s; + int depth, idx; + const char *name; + + name = pic_symbol_ptr(pic_car(pic, pic_cdr(pic, obj)))->name; + s = scope_lookup(state, name, &depth, &idx); + if (! s) { + pic_error(pic, "unbound variable"); + } + + codegen(state, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj)))); + + switch (depth) { + case -1: /* global */ + irep->code[irep->clen].insn = OP_GSET; + irep->code[irep->clen].u.i = idx; + irep->clen++; + break; + default: /* nonlocal */ + /* dirty flag */ + s->cv_tbl[idx] = 1; + /* at this stage, lset and cset are not distinguished */ + FALLTHROUGH; + case 0: /* local */ + irep->code[irep->clen].insn = OP_CSET; + irep->code[irep->clen].u.c.depth = depth; + irep->code[irep->clen].u.c.idx = idx; + irep->clen++; + break; + } + + irep->code[irep->clen].insn = OP_PUSHFALSE; + irep->clen++; + break; + } else if (pic_eq_p(pic, proc, pic->sQUOTE)) { int pidx; pidx = pic->plen++; @@ -412,6 +448,10 @@ codegen_lambda(codegen_state *state, pic_value obj) irep->code[i].insn = OP_LREF; irep->code[i].u.i = irep->code[i].u.c.idx; } + if (c.insn == OP_CSET && c.u.c.depth == 0 && ! state->scope->cv_tbl[c.u.c.idx]) { + irep->code[i].insn = OP_LSET; + irep->code[i].u.i = irep->code[i].u.c.idx; + } } } destroy_scope(pic, state->scope); @@ -511,9 +551,15 @@ print_irep(pic_state *pic, struct pic_irep *irep) case OP_LREF: printf("OP_LREF\t%d\n", irep->code[i].u.i); break; + case OP_LSET: + printf("OP_LSET\t%d\n", irep->code[i].u.i); + break; case OP_CREF: printf("OP_CREF\t%d\t%d\n", irep->code[i].u.c.depth, irep->code[i].u.c.idx); break; + case OP_CSET: + printf("OP_CSET\t%d\t%d\n", irep->code[i].u.c.depth, irep->code[i].u.c.idx); + break; case OP_JMP: printf("OP_JMP\t%d\n", irep->code[i].u.i); break; diff --git a/src/gc.c b/src/gc.c index b06af423..13e5ecb8 100644 --- a/src/gc.c +++ b/src/gc.c @@ -239,6 +239,7 @@ gc_mark_phase(pic_state *pic) gc_mark(pic, pic->sLAMBDA); gc_mark(pic, pic->sIF); gc_mark(pic, pic->sBEGIN); + gc_mark(pic, pic->sSETBANG); gc_mark(pic, pic->sQUOTE); gc_mark(pic, pic->sQUASIQUOTE); gc_mark(pic, pic->sUNQUOTE); diff --git a/src/state.c b/src/state.c index c39e2051..935361f3 100644 --- a/src/state.c +++ b/src/state.c @@ -79,6 +79,7 @@ pic_open(int argc, char *argv[], char **envp) pic->sLAMBDA = pic_intern_cstr(pic, "lambda"); pic->sIF = pic_intern_cstr(pic, "if"); pic->sBEGIN = pic_intern_cstr(pic, "begin"); + pic->sSETBANG = pic_intern_cstr(pic, "set!"); pic->sQUOTE = pic_intern_cstr(pic, "quote"); pic->sQUASIQUOTE = pic_intern_cstr(pic, "quasiquote"); pic->sUNQUOTE = pic_intern_cstr(pic, "unquote"); diff --git a/src/vm.c b/src/vm.c index 1b1b7009..1dc31bf7 100644 --- a/src/vm.c +++ b/src/vm.c @@ -118,10 +118,10 @@ pic_run(pic_state *pic, struct pic_proc *proc, pic_value args) #if PIC_DIRECT_THREADED_VM static void *oplabels[] = { &&L_OP_POP, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, &&L_OP_PUSHFALSE, &&L_OP_PUSHNUM, - &&L_OP_PUSHCONST, &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_CREF, - &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_CALL, &&L_OP_RET, &&L_OP_LAMBDA, &&L_OP_CONS, - &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP, &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, - &&L_OP_DIV, &&L_OP_STOP + &&L_OP_PUSHCONST, &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, + &&L_OP_CREF, &&L_OP_CSET, &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_CALL, &&L_OP_RET, + &&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP, + &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_STOP }; #endif @@ -178,6 +178,10 @@ pic_run(pic_state *pic, struct pic_proc *proc, pic_value args) PUSH(pic->ci->fp[pc->u.i]); NEXT; } + CASE(OP_LSET) { + pic->ci->fp[pc->u.i] = POP(); + NEXT; + } CASE(OP_CREF) { int depth = pc->u.c.depth; struct pic_env *env; @@ -189,6 +193,17 @@ pic_run(pic_state *pic, struct pic_proc *proc, pic_value args) PUSH(env->values[pc->u.c.idx]); NEXT; } + CASE(OP_CSET) { + int depth = pc->u.c.depth; + struct pic_env *env; + + env = pic_proc_ptr(*pic->ci->fp)->env; + while (depth--) { + env = env->up; + } + env->values[pc->u.c.idx] = POP(); + NEXT; + } CASE(OP_JMP) { pc += pc->u.i; JUMP;