From 1a91192636f8d326ae8c9710596838b0d6ec8da0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 20 Apr 2019 21:34:14 +0200 Subject: Add catch-multiple. --- module/util.scm | 36 +++++++++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) (limited to 'module/util.scm') diff --git a/module/util.scm b/module/util.scm index a5d3d0dc..702873a1 100644 --- a/module/util.scm +++ b/module/util.scm @@ -6,7 +6,8 @@ for-each-in for define-quick-record mod! sort* sort*! - find-min) + find-min + catch-multiple) #:replace (let* set!) ) @@ -242,3 +243,36 @@ (call-with-values (lambda () (apply proc args)) (lambda args (list-ref args n))))) +;; Takes a (non nested) list, and replaces all single underscore +;; symbols with a generated symbol. For macro usage. +(define (multiple-ignore lst) + (cond ((not-pair? lst) lst) + ((eq? '_ (car lst)) (cons (gensym "ignored_") + (multiple-ignore (cdr lst)))) + (else (cons (car lst) + (multiple-ignore (cdr lst)))))) + +(define (catch-recur% errs thunk 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) thunk other))) + (lambda (err . ,g!rest) + (apply (lambda ,(multiple-ignore (second (car case))) + ,@(cddr (car case))) + ,g!rest))))) + +;; 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) + (catch-recur% (map car cases) thunk cases)) + -- cgit v1.2.3