Changeset 33291 in project


Ignore:
Timestamp:
04/04/16 16:59:28 (5 years ago)
Author:
Alex Shinn
Message:

Syncing with upstream (path from TheLemonMan?).

Location:
release/4/matchable
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/matchable/tags/3.4/matchable.meta

    r23255 r33291  
    77 (author "Alex Shinn")
    88 (doc-from-wiki)
    9  (files "matchable.release-info" "matchable.scm" "match-simple.scm" "matchable.setup" "matchable-test.scm" "matchable.meta"))
     9 (test-depends test)
     10 (files "matchable.release-info" "matchable.scm" "match-simple.scm" "matchable.setup" "matchable-test.scm" "matchable.meta" "match.scm"))
  • release/4/matchable/tags/3.4/matchable.scm

    r28001 r33291  
    1 ;;;; match-cond-expand.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.
     1(module matchable *
     2  (import scheme chicken)
     3  (use lolevel)
    54
    6 ;; Variant of match.scm, a few non-portable bits of code are
    7 ;; conditioned out with COND-EXPAND, notably allowing matching of the
    8 ;; `...' literal.
     5  ;; CHICKEN-specific glue
    96
    10 ;; This is a simple generative pattern matcher - each pattern is
    11 ;; expanded into the required tests, calling a failure continuation if
    12 ;; the tests fail.  This makes the logic easy to follow and extend,
    13 ;; but produces sub-optimal code in cases where you have many similar
    14 ;; clauses due to repeating the same tests.  Nonetheless a smart
    15 ;; compiler should be able to remove the redundant tests.  For
    16 ;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
    17 ;; hit.
     7  ;; slot-ref type obj n
     8  ;; Returns the 'n'th field of the record 'obj'.
     9  ;; 'n' might be a quoted symbol indicating a field name, we have to reject it
     10  ;; since CHICKEN doesn't carry any information about the field names.
     11  (define-syntax slot-ref
     12    (syntax-rules ()
     13      ((_ type obj n) (if (fixnum? n)
     14                          (record-instance-slot obj n)
     15                          (error "Accessing fields by name is not supported")))))
    1816
    19 ;; The original version was written on 2006/11/29 and described in the
    20 ;; following Usenet post:
    21 ;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
    22 ;; and is still available at
    23 ;;   http://synthcode.com/scheme/match-simple.scm
    24 ;;
    25 ;; 2012/12/26 - wrapping match-let&co body in lexical closure
    26 ;; 2012/11/28 - fixing typo s/vetor/vector in largely unused set! code
    27 ;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
    28 ;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
    29 ;;              the pattern (thanks to Stefan Israelsson Tampe)
    30 ;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
    31 ;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic CourtÚs)
    32 ;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
    33 ;; 2009/11/25 - adding `***' tree search patterns
    34 ;; 2008/03/20 - fixing bug where (a ...) matched non-lists
    35 ;; 2008/03/15 - removing redundant check in vector patterns
    36 ;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
    37 ;; 2007/09/04 - fixing quasiquote patterns
    38 ;; 2007/07/21 - allowing ellipse patterns in non-final list positions
    39 ;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
    40 ;;              (thanks to Taylor Campbell)
    41 ;; 2007/04/08 - clean up, commenting
    42 ;; 2006/12/24 - bugfixes
    43 ;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
     17  ;; slot-set! type obj n val
     18  ;; Sets the value of the 'n'th field of the record 'obj' to 'val'.
     19  (define-syntax slot-set!
     20    (syntax-rules ()
     21      ((_ type obj n val) (record-instance-slot-set! obj n val))))
    4422
    45 (module matchable *
     23  ;; is-a? obj type
     24  ;; Returns #t if 'obj' is a record with name 'type', #f otherwise.
     25  (define-syntax is-a?
     26    (syntax-rules ()
     27      ((_ obj type) (record-instance? obj (quote type)))))
    4628
    47   (import scheme chicken)
    48 
    49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    50 ;; force compile-time syntax errors with useful messages
    51 
    52 (define-syntax match-syntax-error
    53   (syntax-rules ()
    54     ((_) (match-syntax-error "invalid match-syntax-error usage"))))
    55 
    56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    57 
    58 ;; The basic interface.  MATCH just performs some basic syntax
    59 ;; validation, binds the match expression to a temporary variable, and
    60 ;; passes it on to MATCH-NEXT.
    61 
    62 (define-syntax match
    63   (syntax-rules ()
    64     ((match)
    65      (match-syntax-error "missing match expression"))
    66     ((match atom)
    67      (match-syntax-error "no match clauses"))
    68     ((match (app ...) (pat . body) ...)
    69      (let ((v (app ...)))
    70        (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
    71     ((match #(vec ...) (pat . body) ...)
    72      (let ((v #(vec ...)))
    73        (match-next v (v (set! v)) (pat . body) ...)))
    74     ((match atom (pat . body) ...)
    75      (let ((v atom))
    76        (match-next v (atom (set! atom)) (pat . body) ...)))
    77     ))
    78 
    79 ;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
    80 ;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
    81 ;; clauses.
    82 
    83 (define-syntax match-next
    84   (syntax-rules (=>)
    85     ;; no more clauses, the match failed
    86     ((match-next v g+s)
    87      (error 'match "no matching pattern"))
    88     ;; named failure continuation
    89     ((match-next v g+s (pat (=> failure) . body) . rest)
    90      (let ((failure (lambda () (match-next v g+s . rest))))
    91        ;; match-one analyzes the pattern for us
    92        (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
    93     ;; anonymous failure continuation, give it a dummy name
    94     ((match-next v g+s (pat . body) . rest)
    95      (match-next v g+s (pat (=> failure) . body) . rest))))
    96 
    97 ;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
    98 ;; MATCH-TWO.
    99 
    100 (define-syntax match-one
    101   (syntax-rules ()
    102     ;; If it's a list of two or more values, check to see if the
    103     ;; second one is an ellipse and handle accordingly, otherwise go
    104     ;; to MATCH-TWO.
    105     ((match-one v (p q . r) g+s sk fk i)
    106      (match-check-ellipse
    107       q
    108       (match-extract-vars p (match-gen-ellipses v p r  g+s sk fk i) i ())
    109       (match-two v (p q . r) g+s sk fk i)))
    110     ;; Go directly to MATCH-TWO.
    111     ((match-one . x)
    112      (match-two . x))))
    113 
    114 ;; This is the guts of the pattern matcher.  We are passed a lot of
    115 ;; information in the form:
    116 ;;
    117 ;;   (match-two var pattern getter setter success-k fail-k (ids ...))
    118 ;;
    119 ;; where VAR is the symbol name of the current variable we are
    120 ;; matching, PATTERN is the current pattern, getter and setter are the
    121 ;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
    122 ;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
    123 ;; continuation (which is just a thunk call and is thus safe to expand
    124 ;; multiple times) and IDS are the list of identifiers bound in the
    125 ;; pattern so far.
    126 
    127 (define-syntax match-two
    128   (syntax-rules (_ ___ ..1 *** quote quasiquote ? $ = and or not set! get!)
    129     ((match-two v () g+s (sk ...) fk i)
    130      (if (null? v) (sk ... i) fk))
    131     ((match-two v (quote p) g+s (sk ...) fk i)
    132      (if (equal? v 'p) (sk ... i) fk))
    133     ((match-two v (quasiquote p) . x)
    134      (match-quasiquote v p . x))
    135     ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
    136     ((match-two v (and p q ...) g+s sk fk i)
    137      (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
    138     ((match-two v (or) g+s sk fk i) fk)
    139     ((match-two v (or p) . x)
    140      (match-one v p . x))
    141     ((match-two v (or p ...) g+s sk fk i)
    142      (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
    143     ((match-two v (not p) g+s (sk ...) fk i)
    144      (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
    145     ((match-two v (get! getter) (g s) (sk ...) fk i)
    146      (let ((getter (lambda () g))) (sk ... i)))
    147     ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
    148      (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
    149     ((match-two v (? pred . p) g+s sk fk i)
    150      (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
    151     ((match-two v (= proc p) . x)
    152      (let ((w (proc v))) (match-one w p . x)))
    153     ((match-two v (p ___ . r) g+s sk fk i)
    154      (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
    155     ((match-two v (p) g+s sk fk i)
    156      (if (and (pair? v) (null? (cdr v)))
    157          (let ((w (car v)))
    158            (match-one w p ((car v) (set-car! v)) sk fk i))
    159          fk))
    160     ((match-two v (p *** q) g+s sk fk i)
    161      (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
    162     ((match-two v (p *** . q) g+s sk fk i)
    163      (match-syntax-error "invalid use of ***" (p *** . q)))
    164     ((match-two v (p ..1) g+s sk fk i)
    165      (if (pair? v)
    166          (match-one v (p ___) g+s sk fk i)
    167          fk))
    168     ((match-two v ($ rec p ...) g+s sk fk i)
    169      (if ((syntax-symbol-append-? rec) v)
    170          (match-record-refs v 1 (p ...) g+s sk fk i)
    171          fk))
    172     ((match-two v (p . q) g+s sk fk i)
    173      (if (pair? v)
    174          (let ((w (car v)) (x (cdr v)))
    175            (match-one w p ((car v) (set-car! v))
    176                       (match-one x q ((cdr v) (set-cdr! v)) sk fk)
    177                       fk
    178                       i))
    179          fk))
    180     ((match-two v #(p ...) g+s . x)
    181      (match-vector v 0 () (p ...) . x))
    182     ((match-two v _ g+s (sk ...) fk i) (sk ... i))
    183     ;; Not a pair or vector or special literal, test to see if it's a
    184     ;; new symbol, in which case we just bind it, or if it's an
    185     ;; already bound symbol or some other literal, in which case we
    186     ;; compare it with EQUAL?.
    187     ((match-two v x g+s (sk ...) fk (id ...))
    188      (let-syntax
    189          ((new-sym?
    190            (syntax-rules (id ...)
    191              ((new-sym? x sk2 fk2) sk2)
    192              ((new-sym? y sk2 fk2) fk2))))
    193        (new-sym? random-sym-to-match
    194                  (let ((x v)) (sk ... (id ... x)))
    195                  (if (equal? v x) (sk ... (id ...)) fk))))
    196     ))
    197 
    198 ;; QUASIQUOTE patterns
    199 
    200 (define-syntax match-quasiquote
    201   (syntax-rules (unquote unquote-splicing quasiquote)
    202     ((_ v (unquote p) g+s sk fk i)
    203      (match-one v p g+s sk fk i))
    204     ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
    205      (if (pair? v)
    206        (match-one v
    207                   (p . tmp)
    208                   (match-quasiquote tmp rest g+s sk fk)
    209                   fk
    210                   i)
    211        fk))
    212     ((_ v (quasiquote p) g+s sk fk i . depth)
    213      (match-quasiquote v p g+s sk fk i #f . depth))
    214     ((_ v (unquote p) g+s sk fk i x . depth)
    215      (match-quasiquote v p g+s sk fk i . depth))
    216     ((_ v (unquote-splicing p) g+s sk fk i x . depth)
    217      (match-quasiquote v p g+s sk fk i . depth))
    218     ((_ v (p . q) g+s sk fk i . depth)
    219      (if (pair? v)
    220        (let ((w (car v)) (x (cdr v)))
    221          (match-quasiquote
    222           w p g+s
    223           (match-quasiquote-step x q g+s sk fk depth)
    224           fk i . depth))
    225        fk))
    226     ((_ v #(elt ...) g+s sk fk i . depth)
    227      (if (vector? v)
    228        (let ((ls (vector->list v)))
    229          (match-quasiquote ls (elt ...) g+s sk fk i . depth))
    230        fk))
    231     ((_ v x g+s sk fk i . depth)
    232      (match-one v 'x g+s sk fk i))))
    233 
    234 (define-syntax match-quasiquote-step
    235   (syntax-rules ()
    236     ((match-quasiquote-step x q g+s sk fk depth i)
    237      (match-quasiquote x q g+s sk fk i . depth))))
    238 
    239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    240 ;; Utilities
    241 
    242 ;; A CPS utility that takes two values and just expands into the
    243 ;; first.
    244 (define-syntax match-drop-ids
    245   (syntax-rules ()
    246     ((_ expr ids ...) expr)))
    247 
    248 (define-syntax match-tuck-ids
    249   (syntax-rules ()
    250     ((_ (letish args (expr ...)) ids ...)
    251      (letish args (expr ... ids ...)))))
    252 
    253 (define-syntax match-drop-first-arg
    254   (syntax-rules ()
    255     ((_ arg expr) expr)))
    256 
    257 ;; To expand an OR group we try each clause in succession, passing the
    258 ;; first that succeeds to the success continuation.  On failure for
    259 ;; any clause, we just try the next clause, finally resorting to the
    260 ;; failure continuation fk if all clauses fail.  The only trick is
    261 ;; that we want to unify the identifiers, so that the success
    262 ;; continuation can refer to a variable from any of the OR clauses.
    263 
    264 (define-syntax match-gen-or
    265   (syntax-rules ()
    266     ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
    267      (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
    268        (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
    269 
    270 (define-syntax match-gen-or-step
    271   (syntax-rules ()
    272     ((_ v () g+s sk fk . x)
    273      ;; no OR clauses, call the failure continuation
    274      fk)
    275     ((_ v (p) . x)
    276      ;; last (or only) OR clause, just expand normally
    277      (match-one v p . x))
    278     ((_ v (p . q) g+s sk fk i)
    279      ;; match one and try the remaining on failure
    280      (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
    281        (match-one v p g+s sk (fk2) i)))
    282     ))
    283 
    284 ;; We match a pattern (p ...) by matching the pattern p in a loop on
    285 ;; each element of the variable, accumulating the bound ids into lists.
    286 
    287 ;; Look at the body of the simple case - it's just a named let loop,
    288 ;; matching each element in turn to the same pattern.  The only trick
    289 ;; is that we want to keep track of the lists of each extracted id, so
    290 ;; when the loop recurses we cons the ids onto their respective list
    291 ;; variables, and on success we bind the ids (what the user input and
    292 ;; expects to see in the success body) to the reversed accumulated
    293 ;; list IDs.
    294 
    295 (define-syntax match-gen-ellipses
    296   (syntax-rules ()
    297     ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
    298      (match-check-identifier p
    299        ;; simplest case equivalent to (p ...), just bind the list
    300        (let ((p v))
    301          (if (list? p)
    302              (sk ... i)
    303              fk))
    304        ;; simple case, match all elements of the list
    305        (let loop ((ls v) (id-ls '()) ...)
    306          (cond
    307            ((null? ls)
    308             (let ((id (reverse id-ls)) ...) (sk ... i)))
    309            ((pair? ls)
    310             (let ((w (car ls)))
    311               (match-one w p ((car ls) (set-car! ls))
    312                          (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
    313                          fk i)))
    314            (else
    315             fk)))))
    316     ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
    317      ;; general case, trailing patterns to match, keep track of the
    318      ;; remaining list length so we don't need any backtracking
    319      (match-verify-no-ellipses
    320       r
    321       (let* ((tail-len (length 'r))
    322              (ls v)
    323              (len (and (list? ls) (length ls))))
    324         (if (or (not len) (< len tail-len))
    325             fk
    326             (let loop ((ls ls) (n len) (id-ls '()) ...)
    327               (cond
    328                 ((= n tail-len)
    329                  (let ((id (reverse id-ls)) ...)
    330                    (match-one ls r (#f #f) (sk ...) fk i)))
    331                 ((pair? ls)
    332                  (let ((w (car ls)))
    333                    (match-one w p ((car ls) (set-car! ls))
    334                               (match-drop-ids
    335                                (loop (cdr ls) (- n 1) (cons id id-ls) ...))
    336                               fk
    337                               i)))
    338                 (else
    339                  fk)))))))))
    340 
    341 ;; This is just a safety check.  Although unlike syntax-rules we allow
    342 ;; trailing patterns after an ellipses, we explicitly disable multiple
    343 ;; ellipses at the same level.  This is because in the general case
    344 ;; such patterns are exponential in the number of ellipses, and we
    345 ;; don't want to make it easy to construct very expensive operations
    346 ;; with simple looking patterns.  For example, it would be O(n^2) for
    347 ;; patterns like (a ... b ...) because we must consider every trailing
    348 ;; element for every possible break for the leading "a ...".
    349 
    350 (define-syntax match-verify-no-ellipses
    351   (syntax-rules ()
    352     ((_ (x . y) sk)
    353      (match-check-ellipse
    354       x
    355       (match-syntax-error
    356        "multiple ellipse patterns not allowed at same level")
    357       (match-verify-no-ellipses y sk)))
    358     ((_ () sk)
    359      sk)
    360     ((_ x sk)
    361      (match-syntax-error "dotted tail not allowed after ellipse" x))))
    362 
    363 ;; Matching a tree search pattern is only slightly more complicated.
    364 ;; Here we allow patterns of the form
    365 ;;
    366 ;;     (x *** y)
    367 ;;
    368 ;; to represent the pattern y located somewhere in a tree where the
    369 ;; path from the current object to y can be seen as a list of the form
    370 ;; (X ...).  Y can immediately match the current object in which case
    371 ;; the path is the empty list.  In a sense it's a 2-dimensional
    372 ;; version of the ... pattern.
    373 ;;
    374 ;; As a common case the pattern (_ *** y) can be used to search for Y
    375 ;; anywhere in a tree, regardless of the path used.
    376 ;;
    377 ;; To implement the search, we use two recursive procedures.  TRY
    378 ;; attempts to match Y once, and on success it calls the normal SK on
    379 ;; the accumulated list ids as in MATCH-GEN-ELLIPSES.  On failure, we
    380 ;; call NEXT which first checks if the current value is a list
    381 ;; beginning with X, then calls TRY on each remaining element of the
    382 ;; list.  Since TRY will recursively call NEXT again on failure, this
    383 ;; effects a full depth-first search.
    384 ;;
    385 ;; The failure continuation throughout is a jump to the next step in
    386 ;; the tree search, initialized with the original failure continuation
    387 ;; FK.
    388 
    389 (define-syntax match-gen-search
    390   (syntax-rules ()
    391     ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
    392      (letrec ((try (lambda (w fail id-ls ...)
    393                      (match-one w q g+s
    394                                 (match-tuck-ids
    395                                  (let ((id (reverse id-ls)) ...)
    396                                    sk))
    397                                 (next w fail id-ls ...) i)))
    398               (next (lambda (w fail id-ls ...)
    399                       (if (not (pair? w))
    400                           (fail)
    401                           (let ((u (car w)))
    402                             (match-one
    403                              u p ((car w) (set-car! w))
    404                              (match-drop-ids
    405                               ;; accumulate the head variables from
    406                               ;; the p pattern, and loop over the tail
    407                               (let ((id-ls (cons id id-ls)) ...)
    408                                 (let lp ((ls (cdr w)))
    409                                   (if (pair? ls)
    410                                       (try (car ls)
    411                                            (lambda () (lp (cdr ls)))
    412                                            id-ls ...)
    413                                       (fail)))))
    414                              (fail) i))))))
    415        ;; the initial id-ls binding here is a dummy to get the right
    416        ;; number of '()s
    417        (let ((id-ls '()) ...)
    418          (try v (lambda () fk) id-ls ...))))))
    419 
    420 ;; Vector patterns are just more of the same, with the slight
    421 ;; exception that we pass around the current vector index being
    422 ;; matched.
    423 
    424 (define-syntax match-vector
    425   (syntax-rules (___)
    426     ((_ v n pats (p q) . x)
    427      (match-check-ellipse q
    428                           (match-gen-vector-ellipses v n pats p . x)
    429                           (match-vector-two v n pats (p q) . x)))
    430     ((_ v n pats (p ___) sk fk i)
    431      (match-gen-vector-ellipses v n pats p sk fk i))
    432     ((_ . x)
    433      (match-vector-two . x))))
    434 
    435 ;; Check the exact vector length, then check each element in turn.
    436 
    437 (define-syntax match-vector-two
    438   (syntax-rules ()
    439     ((_ v n ((pat index) ...) () sk fk i)
    440      (if (vector? v)
    441          (let ((len (vector-length v)))
    442            (if (= len n)
    443                (match-vector-step v ((pat index) ...) sk fk i)
    444                fk))
    445          fk))
    446     ((_ v n (pats ...) (p . q) . x)
    447      (match-vector v (+ n 1) (pats ... (p n)) q . x))))
    448 
    449 (define-syntax match-vector-step
    450   (syntax-rules ()
    451     ((_ v () (sk ...) fk i) (sk ... i))
    452     ((_ v ((pat index) . rest) sk fk i)
    453      (let ((w (vector-ref v index)))
    454        (match-one w pat ((vector-ref v index) (vector-set! v index))
    455                   (match-vector-step v rest sk fk)
    456                   fk i)))))
    457 
    458 ;; With a vector ellipse pattern we first check to see if the vector
    459 ;; length is at least the required length.
    460 
    461 (define-syntax match-gen-vector-ellipses
    462   (syntax-rules ()
    463     ((_ v n ((pat index) ...) p sk fk i)
    464      (if (vector? v)
    465        (let ((len (vector-length v)))
    466          (if (>= len n)
    467            (match-vector-step v ((pat index) ...)
    468                               (match-vector-tail v p n len sk fk)
    469                               fk i)
    470            fk))
    471        fk))))
    472 
    473 (define-syntax match-vector-tail
    474   (syntax-rules ()
    475     ((_ v p n len sk fk i)
    476      (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
    477 
    478 (define-syntax match-vector-tail-two
    479   (syntax-rules ()
    480     ((_ v p n len (sk ...) fk i ((id id-ls) ...))
    481      (let loop ((j n) (id-ls '()) ...)
    482        (if (>= j len)
    483          (let ((id (reverse id-ls)) ...) (sk ... i))
    484          (let ((w (vector-ref v j)))
    485            (match-one w p ((vector-ref v j) (vector-set! v j))
    486                       (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
    487                       fk i)))))))
    488 
    489 ;; Chicken-specific.
    490 
    491 (cond-expand
    492  (chicken
    493   (define-syntax match-record-refs
    494     (syntax-rules ()
    495       ((_ v n (p . q) g+s sk fk i)
    496        (let ((w (##sys#block-ref v n)))
    497          (match-one w p ((##sys#block-ref v n) (##sys#block-set! v n))
    498                     (match-record-refs v (+ n 1) q g+s sk fk)
    499                     fk i)))
    500       ((_ v n () g+s (sk ...) fk i)
    501        (sk ... i)))))
    502  (else
    503   ))
    504 
    505 ;; Extract all identifiers in a pattern.  A little more complicated
    506 ;; than just looking for symbols, we need to ignore special keywords
    507 ;; and non-pattern forms (such as the predicate expression in ?
    508 ;; patterns), and also ignore previously bound identifiers.
    509 ;;
    510 ;; Calls the continuation with all new vars as a list of the form
    511 ;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
    512 ;; pair with the original variable (e.g. it's used in the ellipse
    513 ;; generation for list variables).
    514 ;;
    515 ;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
    516 
    517 (define-syntax match-extract-vars
    518   (syntax-rules (_ ___ ..1 *** ? $ = quote quasiquote and or not get! set!)
    519     ((match-extract-vars (? pred . p) . x)
    520      (match-extract-vars p . x))
    521     ((match-extract-vars ($ rec . p) . x)
    522      (match-extract-vars p . x))
    523     ((match-extract-vars (= proc p) . x)
    524      (match-extract-vars p . x))
    525     ((match-extract-vars (quote x) (k ...) i v)
    526      (k ... v))
    527     ((match-extract-vars (quasiquote x) k i v)
    528      (match-extract-quasiquote-vars x k i v (#t)))
    529     ((match-extract-vars (and . p) . x)
    530      (match-extract-vars p . x))
    531     ((match-extract-vars (or . p) . x)
    532      (match-extract-vars p . x))
    533     ((match-extract-vars (not . p) . x)
    534      (match-extract-vars p . x))
    535     ;; A non-keyword pair, expand the CAR with a continuation to
    536     ;; expand the CDR.
    537     ((match-extract-vars (p q . r) k i v)
    538      (match-check-ellipse
    539       q
    540       (match-extract-vars (p . r) k i v)
    541       (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
    542     ((match-extract-vars (p . q) k i v)
    543      (match-extract-vars p (match-extract-vars-step q k i v) i ()))
    544     ((match-extract-vars #(p ...) . x)
    545      (match-extract-vars (p ...) . x))
    546     ((match-extract-vars _ (k ...) i v)    (k ... v))
    547     ((match-extract-vars ___ (k ...) i v)  (k ... v))
    548     ((match-extract-vars *** (k ...) i v)  (k ... v))
    549     ((match-extract-vars ..1 (k ...) i v)  (k ... v))
    550     ;; This is the main part, the only place where we might add a new
    551     ;; var if it's an unbound symbol.
    552     ((match-extract-vars p (k ...) (i ...) v)
    553      (let-syntax
    554          ((new-sym?
    555            (syntax-rules (i ...)
    556              ((new-sym? p sk fk) sk)
    557              ((new-sym? any sk fk) fk))))
    558        (new-sym? random-sym-to-match
    559                  (k ... ((p p-ls) . v))
    560                  (k ... v))))
    561     ))
    562 
    563 ;; Stepper used in the above so it can expand the CAR and CDR
    564 ;; separately.
    565 
    566 (define-syntax match-extract-vars-step
    567   (syntax-rules ()
    568     ((_ p k i v ((v2 v2-ls) ...))
    569      (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
    570     ))
    571 
    572 (define-syntax match-extract-quasiquote-vars
    573   (syntax-rules (quasiquote unquote unquote-splicing)
    574     ((match-extract-quasiquote-vars (quasiquote x) k i v d)
    575      (match-extract-quasiquote-vars x k i v (#t . d)))
    576     ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
    577      (match-extract-quasiquote-vars (unquote x) k i v d))
    578     ((match-extract-quasiquote-vars (unquote x) k i v (#t))
    579      (match-extract-vars x k i v))
    580     ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
    581      (match-extract-quasiquote-vars x k i v d))
    582     ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
    583      (match-extract-quasiquote-vars
    584       x
    585       (match-extract-quasiquote-vars-step y k i v d) i ()))
    586     ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
    587      (match-extract-quasiquote-vars (x ...) k i v d))
    588     ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
    589      (k ... v))
    590     ))
    591 
    592 (define-syntax match-extract-quasiquote-vars-step
    593   (syntax-rules ()
    594     ((_ x k i v d ((v2 v2-ls) ...))
    595      (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
    596     ))
    597 
    598 
    599 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    600 ;; Gimme some sugar baby.
    601 
    602 (define-syntax match-lambda
    603   (syntax-rules ()
    604     ((_ clause ...) (lambda (expr) (match expr clause ...)))))
    605 
    606 (define-syntax match-lambda*
    607   (syntax-rules ()
    608     ((_ clause ...) (lambda expr (match expr clause ...)))))
    609 
    610 (define-syntax match-let
    611   (syntax-rules ()
    612     ((_ (vars ...) . body)
    613      (match-let/helper let () () (vars ...) . body))
    614     ((_ loop . rest)
    615      (match-named-let loop () . rest))))
    616 
    617 (define-syntax match-letrec
    618   (syntax-rules ()
    619     ((_ vars . body) (match-let/helper letrec () () vars . body))))
    620 
    621 (define-syntax match-let/helper
    622   (syntax-rules ()
    623     ((_ let ((var expr) ...) () () . body)
    624      (let ((var expr) ...) . body))
    625     ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
    626      (let ((var expr) ...)
    627        (match-let* ((pat tmp) ...)
    628          . body)))
    629     ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
    630      (match-let/helper
    631       let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
    632     ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
    633      (match-let/helper
    634       let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
    635     ((_ let (v ...) (p ...) ((a expr) . rest) . body)
    636      (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
    637 
    638 (define-syntax match-named-let
    639   (syntax-rules ()
    640     ((_ loop ((pat expr var) ...) () . body)
    641      (let loop ((var expr) ...)
    642        (match-let ((pat var) ...)
    643          . body)))
    644     ((_ loop (v ...) ((pat expr) . rest) . body)
    645      (match-named-let loop (v ... (pat expr tmp)) rest . body))))
    646 
    647 (define-syntax match-let*
    648   (syntax-rules ()
    649     ((_ () . body)
    650      (let () . body))
    651     ((_ ((pat expr) . rest) . body)
    652      (match expr (pat (match-let* rest . body))))))
    653 
    654 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    655 ;; Not quite portable bits.
    656 
    657 ;; Matching ellipses `...' is tricky.  A strict interpretation of R5RS
    658 ;; would suggest that `...' in the literals list would treat it as a
    659 ;; literal in pattern, however no SYNTAX-RULES implementation I'm
    660 ;; aware of currently supports this.  SRFI-46 support would makes this
    661 ;; easy, but SRFI-46 also is widely unsupported.
    662 
    663 ;; In the meantime we conditionally implement this in whatever
    664 ;; low-level macro system is available, defaulting to an
    665 ;; implementation which doesn't support `...' and requires the user to
    666 ;; match with `___'.
    667 
    668 (cond-expand
    669  (syntax-case
    670    (define-syntax (match-check-ellipse stx)
    671      (syntax-case stx ()
    672        ((_ q sk fk)
    673         (if (and (identifier? (syntax q))
    674                  (literal-identifier=? (syntax q) (syntax (... ...))))
    675             (syntax sk)
    676             (syntax fk))))))
    677  (syntactic-closures
    678   (define-syntax match-check-ellipse
    679     (sc-macro-transformer
    680      (lambda (form usage-environment)
    681        (capture-syntactic-environment
    682         (lambda (closing-environment)
    683           (make-syntactic-closure usage-environment '()
    684             (if (and (identifier? (cadr form))
    685                      (identifier=? usage-environment (cadr form)
    686                                    closing-environment '...))
    687                 (caddr form)
    688                 (cadddr form)))))))))
    689  (else
    690   ;; This is a little more complicated, and introduces a new let-syntax,
    691   ;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
    692   ;; originally came up with the idea.
    693   (define-syntax match-check-ellipse
    694     (syntax-rules ()
    695       ;; these two aren't necessary but provide fast-case failures
    696       ((match-check-ellipse (a . b) success-k failure-k) failure-k)
    697       ((match-check-ellipse #(a ...) success-k failure-k) failure-k)
    698       ;; matching an atom
    699       ((match-check-ellipse id success-k failure-k)
    700        (let-syntax ((ellipse? (syntax-rules ()
    701                                 ;; iff `id' is `...' here then this will
    702                                 ;; match a list of any length
    703                                 ((ellipse? (foo id) sk fk) sk)
    704                                 ((ellipse? other sk fk) fk))))
    705          ;; this list of three elements will only many the (foo id) list
    706          ;; above if `id' is `...'
    707          (ellipse? (a b c) success-k failure-k)))))))
    708 
    709 
    710 ;; This is portable but can be more efficient with non-portable
    711 ;; extensions.
    712 
    713 (cond-expand
    714  (syntax-case
    715   (define-syntax (match-check-identifier stx)
    716     (syntax-case stx ()
    717       ((_ x sk fk)
    718        (if (identifier? (syntax q))
    719            (syntax sk)
    720            (syntax fk))))))
    721  (syntactic-closures
    722   (define-syntax match-check-identifier
    723     (sc-macro-transformer
    724      (lambda (form usage-environment)
    725        (capture-syntactic-environment
    726         (lambda (closing-environment)
    727           (make-syntactic-closure usage-environment '()
    728             (if (identifier? (cadr form))
    729                 (caddr form)
    730                 (cadddr form)))))))))
    731  (else
    732   (define-syntax match-check-identifier
    733     (syntax-rules ()
    734       ;; fast-case failures, lists and vectors are not identifiers
    735       ((_ (x . y) success-k failure-k) failure-k)
    736       ((_ #(x ...) success-k failure-k) failure-k)
    737       ;; x is an atom
    738       ((_ x success-k failure-k)
    739        (let-syntax
    740            ((sym?
    741              (syntax-rules ()
    742                ;; if the symbol `abracadabra' matches x, then x is a
    743                ;; symbol
    744                ((sym? x sk fk) sk)
    745                ;; otherwise x is a non-symbol datum
    746                ((sym? y sk fk) fk))))
    747          (sym? abracadabra success-k failure-k)))))))
    748 
    749 ;; Annoying unhygienic record matching.  Record patterns look like
    750 ;;   ($ record fields...)
    751 ;; where the record name simply assumes that the same name suffixed
    752 ;; with a "?" is the correct predicate.
    753 
    754 ;; Why not just require the "?" to begin with?!
    755 
    756 (cond-expand
    757  (chicken
    758   (define-syntax syntax-symbol-append-?
    759     (lambda (x r c)
    760       (string->symbol (string-append (symbol->string (cadr x)) "?")))))
    761  (syntax-case
    762   (define-syntax (syntax-symbol-append-? stx)
    763     (syntax-case stx ()
    764       ((s x)
    765        (datum->syntax-object
    766         (syntax s)
    767         (string->symbol
    768          (string-append
    769           (symbol->string (syntax-object->datum (syntax x)))
    770           "?")))))))
    771  (syntactic-closures
    772   (define-syntax syntax-symbol-append-?
    773     (sc-macro-transformer
    774      (lambda (x e)
    775        (string->symbol (string-append (symbol->string (cadr x)) "?"))))))
    776  (else
    777   (define-syntax syntax-symbol-append-?
    778     (syntax-rules ()
    779       ((_ sym)
    780        (eval (string->symbol (string-append (symbol->string sym) "?"))))))))
    781 
     29  (include "match.scm")
    78230)
  • release/4/matchable/tags/3.4/matchable.setup

    r28001 r33291  
    44(install-extension 'matchable
    55 '("matchable.so" "matchable.import.so")
    6  '((version "3.3")))
     6 '((version "3.4")))
  • release/4/matchable/trunk/matchable.meta

    r23255 r33291  
    77 (author "Alex Shinn")
    88 (doc-from-wiki)
    9  (files "matchable.release-info" "matchable.scm" "match-simple.scm" "matchable.setup" "matchable-test.scm" "matchable.meta"))
     9 (test-depends test)
     10 (files "matchable.release-info" "matchable.scm" "match-simple.scm" "matchable.setup" "matchable-test.scm" "matchable.meta" "match.scm"))
  • release/4/matchable/trunk/matchable.scm

    r28001 r33291  
    1 ;;;; match-cond-expand.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.
     1(module matchable *
     2  (import scheme chicken)
     3  (use lolevel)
    54
    6 ;; Variant of match.scm, a few non-portable bits of code are
    7 ;; conditioned out with COND-EXPAND, notably allowing matching of the
    8 ;; `...' literal.
     5  ;; CHICKEN-specific glue
    96
    10 ;; This is a simple generative pattern matcher - each pattern is
    11 ;; expanded into the required tests, calling a failure continuation if
    12 ;; the tests fail.  This makes the logic easy to follow and extend,
    13 ;; but produces sub-optimal code in cases where you have many similar
    14 ;; clauses due to repeating the same tests.  Nonetheless a smart
    15 ;; compiler should be able to remove the redundant tests.  For
    16 ;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
    17 ;; hit.
     7  ;; slot-ref type obj n
     8  ;; Returns the 'n'th field of the record 'obj'.
     9  ;; 'n' might be a quoted symbol indicating a field name, we have to reject it
     10  ;; since CHICKEN doesn't carry any information about the field names.
     11  (define-syntax slot-ref
     12    (syntax-rules ()
     13      ((_ type obj n) (if (fixnum? n)
     14                          (record-instance-slot obj n)
     15                          (error "Accessing fields by name is not supported")))))
    1816
    19 ;; The original version was written on 2006/11/29 and described in the
    20 ;; following Usenet post:
    21 ;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
    22 ;; and is still available at
    23 ;;   http://synthcode.com/scheme/match-simple.scm
    24 ;;
    25 ;; 2012/12/26 - wrapping match-let&co body in lexical closure
    26 ;; 2012/11/28 - fixing typo s/vetor/vector in largely unused set! code
    27 ;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
    28 ;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
    29 ;;              the pattern (thanks to Stefan Israelsson Tampe)
    30 ;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
    31 ;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic CourtÚs)
    32 ;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
    33 ;; 2009/11/25 - adding `***' tree search patterns
    34 ;; 2008/03/20 - fixing bug where (a ...) matched non-lists
    35 ;; 2008/03/15 - removing redundant check in vector patterns
    36 ;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
    37 ;; 2007/09/04 - fixing quasiquote patterns
    38 ;; 2007/07/21 - allowing ellipse patterns in non-final list positions
    39 ;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
    40 ;;              (thanks to Taylor Campbell)
    41 ;; 2007/04/08 - clean up, commenting
    42 ;; 2006/12/24 - bugfixes
    43 ;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
     17  ;; slot-set! type obj n val
     18  ;; Sets the value of the 'n'th field of the record 'obj' to 'val'.
     19  (define-syntax slot-set!
     20    (syntax-rules ()
     21      ((_ type obj n val) (record-instance-slot-set! obj n val))))
    4422
    45 (module matchable *
     23  ;; is-a? obj type
     24  ;; Returns #t if 'obj' is a record with name 'type', #f otherwise.
     25  (define-syntax is-a?
     26    (syntax-rules ()
     27      ((_ obj type) (record-instance? obj (quote type)))))
    4628
    47   (import scheme chicken)
    48 
    49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    50 ;; force compile-time syntax errors with useful messages
    51 
    52 (define-syntax match-syntax-error
    53   (syntax-rules ()
    54     ((_) (match-syntax-error "invalid match-syntax-error usage"))))
    55 
    56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    57 
    58 ;; The basic interface.  MATCH just performs some basic syntax
    59 ;; validation, binds the match expression to a temporary variable, and
    60 ;; passes it on to MATCH-NEXT.
    61 
    62 (define-syntax match
    63   (syntax-rules ()
    64     ((match)
    65      (match-syntax-error "missing match expression"))
    66     ((match atom)
    67      (match-syntax-error "no match clauses"))
    68     ((match (app ...) (pat . body) ...)
    69      (let ((v (app ...)))
    70        (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
    71     ((match #(vec ...) (pat . body) ...)
    72      (let ((v #(vec ...)))
    73        (match-next v (v (set! v)) (pat . body) ...)))
    74     ((match atom (pat . body) ...)
    75      (let ((v atom))
    76        (match-next v (atom (set! atom)) (pat . body) ...)))
    77     ))
    78 
    79 ;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
    80 ;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
    81 ;; clauses.
    82 
    83 (define-syntax match-next
    84   (syntax-rules (=>)
    85     ;; no more clauses, the match failed
    86     ((match-next v g+s)
    87      (error 'match "no matching pattern"))
    88     ;; named failure continuation
    89     ((match-next v g+s (pat (=> failure) . body) . rest)
    90      (let ((failure (lambda () (match-next v g+s . rest))))
    91        ;; match-one analyzes the pattern for us
    92        (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
    93     ;; anonymous failure continuation, give it a dummy name
    94     ((match-next v g+s (pat . body) . rest)
    95      (match-next v g+s (pat (=> failure) . body) . rest))))
    96 
    97 ;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
    98 ;; MATCH-TWO.
    99 
    100 (define-syntax match-one
    101   (syntax-rules ()
    102     ;; If it's a list of two or more values, check to see if the
    103     ;; second one is an ellipse and handle accordingly, otherwise go
    104     ;; to MATCH-TWO.
    105     ((match-one v (p q . r) g+s sk fk i)
    106      (match-check-ellipse
    107       q
    108       (match-extract-vars p (match-gen-ellipses v p r  g+s sk fk i) i ())
    109       (match-two v (p q . r) g+s sk fk i)))
    110     ;; Go directly to MATCH-TWO.
    111     ((match-one . x)
    112      (match-two . x))))
    113 
    114 ;; This is the guts of the pattern matcher.  We are passed a lot of
    115 ;; information in the form:
    116 ;;
    117 ;;   (match-two var pattern getter setter success-k fail-k (ids ...))
    118 ;;
    119 ;; where VAR is the symbol name of the current variable we are
    120 ;; matching, PATTERN is the current pattern, getter and setter are the
    121 ;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
    122 ;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
    123 ;; continuation (which is just a thunk call and is thus safe to expand
    124 ;; multiple times) and IDS are the list of identifiers bound in the
    125 ;; pattern so far.
    126 
    127 (define-syntax match-two
    128   (syntax-rules (_ ___ ..1 *** quote quasiquote ? $ = and or not set! get!)
    129     ((match-two v () g+s (sk ...) fk i)
    130      (if (null? v) (sk ... i) fk))
    131     ((match-two v (quote p) g+s (sk ...) fk i)
    132      (if (equal? v 'p) (sk ... i) fk))
    133     ((match-two v (quasiquote p) . x)
    134      (match-quasiquote v p . x))
    135     ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
    136     ((match-two v (and p q ...) g+s sk fk i)
    137      (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
    138     ((match-two v (or) g+s sk fk i) fk)
    139     ((match-two v (or p) . x)
    140      (match-one v p . x))
    141     ((match-two v (or p ...) g+s sk fk i)
    142      (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
    143     ((match-two v (not p) g+s (sk ...) fk i)
    144      (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
    145     ((match-two v (get! getter) (g s) (sk ...) fk i)
    146      (let ((getter (lambda () g))) (sk ... i)))
    147     ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
    148      (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
    149     ((match-two v (? pred . p) g+s sk fk i)
    150      (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
    151     ((match-two v (= proc p) . x)
    152      (let ((w (proc v))) (match-one w p . x)))
    153     ((match-two v (p ___ . r) g+s sk fk i)
    154      (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
    155     ((match-two v (p) g+s sk fk i)
    156      (if (and (pair? v) (null? (cdr v)))
    157          (let ((w (car v)))
    158            (match-one w p ((car v) (set-car! v)) sk fk i))
    159          fk))
    160     ((match-two v (p *** q) g+s sk fk i)
    161      (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
    162     ((match-two v (p *** . q) g+s sk fk i)
    163      (match-syntax-error "invalid use of ***" (p *** . q)))
    164     ((match-two v (p ..1) g+s sk fk i)
    165      (if (pair? v)
    166          (match-one v (p ___) g+s sk fk i)
    167          fk))
    168     ((match-two v ($ rec p ...) g+s sk fk i)
    169      (if ((syntax-symbol-append-? rec) v)
    170          (match-record-refs v 1 (p ...) g+s sk fk i)
    171          fk))
    172     ((match-two v (p . q) g+s sk fk i)
    173      (if (pair? v)
    174          (let ((w (car v)) (x (cdr v)))
    175            (match-one w p ((car v) (set-car! v))
    176                       (match-one x q ((cdr v) (set-cdr! v)) sk fk)
    177                       fk
    178                       i))
    179          fk))
    180     ((match-two v #(p ...) g+s . x)
    181      (match-vector v 0 () (p ...) . x))
    182     ((match-two v _ g+s (sk ...) fk i) (sk ... i))
    183     ;; Not a pair or vector or special literal, test to see if it's a
    184     ;; new symbol, in which case we just bind it, or if it's an
    185     ;; already bound symbol or some other literal, in which case we
    186     ;; compare it with EQUAL?.
    187     ((match-two v x g+s (sk ...) fk (id ...))
    188      (let-syntax
    189          ((new-sym?
    190            (syntax-rules (id ...)
    191              ((new-sym? x sk2 fk2) sk2)
    192              ((new-sym? y sk2 fk2) fk2))))
    193        (new-sym? random-sym-to-match
    194                  (let ((x v)) (sk ... (id ... x)))
    195                  (if (equal? v x) (sk ... (id ...)) fk))))
    196     ))
    197 
    198 ;; QUASIQUOTE patterns
    199 
    200 (define-syntax match-quasiquote
    201   (syntax-rules (unquote unquote-splicing quasiquote)
    202     ((_ v (unquote p) g+s sk fk i)
    203      (match-one v p g+s sk fk i))
    204     ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
    205      (if (pair? v)
    206        (match-one v
    207                   (p . tmp)
    208                   (match-quasiquote tmp rest g+s sk fk)
    209                   fk
    210                   i)
    211        fk))
    212     ((_ v (quasiquote p) g+s sk fk i . depth)
    213      (match-quasiquote v p g+s sk fk i #f . depth))
    214     ((_ v (unquote p) g+s sk fk i x . depth)
    215      (match-quasiquote v p g+s sk fk i . depth))
    216     ((_ v (unquote-splicing p) g+s sk fk i x . depth)
    217      (match-quasiquote v p g+s sk fk i . depth))
    218     ((_ v (p . q) g+s sk fk i . depth)
    219      (if (pair? v)
    220        (let ((w (car v)) (x (cdr v)))
    221          (match-quasiquote
    222           w p g+s
    223           (match-quasiquote-step x q g+s sk fk depth)
    224           fk i . depth))
    225        fk))
    226     ((_ v #(elt ...) g+s sk fk i . depth)
    227      (if (vector? v)
    228        (let ((ls (vector->list v)))
    229          (match-quasiquote ls (elt ...) g+s sk fk i . depth))
    230        fk))
    231     ((_ v x g+s sk fk i . depth)
    232      (match-one v 'x g+s sk fk i))))
    233 
    234 (define-syntax match-quasiquote-step
    235   (syntax-rules ()
    236     ((match-quasiquote-step x q g+s sk fk depth i)
    237      (match-quasiquote x q g+s sk fk i . depth))))
    238 
    239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    240 ;; Utilities
    241 
    242 ;; A CPS utility that takes two values and just expands into the
    243 ;; first.
    244 (define-syntax match-drop-ids
    245   (syntax-rules ()
    246     ((_ expr ids ...) expr)))
    247 
    248 (define-syntax match-tuck-ids
    249   (syntax-rules ()
    250     ((_ (letish args (expr ...)) ids ...)
    251      (letish args (expr ... ids ...)))))
    252 
    253 (define-syntax match-drop-first-arg
    254   (syntax-rules ()
    255     ((_ arg expr) expr)))
    256 
    257 ;; To expand an OR group we try each clause in succession, passing the
    258 ;; first that succeeds to the success continuation.  On failure for
    259 ;; any clause, we just try the next clause, finally resorting to the
    260 ;; failure continuation fk if all clauses fail.  The only trick is
    261 ;; that we want to unify the identifiers, so that the success
    262 ;; continuation can refer to a variable from any of the OR clauses.
    263 
    264 (define-syntax match-gen-or
    265   (syntax-rules ()
    266     ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
    267      (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
    268        (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
    269 
    270 (define-syntax match-gen-or-step
    271   (syntax-rules ()
    272     ((_ v () g+s sk fk . x)
    273      ;; no OR clauses, call the failure continuation
    274      fk)
    275     ((_ v (p) . x)
    276      ;; last (or only) OR clause, just expand normally
    277      (match-one v p . x))
    278     ((_ v (p . q) g+s sk fk i)
    279      ;; match one and try the remaining on failure
    280      (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
    281        (match-one v p g+s sk (fk2) i)))
    282     ))
    283 
    284 ;; We match a pattern (p ...) by matching the pattern p in a loop on
    285 ;; each element of the variable, accumulating the bound ids into lists.
    286 
    287 ;; Look at the body of the simple case - it's just a named let loop,
    288 ;; matching each element in turn to the same pattern.  The only trick
    289 ;; is that we want to keep track of the lists of each extracted id, so
    290 ;; when the loop recurses we cons the ids onto their respective list
    291 ;; variables, and on success we bind the ids (what the user input and
    292 ;; expects to see in the success body) to the reversed accumulated
    293 ;; list IDs.
    294 
    295 (define-syntax match-gen-ellipses
    296   (syntax-rules ()
    297     ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
    298      (match-check-identifier p
    299        ;; simplest case equivalent to (p ...), just bind the list
    300        (let ((p v))
    301          (if (list? p)
    302              (sk ... i)
    303              fk))
    304        ;; simple case, match all elements of the list
    305        (let loop ((ls v) (id-ls '()) ...)
    306          (cond
    307            ((null? ls)
    308             (let ((id (reverse id-ls)) ...) (sk ... i)))
    309            ((pair? ls)
    310             (let ((w (car ls)))
    311               (match-one w p ((car ls) (set-car! ls))
    312                          (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
    313                          fk i)))
    314            (else
    315             fk)))))
    316     ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
    317      ;; general case, trailing patterns to match, keep track of the
    318      ;; remaining list length so we don't need any backtracking
    319      (match-verify-no-ellipses
    320       r
    321       (let* ((tail-len (length 'r))
    322              (ls v)
    323              (len (and (list? ls) (length ls))))
    324         (if (or (not len) (< len tail-len))
    325             fk
    326             (let loop ((ls ls) (n len) (id-ls '()) ...)
    327               (cond
    328                 ((= n tail-len)
    329                  (let ((id (reverse id-ls)) ...)
    330                    (match-one ls r (#f #f) (sk ...) fk i)))
    331                 ((pair? ls)
    332                  (let ((w (car ls)))
    333                    (match-one w p ((car ls) (set-car! ls))
    334                               (match-drop-ids
    335                                (loop (cdr ls) (- n 1) (cons id id-ls) ...))
    336                               fk
    337                               i)))
    338                 (else
    339                  fk)))))))))
    340 
    341 ;; This is just a safety check.  Although unlike syntax-rules we allow
    342 ;; trailing patterns after an ellipses, we explicitly disable multiple
    343 ;; ellipses at the same level.  This is because in the general case
    344 ;; such patterns are exponential in the number of ellipses, and we
    345 ;; don't want to make it easy to construct very expensive operations
    346 ;; with simple looking patterns.  For example, it would be O(n^2) for
    347 ;; patterns like (a ... b ...) because we must consider every trailing
    348 ;; element for every possible break for the leading "a ...".
    349 
    350 (define-syntax match-verify-no-ellipses
    351   (syntax-rules ()
    352     ((_ (x . y) sk)
    353      (match-check-ellipse
    354       x
    355       (match-syntax-error
    356        "multiple ellipse patterns not allowed at same level")
    357       (match-verify-no-ellipses y sk)))
    358     ((_ () sk)
    359      sk)
    360     ((_ x sk)
    361      (match-syntax-error "dotted tail not allowed after ellipse" x))))
    362 
    363 ;; Matching a tree search pattern is only slightly more complicated.
    364 ;; Here we allow patterns of the form
    365 ;;
    366 ;;     (x *** y)
    367 ;;
    368 ;; to represent the pattern y located somewhere in a tree where the
    369 ;; path from the current object to y can be seen as a list of the form
    370 ;; (X ...).  Y can immediately match the current object in which case
    371 ;; the path is the empty list.  In a sense it's a 2-dimensional
    372 ;; version of the ... pattern.
    373 ;;
    374 ;; As a common case the pattern (_ *** y) can be used to search for Y
    375 ;; anywhere in a tree, regardless of the path used.
    376 ;;
    377 ;; To implement the search, we use two recursive procedures.  TRY
    378 ;; attempts to match Y once, and on success it calls the normal SK on
    379 ;; the accumulated list ids as in MATCH-GEN-ELLIPSES.  On failure, we
    380 ;; call NEXT which first checks if the current value is a list
    381 ;; beginning with X, then calls TRY on each remaining element of the
    382 ;; list.  Since TRY will recursively call NEXT again on failure, this
    383 ;; effects a full depth-first search.
    384 ;;
    385 ;; The failure continuation throughout is a jump to the next step in
    386 ;; the tree search, initialized with the original failure continuation
    387 ;; FK.
    388 
    389 (define-syntax match-gen-search
    390   (syntax-rules ()
    391     ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
    392      (letrec ((try (lambda (w fail id-ls ...)
    393                      (match-one w q g+s
    394                                 (match-tuck-ids
    395                                  (let ((id (reverse id-ls)) ...)
    396                                    sk))
    397                                 (next w fail id-ls ...) i)))
    398               (next (lambda (w fail id-ls ...)
    399                       (if (not (pair? w))
    400                           (fail)
    401                           (let ((u (car w)))
    402                             (match-one
    403                              u p ((car w) (set-car! w))
    404                              (match-drop-ids
    405                               ;; accumulate the head variables from
    406                               ;; the p pattern, and loop over the tail
    407                               (let ((id-ls (cons id id-ls)) ...)
    408                                 (let lp ((ls (cdr w)))
    409                                   (if (pair? ls)
    410                                       (try (car ls)
    411                                            (lambda () (lp (cdr ls)))
    412                                            id-ls ...)
    413                                       (fail)))))
    414                              (fail) i))))))
    415        ;; the initial id-ls binding here is a dummy to get the right
    416        ;; number of '()s
    417        (let ((id-ls '()) ...)
    418          (try v (lambda () fk) id-ls ...))))))
    419 
    420 ;; Vector patterns are just more of the same, with the slight
    421 ;; exception that we pass around the current vector index being
    422 ;; matched.
    423 
    424 (define-syntax match-vector
    425   (syntax-rules (___)
    426     ((_ v n pats (p q) . x)
    427      (match-check-ellipse q
    428                           (match-gen-vector-ellipses v n pats p . x)
    429                           (match-vector-two v n pats (p q) . x)))
    430     ((_ v n pats (p ___) sk fk i)
    431      (match-gen-vector-ellipses v n pats p sk fk i))
    432     ((_ . x)
    433      (match-vector-two . x))))
    434 
    435 ;; Check the exact vector length, then check each element in turn.
    436 
    437 (define-syntax match-vector-two
    438   (syntax-rules ()
    439     ((_ v n ((pat index) ...) () sk fk i)
    440      (if (vector? v)
    441          (let ((len (vector-length v)))
    442            (if (= len n)
    443                (match-vector-step v ((pat index) ...) sk fk i)
    444                fk))
    445          fk))
    446     ((_ v n (pats ...) (p . q) . x)
    447      (match-vector v (+ n 1) (pats ... (p n)) q . x))))
    448 
    449 (define-syntax match-vector-step
    450   (syntax-rules ()
    451     ((_ v () (sk ...) fk i) (sk ... i))
    452     ((_ v ((pat index) . rest) sk fk i)
    453      (let ((w (vector-ref v index)))
    454        (match-one w pat ((vector-ref v index) (vector-set! v index))
    455                   (match-vector-step v rest sk fk)
    456                   fk i)))))
    457 
    458 ;; With a vector ellipse pattern we first check to see if the vector
    459 ;; length is at least the required length.
    460 
    461 (define-syntax match-gen-vector-ellipses
    462   (syntax-rules ()
    463     ((_ v n ((pat index) ...) p sk fk i)
    464      (if (vector? v)
    465        (let ((len (vector-length v)))
    466          (if (>= len n)
    467            (match-vector-step v ((pat index) ...)
    468                               (match-vector-tail v p n len sk fk)
    469                               fk i)
    470            fk))
    471        fk))))
    472 
    473 (define-syntax match-vector-tail
    474   (syntax-rules ()
    475     ((_ v p n len sk fk i)
    476      (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
    477 
    478 (define-syntax match-vector-tail-two
    479   (syntax-rules ()
    480     ((_ v p n len (sk ...) fk i ((id id-ls) ...))
    481      (let loop ((j n) (id-ls '()) ...)
    482        (if (>= j len)
    483          (let ((id (reverse id-ls)) ...) (sk ... i))
    484          (let ((w (vector-ref v j)))
    485            (match-one w p ((vector-ref v j) (vector-set! v j))
    486                       (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
    487                       fk i)))))))
    488 
    489 ;; Chicken-specific.
    490 
    491 (cond-expand
    492  (chicken
    493   (define-syntax match-record-refs
    494     (syntax-rules ()
    495       ((_ v n (p . q) g+s sk fk i)
    496        (let ((w (##sys#block-ref v n)))
    497          (match-one w p ((##sys#block-ref v n) (##sys#block-set! v n))
    498                     (match-record-refs v (+ n 1) q g+s sk fk)
    499                     fk i)))
    500       ((_ v n () g+s (sk ...) fk i)
    501        (sk ... i)))))
    502  (else
    503   ))
    504 
    505 ;; Extract all identifiers in a pattern.  A little more complicated
    506 ;; than just looking for symbols, we need to ignore special keywords
    507 ;; and non-pattern forms (such as the predicate expression in ?
    508 ;; patterns), and also ignore previously bound identifiers.
    509 ;;
    510 ;; Calls the continuation with all new vars as a list of the form
    511 ;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
    512 ;; pair with the original variable (e.g. it's used in the ellipse
    513 ;; generation for list variables).
    514 ;;
    515 ;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
    516 
    517 (define-syntax match-extract-vars
    518   (syntax-rules (_ ___ ..1 *** ? $ = quote quasiquote and or not get! set!)
    519     ((match-extract-vars (? pred . p) . x)
    520      (match-extract-vars p . x))
    521     ((match-extract-vars ($ rec . p) . x)
    522      (match-extract-vars p . x))
    523     ((match-extract-vars (= proc p) . x)
    524      (match-extract-vars p . x))
    525     ((match-extract-vars (quote x) (k ...) i v)
    526      (k ... v))
    527     ((match-extract-vars (quasiquote x) k i v)
    528      (match-extract-quasiquote-vars x k i v (#t)))
    529     ((match-extract-vars (and . p) . x)
    530      (match-extract-vars p . x))
    531     ((match-extract-vars (or . p) . x)
    532      (match-extract-vars p . x))
    533     ((match-extract-vars (not . p) . x)
    534      (match-extract-vars p . x))
    535     ;; A non-keyword pair, expand the CAR with a continuation to
    536     ;; expand the CDR.
    537     ((match-extract-vars (p q . r) k i v)
    538      (match-check-ellipse
    539       q
    540       (match-extract-vars (p . r) k i v)
    541       (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
    542     ((match-extract-vars (p . q) k i v)
    543      (match-extract-vars p (match-extract-vars-step q k i v) i ()))
    544     ((match-extract-vars #(p ...) . x)
    545      (match-extract-vars (p ...) . x))
    546     ((match-extract-vars _ (k ...) i v)    (k ... v))
    547     ((match-extract-vars ___ (k ...) i v)  (k ... v))
    548     ((match-extract-vars *** (k ...) i v)  (k ... v))
    549     ((match-extract-vars ..1 (k ...) i v)  (k ... v))
    550     ;; This is the main part, the only place where we might add a new
    551     ;; var if it's an unbound symbol.
    552     ((match-extract-vars p (k ...) (i ...) v)
    553      (let-syntax
    554          ((new-sym?
    555            (syntax-rules (i ...)
    556              ((new-sym? p sk fk) sk)
    557              ((new-sym? any sk fk) fk))))
    558        (new-sym? random-sym-to-match
    559                  (k ... ((p p-ls) . v))
    560                  (k ... v))))
    561     ))
    562 
    563 ;; Stepper used in the above so it can expand the CAR and CDR
    564 ;; separately.
    565 
    566 (define-syntax match-extract-vars-step
    567   (syntax-rules ()
    568     ((_ p k i v ((v2 v2-ls) ...))
    569      (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
    570     ))
    571 
    572 (define-syntax match-extract-quasiquote-vars
    573   (syntax-rules (quasiquote unquote unquote-splicing)
    574     ((match-extract-quasiquote-vars (quasiquote x) k i v d)
    575      (match-extract-quasiquote-vars x k i v (#t . d)))
    576     ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
    577      (match-extract-quasiquote-vars (unquote x) k i v d))
    578     ((match-extract-quasiquote-vars (unquote x) k i v (#t))
    579      (match-extract-vars x k i v))
    580     ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
    581      (match-extract-quasiquote-vars x k i v d))
    582     ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
    583      (match-extract-quasiquote-vars
    584       x
    585       (match-extract-quasiquote-vars-step y k i v d) i ()))
    586     ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
    587      (match-extract-quasiquote-vars (x ...) k i v d))
    588     ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
    589      (k ... v))
    590     ))
    591 
    592 (define-syntax match-extract-quasiquote-vars-step
    593   (syntax-rules ()
    594     ((_ x k i v d ((v2 v2-ls) ...))
    595      (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
    596     ))
    597 
    598 
    599 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    600 ;; Gimme some sugar baby.
    601 
    602 (define-syntax match-lambda
    603   (syntax-rules ()
    604     ((_ clause ...) (lambda (expr) (match expr clause ...)))))
    605 
    606 (define-syntax match-lambda*
    607   (syntax-rules ()
    608     ((_ clause ...) (lambda expr (match expr clause ...)))))
    609 
    610 (define-syntax match-let
    611   (syntax-rules ()
    612     ((_ (vars ...) . body)
    613      (match-let/helper let () () (vars ...) . body))
    614     ((_ loop . rest)
    615      (match-named-let loop () . rest))))
    616 
    617 (define-syntax match-letrec
    618   (syntax-rules ()
    619     ((_ vars . body) (match-let/helper letrec () () vars . body))))
    620 
    621 (define-syntax match-let/helper
    622   (syntax-rules ()
    623     ((_ let ((var expr) ...) () () . body)
    624      (let ((var expr) ...) . body))
    625     ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
    626      (let ((var expr) ...)
    627        (match-let* ((pat tmp) ...)
    628          . body)))
    629     ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
    630      (match-let/helper
    631       let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
    632     ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
    633      (match-let/helper
    634       let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
    635     ((_ let (v ...) (p ...) ((a expr) . rest) . body)
    636      (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
    637 
    638 (define-syntax match-named-let
    639   (syntax-rules ()
    640     ((_ loop ((pat expr var) ...) () . body)
    641      (let loop ((var expr) ...)
    642        (match-let ((pat var) ...)
    643          . body)))
    644     ((_ loop (v ...) ((pat expr) . rest) . body)
    645      (match-named-let loop (v ... (pat expr tmp)) rest . body))))
    646 
    647 (define-syntax match-let*
    648   (syntax-rules ()
    649     ((_ () . body)
    650      (let () . body))
    651     ((_ ((pat expr) . rest) . body)
    652      (match expr (pat (match-let* rest . body))))))
    653 
    654 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    655 ;; Not quite portable bits.
    656 
    657 ;; Matching ellipses `...' is tricky.  A strict interpretation of R5RS
    658 ;; would suggest that `...' in the literals list would treat it as a
    659 ;; literal in pattern, however no SYNTAX-RULES implementation I'm
    660 ;; aware of currently supports this.  SRFI-46 support would makes this
    661 ;; easy, but SRFI-46 also is widely unsupported.
    662 
    663 ;; In the meantime we conditionally implement this in whatever
    664 ;; low-level macro system is available, defaulting to an
    665 ;; implementation which doesn't support `...' and requires the user to
    666 ;; match with `___'.
    667 
    668 (cond-expand
    669  (syntax-case
    670    (define-syntax (match-check-ellipse stx)
    671      (syntax-case stx ()
    672        ((_ q sk fk)
    673         (if (and (identifier? (syntax q))
    674                  (literal-identifier=? (syntax q) (syntax (... ...))))
    675             (syntax sk)
    676             (syntax fk))))))
    677  (syntactic-closures
    678   (define-syntax match-check-ellipse
    679     (sc-macro-transformer
    680      (lambda (form usage-environment)
    681        (capture-syntactic-environment
    682         (lambda (closing-environment)
    683           (make-syntactic-closure usage-environment '()
    684             (if (and (identifier? (cadr form))
    685                      (identifier=? usage-environment (cadr form)
    686                                    closing-environment '...))
    687                 (caddr form)
    688                 (cadddr form)))))))))
    689  (else
    690   ;; This is a little more complicated, and introduces a new let-syntax,
    691   ;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
    692   ;; originally came up with the idea.
    693   (define-syntax match-check-ellipse
    694     (syntax-rules ()
    695       ;; these two aren't necessary but provide fast-case failures
    696       ((match-check-ellipse (a . b) success-k failure-k) failure-k)
    697       ((match-check-ellipse #(a ...) success-k failure-k) failure-k)
    698       ;; matching an atom
    699       ((match-check-ellipse id success-k failure-k)
    700        (let-syntax ((ellipse? (syntax-rules ()
    701                                 ;; iff `id' is `...' here then this will
    702                                 ;; match a list of any length
    703                                 ((ellipse? (foo id) sk fk) sk)
    704                                 ((ellipse? other sk fk) fk))))
    705          ;; this list of three elements will only many the (foo id) list
    706          ;; above if `id' is `...'
    707          (ellipse? (a b c) success-k failure-k)))))))
    708 
    709 
    710 ;; This is portable but can be more efficient with non-portable
    711 ;; extensions.
    712 
    713 (cond-expand
    714  (syntax-case
    715   (define-syntax (match-check-identifier stx)
    716     (syntax-case stx ()
    717       ((_ x sk fk)
    718        (if (identifier? (syntax q))
    719            (syntax sk)
    720            (syntax fk))))))
    721  (syntactic-closures
    722   (define-syntax match-check-identifier
    723     (sc-macro-transformer
    724      (lambda (form usage-environment)
    725        (capture-syntactic-environment
    726         (lambda (closing-environment)
    727           (make-syntactic-closure usage-environment '()
    728             (if (identifier? (cadr form))
    729                 (caddr form)
    730                 (cadddr form)))))))))
    731  (else
    732   (define-syntax match-check-identifier
    733     (syntax-rules ()
    734       ;; fast-case failures, lists and vectors are not identifiers
    735       ((_ (x . y) success-k failure-k) failure-k)
    736       ((_ #(x ...) success-k failure-k) failure-k)
    737       ;; x is an atom
    738       ((_ x success-k failure-k)
    739        (let-syntax
    740            ((sym?
    741              (syntax-rules ()
    742                ;; if the symbol `abracadabra' matches x, then x is a
    743                ;; symbol
    744                ((sym? x sk fk) sk)
    745                ;; otherwise x is a non-symbol datum
    746                ((sym? y sk fk) fk))))
    747          (sym? abracadabra success-k failure-k)))))))
    748 
    749 ;; Annoying unhygienic record matching.  Record patterns look like
    750 ;;   ($ record fields...)
    751 ;; where the record name simply assumes that the same name suffixed
    752 ;; with a "?" is the correct predicate.
    753 
    754 ;; Why not just require the "?" to begin with?!
    755 
    756 (cond-expand
    757  (chicken
    758   (define-syntax syntax-symbol-append-?
    759     (lambda (x r c)
    760       (string->symbol (string-append (symbol->string (cadr x)) "?")))))
    761  (syntax-case
    762   (define-syntax (syntax-symbol-append-? stx)
    763     (syntax-case stx ()
    764       ((s x)
    765        (datum->syntax-object
    766         (syntax s)
    767         (string->symbol
    768          (string-append
    769           (symbol->string (syntax-object->datum (syntax x)))
    770           "?")))))))
    771  (syntactic-closures
    772   (define-syntax syntax-symbol-append-?
    773     (sc-macro-transformer
    774      (lambda (x e)
    775        (string->symbol (string-append (symbol->string (cadr x)) "?"))))))
    776  (else
    777   (define-syntax syntax-symbol-append-?
    778     (syntax-rules ()
    779       ((_ sym)
    780        (eval (string->symbol (string-append (symbol->string sym) "?"))))))))
    781 
     29  (include "match.scm")
    78230)
  • release/4/matchable/trunk/matchable.setup

    r28001 r33291  
    44(install-extension 'matchable
    55 '("matchable.so" "matchable.import.so")
    6  '((version "3.3")))
     6 '((version "3.4")))
Note: See TracChangeset for help on using the changeset viewer.