654 lines
34 KiB
Scheme
654 lines
34 KiB
Scheme
;; This library is used by match.ss
|
|
|
|
(define (get-bind-val b-var bv-list)
|
|
(let ((res (assq
|
|
b-var
|
|
bv-list)))
|
|
(if res (cdr res)
|
|
(let ((res
|
|
(assq
|
|
(syntax-object->datum b-var)
|
|
(map (lambda (x)
|
|
(cons
|
|
(syntax-object->datum (car x)) (cdr x)))
|
|
bv-list))))
|
|
(if res (cdr res) (error 'var-not-found))))))
|
|
|
|
|
|
;;!(function handle-end-ddk-list
|
|
;; (form (handle-end-ddk-list ae kf ks pat
|
|
;; dot-dot-k stx
|
|
;; let-bound)
|
|
;; ->
|
|
;; ((list list) -> syntax))
|
|
;; (contract (syntax
|
|
;; ((list list) -> syntax)
|
|
;; ((list list) -> syntax)
|
|
;; syntax
|
|
;; syntax
|
|
;; syntax
|
|
;; list)
|
|
;; ->
|
|
;; ((list list) -> syntax)))
|
|
;; This returns a function which generates the code for
|
|
;; a pattern that ends with a ddk. This function is only applied to the
|
|
;; last pattern and the ddk.
|
|
;; Args:
|
|
;; ae - the expression being matched
|
|
;; kf - a failure function
|
|
;; ks - a success function
|
|
;; pat - the pattern to be matched repeatedly
|
|
;; dot-dot-k - the ddk pattern
|
|
;; stx - the source stx for error purposes
|
|
;; let-bound - a list of let bindings
|
|
(define handle-end-ddk-list
|
|
(lambda (ae kf ks pat dot-dot-k stx let-bound)
|
|
(lambda (sf bv)
|
|
(let* ((k (stx-dot-dot-k? dot-dot-k))
|
|
(ksucc (lambda (sf bv)
|
|
(let ((bound (getbindings pat)))
|
|
(if (syntax? bound)
|
|
(kf sf bv)
|
|
(syntax-case pat (_)
|
|
(_ (ks sf bv))
|
|
(the-pat
|
|
(null? bound)
|
|
(with-syntax ((exp-sym (syntax exp-sym)))
|
|
(let* ((ptst (next-outer
|
|
pat
|
|
(syntax exp-sym)
|
|
sf
|
|
bv
|
|
let-bound
|
|
(lambda (sf bv) (syntax #f))
|
|
(lambda (sf bv) (syntax #t))))
|
|
(tst (syntax-case ptst ()
|
|
((pred eta)
|
|
(and (identifier?
|
|
(syntax pred))
|
|
;free-identifier=?
|
|
(stx-equal?
|
|
(syntax eta)
|
|
(syntax exp-sym)))
|
|
(syntax pred))
|
|
(whatever
|
|
(quasisyntax/loc
|
|
stx
|
|
(lambda (exp-sym)
|
|
#,ptst))))))
|
|
(assm (quasisyntax/loc
|
|
stx
|
|
(andmap #,tst
|
|
#,(subst-bindings ae let-bound)))
|
|
(kf sf bv)
|
|
(ks sf bv)))))
|
|
(id
|
|
(and (identifier? (syntax id))
|
|
(stx-equal? (syntax id)
|
|
(car bound)))
|
|
(next-outer (syntax id) ae sf bv let-bound kf ks))
|
|
(the-pat
|
|
(let ((binding-list-names
|
|
(map (lambda (x)
|
|
(datum->syntax-object
|
|
(quote-syntax here)
|
|
(symbol-append
|
|
(gensym (syntax-object->datum x))
|
|
'-bindings)))
|
|
bound))
|
|
(loop-name (quasisyntax/loc
|
|
(syntax the-pat)
|
|
#,(gensym 'loop)))
|
|
(exp-name (quasisyntax/loc
|
|
(syntax the-pat)
|
|
#,(gensym 'exp))))
|
|
(quasisyntax/loc
|
|
stx
|
|
(let #,loop-name
|
|
((#,exp-name #,(subst-bindings ae let-bound))
|
|
#,@(map
|
|
(lambda (x)
|
|
(quasisyntax/loc
|
|
stx
|
|
(#,x '())))
|
|
binding-list-names))
|
|
(if (null? #,exp-name)
|
|
#,(ks sf
|
|
(append
|
|
(map cons
|
|
bound
|
|
(map
|
|
(lambda (x)
|
|
(quasisyntax/loc
|
|
stx
|
|
(reverse #,x)))
|
|
binding-list-names))
|
|
bv))
|
|
#,(next-outer (syntax the-pat)
|
|
(quasisyntax/loc
|
|
(syntax the-pat)
|
|
(car #,exp-name))
|
|
sf
|
|
bv ;; we always start
|
|
;; over with the old
|
|
;; bindings
|
|
let-bound
|
|
kf
|
|
(lambda (sf bv)
|
|
(quasisyntax/loc
|
|
stx
|
|
(#,loop-name
|
|
(cdr #,exp-name)
|
|
#,@(map
|
|
(lambda
|
|
(b-var
|
|
bindings-var)
|
|
(quasisyntax/loc
|
|
stx
|
|
(cons
|
|
#,(get-bind-val
|
|
b-var
|
|
bv)
|
|
#,bindings-var)))
|
|
bound binding-list-names))))))))))))))))
|
|
(case k
|
|
((0) (ksucc sf bv))
|
|
((1) (emit (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf bv kf ksucc))
|
|
(else (emit (lambda (exp) (quasisyntax/loc stx (>= (length #,exp) #,k)))
|
|
ae
|
|
let-bound
|
|
sf bv kf ksucc)))))))
|
|
|
|
;;!(function handle-inner-ddk-list
|
|
;; (form (handle-inner-ddk-list ae kf ks pat
|
|
;; dot-dot-k pat-rest stx
|
|
;; let-bound)
|
|
;; ->
|
|
;; ((list list) -> syntax))
|
|
;; (contract (syntax
|
|
;; ((list list) -> syntax)
|
|
;; ((list list) -> syntax)
|
|
;; syntax
|
|
;; syntax
|
|
;; syntax
|
|
;; syntax
|
|
;; list)
|
|
;; ->
|
|
;; ((list list) -> syntax)))
|
|
;; This returns a function which generates the code for a list
|
|
;; pattern that contains with a ddk that occurs before the end of
|
|
;; the list. This code is extremely similar to the code in
|
|
;; handle-end-ddk-list but there are enough differences to warrant
|
|
;; having a separate method for readability.
|
|
;; Args:
|
|
;; ae - the expression being matched
|
|
;; kf - a failure function
|
|
;; ks - a success function
|
|
;; pat - the pattern that preceeds the ddk
|
|
;; dot-dot-k - the ddk pattern
|
|
;; pat-rest - the rest of the list pattern that occurs after the ddk
|
|
;; stx - the source stx for error purposes
|
|
;; let-bound - a list of let bindings
|
|
(define handle-inner-ddk-list
|
|
(lambda (ae kf ks pat dot-dot-k pat-rest stx let-bound)
|
|
(lambda (sf bv)
|
|
(let* ((k (stx-dot-dot-k? dot-dot-k)))
|
|
(let ((bound (getbindings pat)))
|
|
(if (syntax? bound)
|
|
(kf sf bv)
|
|
(syntax-case pat (_)
|
|
(_
|
|
(stx-null? pat-rest)
|
|
(ks sf bv))
|
|
(the-pat
|
|
(null? bound)
|
|
(with-syntax ((exp-sym (syntax exp-sym)))
|
|
(let* ((ptst (next-outer
|
|
pat
|
|
(syntax exp-sym)
|
|
sf
|
|
bv
|
|
let-bound
|
|
(lambda (sf bv) (syntax #f))
|
|
(lambda (sf bv) (syntax #t))))
|
|
(tst (syntax-case ptst ()
|
|
((pred eta)
|
|
(and (identifier?
|
|
(syntax pred))
|
|
;free-identifier=?
|
|
(stx-equal?
|
|
(syntax eta)
|
|
(syntax exp-sym)))
|
|
(syntax pred))
|
|
(whatever
|
|
(quasisyntax/loc stx (lambda (exp-sym)
|
|
#,ptst)))))
|
|
(loop-name (gensym 'ddnnl))
|
|
(exp-name (gensym 'exp))
|
|
(count-name (gensym 'count)))
|
|
(quasisyntax/loc
|
|
(syntax the-pat)
|
|
(let #,loop-name ((#,exp-name
|
|
#,(subst-bindings ae let-bound))
|
|
(#,count-name 0))
|
|
(if (and (not (null? #,exp-name))
|
|
;; added for improper ddk
|
|
(pair? #,exp-name)
|
|
(#,tst (car #,exp-name)))
|
|
(#,loop-name (cdr #,exp-name)
|
|
(add1 #,count-name))
|
|
;; testing the count is not neccessary
|
|
;; if the count is zero
|
|
#,(let ((succ (next-outer
|
|
pat-rest
|
|
(quasisyntax/loc
|
|
(syntax the-pat) #,exp-name)
|
|
sf
|
|
bv
|
|
let-bound
|
|
kf
|
|
ks)))
|
|
(if (zero? k)
|
|
succ
|
|
(quasisyntax/loc
|
|
(syntax the-pat)
|
|
(if (>= #,count-name #,k)
|
|
#,succ
|
|
#,(kf sf bv)))))))))))
|
|
(the-pat
|
|
(let* ((binding-list-names
|
|
(map (lambda (x)
|
|
(datum->syntax-object
|
|
(quote-syntax here)
|
|
(symbol-append
|
|
(gensym (syntax-object->datum x))
|
|
'-bindings)))
|
|
bound))
|
|
(loop-name (quasisyntax/loc
|
|
(syntax the-pat)
|
|
#,(gensym 'loop)))
|
|
(exp-name (quasisyntax/loc
|
|
(syntax the-pat)
|
|
#,(gensym 'exp)))
|
|
(fail-name (quasisyntax/loc
|
|
(syntax the-pat)
|
|
#,(gensym 'fail)))
|
|
(count-name (quasisyntax/loc
|
|
(syntax the-pat)
|
|
#,(gensym 'count)))
|
|
(new-bv (append
|
|
(map cons
|
|
bound
|
|
(map
|
|
(lambda (x)
|
|
(quasisyntax/loc stx (reverse #,x)))
|
|
binding-list-names)) bv)))
|
|
(quasisyntax/loc
|
|
(syntax the-pat)
|
|
(let #,loop-name
|
|
((#,exp-name #,(subst-bindings ae let-bound))
|
|
(#,count-name 0)
|
|
#,@(map
|
|
(lambda (x) (quasisyntax/loc
|
|
(syntax the-pat)
|
|
(#,x '())))
|
|
binding-list-names))
|
|
(let ((#,fail-name
|
|
(lambda ()
|
|
#,(let ((succ (next-outer
|
|
pat-rest
|
|
(quasisyntax/loc
|
|
(syntax the-pat)
|
|
#,exp-name)
|
|
sf
|
|
new-bv
|
|
let-bound
|
|
kf
|
|
ks)))
|
|
(if (zero? k)
|
|
succ
|
|
(quasisyntax/loc
|
|
(syntax the-pat)
|
|
(if (>= #,count-name #,k)
|
|
#,succ
|
|
#,(kf sf new-bv))))))))
|
|
(if (or (null? #,exp-name)
|
|
(not (pair? #,exp-name)))
|
|
(#,fail-name)
|
|
#,(next-outer (syntax the-pat)
|
|
(quasisyntax/loc
|
|
(syntax the-pat)
|
|
(car #,exp-name))
|
|
sf
|
|
bv ;; we always start
|
|
;; over with the old
|
|
;; bindings
|
|
let-bound
|
|
(lambda (sf bv)
|
|
(quasisyntax/loc
|
|
(syntax the-pat)
|
|
(#,fail-name)))
|
|
(lambda (sf bv)
|
|
(quasisyntax/loc
|
|
stx
|
|
(#,loop-name
|
|
(cdr #,exp-name)
|
|
(add1 #,count-name)
|
|
#,@(map
|
|
(lambda
|
|
(b-var
|
|
bindings-var)
|
|
(quasisyntax/loc
|
|
stx
|
|
(cons
|
|
#,(get-bind-val
|
|
b-var
|
|
bv)
|
|
#,bindings-var)))
|
|
bound
|
|
binding-list-names))))))))))))))))))
|
|
;;!(function handle-ddk-vector
|
|
;; (form (handle-ddk-vector ae kf ks pt let-bound)
|
|
;; ->
|
|
;; ((list list) -> syntax))
|
|
;; (contract (syntax
|
|
;; ((list list) -> syntax)
|
|
;; ((list list) -> syntax)
|
|
;; syntax
|
|
;; list)
|
|
;; ->
|
|
;; ((list list) -> syntax)))
|
|
;; This returns a function which generates the code for a vector
|
|
;; pattern that contains a ddk that occurs at the end of the
|
|
;; vector.
|
|
;; Args:
|
|
;; ae - the expression being matched
|
|
;; kf - a failure function
|
|
;; ks - a success function
|
|
;; pt - the whole vector pattern
|
|
;; let-bound - a list of let bindings
|
|
(define handle-ddk-vector
|
|
(lambda (ae kf ks pt stx let-bound)
|
|
(let* ((vec-stx (syntax-e pt))
|
|
(vlen (- (vector-length vec-stx) 2)) ;; length minus
|
|
;; the pat ...
|
|
(k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen))))
|
|
(minlen (+ vlen k))
|
|
;; get the bindings for the second to last element:
|
|
;; 'pat' in pat ...
|
|
(bound (getbindings (vector-ref vec-stx vlen)))
|
|
(exp-name (gensym 'exnm)))
|
|
(lambda (sf bv)
|
|
(if (syntax? bound)
|
|
(kf sf bv)
|
|
(quasisyntax/loc
|
|
pt
|
|
(let ((#,exp-name #,(subst-bindings ae let-bound)))
|
|
#,(assm (quasisyntax/loc
|
|
stx
|
|
(>= (vector-length #,exp-name) #,minlen))
|
|
(kf sf bv)
|
|
((let vloop ((n 0))
|
|
(lambda (sf bv)
|
|
(cond
|
|
((not (= n vlen))
|
|
(next-outer
|
|
(vector-ref vec-stx n)
|
|
(quasisyntax/loc
|
|
stx
|
|
(vector-ref #,exp-name #,n))
|
|
sf
|
|
bv
|
|
let-bound
|
|
kf
|
|
(vloop (+ 1 n))))
|
|
((eq? (syntax-object->datum
|
|
(vector-ref vec-stx vlen))
|
|
'_)
|
|
(ks sf bv))
|
|
(else
|
|
(let* ((binding-list-names
|
|
(map (lambda (x)
|
|
(datum->syntax-object
|
|
(quote-syntax here)
|
|
(symbol-append
|
|
(gensym (syntax-object->datum x))
|
|
'-bindings)))
|
|
bound))
|
|
(vloop-name (gensym 'vloop))
|
|
(index-name (gensym 'index)))
|
|
(quasisyntax/loc
|
|
stx
|
|
(let #,vloop-name
|
|
((#,index-name (- (vector-length #,exp-name) 1))
|
|
#,@(map (lambda (x)
|
|
(quasisyntax/loc stx (#,x '())))
|
|
binding-list-names))
|
|
(if (> #,vlen #,index-name)
|
|
#,(ks sf
|
|
(append (map cons bound
|
|
binding-list-names)
|
|
bv))
|
|
#,(next-outer
|
|
(vector-ref vec-stx n)
|
|
(quasisyntax/loc
|
|
stx
|
|
(vector-ref #,exp-name #,index-name))
|
|
sf
|
|
bv ;; we alway start over
|
|
;; with the old bindings
|
|
let-bound
|
|
kf
|
|
(lambda (sf bv)
|
|
(quasisyntax/loc
|
|
stx (#,vloop-name
|
|
(- #,index-name 1)
|
|
#,@(map
|
|
(lambda (b-var
|
|
bindings-var)
|
|
(quasisyntax/loc
|
|
stx
|
|
(cons
|
|
#,(get-bind-val
|
|
b-var
|
|
bv)
|
|
#,bindings-var)))
|
|
bound
|
|
binding-list-names)))))))))))))
|
|
sf
|
|
bv)))))))))
|
|
|
|
;;!(function handle-ddk-vector-inner
|
|
;; (form (handle-ddk-vector-inner ae kf ks pt let-bound)
|
|
;; ->
|
|
;; ((list list) -> syntax))
|
|
;; (contract (syntax
|
|
;; ((list list) -> syntax)
|
|
;; ((list list) -> syntax)
|
|
;; syntax
|
|
;; list)
|
|
;; ->
|
|
;; ((list list) -> syntax)))
|
|
;; This returns a function which generates the code for a vector
|
|
;; pattern that contains a ddk that occurs before another pattern
|
|
;; in the list.
|
|
;; Args:
|
|
;; ae - the expression being matched
|
|
;; kf - a failure function
|
|
;; ks - a success function
|
|
;; pt - the whole vector pattern
|
|
;; let-bound - a list of let bindings
|
|
(define handle-ddk-vector-inner
|
|
(lambda (ae kf ks pt stx let-bound)
|
|
(let* ((vec-stx (syntax-e pt))
|
|
;; vlen as an index points at the pattern before the ddk
|
|
(vlen (- (vector-length vec-stx) 2)) ;; length minus
|
|
;; the pat ...
|
|
(vec-len (vector-length vec-stx))
|
|
(total-k (ddk-in-vec? vec-stx pt))
|
|
;; (k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen))))
|
|
(minlen (+ vec-len total-k))
|
|
(length-of-vector-name (gensym 'lv))
|
|
(exp-name (gensym 'exnm)))
|
|
;; get the bindings for the second to last element:
|
|
;; 'pat' in pat ...
|
|
;;(bound (getbindings (vector-ref vec-stx vlen))))
|
|
;; we have to look at the first pattern and see if a ddk follows it
|
|
;; if so handle that case else handle the pattern
|
|
(lambda (sf bv)
|
|
;; minlen here could be the lentgh plus the k's - 1 for each ddk
|
|
(quasisyntax/loc
|
|
pt
|
|
(let ((#,exp-name #,(subst-bindings ae let-bound)))
|
|
(let ((#,length-of-vector-name (vector-length #,exp-name)))
|
|
#,(assm (quasisyntax/loc pt (>= #,length-of-vector-name #,minlen))
|
|
(kf sf bv)
|
|
(let ((current-index-name (gensym 'curr-ind)))
|
|
(quasisyntax/loc
|
|
pt
|
|
(let ((#,current-index-name 0))
|
|
#,((let vloop ((n 0)
|
|
(count-offset-name-passover
|
|
current-index-name))
|
|
(lambda (sf bv)
|
|
|
|
(cond
|
|
((= n vec-len) ;; at the end of the patterns
|
|
(quasisyntax/loc
|
|
pt
|
|
(if (>= #,count-offset-name-passover
|
|
#,length-of-vector-name)
|
|
#,(ks sf bv)
|
|
#,(kf sf bv))))
|
|
((stx-dot-dot-k? (vector-ref vec-stx n))
|
|
;;this could be it
|
|
(match:syntax-err
|
|
stx
|
|
"should not get here"))
|
|
;; if the next one is not a ddk do a normal pattern match
|
|
;; on element
|
|
((or (= n (sub1 vec-len))
|
|
(not (stx-dot-dot-k? (vector-ref vec-stx
|
|
(add1 n)))))
|
|
(quasisyntax/loc
|
|
pt
|
|
(if (= #,count-offset-name-passover
|
|
#,length-of-vector-name)
|
|
#,(kf sf bv)
|
|
#,(next-outer
|
|
(vector-ref vec-stx n) ;this could be it
|
|
(quasisyntax/loc
|
|
stx
|
|
(vector-ref #,exp-name #,count-offset-name-passover))
|
|
'() ;we don't want these tests to take part in future
|
|
; elimination or to be eliminated
|
|
bv
|
|
let-bound
|
|
kf
|
|
(lambda (bsf bv)
|
|
;(set! current-index-name #`(add1 #,current-index-name))
|
|
(let ((cindnm (gensym 'cindnm)))
|
|
(quasisyntax/loc
|
|
pt
|
|
(let ((#,cindnm (add1 #,count-offset-name-passover)))
|
|
#,((vloop (+ 1 n) cindnm) sf bv)))))))))
|
|
((and (eq? (syntax-object->datum
|
|
(vector-ref vec-stx n)) ;this could be it
|
|
'_)
|
|
(>= (- vec-len n 1)
|
|
(stx-dot-dot-k? (vector-ref vec-stx (add1 n)))))
|
|
(ks sf bv))
|
|
(else ;; we now know that the next pattern is a ddk
|
|
(let ((bound (getbindings (vector-ref vec-stx n))))
|
|
(if (syntax? bound)
|
|
(kf sf bv)
|
|
(let* ((k (stx-dot-dot-k? (vector-ref vec-stx (add1 n))))
|
|
(binding-list-names
|
|
(map (lambda (x)
|
|
(datum->syntax-object
|
|
(quote-syntax here)
|
|
(symbol-append
|
|
(gensym (syntax-object->datum x))
|
|
'-bindings)))
|
|
bound))
|
|
(vloop-name (gensym 'vloop))
|
|
(count-name (gensym 'count))
|
|
(index-name (gensym 'index)))
|
|
(quasisyntax/loc
|
|
stx
|
|
(let #,vloop-name
|
|
((#,count-name #,count-offset-name-passover)
|
|
#,@(map (lambda (x) (quasisyntax/loc stx (#,x '())))
|
|
binding-list-names))
|
|
#,(let ((fail-name (gensym 'fail))
|
|
(count-offset-name (gensym 'count-offset))
|
|
(index-name (gensym 'index))
|
|
)
|
|
(quasisyntax/loc
|
|
pt
|
|
(let ((#,fail-name
|
|
(lambda (#,count-offset-name #,index-name)
|
|
#,(let ((body ((vloop (+ n 2) index-name) sf
|
|
(append (map (lambda (b bln)
|
|
(cons b
|
|
(quasisyntax/loc
|
|
pt
|
|
(reverse #,bln))))
|
|
bound
|
|
binding-list-names)
|
|
bv)
|
|
)))
|
|
(if (> k 0)
|
|
(quasisyntax/loc
|
|
pt
|
|
(if (>= #,count-offset-name #,k)
|
|
#,body
|
|
#,(kf sf bv)))
|
|
body)))))
|
|
(if (= #,length-of-vector-name #,count-name)
|
|
(#,fail-name
|
|
(- #,count-name #,count-offset-name-passover)
|
|
#,count-name)
|
|
#,(next-outer
|
|
(vector-ref vec-stx n) ;this could be it
|
|
(quasisyntax/loc
|
|
stx
|
|
(vector-ref #,exp-name #,count-name))
|
|
'() ;sf
|
|
bv ;; we alway start over
|
|
;; with the old bindings
|
|
let-bound
|
|
(lambda (sf bv)
|
|
(quasisyntax/loc
|
|
pt
|
|
(#,fail-name
|
|
(- #,count-name
|
|
#,count-offset-name-passover)
|
|
#,count-name)))
|
|
(lambda (sf bv)
|
|
(quasisyntax/loc
|
|
stx
|
|
(let ((arglist
|
|
(list
|
|
#,@(map
|
|
(lambda (b-var
|
|
bindings-var)
|
|
(quasisyntax/loc
|
|
stx
|
|
(cons
|
|
#,(get-bind-val
|
|
b-var
|
|
bv)
|
|
#,bindings-var)))
|
|
bound
|
|
binding-list-names))))
|
|
(apply
|
|
#,vloop-name
|
|
(add1 #,count-name)
|
|
arglist))))))))))))))))))
|
|
sf
|
|
bv))))))))))))
|