source: project/matchable/matchable.scm @ 5888

Last change on this file since 5888 was 5888, checked in by Alex Shinn, 12 years ago

Fixing quasiquote patterns.

File size: 23.5 KB
Line 
1;;;; matchable.scm -- portable hygienic pattern matcher
2;;
3;; This code is written by Alex Shinn and placed in the
4;; Public Domain.  All warranties are disclaimed.
5
6;; Written in fully portable SYNTAX-RULES, with a few non-portable
7;; bits at the end of the file conditioned out with COND-EXPAND.
8
9;; This is a simple generative pattern matcher - each pattern is
10;; expanded into the required tests, calling a failure continuation if
11;; the tests pass.  This makes the logic easy to follow and extend,
12;; but produces sub-optimal code in cases where you have many similar
13;; clauses due to repeating the same tests.  Nonetheless a smart
14;; compiler should be able to remove the redundant tests.  For
15;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
16;; hit.
17
18;; 2007/09/04 - fixing quasiquote patterns
19;; 2007/07/21 - allowing ellipse patterns in non-final list positions
20;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
21;;              (thanks to Taylor Campbell)
22;; 2007/04/08 - clean up, commenting
23;; 2006/12/24 - bugfixes
24;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
25
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28;; This is always passed a message, yet won't match the message, and
29;; thus always results in a compile-time error.
30
31(define-syntax match-syntax-error
32  (syntax-rules ()
33    ((_)
34     (match-syntax-error "invalid match-syntax-error usage"))))
35
36;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37
38;; The basic interface.  MATCH just performs some basic syntax
39;; validation, binds the match expression to a temporary variable, and
40;; passes it on to MATCH-NEXT.
41
42(define-syntax match
43  (syntax-rules ()
44    ((match)
45     (match-syntax-error "missing match expression"))
46    ((match atom)
47     (match-syntax-error "missing match clause"))
48    ((match (app ...) (pat . body) ...)
49     (let ((v (app ...)))
50       (match-next v (app ...) (set! (app ...)) (pat . body) ...)))
51    ((match #(vec ...) (pat . body) ...)
52     (let ((v #(vec ...)))
53       (match-next v v (set! v) (pat . body) ...)))
54    ((match atom (pat . body) ...)
55     (match-next atom atom (set! atom) (pat . body) ...))
56    ))
57
58;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
59;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
60;; clauses.
61
62(define-syntax match-next
63  (syntax-rules (=>)
64    ;; no more clauses, the match failed
65    ((match-next v g s)
66     (error 'match "no matching pattern"))
67    ;; named failure continuation
68    ((match-next v g s (pat (=> failure) . body) . rest)
69     (let ((failure (lambda () (match-next v g s . rest))))
70       ;; match-one analyzes the pattern for us
71       (match-one v pat g s (match-drop-ids (begin . body)) (failure) ())))
72    ;; anonymous failure continuation, give it a dummy name
73    ((match-next v g s (pat . body) . rest)
74     (match-next v g s (pat (=> failure) . body) . rest))))
75
76;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
77;; MATCH-TWO.
78
79(define-syntax match-one
80  (syntax-rules ()
81    ;; If it's a list of two values, check to see if the second one is
82    ;; an ellipse and handle accordingly, otherwise go to MATCH-TWO.
83    ((match-one v (p q . r) g s sk fk i)
84     (match-check-ellipse
85      q
86      (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())
87      (match-two v (p q . r) g s sk fk i)))
88    ;; Otherwise, go directly to MATCH-TWO.
89    ((match-one . x)
90     (match-two . x))))
91
92;; This is the guts of the pattern matcher.  We are passed a lot of
93;; information in the form:
94;;
95;;   (match-two var pattern getter setter success-k fail-k (ids ...))
96;;
97;; where VAR is the symbol name of the current variable we are
98;; matching, PATTERN is the current pattern, getter and setter are the
99;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
100;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
101;; continuation (which is just a thunk call and is thus safe to expand
102;; multiple times) and IDS are the list of identifiers bound in the
103;; pattern so far.
104
105(define-syntax match-two
106  (syntax-rules (_ ___ quote quasiquote ? $ = and or not set! get!)
107    ((match-two v () g s (sk ...) fk i)
108     (if (null? v) (sk ... i) fk))
109    ((match-two v (quote p) g s (sk ...) fk i)
110     (if (equal? v 'p) (sk ... i) fk))
111    ((match-two v (quasiquote p) g s sk fk i)
112     (match-quasiquote v p g s sk fk i))
113    ((match-two v (and) g s (sk ...) fk i) (sk ... i))
114    ((match-two v (and p q ...) g s sk fk i)
115     (match-one v p g s (match-one v (and q ...) g s sk fk) fk i))
116    ((match-two v (or) g s sk fk i) fk)
117    ((match-two v (or p) g s sk fk i)
118     (match-one v p g s sk fk i))
119    ((match-two v (or p ...) g s sk fk i)
120     (match-extract-vars (or p ...)
121                         (match-gen-or v (p ...) g s sk fk i)
122                         i
123                         ()))
124    ((match-two v (not p) g s (sk ...) fk i)
125     (match-one v p g s (match-drop-ids fk) (sk ... i) i))
126    ((match-two v (get! getter) g s (sk ...) fk i)
127     (let ((getter (lambda () g))) (sk ... i)))
128    ((match-two v (set! setter) g (s ...) (sk ...) fk i)
129     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
130    ((match-two v (? pred p ...) g s sk fk i)
131     (if (pred v) (match-one v (and p ...) g s sk fk i) fk))
132    ;; Record matching - comment this out if you don't support
133    ;; records.
134    ((match-two v ($ rec p ...) g s sk fk i)
135     (if ((syntax-symbol-append-? rec) v)
136       (match-record-refs v 1 (p ...) g s sk fk i)
137       fk))
138    ((match-two v (= proc p) g s sk fk i)
139     (let ((w (proc v)))
140       (match-one w p g s sk fk i)))
141    ((match-two v (p ___ . r) g s sk fk i)
142     (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ()))
143    ((match-two v (p) g s sk fk i)
144     (if (and (pair? v) (null? (cdr v)))
145       (let ((w (car v)))
146         (match-one w p (car v) (set-car! v) sk fk i))
147       fk))
148    ((match-two v (p . q) g s sk fk i)
149     (if (pair? v)
150       (let ((w (car v)) (x (cdr v)))
151         (match-one w p (car v) (set-car! v)
152                    (match-one x q (cdr v) (set-cdr! v) sk fk)
153                    fk
154                    i))
155       fk))
156    ((match-two v #(p ...) g s sk fk i)
157     (if (vector? v)
158       (match-vector v 0 () (p ...) sk fk i)
159       fk))
160    ((match-two v _ g s (sk ...) fk i) (sk ... i))
161    ;; Not a pair or vector or special literal, test to see if it's a
162    ;; new symbol, in which case we just bind it, or if it's an
163    ;; already bound symbol or some other literal, in which case we
164    ;; compare it with EQUAL?.
165    ((match-two v x g s (sk ...) fk (id ...))
166     (let-syntax
167         ((new-sym?
168           (syntax-rules (id ...)
169             ((new-sym? x sk2 fk2) sk2)
170             ((new-sym? y sk2 fk2) fk2))))
171       (new-sym? abracadabra  ; thanks Oleg
172             (let ((x v)) (sk ... (id ... x)))
173             (if (equal? v x) (sk ... (id ...)) fk))))
174    ))
175
176;; QUASIQUOTE patterns
177
178(define-syntax match-quasiquote
179  (syntax-rules (unquote unquote-splicing quasiquote)
180    ((_ v (unquote p) g s sk fk i)
181     (match-one v p g s sk fk i))
182    ((_ v ((unquote-splicing p) . rest) g s sk fk i)
183     (if (pair? v)
184       (match-one v
185                  (p . tmp)
186                  (match-quasiquote tmp rest g s sk fk)
187                  fk
188                  i)
189       fk))
190    ((_ v (quasiquote p) g s sk fk i . depth)
191     (match-quasiquote v p g s sk fk i #f . depth))
192    ((_ v (unquote p) g s sk fk i x . depth)
193     (match-quasiquote v p g s sk fk i . depth))
194    ((_ v (unquote-splicing p) g s sk fk i x . depth)
195     (match-quasiquote v p g s sk fk i . depth))
196    ((_ v (p . q) g s sk fk i . depth)
197     (if (pair? v)
198       (let ((w (car v)) (x (cdr v)))
199         (match-quasiquote
200          w p g s
201          (match-quasiquote-step x q g s sk fk depth)
202          fk i . depth))
203       fk))
204    ((_ v #(elt ...) g s sk fk i . depth)
205     (if (vector? v)
206       (let ((ls (vector->list v)))
207         (match-quasiquote ls (elt ...) g s sk fk i . depth))
208       fk))
209    ((_ v x g s sk fk i . depth)
210     (match-one v 'x g s sk fk i))))
211
212(define-syntax match-quasiquote-step
213  (syntax-rules ()
214    ((match-quasiquote-step x q g s sk fk depth i)
215     (match-quasiquote x q g s sk fk i . depth))
216    ))
217
218;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
219;; Utilities
220
221;; A CPS utility that takes two values and just expands into the
222;; first.
223(define-syntax match-drop-ids
224  (syntax-rules ()
225    ((_ expr ids ...) expr)))
226
227;; Generating OR clauses just involves binding the success
228;; continuation into a thunk which takes the identifiers common to
229;; each OR clause, and trying each clause, calling the thunk as soon
230;; as we succeed.
231
232(define-syntax match-gen-or
233  (syntax-rules ()
234    ((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...))
235     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
236       (match-gen-or-step
237        v p g s (match-drop-ids (sk2 id ...)) fk (i ...))))))
238
239(define-syntax match-gen-or-step
240  (syntax-rules ()
241    ((_ v () g s sk fk i)
242     ;; no OR clauses, call the failure continuation
243     fk)
244    ((_ v (p) g s sk fk i)
245     ;; last (or only) OR clause, just expand normally
246     (match-one v p g s sk fk i))
247    ((_ v (p . q) g s sk fk i)
248     ;; match one and try the remaining on failure
249     (match-one v p g s sk (match-gen-or-step v q g s sk fk i) i))
250    ))
251
252;; We match a pattern (p ...) by matching the pattern p in a loop on
253;; each element of the variable, accumulating the bound ids into lists
254
255;; Look at the body - it's just a named let loop, matching each
256;; element in turn to the same pattern.  This illustrates the
257;; simplicity of this generative-style pattern matching.  It would be
258;; just as easy to implement a tree searching pattern.
259
260(define-syntax match-gen-ellipses
261  (syntax-rules ()
262    ((_ v p () g s (sk ...) fk i ((id id-ls) ...))
263     (match-check-identifier p
264       (let ((p v))
265         (sk ... i))
266       (let loop ((ls v) (id-ls '()) ...)
267         (cond
268           ((null? ls)
269            (let ((id (reverse id-ls)) ...) (sk ... i)))
270           ((pair? ls)
271            (let ((w (car ls)))
272              (match-one w p (car ls) (set-car! ls)
273                         (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
274                         fk i)))
275           (else
276            fk)))))
277    ((_ v p (r ...) g s (sk ...) fk i ((id id-ls) ...))
278     (match-verify-no-ellipses
279      (r ...)
280      (let* ((tail-len (length '(r ...)))
281             (ls v)
282             (len (length ls)))
283        (if (< len tail-len)
284            fk
285            (let loop ((ls ls) (n len) (id-ls '()) ...)
286              (cond
287                ((= n tail-len)
288                 (let ((id (reverse id-ls)) ...)
289                   (match-one ls (r ...) #f #f (sk ... i) fk i)))
290                ((pair? ls)
291                 (let ((w (car ls)))
292                   (match-one w p (car ls) (set-car! ls)
293                              (match-drop-ids
294                               (loop (cdr ls) (- n 1) (cons id id-ls) ...))
295                              fk
296                              i)))
297                (else
298                 fk)))))))
299    ))
300
301(define-syntax match-verify-no-ellipses
302  (syntax-rules ()
303    ((_ (x . y) sk)
304     (match-check-ellipse
305      x
306      (match-syntax-error
307       "multiple ellipse patterns not allowed at same level")
308      (match-verify-no-ellipses y sk)))
309    ((_ x sk) sk)
310    ))
311
312;; Vector patterns are just more of the same, with the slight
313;; exception that we pass around the current vector index being
314;; matched.
315
316(define-syntax match-vector
317  (syntax-rules (___)
318    ((_ v n pats (p q) sk fk i)
319     (match-check-ellipse q
320                          (match-vector-ellipses v n pats p sk fk i)
321                          (match-vector-two v n pats (p q) sk fk i)))
322    ((_ v n pats (p ___) sk fk i)
323     (match-vector-ellipses v n pats p sk fk i))
324    ((_ . x)
325     (match-vector-two . x))))
326
327;; Check the exact vector length, then check each element in turn.
328
329(define-syntax match-vector-two
330  (syntax-rules ()
331    ((_ v n ((pat index) ...) () sk fk i)
332     (if (vector? v)
333       (let ((len (vector-length v)))
334         (if (= len n)
335           (match-vector-step v ((pat index) ...) sk fk i)
336           fk))
337       fk))
338    ((_ v n (pats ...) (p . q) sk fk i)
339     (match-vector v (+ n 1) (pats ... (p n)) q sk fk i))
340    ))
341
342(define-syntax match-vector-step
343  (syntax-rules ()
344    ((_ v () (sk ...) fk i) (sk ... i))
345    ((_ v ((pat index) . rest) sk fk i)
346     (let ((w (vector-ref v index)))
347       (match-one w pat (vector-ref v index) (vector-set! v index)
348                  (match-vector-step v rest sk fk)
349                  fk i)))))
350
351;; With a vector ellipse pattern we first check to see if the vector
352;; length is at least the required length.
353
354(define-syntax match-vector-ellipses
355  (syntax-rules ()
356    ((_ v n ((pat index) ...) p sk fk i)
357     (if (vector? v)
358       (let ((len (vector-length v)))
359         (if (>= len n)
360           (match-vector-step v ((pat index) ...)
361                              (match-vector-tail v p n len sk fk)
362                              fk i)
363           fk))
364       fk))))
365
366(define-syntax match-vector-tail
367  (syntax-rules ()
368    ((_ v p n len sk fk i)
369     (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
370
371(define-syntax match-vector-tail-two
372  (syntax-rules ()
373    ((_ v p n len (sk ...) fk i ((id id-ls) ...))
374     (let loop ((j n) (id-ls '()) ...)
375       (if (>= j len)
376         (let ((id (reverse id-ls)) ...) (sk ... i))
377         (let ((w (vector-ref v j)))
378           (match-one w p (vector-ref v j) (vetor-set! v j)
379                      (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
380                      fk i)))))))
381
382;; Chicken-specific.
383
384(cond-expand
385 (chicken
386  (define-syntax match-record-refs
387    (syntax-rules ()
388      ((_ v n (p . q) g s sk fk i)
389       (let ((w (##sys#block-ref v n)))
390         (match-one w p (##sys#block-ref v n) (##sys#block-set! v n)
391                    (match-record-refs v (+ n 1) q g s sk fk)
392                    fk i)))
393      ((_ v n () g s (sk ...) fk i)
394       (sk ... i)))))
395 (else
396  ))
397
398;; Extract all identifiers in a pattern.  A little more complicated
399;; than just looking for symbols, we need to ignore special keywords
400;; and not pattern forms (such as the predicate expression in ?
401;; patterns).
402;;
403;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
404
405(define-syntax match-extract-vars
406  (syntax-rules (_ ___ ? $ = quote quasiquote and or not get! set!)
407    ((match-extract-vars (? pred . p) k i v)
408     (match-extract-vars p k i v))
409    ((match-extract-vars ($ rec . p) k i v)
410     (match-extract-vars p k i v))
411    ((match-extract-vars (= proc p) k i v)
412     (match-extract-vars p k i v))
413    ((match-extract-vars (quote x) (k ...) i v)
414     (k ... v))
415    ((match-extract-vars (quasiquote x) k i v)
416     (match-extract-quasiquote-vars x k i v (#t)))
417    ((match-extract-vars (and . p) k i v)
418     (match-extract-vars p k i v))
419    ((match-extract-vars (or . p) k i v)
420     (match-extract-vars p k i v))
421    ((match-extract-vars (not . p) k i v)
422     (match-extract-vars p k i v))
423    ;; A non-keyword pair, expand the CAR with a continuation to
424    ;; expand the CDR.
425    ((match-extract-vars (p q . r) k i v)
426     (match-check-ellipse
427      q
428      (match-extract-vars (p . r) k i v)
429      (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
430    ((match-extract-vars (p . q) k i v)
431     (match-extract-vars p (match-extract-vars-step q k i v) i ()))
432    ((match-extract-vars #(p ...) k i v)
433     (match-extract-vars (p ...) k i v))
434    ((match-extract-vars _ (k ...) i v)    (k ... v))
435    ((match-extract-vars ___ (k ...) i v)  (k ... v))
436    ;; This is the main part, the only place where we might add a new
437    ;; var if it's an unbound symbol.
438    ((match-extract-vars p (k ...) (i ...) v)
439     (let-syntax
440         ((new-sym?
441           (syntax-rules (i ...)
442             ((new-sym? p sk fk) sk)
443             ((new-sym? x sk fk) fk))))
444       (new-sym? random-sym-to-match
445                 (k ... ((p p-ls) . v))
446                 (k ... v))))
447    ))
448
449;; Stepper used in the above so it can expand the CAR and CDR
450;; separately.
451
452(define-syntax match-extract-vars-step
453  (syntax-rules ()
454    ((_ p k i v ((v2 v2-ls) ...))
455     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
456    ))
457
458(define-syntax match-extract-quasiquote-vars
459  (syntax-rules (quasiquote unquote unquote-splicing)
460    ((match-extract-quasiquote-vars (quasiquote x) k i v d)
461     (match-extract-quasiquote-vars x k i v (#t . d)))
462    ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
463     (match-extract-quasiquote-vars (unquote x) k i v d))
464    ((match-extract-quasiquote-vars (unquote x) k i v (#t))
465     (match-extract-vars x k i v))
466    ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
467     (match-extract-quasiquote-vars x k i v d))
468    ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
469     (match-extract-quasiquote-vars
470      x
471      (match-extract-quasiquote-vars-step y k i v d) i ()))
472    ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
473     (match-extract-quasiquote-vars (x ...) k i v d))
474    ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
475     (k ... v))
476    ))
477
478(define-syntax match-extract-quasiquote-vars-step
479  (syntax-rules ()
480    ((_ x k i v d ((v2 v2-ls) ...))
481     (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
482    ))
483
484
485;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
486;; Gimme some sugar baby.
487
488(define-syntax match-lambda
489  (syntax-rules ()
490    ((_ clause ...) (lambda (expr) (match expr clause ...)))))
491
492(define-syntax match-lambda*
493  (syntax-rules ()
494    ((_ clause ...) (lambda expr (match expr clause ...)))))
495
496(define-syntax match-let
497  (syntax-rules ()
498    ((_ (vars ...) . body)
499     (match-let/helper let () () (vars ...) . body))
500    ((_ loop . rest)
501     (match-named-let loop () . rest))))
502
503(define-syntax match-letrec
504  (syntax-rules ()
505    ((_ vars . body) (match-let/helper letrec () () vars . body))))
506
507(define-syntax match-let/helper
508  (syntax-rules ()
509    ((_ let ((var expr) ...) () () . body)
510     (let ((var expr) ...) . body))
511    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
512     (let ((var expr) ...)
513       (match-let* ((pat tmp) ...)
514         . body)))
515    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
516     (match-let/helper
517      let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
518    ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
519     (match-let/helper
520      let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
521    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
522     (match-let/helper let (v ... (a expr)) (p ...) rest . body))
523    ))
524
525(define-syntax match-named-let
526  (syntax-rules ()
527    ((_ loop ((pat expr var) ...) () . body)
528     (let loop ((var expr) ...)
529       (match-let ((pat var) ...)
530         . body)))
531    ((_ loop (v ...) ((pat expr) . rest) . body)
532     (match-named-let loop (v ... (pat expr tmp)) rest . body))))
533
534(define-syntax match-let*
535  (syntax-rules ()
536    ((_ () . body)
537     (begin . body))
538    ((_ ((pat expr) . rest) . body)
539     (match expr (pat (match-let* rest . body))))))
540
541
542;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
543;; Not quite portable bits.
544
545;; Matching ellipses `...' is tricky.  A strict interpretation of R5RS
546;; would suggest that `...' in the literals list would treat it as a
547;; literal in pattern, however no SYNTAX-RULES implementation I'm
548;; aware of currently supports this.  SRFI-46 support would makes this
549;; easy, but SRFI-46 also is widely unsupported.
550
551;; In the meantime we conditionally implement this in whatever
552;; low-level macro system is available, defaulting to an
553;; implementation which doesn't support `...' and requires the user to
554;; match with `___'.
555
556(cond-expand
557 (syntax-case
558   (define-syntax (match-check-ellipse stx)
559     (syntax-case stx ()
560       ((_ q sk fk)
561        (if (and (identifier? (syntax q))
562                 (literal-identifier=? (syntax q) (syntax (... ...))))
563            (syntax sk)
564            (syntax fk))))))
565 (syntactic-closures
566  (define-syntax match-check-ellipse
567    (sc-macro-transformer
568     (lambda (form usage-environment)
569       (capture-syntactic-environment
570        (lambda (closing-environment)
571          (make-syntactic-closure usage-environment '()
572            (if (and (identifier? (cadr form))
573                     (identifier=? usage-environment (cadr form)
574                                   closing-environment '...))
575                (caddr form)
576                (cadddr form)))))))))
577 (else
578  ;; This should work, but doesn't for all implementations, so to be
579  ;; safe we use the definition below by default, which just never
580  ;; matches.
581  ;;   (define-syntax match-check-ellipse
582  ;;     (syntax-rules (...)
583  ;;       ((_ ... sk fk) sk)
584  ;;       ((_ x sk fk) fk)))
585  (define-syntax match-check-ellipse
586    (syntax-rules ()
587      ((_ x sk fk) fk)))
588  ))
589
590(cond-expand
591 (syntax-case
592  (define-syntax (match-check-identifier stx)
593    (syntax-case stx ()
594      ((_ x sk fk)
595       (if (identifier? (syntax q))
596           (syntax sk)
597           (syntax fk))))))
598 (syntactic-closures
599  (define-syntax match-check-identifier
600    (sc-macro-transformer
601     (lambda (form usage-environment)
602       (capture-syntactic-environment
603        (lambda (closing-environment)
604          (make-syntactic-closure usage-environment '()
605            (if (identifier? (cadr form))
606                (caddr form)
607                (cadddr form)))))))))
608 (else
609  (define-syntax match-check-identifier
610    (syntax-rules ()
611      ((_ (x . y) sk fk) fk)
612      ((_ #(x ...) sk fk) fk)
613      ((_ x sk fk)
614       (let-syntax
615         ((sym?
616           (syntax-rules ()
617             ((sym? x sk2 fk2) sk2)
618             ((sym? y sk2 fk2) fk2))))
619         (sym? abracadabra sk fk)))
620      ))
621  ))
622
623;; Annoying unhygienic record matching.  Record patterns look like
624;;   ($ record fields...)
625;; where the record name simply assumes that the same name suffixed
626;; with a "?" is the correct predicate.
627
628;; Why not just require the "?" to begin with?!
629
630(cond-expand
631 (syntax-case
632  (define-syntax (syntax-symbol-append-? stx)
633    (syntax-case stx ()
634      ((s x)
635       (datum->syntax-object
636        (syntax s)
637        (string->symbol
638         (string-append
639          (symbol->string (syntax-object->datum (syntax x)))
640          "?")))))))
641 (syntactic-closures
642  (define-syntax syntax-symbol-append-?
643    (sc-macro-transformer
644     (lambda (x e)
645       (string->symbol (string-append (symbol->string (cadr x)) "?"))))))
646 (else
647  (define-syntax syntax-symbol-append-?
648    (syntax-rules ()
649      ((_ sym)
650       (eval (string->symbol (string-append (symbol->string sym) "?"))))))))
651
652;; And another portability headache that I'm punting for now.
653
654;; Convert `..k' patterns (not used much, and under-powered, worry
655;; about this later).
656
657;; (cond-expand
658;;  (syntax-case
659;;   (define-syntax (match-convert-..k stx)
660;;     (syntax-case stx ()
661;;       ((_ (p q r s) (sk ...) fk)
662;;        (let ((q2 (cadadr (syntax-object->datum stx))))
663;;          (if (symbol? q2)
664;;            (let* ((str (symbol->string q2))
665;;                   (len (string-length str)))
666;;              (cond
667;;                ((and (> len 2)
668;;                      (eqv? #\. (string-ref str 0))
669;;                      (eqv? #\. (string-ref str 1))
670;;                      (string->number (substring str 2 len)))
671;;                 => (lambda (n)
672;;                      (syntax (sk ... n))))
673;;                (else
674;;                 (syntax fk))))
675;;            (syntax fk))))
676;;       ((_ x sk fk)
677;;        (syntax fk)))))
678;;  (else
679;;   (define-syntax match-convert-..k
680;;     (syntax-rules ()
681;;       ((_ (p q r s) sk fk) sk)
682;;       ((_ x sk fk) fk)))))
683
Note: See TracBrowser for help on using the repository browser.