/
match.ss
197 lines (179 loc) · 7.88 KB
/
match.ss
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
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
;; (documentation (name match))
;; <pre>Pattern Matching Syntactic Extensions for Scheme
;;
;; All bugs or questions concerning this software should be directed to
;; Bruce Hauman <bhauman@cs.wcu.edu>. The latest version of this software
;; can be obtained from http://sol.cs.wcu.edu/~bhauman/scheme/pattern.php.
;;
;; Special thanks go out to:
;; Robert Bruce Findler for support and bug detection.
;; Doug Orleans for pointing out that pairs should be reused while
;; matching lists.
;;
;;
;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
;; which in turn was adapted from code written by Bruce F. Duba, 1991.
;;
;; This software is in the public domain. Feel free to copy,
;; distribute, and modify this software as desired. No warranties
;; nor guarantees of any kind apply. Please return any improvements
;; or bug fixes to bhauman@cs.wcu.edu so that they may be included
;; in future releases.
;;
;; This macro package extends Scheme with several new expression forms.
;; Following is a brief summary of the new forms. See the associated
;; LaTeX documentation for a full description of their functionality.
;;
;;
;; match expressions:
;;
;; exp ::= ...
;; | (match exp clause ...)
;; | (match-lambda clause ...)
;; | (match-lambda* clause ...)
;; | (match-let ((pat exp) ...) body ...)
;; | (match-let var ((pat exp) ...) body ...)
;; | (match-let* ((pat exp) ...) body ...)
;; | (match-letrec ((pat exp) ...) body ...)
;; | (match-define pat exp)
;;
;; clause ::= (pat body) | (pat (=> identifier) exp)
;;
;; patterns: matches:
;;
;; pat ::=
;; identifier this binds an identifier if it
;; doesn't conflict with
;; ..k, var, $, =, and,
;; or, not, ?, set!, or get!
;; | _ anything
;; | () the empty list
;; | #t #t
;; | #f #f
;; | string a string
;; | number a number
;; | character a character
;; | 'sexp an s-expression
;; | 'symbol a symbol (special case of s-expr)
;; | (lvp_1 ... lvp_n) list of n elements
;; | (pat ... pat_n . pat_{n+1}) list of n or more
;; | #(lvp_1 ... lvp_n) vector of n elements
;; | #&pat box
;; | ($ struct-name pat_1 ... pat_n) a structure
;; | (= field pat) a field of a structure (field is
;; an accessor)
;; Actually field can be any function
;; which can be
;; applied to the data being matched.
;; Ex: (match 5 ((= add1 b) b)) => 6
;;
;; | (and pat_1 ... pat_n) if all of pat_1 thru pat_n match
;; | (or pat_1 ... pat_n) if any of pat_1 thru pat_n match
;; | (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match
;; | (? predicate pat_1 ... pat_n) if predicate true and all of
;; pat_1 thru pat_n match
;; | (set! identifier) anything, and binds setter
;; | (get! identifier) anything, and binds getter
;; | `qp a quasi-pattern
;;
;; lvp ::= pat ooo greedily matches n or more of pat,
;; each element must match pat
;; | pat matches pat
;;
;; ooo ::= ... zero or more
;; | ___ zero or more
;; | ..k k or more
;; | __k k or more
;;
;; quasi-patterns: matches:
;;
;; qp ::= () the empty list
;; | #t #t
;; | #f #f
;; | string a string
;; | number a number
;; | character a character
;; | identifier a symbol
;; | (qp_1 ... qp_n) list of n elements
;; | (qp_1 ... qp_n . qp_{n+1}) list of n or more
;; | (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each element
;; of remainder must match qp_n+1
;; | #(qp_1 ... qp_n) vector of n elements
;; | #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each element
;; of remainder must match qp_n+1
;; | #&qp box
;; | ,pat a pattern
;; | ,@(lvp . . . lvp-n)
;; | ,@(pat . . . pat_n . pat_{n+1})
;; | ,@`qp qp must evaluate to a list as
;; so that this rule resembles the
;; above two rules
;;
;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
;; and, or, not, set!, get!, list-no-order, hash-table, ..., ___)
;; cannot be used as pattern variables.</pre>
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module match mzscheme
(provide
match
match-lambda
match-lambda*
match-let
match-let*
match-letrec
match-define
match-equality-test
exn:misc:match?
exn:misc:match-value
define-match-expander)
(require-for-syntax "private/convert-pat.ss"
"private/match-helper.ss")
(require-for-template mzscheme (prefix plt: "private/match-internal-func.ss"))
(require (prefix plt: "private/match-internal-func.ss")
"private/match-expander.ss"
"private/match-helper.ss"
"private/match-error.ss")
(define-syntax (match-lambda stx)
(syntax-case stx ()
[(k clause ...)
(with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
#'(plt:match-lambda new-clauses ...))]))
(define-syntax (match-lambda* stx)
(syntax-case stx ()
[(k clause ...)
(with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
#'(plt:match-lambda* new-clauses ...))]))
(define-syntax (match-let stx)
(syntax-case stx ()
[(k name (clauses ...) body ...)
(identifier? (syntax name))
(with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
#'(plt:match-let name (new-clauses ...) body ...))]
[(k (clauses ...) body ...)
(with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
#'(plt:match-let (new-clauses ...) body ...))]))
(define-syntax (match-let* stx)
(syntax-case stx ()
[(k (clauses ...) body ...)
(with-syntax
([(new-clauses ...) (handle-clauses #'(clauses ...))])
#'(plt:match-let* (new-clauses ...) body ...))]))
(define-syntax (match stx)
(syntax-case stx ()
[(_ exp clause ...)
(with-syntax
([(new-clauses ...) (handle-clauses #'(clause ...))])
#'(plt:match exp new-clauses ...))]))
(define-syntax (match-letrec stx)
(syntax-case stx ()
[(k (clauses ...) body ...)
(with-syntax
([(new-clauses ...) (handle-clauses #'(clauses ...))])
#'(plt:match-letrec (new-clauses ...) body ...))]))
(define-syntax (match-define stx)
(syntax-case stx ()
[(k pat exp)
(with-syntax ([new-pat (convert-pat #'pat)])
#'(plt:match-define new-pat exp))]))
)