Merge branch 'native-mv'. fix #16

include/picrin.h

@@ -60,7 +60,7 @@ extern "C" {
 struct pic_code;
 
 typedef struct {
-  int argc;
+  int argc, retc;
   struct pic_code *ip;
   pic_value *fp;
   struct pic_env *env;

src/codegen.c

@@ -88,7 +88,9 @@ 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, sRETURN;
+  pic_sym rVALUES, rCALL_WITH_VALUES;
+  pic_sym sCALL, sTAILCALL, sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES;
+  pic_sym sREF, sRETURN;
 } analyze_state;
 
 static void push_scope(analyze_state *, pic_value);
@@ -134,9 +136,13 @@ new_analyze_state(pic_state *pic)
   register_renamed_symbol(pic, state, rGT, stdlib, ">");
   register_renamed_symbol(pic, state, rGE, stdlib, ">=");
   register_renamed_symbol(pic, state, rNOT, stdlib, "not");
+  register_renamed_symbol(pic, state, rVALUES, stdlib, "values");
+  register_renamed_symbol(pic, state, rCALL_WITH_VALUES, stdlib, "call-with-values");
 
   register_symbol(pic, state, sCALL, "call");
   register_symbol(pic, state, sTAILCALL, "tail-call");
+  register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values");
+  register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values");
   register_symbol(pic, state, sREF, "ref");
   register_symbol(pic, state, sRETURN, "return");
 
@@ -264,7 +270,7 @@ analyze(analyze_state *state, pic_value obj, bool tailpos)
 
   tag = pic_sym(pic_car(pic, res));
   if (tailpos) {
-    if (tag == pic->sIF || tag == pic->sBEGIN || tag == state->sTAILCALL || tag == state->sRETURN) {
+    if (tag == pic->sIF || tag == pic->sBEGIN || tag == state->sTAILCALL || tag == state->sTAILCALL_WITH_VALUES || tag == state->sRETURN) {
       /* pass through */
     }
     else {
@@ -540,6 +546,30 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
         ARGC_ASSERT(1);
         return CONSTRUCT_OP1(pic->sNOT);
       }
+      else if (sym == state->rVALUES && tailpos) {
+	pic_value v, seq;
+
+        seq = pic_list(pic, 1, pic_symbol_value(state->sRETURN));
+        pic_for_each (v, pic_cdr(pic, obj)) {
+          seq = pic_cons(pic, analyze(state, v, false), seq);
+        }
+        return pic_reverse(pic, seq);
+      }
+      else if (sym == state->rCALL_WITH_VALUES) {
+        pic_value prod, cnsm;
+        pic_sym call;
+
+	ARGC_ASSERT(2);
+
+        if (! tailpos) {
+          call = state->sCALL_WITH_VALUES;
+        } else {
+          call = state->sTAILCALL_WITH_VALUES;
+        }
+        prod = analyze(state, pic_list_ref(pic, obj, 1), false);
+        cnsm = analyze(state, pic_list_ref(pic, obj, 2), false);
+        return pic_list(pic, 3, pic_symbol_value(call), prod, cnsm);
+      }
     }
     return analyze_call(state, obj, tailpos);
   }
@@ -939,6 +969,7 @@ typedef struct codegen_state {
   codegen_context *cxt;
   pic_sym sGREF, sCREF, sLREF;
   pic_sym sCALL, sTAILCALL, sRETURN;
+  pic_sym sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES;
   unsigned *cv_tbl, cv_num;
 } codegen_state;
 
@@ -960,6 +991,8 @@ new_codegen_state(pic_state *pic)
   register_symbol(pic, state, sLREF, "lref");
   register_symbol(pic, state, sCREF, "cref");
   register_symbol(pic, state, sRETURN, "return");
+  register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values");
+  register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values");
 
   push_codegen_context(state, pic_nil_value(), pic_nil_value(), false, pic_nil_value());
 
@@ -1311,9 +1344,29 @@ codegen(codegen_state *state, pic_value obj)
     cxt->clen++;
     return;
   }
-  else if (sym == state->sRETURN) {
+  else if (sym == state->sCALL_WITH_VALUES || sym == state->sTAILCALL_WITH_VALUES) {
+    /* stack consumer at first */
+    codegen(state, pic_list_ref(pic, obj, 2));
     codegen(state, pic_list_ref(pic, obj, 1));
+    /* call producer */
+    cxt->code[cxt->clen].insn = OP_CALL;
+    cxt->code[cxt->clen].u.i = 1;
+    cxt->clen++;
+    /* call consumer */
+    cxt->code[cxt->clen].insn = (sym == state->sCALL_WITH_VALUES) ? OP_CALL : OP_TAILCALL;
+    cxt->code[cxt->clen].u.i = -1;
+    cxt->clen++;
+    return;
+  }
+  else if (sym == state->sRETURN) {
+    int len = pic_length(pic, obj);
+    pic_value elt;
+
+    pic_for_each (elt, pic_cdr(pic, obj)) {
+      codegen(state, elt);
+    }
     cxt->code[cxt->clen].insn = OP_RET;
+    cxt->code[cxt->clen].u.i = len - 1;
     cxt->clen++;
     return;
   }
@@ -1361,51 +1414,51 @@ compile(pic_state *pic, pic_value obj)
   int ai = pic_gc_arena_preserve(pic);
 
 #if DEBUG
-  fprintf(stderr, "ai = %d\n", pic_gc_arena_preserve(pic));
+  fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
 
-  fprintf(stderr, "# input expression\n");
+  fprintf(stdout, "# input expression\n");
   pic_debug(pic, obj);
-  fprintf(stderr, "\n");
+  fprintf(stdout, "\n");
 
-  fprintf(stderr, "ai = %d\n", pic_gc_arena_preserve(pic));
+  fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
 #endif
 
   /* macroexpand */
   obj = pic_macroexpand(pic, obj);
 #if DEBUG
-  fprintf(stderr, "## macroexpand completed\n");
+  fprintf(stdout, "## macroexpand completed\n");
   pic_debug(pic, obj);
-  fprintf(stderr, "\n");
+  fprintf(stdout, "\n");
-  fprintf(stderr, "ai = %d\n", pic_gc_arena_preserve(pic));
+  fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
 #endif
 
   /* analyze */
   obj = pic_analyze(pic, obj);
 #if DEBUG
-  fprintf(stderr, "## analyzer completed\n");
+  fprintf(stdout, "## analyzer completed\n");
   pic_debug(pic, obj);
-  fprintf(stderr, "\n");
+  fprintf(stdout, "\n");
-  fprintf(stderr, "ai = %d\n", pic_gc_arena_preserve(pic));
+  fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
 #endif
 
   /* resolution */
   obj = pic_resolve(pic, obj);
 #if DEBUG
-  fprintf(stderr, "## resolver completed\n");
+  fprintf(stdout, "## resolver completed\n");
   pic_debug(pic, obj);
-  fprintf(stderr, "\n");
+  fprintf(stdout, "\n");
-  fprintf(stderr, "ai = %d\n", pic_gc_arena_preserve(pic));
+  fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
 #endif
 
   /* codegen */
   irep = pic_codegen(pic, obj);
 #if DEBUG
-  fprintf(stderr, "## codegen completed\n");
+  fprintf(stdout, "## codegen completed\n");
   pic_dump_irep(pic, irep);
 #endif
 
 #if DEBUG
-  fprintf(stderr, "# compilation finished\n");
+  fprintf(stdout, "# compilation finished\n");
   puts("");
 #endif
 
@@ -1581,7 +1634,7 @@ print_code(pic_state *pic, struct pic_code c)
     printf("OP_TAILCALL\t%d\n", c.u.i);
     break;
   case OP_RET:
-    puts("OP_RET");
+    printf("OP_RET\t%d\n", c.u.i);
     break;
   case OP_LAMBDA:
     printf("OP_LAMBDA\t%d\n", c.u.i);

src/cont.c

@@ -181,13 +181,13 @@ pic_values(pic_state *pic, size_t c, ...)
   va_start(ap, c);
 
   for (i = 0; i < c; ++i) {
-    pic->ci->fp[i] = va_arg(ap, pic_value);
+    pic->sp[i] = va_arg(ap, pic_value);
   }
-  pic->ci->fp[i] = pic_undef_value();
+  pic->ci->retc = c;
 
   va_end(ap);
 
-  return c == 0 ? pic_none_value() : pic->ci->fp[0];
+  return c == 0 ? pic_none_value() : pic->sp[0];
 }
 
 pic_value
@@ -196,11 +196,11 @@ pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv)
   size_t i;
 
   for (i = 0; i < argc; ++i) {
-    pic->ci->fp[i] = argv[i];
+    pic->sp[i] = argv[i];
   }
-  pic->ci->fp[i] = pic_undef_value();
+  pic->ci->retc = argc;
 
-  return argc == 0 ? pic_none_value() : pic->ci->fp[0];
+  return argc == 0 ? pic_none_value() : pic->sp[0];
 }
 
 pic_value
@@ -211,30 +211,28 @@ pic_values_by_list(pic_state *pic, pic_value list)
 
   i = 0;
   pic_for_each (v, list) {
-    pic->ci->fp[i++] = v;
+    pic->sp[i++] = v;
   }
-  pic->ci->fp[i] = pic_undef_value();
+  pic->ci->retc = i;
 
-  return pic_nil_p(list) ? pic_none_value() : pic->ci->fp[0];
+  return pic_nil_p(list) ? pic_none_value() : pic->sp[0];
 }
 
 size_t
 pic_receive(pic_state *pic, size_t n, pic_value *argv)
 {
   pic_callinfo *ci;
-  size_t i;
+  size_t i, retc;
 
-  /* take info from already discarded frame */
+  /* take info from discarded frame */
   ci = pic->ci + 1;
+  retc = ci->retc;
 
-  for (i = 0; ; ++i) {
+  for (i = 0; i < n; ++i) {
-    if (pic_undef_p(ci->fp[i]))
+    argv[i] = ci->fp[i];
-      break;
-    if (i < n) {
-      argv[i] = ci->fp[i];
-    }
   }
-  return i;
+
+  return retc;
 }
 
 static pic_value

src/vm.c

@@ -411,6 +411,8 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
 
 #if VM_DEBUG
   puts("### booting VM... ###");
+  pic_value *stbase = pic->sp;
+  pic_callinfo *cibase = pic->ci;
 #endif
 
   PUSH(pic_obj_value(proc));
@@ -532,13 +534,15 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
       pic_callinfo *ci;
       struct pic_proc *proc;
 
+      if (c.u.i == -1) {
+        pic->sp += pic->ci[1].retc - 1;
+        c.u.i = pic->ci[1].retc + 1;
+      }
+
     L_CALL:
       x = pic->sp[-c.u.i];
       if (! pic_proc_p(x)) {
-#if DEBUG
+	pic_errorf(pic, "invalid application: ~S", x);
-	pic_debug(pic, x);
-#endif
-	pic_error(pic, "invalid application");
       }
       proc = pic_proc_ptr(x);
 
@@ -566,17 +570,18 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
 
       ci = PUSHCI();
       ci->argc = c.u.i;
+      ci->retc = 1;
       ci->ip = pic->ip;
       ci->fp = pic->sp - c.u.i;
       ci->env = NULL;
       if (pic_proc_cfunc_p(x)) {
-	v = proc->u.cfunc(pic);
+
-	ci = POPCI();
+        /* invoke! */
-        pic->ip = ci->ip;
+	pic->sp[0] = proc->u.cfunc(pic);
-	pic->sp = ci->fp;
+        pic->sp += ci->retc;
-	PUSH(v);
+
-	pic_gc_arena_restore(pic, ai);
+        pic_gc_arena_restore(pic, ai);
-	NEXT;
+        goto L_RET;
       }
       else {
 	int i;
@@ -624,20 +629,28 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
     CASE(OP_TAILCALL) {
       int i, argc;
       pic_value *argv;
+      pic_callinfo *ci;
+
+      if (c.u.i == -1) {
+        pic->sp += pic->ci[1].retc - 1;
+        c.u.i = pic->ci[1].retc + 1;
+      }
 
       argc = c.u.i;
       argv = pic->sp - argc;
       for (i = 0; i < argc; ++i) {
 	pic->ci->fp[i] = argv[i];
       }
-      pic->sp = pic->ci->fp + argc;
+      ci = POPCI();
-      pic->ip = POPCI()->ip;
+      pic->sp = ci->fp + argc;
+      pic->ip = ci->ip;
 
       /* c is not changed */
       goto L_CALL;
     }
     CASE(OP_RET) {
-      pic_value v;
+      int i, retc;
+      pic_value *retv;
       pic_callinfo *ci;
 
       if (pic->err) {
@@ -645,13 +658,22 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
       L_RAISE:
 	goto L_STOP;
       }
-      else {
+
-	v = POP();
+      pic->ci->retc = c.u.i;
-	ci = POPCI();
+
-	pic->ip = ci->ip;
+    L_RET:
-	pic->sp = ci->fp;
+      retc = pic->ci->retc;
-	PUSH(v);
+      retv = pic->sp - retc;
+      if (retc == 0) {
+        pic->ci->fp[0] = retv[0]; /* copy at least once */
       }
+      for (i = 0; i < retc; ++i) {
+        pic->ci->fp[i] = retv[i];
+      }
+      ci = POPCI();
+      pic->sp = ci->fp + 1;     /* advance only one! */
+      pic->ip = ci->ip;
+
       NEXT;
     }
     CASE(OP_LAMBDA) {
@@ -789,17 +811,17 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
 
 #if VM_DEBUG
       puts("**VM END STATE**");
-      printf("stbase\t= %p\nsp\t= %p\n", (void *)pic->stbase, (void *)pic->sp);
+      printf("stbase\t= %p\nsp\t= %p\n", (void *)stbase, (void *)pic->sp);
-      printf("cibase\t= %p\nci\t= %p\n", (void *)pic->cibase, (void *)pic->ci);
+      printf("cibase\t= %p\nci\t= %p\n", (void *)cibase, (void *)pic->ci);
-      if (pic->stbase < pic->sp) {
+      if (stbase < pic->sp) {
 	pic_value *sp;
 	printf("* stack trace:");
-	for (sp = pic->stbase; pic->sp != sp; ++sp) {
+	for (sp = stbase; pic->sp != sp; ++sp) {
 	  pic_debug(pic, *sp);
 	  puts("");
 	}
       }
-      if (pic->stbase > pic->sp) {
+      if (stbase > pic->sp) {
 	puts("*** stack underflow!");
       }
 #endif