add OP_LAMBDA (lambda object creation)

include/picrin.h

@@ -16,10 +16,10 @@ typedef struct {
   pic_value *sp;
   pic_value *stbase, *stend;
 
-  pic_value sDEFINE, sCONS;
   pic_callinfo *ci;
   pic_callinfo *cibase, *ciend;
 
+  pic_value sDEFINE, sLAMBDA, sCONS;
   pic_value sADD, sSUB, sMUL, sDIV;
   struct pic_env *global_env;
 

include/picrin/irep.h

@@ -8,6 +8,8 @@ enum pic_instruction {
   OP_GREF,
   OP_GSET,
   OP_CALL,
+  OP_RET,
+  OP_LAMBDA,
   OP_CONS,
   OP_ADD,
   OP_SUB,
@@ -28,6 +30,9 @@ struct pic_code {
 struct pic_irep {
   struct pic_code *code;
   size_t clen, ccapa;
+
+  struct pic_irep **proto;
+  size_t plen, pcapa;
 };
 
 #endif

src/gc.c

@@ -193,6 +193,7 @@ gc_mark_phase(pic_state *pic)
   } while ((env = env->parent) != NULL);
 
   gc_mark(pic, pic->sDEFINE);
+  gc_mark(pic, pic->sLAMBDA);
   gc_mark(pic, pic->sCONS);
   gc_mark(pic, pic->sADD);
   gc_mark(pic, pic->sSUB);

src/state.c

@@ -41,6 +41,7 @@ pic_open()
   pic->arena_idx = 0;
 
   pic->sDEFINE = pic_intern_cstr(pic, "define");
+  pic->sLAMBDA = pic_intern_cstr(pic, "lambda");
   pic->sCONS = pic_intern_cstr(pic, "cons");
   pic->sADD = pic_intern_cstr(pic, "+");
   pic->sSUB = pic_intern_cstr(pic, "-");

src/vm.c

@@ -125,6 +125,12 @@ print_irep(pic_state *pic, struct pic_irep *irep)
     case OP_CALL:
       printf("OP_CALL\t%d\n", irep->code[i].u.i);
       break;
+    case OP_RET:
+      puts("OP_RET");
+      break;
+    case OP_LAMBDA:
+      printf("OP_LAMBDA\t%d\n", irep->code[i].u.i);
+      break;
     case OP_CONS:
       puts("OP_CONS");
       break;
@@ -150,14 +156,31 @@ print_irep(pic_state *pic, struct pic_irep *irep)
   }
 }
 
+static struct pic_irep *
+new_irep(pic_state *pic)
+{
+  struct pic_irep *irep;
+
+  irep = (struct pic_irep *)pic_alloc(pic, sizeof(struct pic_irep));
+  irep->code = (struct pic_code *)pic_alloc(pic, sizeof(struct pic_code) * 1024);
+  irep->clen = 0;
+  irep->ccapa = 1024;
+  irep->proto = NULL;
+  irep->plen = irep->pcapa = 0;
+
+  return irep;
+}
+
 static void pic_gen_call(pic_state *, struct pic_irep *, pic_value, struct pic_env *);
+static struct pic_irep *pic_gen_lambda(pic_state *, pic_value, struct pic_env *);
 
 static void
 pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *env)
 {
-  pic_value sDEFINE, sCONS, sADD, sSUB, sMUL, sDIV;
+  pic_value sDEFINE, sLAMBDA, sCONS, sADD, sSUB, sMUL, sDIV;
 
   sDEFINE = pic->sDEFINE;
+  sLAMBDA = pic->sLAMBDA;
   sCONS = pic->sCONS;
   sADD = pic->sADD;
   sSUB = pic->sSUB;
@@ -194,6 +217,22 @@ pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *en
       irep->clen++;
       break;
     }
+    else if (pic_eq_p(pic, proc, sLAMBDA)) {
+      if (irep->proto == NULL) {
+	irep->proto = (struct pic_irep **)pic_alloc(pic, sizeof(struct pic_irep **) * 5);
+	irep->pcapa = 5;
+      }
+      if (irep->plen >= irep->pcapa) {
+	irep->proto = (struct pic_irep **)pic_realloc(pic, irep->proto, irep->pcapa * 2);
+	irep->pcapa *= 2;
+      }
+      irep->code[irep->clen].insn = OP_LAMBDA;
+      irep->code[irep->clen].u.i = irep->plen;
+      irep->clen++;
+
+      irep->proto[irep->plen++] = pic_gen_lambda(pic, obj, env);
+      break;
+    }
     else if (pic_eq_p(pic, proc, sCONS)) {
       pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), env);
       pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), env);
@@ -280,20 +319,33 @@ pic_gen_call(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_en
   irep->clen++;
 }
 
+static struct pic_irep *
+pic_gen_lambda(pic_state *pic, pic_value obj, struct pic_env *env)
+{
+  pic_value body, v;
+  struct pic_irep *irep;
+
+  irep = new_irep(pic);
+
+  body = pic_cdr(pic, pic_cdr(pic, obj));
+  for (v = body; ! pic_nil_p(v); v = pic_cdr(pic, v)) {
+    pic_gen(pic, irep, pic_car(pic, v), env);
+  }
+  irep->code[irep->clen].insn = OP_RET;
+  irep->clen++;
+
+  return irep;
+}
+
 struct pic_proc *
 pic_codegen(pic_state *pic, pic_value obj, struct pic_env *env)
 {
   struct pic_proc *proc;
   struct pic_irep *irep;
-  struct pic_code *code;
 
   proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
-
   proc->cfunc_p = false;
-  proc->u.irep = irep = (struct pic_irep *)pic_alloc(pic, sizeof(struct pic_irep));
+  proc->u.irep = irep = new_irep(pic);
-  irep->code = code = (struct pic_code *)pic_alloc(pic, sizeof(struct pic_code) * 1024);
-  irep->clen = 0;
-  irep->ccapa = 1024;
 
   pic_gen(pic, irep, obj, env);
   irep->code[irep->clen].insn = OP_STOP;
@@ -373,6 +425,16 @@ pic_run(pic_state *pic, struct pic_proc *proc, pic_value args)
       pic_gc_arena_restore(pic, ai);
       NEXT;
     }
+    CASE(OP_LAMBDA) {
+      struct pic_proc *proc;
+
+      proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc *), PIC_TT_PROC);
+      proc->cfunc_p = false;
+      proc->u.irep = ci->proc->u.irep->proto[pc->u.i];
+      PUSH(pic_obj_value(proc));
+      pic_gc_arena_restore(pic, ai);
+      NEXT;
+    }
     CASE(OP_CONS) {
       pic_value a, b;
       pic_gc_protect(pic, a = POP());