add OP_LSET and OP_CSET

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;

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,

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;

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

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

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_PUSHCONST, &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET,
-    &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_CALL, &&L_OP_RET, &&L_OP_LAMBDA, &&L_OP_CONS,
+    &&L_OP_CREF, &&L_OP_CSET, &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_CALL, &&L_OP_RET,
-    &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP, &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL,
+    &&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP,
-    &&L_OP_DIV, &&L_OP_STOP
+    &&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;