fixing tail-call bug when the new frame is larger.

allowing (error x) for any object x.
vm tracing is now a compile-time option with -DDEBUG_VM.

Makefile

@@ -19,13 +19,13 @@ GC_OBJ=./gc/gc.a
 	cd gc && make test
 
 sexp.o: sexp.c sexp.h config.h defaults.h Makefile
-	gcc -c $(CFLAGS) -o $@ $<
+	gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
 
 eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile
-	gcc -c $(CFLAGS) -o $@ $<
+	gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
 
 main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile
-	gcc -c $(CFLAGS) -o $@ $<
+	gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
 
 libchibisexp.$(SO): sexp.o $(GC_OBJ)
 	gcc $(LDFLAGS) -shared -dynamiclib -o $@ $^

debug.c

@@ -61,32 +61,7 @@ static sexp sexp_disasm (sexp bc, sexp out) {
   return SEXP_VOID;
 }
 
-static void print_bytecode (sexp bc) {
+static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) {
-  int i;
-  unsigned char *data = sexp_bytecode_data(bc);
-  fprintf(stderr, "bytecode @ %p, data @ %p, length = %lu\n",
-          bc, data, sexp_bytecode_length(bc));
-  for (i=0; i+16 < sexp_bytecode_length(bc); i+=8) {
-    fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x   ", i,
-            data[i], data[i+1], data[i+2], data[i+3],
-            data[i+4], data[i+5], data[i+6], data[i+7]);
-    i += 8;
-    fprintf(stderr, "%02x %02x %02x %02x %02x %02x %02x %02x\n",
-            data[i], data[i+1], data[i+2], data[i+3],
-            data[i+4], data[i+5], data[i+6], data[i+7]);
-  }
-  if (i != sexp_bytecode_length(bc)) {
-    fprintf(stderr, "%02x:", i);
-    for ( ; i < sexp_bytecode_length(bc); i++) {
-      if ((i % 8) == 0 && (i % 16) != 0)
-        fprintf(stderr, "  ");
-      fprintf(stderr, " %02x", data[i]);
-    }
-    fprintf(stderr, "\n");
-  }
-}
-
-static void print_stack (sexp *stack, int top, int fp, sexp out) {
   int i;
   for (i=0; i<top; i++) {
     sexp_printf(out, "%s %02d: ", ((i==fp) ? "*" : " "), i);

eval.c

@@ -242,6 +242,7 @@ static sexp sexp_make_context(sexp *stack, sexp env) {
   sexp_context_pos(res) = 0;
   sexp_context_top(res) = 0;
   sexp_context_tailp(res) = 0;
+  sexp_context_tracep(res) = 0;
   return res;
 }
 
@@ -251,6 +252,7 @@ static sexp sexp_child_context(sexp context, sexp lambda) {
   sexp_context_lambda(ctx) = lambda;
   sexp_context_env(ctx) = sexp_context_env(context);
   sexp_context_top(ctx) = sexp_context_top(context);
+  sexp_context_tracep(ctx) = sexp_context_tracep(context);
   return ctx;
 }
 
@@ -991,8 +993,13 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
   sexp_sint_t i, j, k, fp=top-4;
 
  loop:
-/*   print_stack(stack, top, fp, env_global_ref(env, the_cur_err_symbol, SEXP_FALSE)); */
+#ifdef DEBUG_VM
-/*   fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); */
+  if (sexp_context_tracep(context)) {
+    sexp_print_stack(stack, top, fp,
+                     env_global_ref(env, the_cur_err_symbol, SEXP_FALSE));
+    fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN");
+  }
+#endif
   switch (*ip++) {
   case OP_NOOP:
     fprintf(stderr, "<<<NOOP>>>\n");
@@ -1050,6 +1057,7 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
     i = sexp_unbox_integer(_WORD0);    /* number of params */
     tmp1 = _ARG1;                              /* procedure to call */
     /* save frame info */
+    tmp2 = stack[fp+3];
     j = sexp_unbox_integer(stack[fp]);
     ip = ((unsigned char*) sexp_unbox_integer(stack[fp+1])) - sizeof(sexp);
     cp = stack[fp+2];
@@ -1057,7 +1065,7 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
     for (k=0; k<i; k++)
       stack[fp-j+k] = stack[top-1-i+k];
     top = fp+i-j+1;
-    fp = sexp_unbox_integer(stack[fp+3]);
+    fp = sexp_unbox_integer(tmp2);
     goto make_call;
   case OP_CALL:
     if (top >= INIT_STACK_SIZE)

main.c

@@ -4,6 +4,7 @@
 void repl (sexp context) {
   sexp obj, res, env, in, out, err;
   env = sexp_context_env(context);
+  sexp_context_tracep(context) = 1;
   in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE);
   out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE);
   err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);

sexp.c

@@ -118,6 +118,7 @@ sexp sexp_range_exception (sexp obj, sexp start, sexp end) {
 sexp sexp_print_exception (sexp exn, sexp out) {
   sexp ls;
   sexp_write_string("ERROR", out);
+  if (sexp_exceptionp(exn)) {
     if (sexp_integerp(sexp_exception_line(exn))
         && (sexp_exception_line(exn) > sexp_make_integer(0))) {
       sexp_write_string(" on line ", out);
@@ -141,11 +142,19 @@ sexp sexp_print_exception (sexp exn, sexp out) {
              sexp_pairp(ls); ls=sexp_cdr(ls)) {
           sexp_write_string("    ", out);
           sexp_write(sexp_car(ls), out);
-        sexp_write_string("\n", out);
+          sexp_write_char('\n', out);
         }
       }
     } else {
-    sexp_write_string("\n", out);
+      sexp_write_char('\n', out);
+    }
+  } else {
+    sexp_write_string(": ", out);
+    if (sexp_stringp(exn))
+      sexp_write_string(sexp_string_data(exn), out);
+    else
+      sexp_write(exn, out);
+    sexp_write_char('\n', out);
   }
   return SEXP_VOID;
 }

sexp.h

@@ -160,7 +160,7 @@ struct sexp_struct {
     /* compiler state */
     struct {
       sexp bc, lambda, *stack, env;
-      sexp_uint_t pos, top, depth, tailp;
+      sexp_uint_t pos, top, depth, tailp, tracep;
     } context;
   } value;
 };
@@ -340,6 +340,7 @@ struct sexp_struct {
 #define sexp_context_top(x)     ((x)->value.context.top)
 #define sexp_context_lambda(x)  ((x)->value.context.lambda)
 #define sexp_context_tailp(x)   ((x)->value.context.tailp)
+#define sexp_context_tracep(x)  ((x)->value.context.tailp)
 
 /****************************** arithmetic ****************************/
 

syntax-rules.scm

@@ -168,7 +168,7 @@
                 (map
                  (lambda (clause) (expand-pattern (car clause) (cadr clause)))
                  forms)
-                (list (list 'else) (list 'error "no expansion"))))))))))
+                (list (list 'error "no expansion"))))))))))
 
 ;; Local Variables:
 ;; eval: (put '_lambda 'scheme-indent-function 1)