core+scm: Implement exception handling.
authorJan Nieuwenhuizen <janneke@gnu.org>
Wed, 28 Dec 2016 21:26:07 +0000 (22:26 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Wed, 28 Dec 2016 21:26:07 +0000 (22:26 +0100)
* 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
module/mes/base-0.mes
module/mes/base.mes
module/mes/catch.mes
tests/catch.test
tests/scm.test

diff --git a/mes.c b/mes.c
index 4e7883ad0274274e8657814b25a7dcb74d8f7cdc..919a27b427fd2243984110d10ef09b3c9e65e5d5 100644 (file)
--- 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"};
index 41073023327c1198424bb1af3abc848632c52688..4ed7f483db3c1bfb86442e63c0d9225cfb2efcb7 100644 (file)
 (mes-use-module (mes scm))
 (mes-use-module (srfi srfi-13))
 (mes-use-module (mes display))
+(mes-use-module (mes catch))
index 2f3255a0e129b4efa7c7b744fb35b809b46e08b8..d31938589ce930686dae2ca932a47927fd366bbf 100644 (file)
@@ -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
index 6ec9d41460c2240dbb5d4541808e2d624eb91589..18300040f29fceb61534c065c24c043298d214fc 100644 (file)
 ;;; 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)))
-
-(define throw make-exception)
+  (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 key . args)
+  (let ((handler (fluid-ref %eh)))
+    (apply handler (cons key args))))
index ae3f0780e171293698fec8d5524daf3d8e79968a..22e360e08d5c3e13f36b581268a61144cdc66647 100755 (executable)
@@ -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)
 
index 2b4728edcfa956178c7d2b04b31be9923062b02b..27b3757127e253079b7da47fa724074541509484 100755 (executable)
@@ -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 '()) '()))