suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Remove old match implementation.

Browse Source 
Fix typed-scheme to work w/ new match.
Factor out lots of common code.
Implement (mcons ..) patterns

svn: r9086
This commit is contained in:
Sam Tobin-Hochstadt 2008-03-25 18:26:39 +00:00
parent a37fe34a48
commit ae4acf1d51
34 changed files with 160 additions and 4506 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

134
collects/mzlib/private/match/convert-pat.ss
View File

@ -1,134 +0,0 @@
(module convert-pat mzscheme
(require "match-error.ss"
"match-helper.ss"
"match-expander-struct.ss"
"observe-step.ss")
(require-for-template mzscheme
"match-error.ss")
(provide convert-pat handle-clauses convert-pats)
;; these functions convert the patterns from the old syntax
;; to the new syntax
(define (handle-clause stx)
(syntax-case stx ()
[(pat . rest) (quasisyntax/loc stx (#,(convert-pat #'pat) . rest))]))
(define (handle-clauses stx) (syntax-map handle-clause stx))
(define (convert-pats stx)
(with-syntax ([new-pats (syntax-map convert-pat stx)])
#'new-pats))
(define (imp-list? stx)
(define datum (syntax-e stx))
(define (keyword? x)
(memq (syntax-object->datum x)
'(quote quasiquote ? = and or not $ set! get!)))
(let/ec out
(let loop ([x datum])
(cond [(null? x) (out #f)]
[(or (not (pair? x))
(and (list? x)
(keyword? (car x))))
(list
(quasisyntax/loc stx #,x))]
[else (cons (car x) (loop (cdr x)))]))))
(define (convert-quasi stx)
(syntax-case stx (unquote quasiquote unquote-splicing)
[,pat (quasisyntax/loc stx ,#,(convert-pat (syntax pat)))]
[,@pat (quasisyntax/loc stx ,@#,(convert-pat (syntax pat)))]
[(x . y)
(quasisyntax/loc
stx (#,(convert-quasi (syntax x)) . #,(convert-quasi (syntax y))))]
[pat
(vector? (syntax-e stx))
(quasisyntax/loc
stx
#,(list->vector (map convert-quasi
(vector->list (syntax-e stx)))))]
[pat
(box? (syntax-e stx))
(quasisyntax/loc
stx #,(box (convert-quasi (unbox (syntax-e stx)))))]
[pat stx]))
(define (convert-pat stx)
(convert-pat/cert stx (lambda (x) x)))
(define (convert-pat/cert stx cert)
(let ([convert-pat (lambda (x) (convert-pat/cert x cert))])
(syntax-case*
stx
(_ ? = and or not $ set! get! quasiquote
quote unquote unquote-splicing) stx-equal?
[(expander . args)
(and (identifier? #'expander)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(let* ([expander (syntax-local-value (cert #'expander) (lambda () #f))]
[xformer (match-expander-match-xform expander)])
(if (not xformer)
(match:syntax-err #'expander
"This expander only works with plt-match.ss.")
(let* ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)]
[mstx (introducer stx)]
[mresult (xformer mstx)]
[result (introducer mresult)]
[cert* (lambda (id) (certifier (cert id) #f introducer))])
(observe-step stx mstx mresult result)
(convert-pat/cert result cert*))))]
[p
(dot-dot-k? (syntax-object->datum #'p))
stx]
[_ stx]
[() (syntax/loc stx (list))]
['() (syntax/loc stx (list))]
['item stx]
[p (constant-data? (syntax-e stx)) stx]
[(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))]
[(? pred . a)
(with-syntax ([pred (cert #'pred)]
[pats (syntax-map convert-pat #'a)])
(syntax/loc stx (? pred . pats)))]
[`pat (quasisyntax/loc stx `#,(convert-quasi #'pat))]
[(= op pat) (quasisyntax/loc stx (app #,(cert #'op) #,(convert-pat #'pat)))]
[(and . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)])
(syntax/loc stx (and . new-pats)))]
[(or . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)])
(syntax/loc stx (or . new-pats)))]
[(not . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)])
(syntax/loc stx (not . new-pats)))]
[($ struct-name . fields)
(with-syntax ([struct-name (cert #'struct-name)]
[new-fields (syntax-map convert-pat #'fields)])
(syntax/loc stx (struct struct-name new-fields)))]
[(get! id) (with-syntax ([id (cert #'id)])
(syntax/loc stx (get! id)))]
[(set! id) (with-syntax ([id (cert #'id)])
(syntax/loc stx (set! id)))]
[(quote p) stx]
[(car-pat . cdr-pat)
(let ([l (imp-list? stx)])
(if l (quasisyntax/loc stx (list-rest #,@(map convert-pat l)))
(quasisyntax/loc stx (list #,@(syntax-map convert-pat stx)))))]
[pt
(vector? (syntax-e stx))
(with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))])
(syntax/loc stx (vector . new-pats)))]
[pt
(box? (syntax-e stx))
(quasisyntax/loc stx (box #,(convert-pat (unbox (syntax-e stx)))))]
[pt
(identifier? stx)
(cert stx)]
[got-too-far
(match:syntax-err stx "syntax error in pattern")])))
)

185
collects/mzlib/private/match/coupling-and-binding.scm
View File

@ -1,185 +0,0 @@
(module coupling-and-binding mzscheme
;; This library is used by match.ss
(provide couple-tests meta-couple subst-bindings)
(require "test-structure.scm"
"match-helper.ss"
mzlib/pretty
mzlib/list)
(require-for-template mzscheme)
;; a structure representing bindings of portions of the matched data
;; exp: the expression that is bound in s-exp form
;; exp-stx: the expression that is bound in syntax form
;; new-exp: the new symbol that will represent the expression
(define-struct binding (exp exp-stx new-exp))
;;!(function couple-tests
;; (form (couple-tests test-list ks-func kf-func let-bound)
;; ->
;; ((list list) -> syntax))
;; (contract (list
;; ((((list list) -> syntax) list) ->
;; ((list list) -> syntax))
;; (list -> ((list list) -> syntax))
;; list)
;; ->
;; ((list list) -> syntax)))
;; This is a major function of the compiler. This function
;; couples a list of tests together. Here is where state is
;; passed around to the various partially compiled tests so that
;; compilation can be completed. This returns a function that takes a
;; list of tests so far and a list of bound pattern variables.
(define (couple-tests test-list ks-func kf-func let-bound)
;(print-time "entering couple-tests")
;(printf "test-list: ~a~n" (map test-tst test-list))
;(printf "test-list size: ~a~n" (length test-list))
(if (null? test-list)
(ks-func (kf-func let-bound) let-bound)
(let* ([cur-test (car test-list)]
[rest-tests (cdr test-list)]
;; this couples together the rest of the test
;; it is passed a list of the already bound expressions
;; only used in test/rest
[couple-rest (lambda (let-bound)
(couple-tests rest-tests
ks-func
(if (negate-test? cur-test)
(lambda (let-bound)
(lambda (sf bv)
#`(match-failure)))
kf-func)
let-bound))]
;; this generates the current test as well as the rest of the match expression
;; it is passed a list of the already bound expressions
[test/rest (lambda (let-bound)
((test-comp cur-test)
(couple-rest let-bound)
(kf-func let-bound)
let-bound))])
(if (and
;; the expression is referenced twice
(>= (test-bind-count cur-test) 2)
;; and it's not already bound to some variable
(not (exp-already-bound?
(test-bind-exp cur-test)
let-bound)))
;; then generate a new binding for this expression
(let* ([new-exp (get-exp-var)]
[binding (make-binding (test-bind-exp cur-test)
(test-bind-exp-stx cur-test)
new-exp)]
[let-bound (cons binding let-bound)])
(with-syntax (;; the new variable
[v new-exp]
;; the expression being bound
;; with appropriate substitutions for the already bound portions
[expr (sub-expr-subst (binding-exp-stx binding) let-bound)])
(lambda (sf bv)
#`(let ([v expr])
;; the new body, using the new binding (through let-bound)
#,((test/rest let-bound) sf bv)))))
;; otherwise it doesn't need a binding, and we can just do the test
(test/rest let-bound)))))
;;!(function subst-bindings
;; (form (subst-bindings exp-stx let-bound) -> syntax)
;; (contract (syntax list) -> syntax)
;; (example (subst-bindings (syntax (car (cdr x)))
;; (list (list '(cdr x)
;; (syntax (cdr x))
;; 'exp5)))
;; -> (syntax (car 'exp5))))
;; This function substitutes let bound variables names for the
;; expressions that they represent.
(define (subst-bindings exp-stx let-bound)
(cond [(get-bind exp-stx let-bound) => binding-new-exp]
[else (sub-expr-subst exp-stx let-bound)]))
;;!(function sub-exp-subst
;; (form (sub-exp-subst exp-stx let-bound) -> syntax)
;; (contract (syntax list) -> syntax)
;; (example (subst-bindings (syntax (car (cdr x)))
;; (list (list '(cdr x)
;; (syntax (cdr x))
;; 'exp5)))
;; -> (syntax (car 'exp5))))
;; This function substitutes let bound variables names for the
;; expressions that they represent. This only works if a
;; subexpression of exp-stx is bound in the let-bound list.
;; This function assumes that all accessors are of the form
;; (acc obj other-args ...) (such as list-ref)
(define (sub-expr-subst exp-stx let-bound)
(syntax-case exp-stx ()
[(access sub-exp rest ...)
(let ([binding (get-bind #'sub-exp let-bound)])
(if binding
#`(access #,(binding-new-exp binding) rest ...)
#`(access #,(sub-expr-subst #'sub-exp let-bound) rest ...)))]
[_ exp-stx]))
; helper for the following functions
(define ((equal-bind-get exp) e)
(equal? exp (binding-exp e)))
;;!(function get-bind
;; (form (get-bind exp let-bound) -> binding)
;; (contract (any list) -> list))
;; This function looks up the binding for a given expression exp
;; in the binding list let-bound. If the binding is found then the
;; binding is returned if not then #f is returned.
(define (get-bind exp let-bound)
(cond [(memf (equal-bind-get (syntax-object->datum exp)) let-bound) => car]
[else #f]))
;;!(function exp-already-bound?
;; (form (exp-already-bound? exp let-bound) -> binding)
;; (contract (any list) -> boolean))
;; This function looks up the binding for a given expression exp
;; in the binding list let-bound. If the binding is found then #t
;; binding is returned if not then #f is returned.
(define (exp-already-bound? exp let-bound)
(ormap (equal-bind-get exp) let-bound))
;;!(function meta-couple
;; (form (meta-couple rendered-list failure-func
;; let-bound bvsf)
;; ->
;; ((list list) -> syntax))
;; (contract (list ((list list) -> syntax) list list)
;; ->
;; ((list list) -> syntax)))
;; This function takes a list of rendered clauses which also have
;; success functions attached and couples the whole lot together
;; yeilding one function that when invoked will compile the whole
;; original match expression.
(define (meta-couple rendered-list failure-func let-bound bvsf)
#;(print-time "entering meta-couple")
;(printf "rendered-list ~n")
;(pretty-print (map (lambda (x) (map test-tst (car x))) rendered-list))
(if (null? rendered-list)
failure-func
;; here we erase the previously bound variables
(let* ([failed
(lambda (let-bound)
(lambda (sf bv)
((meta-couple (cdr rendered-list)
failure-func
let-bound
bvsf)
sf bvsf)))])
(couple-tests (caar rendered-list)
(cdar rendered-list) ;; successfunc needs
;; failure method
failed ;; needs let-bound
let-bound ;; initial-let bindings
)))) ;; fail-func
(require mzlib/trace)
;(trace meta-couple)
;(trace couple-tests)
)

555
collects/mzlib/private/match/ddk-handlers.ss
View File

@ -1,555 +0,0 @@
(module ddk-handlers mzscheme
(provide ddk-handlers@)
(require "match-error.ss"
"match-helper.ss"
"coupling-and-binding.scm"
"render-helpers.ss"
"render-sigs.ss"
syntax/stx
mzlib/unit
mzlib/trace)
(require-for-template mzscheme
"test-no-order.ss")
(define-unit ddk-handlers@
(import getbindings^ render-test-list^)
(export ddk-handlers^)
;;!(function handle-end-ddk-list
;; (form (handle-end-ddk-list ae kf ks pat
;; dot-dot-k
;; let-bound)
;; ->
;; ((list list) -> syntax))
;; (contract (syntax
;; ((list list) -> syntax)
;; ((list list) -> 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
;; let-bound - a list of let bindings
(define ((handle-end-ddk-list ae kf ks pat dot-dot-k let-bound cert) sf bv)
(define k (stx-dot-dot-k? dot-dot-k))
(define (ksucc sf bv)
(let ([bound (getbindings pat cert)])
(if (syntax? bound)
(kf sf bv)
(syntax-case pat (_)
[_ (ks sf bv)]
[the-pat
(null? bound)
(with-syntax ([exp-sym #'exp-sym])
(let* ([ptst (next-outer
pat
#'exp-sym
sf
bv
let-bound
(lambda (sf bv) #'#f)
(lambda (sf bv) #'#t)
cert)]
[tst (syntax-case ptst ()
[(pred eta)
(and (identifier? #'pred)
;free-identifier=?
(stx-equal? #'eta #'exp-sym))
#'pred]
[_ #`(lambda (exp-sym) #,ptst)])])
(assm #`(andmap #,tst #,(subst-bindings ae let-bound))
(kf sf bv)
(ks sf bv))))]
[id
(and (identifier? #'id) (stx-equal? #'id (car bound)))
(next-outer #'id ae sf bv let-bound kf ks cert)]
[the-pat
(let ([binding-list-names (generate-temporaries bound)]
(loop-name (gensym 'loop))
(exp-name (gensym 'exp)))
#`(let #,loop-name
((#,exp-name #,(subst-bindings ae let-bound))
#,@(map
(lambda (x)
#`(#,x '()))
binding-list-names))
(if (null? #,exp-name)
#,(ks sf (append (map cons bound
(map
(lambda (x) #`(reverse #,x))
binding-list-names))
bv))
#,(let ([new-var (gensym 'exp)])
#`(let ([#,new-var (car #,exp-name)])
#,(next-outer* #'the-pat
#`#,new-var
sf
;(append (map cons bound new-vars) bv)
bv
;; we always start
;; over with the old
;; bindings
let-bound
kf
(lambda (let-bound)
(lambda (sf bv)
;(printf "let-bound is: ~a~n" let-bound)
;(printf "bv is: ~a ~a~n"
; (map syntax-e (map car bv))
; (map syntax-object->datum (map cdr bv)))
#`(#,loop-name
(cdr #,exp-name)
#,@(map
(lambda
(b-var
bindings-var)
(subst-bindings
#`(cons
#,(get-bind-val
b-var
bv)
#,bindings-var)
let-bound))
bound binding-list-names))))
cert))))))]))))
(define (new-emit f) (emit f ae let-bound sf bv kf ksucc))
(case k
((0) (ksucc sf bv))
((1) (new-emit (lambda (exp) #`(pair? #,exp))))
(else (new-emit (lambda (exp) #`(>= (length #,exp) #,k))))))
;;!(function handle-inner-ddk-list
;; (form (handle-inner-ddk-list ae kf ks pat
;; dot-dot-k pat-rest
;; 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 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
;; let-bound - a list of let bindings
(define ((handle-inner-ddk-list ae kf ks pat dot-dot-k pat-rest let-bound cert) sf bv)
(let* ((k (stx-dot-dot-k? dot-dot-k)))
(let ((bound (getbindings pat cert)))
(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
#'exp-sym
sf
bv
let-bound
(lambda (sf bv) #'#f)
(lambda (sf bv) #'#t)
cert))
(tst (syntax-case ptst ()
((pred eta)
(and (identifier?
(syntax pred))
;free-identifier=?
(stx-equal?
(syntax eta)
(syntax exp-sym)))
(syntax pred))
(whatever
#`(lambda (exp-sym) #,ptst))))
(loop-name (gensym 'ddnnl))
(exp-name (gensym 'exp))
(count-name (gensym 'count)))
#`(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
#`#,exp-name
sf
bv
let-bound
kf
ks
cert)))
(if (zero? k)
succ
#`(if (>= #,count-name #,k)
#,succ
#,(kf sf bv)))))))))
(the-pat
(let* ([binding-list-names (generate-temporaries bound)]
(loop-name #`#,(gensym 'loop))
(exp-name #`#,(gensym 'exp))
(fail-name #`#,(gensym 'fail))
(count-name #`#,(gensym 'count))
(new-bv (append (map cons bound
(map (lambda (x) #`(reverse #,x))
binding-list-names))
bv)))
#`(let #,loop-name
((#,exp-name #,(subst-bindings ae let-bound))
(#,count-name 0)
#,@(map
(lambda (x) #`(#,x '()))
binding-list-names))
(let ((#,fail-name
(lambda ()
#,(let ((succ (next-outer
pat-rest
#`#,exp-name
sf
new-bv
let-bound
kf
ks
cert)))
(if (zero? k)
succ
#`(if (>= #,count-name #,k)
#,succ
#,(kf sf new-bv)))))))
(if (or (null? #,exp-name)
(not (pair? #,exp-name)))
(#,fail-name)
#,(next-outer #'the-pat
#`(car #,exp-name)
sf
bv ;; we always start
;; over with the old
;; bindings
let-bound
(lambda (sf bv)
#`(#,fail-name))
(lambda (sf bv)
#`(#,loop-name
(cdr #,exp-name)
(add1 #,count-name)
#,@(map
(lambda
(b-var
bindings-var)
#`(cons
#,(get-bind-val
b-var
bv)
#,bindings-var))
bound
binding-list-names)))
cert)))))))))))
;;!(function handle-ddk-vector
;; (form (handle-ddk-vector ae kf ks let-bound)
;; ->
;; ((list list) -> syntax))
;; (contract (syntax
;; ((list list) -> syntax)
;; ((list list) -> 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 ae kf ks pt let-bound cert)
(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) cert))
(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 #`(>= (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)
#`(vector-ref #,exp-name #,n)
sf
bv
let-bound
kf
(vloop (+ 1 n))
cert))
((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)))
#`(let #,vloop-name
((#,index-name (- (vector-length #,exp-name) 1))
#,@(map (lambda (x) #`(#,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)
#`(vector-ref #,exp-name #,index-name)
sf
bv ;; we alway start over
;; with the old bindings
let-bound
kf
(lambda (sf bv)
#`(#,vloop-name
(- #,index-name 1)
#,@(map
(lambda (b-var
bindings-var)
#`(cons
#,(get-bind-val
b-var
bv)
#,bindings-var))
bound
binding-list-names)))
cert))))))))
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 ae kf ks pt let-bound cert)
(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) cert)))
;; 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
#`(let ((#,exp-name #,(subst-bindings ae let-bound)))
(let ((#,length-of-vector-name (vector-length #,exp-name)))
#,(assm #`(>= #,length-of-vector-name #,minlen)
(kf sf bv)
(let ((current-index-name (gensym 'curr-ind)))
#`(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
pt
"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
#`(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)))
#`(let ((#,cindnm (add1 #,count-offset-name-passover)))
#,((vloop (+ 1 n) cindnm) sf bv))))
cert))))
((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) cert)))
(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)))
#`(let #,vloop-name
((#,count-name #,count-offset-name-passover)
#,@(map (lambda (x) #`(#,x '()))
binding-list-names))
#,(let ((fail-name (gensym 'fail))
(count-offset-name (gensym 'count-offset))
(index-name (gensym 'index))
)
#`(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
#`(vector-ref #,exp-name #,count-name)
'() ;sf
bv ;; we alway start over
;; with the old bindings
let-bound
(lambda (sf bv)
#`(#,fail-name
(- #,count-name
#,count-offset-name-passover)
#,count-name))
(lambda (sf bv)
#`(let ((arglist
(list
#,@(map
(lambda (b-var
bindings-var)
#`(cons
#,(get-bind-val
b-var
bv)
#,bindings-var))
bound
binding-list-names))))
(apply
#,vloop-name
(add1 #,count-name)
arglist)))
cert))))))))))))
sf
bv)))))))))
;; end of ddk-handlers@
)
)

113
collects/mzlib/private/match/define-struct.scm
View File

@ -1,113 +0,0 @@
(module define-struct mzscheme
(require-for-syntax "struct-helper.scm")
(provide define-struct*)
(define-syntax (define-struct* stx)
(syntax-case stx ()
[(_ type [field-decl ...] decl ...)
(let* ([field-decls (map (mk-parse-field-decl #'type) (syntax->list #'(field-decl ...)))]
[decls (map parse-decl (syntax->list #'(decl ...)))]
[info (create-info #'type decls field-decls)])
(let ([init-field-k (length (info-init-fields info))]
[auto-field-k (length (info-auto-fields info))])
#`(begin
#,(if (info-include-define-values? info)
#`(define-values #,(info-defined-names info)
(let-values
([(struct:x make-x x? x-ref x-set!)
(make-struct-type 'type
#,(info-super info)
#,init-field-k
#,auto-field-k
#,(info-auto-v info)
#,(info-props info)
#,(info-insp info)
#,(info-proc-spec info)
#,(info-imm-k-list info)
#,(info-guard info))])
(values struct:x
make-x
x?
#,@(if (info-include-x-ref? info) #'(x-ref) #'())
#,@(if (info-include-x-set!? info) #'(x-set!) #'())
#,@(map (lambda (ref-field ref-posn)
#`(make-struct-field-accessor
x-ref
#,ref-posn
'#,ref-field))
(info-ref-fields info)
(info-ref-posns info))
#,@(map (lambda (mut-field mut-posn)
#`(make-struct-field-mutator
x-set!
#,mut-posn
'#,mut-field))
(info-mut-fields info)
(info-mut-posns info)))))
#'(begin))
#,(if (info-include-replacers? info)
#`(define-struct-replacers type #,(info-name:constructor info)
#,(map field-decl-field (info-init-fields info))
#,(map field-decl-ref (info-init-fields info)))
#'(begin))
#,(if (info-include-clone? info)
(with-syntax ([(field-ref ...) (map field-decl-ref (info-init-fields info))])
#`(define (#,(datum->syntax-object #'type (sym+ 'clone- #'type)) obj)
(let ([field-ref (field-ref obj)] ...)
(#,(info-name:constructor info) field-ref ...))))
#'(begin))
#;#,(if (info-include-static-info? info)
#`(define-syntax type
(list-immutable
(quote-syntax #,(info-name:struct-record info))
(quote-syntax #,(info-name:constructor info))
(quote-syntax #,(info-name:predicate info))
(list-immutable
#,@(map (lambda (ref) #`(quote-syntax #,ref))
(info-field-refs info)))
(list-immutable
#,@(map (lambda (mut) #`(quote-syntax #,mut))
(info-field-muts info)))
;; FIXME
#t))
#'(begin)))))]))
(define-syntax (define-struct-replacers stx)
(syntax-case stx ()
[(_ type constructor (field ...) (accessor ...))
(with-syntax
([(replace ...)
(map (lambda (f) (datum->syntax-object #'type (sym+ 'replace- #'type '- f)))
(syntax->list #'(field ...)))]
[all-field-bindings #'([field (accessor obj)] ...)]
[all-fields #'(field ...)])
#'(begin (define (replace obj newval)
(let all-field-bindings
(let ([field newval])
(constructor . all-fields))))
...))]))
)
#|
(require struct)
(require mzlib/pretty)
(print-struct #t)
(define-syntax go
(syntax-rules ()
[(_ form)
(begin #;(pretty-print (syntax-object->datum (expand-once #'form)))
form)]))
(go (define-struct* A
[x (y (immutable)) (z (auto)) (w (auto))]
transparent (auto-value 'foo)))
(go (define-struct* B
[q (r (immutable)) c]
(procedure (lambda (self) (list (B-q self) (B-r self))))
transparent clone replace))
(define a1 (make-A 'athens 'sparta))
(define b1 (make-B 'three 'fifty (lambda _ 'loch-ness)))
|#

94
collects/mzlib/private/match/emit-assm.scm
View File

@ -1,94 +0,0 @@
;; This library is used by match.ss
(module emit-assm mzscheme
(provide emit assm)
(require "match-helper.ss"
"coupling-and-binding.scm")
(require-for-template mzscheme)
;;!(function emit
;; (form (emit act-test-func ae let-bound sf bv kf ks)
;; ->
;; syntax)
;; (contract ((syntax -> syntax)
;; syntax
;; list
;; list
;; list
;; (list list -> syntax)
;; (list list -> syntax))
;; ->
;; syntax))
;; emit's true function is to manage the tests-seen-so-far lists
;; it decides whether a new test needs to be added to the list
;; or whether this condition has already been tested for and if
;; it is true emit calls the success function. If it has been
;; determined to be a false property emit calls the fail function.
;; emit adds implied truths to the test seen so far list so that
;; these truths can be checked against later.
(define (emit act-test-func ae let-bound sf bv kf ks)
(let ([test (syntax-object->datum (act-test-func ae))])
(cond
[(in test sf) (ks sf bv)]
[(in `(not ,test) sf) (kf sf bv)]
[else
(let* ([pred (car test)]
[exp (cadr test)]
[implied (implied test)]
[not-imp
(if (equal? pred 'list?)
(list `(not (null? ,exp)))
'())]
[s (ks (cons test (append implied sf)) bv)]
[k (kf (cons `(not ,test) (append not-imp sf)) bv)]
[the-test (act-test-func (subst-bindings ae let-bound))])
(assm (syntax-case the-test (struct-pred)
[(struct-pred pred parent-list exp) #'(pred exp)]
[reg #'reg])
k s))])))
;;!(function assm
;; (form (assm tst main-fail main-succ) -> syntax)
;; (contract (syntax syntax syntax) -> syntax))
;; assm - this function is responsible for constructing the actual
;; if statements. It performs minor expansion optimizations.
(define (assm tst main-fail main-succ)
(node-count (add1 (node-count)))
(cond
[(stx-equal? main-succ main-fail)
(begin
(when (stx-equal? main-succ #'(match-failure))
(node-count (sub1 (node-count))))
main-succ)]
[(and (eq? (syntax-e main-succ) #t) (eq? (syntax-e main-fail) #f)) tst]
[else
(syntax-case main-succ (if
and
let/ec
lambda
let) ;free-identifier=? ;stx-equal?
[(if (and tsts ...) true-act fail-act)
(stx-equal? main-fail #'fail-act)
(quasisyntax/loc
tst
(if (and #,tst tsts ...) true-act fail-act))]
[(if tst-prev true-act fail-act)
(stx-equal? main-fail #'fail-act)
(quasisyntax/loc
tst
(if (and #,tst tst-prev) true-act fail-act))]
[(let/ec k (let ((fail (lambda () (_ f2)))) s2))
(stx-equal? main-fail #'f2)
(begin
(quasisyntax/loc
tst
(let/ec k
(let ((fail (lambda () (k #,main-fail))))
#,(assm tst (syntax/loc tst (fail)) (syntax s2))))))]
;; leaving out pattern that is never used in original
[_ (quasisyntax/loc
tst
(if #,tst #,main-succ #,main-fail))])]))
)

157
collects/mzlib/private/match/gen-match.ss
View File

@ -1,157 +0,0 @@
(module gen-match mzscheme
(provide gen-match)
(require mzlib/etc
syntax/stx
"match-helper.ss"
"match-error.ss"
"coupling-and-binding.scm"
"update-counts.scm"
"update-binding-counts.scm"
"render-test-list.scm"
"render-helpers.ss"
"reorder-tests.scm"
"tag-negate-tests.scm"
"simplify-patterns.ss"
"convert-pat.ss")
(require-for-template mzscheme
mzlib/etc
"match-error.ss")
;; mark-patlist : listof[x] -> listof[(cons x #f)]
;; This function takes each clause from the match expression and
;; pairs it with the dummy value #f. This value will be set! when
;; the pattern matcher compiles a possible successful match for
;; the clause. If it is not set to #t then the clause is
;; unreachable which is an indication of programmer error.
(define (mark-patlist clauses)
(syntax-map (lambda (x) (mcons x #f)) clauses))
;; parse-clause : syntax -> syntax syntax maybe[syntax]
;; takes in a pattern
;; returns three values representing the pattern, the body and the failure symbol
(define (parse-clause clause)
(syntax-case* clause (=>) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[(pat) (match:syntax-err clause
"missing action for pattern")]
[(pat (=> fail-sym))
(match:syntax-err clause
"missing action for pattern")]
[(pat (=> fail-sym) body ...)
(values #'pat
#'(body ...)
#'fail-sym)]
[(pat body ...)
(values #'pat
#'(body ...)
#f)]
[pat (match:syntax-err #'pat
"syntax error in clause")]))
;; test-list-with-success-func : syntax (cons syntax boolean) syntax success-func -> (cons test-list success-func)
;; This function takes an exp which is to be matched, a marked
;; clause, and a syntax-object that is for reporting errors. It
;; returns a pair the car of which is a list of test structs which
;; are in essense partially evaluated tests. The cdr of the
;; result is a function which takes a failure function and a list
;; of let-bound expressions and returns a success-function.
(define (test-list-with-success-func exp pat/mark stx success-func)
(define-values (pat body fail-sym) (parse-clause (mcar pat/mark)))
(define (success fail let-bound)
(if (not success-func)
(lambda (sf bv)
;; mark this pattern as reached
(set-mcdr! pat/mark #t)
(with-syntax ([fail-var fail-sym]
[(bound-vars ...) (map car bv)]
[(args ...) (map (lambda (b) (subst-bindings (cdr b) let-bound)) bv)]
[body body])
(if fail-sym
#`(let/ec fail-cont
(let ([fail-var (lambda () (fail-cont #,(fail sf bv)))]
[bound-vars args] ...)
. body))
#'(let ([bound-vars args] ...) . body))))
(lambda (sf bv)
;; mark this pattern as reached
(set-mcdr! pat/mark #t)
(let ((bv (map
(lambda (bind)
(cons (car bind)
(subst-bindings
(cdr bind)
let-bound)))
bv)))
(success-func sf bv)))))
(define test-list
(let* ([cert (lambda (x) x)]
[simplified-pat (simplify pat cert)])
(render-test-list simplified-pat exp cert stx)))
(cons test-list success))
;; gen-match : syntax list list syntax success-func -> syntax
;; <p>gen-match is the gateway through which match accesses the match
;; pattern compiler.
;;
;; <p>exp - the expression that is to be tested against the pattern.
;; This should normally be a piece of syntax that indirectly
;; represents the expression. Because if it is the syntax of the
;; expression itself it will be duplicated many times throughout
;; the generated match test.
;;
;; <p>tsf - is a list of tests-seen-so-far and is used to
;; prevent generating tests for the same condition twice
;;
;; <p>patlist - is a list of the pattern clauses of the match expr
;; these can be of either form (pat body ...) or
;; (pat (=> fail) body ...)
;;
;; <p>stx is the original syntax of the match expression.
;; This is only used for error reporting.
;;
;; <p>success-func - an optional argument which allows one to
;; specify how a successful match is treated. This made
;; the creation of match-letrec and match-define macros simple.
;; The reason for this function is that most of the information
;; about a match (namely the bound match variables) is at the bottom
;; of the recursion tree. The success function must take two arguments
;; and it should return a syntax object.
(define/opt (gen-match exp patlist stx [success-func #f])
(begin-with-definitions
(when (stx-null? patlist)
(match:syntax-err stx "null clause list"))
;; We set up the list of
;; clauses so that one can mark that they have been "reached".
(define marked-clauses (mark-patlist patlist))
(define failure-func #'(match-failure))
;; iterate through list and render each pattern to a list of partially compiled tests
;; and success functions.
;; These are partially compiled
;; because the test structures containa a function that needs to
;; be coupled with the other functions of the other test
;; structures before actual compilation results.
(define rendered-list (map (lambda (clause) (test-list-with-success-func
exp clause stx success-func))
marked-clauses))
(update-counts rendered-list)
(tag-negate-tests rendered-list)
(update-binding-counts rendered-list)
;; couple the partially compiled tests together into the final result.
(define compiled-exp
((meta-couple (reorder-all-lists rendered-list)
(lambda (sf bv) failure-func)
'()
'())
'() '()))
;; Also wrap the final compilation in syntax which binds the
;; match-failure function.
(define compiled-match
#`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))])
#,compiled-exp))
(unreachable marked-clauses stx)
compiled-match))
)

141
collects/mzlib/private/match/getbindings.ss
View File

@ -1,141 +0,0 @@
(module getbindings mzscheme
(provide getbindings@)
(require "coupling-and-binding.scm"
"update-binding-counts.scm"
"render-helpers.ss"
"render-sigs.ss"
mzlib/unit)
(require-for-template mzscheme)
(define-unit getbindings@
(import render-test-list^)
(export getbindings^)
;;!(function next-outer
;; (form (next-outer p ae sf bv let-bound kf ks syntax bool)
;; ->
;; syntax)
;; (contract (syntax syntax list list list (list list -> syntax)
;; (list list -> syntax) syntax bool)
;; ->
;; syntax))
;; The function next-outer is basically a throw-back to the next
;; function of the original match compiler. It compiles a pattern
;; or sub-pattern of a clause and does not yield a list of
;; partially compiled test structs. This function is called
;; inside of test constructs that cannot be eliminated because of
;; a related presence in the test-so-far list. So, instead of
;; partially compiling patterns this function fully compiles patterns.
(define/opt (next-outer
p
ae ;; this is the actual expression
sf
bv
let-bound
kf
ks
cert
[stx (syntax '())])
(next-outer-helper p ae sf bv let-bound
(lambda (x) kf) (lambda (a b) ks) cert stx))
(define/opt (next-outer*
p
ae ;; this is the actual expression
sf
bv
let-bound
kf
ks
cert
[stx (syntax '())])
(next-outer-helper p ae sf bv let-bound
(lambda (x) kf) (lambda (a b) (ks b)) cert stx))
;;!(function next-outer-helper
;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool)
;; ->
;; syntax)
;; (contract (syntax syntax list list list (list list -> syntax)
;; (list list -> syntax) syntax bool)
;; ->
;; syntax))
;; The function next-outer-helper contains the meat of next-outer
;; and allows the programmer to pass higher order functions
;; ks-func and kf-func that will be given compile time imformation
;; about let-bindings etc. which in turn will allow the programmer
;; to take advantage of this info.
(define/opt (next-outer-helper
p
ae ;; this is the actual expression
sf
bv
let-bound
kf-func
ks-func
cert
[stx (syntax '())])
;; right now this does not bind new variables
(let ((rendered-list (render-test-list p ae cert stx)))
;; no need to reorder lists although I suspect that it may be
;; better to put shape tests first
(update-binding-count rendered-list)
((couple-tests rendered-list ks-func kf-func let-bound) sf bv)))
;;!(function create-test-func
;; (form (create-test-func p sf let-bound bind-map last-test)
;; ->
;; syntax)
;; (contract (syntax list list a-list bool) -> syntax))
;; This function creates a runtime function that is used as an
;; individual test in a list of tests for the list-no-order
;; pattern.
;; <pre>
;; bindmap - a-list of bindings mapped to their expressions
;; last-test - a boolean value that indicates whether this function
;; is collecting one value or a list of values.</pre>
(define (create-test-func p sf let-bound bind-map last-test cert)
#`(lambda (exp)
#,(next-outer-helper
p #'exp sf '() let-bound
(lambda (let-bound)
(lambda (sf bv)
#'#f))
(lambda (fail let-bound)
(lambda (sf bv)
#`(begin
#,@(map (lambda (bind)
(let ((binding-name (get-bind-val (car bind) bind-map))
(exp-to-bind
(subst-bindings (cdr bind) let-bound)))
(if last-test
#`(set! #,binding-name
(cons #,exp-to-bind #,binding-name))
#`(set! #,binding-name
#,exp-to-bind))))
bv)
#t)))
cert)))
;;!(function getbindings
;; (form (getbindings pat-syntax) -> list)
;; (contract syntax -> list))
;; This function given a pattern returns a list of pattern
;; variable names which are found in the pattern.
(define (getbindings pat-syntax cert)
(let/cc out
(next-outer
pat-syntax
(quote-syntax dummy)
'()
'()
'()
(lambda (sf bv) #'(dummy-symbol))
(lambda (sf bv) (out (map car bv)))
cert)))
;; end getbindings@
)
)

82
collects/mzlib/private/match/getter-setter.scm
View File

@ -1,82 +0,0 @@
;; This library is used by match.ss
(module getter-setter mzscheme
(provide getter setter)
(require "coupling-and-binding.scm"
"match-helper.ss"
"match-error.ss"
syntax/stx)
(require-for-template mzscheme
"match-error.ss")
;;!(function setter
;; (form (setter e ident let-bound) -> syntax)
;; (contract (syntax syntax list) -> syntax)
;; (example (setter (syntax (mcar x)) (syntax here) '())
;; ->
;; (syntax (lambda (y) (set-mcar! x y)))))
;; This function takes an expression and returns syntax which
;; represents a function that is able to set the value that the
;; expression points to.
(define (setter e ident let-bound)
(define (subst e) (subst-bindings e let-bound))
(define (mk-setter s cxt) (datum->syntax-object cxt (symbol-append 'set- s '!)))
(syntax-case e (vector-ref unbox car cdr mcar mcdr)
[p
(not (stx-pair? #'p))
(match:syntax-err
ident
"set! pattern should be nested inside of a vector, box, or struct")]
[(vector-ref vector index)
#`(let ((x #,(subst #'vector)))
(lambda (y) (vector-set! x index y)))]
[(unbox boxed)
#`(let ((x #,(subst #'boxed)))
(lambda (y) (set-box! x y)))]
[(car exp)
(match:syntax-err
ident
"set! cannot be used within list")]
[(cdr exp)
(match:syntax-err
ident
"set! cannot be used within list")]
[(mcar exp)
#`(let ((x #,(subst #'exp)))
(lambda (y) (set-mcar! x y)))]
[(mcdr exp)
#`(let ((x #,(subst #'exp)))
(lambda (y) (set-mcdr! x y)))]
[(acc exp)
(let ([a (assq (syntax-object->datum #'acc) get-c---rs)])
(if a
#`(let ((x (#,(cadr a) #,(subst #'exp))))
(lambda (y) (#,(mk-setter (cddr a) #'acc) x y)))
#`(let ((x #,(subst #'exp)))
(lambda (y)
(#,(mk-setter (syntax-object->datum #'acc) #'acc) x y)))))]))
;;!(function getter
;; (form (getter e ident let-bound) -> syntax)
;; (contract (syntax syntax list) -> syntax)
;; (example (getter (syntax (car x)) (syntax here) '())
;; ->
;; (syntax (lambda () (car x)))))
;; This function takes an expression and returns syntax which
;; represents a function that is able to get the value that the
;; expression points to.
(define (getter e ident let-bound)
(define (subst e) (subst-bindings e let-bound))
(syntax-case e (vector-ref unbox car cdr)
[p
(not (stx-pair? #'p))
(match:syntax-err
ident
"get! pattern should be nested inside of a list, vector or box")]
[(vector-ref vector index)
#`(let ((x #,(subst #'vector)))
(lambda () (vector-ref x index)))]
[(acc exp)
#`(let ((x #,(subst #'exp)))
(lambda () (acc x)))]))
)

81
collects/mzlib/private/match/match-error.ss
View File

@ -1,81 +0,0 @@
(module match-error mzscheme
(provide (all-defined))
(require mzlib/pregexp)
(define-struct (exn:misc:match exn:fail) (value))
(define match:error
(case-lambda
((val)
(raise
(make-exn:misc:match
(format "match: no matching clause for ~e" val)
(current-continuation-marks)
val)))
((val expr)
(raise
(make-exn:misc:match
(format "match: no matching clause for ~e: ~s" val expr)
(current-continuation-marks)
val)))))
;;! (function match:syntax-err
;; (form (match:syntax-err object message . detail) -> void)
;; (contract (any string . any) -> void)
;; (example (match:syntax-err (syntax here) "Bad error" (vector))
;; -> void)
;; (contract object -> (normally a syntax object that
;; that helps determine the source location
;; of the error)))
;; This function is used to report malformed match expressions.
(define match:syntax-err (lambda (obj msg . detail)
(apply
raise-syntax-error
'match
msg
obj
detail)))
(define (match:internal-err obj msg . detail)
(apply raise-syntax-error '|internal match error| msg obj detail))
;;!(function unreachable
;; (form (unreachable plist match-expr) -> void)
;; (contract (list syntax-object) -> void)
;; (contract plist -> (is a list of unreached pattern clauses))
;; (contract match-expr -> (is the origional match expr
;; the clauses came from)))
;; This function takes a list of unreached clauses and the original
;; match expression and prints a warning for each of the unreached
;; match clauses to the current error port
(define unreachable
(lambda (plist match-expr)
(map
(lambda (x)
(if (not (mcdr x))
(fprintf
(current-error-port)
"Warning: unreachable match clause ~e in ~e~n"
(syntax-object->datum (mcar x))
(syntax-object->datum match-expr))))
plist)))
;; this makes pregexp errors a little more friendly
(define (pregexp-match-with-error regex str)
(if (or (string? regex)
(bytes? regex)
(regexp? regex)
(byte-regexp? regex))
(pregexp-match regex str)
(error 'match:pregex
(string-append
"this pattern expects either a string, byte string, regexp or byte regexp,"
" given " (format "~e" regex) "; "
"other argument was " (format "~e" str)))))
)

7
collects/mzlib/private/match/match-expander-struct.ss
View File

@ -1,7 +0,0 @@
(module match-expander-struct mzscheme
(require "define-struct.scm")
(provide (all-defined))
#;(provide (struct match-expander (match-xform std-xform)))
(define-struct* match-expander (plt-match-xform match-xform std-xform certifier)
(procedure-field std-xform))
)

69
collects/mzlib/private/match/match-expander.ss
View File

@ -1,69 +0,0 @@
(module match-expander mzscheme
(provide (all-defined))
(require-for-syntax "match-expander-struct.ss"
"match-error.ss")
;; (define-match-expander id [#:plt-match transformer-for-plt-match]
;; [#:match transformer-for-match]
;; [#:expression transformer-outside-of-match])
;; There is also a legacy syntax, as follows:
;; (define-match-expander id transformer-for-plt-match [[transformer-for-match] transformer-outside-of-match])
(define-syntax (define-match-expander stx)
(define (lookup v alist)
(cond [(assoc v alist) => cadr]
[else #f]))
(define (parse args)
(let loop ([args args]
[alist '()])
(if (null? args)
alist
(let* ([stx-v (car args)]
[v (syntax-e stx-v)])
(cond
[(not (keyword? v))
(match:syntax-err stx-v "Argument must be a keyword")]
[(not (member v '(#:expression #:plt-match #:match)))
(match:syntax-err stx-v "Keyword argument is not a correct keyword")]
[else
(loop (cddr args)
(cons (list v (cadr args))
alist))])))))
(syntax-case stx ()
[(_ id kw . rest)
(keyword? (syntax-e #'kw))
(let* ([args (syntax->list #'(kw . rest))]
[parsed-args (parse args)])
(with-syntax
([match-xform (lookup #:match parsed-args)]
[plt-match-xform (lookup #:plt-match parsed-args)]
[std-xform (or (lookup #:expression parsed-args)
#'(lambda (stx)
(match:syntax-err stx "This match expander must be used inside match")))])
(if (identifier? #'std-xform)
#`(define-syntax id (make-match-expander plt-match-xform
match-xform
(lambda (stx)
(syntax-case stx (set!)
#;[(set! id v) #'(set! std-xform v)]
[(nm args (... ...)) #'(std-xform args (... ...))]
[nm #'std-xform]))
(syntax-local-certifier)))
#'(define-syntax id (make-match-expander plt-match-xform match-xform std-xform (syntax-local-certifier))))))]
;; implement legacy syntax
[(_ id plt-match-xform match-xform std-xform)
#'(define-match-expander id #:plt-match plt-match-xform #:match match-xform #:expression std-xform)]
[(_ id plt-match-xform std-xform)
#'(define-match-expander id #:plt-match plt-match-xform #:expression std-xform)]
[(_ id plt-match-xform)
#'(define-match-expander id #:plt-match plt-match-xform)]
;; error checking
[_ (match:syntax-err stx "Invalid use of define-match-expander")]
))
)

482
collects/mzlib/private/match/match-helper.ss
View File

@ -1,482 +0,0 @@
(module match-helper mzscheme
(provide (all-defined)
(all-from "syntax-utils.ss"))
(require syntax/struct
"syntax-utils.ss"
"match-error.ss"
mzlib/list)
(require-for-template mzscheme)
;; define a syntax-transformer in terms of a two-argument function
(define-syntax define-proc
(syntax-rules ()
[(_ nm func)
(define-syntax (nm stx) (func stx stx))]))
;; bind an identifier to be syntax/loc with a particular location, in an expression
(define-syntax md-help
(syntax-rules ()
[(md-help id stx e)
(let-syntax ([id (syntax-rules () [(id arg) (syntax/loc stx arg)])])
e)]))
(define (constant-data? v)
(or
(string? v)
(boolean? v)
(char? v)
(number? v)
(keyword? v)
(bytes? v)))
;;!(function symbol-append
;; (form (symbol-append . args) -> symbol)
;; (contract ((symbol or number) ...) -> symbol)
;; (example (symbol-append 'hello 5 'goodbye) -> 'hello5goodbye))
;; This function takes any number of arguments which can be either
;; symbols or numbers and returns one symbol which is the
;; concatenation of the input.
(define (symbol-append . l)
(define (data->string x)
(cond
[(symbol? x) (symbol->string x)]
[(number? x) (number->string x)]
[else x]))
(string->symbol (apply string-append (map data->string l))))
;;!(function struct-pred-accessors-mutators
;; (form (struct-pred-accessors-mutators struct-name)
;; ->
;; (values pred accessors mutators parental-chain))
;; (contract (syntax-object)
;; ->
;; (values (any -> bool) list list list)))
;; This function takes a syntax-object that is the name of a structure.
;; It returns four values. The first is
;; a predicate for the structure. The second is a list of accessors
;; in the same order as the fields of the structure declaration. The
;; third is a list of mutators for the structure also in the same
;; order. The last is a list of supertypes of this struct. An
;; error is raised if the struct-name is not bound to a
;; structure.
(define (struct-pred-accessors-mutators struct-name)
(define accessors-index 3)
(define mutators-index 4)
(define pred-index 2)
(define super-type-index 5)
(define (failure-thunk)
(match:syntax-err struct-name
"not a defined structure"))
(define (local-val sn) (syntax-local-value sn failure-thunk))
;; accessor/mutator lists are stored in reverse order, and can contain #f
;; we only filter out a mutator if the accessor is also false.
;; this function returns 2 lists of the same length if the inputs were the same length
(define (handle-acc/mut-lists accs muts)
(let*-values ([(filtered-lists) (filter (lambda (x) (car x)) (map list accs muts))]
[(accs muts) (values (map car filtered-lists)
(map cadr filtered-lists))])
(values (reverse accs)
(reverse muts))))
;; this produces a list of all the super-types of this struct
;; ending when it reaches the top of the hierarchy, or a struct that we can't access
(define (get-lineage struct-name)
(let ([super (list-ref
(extract-struct-info (local-val struct-name))
super-type-index)])
(cond [(equal? super #t) '()] ;; no super type exists
[(equal? super #f) '()] ;; super type is unknown
[else (cons super (get-lineage super))])))
(define info-on-struct (let ([v (local-val struct-name)])
(unless (struct-declaration-info? v)
(failure-thunk))
(extract-struct-info v)))
(define (ref-info i) (list-ref info-on-struct i))
(let*-values ([(acc-list) (ref-info accessors-index)]
[(mut-list) (ref-info mutators-index)]
[(pred) (ref-info pred-index)]
[(accessors mutators) (handle-acc/mut-lists acc-list mut-list)]
[(parental-chain) (get-lineage struct-name)])
(values pred accessors mutators (cons struct-name parental-chain)))
)
;;!(function in
;; (form (in e l) -> bool)
;; (contract (s-exp list) -> bool)
;; (example (in '(number? x) (list '(number? x))) -> #t))
;; This function is responsible for determining which tests are
;; redundant. If e can be determined to be true from the list of
;; tests l then e is "in" l.
(define (in e l)
(or
(ormap
(lambda (el)
(or (equal? e el)
(and
(eq? (car e) 'struct-pred)
(eq? (car el) 'struct-pred)
(member (caaddr e) (caddr el))
(equal? (cadddr e) (cadddr el))))) l)
(and (eq? (car e) 'not)
(let* ((srch (cadr e))
(const-class (equal-test? srch)))
;(write srch)
(cond
((equal? (car srch) 'struct-pred)
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(if (and (equal? (car x)
'struct-pred)
(not (equal? (cadr x) (cadr srch)))
; the current struct type should not
; be a member of the parental-chain of
(not (member (caaddr x) (caddr srch)))
(equal? (cadddr x) (cadddr srch)))
#t
(mem (cdr l)))))))
(const-class
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (equal?
(cadr x)
(cadr srch))
(disjoint? x)
(not (equal?
const-class
(car x))))
(equal?
x
`(not (,const-class
,(cadr srch))))
(and (equal?
(cadr x)
(cadr srch))
(equal-test?
x)
(not (equal?
(caddr
srch)
(caddr
x))))
(mem (cdr l)))))))
((disjoint? srch)
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (disjoint? x)
(not (equal?
(car x)
(car srch)))
(cond ((equal?
(car srch)
'struct-pred)
(equal?
(cadr x)
;; we use cadddr here to access the expression
;; because struct predicates carry some extra baggage
;; They have the form (struct-pred <predicate> <list of super types> <exp>)
(cadddr srch)))
((equal?
(car x)
'struct-pred)
(equal?
(cadr srch)
;; we use cadddr here to access the expression
;; because struct predicates carry some extra baggage
(cadddr x)))
(else (equal?
(cadr x)
(cadr srch)))))
(mem (cdr l)))))))
((eq? (car srch) 'list?)
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (equal?
(cadr x)
(cadr srch))
(disjoint?
x)
(not (memq (car x)
'(list?
pair?
null?))))
(mem (cdr l)))))))
((vec-structure? srch)
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (equal?
(cadr x)
(cadr srch))
(or (disjoint?
x)
(vec-structure?
x))
(not (equal?
(car x)
'vector?))
(not (equal?
(car x)
(car srch))))
(equal?
x
`(not (vector?
,(cadr srch))))
(mem (cdr l)))))))
(else #f))))))
;;!(function equal-test?
;; (form (equal-test? tst) -> (or symbol
;; #f))
;; (contract s-exp -> (or symbol
;; #f))
;; (example (equal-test? '(equal? x 5))
;; -> 'number?)
;; (example (equal-test? '(symbol? x))
;; -> #f))
;; This function returns false if the s-exp does not represent an
;; "equal?" test. If it does then this function returns a
;; predicate for the data type that the test is testing.
(define (equal-test? tst)
(and (eq? (car tst) 'equal?)
(let ((p (caddr tst)))
(cond
((string? p) 'string?)
((boolean? p) 'boolean?)
((char? p) 'char?)
((number? p) 'number?)
((and (pair? p)
(pair? (cdr p))
(null? (cddr p))
(eq? 'quote (car p))
(symbol? (cadr p))) 'symbol?)
(else #f)))))
(define match:disjoint-predicates
'(struct-pred null? pair? symbol? boolean? number? string? char?
procedure? vector?
box? promise?))
(define match:vector-structures '())
;;!(function disjoint?
;; (form (disjoint? tst))
;; (contract s-exp -> bool)
;; (example (disjoint? 'pair?) -> #t))
;; This function retirns true if the predicate is disjoint.
(define (disjoint? tst)
(memq (car tst) match:disjoint-predicates))
(define (vec-structure? tst)
(memq (car tst) match:vector-structures))
;;!(function add-a
;; (form (add-a exp-syntax) -> syntax)
;; (contract syntax -> syntax)
;; (example (add-a (syntax (cdr x))) -> (syntax (cadr x))))
;; Add car operation, ie. given (c...r x), return (ca...r x).
(define add-a
(lambda (exp-syntax)
(syntax-case exp-syntax ()
((car-thing exp)
(let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
(if new
(quasisyntax/loc exp-syntax (#,(cadr new) exp))
(syntax/loc exp-syntax (car (car-thing exp))))))
(exp (syntax/loc exp-syntax (car exp))))))
;;!(function add-d
;; (form (add-d exp-syntax) -> syntax)
;; (contract syntax -> syntax)
;; (example (add-a (syntax (cdr x))) -> (syntax (cddr x))))
;; Add cdr operation, ie. given (c...r x), return (cd...r x).
(define add-d
(lambda (exp-syntax)
(syntax-case exp-syntax ()
((car-thing exp)
(let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
(if new
(quasisyntax/loc exp-syntax (#,(cddr new) exp))
(syntax/loc exp-syntax (cdr (car-thing exp))))))
(exp (syntax/loc exp-syntax (cdr exp))))))
(define c---rs '((car caar . cdar)
(cdr cadr . cddr)
(caar caaar . cdaar)
(cadr caadr . cdadr)
(cdar cadar . cddar)
(cddr caddr . cdddr)
(caaar caaaar . cdaaar)
(caadr caaadr . cdaadr)
(cadar caadar . cdadar)
(caddr caaddr . cdaddr)
(cdaar cadaar . cddaar)
(cdadr cadadr . cddadr)
(cddar caddar . cdddar)
(cdddr cadddr . cddddr)))
(define get-c---rs '((caar car . car)
(cadr cdr . car)
(cdar car . cdr)
(cddr cdr . cdr)
(caaar caar . car)
(caadr cadr . car)
(cadar cdar . car)
(caddr cddr . car)
(cdaar caar . cdr)
(cdadr cadr . cdr)
(cddar cdar . cdr)
(cdddr cddr . cdr)
(caaaar caaar . car)
(caaadr caadr . car)
(caadar cadar . car)
(caaddr caddr . car)
(cadaar cdaar . car)
(cadadr cdadr . car)
(caddar cddar . car)
(cadddr cdddr . car)
(cdaaar caaar . cdr)
(cdaadr caadr . cdr)
(cdadar cadar . cdr)
(cdaddr caddr . cdr)
(cddaar cdaar . cdr)
(cddadr cdadr . cdr)
(cdddar cddar . cdr)
(cddddr cdddr . cdr)))
;;!(function stx-dot-dot-k?
;; (form (stx-dot-dot-k? syn) -> bool)
;; (contract syntax -> bool)
;; (example (stx-dot-dot-k? (syntax ..3)) -> #t))
;; This function is a predicate that returns true if the argument
;; is syntax represents a ... or ___ syntax where the last dot or
;; underscore can be an integer
(define stx-dot-dot-k?
(lambda (syn)
(dot-dot-k? (syntax-object->datum syn))))
;;!(function implied
;; (form (implied test) -> list)
;; (contract s-exp -> list))
;; This function is given a s-expression for a test and returns a
;; list of tests that are implied by that test. The implied test
;; would have to be true if the argument is true.
(define (implied test)
(let* ((pred (car test))
(exp (cadr test)))
(cond
((equal? pred 'equal?)
(let ((ex (caddr test)))
(cond ((string? ex)
(list `(string? ,ex)))
((boolean? ex)
(list `(boolean? ,exp)))
((char? ex)
(list `(char? ,exp)))
((number? ex)
(list `(number? ,exp)))
((and (pair? ex)
(eq? 'quote (car ex)))
(list `(symbol? ,exp)))
(else '()))))
((equal? pred 'null?)
(list `(list? ,exp)))
(else '()))))
;;! (function pattern-var?
;; (form (pattern-var? pattern-element) -> bool)
;; (contract syntax -> bool)
;; (example (pattern-var? #'x) -> #t)
;; )
;; This function takes a syntax object and determines if it
;; qualifies as a pattern variable.
(define (pattern-var? x)
(let ([x (syntax-object->datum x)])
(and (symbol? x)
(not (dot-dot-k? x))
(not (memq x '(_
quasiquote
quote
unquote
unquote-splicing
; hash-table
; list-no-order
; list-rest
; list
; app
; struct
; var
; vector
; box
; ?
; and
; or
; not
; set!
; get!
))))))
;;!(function dot-dot-k?
;; (form (dot-dot-k? s) -> bool)
;; (contract any -> bool)
;; (example (dot-dot-k? '..3) -> 3))
;; This function is a predicate that returns the number of elements required
;; by the pattern
;; (dot-dot-k? '..3) -> 3
;; (dot-dot-k? '...) -> 0
(define (dot-dot-k? s)
(define (./_ c)
(or (equal? c #\.)
(equal? c #\_)))
(and (symbol? s)
(if (memq s '(... ___)) 0
(let* ((s (symbol->string s)))
(and (<= 3 (string-length s))
(./_ (string-ref s 0))
(./_ (string-ref s 1))
(string->number
(substring s 2)))))))
(define node-count (make-parameter 0))
(define convert-patterns? (make-parameter #f))
(define match-equality-test (make-parameter equal?))
;; a helper for timing testing
(define-values (print-time initer)
(let* ((t (current-milliseconds))
(orig t))
(values
(lambda (msg)
(void)
#;(let ((t* (current-milliseconds)))
(printf "~a: (total: ~a real: ~a diff: ~a)~n" msg (- t* orig) t* (- t* t))
(set! t t*)))
(lambda () (void)#;(set! t (current-milliseconds)) #;(set! orig t)))))
)

104
collects/mzlib/private/match/match-internal-func.ss
View File

@ -1,104 +0,0 @@
(module match-internal-func mzscheme
(provide (all-defined))
(require-for-syntax "gen-match.ss"
"match-helper.ss"
"match-error.ss")
(require mzlib/etc
mzlib/list
"match-expander.ss"
"match-error.ss")
(define-syntax (match stx)
(syntax-case stx ()
[(_ exp . clauses)
(with-syntax ([body (gen-match #'x #'clauses stx)])
(syntax/loc stx (let ([x exp]) body)))]))
(define-syntax (match-lambda stx)
(syntax-case stx ()
[(k . clauses)
(syntax/loc stx (lambda (exp) (match exp . clauses)))]))
(define-syntax (match-lambda* stx)
(syntax-case stx ()
[(k . clauses)
(syntax/loc stx (lambda exp (match exp . clauses)))]))
;; there's lots of duplication here to handle named let
;; some factoring out would do a lot of good
(define-syntax (match-let stx)
(syntax-case stx ()
;; an empty body is an error
[(_ nm (clauses ...))
(identifier? #'nm)
(match:syntax-err stx "bad syntax (empty body)")]
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
;; with no bindings, there's nothing to do
[(_ name () body ...)
(identifier? #'name)
(syntax/loc stx (let name () body ...))]
[(_ () body ...) (syntax/loc stx (let () body ...))]
;; optimize the all-variable case
[(_ ([pat exp]...) body ...)
(andmap pattern-var? (syntax->list #'(pat ...)))
(syntax/loc stx (let name ([pat exp] ...) body ...))]
[(_ name ([pat exp]...) body ...)
(and (identifier? (syntax name))
(andmap pattern-var? (syntax->list #'(pat ...))))
(syntax/loc stx (let name ([pat exp] ...) body ...))]
;; now the real cases
[(_ name ([pat exp] ...) . body)
(syntax/loc stx (letrec ([name (match-lambda* ((list pat ...) . body))])
(name exp ...)))]
[(_ ([pat exp] ...) . body)
(syntax/loc stx (match (list exp ...) [(list pat ...) . body]))]))
(define-syntax (match-let* stx)
(syntax-case stx ()
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
((_ () body ...)
(syntax/loc stx (let* () body ...)))
((_ ([pat exp] rest ...) body ...)
(if (pattern-var? (syntax pat))
(syntax/loc stx (let ([pat exp])
(match-let* (rest ...) body ...)))
(syntax/loc stx (match exp [pat (match-let* (rest ...) body ...)]))))
))
(define-syntax (match-letrec stx)
(syntax-case stx ()
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
[(_ ([pat exp] ...) . body)
(andmap pattern-var?
(syntax->list #'(pat ...)))
(syntax/loc stx (letrec ([pat exp] ...) . body))]
[(_ ([pat exp] ...) . body)
(syntax/loc stx (let ()
(match-define (list pat ...) (list exp ...))
. body))]))
(define-syntax (match-define stx)
(syntax-case stx ()
[(_ pat exp)
(identifier? #'pat)
(syntax/loc stx (define pat exp))]
[(_ pat exp)
(let ([**match-bound-vars** '()])
(with-syntax ([compiled-match
(gen-match #'the-exp
#'((pat never-used))
stx
(lambda (sf bv)
(set! **match-bound-vars** bv)
(with-syntax ([((vars . vals) ...) (reverse bv)])
#'(values vals ...))))]
[(vars ...) (map car (reverse **match-bound-vars**))])
(syntax/loc stx
(define-values (vars ...)
(let ([the-exp exp])
compiled-match)))))]))
)

43
collects/mzlib/private/match/observe-step.ss
View File

@ -1,43 +0,0 @@
(module observe-step mzscheme
(provide observe-step)
(define current-expand-observe
(dynamic-require ''#%expobs 'current-expand-observe))
(define (observe-step pre mpre mpost post)
(define (call-obs ev . args)
(let ([obs values #;(current-expand-observe)])
(if obs
(let ([evn (case ev
[(visit) 0]
[(enter-prim) 6]
[(prim-stop) 100]
[(exit-prim) 7]
[(return) 2]
[(macro-enter) 8]
[(macro-exit) 9]
[(macro-pre) 21]
[(macro-post) 22]
[(local-enter) 130]
[(local-exit) 131]
[(local-pre) 132]
[(local-post) 133])])
(apply obs evn args)))))
(call-obs 'local-enter pre)
(call-obs 'local-pre pre)
(call-obs 'visit pre)
(call-obs 'macro-enter pre)
(call-obs 'macro-pre mpre)
(call-obs 'macro-post mpost)
(call-obs 'macro-exit post)
(call-obs 'visit post)
(call-obs 'enter-prim post)
(call-obs 'prim-stop #f)
(call-obs 'exit-prim post)
(call-obs 'return post)
(call-obs 'local-post post)
(call-obs 'local-exit post)
)
)

135
collects/mzlib/private/match/parse-quasi.scm
View File

@ -1,135 +0,0 @@
;; This library is used by match.ss
(module parse-quasi mzscheme
(provide (all-defined))
(require "match-error.ss"
"match-helper.ss"
mzlib/etc
syntax/stx)
(require-for-template mzscheme
"match-error.ss")
;; Raise an error from a quasi-pattern
(define q-error
(opt-lambda (syn [msg ""])
(match:syntax-err
syn
(string-append "syntax error in quasi-pattern: " msg))))
;;!(function parse-quasi
;; (form (parse-quasi syn) -> syntax)
;; (contract syntax -> syntax))
;; This function parses a quasi pattern in to a regular pattern
;; and returns it. This function does not parse the quasi pattern
;; recursively in order to find nested quasi patterns. It only
;; parses the top quasi pattern.
(define (parse-quasi stx)
(define parse-q
(lambda (phrase)
;(write phrase)(newline)
(syntax-case phrase (quasiquote unquote unquote-splicing)
(p
(let ((pat (syntax-object->datum (syntax p))))
(or (constant-data? pat)
(dot-dot-k? pat)))
(syntax p))
(p
(stx-null? (syntax p))
(syntax/loc stx (list)))
(p
;; although it is not in the grammer for quasi patterns
;; it seems important to not allow unquote splicing to be
;; a symbol in this case `,@(a b c). In this unquote-splicing
;; is treated as a symbol and quoted to be matched.
;; this is probably not what the programmer intends so
;; it may be better to throw a syntax error
(identifier? (syntax p))
(syntax/loc stx 'p))
;; ((var p) ;; we shouldn't worry about this in quasi-quote
;; (identifier? (syntax p))
;; (syntax/loc phrase 'p))
(,p (syntax p))
(,@pat
(q-error (syntax ,@pat) "unquote-splicing not nested in list"))
((x . y)
(let* ([list-type 'list]
[result
(let loop
((l (syntax-e (syntax (x . y)))))
;(write l)(newline)
(cond [(null? l) '()]
[(and (stx-pair? (car l))
(equal? (car (syntax-object->datum (car l)))
'unquote-splicing))
(let ([first-car
(syntax-case (car l)
(unquote-splicing quasiquote)
[,@(q p) ;; have to parse forward here
(or (module-identifier=? #'quasiquote #'q)
(module-identifier=? #'quote #'q))
(let ((pq (parse-q (syntax p))))
(if (stx-list? pq)
(cdr (syntax->list pq))
(begin
(q-error (syntax ,@`p)
"unquote-splicing not followed by list"))))]
[,@p
(if (and (stx-list? (syntax p))
(memq (syntax-e (car (syntax->list #'p))) '(list list-rest)))
(cdr (syntax->list (syntax p)))
(begin ; (write (syntax-e (syntax p)))
(q-error (syntax ,@p)
"unquote-splicing not followed by list")))])])
(syntax-case (cdr l) (unquote unquote-splicing)
[,@p (q-error (syntax ,@p)
"unquote-splicing can not follow dot notation")]
[,p
(let ((res (parse-q (syntax ,p))))
(set! list-type 'list-rest)
`(,@first-car ,res))]
[p (or (stx-pair? (syntax p))
(stx-null? (syntax p)))
(append first-car
(loop (syntax-e (syntax p))))]
[p ;; must be an atom
(let ([res (parse-q (syntax p))])
(set! list-type 'list-rest)
`(,@first-car ,res))]))]
[else
(syntax-case (cdr l) (unquote unquote-splicing)
(,@p (q-error (syntax p)
"unquote-splicing can not follow dot notation"))
(,p (begin
(set! list-type 'list-rest)
(list (parse-q (car l))
(parse-q (syntax ,p)))))
(p (or (stx-pair? (syntax p))
(stx-null? (syntax p)))
(cons (parse-q (car l))
(loop (syntax-e (syntax p)))))
(p ;; must be an atom
(begin
(set! list-type 'list-rest)
(list (parse-q (car l))
(parse-q (syntax p))))))]))])
(quasisyntax/loc stx (#,list-type #,@result))))
(p
(vector? (syntax-object->datum (syntax p)))
(quasisyntax/loc
stx
(vector #,@(cdr
(syntax-e
(parse-q
(quasisyntax/loc
stx
#,(vector->list (syntax-e (syntax p))))))))))
(p
(box? (syntax-object->datum (syntax p)))
(quasisyntax/loc
stx
(box #,(parse-q (unbox (syntax-e (syntax p)))))))
(p (q-error (syntax p))))))
(parse-q stx))
)

171
collects/mzlib/private/match/render-helpers.ss
View File

@ -1,171 +0,0 @@
(module render-helpers mzscheme
(provide (all-defined))
(require "match-helper.ss"
"match-error.ss"
"emit-assm.scm"
"getter-setter.scm"
"parse-quasi.scm"
"test-structure.scm"
mzlib/etc
mzlib/trace)
(require-for-template mzscheme
mzlib/list
"match-error.ss")
(provide (all-from "emit-assm.scm")
(all-from "getter-setter.scm")
(all-from "parse-quasi.scm"))
(define-syntax define/opt
(syntax-rules ()
[(_ (nm args ...) body ...)
(define nm (opt-lambda (args ...) body ...))]))
(define (append-if-necc sym stx)
(syntax-case stx ()
[() #'(list)]
[(a ...) #`(#,sym a ...)]
[p #'p]))
(define (get-bind-val b-var bv-list)
(cond [(assq b-var bv-list) => cdr]
[(assq
(syntax-object->datum b-var)
(map (lambda (x)
(cons
(syntax-object->datum (car x)) (cdr x)))
bv-list))
=> cdr]
[else (error 'var-not-found)]))
;;!(function proper-hash-table-pattern?
;; (form (proper-hash-table-pattern? pat-list) -> bool)
;; (contract list-of-syntax -> bool))
;; This function returns true if there is no ddk in the list of
;; patterns or there is only a ddk at the end of the list.
(define (proper-hash-table-pattern? pat-list)
(cond ((null? pat-list) #t)
(else
(let ((ddk-list (ddk-in-list? pat-list)))
(or (not ddk-list)
(and ddk-list
(ddk-only-at-end-of-list? pat-list)))))))
;;!(function ddk-in-list?
;; (form (ddk l) -> bool)
;; (contract list-of-syntax -> bool))
;; This is a predicate that returns true if there is a ddk in the
;; list.
(define (ddk-in-list? l)
(not (andmap (lambda (x) (not (stx-dot-dot-k? x))) l)))
;;!(function ddk-only-at-end-of-list?
;; (form (ddk-only-at-end-of-list? l) -> bool)
;; (contract list-of-syntax -> bool))
;; This is a predicate that returns true if there is a ddk at the
;; end of the list and the list has at least one item before the ddk.
(define ddk-only-at-end-of-list?
(lambda (l)
'(match
l
(((not (? stx-dot-dot-k?)) ..1 a) (stx-dot-dot-k? a)))
(let ((x l))
(if (list? x)
(let ddnnl26305 ((exp26306 x) (count26307 0))
(if (and (not (null? exp26306))
((lambda (exp-sym) (if (stx-dot-dot-k? exp-sym) #f #t))
(car exp26306)))
(ddnnl26305 (cdr exp26306) (add1 count26307))
(if (>= count26307 1)
(if (and (pair? exp26306) (null? (cdr exp26306)))
((lambda (a) (stx-dot-dot-k? a)) (car exp26306))
#f)
#f)))
#f))))
;;!(function ddk-only-at-end-of-vector?
;; (form (ddk-only-at-end-of-vector? vec) -> bool)
;; (contract vector -> bool))
;; This is a predicate that returns true if there is a ddk at the
;; end of the vector and the list has at least one item before the ddk.
(define ddk-only-at-end-of-vector?
(lambda (vec)
'(match
vec
(#((not (? stx-dot-dot-k?)) ..1 a) #t))
;; the following is expanded from the above match expression
(let ((x vec))
(let ((match-failure
(lambda () #f)))
(if (vector? x)
(let ((lv32956 (vector-length x)))
(if (>= lv32956 2)
(let ((curr-ind32957 0))
(let vloop32958 ((count32959 curr-ind32957))
(let ((fail32961
(lambda (count-offset32962 index32963)
(if (>= count-offset32962 1)
(if (= index32963 lv32956)
(match-failure)
(let ((cindnm32965 (add1 index32963)))
(if (>= cindnm32965 lv32956)
((lambda (a) #t)
(vector-ref x index32963))
(match-failure))))
(match-failure)))))
(if (= lv32956 count32959)
(fail32961 (- count32959 curr-ind32957) count32959)
(if (stx-dot-dot-k? (vector-ref x count32959))
(fail32961 (- count32959 curr-ind32957)
count32959)
(let ((arglist (list)))
(apply vloop32958 (add1 count32959)
arglist)))))))
(match-failure)))
(match-failure))))))
;;!(function ddk-in-vec?
;; (form (ddk-in-vec? vec stx) -> (integer or #f))
;; (contract (vector syntax) -> (integer or bool)))
;; this function returns the total of the k's in a vector of syntax
;; it also insure that the ..k's are not consecutive
(define ddk-in-vec?
(lambda (vec stx)
;; make sure first element is not ddk
(if (stx-dot-dot-k? (vector-ref vec 0))
(match:syntax-err
stx
"vector pattern cannot start with ..k syntax")
(let ((vlength (vector-length vec))
(flag #f))
(letrec ((check-vec
(lambda (last-stx index)
(if (= index vlength)
0
(let ((k-prev (stx-dot-dot-k? last-stx))
(k-curr (stx-dot-dot-k? (vector-ref vec
index))))
(cond
((and k-prev k-curr)
(match:syntax-err
stx
"consecutive ..k markers are not allowed"))
(k-curr
(begin
(set! flag #t)
(+ (- k-curr 2) (check-vec (vector-ref vec
index)
(add1 index)))))
(else
(check-vec (vector-ref vec index)
(add1 index)))))))))
(let ((res (check-vec (vector-ref vec 0) 1)))
(if flag res #f)))))))
)

12
collects/mzlib/private/match/render-sigs.ss
View File

@ -1,12 +0,0 @@
(module render-sigs mzscheme
(require mzlib/unit)
(provide (all-defined))
(define-signature render-test-list^ (render-test-list))
(define-signature ddk-handlers^ (handle-end-ddk-list handle-inner-ddk-list handle-ddk-vector handle-ddk-vector-inner))
(define-signature getbindings^ (getbindings create-test-func next-outer next-outer*))
)

616
collects/mzlib/private/match/render-test-list-impl.ss
View File

@ -1,616 +0,0 @@
(module render-test-list-impl mzscheme
(require syntax/stx)
(require "match-error.ss"
"match-helper.ss"
"test-structure.scm"
"coupling-and-binding.scm"
"update-counts.scm"
"update-binding-counts.scm"
"reorder-tests.scm"
"match-expander-struct.ss"
"render-helpers.ss")
(require "render-sigs.ss"
mzlib/unit)
(require-for-syntax "match-helper.ss"
"match-expander-struct.ss"
"test-no-order.ss")
(require-for-template mzscheme
"match-error.ss"
"test-no-order.ss"
"match-helper.ss")
(provide render-test-list@)
(define-unit render-test-list@
(import ddk-handlers^ getbindings^)
(export render-test-list^)
;; some convenient syntax for make-reg-test and make-shape-test
(define make-test-gen
(case-lambda
[(constructor test ae emitter) (make-test-gen constructor test ae emitter ae)]
[(constructor test ae emitter ae2)
(constructor test ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit emitter ae2 let-bound sf bv kf ks))))]))
(define (reg-test . args) (apply make-test-gen make-reg-test args))
(define (shape-test . args) (apply make-test-gen make-shape-test args))
;; produce a matcher for the empty list
(define (emit-null ae)
(list (reg-test `(null? ,(syntax-object->datum ae))
ae (lambda (exp) #`(null? #,exp)))))
;; generic helper for producing set/get matchers
(define-syntax (set/get-matcher stx)
(syntax-case stx (set! get!)
[(_ set!/get! ae p arg set/get-func) #`(set/get-matcher set!/get! ae p let-bound arg set/get-func)]
[(_ set!/get! ae p let-bound arg set/get-func)
(with-syntax ([sym (syntax-case #'set!/get! (set! get!) ['set! #''set!-pat] ['get! #''get!-pat])])
#`(syntax-case arg ()
[(ident)
(identifier? #'ident)
(list (make-act
sym
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(ks sf (cons (cons #'ident
set/get-func)
bv))))))]
[() (match:syntax-err p
(format "there should be an identifier after ~a in pattern" set!/get!))]
[(_) (match:syntax-err p
(format " ~a followed by something that is not an identifier" set!/get!))]
[(_ (... ...))
(match:syntax-err p
(format "there should be only one identifier after ~a in pattern" set!/get!))]
[_ (match:syntax-err p
(format "invalid ~a pattern syntax" set!/get!))]))]))
;;!(function or-gen
;; (form (or-gen exp orpatlist sf bv ks kf let-bound)
;; ->
;; syntax)
;; (contract (syntax list list list (list list -> syntax)
;; (list list -> syntax) list)
;; ->
;; syntax))
;; The function or-gen is very similar to the function gen except
;; that it is called when an or pattern is compiled. An or
;; pattern is essentially the same as a match pattern with several
;; clauses. The key differences are that it exists within a
;; larger pattern and the state of compilation has information
;; that will help optimaize its compilation. And the success of
;; any pattern results in the same outcome.
(define (or-gen exp orpatlist sf bv ks kf let-bound cert stx)
(define rendered-list
(map
(lambda (pat)
(cons (render-test-list pat exp cert stx)
(lambda (fail let-bound)
(lambda (sf bv)
(let ((bv (map
(lambda (bind)
(cons (car bind)
(subst-bindings (cdr bind)
let-bound)))
bv)))
(ks sf bv))))))
orpatlist))
(update-counts rendered-list)
(update-binding-counts rendered-list)
((meta-couple (reorder-all-lists rendered-list) kf let-bound bv) sf bv))
;;!(function render-test-list
;; (form (render-test-list p ae stx) -> test-list)
;; (contract (syntax syntax syntax) -> list))
;; This is the most important function of the entire compiler.
;; This is where the functionality of each pattern is implemented.
;; This function maps out how each pattern is compiled. While it
;; only returns a list of tests, the comp field of those tests
;; contains a function which inturn knows enough to compile the
;; pattern.
;; <p>This is implemented in what Wright terms as mock-continuation-passing
;; style. The functions that create the syntax for a match success and failure
;; are passed forward
;; but they are always called in emit. This is extremely effective for
;; handling the different structures that are matched. This way we can
;; specify ahead of time how the rest of the elements of a list or vector
;; should be handled. Otherwise we would have to pass more information
;; forward in the argument list of next and then test for it later and
;; then take the appropriate action. To understand this better take a
;; look at how proper and improper lists are handled.
(define/opt (render-test-list p ae cert [stx #'here])
(define ae-datum (syntax-object->datum ae))
(syntax-case*
p
(_ list quote quasiquote vector box ? app and or not struct set! var
list-rest get! ... ___ unquote unquote-splicing cons
list-no-order hash-table regexp pregexp cons) stx-equal?
;; this is how we extend match
[(expander args ...)
(and (identifier? #'expander)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(let* ([expander (syntax-local-value (cert #'expander))]
[transformer (match-expander-plt-match-xform expander)])
(if (not transformer)
(match:syntax-err #'expander
"This expander only works with standard match.")
(let ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)])
(render-test-list
(introducer (transformer (introducer p)))
ae
(lambda (id)
(certifier (cert id) #f introducer))
stx))))]
;; underscore is reserved to match anything and bind nothing
(_ '()) ;(ks sf bv let-bound))
;; for variable patterns, we do bindings, and check if we've seen this variable before
((var pt)
(identifier? (syntax pt))
(list (make-act `bind-var-pat
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(cond [(ormap (lambda (x)
(if (bound-identifier=? #'pt (car x))
(cdr x)
#f))
bv)
=> (lambda (bound-exp)
(emit (lambda (exp)
#`((match-equality-test) #,exp #,(subst-bindings bound-exp let-bound)))
ae
let-bound
sf bv kf ks))]
[else
(ks sf (cons (cons (syntax pt) ae) bv))]))))))
;; Recognize the empty list
((list) (emit-null ae))
;; This recognizes constants such strings
[pt
(constant-data? (syntax-e #'pt))
(list
(reg-test
`(equal? ,ae-datum
,(syntax-object->datum (syntax pt)))
ae (lambda (exp) #`(equal? #,exp pt))))]
;(pt
; (stx-? regexp? (syntax pt))
; (render-test-list (syntax/loc p (regex pt)) ae stx))
;; match a quoted datum
;; this is very similar to the previous pattern, except for the second argument to equal?
[(quote item)
(list
(reg-test
`(equal? ,ae-datum
,(syntax-object->datum p))
ae (lambda (exp) #`(equal? #,exp #,p))))]
;; check for predicate patterns
;; could we check to see if a predicate is a procedure here?
[(? pred?)
(list (reg-test
`(,(syntax-object->datum #'pred?)
,ae-datum)
ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))]
;; app patterns just apply their operation.
((app op pat)
(render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx))
[(and . pats) (apply
append
(map (lambda (pat) (render-test-list pat ae cert stx))
(syntax->list #'pats)))]
((or . pats)
(list (make-act
'or-pat ;`(or-pat ,ae-datum)
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(or-gen ae (syntax-e #'pats)
sf bv ks kf let-bound
cert stx))))))
((not pat)
(list (make-act
'not-pat ;`(not-pat ,ae-datum)
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
;; swap success and fail
(next-outer #'pat ae sf bv let-bound ks kf cert))))))
;; could try to catch syntax local value error and rethrow syntax error
((list-no-order pats ...)
(if (stx-null? (syntax (pats ...)))
(render-test-list #'(list) ae cert stx)
(let* ((pat-list (syntax->list (syntax (pats ...))))
(ddk-list (ddk-in-list? pat-list))
(ddk (ddk-only-at-end-of-list? pat-list)))
(if (or (not ddk-list)
(and ddk-list ddk))
(let* ((bound (getbindings (append-if-necc 'list
(syntax (pats ...)))
cert))
(bind-map
(map (lambda (x)
(cons x #`#,(gensym (syntax-object->datum x))))
bound)))
(list
(shape-test
`(list? ,ae-datum)
ae (lambda (exp) #`(list? #,exp)))
(make-act
'list-no-order
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(let ((last-test
(if ddk
(let ((pl (cdr (reverse pat-list))))
(begin
(set! pat-list (reverse (cdr pl)))
(create-test-func (car pl)
sf
let-bound
bind-map
#t
cert)))
#f)))
#`(let #,(map (lambda (b)
#`(#,(cdr b) '()))
bind-map)
(let ((last-test #,last-test)
(test-list
(list
#,@(map (lambda (p)
(let ([v (create-test-func
p
sf
let-bound
bind-map
#f
cert)])
(printf "~s ~s ~s\n"
(syntax-object->datum p)
(syntax-object->datum v)
(continuation-mark-set->context
(current-continuation-marks)))
v))
pat-list))))
(if (match:test-no-order test-list
#,ae
last-test
#,ddk)
#,(ks sf (append bind-map bv))
#,(kf sf bv))))))))))
(match:syntax-err
p
(string-append "dot dot k can only appear at "
"the end of unordered match patterns"))))))
((hash-table pats ...)
;; must check the structure
#;(proper-hash-table-pattern? (syntax->list (syntax (pats ...))))
(list
(shape-test
`(hash-table? ,ae-datum)
ae (lambda (exp) #`(hash-table? #,exp)))
(let ([mod-pat
(lambda (pat)
(syntax-case* pat (var) stx-equal?
[(var id) pat]
[(keypat valpat) (syntax/loc pat (list keypat valpat))]
[_ pat]))])
(make-act
'hash-table-pat
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(let ((hash-name (gensym 'hash)))
#`(let ((#,hash-name
(hash-table-map #,(subst-bindings ae
let-bound)
(lambda (k v) (list k v)))))
#,(next-outer #`(list-no-order #,@(syntax-map mod-pat #'(pats ...)))
#`#,hash-name
sf
;; these tests have to be true
;;(append (list
;; '(pair? exp)
;; '(pair? (cdr exp))
;; '(null? (cdr (cdr exp))))
;; sf)
bv
let-bound
kf
ks
cert)))))))))
((struct struct-name (fields ...))
(identifier? (syntax struct-name))
(let*-values ([(field-pats) (syntax->list (syntax (fields ...)))]
[(num-of-fields) (length field-pats)]
[(pred accessors mutators parental-chain)
(struct-pred-accessors-mutators (cert #'struct-name))]
;; check that we have the right number of fields
[(dif) (- (length accessors) num-of-fields)])
(unless (zero? dif)
(match:syntax-err
p
(string-append
(if (> dif 0) "not enough " "too many ")
"fields for structure in pattern")))
(cons
(shape-test
`(struct-pred ,(syntax-object->datum pred)
,(map syntax-object->datum parental-chain)
,ae-datum)
ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp)))
(apply
append
(map
(lambda (cur-pat cur-mutator cur-accessor)
(syntax-case cur-pat (set! get!)
[(set! . rest)
(unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields"))
(set/get-matcher 'set! ae p #'rest
#`(lambda (y)
(#,cur-mutator #,ae y)))]
[(get! . rest)
(set/get-matcher 'get! ae p #'rest
#`(lambda ()
(#,cur-accessor #,ae)))]
[_ (render-test-list
cur-pat
(quasisyntax/loc cur-pat (#,cur-accessor #,ae))
cert
stx)]))
field-pats mutators accessors)))))
;; syntax checking
((struct ident ...)
(match:syntax-err
p
(if (zero? (length (syntax-e (syntax (ident ...)))))
(format "~a~n~a~n~a"
"a structure pattern must have the name "
"of a defined structure followed by a list of patterns "
"to match each field of that structure")
"syntax error in structure pattern")))
;; use a helper macro to match set/get patterns.
;; we give it the whole rest so that it can do error-checking and reporting
[(set! . rest)
(set/get-matcher 'set! ae p let-bound (syntax rest)
(setter ae p let-bound))]
[(get! . rest)
(set/get-matcher 'get! ae p let-bound (syntax rest)
(getter ae p let-bound))]
;; list pattern with ooo or ook
((list pat dot-dot-k pat-rest ...)
(and (not (or (memq (syntax-e (syntax pat))
'(unquote unquote-splicing ... ___))
(stx-dot-dot-k? (syntax pat))))
(stx-dot-dot-k? (syntax dot-dot-k)))
(begin
(list
(shape-test
`(list? ,ae-datum)
ae (lambda (exp) #`(list? #,exp)))
(make-act
'list-ddk-pat
ae
(lambda (ks kf let-bound)
(if (stx-null? (syntax (pat-rest ...)))
(handle-end-ddk-list ae kf ks
(syntax pat)
(syntax dot-dot-k)
let-bound
cert)
(handle-inner-ddk-list ae kf ks
(syntax pat)
(syntax dot-dot-k)
(append-if-necc 'list
(syntax (pat-rest ...)))
let-bound
cert)))))))
;; list-rest pattern with a ooo or ook pattern
((list-rest pat dot-dot-k pat-rest ...)
(and (not (or (memq (syntax-e (syntax pat))
'(unquote unquote-splicing ... ___))
(stx-dot-dot-k? (syntax pat))
(stx-null? (syntax (pat-rest ...)))))
(stx-dot-dot-k? (syntax dot-dot-k)))
(list
(shape-test
`(pair? ,ae-datum)
ae (lambda (exp) #`(pair? #,exp)))
(make-act
'list-ddk-pat
ae
(lambda (ks kf let-bound)
(handle-inner-ddk-list
ae kf ks
(syntax pat)
(syntax dot-dot-k)
(if (= 1 (length
(syntax->list (syntax (pat-rest ...)))))
(stx-car (syntax (pat-rest ...)))
(append-if-necc 'list-rest
(syntax (pat-rest ...))))
let-bound
cert)))))
;; list-rest pattern for improper lists
;; handle proper and improper lists
((list-rest car-pat cdr-pat) ;pattern ;(pat1 pats ...)
(not (or (memq (syntax-e (syntax car-pat))
'(unquote unquote-splicing))
(stx-dot-dot-k? (syntax car-pat))))
(cons
(shape-test
`(pair? ,ae-datum)
ae (lambda (exp) #`(pair? #,exp)))
(append
(render-test-list (syntax car-pat)
(quasisyntax/loc (syntax car-pat) (car #,ae))
cert
stx) ;(add-a e)
(render-test-list
(syntax cdr-pat)
#`(cdr #,ae)
cert
stx))))
;; list-rest pattern
((list-rest car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
(not (or (memq (syntax-e (syntax car-pat))
'(unquote unquote-splicing))
(stx-dot-dot-k? (syntax car-pat))))
(cons
(shape-test
`(pair? ,ae-datum)
ae (lambda (exp) #`(pair? #,exp)))
(append
(render-test-list (syntax car-pat)
#`(car #,ae)
cert
stx) ;(add-a e)
(render-test-list
(append-if-necc 'list-rest (syntax (cdr-pat ...)))
#`(cdr #,ae)
cert
stx))))
;; general list pattern
((list car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
(not (or (memq (syntax-e (syntax car-pat))
'(unquote unquote-splicing))
(stx-dot-dot-k? (syntax car-pat))))
(cons
(shape-test
`(pair? ,ae-datum)
ae (lambda (exp) #`(pair? #,exp)))
(append
(render-test-list (syntax car-pat)
#`(car #,ae)
cert
stx) ;(add-a e)
(if (stx-null? (syntax (cdr-pat ...)))
(list
(shape-test
`(null? (cdr ,ae-datum))
ae (lambda (exp) #`(null? #,exp)) #`(cdr #,ae)))
(render-test-list
(append-if-necc 'list (syntax (cdr-pat ...)))
#`(cdr #,ae)
cert
stx)))))
;; vector pattern with ooo or ook at end
((vector pats ...)
(ddk-only-at-end-of-list? (syntax-e (syntax (pats ...))))
(list
(shape-test
`(vector? ,ae-datum)
ae (lambda (exp) #`(vector? #,exp)))
(make-act
'vec-ddk-pat
ae
(lambda (ks kf let-bound)
(handle-ddk-vector ae kf ks
#'#(pats ...)
let-bound
cert)))))
;; vector pattern with ooo or ook, but not at end
[(vector pats ...)
(let* ((temp (syntax-e (syntax (pats ...))))
(len (length temp)))
(and (>= len 2)
(ddk-in-list? temp)))
;; make this contains ddk with no ddks consecutive
;;(stx-dot-dot-k? (vector-ref temp (sub1 len))))))
(list
(shape-test
`(vector? ,ae-datum)
ae (lambda (exp) #`(vector? #,exp)))
;; we have to look at the first pattern and see if a ddk follows it
;; if so handle that case else handle the pattern
(make-act
'vec-ddk-pat
ae
(lambda (ks kf let-bound)
(handle-ddk-vector-inner ae kf ks
#'#(pats ...)
let-bound
cert))))]
;; plain old vector pattern
[(vector pats ...)
(let* ([syntax-vec (list->vector (syntax->list (syntax (pats ...))))]
[vlen (vector-length syntax-vec)])
(list*
(shape-test
`(vector? ,ae-datum) ae
(lambda (exp) #`(vector? #,exp)))
(shape-test
`(equal? (vector-length ,ae-datum) ,vlen)
ae (lambda (exp) #`(equal? (vector-length #,exp) #,vlen)))
(let vloop ((n 0))
(if (= n vlen)
'()
(append
(render-test-list
(vector-ref syntax-vec n)
#`(vector-ref #,ae #,n)
cert
stx)
(vloop (+ 1 n)))))))]
[(box pat)
(cons
(shape-test
`(box? ,ae-datum)
ae (lambda (exp) #`(box? #,exp)))
(render-test-list
#'pat #`(unbox #,ae) cert stx))]
;; This pattern wasn't a valid form.
[got-too-far
(match:syntax-err
#'got-too-far
"syntax error in pattern")]))
;; end of render-test-list@
)
)

19
collects/mzlib/private/match/render-test-list.scm
View File

@ -1,19 +0,0 @@
;; This library is used by match.ss
(module render-test-list mzscheme
(provide render-test-list)
(require "render-sigs.ss"
"render-test-list-impl.ss"
"getbindings.ss"
"ddk-handlers.ss"
mzlib/unit)
(define-compound-unit/infer rtl@
(import)
(export render-test-list^)
(link render-test-list@ getbindings@ ddk-handlers@))
(define-values/invoke-unit/infer rtl@)
)

102
collects/mzlib/private/match/reorder-tests.scm
View File

@ -1,102 +0,0 @@
;; This library is used by match.ss
;; This requires the test data structure.
(module reorder-tests mzscheme
(provide reorder-all-lists)
(require "test-structure.scm")
(require-for-template mzscheme)
;; There really ought to be a stable sort in the std library.
;;!(function insertion-sort
;; (form (insertion-sort ls less-than?) -> list)
;; (contract (list (any any -> bool) -> list)))
;; This is the classic stable sort. Any stable sort will do.
(define insertion-sort
(lambda (ls less-than?)
(define (insert el ls)
(define (ins ls)
(cond ((null? ls) (list el))
((less-than? el (car ls))
(cons el ls))
(else (cons (car ls) (ins (cdr ls))))))
(ins ls))
(letrec ((IS (lambda (ls)
(if (null? ls)
'()
(insert (car ls)
(IS (cdr ls)))))))
(IS ls))))
;;!(function make-test-order-func
;; (form (make-test-order-func whole-list) -> less-than?)
;; (contract list -> (any any -> bool)))
;; This function creates a test function which has access to the
;;whole list of test structures capured in the closure. This
;;function places tests that are used more ahead of those used
;;less. When tests are used an equal number of times the test whos
;;membership set has the greatest presence is placed ahead.
(define make-test-order-func
(lambda (whole-list)
(lambda (t1 t2)
(let ((t1-tu (test-times-used t1))
(t2-tu (test-times-used t2)))
(cond ((> t1-tu t2-tu) #t)
;; these two new rules allow negate
;; tests to be placed properly
((and (= t1-tu t2-tu)
(shape-test? t1)
(not (shape-test? t2))
(negate-test? t2))
#t)
((and (= t1-tu t2-tu)
(not (shape-test? t1))
(negate-test? t1)
(shape-test? t2))
#f)
((and (= t1-tu t2-tu)
(or (equal? (test-used-set t1) (test-used-set t2))
(>= (number-of-similar (test-used-set t1)
whole-list)
(number-of-similar (test-used-set t2)
whole-list))))
#t)
(else #f))))))
;;!(function number-of-similar
;; (form (number-of-similar set ls) -> integer)
;; (contract (list list) -> integer))
;; This function returns the number of tests that have a
;; membership set similar to set. A membership set is the set of
;; test-lists that have a similar tests as the test itself.
(define number-of-similar
(lambda (set ls)
(apply + (map (lambda (set2) (if (equal? set set2) 1 0))
(map test-used-set ls)))))
;;!(function reorder-tests
;; (form (reorder-tests2 test-list) -> test-list)
;; (contract list -> list))
;; This function reorders one list of test structs.
(define reorder-tests
(lambda (test-list)
;;(pretty-print test-list)(newline)
(insertion-sort test-list (make-test-order-func test-list))))
;;!(function reorder-all-lists
;; (form (reorder-all-lists2 rendered-list) -> list)
;; (contract list -> list))
;; This function reorders all of the rendered-lists that have
;; success-functions attached to them.
(define reorder-all-lists
(lambda (rendered-list)
(if (null? rendered-list)
'()
(let ((success-func (cdr (car rendered-list)))
(rot (reorder-tests (caar rendered-list))))
;(pretty-print rot)(newline)
(cons (cons rot success-func)
(reorder-all-lists (cdr rendered-list)))))))
)

190
collects/mzlib/private/match/simplify-patterns.ss
View File

@ -1,190 +0,0 @@
(module simplify-patterns mzscheme
(require syntax/stx)
(require scheme/list)
(require "match-error.ss"
"match-helper.ss"
"test-structure.scm"
"coupling-and-binding.scm"
"update-counts.scm"
"update-binding-counts.scm"
"reorder-tests.scm"
"match-expander-struct.ss"
"render-helpers.ss"
"observe-step.ss")
(require "render-sigs.ss")
(require-for-syntax "match-helper.ss"
"match-expander-struct.ss"
"test-no-order.ss")
(require-for-template mzscheme
"match-error.ss"
"test-no-order.ss"
"match-helper.ss")
(provide simplify match-...-nesting)
(define match-...-nesting (make-parameter 0))
;; simplifies patterns by removing syntactic sugar and expanding match-expanders
;; simplify : syntax certifier-> syntax
(define (simplify stx cert)
;; convert and check sub patterns for hash-table patterns
(define (convert-hash-table-pat pat)
(syntax-case pat ()
[(p1 p2) #`(#,(simplify/i #'p1) #,(simplify/i #'p2))]
[i (and (identifier? #'i) (not (stx-dot-dot-k? #'i))) #'(var i)]
[_ (match:syntax-err pat "hash table subpattern must contain either two patterns or an identifier")]))
;; simple one-arg version, just passes the cert along
(define (simplify/i stx) (simplify stx cert))
(syntax-case*
stx
(_ list quote quasiquote vector box ? app and or not struct set! var
list-rest get! ... ___ unquote unquote-splicing cons
list-no-order hash-table regexp pregexp cons) stx-equal?
;; expand match-expanders
;; this doesn't work because we need to keep the certifier around
[(expander args ...)
(and (identifier? #'expander)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(let* ([expander (syntax-local-value (cert #'expander))]
[transformer (match-expander-plt-match-xform expander)])
(unless transformer
(match:syntax-err #'expander
"This expander only works with the match.ss library."))
(let* ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)]
[mstx (introducer (syntax-local-introduce stx))]
[mresult (transformer mstx)]
[result (syntax-local-introduce (introducer mresult))]
[cert* (lambda (id) (certifier (cert id) #f introducer))])
(observe-step stx mstx mresult result)
(simplify result cert*)))]
;; label variable patterns
[id
(and (pattern-var? #'id) (not (stx-dot-dot-k? #'id)))
#'(var id)]
;; match the empty list
['() (syntax/loc stx (list))]
;; other quoted data is untransformed
[(quote data) stx]
;; transform quasi-patterns into regular patterns
[`quasi-pat (simplify/i (parse-quasi #'quasi-pat))]
;; predicate patterns with binders are redundant with and patterns
[(? pred pat . pats) (simplify/i (syntax/loc stx (and (? pred) pat . pats)))]
[(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))]
[(? . anything)
(match:syntax-err
stx
(if (null? (syntax-e #'anything))
"a predicate pattern must have a predicate following the ?"
"syntax error in predicate pattern"))]
;; regexp patterns - FIXME: abstract here
[(regexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (regexp-match re x))))))]
[(pregexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (pregexp-match-with-error re x))))))]
[(regexp re pat) (simplify/i (syntax/loc stx (and (? string?) (app (lambda (x) (regexp-match re x)) pat))))]
[(pregexp re pat) (simplify/i (syntax/loc stx (and (? string?) (app (lambda (x) (pregexp-match-with-error re x)) pat))))]
[(regexp . re) (match:syntax-err stx "regexp pattern must have one or two subpatterns")]
[(pregexp . re) (match:syntax-err stx "pregexp pattern must have one or two subpatterns")]
;; cons is just list-rest with 2 arguments
[(cons p1 p2) (simplify/i (syntax/loc stx (list-rest p1 p2)))]
[(cons . rest) (match:syntax-err stx "cons pattern must have exactly two subpatterns")]
;; aggregates
[(kw pats ... last ddk)
(and (stx-dot-dot-k? #'ddk)
(memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not)))
(with-syntax ([(pats* ...) (append (syntax-map simplify/i #'(pats ...))
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
(list (simplify/i #'last))))])
#;(printf "kw: ~a~n" (syntax-object->datum stx))
(quasisyntax/loc stx (kw pats* ... ddk)))
#;
(with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))]
[last* (parameterize ([match-...-nesting (add1 (match-...-nesting))])
(simplify/i #'last))])
(syntax/loc stx (kw pats* ... last* ddk)))]
[(kw pats ...)
(memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not))
(with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))])
(syntax/loc stx (kw pats* ...)))]
[(kw pats ... . rest)
(not (null? (syntax-e #'rest)))
(match:syntax-err stx (format "~a pattern must have a proper list of subpatterns" (syntax-e #'kw)))]
;; hash table patterns have their own syntax
[(hash-table pats ... ooo)
(stx-dot-dot-k? #'ooo)
(with-syntax
([(pats* ...) (syntax-map convert-hash-table-pat #'(pats ...))])
(syntax/loc stx (hash-table pats* ... ooo)))]
[(hash-table pats ...)
(with-syntax
([(pats* ...) (syntax-map convert-hash-table-pat #'(pats ...))])
(syntax/loc stx (hash-table pats* ...)))]
[(hash-table . rest) (match:syntax-err stx "syntax error in hash table pattern")]
;; struct patterns
[(struct st (pats ...)) (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))]
[st* (cert #'st)])
(syntax/loc stx (struct st* (pats* ...))))]
[(struct . rest)
(match:syntax-err
stx
(if (null? (syntax-e #'rest))
(format "~a~n~a~n~a"
"a structure pattern must have the name "
"of a defined structure followed by a list of patterns "
"to match each field of that structure")
"syntax error in structure pattern"))]
[(box pat) (quasisyntax/loc stx (box #,(simplify/i #'pat)))]
[(box . rest) (match:syntax-err stx "syntax error in box pattern")]
[(app e pat) (quasisyntax/loc stx (app #,(cert #'e) #,(simplify/i #'pat)))]
[(app . rest) (match:syntax-err stx "syntax error in app pattern")]
[(set! id)
(identifier? #'id)
stx]
[(set! . rest) (match:syntax-err stx "set! pattern must have one identifier")]
[(get! id)
(identifier? #'id)
stx]
[(get! . rest) (match:syntax-err stx "get! pattern must have one identifier")]
[(var id)
(identifier? #'id)
stx]
[(var . rest)
(match:syntax-err stx "var pattern must have one identifier")]
[__ stx])
)
)

235
collects/mzlib/private/match/struct-helper.scm
View File

@ -1,235 +0,0 @@
(module struct-helper mzscheme
(require mzlib/list)
(require-for-template mzscheme)
(provide (all-defined))
(define-struct field-decl (field ref mut posn immutable? auto?) (make-inspector))
(define (sym+ . items)
(define (->string x)
(cond [(string? x) x]
[(symbol? x) (symbol->string x)]
[(identifier? x) (symbol->string (syntax-e x))]))
(string->symbol (apply string-append (map ->string items))))
(define (identifier/tf? stx)
(or (identifier? stx)
(not stx)
(eq? (syntax-e stx) #t)
(eq? (syntax-e stx) #f)))
(define (id/tf stx stx2)
(cond [(identifier? stx)
stx]
[(eq? (syntax-e stx) #t)
stx2]
[else #f]))
(define (mk-parse-field-decl name-id)
(define (parse-field-decl stx)
(syntax-case stx ()
[(field (flag ...) ref mut)
(and (identifier? #'field)
(identifier/tf? #'ref)
(identifier/tf? #'mut)
(andmap identifier? (syntax->list #'(flag ...))))
(let ((flags (syntax-object->datum #'(flag ...))))
(make-field-decl
(id/tf #'field #f)
(id/tf #'ref (datum->syntax-object name-id (sym+ name-id '- #'field)))
(id/tf #'mut (datum->syntax-object name-id (sym+ 'set- name-id '- #'field '!)))
#f
(memq 'immutable flags)
(memq 'auto flags)))]
[(field (flag ...) ref)
(parse-field-decl #'(field (flag ...) ref #t))]
[(field (flag ...))
(parse-field-decl
#`(field
(flag ...)
#t
#t))]
[field
(identifier? #'field)
(parse-field-decl
#`(field () #t #t))]))
(lambda (stx)
(let ((r (parse-field-decl stx)))
#;(printf "parse-field-decl returned ~s~n" r)
r)))
(define-struct decl:super (super struct:super))
(define-struct decl:auto (value))
(define-struct decl:property (key value))
(define-struct decl:inspector (value))
(define-struct decl:procedure-field (field))
(define-struct decl:procedure (value))
(define-struct decl:guard (value))
(define-struct decl:option (value))
(define (fetch-struct:super type)
(let ((struct-info (syntax-local-value type)))
(car struct-info)))
(define (parse-decl stx)
(syntax-case stx (super struct:super
auto-value property inspector transparent
procedure procedure-field guard
omit-define-values
omit-static-info
clone
replace
)
[(super type)
(identifier? #'type)
(make-decl:super #'type (fetch-struct:super #'type))]
[(struct:super value)
(make-decl:super #f #'value)]
[(auto-value value)
(make-decl:auto #'value)]
[(property key value)
(make-decl:property #'key #'value)]
[(inspector value)
(make-decl:inspector #'value)]
[transparent
(make-decl:inspector #'(make-inspector))]
[(procedure proc)
(make-decl:procedure #'proc)]
[(procedure-field field)
(identifier? #'field)
(make-decl:procedure-field #'field)]
[(guard proc)
(make-decl:guard #'proc)]
[omit-define-values
(make-decl:option 'omit-define-values)]
[omit-static-info
(make-decl:option 'omit-static-info)]
[clone
(make-decl:option 'include-clone)]
[replace
(make-decl:option 'include-replace)]))
(define-struct info (type super auto-k auto-v
props insp proc-spec imm-k-list guard
ref-fields ref-posns ref-names
mut-fields mut-posns mut-names
options fdecls))
(define (make-null-info type)
(make-info type #f 0 #f
'() #f #f '() #f
'() '() '()
'() '() '()
'() '()))
(define (create-info type decls field-decls)
(let ((info (make-null-info type)))
(let loop ((fdecls field-decls) (posn 0) (first-auto #f))
(if (pair? fdecls)
(let ((fdecl (car fdecls)))
(set-field-decl-posn! fdecl posn)
(when (and first-auto (not (field-decl-auto? fdecl)))
(raise-syntax-error 'define-struct*
"non-auto field came after auto field"
(field-decl-field fdecl)))
(when (field-decl-ref fdecl)
(set-info-ref-fields! info
(cons (field-decl-field fdecl) (info-ref-fields info)))
(set-info-ref-posns! info
(cons posn (info-ref-posns info)))
(set-info-ref-names! info
(cons (field-decl-ref fdecl) (info-ref-names info))))
(when (field-decl-mut fdecl)
(set-info-mut-fields! info
(cons (field-decl-field fdecl) (info-mut-fields info)))
(set-info-mut-posns! info
(cons posn (info-mut-posns info)))
(set-info-mut-names! info
(cons (field-decl-mut fdecl) (info-mut-names info))))
(loop (cdr fdecls)
(add1 posn)
(or first-auto (if (field-decl-auto? fdecl) posn #f))))
(begin (set-info-auto-k! info
(if first-auto (- posn first-auto) 0)))))
(set-info-ref-fields! info (reverse (info-ref-fields info)))
(set-info-ref-posns! info (reverse (info-ref-posns info)))
(set-info-ref-names! info (reverse (info-ref-names info)))
(set-info-mut-fields! info (reverse (info-mut-fields info)))
(set-info-mut-posns! info (reverse (info-mut-posns info)))
(set-info-mut-names! info (reverse (info-mut-names info)))
(set-info-fdecls! info field-decls)
(for-each
(lambda (decl)
(cond [(decl:super? decl) (set-info-super! info decl)]
[(decl:auto? decl) (set-info-auto-v! info (decl:auto-value decl))]
[(decl:property? decl)
(set-info-props! info (cons (cons (decl:property-key decl)
(decl:property-value decl))
(info-props info)))]
[(decl:inspector? decl)
(set-info-insp! info (decl:inspector-value decl))]
[(decl:procedure? decl)
(set-info-proc-spec! info (decl:procedure-value decl))]
[(decl:procedure-field? decl)
(set-info-proc-spec!
info
(let loop ((fields (map field-decl-field field-decls)) (i 0))
(cond
[(null? fields)
(raise-syntax-error 'define-struct*
"procedure-field not in field set"
(decl:procedure-field-field decl))]
[(module-identifier=? (decl:procedure-field-field decl)
(car fields))
i]
[else (loop (cdr fields) (add1 i))])))]
[(decl:guard? decl)
(set-info-guard! info (decl:guard-value decl))]
[(decl:option? decl)
(set-info-options! info (cons (decl:option-value decl)
(info-options info)))]
))
decls)
(when (and (info-include-replacers? info) (pair? (info-auto-fields info)))
(error 'define-struct* "cannot define replacers with auto-fields"))
info))
(define (info-init-fields info)
(filter (lambda (fdecl) (not (field-decl-auto? fdecl)))
(info-fdecls info)))
(define (info-auto-fields info)
(filter (lambda (fdecl) (field-decl-auto? fdecl))
(info-fdecls info)))
(define (info-include-define-values? info)
(not (memq 'omit-define-values (info-options info))))
(define (info-include-static-info? info)
(not (memq 'omit-static-info (info-options info))))
(define (info-include-replacers? info)
(memq 'include-replace (info-options info)))
(define (info-include-clone? info)
(memq 'include-clone (info-options info)))
(define (info-include-x-ref? info)
#f)
(define (info-include-x-set!? info)
#f)
(define (info-name:struct-record info)
(let ((type (info-type info)))
(datum->syntax-object type (sym+ 'struct: type))))
(define (info-name:constructor info)
(let ((type (info-type info)))
(datum->syntax-object type (sym+ 'make- type))))
(define (info-name:predicate info)
(let ((type (info-type info)))
(datum->syntax-object type (sym+ type '?))))
(define (info-defined-names info)
(let ((type (info-type info)))
(append (list (info-name:struct-record info)
(info-name:constructor info)
(info-name:predicate info))
(info-ref-names info)
(info-mut-names info))))
)

45
collects/mzlib/private/match/syntax-utils.ss
View File

@ -1,45 +0,0 @@
(module syntax-utils mzscheme
;; Useful utilities on syntax objects
(provide (all-defined))
;;! (function stx-length
;; (form (syntax-length syntax-obj) -> int)
;; (contract syntax-object -> int)
;; (example (syntax-length (syntax iraq war idiocy)) -> 3))
;; Returns the length of the top-level syntax list.
(define (stx-length stx) (length (syntax->list stx)))
;;! (function stx-?
;; (form (stx? test val) -> bool)
;; (contract ((any -> bool) syntax-object) -> bool)
;; (example (stx-? number? (syntax 4)) -> #t))
;; Applies predicate test to the syntax object val and returns the resulting
;; boolean value.
(define (stx-? test val) (test (syntax-object->datum val)))
;;!(function stx-equal?
;; (form (stx-equal? a b) -> bool)
;; (contract (syntax-object syntax-object) -> bool)
;; (example (stx-equal? (syntax 5) (syntax 5)) -> #t))
;; Check the equality of two syntax objects by after applying
;; syntax-object->datum to the objects first. Checks equaltiy of
;; syntax objects after they have had all syntax data stripped away.
(define (stx-equal? a b)
(equal? (syntax-object->datum a)
(syntax-object->datum b)))
;;!(function get-exp-var
;; (form (get-exp-var) -> syntax)
;; (contract () -> syntax)
;; (example (get-exp-var) -> (syntax exp754)))
;; This function just produces unique identifiers for expressions.
(define (get-exp-var) #`#,(gensym 'exp))
;; syntax-map : (stx -> b) stx-list -> listof[b]
;; maps a function over a syntax object that represents a list
(define (syntax-map f stx-l)
(map f (syntax->list stx-l)))
)

103
collects/mzlib/private/match/tag-negate-tests.scm
View File

@ -1,103 +0,0 @@
(module tag-negate-tests mzscheme
(provide tag-negate-tests)
(require "test-structure.scm")
(define (tag-neg-test ls target-set)
(easy-tag ls #f target-set))
(define (easy-tag ls last-shape target-set)
(cond ((null? ls) #f)
((let ((tst (car ls)))
(and ;(not (action-test? tst))
(not (or (shape-test? tst) (action-test? tst)))
(equal? target-set (test-used-set-neg tst))))
(begin
(when (and last-shape (not (shape-test? (car ls))))
(set-test-closest-shape-tst! (car ls) last-shape)
(set-test-used-set! (car ls) last-shape)
(set-test-times-used! (car ls) (length last-shape)))
#t))
((shape-test? (car ls))
(easy-tag (cdr ls) (test-used-set (car ls)) target-set))
(else
(easy-tag (cdr ls) last-shape target-set))))
(define (tag-negate-tests ls-of-ls)
(letrec ((gen-target-set-help
(lambda (init length)
(if (zero? length)
'()
(cons init
(gen-target-set-help (add1 init)
(sub1 length))))))
(gen-target-set
(lambda (length)
(gen-target-set-help 2 length)))
(tag-help
(lambda (ls target-set)
(if (null? target-set)
'()
(begin
(tag-neg-test (car ls)
(reverse target-set))
(tag-help
(cdr ls)
(cdr target-set)))))))
(tag-help (map car ls-of-ls) (gen-target-set (sub1 (length ls-of-ls))))))
; (define (move-negates-to-tags ls-of-ls)
; (map (lambda (l) (cons (move-neg-to-tag (car l))
; (cdr l)))
; ls-of-ls))
; (define (move-neg-to-tag ls)
; (let-values (((list-without-neg-tests neg-tests)
; (let loop ((l ls)
; (ntsf '()))
; (cond ((null? l) (values '() ntsf))
; ((negate-test? (car l))
; (loop (cdr l) (append ntsf (list (car l)))))
; (else
; (let-values (((lwnt ntsf) (loop (cdr l) ntsf)))
; (values (cons (car l) lwnt)
; ntsf)))))))
; ;(write 'lwnt--)(pretty-print list-without-neg-tests)
; ;(write 'neg-test)(pretty-print neg-tests)
; (letrec ((insert-negtest
; (lambda (t-list neg-test)
; (cond ((null? t-list)
; '())
; ((and (equal? (test-used-set (car t-list))
; (test-closest-shape-tst neg-test))
; (or (null? (cdr t-list))
; (not (equal? (test-used-set (cadr t-list))
; (test-closest-shape-tst neg-test)))))
; (cons (car t-list)
; (cons neg-test
; (cdr t-list))))
; ; ((equal? (test-tst (car t-list))
; ; (test-closest-shape-tst neg-test))
; ; (cons (car t-list)
; ; (cons neg-test
; ; (cdr t-list))))
; (else
; (cons (car t-list)
; (insert-negtest (cdr t-list)
; neg-test)))))))
; (let loop2 ((t-list list-without-neg-tests)
; (ntst neg-tests))
; ;(write 't-list)(pretty-print t-list)
; ;(write 'ntst ) (pretty-print ntst)
; ;(write 'insert) (pretty-print (insert-negtest t-list (car ntst)) )
; (cond ((null? ntst) t-list)
; (else (insert-negtest t-list (car ntst))))))))
; ; (cond ((null? ntst)
; ; t-list)
; ; (loop2 (insert-negtest t-list (car ntst))
; ; (cdr ntst)))))))
)

39
collects/mzlib/private/match/test-no-order.ss
View File

@ -1,39 +0,0 @@
(module test-no-order mzscheme
(require mzlib/list)
(provide match:test-no-order)
;;!(function match:test-no-order
;; (form (match:test-no-order tests l last-test ddk-num)
;; ->
;; bool)
;; (contract (list list test integer) -> bool))
;; This is a recursive depth first search for a sequence of
;; items in list l which will satisfy all of the tests in list
;; tests. This is used for list-no-order and hash-table patterns.
;; This function also handles ddk patterns by passing it the last
;; test before the ddk and the value of k.
(define (match:test-no-order tests l last-test ddk-num)
(define (handle-last-test test l)
(and (>= (length l) ddk-num)
(andmap test l)))
(define (dep-first-test head rest tests)
(cond [(null? tests)
(if last-test
(handle-last-test last-test (cons head rest))
#f)]
[(null? rest)
(if last-test
(and (= 0 ddk-num)
(= 1 (length tests))
((car tests) head))
(and (= 1 (length tests))
((car tests) head)))]
[else (and (pair? tests)
((car tests) head)
(match:test-no-order (cdr tests)
rest
last-test
ddk-num))]))
(printf "~s\n" (list tests l last-test ddk-num))
(ormap (lambda (elem) (dep-first-test elem (remove elem l) tests)) l)))

120
collects/mzlib/private/match/test-structure.scm
View File

@ -1,120 +0,0 @@
;; This library is used by match.ss
(module test-structure mzscheme
(provide (all-defined))
;; This is the major data structure of the compiler. It holds a
;; great deal of information. This structure represents a
;; partially compiled match test. This test is the basic unit of
;; compilation. The order of these tests greatly affects the size
;; of the final compiled match expression. it also affects the
;; amount of time it takes to compile a match expression.
;; the fields:
;; tst - an S-exp of the test such as (equal exp 5). It can also
;; be a name of a test that isn't meant to be compared to other
;; tests such as 'list-ddk-pat.
;; comp - a function that takes a success-function, a fail-function and
;; a list of let bindings
;; shape - a boolean that is true if the test tests the shape or type
;; of the data rather than the value of the data
;; times-used - the number of clauses that use this test. In reality
;; the number of clauses in which this test will eliminate
;; tests
;; used-set - a list of numbers which designate the test-lists that
;; in which this test will eliminate tests
;; bind-exp-stx - the syntax of the actual expression that is being tested
;; by this test ex. (syntax (car (cdr x)))
;; bind-exp - the s-exp that is being tested by this test,
;; easily obtained by taking the syntax-object->datum
;; of bind-exp-stx
;; bind-count - is the number of times in the bind-exp is found in the
;; test list in which this test is a member
;; used-set-neg - ???
;; closest-shape-tst - ???
;; equal-set - ???
(define-struct test (tst
comp
shape
times-used
used-set
bind-exp-stx
bind-exp
bind-count
used-set-neg
closest-shape-tst
equal-set)
#f)
;;!(function make-shape-test
;; (form (make-shape-test test exp comp) -> test-struct)
;; (contract (s-exp syntax (((list list -> syntax)
;; (list list -> syntax) list)
;; ->
;; (list list -> syntax)))
;; -> test))
;; This function is essentially a constructor for a test struct.
;; This constructor makes a "shape" test - test that tests for type
;; rather than value.
;; Arguments:
;; test - s-exp of the test
;; exp - the syntax of the expression being tested
;; comp - the compilation function which will finish the compilation
;; after tests have been reordered
(define (make-shape-test test exp comp)
(make-test test comp #t 0 '() exp (syntax-object->datum exp) 1 '() #f '()))
;;!(function make-reg-test
;; (form (make-shape-test test exp comp) -> test-struct)
;; (contract (s-exp syntax (((list list -> syntax)
;; (list list -> syntax) list)
;; -> (list list -> syntax)))
;; -> test))
;; This function is essentially a constructor for a test struct.
;; This constructor makes a "regular" test
;; Arguments:
;; test - s-exp of the test
;; exp - the syntax of the expression being tested
;; comp - the compilation function which will finish the compilation
;; after tests have been reordered
(define (make-reg-test test exp comp)
(make-test test comp #f 0 '() exp (syntax-object->datum exp) 1 '() #f '()))
;;!(function make-act-test
;; (form (make-shape-test test exp comp) -> test-struct)
;; (contract (s-exp syntax (((list list -> syntax)
;; (list list -> syntax) list) -> (list list -> syntax)))
;; -> test))
;; This function is essentially a constructor for a test struct.
;; This constructor makes an "action" test - an action test is not
;; neccessarily a test so to speak but rather an action that needs to be
;; taken in order to verify that a certain expression matches a pattern.
;; A good example of this is the binding of a pattern variable.
;; Arguments:
;; act-name -
;; exp - the syntax of the expression being tested
;; comp - the compilation function which will finish the compilation
;; after tests have been reordered
(define (make-act act-name exp comp)
(make-test act-name comp #f -1 '() exp (syntax-object->datum exp) 1 '() #f '()))
;;!(function action-test?
;; (form (action-test? test) -> bool)
;; (contract test -> bool))
;; a predicate that returns true if a test is an action test
(define (action-test? test)
(= -1 (test-times-used test)))
;;!(function shape-test?
;; (form (shape-test? test) -> bool)
;; (contract test -> bool))
;; a predicate that returns true if a test is an shape test
(define (shape-test? test)
(test-shape test))
(define (negate-test? test)
(test-closest-shape-tst test))
)

109
collects/mzlib/private/match/update-binding-counts.scm
View File

@ -1,109 +0,0 @@
;; This library is used by match.ss
(module update-binding-counts mzscheme
(provide update-binding-counts update-binding-count)
(require "test-structure.scm")
(require mzlib/etc)
;;!(function update-binding-count
;; (form (update-binding-count render-list) -> list)
;; (contract list -> list))
;; This function is normally executed for its side effect of
;; setting the count for the number of times an expression used in
;; a test if found in the rest of the list of tests. This does
;; not only count occurrances of the exp in other tests but
;; whether the expression is also a sub expression in the other tests.
;; Arg:
;; render-list - a list of test structs
(define update-binding-count
(lambda (render-list)
(define (inc-bind-count test)
(set-test-bind-count! test
(add1 (test-bind-count test))))
(if (null? render-list)
'()
(let ((cur-test (car render-list)))
(update-binding-count
(let loop ((l (cdr render-list)))
(cond ((null? l) '())
((>= (test-bind-count cur-test) 2) l)
((and (valid-for-let-binding (test-bind-exp cur-test))
(equal? (test-bind-exp cur-test)
(test-bind-exp (car l))))
(begin
(inc-bind-count cur-test)
(loop (cdr l))))
((sub-exp-contains (test-bind-exp cur-test)
(test-bind-exp (car l)))
(begin
(inc-bind-count cur-test)
(cons (car l) (loop (cdr l)))))
(else (cons (car l) (loop (cdr l)))))))))))
;;!(function valid-for-let-binding
;; (form (valid-for-let-binding exp) -> bool)
;; (contract s-exp -> bool)
;; (example (valid-for-let-binding 'x) -> #f))
;; This function is a predicate that determins if an expression
;; should be considered for let binding.
(define valid-for-let-binding
(lambda (exp)
;; it must be a pair
;; the index must be an integer
#;(match exp
(('vector-ref _ n) (number? n))
((? pair?) #t)
(_ #f))
;; the following is expanded fromt the above match expression
(let ((x exp))
(if (pair? x)
(if (and (equal? (car x) 'vector-ref)
(pair? (cdr x))
(pair? (cdr (cdr x)))
(null? (cdr (cdr (cdr x)))))
((lambda (n) (number? n)) (car (cdr (cdr x))))
((lambda () #t)))
((lambda () #f))))))
;;!(function sub-exp-contains
;; (form (sub-exp-contains exp1 exp2) -> bool)
;; (contract (s-exp s-exp) -> bool)
;; (example (sub-exp-contains '(cdr x) '(car (cdr x))) -> #t))
;; This function returns true if exp2 contains a sub-expression
;; that is equal? to exp1. For this function to work the subexp
;; must always be in the second position in a exp. This is a
;; convention that is followed throughout the match program.
(define sub-exp-contains
(lambda (exp1 exp2)
#;(match exp2
(() #f)
((_ sub-exp _ ...)
(if (and (valid-for-let-binding sub-exp)
(equal? sub-exp exp1))
#t
(sub-exp-contains exp1 sub-exp)))
(_ #f))
;; The following was expanded from the above match expression
(let ((x exp2))
(if (null? x)
((lambda () #f))
(if (and (pair? x) (pair? (cdr x)) (list? (cdr (cdr x))))
((lambda (sub-exp)
(if (and (pair? sub-exp)
(equal? sub-exp exp1))
#t
(sub-exp-contains exp1 sub-exp)))
(car (cdr x)))
((lambda () #f)))))))
;;!(function update-binding-counts
;; (form (update-binding-counts render-lists) -> list)
;; (contract list -> list))
;; This function calls update-binding-count for each render list
;; in the list of render lists. This is used mainly for its side
;; affects. The result is of no consequence.
(define update-binding-counts
(lambda (render-lists)
(map (compose update-binding-count car) render-lists)))
)

148
collects/mzlib/private/match/update-counts.scm
View File

@ -1,148 +0,0 @@
;; This library is used by match.ss
;; This requires the test data structure.
(module update-counts mzscheme
(provide update-counts)
(require "test-structure.scm"
"match-helper.ss"
mzlib/etc
mzlib/list)
;;!(function test-filter
;; (form (test-filter test-list) -> test-list)
;; (contract list -> list))
;; This function filters out tests that do not need to be to have
;; their counts updated for reordering purposes. These are the
;; more complex patterns such as or-patterns or ddk patterns.
(define (test-filter tlist)
(filter (lambda (t) (not (= -1 (test-times-used t)))) tlist))
;; !(function inverse-in
;; (form (inverse-in test test-list) -> bool)
;; (contract (s-exp list) -> bool))
;; This function checks to see if any of the members of the test-list
;; would be eliminated by the function if the test was in the test so far
;; list. This is the opposite of what the in function does.
(define (inverse-in test test-list)
(or (pos-inverse-in test test-list)
(neg-inverse-in test test-list)))
(define (pos-inverse-in test test-list)
(let ([test-with-implied (cons test (implied test))])
(ormap (lambda (t) (in t test-with-implied))
test-list)))
(define (neg-inverse-in test test-list)
(let ([test-with-implied (cons test (implied test))])
(ormap (lambda (t) (in `(not ,t) test-with-implied))
test-list)))
(define (logical-member item lst)
(ormap (lambda (cur)
(logical-equal? item cur))
lst))
(define (logical-equal? a b)
(or (equal? a b)
(and
;; error checking
(list? a)
(list? b)
(list? (cdr a))
(list? (cdr b))
(null? (cddr a))
(null? (cddr b))
;; end error checking
(eq? (car a) 'list?)
(eq? (car b) 'null?)
(equal? (cadr a) (cadr b)))))
;; truncate-list : int listof[int] -> listof[int]
;; truncate-list-neg : int listof[int] -> listof[int]
;; truncate-list removes all elements of a list after the element at least as large as p
;; truncate-list-neg removes the found element as well
(define-values (truncate-list truncate-list-neg)
(let ([mk (lambda (pos-f)
(define (f p l)
(cond [(null? l)
'()]
[(>= p (car l))
(pos-f p)]
[else
(cons (car l)
(f p (cdr l)))]))
f)])
(values (mk list) (mk (lambda (x) '())))))
;; update-count : test listof[test] int -> void
;; This function updates the test-times-used and test-used-set
;; fields of the test structs. These fields are essential to
;; determining the order of the tests.
(define (update-count test tests-rest pos mem-table)
(let loop ([l tests-rest]
[p (add1 pos)])
(if (null? l)
(hash-table-get mem-table (test-tst test)
(lambda ()
(hash-table-put!
mem-table
(test-tst test)
(list (test-used-set test)
(test-used-set-neg test)))))
(let ([entry-pair
(hash-table-get mem-table (test-tst test)
(lambda ()
(when (logical-member (test-tst test) (car l))
(set-test-times-used! test (add1 (test-times-used test)))
(set-test-used-set! test (cons p (test-used-set test)))
(set-test-equal-set! test (cons p (test-equal-set test))))
(when (neg-inverse-in (test-tst test) (car l))
(set-test-used-set-neg! test (cons p (test-used-set-neg test))))
(loop (cdr l) (add1 p))))])
(when (and (list? entry-pair) (not (null? entry-pair)))
(let ([trun-used (truncate-list pos (car entry-pair))])
(set-test-used-set! test trun-used)
(set-test-equal-set! test trun-used)
(set-test-times-used! test (length trun-used))
(set-test-used-set-neg! test (truncate-list-neg pos (cadr entry-pair)))))))))
;; update-counts : listof[(cons test any)] -> void
;; This function essentially calls update-count on every test in
;; all of the test lists.
(define (update-counts render-list)
(let* ([mem-table (make-hash-table 'equal)]
[test-master-list (map (compose test-filter car) render-list)]
[test-so-far-lists ;; horrible name
(map
(lambda (tl) (map test-tst (test-filter tl)))
test-master-list)])
(let loop ([tml test-master-list]
[tsf test-so-far-lists]
[pos 1])
(if (null? tml)
(void)
(begin
(for-each
(lambda (t)
(set-test-times-used! t 1)
(set-test-used-set!
t
(cons pos (test-used-set t)))
(set-test-equal-set!
t
(cons pos (test-equal-set t)))
(update-count t (cdr tsf) pos mem-table))
(car tml))
(loop (cdr tml) (cdr tsf) (add1 pos)))))))
)

62
collects/scheme/match/compiler.ss
View File

@ -41,34 +41,29 @@
rows)
esc)])
#`[(#,predicate-stx #,x) rhs]))
(define (compile-con-pat accs pred pat-acc)
(with-syntax ([(tmps ...) (generate-temporaries accs)])
(with-syntax ([(accs ...) accs]
[pred pred]
[body (compile*
(append (syntax->list #'(tmps ...)) xs)
(map (lambda (row)
(define-values (p1 ps) (Row-split-pats row))
(make-Row (append (pat-acc p1) ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
rows)
esc)])
#`[(pred #,x)
(let ([tmps (accs #,x)] ...)
body)])))
(cond
[(eq? 'box k)
(with-syntax ([(v) (generate-temporaries #'(v))])
(with-syntax
([body (compile*
(cons #'v xs)
(map (lambda (r)
(define-values (p1 ps) (Row-split-pats r))
(make-Row (cons (Box-p p1) ps) (Row-rhs r) (Row-unmatch r) (Row-vars-seen r)))
rows)
esc)])
#`[(box? #,x)
(let ([v (unbox #,x)])
body)]))]
(compile-con-pat (list #'unbox) #'box? (compose list Box-p))]
[(eq? 'pair k)
(with-syntax ([(v1 v2) (generate-temporaries #'(v1 v2))])
(with-syntax
([body (compile*
(list* #'v1 #'v2 xs)
(map (lambda (r)
(define-values (p1 ps) (Row-split-pats r))
(make-Row (list* (Pair-a p1) (Pair-d p1) ps) (Row-rhs r) (Row-unmatch r) (Row-vars-seen r)))
rows)
esc)])
#`[(pair? #,x)
(let ([v1 (car #,x)]
[v2 (cdr #,x)])
body)]))]
(compile-con-pat (list #'car #'cdr) #'pair?
(lambda (p) (list (Pair-a p) (Pair-d p))))]
[(eq? 'mpair k)
(compile-con-pat (list #'mcar #'mcdr) #'mpair?
(lambda (p) (list (MPair-a p) (MPair-d p))))]
[(eq? 'string k) (constant-pat #'string?)]
[(eq? 'number k) (constant-pat #'number?)]
[(eq? 'symbol k) (constant-pat #'symbol?)]
@ -78,6 +73,8 @@
[(eq? 'regexp k) (constant-pat #'regexp?)]
[(eq? 'boolean k) (constant-pat #'boolean?)]
[(eq? 'null k) (constant-pat #'null?)]
;; vectors are handled specially
;; because each arity is like a different constructor
[(eq? 'vector k)
(let ()
(define ht (hash-on (lambda (r) (length (Vector-ps (Row-first-pat r)))) rows))
@ -110,21 +107,10 @@
(let* ([s (Row-first-pat (car rows))]
[accs (Struct-accessors s)]
[pred (Struct-pred s)])
(with-syntax ([(tmps ...) (generate-temporaries accs)])
(with-syntax ([(accs ...) accs]
[pred pred]
[body (compile*
(append (syntax->list #'(tmps ...)) xs)
(map (lambda (row)
(define-values (p1 ps) (Row-split-pats row))
(make-Row (append (Struct-ps p1) ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
rows)
esc)])
#`[(pred #,x)
(let ([tmps (accs #,x)] ...)
body)])))]
(compile-con-pat accs pred Struct-ps))]
[else (error 'compile "bad key: ~a" k)]))
;; produces the syntax for a let clause
(define (compile-one vars block esc)
(define-values (first rest-pats) (Row-split-pats (car block)))

91
collects/scheme/match/parse-helper.ss
View File

@ -8,7 +8,95 @@
"compiler.ss"
(only-in srfi/1 delete-duplicates))
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err match-expander-transform matchable?)
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err
match-expander-transform matchable? trans-match parse-struct
dd-parse parse-quote parse-id)
;; parse x as a match variable
;; x : identifier
(define (parse-id x)
(cond [(eq? '_ (syntax-e x))
(make-Dummy x)]
[(ddk? x) (raise-syntax-error 'match "incorrect use of ... in pattern" #'x)]
[else (make-Var x)]))
;; stx : syntax of pattern, starting with quote
;; parse : the parse function
(define (parse-quote stx parse)
(syntax-case stx (quote)
[(quote ())
(make-Null (make-Dummy stx))]
[(quote (a . b))
(make-Pair (parse (syntax/loc stx (quote a)))
(parse (syntax/loc stx (quote b))))]
[(quote vec)
(vector? (syntax-e #'vec))
(make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
(parse (quasisyntax/loc stx (quote #,e)))))]
[(quote bx)
(vector? (syntax-e #'bx))
(make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'bx)))))]
[(quote v)
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
[_
(raise-syntax-error 'match "syntax error in quote pattern" stx)]))
;; parse : the parse fn
;; p : the repeated pattern
;; dd : the ... stx
;; rest : the syntax for the rest
(define (dd-parse parse p dd rest)
(let* ([count (ddk? dd)]
[min (if (number? count) count #f)])
(make-GSeq
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
(list (list (parse p))))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
(parse rest))))
;; stx : the syntax object for the whole pattern
;; cert : the certifier
;; parse : the pattern parser
;; struct-name : identifier
;; pats : syntax representing the member patterns
;; returns a pattern
(define (parse-struct stx cert parse struct-name pats)
(let* ([fail (lambda ()
(raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum struct-name)) stx struct-name))]
[v (syntax-local-value (cert struct-name) fail)])
(unless (struct-info? v)
(fail))
(let-values ([(id _1 pred acc _2 super) (apply values (extract-struct-info v))])
;; this produces a list of all the super-types of this struct
;; ending when it reaches the top of the hierarchy, or a struct that we can't access
(define (get-lineage struct-name)
(let ([super (list-ref
(extract-struct-info (syntax-local-value struct-name))
5)])
(cond [(equal? super #t) '()] ;; no super type exists
[(equal? super #f) '()] ;; super type is unknown
[else (cons super (get-lineage super))])))
(let* (;; the accessors come in reverse order
[acc (reverse acc)]
;; remove the first element, if it's #f
[acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])])
(make-Struct id pred (get-lineage (cert struct-name)) acc
(if (eq? '_ (syntax-e pats))
(map make-Dummy acc)
(let* ([ps (syntax->list pats)])
(unless (= (length ps) (length acc))
(raise-syntax-error 'match (format "wrong number for fields for structure ~a: expected ~a but got ~a"
(syntax->datum struct-name) (length acc) (length ps))
stx pats))
(map parse ps))))))))
(define (trans-match pred transformer pat)
(make-And (list (make-Pred pred) (make-App transformer pat))))
;; transform a match-expander application
;; parse/cert : stx certifier -> pattern
@ -30,6 +118,7 @@
[cert* (lambda (id) (certifier (cert id) #f introducer))])
(parse/cert result cert*))))
;; can we pass this value to regexp-match?
(define (matchable? e)
(or (string? e) (bytes? e)))

66
collects/scheme/match/parse-legacy.ss
View File

@ -19,8 +19,6 @@
[(expander args ...)
(and (identifier? #'expander)
;; for debugging
(syntax-transforming?)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(match-expander-transform parse/legacy/cert cert #'expander stx match-expander-legacy-xform
"This expander only works with the standard match syntax")]
@ -44,34 +42,7 @@
(make-Vector (map parse (syntax->list #'(es ...))))]
[($ s . pats)
(let* ([fail (lambda ()
(raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum #'s)) stx #'s))]
[v (syntax-local-value (cert #'s) fail)])
(unless (struct-info? v)
(fail))
(let-values ([(id _1 pred acc _2 super) (apply values (extract-struct-info v))])
;; this produces a list of all the super-types of this struct
;; ending when it reaches the top of the hierarchy, or a struct that we can't access
(define (get-lineage struct-name)
(let ([super (list-ref
(extract-struct-info (syntax-local-value struct-name))
5)])
(cond [(equal? super #t) '()] ;; no super type exists
[(equal? super #f) '()] ;; super type is unknown
[else (cons super (get-lineage super))])))
(let* (;; the accessors come in reverse order
[acc (reverse acc)]
;; remove the first element, if it's #f
[acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])])
(make-Struct id pred (get-lineage (cert #'s)) acc
(if (eq? '_ (syntax-e #'pats))
(map make-Dummy acc)
(let* ([ps (syntax->list #'pats)])
(unless (= (length ps) (length acc))
(raise-syntax-error 'match (format "wrong number for fields for structure ~a: expected ~a but got ~a"
(syntax->datum #'s) (length acc) (length ps))
stx #'pats))
(map parse ps)))))))]
(parse-struct stx cert parse #'s #'pats)]
[(? p q1 qs ...)
(make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))]
[(? p)
@ -80,47 +51,20 @@
(make-App #'f (parse (cert #'p)))]
[(quasiquote p)
(parse-quasi #'p cert parse/legacy/cert)]
[(quote ())
(make-Null (make-Dummy stx))]
[(quote (a . b))
(make-Pair (parse (syntax/loc stx (quote a)))
(parse (syntax/loc stx (quote b))))]
[(quote vec)
(vector? (syntax-e #'vec))
(make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
(parse (quasisyntax/loc stx (quote #,e)))))]
[(quote bx)
(vector? (syntax-e #'bx))
(make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'bx)))))]
[(quote v)
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
[(quote . rest)
(parse-quote stx parse)]
[() (make-Null (make-Dummy #f))]
[(..)
(ddk? #'..)
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(p .. . rest)
(ddk? #'..)
(let* ([count (ddk? #'..)]
[min (if (number? count) count #f)]
[max (if (number? count) count #f)])
(make-GSeq
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
(list (list (parse #'p))))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
(parse (syntax/loc stx rest))))]
(dd-parse parse #'p #'.. #'rest)]
[(e . es)
(make-Pair (parse #'e) (parse (syntax/loc stx es)))]
[x
(identifier? #'x)
(cond [(eq? '_ (syntax-e #'x))
(make-Dummy #'x)]
[(ddk? #'x) (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'x)]
[else (make-Var #'x)])]
(parse-id #'x)]
[v
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "syntax error in pattern" stx))]))

146
collects/scheme/match/parse.ss
View File

@ -13,12 +13,19 @@
(provide parse/cert)
(define (ht-pat-transform p)
(syntax-case p ()
[(a b) #'(list a b)]
[x
(identifier? #'x)
#'x]))
;; parse : syntax -> Pat
;; compile stx into a pattern, using the new syntax
(define (parse/cert stx cert)
(define (parse stx) (parse/cert stx cert))
(syntax-case* stx (not var struct box cons list vector ? and or quote app regexp pregexp
list-rest list-no-order hash-table quasiquote)
list-rest list-no-order hash-table quasiquote mcons list*)
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(expander args ...)
@ -40,62 +47,36 @@
(let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
(make-And ps))]
[(regexp r)
(make-And (list (make-Pred #'matchable?) (make-App #'(lambda (e) (regexp-match r e)) (make-Pred #'values))))]
(trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (make-Pred #'values))]
[(regexp r p)
(make-And (list (make-Pred #'matchable?) (make-App #'(lambda (e) (regexp-match r e)) (parse #'p))))]
(trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (parse #'p))]
[(pregexp r)
(make-And (list (make-Pred #'matchable?) (make-App (syntax/loc #'r
(lambda (e) (regexp-match (if (pregexp? r)
r
(pregexp r))
e)))
(make-Pred #'values))))]
(trans-match #'matchable? #'(lambda (e) (regexp-match (if (pregexp? r) r (pregexp r)) e)) (make-Pred #'values))]
[(pregexp r p)
(make-And (list (make-Pred #'matchable?) (make-App (syntax/loc #'r
(lambda (e) (regexp-match (if (pregexp? r)
r
(pregexp r))
e)))
(parse #'p))))]
(trans-match #'matchable? #'(lambda (e) (regexp-match (if (pregexp? r) r (pregexp r)) e)) (parse #'p))]
[(box e) (make-Box (parse #'e))]
[(vector es ...)
(ormap ddk? (syntax->list #'(es ...)))
(make-And (list (make-Pred #'vector?) (make-App #'vector->list (parse (syntax/loc stx (list es ...))))))]
(trans-match #'vector? #'vector->list (parse (syntax/loc stx (list es ...))))]
[(vector es ...)
(make-Vector (map parse (syntax->list #'(es ...))))]
[(hash-table p ... dd)
(ddk? #'dd)
(make-And
(list
(make-Pred #'hash-table?)
(make-App
#'(lambda (e) (hash-table-map e list))
(with-syntax ([(elems ...) (map (lambda (p)
(syntax-case p ()
[(a b) #'(list a b)]
[x
(identifier? #'x)
#'x]))
(syntax->list #'(p ...)))])
(parse (syntax/loc stx (list-no-order elems ... dd)))))))]
(trans-match
#'hash-table?
#'(lambda (e) (hash-table-map e list))
(with-syntax ([(elems ...) (map ht-pat-transform (syntax->list #'(p ...)))])
(parse (syntax/loc stx (list-no-order elems ... dd)))))]
[(hash-table p ...)
(ormap ddk? (syntax->list #'(p ...)))
(raise-syntax-error 'match "dot dot k can only appear at the end of hash-table patterns" stx
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
[(hash-table p ...)
(make-And
(list
(make-Pred #'hash-table?)
(make-App
#'(lambda (e) (hash-table-map e list))
(with-syntax ([(elems ...) (map (lambda (p)
(syntax-case p ()
[(a b) #'(list a b)]
[x
(identifier? #'x)
#'x]))
(syntax->list #'(p ...)))])
(parse (syntax/loc stx (list-no-order elems ...)))))))]
(trans-match
#'hash-table?
#'(lambda (e) (hash-table-map e list))
(with-syntax ([(elems ...) (map ht-pat-transform (syntax->list #'(p ...)))])
(parse (syntax/loc stx (list-no-order elems ...)))))]
[(hash-table . _)
(raise-syntax-error 'match "syntax error in hash-table pattern" stx)]
[(list-no-order p ... lp dd)
@ -133,67 +114,22 @@
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(list p .. . rest)
(ddk? #'..)
(let* ([count (ddk? #'..)]
[min (if (number? count) count #f)]
[max (if (number? count) count #f)])
(make-GSeq
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
(list (list (parse #'p))))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
(parse (syntax/loc stx (list . rest)))))]
(dd-parse parse #'p #'.. (syntax/loc stx (list . rest)))]
[(list e es ...)
(make-Pair (parse #'e) (parse (syntax/loc stx (list es ...))))]
[(list* . rest)
(parse (syntax/loc stx (list-rest . rest)))]
[(list-rest e)
(parse #'e)]
[(list-rest p dd . rest)
(ddk? #'dd)
(let* ([count (ddk? #'dd)]
[min (if (number? count) count #f)])
(make-GSeq
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
(list (list (parse #'p))))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
(parse (syntax/loc stx (list-rest . rest)))))]
(dd-parse parse #'p #'dd (syntax/loc stx (list-rest . rest)))]
[(list-rest e . es)
(make-Pair (parse #'e) (parse (syntax/loc #'es (list-rest . es))))]
[(cons e1 e2) (make-Pair (parse #'e1) (parse #'e2))]
[(mcons e1 e2) (make-MPair (parse #'e1) (parse #'e2))]
[(struct s pats)
(let* ([fail (lambda ()
(raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum #'s)) stx #'s))]
[v (syntax-local-value (cert #'s) fail)])
(unless (struct-info? v)
(fail))
(let-values ([(id _1 pred acc _2 super) (apply values (extract-struct-info v))])
;; this produces a list of all the super-types of this struct
;; ending when it reaches the top of the hierarchy, or a struct that we can't access
(define (get-lineage struct-name)
(let ([super (list-ref
(extract-struct-info (syntax-local-value struct-name))
5)])
(cond [(equal? super #t) '()] ;; no super type exists
[(equal? super #f) '()] ;; super type is unknown
[else (cons super (get-lineage super))])))
(let* (;; the accessors come in reverse order
[acc (reverse acc)]
;; remove the first element, if it's #f
[acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])])
(make-Struct id pred (get-lineage (cert #'s)) acc
(if (eq? '_ (syntax-e #'pats))
(map make-Dummy acc)
(let* ([ps (syntax->list #'pats)])
(unless (= (length ps) (length acc))
(raise-syntax-error 'match (format "wrong number for fields for structure ~a: expected ~a but got ~a"
(syntax->datum #'s) (length acc) (length ps))
stx #'pats))
(map parse ps)))))))]
(parse-struct stx cert parse #'s #'pats)]
[(? p q1 qs ...)
(make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))]
[(? p)
@ -202,27 +138,13 @@
(make-App #'f (parse (cert #'p)))]
[(quasiquote p)
(parse-quasi #'p cert parse/cert)]
[(quote ())
(make-Null (make-Dummy stx))]
[(quote (a . b))
(make-Pair (parse (syntax/loc stx (quote a)))
(parse (syntax/loc stx (quote b))))]
[(quote vec)
(vector? (syntax-e #'vec))
(make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
(parse (quasisyntax/loc stx (quote #,e)))))]
[(quote bx)
(vector? (syntax-e #'bx))
(make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'bx)))))]
[(quote v)
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
[(quasiquote . _)
(raise-syntax-error 'match "illegal use of quasiquote")]
[(quote . _)
(parse-quote stx parse)]
[x
(identifier? #'x)
(cond [(eq? '_ (syntax-e #'x))
(make-Dummy #'x)]
[(ddk? #'x) (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'x)]
[else (make-Var #'x)])]
(parse-id #'x)]
[v
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "syntax error in pattern" stx))]))

4
collects/scheme/match/patterns.ss
View File

@ -43,6 +43,7 @@
(define-struct (VectorSeq Pat) (p count start) #:transparent)
(define-struct (Pair CPat) (a d) #:transparent)
(define-struct (MPair CPat) (a d) #:transparent)
(define-struct (Box CPat) (p) #:transparent)
@ -121,6 +122,7 @@
[(Box? p) 'box]
[(Vector? p) 'vector]
[(Pair? p) 'pair]
[(MPair? p) 'mpair]
[(String? p) 'string]
[(Symbol? p) 'symbol]
[(Number? p) 'number]
@ -171,6 +173,8 @@
[(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))

6
collects/typed-scheme/private/base-env.ss
View File

@ -7,7 +7,7 @@
string-constants/string-constant
#;'#%more-scheme
#;'#%qq-and-or
(lib "match-error.ss" "mzlib" "private" "match"))
(only-in scheme/match/patterns match:error))
)
@ -20,7 +20,7 @@
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
"union.ss"
string-constants/string-constant
(lib "match-error.ss" "mzlib" "private" "match")
(only-in scheme/match/patterns match:error)
"tc-structs.ss")
(require (for-syntax
@ -32,7 +32,7 @@
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
"union.ss"
string-constants/string-constant
(lib "match-error.ss" "mzlib" "private" "match")
(only-in scheme/match/patterns match:error)
"tc-structs.ss"))
(define-for-syntax (initialize-others)