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

Last change on this file was 5537, checked in by Kon Lovett, 14 years ago

Bugfix for unbound stuff.

File size: 5.8 KB
Line 
1;;;; misc-extn-condition.scm
2;;;; Kon Lovett, Jul '07
3
4;;; Conditions
5
6;; Support Macros
7
8(define-for-syntax (me$bld-cnd-ctor-name key)
9  (string->symbol (conc "make" #\- key #\- "condition")) )
10
11(define-for-syntax (me$bld-cnd-pred-name key)
12  (string->symbol (conc key #\- "condition" #\?)) )
13
14(define-for-syntax (me$bld-cnd-naming key)
15  (string->symbol (conc key #\- "condition")) )
16
17;; ?form is symbol or list (key-symbol [property-symbol ...])
18;; Makes only property-condition constructor
19
20(define-macro (me$bld-prop-cnd-ctor ?form loc)
21  (cond
22    [(symbol? ?form)
23      `(define ,(me$bld-cnd-ctor-name ?form)
24        (let ([cnd (make-property-condition ',?form)])
25          (lambda ()
26            cnd)))]
27    [(pair? ?form)
28      (let ([key (car ?form)]
29            [props (cdr ?form)])
30      `(define (,(me$bld-cnd-ctor-name key) ,@props)
31        (make-property-condition ',key
32          ,@(let loop ([props props] [lst '()])
33            (if (null? props)
34              (reverse lst)
35              (let ([key (car props)])
36                (unless (symbol? key)
37                  (syntax-error loc "invalid property symbol" key) )
38                (loop
39                  (cdr props)
40                  (cons key (cons `(quote ,key) lst)))))))))]
41    [else
42      (syntax-error loc "invalid condition form" ?form)]) )
43
44;; ?form is symbol or list of symbol
45;; Makes both property-condition & composite-conditon
46;; predicates.
47
48(define-macro (me$bld-cnd-pred ?form loc)
49  (cond
50    [(symbol? ?form)
51      `(define ,(me$bld-cnd-pred-name ?form)
52        (let ([cnd? (condition-predicate ',?form)])
53          (lambda (obj)
54            (cnd? obj) ) ) )]
55    [(pair? ?form)
56      `(define (,(me$bld-cnd-pred-name
57                  (string-append (apply conc (intersperse ?form "-"))))
58                obj)
59        (and
60          ,@(let loop ([ilst ?form] [olst '()])
61            (if (null? ilst)
62              olst
63              (loop
64                (cdr ilst)
65                (cons
66                  `(,(me$bld-cnd-pred-name (car ilst)) obj)
67                  olst))))))]
68    [else
69      (syntax-error loc "invalid condition form" ?form)]) )
70
71;; Build one or more property condition procedure suites.
72
73(define-macro (build-property-condition-API ?form . ?args)
74  `(begin
75    ; Make property condition api for each form
76    ,@(let loop ([args (cons ?form ?args)] [lst '()])
77      (if (null? args)
78        (reverse lst)
79        (loop
80          (cdr args)
81          (cons
82            ; Note the macroexpansion; to support condition naming.
83            (let ([form (macroexpand (car args))])
84              (cond
85                [(symbol? form)
86                  `(begin
87                    (me$bld-prop-cnd-ctor ,form build-property-condition-API)
88                    (me$bld-cnd-pred ,form build-property-condition-API))]
89                [(pair? form)
90                  `(begin
91                    (me$bld-prop-cnd-ctor ,form build-property-condition-API)
92                    (me$bld-cnd-pred ,(car form) build-property-condition-API))]
93                [else
94                  (syntax-error 'build-property-condition-API
95                    "invalid condition form" form)]))
96            lst))))) )
97
98;; Build a composite condition procedure suite.
99
100(define-macro (build-composite-condition-API ?form . ?args)
101  (let (
102      ; Returns 2 values, the list of kind-keys & the list for property-keys.
103      ; The actual parameter list order is preserved.
104      ; Macro expansion is performed.
105      [split-cnd-args (lambda (args)
106        (let loop ([args args] [klst '()] [plst '()])
107          (if (null? args)
108            (values (reverse klst) (reverse plst))
109            ; Note the macroexpansion; to support condition naming.
110            (let ([form (macroexpand (car args))])
111              (cond
112                [(symbol? form)
113                  (loop (cdr args)
114                    (cons form klst) (cons '() plst))]
115                [(pair? form)
116                  (loop (cdr args)
117                    (cons (car form) klst) (cons (cdr form) plst))]
118                [else
119                  (syntax-error 'build-composite-condition-API
120                    "invalid condition form" form)]))) ) )])
121    ; Make composite condition api, when composite
122    (if (null? ?args)
123      ; then not composite
124      (syntax-error 'build-composite-condition-API
125        "missing conditions to compose")
126      ; else make composite api
127      (let ([args (cons ?form ?args)])
128        (receive [kndlst prplst] (split-cnd-args args)
129          `(begin
130            (define (,(me$bld-cnd-ctor-name
131                      (apply conc (intersperse kndlst "-")))
132                     ,@(apply append prplst))
133              (make-composite-condition
134                ,@(let loop ([kndlst kndlst] [prplst prplst] [lst '()])
135                  (if (or (null? kndlst) (null? prplst))
136                    (reverse lst)
137                    (let ([kind-key (car kndlst)]
138                          [prop-args (car prplst)])
139                      (loop
140                        (cdr kndlst)
141                        (cdr prplst)
142                        (cons
143                          `(,(me$bld-cnd-ctor-name kind-key) ,@prop-args)
144                          lst)))))))
145            (me$bld-cnd-pred ,kndlst build-composite-condition-API))))) ) )
146
147;; Build a condition API specification.
148
149(define-macro (build-condition-naming-API ?form . ?args)
150  (let loop ([args (cons ?form ?args)] [lst '()])
151    (if (null? args)
152      `(begin ,@(reverse lst))
153      (let ([form (car args)])
154        (loop
155          (cdr args)
156          (cons
157            (cond
158              [(symbol? form)
159                `(define-macro (,(me$bld-cnd-naming form)) ',form)]
160              [(pair? form)
161                `(define-macro (,(me$bld-cnd-naming (car form))) ',form)]
162              [else
163                (syntax-error 'build-condition-naming-API
164                  "invalid condition form" form)])
165            lst)))) ) )
Note: See TracBrowser for help on using the repository browser.