blob: 6b45e14dd988348f73ad74e3dc4d31797d927a79 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
(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))))))
(define-public warning-handler
(make-parameter
(lambda (fmt . args)
(format (current-error-port)
"WARNING: ~?~%" fmt args))))
(define-public (warning fmt . args)
(apply (warning-handler) fmt (or args '())))
|
