*** empty log message ***

module/language/gscheme/spec.scm

@@ -93,6 +93,17 @@
 				  (@begin ,@(map translate body)
 					  (_loop ,@(map translate update)))))))
 		    (_loop ,@(map translate init))))))
+
+      ((eval-case)
+       `(@eval-case
+	 ,@(let loop ((x rest))
+	     (match x
+	       (() '(()))
+	       ((('else . body)) `((@else ,@(map translate body))))
+	       (((keys . body) . rest)
+		`((,keys ,@(map translate body)) ,@(loop rest)))
+	       (else (error "bad eval-case" x))))))
+
       (else
        (let ((e (expand x)))
 	 (if (eq? e x)

module/system/il/ghil.scm

@@ -126,6 +126,9 @@
 (define-method (make-ghil-env (e <ghil-env>))
   (make <ghil-env> :mod e.mod :parent e))
 
+(define (ghil-env-toplevel? e)
+  (eq? e.mod e.parent))
+
 (define-method (ghil-env-ref (env <ghil-env>) (sym <symbol>))
   (assq-ref env.table sym))
 
@@ -267,6 +270,20 @@
 			    syms)))
 	    (make-<ghil-lambda> e vars rest (parse-body body e)))))))
 
+    ;; (@eval-case CLAUSE...)
+    ((@eval-case)
+     (match args
+       ((clause . rest)
+	(match clause
+	  (() (make-<ghil-void>))
+	  (((key ...) . body)
+	   (cond ((and (ghil-env-toplevel? e) (memq 'load-toplevel key))
+		  (parse-body body e))
+		 (else
+		  (error "No match clause"))))
+	  (else
+	   (error "No match clause"))))))
+
     (else (error "Unknown primitive:" prim))))
 
 (define (parse-body x e)

module/system/il/macros.scm

@@ -50,21 +50,6 @@
      (let ((sym (make-sym)))
        `(@let ((,sym ,x)) (@if ,sym ,sym (@or ,@rest)))))))
 
-;; (@cond (TEST BODY...) ...) =>
-;;
-;;   (@if TEST
-;;        (@begin BODY...)
-;;        (@cond ...))
-(define (@cond . clauses)
-  (cond ((null? clauses) (error "missing clauses"))
-	((pair? (car clauses))
-	 (let ((c (car clauses)) (l (cdr clauses)))
-	   (let ((rest (if (null? l) '(@void) `(@cond ,@l))))
-	     (cond ((eq? (car c) '@else) `(@begin (@void) ,@(cdr c)))
-		   ((null? (cdr c)) `(@or ,(car c) ,rest))
-		   (else `(@if ,(car c) (@begin ,@(cdr c)) ,rest))))))
-	(else (error "bad clause:" (car clauses)))))
-
 (define (@let* binds . body)
   (if (null? binds)
       `(@begin ,@body)

module/system/vm/conv.scm

@@ -82,7 +82,7 @@
      (integer->char n))
     (('load-string s) s)
     (('load-symbol s) (string->symbol s))
-    (('load-keyword s) (symbol->keyword (string->symbol s)))
+    (('load-keyword s) (make-keyword-from-dash-symbol (string->symbol s)))
     (else #f)))
 
 (define (code->bytes code)

src/vm_system.c

@@ -347,6 +347,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
       NEXT;
     }
 
+  program = x;
   goto vm_error_wrong_type_apply;
 }
 
@@ -415,6 +416,7 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
   if (SCM_VM_CONT_P (x))
     goto vm_call_cc;
 
+  program = x;
   goto vm_error_wrong_type_apply;
 }