1 | ;;;; conditions.scm |
---|
2 | ;;;; Kon Lovett, Apr '09 |
---|
3 | |
---|
4 | (declare |
---|
5 | (usual-integrations) |
---|
6 | (fixnum) |
---|
7 | (inline) |
---|
8 | (local) |
---|
9 | (no-procedure-checks) |
---|
10 | (no-bound-checks) ) |
---|
11 | |
---|
12 | ;;; |
---|
13 | |
---|
14 | (module conditions (;export |
---|
15 | make-exn-condition |
---|
16 | make-exn-condition+ |
---|
17 | make-condition+ |
---|
18 | condition-predicate* |
---|
19 | condition-property-accessor* |
---|
20 | (make-condition-predicate condition-predicate*) |
---|
21 | (make-condition-property-accessor condition-property-accessor*)) |
---|
22 | |
---|
23 | (import scheme chicken (only srfi-1 alist-cons) srfi-12 type-checks) |
---|
24 | (require-library srfi-1 srfi-12 type-checks) |
---|
25 | |
---|
26 | ;; |
---|
27 | |
---|
28 | (define (make-exn-condition loc msg args) |
---|
29 | (apply make-property-condition |
---|
30 | 'exn |
---|
31 | (append (if loc `(location ,loc) '()) |
---|
32 | (if msg `(message ,msg) '()) |
---|
33 | (if (and args (not (null? args))) `(arguments ,args) '()))) ) |
---|
34 | |
---|
35 | ;; cond: |
---|
36 | ;; <condition> -> <condition> |
---|
37 | ;; <symbol> -> (make-property-condition <symbol>) |
---|
38 | ;; <pair> -> (apply make-property-condition <pair>) |
---|
39 | ;; (<symbol> [<symbol> <object>]...) |
---|
40 | |
---|
41 | (define (expand-property-conditions cnds) |
---|
42 | (map (lambda (cnd) |
---|
43 | (cond ((condition? cnd) cnd ) |
---|
44 | ((symbol? cnd) (make-property-condition cnd) ) |
---|
45 | ((pair? cnd) (apply make-property-condition cnd) ) ) ) |
---|
46 | cnds) ) |
---|
47 | |
---|
48 | ;; |
---|
49 | |
---|
50 | (define (make-exn-condition+ loc msg args . cnds) |
---|
51 | (apply make-composite-condition |
---|
52 | (make-exn-condition loc msg args) |
---|
53 | (expand-property-conditions cnds)) ) |
---|
54 | |
---|
55 | ;; |
---|
56 | |
---|
57 | (define (make-condition+ . cnds) |
---|
58 | (apply make-composite-condition (expand-property-conditions cnds)) ) |
---|
59 | |
---|
60 | ;; |
---|
61 | |
---|
62 | (define condition-predicate* |
---|
63 | (let ((preds '())) |
---|
64 | (lambda (kind) |
---|
65 | (check-symbol 'condition-predicate* kind) |
---|
66 | (let ((cell (assq kind preds))) |
---|
67 | (if cell (cdr cell) |
---|
68 | (let ((pred (condition-predicate kind))) |
---|
69 | (set! preds (alist-cons kind pred preds)) |
---|
70 | pred ) ) ) ) ) ) |
---|
71 | |
---|
72 | ;; |
---|
73 | |
---|
74 | (define condition-property-accessor* |
---|
75 | (let ((accrs '())) |
---|
76 | (lambda (kind prop #!optional dflt) |
---|
77 | (check-symbol 'condition-property-accessor* kind) |
---|
78 | (check-symbol 'condition-property-accessor* prop) |
---|
79 | (let ((cell (assoc (cons kind prop) accrs))) |
---|
80 | (if cell (cdr cell) |
---|
81 | (let ((accr (condition-property-accessor kind prop dflt))) |
---|
82 | (set! accrs (alist-cons (cons kind prop) accr accrs)) |
---|
83 | accr ) ) ) ) ) ) |
---|
84 | |
---|
85 | ;; |
---|
86 | |
---|
87 | (define-syntax make-condition-predicate |
---|
88 | (syntax-rules () |
---|
89 | ((_ kind0 ...) (lambda (obj) (and ((condition-predicate* 'kind0) obj) ...) ) ) ) ) |
---|
90 | |
---|
91 | ;; |
---|
92 | |
---|
93 | (define-syntax make-condition-property-accessor |
---|
94 | (syntax-rules () |
---|
95 | ((_ kind prop) (make-condition-property-accessor kind prop #f) ) |
---|
96 | ((_ kind prop dflt) (condition-property-accessor* 'kind 'prop dflt) ) ) ) |
---|
97 | |
---|
98 | ) ;module conditions |
---|