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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
(define-module (util exceptions)
#:use-module (srfi srfi-1)
#:use-module (util)
#:use-module (util config)
#:use-module (ice-9 format)
#:export (throw-returnable
catch-multiple
assert))
(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 #f "WARNING: ~?~%" fmt args))))
(define-public warnings-are-errors
(make-parameter #f))
(define-config warnings-are-errors #f
"Crash on warnings."
post: warnings-are-errors)
;; forwards return from warning-hander. By default returns an unspecified value,
;; but instances are free to provide a proper return value and use it.
(define-public (warning fmt . args)
(display (apply (warning-handler) fmt (or args '()))
(current-error-port))
(when (warnings-are-errors)
(throw 'warning fmt args)))
(define-public (fatal fmt . args)
(display (format #f "FATAL: ~?~%" fmt (or args '()))
(current-error-port))
(raise 2)
)
(define (prettify-tree tree)
(cond [(pair? tree) (cons (prettify-tree (car tree))
(prettify-tree (cdr tree)))]
[(and (procedure? tree) (procedure-name tree))
=> identity]
[else tree]))
(define-macro (assert form)
`(unless ,form
(throw 'assertion-error "Assertion for ~a failed, ~a"
(quote ,form)
((@@ (util exceptions) prettify-tree) ,(cons 'list form)))))
|
