source: project/matchable/matchable.scm @ 4622

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

Allowing ellipse patterns in other than the final position of a list.

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