source: project/release/3/matcher/matcher.scm

Last change on this file was 2536, checked in by felix winkelmann, 14 years ago

added loopy-loop, scgi fix by pbusser

File size: 7.1 KB
Line 
1;;;; Match extension to SRFI-57
2;;; Taken from AvT's original srfi-57 reference implementation.
3;;; Revised for portable syntax-case and final srfi-57 by Dale Jordan.
4
5
6
7(module matcher (match match-lambda match-let match-let*)
8
9 (import registry)
10 (import portability)
11
12 (define-syntax match
13   (lambda (stx)
14     (syntax-case stx (_ => quote cons vector list list* and or = ? quasiquote unquote)
15       ((match exp . rest)
16        (not (identifier? #'exp))
17        #'(let ((var exp))
18            (match var . rest)))
19       ((match var)
20        #'(error "No match for" var))
21       ((match var (pattern (=> fail) . body) . rest)
22        #'(let ((fail (lambda () (match var . rest))))
23            (match var (pattern . body) . rest)))
24       ((match var (_ . body) . rest)
25        #'(begin . body))
26       ((match var ((quote x) . body) . rest)
27        #'(if (equal? (quote x) var)
28              (begin . body)
29              (match var . rest)))
30       ((match var ((quasiquote ()) . body) . rest)
31        #'(if (null? var)
32              (begin . body)
33              (match var . rest)))
34       ((match var ((quasiquote #(pat ...)) . body) . rest)
35        #'(if (vector? var)
36              (match (vector->list var)
37                         ((list (quasiquote pat) ...) . body) . rest)
38              (match var . rest)))
39       ((match var ((quasiquote (unquote pat)) . body) . rest)
40        #'(match var
41                     (pat . body)
42                     (_     (match var . rest))))
43       ((match var ((quasiquote (pat . pats)) . body) . rest)
44        #'(let ((fail (lambda () (match var . rest))))
45            (if (pair? var)
46                (match (car var)
47                  ((quasiquote pat)
48                   (match (cdr var)
49                     ((quasiquote pats) . body)
50                     (_                 (fail))))
51                  (_                (fail)))
52                (fail))))
53       ((match var ((quasiquote pat) . body) . rest)
54        #'(match var
55                     ((quote pat) . body)
56                     (_           (match var . rest))))
57       ((match var ((cons pat1 pat2) . body) . rest)
58        #'(let ((fail (lambda () (match var . rest))))
59            (if (pair? var)
60                (match (car var)
61                  (pat1 (match (cdr var)
62                          (pat2 . body)
63                          (_    (fail))))
64                  (_    (fail)))
65                (fail))))
66       ((match var ((vector pat ...) . body) . rest)
67        #'(if (vector? var)
68              (match (vector->list var)
69                ((list pat ...) . body) . rest)
70              (match var . rest)))
71       ((match var ((list) . body) . rest)
72        #'(if (null? var)
73              (begin . body)
74              (match var . rest)))
75       ((match var ((list pat . pats) . body) . rest)
76        #'(let ((fail (lambda () (match var . rest))))
77            (if (pair? var)
78                (match (car var)
79                  (pat (match (cdr var)
80                         ((list . pats) . body)
81                         (_             (fail))))
82                  (_    (fail)))
83                (fail))))
84       ((match var ((list* pat) . body) . rest)
85        #'(match var
86            (pat . body)
87            (_ (match var . rest))))
88       ((match var ((list* pat . pats) . body) . rest)
89        #'(let ((fail (lambda () (match var . rest))))
90            (if (pair? var)
91                (match (car var)
92                  (pat (match (cdr var)
93                         ((list* . pats) . body)
94                         (_             (fail))))
95                  (_    (fail)))
96                (fail))))
97       ((match var ((and) . body) . rest)
98        #'(begin . body))
99       ((match var ((and pat . pats) . body) . rest)
100        #'(let ((fail (lambda () (match var . rest))))
101            (match var
102                       (pat
103                        (match var
104                                   ((and . pats) . body)
105                                   (_            (fail))))
106                       (_   (fail)))))
107       ((match var ((or) . body) . rest)
108        #'(match var . rest))
109       ((match var ((or pat . pats) . body) . rest)
110        #'(match var
111                     (pat . body)
112                     (_
113                      (match var
114                                 ((or . pats) . body)
115                                 (_ (match var . rest))))))
116       ((match var ((= f pat) . body) . rest)
117        #'(match (f var)
118            (pat . body)
119            (_   (match var . rest))))
120       ((match var ((? pred? pat ...) . body) . rest)
121        #'(let ((fail (lambda () (match var . rest))))
122            (if (pred? var)
123                (match var
124                           ((and pat ...) . body)
125                           (_             (fail)))
126                (fail))))
127       ((match var ((name binding ...) . body) . rest)
128        (lookup-entry #'name) ; require name is defined record type or scheme
129        (with-syntax
130            (((binding ...)            ; normalized binding list
131              (let ((binds (syntax->list #'(binding ...))))
132                (if (null? binds)      ; expand to all field labels
133                    (map (lambda (bind) (list bind bind))
134                         (lookup-labels #'name))
135                    (map (lambda (bind)
136                           (if (identifier? bind)
137                               (list bind bind) ; l => (l l)
138                               (syntax->list bind))) ; (l var)
139                         binds)))))
140             (with-syntax
141                 ((predicate (lookup-predicate #'name))
142                  ((getter ...)
143                   (map (lambda (bind) (lookup-getter #'name (car bind)))
144                        (syntax->list #'(binding ...))))
145                  ((lvar ...)
146                   (map cadr (syntax->list #'(binding ...)))))
147               #'(if (predicate var)
148                     (let ((lvar (getter var)) ...) . body)
149                     (match var . rest)))))
150       ((match var (x . body) . rest)
151        (identifier? #'x)
152        #'(let ((x var)) . body))
153       ((match var (x . body) . rest)
154        (not (pair? (syntax-object->datum #'x)))
155        #'(if (eqv? x var)
156              (begin . body)
157              (match var . rest)))
158       ((match var (pat . body) . rest)
159        (##syncase#syntax-error #'pat "No match for ")))))
160
161 (define-syntax match-lambda
162   (syntax-rules ()
163     ((match-lambda (pat . body) ...)
164      (lambda (x) (match x (pat . body) ...)))))
165
166 (define-syntax match-let
167   (lambda (stx)
168     (syntax-case stx ()
169       ((match-let ((pat exp) ...) . body)
170        (with-syntax
171            (((temp ...) (generate-temporaries #'(pat ...))))
172          #'(let ((temp exp) ...)
173              (match-let "I" ((pat temp) ...) . body))))
174       ((match-let "I" () . body)
175        #'(begin . body))
176       ((match-let "I" ((pat var) . bindings) . body)
177        #'(match var
178            (pat (match-let "I" bindings . body))
179            (_ (error "match-let -- no match for pattern: " pat)))))))
180
181 (define-syntax match-let*
182   (syntax-rules ()
183     ((match-let* () . body)
184      (begin . body))
185     ((match-let* (binding . bindings) . body)
186      (match-let (binding)
187                 (match-let* bindings . body)))))
188
189 ) ;; matcher
Note: See TracBrowser for help on using the repository browser.