source: project/release/3/misc-extn/trunk/misc-extn-condition-support.scm @ 10987

Last change on this file since 10987 was 6200, checked in by Kon Lovett, 14 years ago

Added tests (finally).

File size: 4.3 KB
Line 
1;;;; misc-extn-condition-support.scm
2;;;; Kon Lovett, Jul '07
3
4(use srfi-1 #;srfi-12 lolevel)
5
6(eval-when (compile)
7  (declare
8    (fixnum)
9    (inline)
10    (no-procedure-checks)
11    (no-bound-checks)
12    (export
13      handle-condition
14      #;condition-properties-fold
15      #;condition-properties-fold/list
16      composite-condition?
17      condition-kind-keys
18      condition-property-keys
19      condition-properties
20      condition-explode
21      make-property-condition/list) ) )
22
23;;;
24
25(define (condition-kind-list cnd)
26  (block-ref cnd 1) )
27
28(define (condition-property-list cnd)
29  (block-ref cnd 2) )
30
31(define (make-condition kinds props)
32  (make-record-instance 'condition kinds props) )
33
34;;;
35
36(define (check-condition obj loc)
37  (unless (condition? obj)
38    (error loc "invalid condition" obj) ) )
39
40(define (check-procedure obj loc)
41  (unless (procedure? obj)
42    (error loc "invalid procedure" obj) ) )
43
44(define (check-kind-key-list obj loc)
45  (unless (and (list? obj)
46               (every symbol? obj))
47    (error loc "invalid conditon kind keys" obj) ) )
48
49(define (check-property-alist obj loc)
50  (let ([is-value #f])
51    (unless (and (list? obj)
52                 (every
53                   (lambda (cell)
54                     (if is-value
55                         (begin (set! is-value #f) #t)
56                         (begin
57                           (set! is-value #t)
58                           (and (pair? cell)
59                                (let ([key (car cell)])
60                                  (pair? key)
61                                  (symbol? (car key))
62                                  (symbol? (cdr key)) ) ) ) ) )
63                   obj) )
64      (error loc "invalid condition property list" obj) ) ) )
65
66;;;
67
68(define (%condition-properties-fold proc init cnd kind-key)
69  (let ([kind-key (or kind-key (car (condition-kind-list cnd)))])
70    (let loop ([props (condition-property-list cnd)] [acc init])
71      (if (null? props)
72          acc
73          (let* ([key (car props)]
74                 [next1 (cdr props)]
75                 [next2 (cdr next1)])
76            (if (eq? kind-key (car key))
77                (loop next2 (proc (cdr key) (car next1) acc))
78                (loop next2 acc)))) ) ) )
79
80(define (%condition-properties-fold/list proc cnd kind-key)
81  (let ([lst (%condition-properties-fold proc '() cnd kind-key)])
82    (and (not (null? lst))
83         lst ) ) )
84
85#;
86(define (*condition-properties-fold proc init cnd kind-key loc)
87  (check-condition cnd loc)
88  (check-procedure proc loc)
89  (%condition-properties-fold proc init cnd kind-key) )
90
91(define (*condition-properties-fold/list proc cnd kind-key loc)
92  (check-condition cnd loc)
93  (check-procedure proc loc)
94  (%condition-properties-fold/list proc cnd kind-key) )
95
96;;;
97
98(define (handle-condition thunk #!optional (handler identity))
99  (call/cc
100    (lambda (k)
101      (with-exception-handler
102        (lambda (exn)
103          (k (handler exn)))
104        thunk))) )
105
106#;
107(define (condition-properties-fold proc init cnd kind-key)
108  (*condition-properties-fold proc init cnd kind-key 'condition-properties-fold) )
109
110#;
111(define (condition-properties-fold/list proc cnd kind-key)
112  (*condition-properties-fold/list proc cnd kind-key 'condition-properties-fold/list) )
113
114(define (composite-condition? obj . kind-keys)
115  (let ([kind-list (condition-kind-list obj)])
116    (and (condition? obj)
117         (not (null? (cdr kind-list )))
118         (or (null? kind-keys)
119             (every (cut memq <> kind-list) kind-keys) ) ) ) )
120
121(define (condition-kind-keys cnd)
122  (check-condition cnd 'condition-kind-keys)
123  (list-copy (condition-kind-list cnd)) )
124
125(define (condition-property-keys cnd #!optional kind-key)
126  (*condition-properties-fold/list
127    (lambda (key val lst) (cons key lst)) cnd kind-key
128    'condition-property-keys) )
129
130(define (condition-properties cnd #!optional kind-key)
131  (*condition-properties-fold/list
132    (lambda (key val lst) (alist-cons key val lst)) cnd kind-key
133    'condition-properties) )
134
135(define (condition-explode cnd)
136  (check-condition cnd 'condition-explode)
137  (map (lambda (kind-key) (cons kind-key (condition-properties cnd kind-key)))
138       (condition-kind-keys cnd)) )
139
140(define (make-property-condition/list kinds props)
141  (check-kind-key-list kinds 'make-property-condition/list)
142  (check-property-alist props 'make-property-condition/list)
143  (make-condition kinds props) )
Note: See TracBrowser for help on using the repository browser.