1001 lines
53 KiB
Scheme
1001 lines
53 KiB
Scheme
;;----------------------------------------------------------------------
|
|
;; pattern-matching utilities
|
|
;; based on Shriram's pattern matcher for Zodiac
|
|
|
|
(module sc '#%kernel
|
|
(#%require "stx.ss" "small-scheme.ss"
|
|
(for-template (only '#%kernel set!)
|
|
"ellipses.ss"))
|
|
|
|
;; Checks whether s is "..."
|
|
(-define (...? s)
|
|
(if (symbol? (syntax-e s))
|
|
(free-identifier=? s (quote-syntax ...))
|
|
#f))
|
|
|
|
(-define (wildcard? p)
|
|
(free-identifier=? p (quote-syntax _)))
|
|
|
|
;; memq on a list of identifiers, and
|
|
;; nested identifiers
|
|
(-define (stx-memq ssym l)
|
|
(ormap (lambda (p)
|
|
(and (syntax? p)
|
|
(bound-identifier=? ssym p)))
|
|
l))
|
|
|
|
;; memq on a list of identifiers and
|
|
;; nested identifiers, returns a position
|
|
(-define (stx-memq-pos ssym l)
|
|
(let loop ([p 0][l l])
|
|
(cond
|
|
[(null? l) #f]
|
|
[(and (syntax? (car l))
|
|
(bound-identifier=? ssym (car l)))
|
|
p]
|
|
[else (loop (add1 p) (cdr l))])))
|
|
|
|
;; Like stx-memq-pos, but goes into nestings to
|
|
;; find identifiers.
|
|
(-define (stx-memq*-pos ssym l)
|
|
(let loop ([p 0][l l])
|
|
(cond
|
|
[(null? l) #f]
|
|
[(bound-identifier=? ssym
|
|
(let loop ([i (car l)])
|
|
(if (syntax? i)
|
|
i
|
|
(loop (car i)))))
|
|
p]
|
|
[else (loop (add1 p) (cdr l))])))
|
|
|
|
;; For error reporting:
|
|
(-define (pick-specificity e de)
|
|
(if (eq? e de)
|
|
(list e)
|
|
(list e de)))
|
|
|
|
;;----------------------------------------------------------------------
|
|
;; Input matcher
|
|
|
|
;; Takes syntax pattern and a keyword list and produces a
|
|
;; matcher. A matcher is a function that takes a syntax input
|
|
;; and produces a pattern-variable environment or #f.
|
|
;;
|
|
;; If `just-vars?' is #t, produces the variables instead of a matcher.
|
|
;; Each variable is nested in the list corresponding to its ellipsis depth
|
|
;; in the pattern. We call this the "environment prototype". For reporting
|
|
;; left-to-right errors, we assume that the function will be called with
|
|
;; `just-vars?' as #t first, to catch errors.
|
|
;;
|
|
;; In the pattern-variable environment produced by a matcher,
|
|
;; a variable under a single ellipsis has a list of matches,
|
|
;; a variable under two ellipses has a list of list of matches, etc.
|
|
;; The top-level environment is a list* --- i.e., a list, except that the last
|
|
;; element is in the cdr of the cons cell for the next-to-last element.
|
|
;;
|
|
;; An environment does not contain any indication of how far a
|
|
;; variable is nested. Uses of the variable should be checked separately
|
|
;; using an environment prototype. Furthermore, the environment
|
|
;; does not contain the pattern variables as "keys", since the positions
|
|
;; can also be determined by the prototype.
|
|
;;
|
|
(-define (make-match&env/extract-vars who top p k just-vars? phase-param? interp-box)
|
|
;; The m&e function returns three values. If just-vars? is true,
|
|
;; only the first result is used, and it is the variable list.
|
|
;; Otherwise, the first result is the code assuming an input bound to `e'.
|
|
;; The second result is #t if a variable was used, so that the code
|
|
;; produces an environment rather than just a boolean.
|
|
;; The last result is #t only when id-is-rest? was #t, and it indicates
|
|
;; that the code refers to cap to get context for datum->syntax.
|
|
(-define (m&e p local-top use-ellipses? last? id-is-rest?)
|
|
(cond
|
|
[(and use-ellipses? (ellipsis? p))
|
|
(if (stx-null? (stx-cdr (stx-cdr p)))
|
|
;; Simple case: ellipses at the end
|
|
(let* ([p-head (stx-car p)]
|
|
[nestings (get-ellipsis-nestings p-head k)])
|
|
(let-values ([(match-head mh-did-var? <false>) (m&e p-head p-head #t #f #f)])
|
|
(if just-vars?
|
|
(values (map list nestings) #f #f)
|
|
(let ([nest-vars (flatten-nestings nestings (lambda (x) #t))])
|
|
(values
|
|
(if interp-box
|
|
(vector 'ellipses
|
|
match-head
|
|
(length nest-vars)
|
|
last?)
|
|
`(lambda (e)
|
|
(if (stx-list? e)
|
|
,(let ([b (app-e match-head)])
|
|
(if (equal? b '(list e))
|
|
(if last?
|
|
'(stx->list e)
|
|
'(list (stx->list e)))
|
|
(if (null? nest-vars)
|
|
`(andmap (lambda (e) ,b) (stx->list e))
|
|
`(let/ec esc
|
|
(let ([l (map (lambda (e) (stx-check/esc ,b esc))
|
|
(stx->list e))])
|
|
(if (null? l)
|
|
(quote ,(let ([empties (map (lambda (v) '()) nest-vars)])
|
|
(if last?
|
|
(apply list* empties)
|
|
empties)))
|
|
(,(if last? 'stx-rotate* 'stx-rotate) l)))))))
|
|
#f)))
|
|
mh-did-var?
|
|
#f)))))
|
|
;; More stuff after ellipses. We need to make sure that
|
|
;; the extra stuff doesn't include any ellipses or a dot
|
|
(let ([hd (list (stx-car p) (stx-car (stx-cdr p)))]
|
|
[rest (stx-cdr (stx-cdr p))])
|
|
(let-values ([(tail-cnt prop?)
|
|
(let loop ([rest rest][cnt 0])
|
|
(if (stx-null? rest)
|
|
(values cnt #t)
|
|
(if (stx-pair? rest)
|
|
(begin
|
|
(when (...? (stx-car rest))
|
|
(raise-syntax-error
|
|
(syntax-e who)
|
|
"misplaced ellipses in pattern (follows other ellipses)"
|
|
top
|
|
(stx-car rest)))
|
|
(loop (stx-cdr rest) (add1 cnt)))
|
|
(values (add1 cnt) #f))))])
|
|
;; Like cons case, but with a more elaborate assembly:
|
|
(let*-values ([(-match-head -mh-did-var? <false>) (if just-vars?
|
|
(m&e hd hd use-ellipses? #f #f)
|
|
(values #f #f #f))]
|
|
[(match-tail mt-did-var? cap?) (m&e rest local-top use-ellipses?
|
|
last? #t)]
|
|
[(match-head mh-did-var? <false>) (if just-vars?
|
|
(values -match-head -mh-did-var? #f)
|
|
(m&e hd hd use-ellipses?
|
|
(and last? (not mt-did-var?))
|
|
#f))])
|
|
(if just-vars?
|
|
(values (append match-head match-tail) #f #f)
|
|
(values
|
|
(if interp-box
|
|
(vector 'mid-ellipses
|
|
match-head
|
|
match-tail
|
|
tail-cnt
|
|
prop?
|
|
mh-did-var?
|
|
mt-did-var?)
|
|
`(lambda (e)
|
|
(let-values ([(pre-items post-items ok?)
|
|
(split-stx-list e ,tail-cnt ,prop?)])
|
|
(if ok?
|
|
,(let ([s (let ([apph (app match-head 'pre-items)]
|
|
[appt (app match-tail 'post-items)])
|
|
(if mh-did-var?
|
|
(app-append apph appt)
|
|
`(if ,apph ,appt #f)))])
|
|
(if cap?
|
|
(if id-is-rest?
|
|
`(let ([cap (if (syntax? e) e cap)]) ,s)
|
|
`(let ([cap e]) ,s))
|
|
s))
|
|
#f))))
|
|
(or mh-did-var? mt-did-var?)
|
|
(and cap? id-is-rest?)))))))]
|
|
[(stx-pair? p)
|
|
(let ([hd (stx-car p)])
|
|
(if (and use-ellipses?
|
|
(...? hd))
|
|
(if (and (stx-pair? (stx-cdr p))
|
|
(stx-null? (stx-cdr (stx-cdr p))))
|
|
(let ([dp (stx-car (stx-cdr p))])
|
|
(m&e dp dp #f last? #f))
|
|
(raise-syntax-error
|
|
(syntax-e who)
|
|
"misplaced ellipses in pattern"
|
|
top
|
|
hd))
|
|
;; When just-vars?, do head first for good error ordering.
|
|
;; Otherwise, do tail first to find out if it has variables.
|
|
(let*-values ([(-match-head -mh-did-var? <false>) (if just-vars?
|
|
(m&e hd hd use-ellipses? #f #f)
|
|
(values #f #f #f))]
|
|
[(match-tail mt-did-var? cap?) (m&e (stx-cdr p) local-top use-ellipses?
|
|
last? #t)]
|
|
[(match-head mh-did-var? <false>) (if just-vars?
|
|
(values -match-head -mh-did-var? #f)
|
|
(m&e hd hd use-ellipses?
|
|
(and last? (not mt-did-var?))
|
|
#f))])
|
|
(if just-vars?
|
|
(values (append match-head match-tail) #f #f)
|
|
(values
|
|
(if interp-box
|
|
(vector 'pair
|
|
match-head
|
|
match-tail
|
|
mh-did-var?
|
|
mt-did-var?)
|
|
`(lambda (e)
|
|
(if (stx-pair? e)
|
|
,(let ([s (let ([apph (app match-head '(stx-car e))]
|
|
[appt (app match-tail '(stx-cdr e))])
|
|
(if mh-did-var?
|
|
(if mt-did-var?
|
|
(app-append apph appt)
|
|
`(let ([mh ,apph]) (and mh ,appt mh)))
|
|
`(if ,apph ,appt #f)))])
|
|
(if cap?
|
|
(if id-is-rest?
|
|
`(let ([cap (if (syntax? e) e cap)]) ,s)
|
|
`(let ([cap e]) ,s))
|
|
s))
|
|
#f)))
|
|
(or mh-did-var? mt-did-var?)
|
|
(and cap? id-is-rest?))))))]
|
|
[(stx-null? p)
|
|
(if just-vars?
|
|
(values null #f #f)
|
|
(values (if interp-box
|
|
'()
|
|
'stx-null/#f)
|
|
#f
|
|
#f))]
|
|
[(identifier? p)
|
|
(if (stx-memq p k)
|
|
(if just-vars?
|
|
(values null #f #f)
|
|
(values
|
|
(if interp-box
|
|
(let ([pos (let ([pos (let loop ([l (unbox interp-box)]
|
|
[pos (sub1 (length (unbox interp-box)))])
|
|
(cond
|
|
[(null? l) #f]
|
|
[(bound-identifier=? (car l) p) pos]
|
|
[else (loop (cdr l) (sub1 pos))]))])
|
|
(if pos
|
|
pos
|
|
(begin
|
|
(set-box! interp-box (cons p (unbox interp-box)))
|
|
(sub1 (length (unbox interp-box))))))])
|
|
pos)
|
|
`(lambda (e)
|
|
(if (identifier? e)
|
|
;; This free-identifier=? can be turned into
|
|
;; free-transformer-identifier=? by an
|
|
;; enclosing binding.
|
|
(if (free-identifier=? e (quote-syntax ,p))
|
|
null
|
|
#f)
|
|
#f)))
|
|
#f
|
|
#f))
|
|
(if (and use-ellipses?
|
|
(...? p))
|
|
(raise-syntax-error
|
|
(syntax-e who)
|
|
"misplaced ellipses in pattern"
|
|
top
|
|
p)
|
|
(if (wildcard? p)
|
|
;; Wildcard
|
|
(if just-vars?
|
|
(values null #f #f)
|
|
(values
|
|
(if interp-box
|
|
#f
|
|
`(lambda (e) null))
|
|
#f
|
|
#f))
|
|
;; Pattern variable
|
|
(if just-vars?
|
|
(values (list p) #f #f)
|
|
(values
|
|
(if interp-box
|
|
(vector 'bind last? id-is-rest?)
|
|
(let ([wrap (if last?
|
|
(lambda (x) `(lambda (e) ,x))
|
|
(lambda (x) `(lambda (e) (list ,x))))])
|
|
(if id-is-rest?
|
|
(wrap '(datum->syntax cap e cap))
|
|
(wrap 'e))))
|
|
#t
|
|
id-is-rest?)))))]
|
|
[(stx-vector? p #f)
|
|
(let ([l (vector->list (syntax-e p))])
|
|
;; If no top-level ellipses, match one by one:
|
|
(if (and (not just-vars?)
|
|
(or (not use-ellipses?)
|
|
(andmap (lambda (x) (not (...? x))) l)))
|
|
;; Match one-by-one:
|
|
;; Do tail first to find out if it has variables.
|
|
(let ([len (vector-length (syntax-e p))])
|
|
(let loop ([pos len][did-var? (not last?)][body null])
|
|
(if (zero? pos)
|
|
(values
|
|
(if interp-box
|
|
(vector 'vector len body)
|
|
`(lambda (e)
|
|
(if (stx-vector? e ,len)
|
|
,body
|
|
#f)))
|
|
did-var?
|
|
#f)
|
|
(let-values ([(match-elem elem-did-var? <false>)
|
|
(let ([e (vector-ref (syntax-e p) (sub1 pos))])
|
|
(m&e e e use-ellipses? (not did-var?) #f))])
|
|
(loop (sub1 pos)
|
|
(or did-var? elem-did-var?)
|
|
(if interp-box
|
|
(cons (cons match-elem elem-did-var?) body)
|
|
(let ([app-elem (app match-elem `(stx-vector-ref e ,(sub1 pos)))])
|
|
(if (null? body)
|
|
app-elem
|
|
(if elem-did-var?
|
|
(app-append app-elem body)
|
|
`(if ,app-elem ,body #f))))))))))
|
|
;; Match as a list:
|
|
(let-values ([(match-content did-var? <false>) (m&e l p use-ellipses? last? #f)])
|
|
(if just-vars?
|
|
(values match-content #f #f)
|
|
(values
|
|
(if interp-box
|
|
(vector 'veclist match-content)
|
|
`(lambda (e)
|
|
(if (stx-vector? e #f)
|
|
,(app match-content '(vector->list (syntax-e e)))
|
|
#f)))
|
|
did-var?
|
|
#f)))))]
|
|
[else
|
|
(if just-vars?
|
|
(values null #f #f)
|
|
(values
|
|
(if interp-box
|
|
(vector 'quote (syntax-e p))
|
|
`(lambda (e)
|
|
(if ,(let ([test `(equal? (quote ,(syntax-e p)) (syntax-e e))])
|
|
(if id-is-rest? ; might get a syntax pair
|
|
`(and (syntax? e) ,test)
|
|
test))
|
|
null
|
|
#f)))
|
|
#f
|
|
#f))]))
|
|
(let-values ([(r did-var? <false>) (m&e p p #t #t #f)])
|
|
(if just-vars?
|
|
;; Look for duplicate uses of variable names:
|
|
(let ([ht (make-hash-table)])
|
|
(let loop ([r r])
|
|
(cond
|
|
[(syntax? r)
|
|
(let ([l (hash-table-get ht (syntax-e r) null)])
|
|
(when (ormap (lambda (i) (bound-identifier=? i r)) l)
|
|
(raise-syntax-error
|
|
(syntax-e who)
|
|
"variable used twice in pattern"
|
|
top
|
|
r))
|
|
(hash-table-put! ht (syntax-e r) (cons r l)))]
|
|
[(pair? r)
|
|
(loop (car r))
|
|
(loop (cdr r))]
|
|
[else (void)]))
|
|
r)
|
|
;; A common trivial case is just return the expression
|
|
(if (equal? r '(lambda (e) e))
|
|
(if phase-param?
|
|
'(lambda (e free-identifier=?) e)
|
|
'(lambda (e) e))
|
|
(if interp-box
|
|
r
|
|
`(lambda (e ,@(if phase-param?
|
|
'(free-identifier=?)
|
|
null))
|
|
,(app-e r)))))))
|
|
|
|
(-define (make-match&env who top p k phase-param?)
|
|
(make-match&env/extract-vars who top p k #f phase-param? #f))
|
|
|
|
(-define (get-match-vars who top p k)
|
|
(make-match&env/extract-vars who top p k #t #f #f))
|
|
|
|
(-define (make-interp-match p keys interp-box)
|
|
(make-match&env/extract-vars (quote-syntax interp)
|
|
#f p
|
|
keys
|
|
#f #f interp-box))
|
|
|
|
;; Create an S-expression that applies
|
|
;; rest to `e'. Optimize ((lambda (e) E) e) to E.
|
|
(-define (app-e rest)
|
|
(if (and (pair? rest)
|
|
(eq? (car rest) 'lambda)
|
|
(equal? (cadr rest) '(e)))
|
|
(caddr rest)
|
|
`(,rest e)))
|
|
|
|
;; Create an S-expression that applies
|
|
;; rest to e.
|
|
(-define (app rest e)
|
|
(if (and (pair? rest)
|
|
(eq? (car rest) 'lambda)
|
|
(equal? (cadr rest) '(e)))
|
|
(let ([r (caddr rest)])
|
|
;; special (common) case: body is `e' or `(list e)'
|
|
(cond
|
|
[(eq? r 'e)
|
|
e]
|
|
[(and (pair? r)
|
|
(eq? (car r) 'list)
|
|
(pair? (cdr r))
|
|
(eq? (cadr r) 'e)
|
|
(null? (cddr r)))
|
|
`(list ,e)]
|
|
[else
|
|
`(,rest ,e)]))
|
|
`(,rest ,e)))
|
|
|
|
;; Create an S-expression that appends
|
|
;; e1 and e2. Optimize...
|
|
(-define (app-append e1 e2)
|
|
(if (and (pair? e1)
|
|
(eq? (car e1) 'list)
|
|
(pair? (cdr e1))
|
|
(null? (cddr e1)))
|
|
`(cons/#f ,(cadr e1) ,e2)
|
|
`(append/#f ,e1 ,e2)))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; Output generator
|
|
|
|
;; Takes a syntax pattern, an environment prototype, and
|
|
;; a keyword symbol list, and produces an expander
|
|
;; that takes an environment and produces syntax.
|
|
;;
|
|
;; If the environment prototype is #f, it produces a list of
|
|
;; variables used in the pattern, instead. This is useful for
|
|
;; determining what kind of environment (and prototype) to construct
|
|
;; for the pattern.
|
|
;;
|
|
;; An environment for an expander is a list*; see the note above,
|
|
;; under "Input Matcher", for details.
|
|
;;
|
|
(-define (make-pexpand p proto-r k dest)
|
|
(-define top p)
|
|
;; Helper function: avoid generating completely new symbols
|
|
;; for substitution. Instead, try to generate normal symbols
|
|
;; with a standard prefix, so that the symbols can be shared.
|
|
(-define sub-gensym (let ([cnt 0]
|
|
[prefix (let pfx-loop ([pfx "_pat"])
|
|
(if (let loop ([p p])
|
|
(cond
|
|
[(symbol? p)
|
|
(let ([s (symbol->string p)])
|
|
(and ((string-length s) . > . (string-length pfx))
|
|
(string=? pfx (substring s 0 (string-length pfx)))))]
|
|
[(syntax? p) (loop (syntax-e p))]
|
|
[(pair? p) (or (loop (car p)) (loop (cdr p)))]
|
|
[(vector? p) (loop (vector->list p))]
|
|
[else #f]))
|
|
(pfx-loop (string-append "_" pfx))
|
|
pfx))])
|
|
(lambda ()
|
|
(set! cnt (add1 cnt))
|
|
(string->symbol (format "~a~a" prefix cnt)))))
|
|
;; The pattern expander:
|
|
(-define (expander p proto-r local-top use-ellipses? use-tail-pos hash!)
|
|
(cond
|
|
[(and use-ellipses? (ellipsis? p))
|
|
(let*-values ([(p-head) (stx-car p)]
|
|
[(el-count rest-p last-el)
|
|
(let loop ([p (stx-cdr (stx-cdr p))][el-count 0][last-el (stx-car (stx-cdr p))])
|
|
(if (and (stx-pair? p)
|
|
(...? (stx-car p)))
|
|
(loop (stx-cdr p) (add1 el-count) (stx-car p))
|
|
(values el-count p last-el)))]
|
|
[(p-head) (let loop ([el-count el-count])
|
|
(if (zero? el-count)
|
|
p-head
|
|
(datum->syntax
|
|
#f
|
|
(list (loop (sub1 el-count)) (quote-syntax ...)))))]
|
|
[(nestings) (and proto-r (get-ellipsis-nestings p-head k))])
|
|
(when (null? nestings)
|
|
(apply
|
|
raise-syntax-error
|
|
'syntax
|
|
"no pattern variables before ellipses in template"
|
|
(pick-specificity
|
|
top
|
|
last-el)))
|
|
(let* ([proto-rr+deep?s (and proto-r
|
|
(map (lambda (nesting)
|
|
(ellipsis-sub-env nesting proto-r top local-top))
|
|
nestings))]
|
|
[proto-rr-deep (and proto-r
|
|
(let loop ([l proto-rr+deep?s])
|
|
(cond
|
|
[(null? l) null]
|
|
[(cdar l) (loop (cdr l))]
|
|
[else (cons (caar l) (loop (cdr l)))])))]
|
|
[proto-rr-shallow (and proto-r
|
|
(let loop ([l proto-rr+deep?s])
|
|
(cond
|
|
[(null? l) null]
|
|
[(cdar l) (cons (caar l) (loop (cdr l)))]
|
|
[else (loop (cdr l))])))]
|
|
[flat-nestings-deep (and proto-r (extract-vars proto-rr-deep))]
|
|
[flat-nestings-shallow (and proto-r (extract-vars proto-rr-shallow))]
|
|
[__ (unless (null? proto-rr-shallow)
|
|
(when (null? proto-rr-deep)
|
|
(apply
|
|
raise-syntax-error
|
|
'syntax
|
|
"too many ellipses in template"
|
|
(pick-specificity
|
|
top
|
|
last-el))))]
|
|
[rest (expander rest-p proto-r local-top #t use-tail-pos hash!)]
|
|
[ehead (expander p-head (and proto-r (append proto-rr-shallow proto-rr-deep)) p-head #t #f hash!)])
|
|
(if proto-r
|
|
`(lambda (r)
|
|
,(let ([pre (let ([deeps
|
|
(let ([valses
|
|
(map (lambda (var)
|
|
(apply-list-ref 'r (stx-memq*-pos var proto-r) use-tail-pos))
|
|
flat-nestings-deep)])
|
|
(cond
|
|
[(and (= 1 (length valses))
|
|
(= 0 el-count)
|
|
(null? flat-nestings-shallow)
|
|
(equal? ehead '(lambda (r) (car r))))
|
|
;; Common case: one item in list, no map needed:
|
|
(car valses)]
|
|
[(and (= 2 (length valses))
|
|
(= 0 el-count)
|
|
(null? flat-nestings-shallow)
|
|
(equal? ehead '(lambda (r) (list (car r) (cadr r)))))
|
|
;; Another common case: a maintained pair
|
|
`(map
|
|
(lambda (a b) (list a b))
|
|
,@valses)]
|
|
[else
|
|
;; General case:
|
|
(letrec ([wrap (lambda (expr el-count)
|
|
(if (zero? el-count)
|
|
expr
|
|
(wrap `(apply append ,expr)
|
|
(sub1 el-count))))])
|
|
(wrap
|
|
`(map
|
|
(lambda vals (,ehead
|
|
,(if (null? flat-nestings-shallow)
|
|
'vals
|
|
'(append shallows vals))))
|
|
,@valses)
|
|
el-count))]))])
|
|
(if (null? flat-nestings-shallow)
|
|
deeps
|
|
`(let ([shallows
|
|
(list ,@(map (lambda (var)
|
|
(apply-list-ref 'r (stx-memq*-pos var proto-r) use-tail-pos))
|
|
flat-nestings-shallow))])
|
|
,deeps)))]
|
|
[post (apply-to-r rest)])
|
|
(if (eq? post 'null)
|
|
pre
|
|
`(append ,pre ,post))))
|
|
;; variables were hashed
|
|
(void))))]
|
|
[(stx-pair? p)
|
|
(let ([hd (stx-car p)])
|
|
(if (and use-ellipses?
|
|
(...? hd))
|
|
(if (and (stx-pair? (stx-cdr p))
|
|
(stx-null? (stx-cdr (stx-cdr p))))
|
|
(let ([dp (stx-car (stx-cdr p))])
|
|
(expander dp proto-r dp #f use-tail-pos hash!))
|
|
(raise-syntax-error
|
|
'syntax
|
|
"misplaced ellipses in template"
|
|
top
|
|
hd))
|
|
(let ([ehd (expander hd proto-r hd use-ellipses? use-tail-pos hash!)]
|
|
[etl (expander (stx-cdr p) proto-r local-top use-ellipses? use-tail-pos hash!)])
|
|
(if proto-r
|
|
`(lambda (r)
|
|
,(apply-cons p (apply-to-r ehd) (apply-to-r etl) p sub-gensym))
|
|
;; variables were hashed
|
|
(void)))))]
|
|
[(stx-vector? p #f)
|
|
(let ([e (expander (vector->list (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash!)])
|
|
(if proto-r
|
|
`(lambda (r)
|
|
(list->vector (stx->list ,(apply-to-r e))))
|
|
;; variables were hashed
|
|
(void)))]
|
|
[(identifier? p)
|
|
(if (stx-memq p k)
|
|
(if proto-r
|
|
`(lambda (r) (quote-syntax ,p))
|
|
(void))
|
|
(if proto-r
|
|
(let ((x (stx-memq p proto-r)))
|
|
(if x
|
|
`(lambda (r) ,(apply-list-ref 'r (stx-memq-pos p proto-r) use-tail-pos))
|
|
(begin
|
|
(when (and use-ellipses?
|
|
(...? p))
|
|
(raise-syntax-error
|
|
'syntax
|
|
"misplaced ellipses in template"
|
|
top
|
|
p))
|
|
(check-not-pattern p proto-r)
|
|
`(lambda (r) (quote-syntax ,p)))))
|
|
(unless (and (...? p)
|
|
use-ellipses?)
|
|
(hash! p))))]
|
|
[(null? p)
|
|
;; Not syntax, so avoid useless syntax info
|
|
(if proto-r
|
|
`(lambda (r) null)
|
|
(void))]
|
|
[else (if proto-r
|
|
`(lambda (r) (quote-syntax ,p))
|
|
(void))]))
|
|
(let* ([ht (if proto-r
|
|
#f
|
|
(make-hash-table))]
|
|
[l (expander p proto-r p #t
|
|
(and proto-r (sub1 (length proto-r)))
|
|
(if proto-r
|
|
#f
|
|
(lambda (r)
|
|
(let ([l (hash-table-get ht (syntax-e r) null)])
|
|
(let ([pr (and (pair? l)
|
|
(ormap (lambda (i)
|
|
(and (bound-identifier=? (mcar i) r) i))
|
|
l))])
|
|
(if pr
|
|
(set-mcdr! pr (cons r (mcdr pr)))
|
|
(hash-table-put! ht (syntax-e r) (cons (mcons r (list r)) l))))))))])
|
|
(if proto-r
|
|
`(lambda (r)
|
|
,(let ([main (let ([build (apply-to-r l)])
|
|
(if (and (pair? build)
|
|
(eq? (car build) 'pattern-substitute))
|
|
build
|
|
(let ([small-dest ;; In case dest has significant structure...
|
|
(and dest (datum->syntax
|
|
dest
|
|
'dest
|
|
dest
|
|
dest))])
|
|
`(datum->syntax/shape (quote-syntax ,small-dest)
|
|
,build))))])
|
|
(if (multiple-ellipsis-vars? proto-r)
|
|
`(catch-ellipsis-error
|
|
(lambda () ,main)
|
|
(quote ,p)
|
|
;; This is a trick to minimize the syntax structure we keep:
|
|
(quote-syntax ,(datum->syntax #f '... p)))
|
|
main)))
|
|
(let ([l (apply append (hash-table-map ht (lambda (k v) v)))])
|
|
(values
|
|
;; Get list of unique vars:
|
|
(map mcar l)
|
|
;; All ids, including duplicates:
|
|
(map mcdr l))))))
|
|
|
|
;; apply-to-r creates an S-expression that applies
|
|
;; rest to `r', but it also optimizes ((lambda (r) E) r)
|
|
;; as simply E.
|
|
(-define (apply-to-r rest)
|
|
(if (and (pair? rest)
|
|
(eq? (car rest) 'lambda)
|
|
(equal? (cadr rest) '(r)))
|
|
(caddr rest)
|
|
`(,rest r)))
|
|
|
|
;; creates an S-expression that conses h and t,
|
|
;; with optimizations. If h and t are quoted
|
|
;; versions of the car and cdr of p, then return
|
|
;; a quoted as the "optimization" --- one that
|
|
;; is necessary to preserve the syntax wraps
|
|
;; associated with p.
|
|
(-define (apply-cons stx h t p sub-gensym)
|
|
(cond
|
|
[(and (pair? h)
|
|
(eq? (car h) 'quote-syntax)
|
|
(eq? (cadr h) (stx-car p))
|
|
(or (eq? t 'null)
|
|
(and
|
|
(pair? t)
|
|
(eq? (car t) 'quote-syntax)
|
|
(eq? (cadr t) (stx-cdr p)))))
|
|
`(quote-syntax ,p)]
|
|
[(and (pair? t)
|
|
(eq? (car t) 'pattern-substitute))
|
|
;; fold h into the existing pattern-substitute:
|
|
(cond
|
|
[(and (pair? h)
|
|
(eq? (car h) 'quote-syntax)
|
|
(eq? (cadr h) (stx-car p)))
|
|
;; Just extend constant part:
|
|
`(pattern-substitute
|
|
(quote-syntax ,(let ([v (cons (cadr h) (cadadr t))])
|
|
;; We exploit the fact that we're
|
|
;; building an S-expression to
|
|
;; preserve the source's distinction
|
|
;; between (x y) and (x . (y)).
|
|
(if (syntax? stx)
|
|
(datum->syntax stx
|
|
v
|
|
stx
|
|
stx
|
|
stx)
|
|
v)))
|
|
. ,(cddr t))]
|
|
[(and (pair? h)
|
|
(eq? 'pattern-substitute (car h)))
|
|
;; Combine two pattern substitutions:
|
|
`(pattern-substitute (quote-syntax ,(let ([v (cons (cadadr h) (cadadr t))])
|
|
(if (syntax? stx)
|
|
(datum->syntax stx
|
|
v
|
|
stx
|
|
stx
|
|
stx)
|
|
v)))
|
|
,@(cddr h) ;; <-- WARNING: potential quadratic expansion
|
|
. ,(cddr t))]
|
|
[else
|
|
;; General case: add a substitution:
|
|
(let* ([id (sub-gensym)]
|
|
[expr (cons id (cadadr t))]
|
|
[expr (if (syntax? stx)
|
|
(datum->syntax stx
|
|
expr
|
|
stx
|
|
stx
|
|
stx)
|
|
expr)])
|
|
`(pattern-substitute
|
|
(quote-syntax ,expr)
|
|
,id ,h
|
|
. ,(cddr t)))])]
|
|
[(eq? t 'null)
|
|
(apply-cons stx h
|
|
`(pattern-substitute (quote-syntax ()))
|
|
p
|
|
sub-gensym)]
|
|
[(and (pair? t)
|
|
(eq? (car t) 'quote-syntax)
|
|
(stx-smaller-than? (car t) 10))
|
|
;; Shift into `pattern-substitute' mode with an intitial constant.
|
|
;; (Only do this for small constants, so we don't traverse
|
|
;; big constants when looking for substitutions.)
|
|
(apply-cons stx h
|
|
`(pattern-substitute ,t)
|
|
p
|
|
sub-gensym)]
|
|
[else
|
|
;; Shift into `pattern-substitute' with an initial substitution:
|
|
(apply-cons stx h
|
|
(let ([id (sub-gensym)])
|
|
`(pattern-substitute (quote-syntax ,id)
|
|
,id ,t))
|
|
p
|
|
sub-gensym)]))
|
|
|
|
(-define (stx-smaller-than? stx sz)
|
|
(sz . > . (stx-size stx (add1 sz))))
|
|
|
|
(-define (stx-size stx up-to)
|
|
(cond
|
|
[(up-to . < . 1) 0]
|
|
[(syntax? stx) (stx-size (syntax-e stx) up-to)]
|
|
[(pair? stx) (let ([s1 (stx-size (car stx) up-to)])
|
|
(+ s1 (stx-size (cdr stx) (- up-to s1))))]
|
|
[(vector? stx) (stx-size (vector->list stx) up-to)]
|
|
[(box? stx) (add1 (stx-size (unbox stx) (sub1 up-to)))]
|
|
[else 1]))
|
|
|
|
;; Generates a list-ref expression; if use-tail-pos
|
|
;; is not #f, then the argument list is really a list*
|
|
;; (see the note under "Input Matcher") and in that case
|
|
;; use-tail-pos is a number indicating the list-tail
|
|
;; position of the last element
|
|
(-define (apply-list-ref e p use-tail-pos)
|
|
(cond
|
|
[(and use-tail-pos (= p use-tail-pos))
|
|
(cond
|
|
[(eq? p 0) e]
|
|
[(eq? p 1) `(cdr ,e)]
|
|
[(eq? p 2) `(cddr ,e)]
|
|
[(eq? p 3) `(cdddr ,e)]
|
|
[(eq? p 4) `(cddddr ,e)]
|
|
[else `(list-tail ,e ,p)])]
|
|
[(eq? p 0) `(car ,e)]
|
|
[(eq? p 1) `(cadr ,e)]
|
|
[(eq? p 2) `(caddr ,e)]
|
|
[(eq? p 3) `(cadddr ,e)]
|
|
[else `(list-ref ,e ,p)]))
|
|
|
|
;; Returns a list that nests a pattern variable as deeply as it
|
|
;; is ellipsed. Escaping ellipses are detected.
|
|
(-define get-ellipsis-nestings
|
|
(lambda (p k)
|
|
(let sub ([p p][use-ellipses? #t])
|
|
(cond
|
|
[(and use-ellipses? (ellipsis? p))
|
|
(let-values ([(rest nest)
|
|
(let loop ([p (stx-cdr (stx-cdr p))][nest list])
|
|
(if (and (stx-pair? p)
|
|
(...? (stx-car p)))
|
|
(loop (stx-cdr p) (lambda (x) (list (nest x))))
|
|
(values p nest)))])
|
|
(let ([subs (sub (stx-car p) #t)])
|
|
(append (map nest subs)
|
|
(sub rest #t))))]
|
|
[(stx-pair? p)
|
|
(let ([hd (stx-car p)])
|
|
(if (and use-ellipses?
|
|
(identifier? hd)
|
|
(...? hd)
|
|
(stx-pair? (stx-cdr p)))
|
|
(sub (stx-car (stx-cdr p)) #f)
|
|
(append (sub (stx-car p) use-ellipses?)
|
|
(sub (stx-cdr p) use-ellipses?))))]
|
|
[(identifier? p)
|
|
(if (or (stx-memq p k)
|
|
(wildcard? p))
|
|
'()
|
|
(list p))]
|
|
[(stx-vector? p #f)
|
|
(sub (vector->list (syntax-e p)) use-ellipses?)]
|
|
[else '()]))))
|
|
|
|
;; Checks whether the given nesting matches a nesting in the
|
|
;; environment prototype, returning the prototype entry if it is
|
|
;; found, and signaling an error otherwise. If the prototype
|
|
;; entry should be unwrapped by one, it is, and the resulting
|
|
;; prototype is paired with #f. Otherwise, the prototype is left
|
|
;; alone and paired with #t.
|
|
(-define ellipsis-sub-env
|
|
(lambda (nesting proto-r src detail-src)
|
|
(let ([v (ormap (lambda (proto)
|
|
(let ([start (if (pair? proto)
|
|
(car proto)
|
|
proto)])
|
|
(let loop ([c start] [n nesting] [unwrap? (pair? proto)])
|
|
(cond
|
|
[(and (pair? c) (pair? n))
|
|
(loop (car c) (car n) #t)]
|
|
[(pair? n)
|
|
(loop c (car n) #f)]
|
|
[(and (syntax? c) (syntax? n))
|
|
(if (bound-identifier=? c n)
|
|
(cons (if unwrap? start proto)
|
|
(not unwrap?))
|
|
#f)]
|
|
[else #f]))))
|
|
proto-r)])
|
|
(unless v
|
|
(apply
|
|
raise-syntax-error
|
|
'syntax
|
|
"too few ellipses for pattern variable in template"
|
|
(pick-specificity
|
|
src
|
|
(let loop ([n nesting])
|
|
(if (syntax? n)
|
|
n
|
|
(loop (car n)))))))
|
|
v)))
|
|
|
|
(-define (extract-vars proto-r)
|
|
(map (lambda (i)
|
|
(let loop ([i i])
|
|
(if (syntax? i)
|
|
i
|
|
(loop (car i)))))
|
|
proto-r))
|
|
|
|
;; Checks that a variable is not in the prototype
|
|
;; environment, and specifically not an ellipsed
|
|
;; variable.
|
|
(-define (check-not-pattern ssym proto-r)
|
|
(for-each (lambda (p)
|
|
(when (pair? p)
|
|
(let loop ([l (car p)])
|
|
(cond
|
|
[(syntax? l)
|
|
(when (bound-identifier=? l ssym)
|
|
(raise-syntax-error
|
|
'syntax
|
|
"missing ellipses with pattern variable in template"
|
|
ssym))]
|
|
[else (loop (car l))]))))
|
|
proto-r))
|
|
|
|
;; Tests if x is an ellipsing pattern of the form
|
|
;; (blah ... . blah2)
|
|
(-define (ellipsis? x)
|
|
(and (stx-pair? x)
|
|
(let ([d (stx-cdr x)])
|
|
(and (stx-pair? d)
|
|
(...? (stx-car d))
|
|
(not (...? (stx-car x)))))))
|
|
|
|
;; Takes an environment prototype and removes
|
|
;; the ellipsis-nesting information.
|
|
(-define (flatten-nestings nestings filter?)
|
|
(let loop ([nestings nestings])
|
|
(if (null? nestings)
|
|
null
|
|
(if (filter? (car nestings))
|
|
(cons (let loop ([nesting (car nestings)])
|
|
(if (syntax? nesting)
|
|
nesting
|
|
(loop (car nesting))))
|
|
(loop (cdr nestings)))
|
|
(loop (cdr nestings))))))
|
|
|
|
(-define (multiple-ellipsis-vars? proto-r)
|
|
(let loop ([proto-r proto-r])
|
|
(cond
|
|
[(null? proto-r) #f]
|
|
[(pair? (car proto-r))
|
|
(let loop ([proto-r (cdr proto-r)])
|
|
(cond
|
|
[(null? proto-r) #f]
|
|
[(pair? (car proto-r))
|
|
#t]
|
|
[else (loop (cdr proto-r))]))]
|
|
[else (loop (cdr proto-r))])))
|
|
|
|
(-define (no-ellipses? stx)
|
|
(cond
|
|
[(stx-pair? stx)
|
|
(and (no-ellipses? (stx-car stx))
|
|
(no-ellipses? (stx-cdr stx)))]
|
|
[(identifier? stx)
|
|
(not (...? stx))]
|
|
[else #t]))
|
|
|
|
;; Structure for communicating first-order pattern variable information:
|
|
(define-values (struct:syntax-mapping -make-syntax-mapping -syntax-mapping? syntax-mapping-ref syntax-mapping-set!)
|
|
(make-struct-type 'syntax-mapping #f 2 0 #f null (current-inspector)
|
|
(lambda (self stx)
|
|
(if (identifier? stx)
|
|
(raise-syntax-error
|
|
#f
|
|
"pattern variable cannot be used outside of a template"
|
|
stx)
|
|
(raise-syntax-error
|
|
#f
|
|
"pattern variable cannot be used outside of a template"
|
|
stx
|
|
(if (free-identifier=? (quote-syntax set!) (stx-car stx))
|
|
(stx-car (stx-cdr stx))
|
|
(stx-car stx)))))))
|
|
(-define (make-syntax-mapping depth valvar)
|
|
(make-set!-transformer (-make-syntax-mapping depth valvar)))
|
|
(-define (syntax-mapping? v)
|
|
(and (set!-transformer? v)
|
|
(-syntax-mapping? (set!-transformer-procedure v))))
|
|
(-define (syntax-mapping-depth v)
|
|
(syntax-mapping-ref (set!-transformer-procedure v) 0))
|
|
(-define (syntax-mapping-valvar v)
|
|
(syntax-mapping-ref (set!-transformer-procedure v) 1))
|
|
|
|
(#%provide (protect make-match&env get-match-vars make-interp-match
|
|
make-pexpand
|
|
make-syntax-mapping syntax-mapping?
|
|
syntax-mapping-depth syntax-mapping-valvar
|
|
stx-memq-pos no-ellipses?)))
|