Merge branch 'master' into trampoline

extlib/xfile

@@ -1 +1 @@
-Subproject commit 8cb37986f940d4207477ab3710ce1c172cf499d0
+Subproject commit 70abe4ffd48e60b2a7fdeb54ad1a793bc786b27b

src/codegen.c

@@ -92,7 +92,7 @@ typedef struct analyze_state {
   pic_sym rCONS, rCAR, rCDR, rNILP;
   pic_sym rADD, rSUB, rMUL, rDIV;
   pic_sym rEQ, rLT, rLE, rGT, rGE, rNOT;
-  pic_sym sCALL, sTAILCALL, sREF;
+  pic_sym sCALL, sTAILCALL, sREF, sRETURN;
 } analyze_state;
 
 static void push_scope(analyze_state *, pic_value);
@@ -142,6 +142,7 @@ new_analyze_state(pic_state *pic)
   register_symbol(pic, state, sCALL, "call");
   register_symbol(pic, state, sTAILCALL, "tail-call");
   register_symbol(pic, state, sREF, "ref");
+  register_symbol(pic, state, sRETURN, "return");
 
   /* push initial scope */
   push_scope(state, pic_nil_value());
@@ -254,13 +255,25 @@ static pic_value analyze_lambda(analyze_state *, pic_value);
 static pic_value
 analyze(analyze_state *state, pic_value obj, bool tailpos)
 {
-  int ai = pic_gc_arena_preserve(state->pic);
+  pic_state *pic = state->pic;
+  int ai = pic_gc_arena_preserve(pic);
   pic_value res;
+  pic_sym tag;
 
   res = analyze_node(state, obj, tailpos);
 
-  pic_gc_arena_restore(state->pic, ai);
+  tag = pic_sym(pic_car(pic, res));
-  pic_gc_protect(state->pic, res);
+  if (tailpos) {
+    if (tag == pic->sIF || tag == pic->sBEGIN || tag == state->sTAILCALL || tag == state->sRETURN) {
+      /* pass through */
+    }
+    else {
+      res = pic_list(pic, 2, pic_symbol_value(state->sRETURN), res);
+    }
+  }
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, res);
   return res;
 }
 
@@ -646,7 +659,7 @@ pic_analyze(pic_state *pic, pic_value obj)
 
   state = new_analyze_state(pic);
 
-  obj = analyze(state, obj, false);
+  obj = analyze(state, obj, true);
 
   destroy_analyze_state(state);
   return obj;
@@ -925,7 +938,7 @@ typedef struct codegen_state {
   pic_state *pic;
   codegen_context *cxt;
   pic_sym sGREF, sCREF, sLREF;
-  pic_sym sCALL, sTAILCALL;
+  pic_sym sCALL, sTAILCALL, sRETURN;
   unsigned *cv_tbl, cv_num;
 } codegen_state;
 
@@ -946,6 +959,7 @@ new_codegen_state(pic_state *pic)
   register_symbol(pic, state, sGREF, "gref");
   register_symbol(pic, state, sLREF, "lref");
   register_symbol(pic, state, sCREF, "cref");
+  register_symbol(pic, state, sRETURN, "return");
 
   push_codegen_context(state, pic_nil_value(), pic_nil_value(), false, pic_nil_value());
 
@@ -1297,6 +1311,12 @@ codegen(codegen_state *state, pic_value obj)
     cxt->clen++;
     return;
   }
+  else if (sym == state->sRETURN) {
+    codegen(state, pic_list_ref(pic, obj, 1));
+    cxt->code[cxt->clen].insn = OP_RET;
+    cxt->clen++;
+    return;
+  }
   pic_error(pic, "codegen: unknown AST type");
 }
 
@@ -1318,8 +1338,6 @@ codegen_lambda(codegen_state *state, pic_value obj)
   {
     /* body */
     codegen(state, body);
-    state->cxt->code[state->cxt->clen].insn = OP_RET;
-    state->cxt->clen++;
   }
   return pop_codegen_context(state);
 }
@@ -1332,34 +1350,20 @@ pic_codegen(pic_state *pic, pic_value obj)
   state = new_codegen_state(pic);
 
   codegen(state, obj);
-  state->cxt->code[state->cxt->clen].insn = OP_RET;
-  state->cxt->clen++;
 
   return destroy_codegen_state(state);
 }
 
-struct pic_proc *
+static struct pic_irep *
-pic_compile(pic_state *pic, pic_value obj)
+compile(pic_state *pic, pic_value obj)
 {
-  struct pic_proc *proc;
   struct pic_irep *irep;
-  jmp_buf jmp, *prev_jmp = pic->jmp;
   int ai = pic_gc_arena_preserve(pic);
 
-
-  if (setjmp(jmp) == 0) {
-    pic->jmp = &jmp;
-  }
-  else {
-    /* error occured */
-    proc = NULL;
-    goto exit;
-  }
-
 #if DEBUG
   fprintf(stderr, "ai = %d\n", pic_gc_arena_preserve(pic));
 
-  fprintf(stderr, "## input expression\n");
+  fprintf(stderr, "# input expression\n");
   pic_debug(pic, obj);
   fprintf(stderr, "\n");
 
@@ -1398,23 +1402,39 @@ pic_compile(pic_state *pic, pic_value obj)
 #if DEBUG
   fprintf(stderr, "## codegen completed\n");
   pic_dump_irep(pic, irep);
+#endif
 
-  fprintf(stderr, "## compilation finished\n");
+#if DEBUG
+  fprintf(stderr, "# compilation finished\n");
   puts("");
 #endif
 
-  proc = pic_proc_new_irep(pic, irep, NULL);
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, pic_obj_value(irep));
 
-#if VM_DEBUG
+  return irep;
-  pic_dump_irep(pic, proc->u.irep);
+}
-#endif
+
+struct pic_proc *
+pic_compile(pic_state *pic, pic_value obj)
+{
+  struct pic_proc *proc;
+  jmp_buf jmp, *prev_jmp = pic->jmp;
+
+  if (setjmp(jmp) == 0) {
+    pic->jmp = &jmp;
+  }
+  else {
+    /* error occured */
+    proc = NULL;
+    goto exit;
+  }
+
+  proc = pic_proc_new_irep(pic, compile(pic, obj), NULL);
 
  exit:
   pic->jmp = prev_jmp;
 
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, pic_obj_value(proc));
-
   return proc;
 }
 

src/vm.c

@@ -411,21 +411,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
   argc = pic_length(pic, argv) + 1;
 
 #if VM_DEBUG
-  puts("== booting VM...");
+  puts("### booting VM... ###");
-  printf("  proc = ");
-  pic_debug(pic, pic_obj_value(proc));
-  puts("");
-  printf("  argv = ");
-  pic_debug(pic, argv);
-  puts("");
-  if (! proc->cfunc_p) {
-    printf("  irep = ");
-    pic_dump_irep(pic, proc->u.irep);
-  }
-  else {
-    printf("  cfunc = %p\n", (void *)proc->u.cfunc);
-  }
-  puts("\nLet's go!");
 #endif
 
   PUSH(pic_obj_value(proc));
@@ -439,8 +425,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
   boot[0].u.i = argc;
   boot[1].insn = OP_STOP;
   pic->ip = boot;
-  c = *pic->ip;
-  goto L_CALL;
 
   VM_LOOP {
     CASE(OP_NOP) {
@@ -561,13 +545,17 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
       proc = pic_proc_ptr(x);
 
 #if VM_DEBUG
-      puts("== calling proc...");
+      puts("\n== calling proc...");
       printf("  proc = ");
       pic_debug(pic, pic_obj_value(proc));
       puts("");
-      printf("  argv = ");
+      printf("  argv = (");
-      pic_debug(pic, argv);
+      for (short i = 1; i < c.u.i; ++i) {
-      puts("");
+        if (i > 1)
+          printf(" ");
+        pic_debug(pic, pic->sp[-c.u.i + i]);
+      }
+      puts(")");
       if (! proc->cfunc_p) {
 	printf("  irep = ");
 	pic_dump_irep(pic, proc->u.irep);
@@ -575,7 +563,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
       else {
 	printf("  cfunc = %p\n", (void *)proc->u.cfunc);
       }
-      puts("");
+      puts("== end\n");
 #endif
 
       ci = PUSHCI();