Replacing eval opcode with compile + normal application.

eval.c

@@ -1743,22 +1743,27 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se
 
 /************************** eval interface ****************************/
 
-sexp sexp_compile (sexp ctx, sexp x) {
+sexp sexp_compile_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) {
   sexp_gc_var3(ast, vec, res);
   sexp_gc_preserve3(ctx, ast, vec, res);
-  ast = sexp_analyze(ctx, x);
+  sexp ctx2;
+  if (! env) env = sexp_context_env(ctx);
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0);
+  sexp_context_child(ctx) = ctx2;
+  ast = sexp_analyze(ctx2, obj);
   if (sexp_exceptionp(ast)) {
     res = ast;
   } else {
-    res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS);
+    res = sexp_global(ctx2, SEXP_G_OPTIMIZATIONS);
     for ( ; sexp_pairp(res); res=sexp_cdr(res))
-      ast = sexp_apply1(ctx, sexp_cdar(res), ast);
-    sexp_free_vars(ctx, ast, SEXP_NULL);    /* should return SEXP_NULL */
-    emit_enter(ctx);
-    generate(ctx, ast);
-    res = finalize_bytecode(ctx);
-    vec = sexp_make_vector(ctx, 0, SEXP_VOID);
-    res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec);
+      ast = sexp_apply1(ctx2, sexp_cdar(res), ast);
+    sexp_free_vars(ctx2, ast, SEXP_NULL);    /* should return SEXP_NULL */
+    emit_enter(ctx2);
+    generate(ctx2, ast);
+    res = finalize_bytecode(ctx2);
+    vec = sexp_make_vector(ctx2, 0, SEXP_VOID);
+    res = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, vec);
   }
   sexp_gc_release3(ctx);
   return res;
@@ -1776,7 +1781,7 @@ sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) {
   sexp_context_params(ctx) = SEXP_NULL;
   ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0);
   sexp_context_child(ctx) = ctx2;
-  res = sexp_compile(ctx2, obj);
+  res = sexp_compile_op(ctx2, self, n, obj, env);
   if (! sexp_exceptionp(res))
     res = sexp_apply(ctx2, res, SEXP_NULL);
   sexp_context_child(ctx) = SEXP_FALSE;

include/chibi/eval.h

@@ -140,6 +140,7 @@ SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
 SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
 SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv);
 SEXP_API int sexp_param_index (sexp lambda, sexp name);
+SEXP_API sexp sexp_compile_op (sexp context sexp_api_params(self, n), sexp obj, sexp env);
 SEXP_API sexp sexp_eval_op (sexp context sexp_api_params(self, n), sexp obj, sexp env);
 SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp_sint_t len, sexp env);
 SEXP_API sexp sexp_load_op (sexp context sexp_api_params(self, n), sexp expr, sexp env);

lib/chibi/repl.scm

@@ -37,13 +37,19 @@
            (let* ((expr (call-with-input-string line read/ss))
                   (thread (make-thread
                            (lambda ()
-                             (let ((res (eval expr env)))
-                               (if (not (eq? res (if #f #f)))
-                                   (write/ss res))
-                               (newline))))))
+                             (handle-exceptions
+                              exn
+                              (print-exception exn (current-error-port))
+                              (let ((res (eval expr env)))
+                                (cond
+                                 ((not (eq? res (if #f #f)))
+                                  (write/ss res)
+                                  (newline)))))))))
              (with-signal-handler
               signal/interrupt
-              (lambda (n) (thread-terminate! thread))
+              (lambda (n)
+                (display "Interrupt\n" (current-error-port))
+                (thread-terminate! thread))
               (lambda () (thread-join! (thread-start! thread))))))
           (lp module env)))))))
 

lib/init.scm

@@ -65,6 +65,9 @@
          (apply1 proc (append2 (reverse (cdr lol)) (car lol))))
        (reverse args))))
 
+(define (eval x . o)
+  ((compile x (if (pair? o) (car o) (interaction-environment)))))
+
 ;; map with a fast-path for single lists
 
 (define (map proc ls . lol)

opcodes.c

@@ -111,7 +111,7 @@ _FN1(SEXP_VOID, _I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op),
 _FN0(_I(SEXP_ENV), "make-environment", 0, sexp_make_env_op),
 _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op),
 _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op),
-_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "eval", (sexp)"interaction-environment", sexp_eval_op),
+_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "compile", (sexp)"interaction-environment", sexp_compile_op),
 _FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"interaction-environment", sexp_load_op),
 _FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%env-copy!", 0, sexp_env_copy_op),
 _FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op),

vm.c

@@ -659,7 +659,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
     goto make_call;
   case SEXP_OP_TAIL_CALL:
     _ALIGN_IP();
-    i = sexp_unbox_fixnum(_WORD0);    /* number of params */
+    i = sexp_unbox_fixnum(_WORD0);             /* number of params */
     tmp1 = _ARG1;                              /* procedure to call */
     /* save frame info */
     tmp2 = stack[fp+3];
@@ -734,8 +734,8 @@ sexp sexp_vm (sexp ctx, sexp proc) {
     fp = top-4;
     break;
   case SEXP_OP_FCALL0:
-    tmp1 = _WORD0;
     _ALIGN_IP();
+    tmp1 = _WORD0;
     sexp_context_top(ctx) = top;
     sexp_context_last_fp(ctx) = fp;
     _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0)));