From 2675f711a3387d2b9a9a6ebd893c64a8d8c4d9a1 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Wed, 28 Dec 2016 22:26:07 +0100
Subject: [PATCH] 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                 |  5 +++--
 module/mes/base-0.mes |  1 +
 module/mes/base.mes   |  2 +-
 module/mes/catch.mes  | 40 ++++++++++++++++++++++------------------
 tests/catch.test      | 39 +++++++++++++++++++++++++++++++--------
 tests/scm.test        | 10 ++++++----
 6 files changed, 64 insertions(+), 33 deletions(-)

diff --git a/mes.c b/mes.c
index 4e7883ad..919a27b4 100644
--- a/mes.c
+++ b/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"};
diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes
index 41073023..4ed7f483 100644
--- a/module/mes/base-0.mes
+++ b/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))
diff --git a/module/mes/base.mes b/module/mes/base.mes
index 2f3255a0..d3193858 100644
--- a/module/mes/base.mes
+++ b/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
diff --git a/module/mes/catch.mes b/module/mes/catch.mes
index 6ec9d414..18300040 100644
--- a/module/mes/catch.mes
+++ b/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)
-  (cons* '*exception* key args))
-
-(define (exception? o)
-  (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 %eh (make-fluid
+             (lambda (key . args)
+               (format (current-error-port) "unhandled exception: ~a ~a\n" key args)
+               (exit 1))))
 
 (define (catch key thunk handler)
-  (let ((result (thunk)))
-    (if (and (exception? result)
-             (or (eq? key (exception-key result))
-                 (eq? key #t)))
-        (handler (exception-key result) (exception-args result))
-        result)))
+  (let ((previous-eh (fluid-ref %eh)))
+    (with-fluid*
+        %eh #f
+        (lambda ()
+          (call/cc
+           (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))))
diff --git a/tests/catch.test b/tests/catch.test
index ae3f0780..22e360e0 100755
--- a/tests/catch.test
+++ b/tests/catch.test
@@ -31,17 +31,40 @@ exit $?
 (pass-if "first dummy" #t)
 (pass-if-not "second dummy" #f)
 
-(when (not guile?)
-  (pass-if "throw"
-    (exception? (make-exception #t))))
-(pass-if "catch"
+(pass-if-equal "catch"
+    789
   (catch #t
     (lambda ()
-      (throw #t)
-      ;;#f
-      )
+      (throw 'test-exception "foo!")
+      #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)
 
diff --git a/tests/scm.test b/tests/scm.test
index 2b4728ed..27b37571 100755
--- a/tests/scm.test
+++ b/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" (seq? (gensym) 'g0))
-  (pass-if "gensym" (seq? (gensym) 'g1))
-  (pass-if "gensym" (seq? (gensym) 'g2)))
+(pass-if "gensym"
+  (symbol? (gensym)))
+(pass-if "gensym 1"
+  (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 '()) '()))