214 lines
6.6 KiB
Scheme
214 lines
6.6 KiB
Scheme
#lang scheme/base
|
|
|
|
(require syntax/boundmap
|
|
scheme/contract
|
|
(for-syntax scheme/base))
|
|
|
|
(provide (except-out (all-defined-out)
|
|
struct-key-ht
|
|
get-key
|
|
(struct-out Row)))
|
|
|
|
(define orig-stx (make-parameter #f))
|
|
|
|
(define-struct Pat () #:transparent)
|
|
;; v is an identifier
|
|
(define-struct (Var Pat) (v)
|
|
#:transparent
|
|
#:property
|
|
prop:custom-write (lambda (v p w?)
|
|
(fprintf p "(Var ~a)" (syntax-e (Var-v v)))))
|
|
(define-struct (Dummy Var) ()
|
|
#:transparent
|
|
#:property
|
|
prop:custom-write (lambda (v p w?) (fprintf p "_")))
|
|
|
|
;; constructor patterns
|
|
(define-struct (CPat Pat) () #:transparent)
|
|
|
|
;; start is what index to start at
|
|
(define-struct (Vector CPat) (ps) #:transparent)
|
|
|
|
(define-struct (Pair CPat) (a d) #:transparent)
|
|
(define-struct (MPair CPat) (a d) #:transparent)
|
|
|
|
(define-struct (Box CPat) (p) #:transparent)
|
|
|
|
;; p is a pattern to match against the literal
|
|
(define-struct (Atom CPat) (p) #:transparent)
|
|
(define-struct (String Atom) () #:transparent)
|
|
(define-struct (Number Atom) () #:transparent)
|
|
(define-struct (Symbol Atom) () #:transparent)
|
|
(define-struct (Keyword Atom) () #:transparent)
|
|
(define-struct (Char Atom) () #:transparent)
|
|
(define-struct (Bytes Atom) () #:transparent)
|
|
(define-struct (Regexp Atom) () #:transparent)
|
|
(define-struct (Boolean Atom) () #:transparent)
|
|
(define-struct (Null Atom) () #:transparent)
|
|
|
|
;; expr is an expression
|
|
;; p is a pattern
|
|
(define-struct (App Pat) (expr p) #:transparent)
|
|
|
|
;; pred is an expression
|
|
(define-struct (Pred Pat) (pred) #:transparent)
|
|
|
|
;; pred is an identifier
|
|
;; super is an identifier, or #f
|
|
;; accessors is a listof identifiers (NB in reverse order from the struct info)
|
|
;; ps is a listof patterns
|
|
(define-struct (Struct CPat) (id pred super accessors ps) #:transparent)
|
|
|
|
;; both fields are lists of pats
|
|
(define-struct (HashTable CPat) (key-pats val-pats) #:transparent)
|
|
|
|
;; ps are patterns
|
|
(define-struct (Or Pat) (ps) #:transparent)
|
|
(define-struct (And Pat) (ps) #:transparent)
|
|
;; p is a pattern
|
|
(define-struct (Not Pat) (p) #:transparent)
|
|
|
|
;; headss : listof listof pattern
|
|
;; mins : listof option number
|
|
;; maxs : listof option number
|
|
;; onces? : listof boolean -- is this pattern being bound only once (take the
|
|
;; car of the variables)
|
|
;; tail : pattern
|
|
;; mutable? : is this for mutable lists?
|
|
(define-struct (GSeq Pat) (headss mins maxs onces? tail mutable?) #:transparent)
|
|
|
|
;; match with equal?
|
|
;; v is a quotable scheme value
|
|
(define-struct (Exact Pat) (v) #:transparent)
|
|
|
|
;; pats is a Listof Pat
|
|
;; rhs is an expression
|
|
;; unmatch is an identifier
|
|
;; vars-seen is a listof identifiers
|
|
(define-struct Row (pats rhs unmatch vars-seen) #:transparent
|
|
#:property
|
|
prop:custom-write
|
|
(lambda (v p w?) (fprintf p "(Row ~a <expr>)" (Row-pats v))))
|
|
|
|
(define struct-key-ht (make-free-identifier-mapping))
|
|
(define (get-key id)
|
|
(free-identifier-mapping-get
|
|
struct-key-ht id
|
|
(lambda ()
|
|
(let ([k (box-immutable (syntax-e id))])
|
|
(free-identifier-mapping-put! struct-key-ht id k)
|
|
k))))
|
|
|
|
;; pat-key returns either an immutable box, or a symbol., or #f
|
|
;; the result is a box iff the argument was a struct pattern
|
|
;; (eq? (pat-key p) (pat-key q)) if p and q match the same constructor
|
|
;; the result is #f if p is not a constructor pattern
|
|
(define (pat-key p)
|
|
(cond [(Struct? p) (get-key (Struct-id p))]
|
|
[(Box? p) 'box]
|
|
[(Vector? p) 'vector]
|
|
[(Pair? p) 'pair]
|
|
[(MPair? p) 'mpair]
|
|
[(String? p) 'string]
|
|
[(Symbol? p) 'symbol]
|
|
[(Number? p) 'number]
|
|
[(Bytes? p) 'bytes]
|
|
[(Char? p) 'char]
|
|
[(Regexp? p) 'regexp]
|
|
[(Keyword? p) 'keyword]
|
|
[(Boolean? p) 'boolean]
|
|
[(Null? p) 'null]
|
|
[else #f]))
|
|
|
|
;; (require mzlib/trace)
|
|
;; (trace pat-key)
|
|
|
|
;; Row-first-pat : Row -> Pat
|
|
;; Row must not have empty list of pats
|
|
(define (Row-first-pat r)
|
|
(car (Row-pats r)))
|
|
|
|
(define (Row-split-pats r)
|
|
(define p (Row-pats r))
|
|
(values (car p) (cdr p)))
|
|
|
|
;; merge : (liftof (listof id)) -> (listof id)
|
|
;; merges lists of identifiers, removing module-identifier=? duplicates
|
|
(define (merge l)
|
|
(cond [(null? l) null]
|
|
[(null? (cdr l)) (car l)]
|
|
[else (let ([m (make-module-identifier-mapping)])
|
|
(for* ([ids l] [id ids])
|
|
(module-identifier-mapping-put! m id #t))
|
|
(module-identifier-mapping-map m (lambda (k v) k)))]))
|
|
;; bound-vars : Pat -> listof identifiers
|
|
(define (bound-vars p)
|
|
(cond
|
|
[(Dummy? p) null]
|
|
[(Pred? p) null]
|
|
[(Var? p)
|
|
(let ([v (Var-v p)])
|
|
(list (free-identifier-mapping-get (current-renaming) v (lambda () v))))]
|
|
[(Or? p)
|
|
(bound-vars (car (Or-ps p)))]
|
|
[(Box? p)
|
|
(bound-vars (Box-p p))]
|
|
[(Atom? p) null]
|
|
[(Pair? p)
|
|
(merge (list (bound-vars (Pair-a p)) (bound-vars (Pair-d p))))]
|
|
[(MPair? p)
|
|
(merge (list (bound-vars (MPair-a p)) (bound-vars (MPair-d p))))]
|
|
[(GSeq? p)
|
|
(merge (cons (bound-vars (GSeq-tail p))
|
|
(for/list ([pats (GSeq-headss p)])
|
|
(merge (for/list ([pat pats])
|
|
(bound-vars pat))))))]
|
|
[(Vector? p)
|
|
(merge (map bound-vars (Vector-ps p)))]
|
|
[(Struct? p)
|
|
(merge (map bound-vars (Struct-ps p)))]
|
|
[(App? p)
|
|
(bound-vars (App-p p))]
|
|
[(Not? p) null]
|
|
[(And? p)
|
|
(merge (map bound-vars (And-ps p)))]
|
|
[(Exact? p) null]
|
|
[else (error 'match "bad pattern: ~a" p)]))
|
|
|
|
(define match-...-nesting (make-parameter 0))
|
|
|
|
(define current-renaming (make-parameter (make-free-identifier-mapping)))
|
|
|
|
(define (copy-mapping ht)
|
|
(define new-ht (make-free-identifier-mapping))
|
|
(free-identifier-mapping-for-each
|
|
ht (lambda (k v) (free-identifier-mapping-put! new-ht k v)))
|
|
new-ht)
|
|
|
|
#|
|
|
;; EXAMPLES
|
|
|
|
(define p-x (make-Var #'x))
|
|
(define p-y (make-Var #'y))
|
|
(define p-d (make-Dummy #'_))
|
|
|
|
(define p-cons (make-Pair p-x p-y))
|
|
(define p-vec (make-Vector (list p-x p-y p-d)))
|
|
|
|
(define r1 (make-Row (list p-x) #'#f #f null))
|
|
(define r2 (make-Row (list p-y) #'#f #f null))
|
|
(define r3 (make-Row (list p-cons) #'#f #f null))
|
|
(define r4 (make-Row (list p-vec p-d) #'#f #f null))
|
|
|#
|
|
|
|
(provide/contract (struct Row ([pats (listof Pat?)]
|
|
[rhs syntax?]
|
|
[unmatch (or/c identifier? false/c)]
|
|
[vars-seen (listof (cons/c identifier?
|
|
identifier?))])))
|
|
|
|
(define-struct match-expander (match-xform legacy-xform macro-xform certifier)
|
|
#:property prop:procedure (struct-field-index macro-xform))
|
|
|
|
(provide (struct-out match-expander))
|