summaryrefslogtreecommitdiffstats
path: root/share/txr/stdlib/match.tl
blob: 423cbc9c7a39267e98d21ba1c6094b39e925762e (plain)
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
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
;; Copyright 2021
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice, this
;;    list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;;    this list of conditions and the following disclaimer in the documentation
;;    and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(defstruct match-vars ()
  vars
  var-exprs

  (:method assignments (me)
    (mapcar (ret ^(set ,@1 ,@2)) me.vars me.var-exprs)))

(defstruct match-guard (match-vars)
  guard-expr)

(defstruct compiled-match (match-vars)
  pattern
  obj-var
  guard-chain
  test-expr

  (:method get-temps (me)
    (mappend .vars me.guard-chain))

  (:method get-vars (me)
    (append me.(get-temps) me.vars))

  (:method wrap-guards (me exp)
    (let ((rev-guard-chain (reverse me.guard-chain))
          (out exp))
      (each ((g rev-guard-chain))
        (set out ^(when ,g.guard-expr
                    (progn
                      ,*g.(assignments)
                      ,out))))
      out)))

(defvar *match-form*)

(defun compile-struct-match (struct-pat obj-var)
  (let* ((required-type (cadr struct-pat))
         (slot-pairs (plist-to-alist (cddr struct-pat)))
         (required-slots [mapcar car slot-pairs])
         (slot-gensyms [mapcar gensym required-slots])
         (slot-patterns [mapcar cdr slot-pairs])
         (slot-matches [mapcar compile-match slot-patterns slot-gensyms])
         (slot-val-exprs [mapcar (ret ^(slot ,obj-var ',@1))
                                 required-slots])
         (guard (new match-guard
                     vars slot-gensyms
                     var-exprs slot-val-exprs
                     guard-expr  ^(subtypep (typeof ,obj-var)
                                            ',required-type))))
    (new compiled-match
         pattern struct-pat
         obj-var obj-var
         guard-chain (cons guard (mappend .guard-chain slot-matches))
         test-expr ^(and ,*(mapcar .test-expr slot-matches))
         vars [mappend .vars slot-matches]
         var-exprs [mappend .var-exprs slot-matches])))

(defun compile-var-match (sym obj-var)
  (or (null sym) (bindable sym)
      (compile-error *match-form* "~s is not a symbol" sym))
  (new compiled-match
       pattern sym
       obj-var obj-var
       test-expr t
       vars (if sym (list sym))
       var-exprs (if sym (list obj-var))))

(defun compile-vec-match (vec-pat obj-var)
  (let* ((elem-gensyms (mapcar (op gensym `elem-@1-`) (range* 0 (len vec-pat))))
         (elem-matches (list-vec [mapcar compile-match vec-pat elem-gensyms]))
         (guard (new match-guard
                     vars elem-gensyms
                     var-exprs (mapcar (ret ^[,obj-var ,@1])
                                        (range* 0 (len vec-pat)))
                     guard-expr ^(and (vectorp ,obj-var)
                                      (eql (len ,obj-var) ,(len vec-pat))))))
    (new compiled-match
         pattern vec-pat
         obj-var obj-var
         guard-chain (cons guard (mappend .guard-chain elem-matches))
         test-expr ^(and ,*(mapcar .test-expr elem-matches))
         vars (mappend .vars elem-matches)
         var-exprs (mappend .var-exprs elem-matches))))

(defun compile-atom-match (atom obj-var)
  (typecase atom
    (vec (compile-vec-match atom obj-var))
    (t (new compiled-match
            pattern atom
            obj-var obj-var
            test-expr ^(equal ,obj-var ',atom)))))

(defun compile-op-match (op-expr obj-var)
  (let ((var-match (compile-var-match nil obj-var)))
    (set var-match.test-expr ^[,op-expr ,obj-var])
    var-match))

(defun compile-predicate-match (pred-expr obj-var)
  (tree-bind (fun : sym) pred-expr
    (or (null sym) (bindable sym)
        (compile-error *match-form* "~s is not a symbol" sym))
    (let ((var-match (compile-var-match sym obj-var)))
      (set var-match.test-expr ^(,fun ,obj-var))
      var-match)))

(defun compile-cons-structure (cons-pat obj-var)
  (tree-bind (car . cdr) cons-pat
    (let* ((car-gensym (gensym))
           (cdr-gensym (gensym))
           (car-match (compile-match car car-gensym))
           (cdr-match (if (consp cdr)
                        (caseq (car cdr)
                          ((sys:expr sys:var) (compile-match cdr cdr-gensym))
                          (t (compile-cons-structure cdr cdr-gensym)))
                        (compile-atom-match cdr cdr-gensym)))
           (guard (new match-guard
                       vars ^(,car-gensym ,cdr-gensym)
                       var-exprs ^((car ,obj-var) (cdr ,obj-var))
                       guard-expr ^(consp ,obj-var))))
      (new compiled-match
           pattern cons-pat
           obj-var obj-var
           guard-chain (cons guard (append car-match.guard-chain
                                           cdr-match.guard-chain))
           test-expr ^(and ,car-match.test-expr ,cdr-match.test-expr)
           vars (append car-match.vars cdr-match.vars)
           var-exprs (append car-match.var-exprs cdr-match.var-exprs)))))

(defun compile-require-match (exp obj-var)
  (tree-bind (op match condition) exp
    (let ((match (compile-match match obj-var)))
      (set match.test-expr ^(and ,condition ,match.test-expr))
      match)))

(defun compile-let-match (exp obj-var)
  (tree-bind (op sym match) exp
    (or (null sym) (bindable sym)
        (compile-error *match-form* "~s is not a symbol" sym))
    (let ((match (compile-match match obj-var)))
      (push sym match.vars)
      (push obj-var match.var-exprs)
      match)))

(defun compile-loop-match (exp obj-var)
  (tree-bind (op match) exp
    (let* ((list-test (if (eq op 'usr:all*) 'consp 'listp))
           (some-p (eq op 'some))
           (item-var (gensym "item-"))
           (cm (compile-match match item-var))
           (loop-success-p-var (gensym "loop-success-p-"))
           (loop-continue-p-var (gensym "loop-terminate-p"))
           (matched-p-var (gensym "matched-p-"))
           (iter-var (gensym "iter-"))
           (collect-vars [mapcar gensym cm.vars])
           (loop ^(for ((,iter-var ,obj-var)
                        (,loop-continue-p-var t))
                       ((and ,loop-continue-p-var ,iter-var)
                        ,(if some-p
                           ^(not ,loop-continue-p-var)
                           loop-continue-p-var))
                       ((set ,iter-var (cdr ,iter-var)))
                    (let ((,cm.obj-var (car ,iter-var))
                          ,matched-p-var
                          ,*(if some-p cm.(get-temps) cm.(get-vars)))
                      ,cm.(wrap-guards
                            ^(progn ,*cm.(assignments)
                               (if ,cm.test-expr
                                 (progn
                                   (set ,matched-p-var t)
                                   ,*(unless some-p
                                       (mapcar (ret ^(push ,@1 ,@2))
                                               cm.vars
                                               collect-vars))))))
                      (,(if some-p 'when 'unless) ,matched-p-var
                        (set ,loop-continue-p-var nil)))))
           (guard (new match-guard
                       vars (cons loop-success-p-var (unless some-p
                                                       collect-vars))
                       var-exprs (list loop)
                       guard-expr ^(,list-test ,obj-var))))
      (new compiled-match
           pattern exp
           obj-var obj-var
           guard-chain (list guard)
           test-expr loop-success-p-var
           vars cm.vars
           var-exprs (unless some-p
                       (mapcar (ret ^(nreverse ,@1)) collect-vars))))))

(defun compile-parallel-match (par-pat obj-var)
  (tree-bind (op . pats) par-pat
    (flet ((submatch-fun (pm)
             ^(let ,pm.(get-temps)
                ,pm.(wrap-guards
                      ^(progn ,*pm.(assignments)
                         (if ,pm.test-expr t))))))
      (let* ((par-matches (mapcar (op compile-match @1 obj-var) pats))
             (guard (new match-guard
                         guard-expr ^(,op ,*[mapcar submatch-fun par-matches]))))
        (new compiled-match
             pattern par-pat
             obj-var obj-var
             guard-chain (list guard)
             test-expr t
             vars (uniq (mappend .vars par-matches)))))))

(defun compile-match (pat : (obj-var (gensym)))
  (cond
    ((consp pat)
       (caseq (car pat)
         (sys:expr
           (let ((exp (cadr pat)))
             (if (consp exp)
               (caseq (car exp)
                 (struct (compile-struct-match exp obj-var))
                 (require (compile-require-match exp obj-var))
                 (let (compile-let-match exp obj-var))
                 (all (compile-loop-match exp obj-var))
                 (usr:all* (compile-loop-match exp obj-var))
                 (some (compile-loop-match exp obj-var))
                 (or (compile-parallel-match exp obj-var))
                 (and (compile-parallel-match exp obj-var))
                 (op (compile-op-match exp obj-var))
                 (t (compile-predicate-match exp obj-var)))
               (compile-error *match-form*
                              "unrecognized pattern syntax ~s" pat))))
         (sys:var (compile-var-match (cadr pat) obj-var))
         (t (compile-cons-structure pat obj-var))))
    (t (compile-atom-match pat obj-var))))

(defmacro when-match (:form *match-form* pat obj . body)
  (let ((cm (compile-match pat)))
    ^(let ((,cm.obj-var ,obj)
           ,*cm.(get-vars))
       ,cm.(wrap-guards
             ^(progn ,*cm.(assignments)
                (if ,cm.test-expr ,*body))))))