diff options
author | Hugo Hörnquist <hugo@hornquist.se> | 2019-04-25 11:39:38 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@hornquist.se> | 2019-04-25 11:39:49 +0200 |
commit | 2d78e18454545801fbf3ac02c1d32ea68ef65de2 (patch) | |
tree | 96cd2d971f0369b4af2eef0c5dab475624b7c30f /module/util/exceptions.scm | |
parent | Remove take-drop-while, span already in SRFI-1. (diff) | |
download | calp-2d78e18454545801fbf3ac02c1d32ea68ef65de2.tar.gz calp-2d78e18454545801fbf3ac02c1d32ea68ef65de2.tar.xz |
Clean up util and move exceptions.
Diffstat (limited to 'module/util/exceptions.scm')
-rw-r--r-- | module/util/exceptions.scm | 40 |
1 files changed, 40 insertions, 0 deletions
diff --git a/module/util/exceptions.scm b/module/util/exceptions.scm new file mode 100644 index 00000000..d649643c --- /dev/null +++ b/module/util/exceptions.scm @@ -0,0 +1,40 @@ +(define-module (util exceptions) + #:use-module (srfi srfi-1) + #:use-module (util) + #:export (throw-returnable + catch-multiple)) + +(define-syntax-rule (throw-returnable symb args ...) + (call/cc (lambda (cont) (throw symb cont args ...)))) + +;; Takes a (non nested) list, and replaces all single underscore +;; symbols with a generated symbol. For macro usage. +(define (multiple-ignore lst) + (map/dotted (lambda (symb) (if (eq? symb '_) (gensym "ignored_") symb)) + lst)) + +;; Like @var{catch}, but multiple handlers can be specified. +;; Each handler is on the form +;; @example +;; [err-symb (args ...) body ...] +;; @end example +;; +;; Only errors with a handler are caught. Error can *not* be given as +;; an early argument. +(define-macro (catch-multiple thunk . cases) + (let catch-recur% ((errs (map car cases)) (cases cases)) + (let* ((v (car errs)) + (case other (partition (lambda (case) (eq? v (car case))) cases)) + (g!rest (gensym "rest"))) + `(catch (quote ,v) + ,(if (null? (cdr errs)) + thunk + `(lambda () ,(catch-recur% (cdr errs) other))) + (lambda (err . ,g!rest) + (apply (lambda ,(let ((param-list (second (car case)))) + (if (not (pair? param-list)) + param-list + (multiple-ignore param-list))) + ,@(cddr (car case))) + ,g!rest)))))) + |