1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
;;;; Matcher based on match combinators, CPH/GJS style.
;;; Idea is in Hewitt's PhD thesis (1969).
(declare (usual-integrations))
;;; There are match procedures that can be applied to data items. A
;;; match procedure either accepts or rejects the data it is applied
;;; to. Match procedures can be combined to apply to compound data
;;; items.
;;; A match procedure takes a list containing a data item, a
;;; dictionary, and a success continuation. The dictionary
;;; accumulates the assignments of match variables to values found in
;;; the data. The success continuation takes two arguments: the new
;;; dictionary, and the number of items absorbed from the list by the
;;; match. If a match procedure fails it returns #f.
;;; Primitive match procedures:
(define (match:eqv pattern-constant)
(define (eqv-match data dictionary succeed)
(and (pair? data)
(eqv? (car data) pattern-constant)
(succeed dictionary 1)))
eqv-match)
(define (match:element variable)
(define (element-match data dictionary succeed)
(and (pair? data)
(let ((vcell (match:lookup variable dictionary)))
(if vcell
(and (equal? (match:value vcell) (car data))
(succeed dictionary 1))
(succeed (match:bind variable (car data) dictionary)
1)))))
element-match)
;;; Support for the dictionary.
(define (match:bind variable data-object dictionary)
(cons (list variable data-object) dictionary))
(define (match:lookup variable dictionary)
(assq variable dictionary))
(define (match:value vcell)
(cadr vcell))
(define (match:segment variable)
(define (segment-match data dictionary succeed)
(and (list? data)
(let ((vcell (match:lookup variable dictionary)))
(if vcell
(let lp ((data data)
(pattern (match:value vcell))
(n 0))
(cond ((pair? pattern)
(if (and (pair? data)
(equal? (car data) (car pattern)))
(lp (cdr data) (cdr pattern) (+ n 1))
#f))
((not (null? pattern)) #f)
(else (succeed dictionary n))))
(let ((n (length data)))
(let lp ((i 0))
(if (<= i n)
(or (succeed (match:bind variable
(list-head data i)
dictionary)
i)
(lp (+ i 1)))
#f)))))))
segment-match)
(define (match:list . match-combinators)
(define (list-match data dictionary succeed)
(and (pair? data)
(let lp ((data (car data))
(matchers match-combinators)
(dictionary dictionary))
(cond ((pair? matchers)
((car matchers) data dictionary
(lambda (new-dictionary n)
(if (> n (length data))
(error "Matcher ate too much." n))
(lp (list-tail data n)
(cdr matchers)
new-dictionary))))
((pair? data) #f)
((null? data)
(succeed dictionary 1))
(else #f)))))
list-match)
;;; Syntax of matching is determined here.
(define (match:element? pattern)
(and (pair? pattern)
(eq? (car pattern) '?)))
(define (match:segment? pattern)
(and (pair? pattern)
(eq? (car pattern) '??)))
(define (match:variable-name pattern)
(cadr pattern))
(define (match:list? pattern)
(and (list? pattern)
(not (memq (car pattern) '(? ??)))))
(define match:->combinators
(make-generic-operator 1 match:eqv))
(defhandler match:->combinators
(lambda (pattern) (match:element (match:variable-name pattern)))
match:element?)
(defhandler match:->combinators
(lambda (pattern) (match:segment (match:variable-name pattern)))
match:segment?)
(defhandler match:->combinators
(lambda (pattern)
(apply match:list (map match:->combinators pattern)))
match:list?)
(define (matcher pattern)
(let ((match-combinator (match:->combinators pattern)))
(lambda (datum)
(match-combinator
(list datum)
'()
(lambda (dictionary number-of-items-eaten)
(and (= number-of-items-eaten 1)
dictionary))))))
#|
((match:->combinators '(a ((? b) 2 3) 1 c))
'((a (1 2 3) 1 c))
'()
(lambda (x y) `(succeed ,x ,y)))
;Value: (succeed ((b 1)) 1)
((match:->combinators '(a ((? b) 2 3) (? b) c))
'((a (1 2 3) 2 c))
'()
(lambda (x y) `(succeed ,x ,y)))
;Value: #f
((match:->combinators '(a ((? b) 2 3) (? b) c))
'((a (1 2 3) 1 c))
'()
(lambda (x y) `(succeed ,x ,y)))
;Value: (succeed ((b 1)) 1)
((match:->combinators '(a (?? x) (?? y) (?? x) c))
'((a b b b b b b c))
'()
(lambda (x y)
(pp `(succeed ,x ,y))
#f))
(succeed ((y (b b b b b b)) (x ())) 1)
(succeed ((y (b b b b)) (x (b))) 1)
(succeed ((y (b b)) (x (b b))) 1)
(succeed ((y ()) (x (b b b))) 1)
;Value: #f
((matcher '(a ((? b) 2 3) (? b) c))
'(a (1 2 3) 1 c))
;Value: ((b 1))
|#
|
