core+scm: Implement exception handling.

* mes.c (scm_symbol_throw): New symbol.
* module/mes/catch.scm (catch, throw): Implement [WAS: syntactic sugar].
  (make-exception, exception?, exception-key, exception-args): Remove.
* tests/catch.test ("catch", "catch 22"): Add tests.
* module/mes/base-0.scm: Include it.

mes.c

@@ -114,10 +114,11 @@ scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"};
 scm scm_symbol_read_input_file = {SYMBOL, "read-input-file"};
 scm scm_symbol_write = {SYMBOL, "write"};
 scm scm_symbol_display = {SYMBOL, "display"};
-scm scm_symbol_argv = {SYMBOL, "argv"};
+scm scm_symbol_throw = {SYMBOL, "throw"};
 
-scm scm_symbol_mes_version = {SYMBOL, "%version"};
+scm scm_symbol_argv = {SYMBOL, "%argv"};
 scm scm_symbol_mes_prefix = {SYMBOL, "%prefix"};
+scm scm_symbol_mes_version = {SYMBOL, "%version"};
 
 scm scm_symbol_car = {SYMBOL, "car"};
 scm scm_symbol_cdr = {SYMBOL, "cdr"};

module/mes/base-0.mes

@@ -163,3 +163,4 @@
 (mes-use-module (mes scm))
 (mes-use-module (srfi srfi-13))
 (mes-use-module (mes display))
+(mes-use-module (mes catch))

module/mes/base.mes

@@ -43,7 +43,7 @@
 (define (identity x) x)
 (define call/cc call-with-current-continuation)
 
-(define (command-line) argv)
+(define (command-line) %argv)
 
 (define-macro (or . x)
   (if (null? x) #f

module/mes/catch.mes

@@ -19,25 +19,29 @@
 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
 (mes-use-module (mes let))
+(mes-use-module (mes fluids))
 
-(define (make-exception key . args)
+(define %eh (make-fluid
-  (cons* '*exception* key args))
+             (lambda (key . args)
-
+               (format (current-error-port) "unhandled exception: ~a ~a\n" key args)
-(define (exception? o)
+               (exit 1))))
-  (and (pair? o) (eq? (car o) '*exception*)))
-
-(define (exception-key o)
-  (if (exception? o) (cadr o)))
-
-(define (exception-args o)
-  (if (exception? o) (cddr o)))
 
 (define (catch key thunk handler)
-  (let ((result (thunk)))
+  (let ((previous-eh (fluid-ref %eh)))
-    (if (and (exception? result)
+    (with-fluid*
-             (or (eq? key (exception-key result))
+        %eh #f
-                 (eq? key #t)))
+        (lambda ()
-        (handler (exception-key result) (exception-args result))
+          (call/cc
-        result)))
+           (lambda (cc)
+             (fluid-set! %eh
+                         (lambda (k . args)
+                           (let ((handler (if (or (eq? key #t) (eq? key k)) handler
+                                              previous-eh)))
+                             (cc
+                              (lambda (x)
+                                (apply handler (cons k args)))))))
+             (thunk)))))))
 
-(define throw make-exception)
+(define (throw key . args)
+  (let ((handler (fluid-ref %eh)))
+    (apply handler (cons key args))))

tests/catch.test

@@ -31,17 +31,40 @@ exit $?
 (pass-if "first dummy" #t)
 (pass-if-not "second dummy" #f)
 
-(when (not guile?)
+(pass-if-equal "catch"
-  (pass-if "throw"
+    789
-    (exception? (make-exception #t))))
-(pass-if "catch"
   (catch #t
     (lambda ()
-      (throw #t)
+      (throw 'test-exception "foo!")
-      ;;#f
+      #f)
-      )
     (lambda (key . args)
-      #t)))
+      789)))
+
+(define (throw-22)
+  (throw 'twenty-two "hahah"))
+
+(pass-if-equal "catch 22"
+    789
+  (catch #t
+    (lambda ()
+      (throw-22)
+      #f)
+    (lambda (key . args)
+      789)))
+
+(if mes?
+    (pass-if-equal "catch feel"
+        1
+      (let ((save-exit exit))
+        (set! exit (lambda (x)
+                     (set! exit save-exit)
+                     1))
+        (catch 'boo
+          (lambda ()
+            (throw-22)
+            11)
+          (lambda (key . args)
+            22)))))
 
 (result 'report)
 

tests/scm.test

@@ -116,10 +116,12 @@ exit $?
   (pass-if "builtin? eval" (not (builtin? not))))
 (pass-if "procedure?" (procedure? builtin?))
 (pass-if "procedure?" (procedure? procedure?))
-(when (not guile?)
+(pass-if "gensym"
-  (pass-if "gensym" (seq? (gensym) 'g0))
+  (symbol? (gensym)))
-  (pass-if "gensym" (seq? (gensym) 'g1))
+(pass-if "gensym 1"
-  (pass-if "gensym" (seq? (gensym) 'g2)))
+  (not (eq? (gensym) (gensym))))
+(pass-if "gensym 2"
+  (not (eq? (gensym) (gensym))))
 
 (pass-if "last-pair " (sequal? (last-pair '(1 2 3 4)) '(4)))
 (pass-if "last-pair 2" (seq? (last-pair '()) '()))