source: project/release/4/check-errors/trunk/conditions.scm @ 15588

Last change on this file since 15588 was 15588, checked in by Kon Lovett, 10 years ago

Added 'make-error-type-message' & fixed 'define-check+error-type'.

File size: 2.7 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.