Changeset 5888 in project


Ignore:
Timestamp:
09/03/07 18:15:26 (12 years ago)
Author:
Alex Shinn
Message:

Fixing quasiquote patterns.

Location:
matchable
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • matchable/matchable-test.scm

    r4622 r5888  
    214214            '((a b) (1 2) (c . 3) (d . 4) (e . 5)))
    215215
     216(test-equal "Riastradh quasiquote"
     217            (match '(1 2 3) (`(1 ,b ,c) (list b c)))
     218            '(2 3))
     219
    216220(test-end "match")
    217221
  • matchable/matchable.scm

    r4622 r5888  
    1616;; hit.
    1717
     18;; 2007/09/04 - fixing quasiquote patterns
     19;; 2007/07/21 - allowing ellipse patterns in non-final list positions
     20;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
     21;;              (thanks to Taylor Campbell)
     22;; 2007/04/08 - clean up, commenting
     23;; 2006/12/24 - bugfixes
     24;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
     25
    1826;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1927
     
    2129;; thus always results in a compile-time error.
    2230
    23 (define-syntax *match-syntax-error
     31(define-syntax match-syntax-error
    2432  (syntax-rules ()
    2533    ((_)
    26      (syntax-error 'match "invalid *match-syntax-error usage"))))
     34     (match-syntax-error "invalid match-syntax-error usage"))))
    2735
    2836;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    3543  (syntax-rules ()
    3644    ((match)
    37      (*match-syntax-error "missing match expression"))
     45     (match-syntax-error "missing match expression"))
    3846    ((match atom)
    39      (*match-syntax-error "missing match clause"))
     47     (match-syntax-error "missing match clause"))
    4048    ((match (app ...) (pat . body) ...)
    4149     (let ((v (app ...)))
     
    157165    ((match-two v x g s (sk ...) fk (id ...))
    158166     (let-syntax
    159          ((sym?
     167         ((new-sym?
    160168           (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
     169             ((new-sym? x sk2 fk2) sk2)
     170             ((new-sym? y sk2 fk2) fk2))))
     171       (new-sym? abracadabra  ; thanks Oleg
    165172             (let ((x v)) (sk ... (id ... x)))
    166173             (if (equal? v x) (sk ... (id ...)) fk))))
     
    183190    ((_ v (quasiquote p) g s sk fk i . depth)
    184191     (match-quasiquote v p g s sk fk i #f . depth))
    185     ((_ v (unquote p) g s sk fk i  x . depth)
     192    ((_ v (unquote p) g s sk fk i x . depth)
    186193     (match-quasiquote v p g s sk fk i . depth))
    187194    ((_ v (unquote-splicing p) g s sk fk i x . depth)
     
    192199         (match-quasiquote
    193200          w p g s
    194           (match-quasiquote x q g s sk fk i . depth)
     201          (match-quasiquote-step x q g s sk fk depth)
    195202          fk i . depth))
    196203       fk))
     
    202209    ((_ v x g s sk fk i . depth)
    203210     (match-one v 'x g s sk fk i))))
     211
     212(define-syntax match-quasiquote-step
     213  (syntax-rules ()
     214    ((match-quasiquote-step x q g s sk fk depth i)
     215     (match-quasiquote x q g s sk fk i . depth))
     216    ))
    204217
    205218;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    291304     (match-check-ellipse
    292305      x
    293       (*match-syntax-error
     306      (match-syntax-error
    294307       "multiple ellipse patterns not allowed at same level")
    295308      (match-verify-no-ellipses y sk)))
     
    398411    ((match-extract-vars (= proc p) k i v)
    399412     (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))
     413    ((match-extract-vars (quote x) (k ...) i v)
     414     (k ... v))
     415    ((match-extract-vars (quasiquote x) k i v)
     416     (match-extract-quasiquote-vars x k i v (#t)))
    402417    ((match-extract-vars (and . p) k i v)
    403418     (match-extract-vars p k i v))
     
    405420     (match-extract-vars p k i v))
    406421    ((match-extract-vars (not . p) k i v)
    407      (match-extract-vars p k i v))
    408     ((match-extract-vars (p) k i v)
    409422     (match-extract-vars p k i v))
    410423    ;; A non-keyword pair, expand the CAR with a continuation to
     
    425438    ((match-extract-vars p (k ...) (i ...) v)
    426439     (let-syntax
    427          ((sym?
     440         ((new-sym?
    428441           (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))))
     442             ((new-sym? p sk fk) sk)
     443             ((new-sym? x sk fk) fk))))
     444       (new-sym? random-sym-to-match
     445                 (k ... ((p p-ls) . v))
     446                 (k ... v))))
    433447    ))
    434448
     
    439453  (syntax-rules ()
    440454    ((_ p k i v ((v2 v2-ls) ...))
    441      (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))))
     455     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
     456    ))
     457
     458(define-syntax match-extract-quasiquote-vars
     459  (syntax-rules (quasiquote unquote unquote-splicing)
     460    ((match-extract-quasiquote-vars (quasiquote x) k i v d)
     461     (match-extract-quasiquote-vars x k i v (#t . d)))
     462    ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
     463     (match-extract-quasiquote-vars (unquote x) k i v d))
     464    ((match-extract-quasiquote-vars (unquote x) k i v (#t))
     465     (match-extract-vars x k i v))
     466    ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
     467     (match-extract-quasiquote-vars x k i v d))
     468    ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
     469     (match-extract-quasiquote-vars
     470      x
     471      (match-extract-quasiquote-vars-step y k i v d) i ()))
     472    ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
     473     (match-extract-quasiquote-vars (x ...) k i v d))
     474    ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
     475     (k ... v))
     476    ))
     477
     478(define-syntax match-extract-quasiquote-vars-step
     479  (syntax-rules ()
     480    ((_ x k i v d ((v2 v2-ls) ...))
     481     (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
     482    ))
     483
    442484
    443485;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    496538    ((_ ((pat expr) . rest) . body)
    497539     (match expr (pat (match-let* rest . body))))))
     540
    498541
    499542;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  • matchable/matchable.setup

    r4622 r5888  
    11(install-extension 'matchable
    22 '("matchable.scm")
    3  '((version 2.0)
     3 '((version 2.1)
    44   (syntax)))
Note: See TracChangeset for help on using the changeset viewer.