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

Rewrite emit and assem to use better style.

Browse Source 
Remove pointless optional arguments in getbindings.
Don't create unneccessary match-lambda*.
Implement keyword arguments to define-match-expander.
Lots of refactoring of gen-match for general clarity.
Use combinators instead of writing our own loops.
Simplify struct info accessor.
Add timing printer.
Refactor coupling/binding for general clarity.
Rewrite logical-equal not to use the expansion of match.
General replacement of () with [].

svn: r4192
This commit is contained in:
Sam Tobin-Hochstadt 2006-08-30 19:41:47 +00:00
parent 048686eade
commit d1fe9f9645
11 changed files with 317 additions and 326 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,10 +6,17 @@
(require "test-structure.scm" (require "test-structure.scm"
"match-helper.ss" "match-helper.ss"
(lib "pretty.ss")
(lib "list.ss")) (lib "list.ss"))
(require-for-template mzscheme) (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 ;;!(function couple-tests
;; (form (couple-tests test-list ks-func kf-func let-bound) ;; (form (couple-tests test-list ks-func kf-func let-bound)
;; -> ;; ->
@ -27,69 +34,57 @@
;; compilation can be completed. This returns a function that takes a ;; compilation can be completed. This returns a function that takes a
;; list of tests so far and a list of bound pattern variables. ;; list of tests so far and a list of bound pattern variables.
(define (couple-tests test-list ks-func kf-func let-bound) (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) (if (null? test-list)
(ks-func (kf-func let-bound) let-bound) (ks-func (kf-func let-bound) let-bound)
(let ([cur-test (car test-list)]) (let* ([cur-test (car test-list)]
(if (and (>= (test-bind-count cur-test) 2) [rest-tests (cdr test-list)]
(not (exp-already-bound? ;; this couples together the rest of the test
(test-bind-exp cur-test) ;; it is passed a list of the already bound expressions
let-bound))) ;; if it is member of ;; only used in test/rest
;;let-bound skip it [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)] (let* ([new-exp (get-exp-var)]
[binding (list (test-bind-exp cur-test) [binding (make-binding (test-bind-exp cur-test)
(test-bind-exp-stx cur-test) (test-bind-exp-stx cur-test)
new-exp)] new-exp)]
[let-bound (cons binding let-bound)] [let-bound (cons binding let-bound)])
[kf (kf-func let-bound)]) (with-syntax (;; the new variable
(lambda (sf bv) [v new-exp]
#`(let ((#,new-exp ;; the expression being bound
#,(sub-expr-subst (bind-get-exp-stx binding) ;; with appropriate substitutions for the already bound portions
let-bound))) [expr (sub-expr-subst (binding-exp-stx binding) let-bound)])
#,(((test-comp (car test-list)) (lambda (sf bv)
(couple-tests (cdr test-list) #`(let ([v expr])
ks-func ;; the new body, using the new binding (through let-bound)
(if (negate-test? cur-test) #,((test/rest let-bound) sf bv)))))
(lambda (let-bound)
(lambda (sf bv) ;; otherwise it doesn't need a binding, and we can just do the test
#`(match-failure))) (test/rest let-bound)))))
kf-func)
;kf-func
let-bound)
kf let-bound) sf bv))))
(let* ([kf (kf-func let-bound)])
((test-comp (car test-list))
(couple-tests (cdr test-list)
ks-func
(if (negate-test? cur-test)
(lambda (let-bound)
(lambda (sf bv)
#`(match-failure)))
kf-func)
;kf-func
let-bound)
kf
let-bound))))))
;;!(function bind-get-exp
;; (form (bind-get-exp binding) -> exp)
;; (contract binding -> exp))
;; This is just an accessor function for a binding. This function
;; returns the expression that is bound in s-exp form.
(define bind-get-exp car)
;;!(function bind-get-exp-stx
;; (form (bind-get-exp-stx binding) -> exp)
;; (contract binding -> exp))
;; This is just an accessor function for a binding. This function
;; returns the expression that is bound in syntax form.
(define bind-get-exp-stx cadr)
;;!(function bind-get-new-exp
;; (form (bind-get-new-exp binding) -> exp)
;; (contract binding -> exp))
;; This is just an accessor function for a binding. This function
;; returns the new symbol that will represent the expression.
(define bind-get-new-exp caddr)
;;!(function subst-bindings ;;!(function subst-bindings
;; (form (subst-bindings exp-stx let-bound) -> syntax) ;; (form (subst-bindings exp-stx let-bound) -> syntax)
@ -102,10 +97,8 @@
;; This function substitutes let bound variables names for the ;; This function substitutes let bound variables names for the
;; expressions that they represent. ;; expressions that they represent.
(define (subst-bindings exp-stx let-bound) (define (subst-bindings exp-stx let-bound)
(define binding (get-bind exp-stx let-bound)) (cond [(get-bind exp-stx let-bound) => binding-new-exp]
(if binding [else (sub-expr-subst exp-stx let-bound)]))
(bind-get-new-exp binding)
(sub-expr-subst exp-stx let-bound)))
;;!(function sub-exp-subst ;;!(function sub-exp-subst
;; (form (sub-exp-subst exp-stx let-bound) -> syntax) ;; (form (sub-exp-subst exp-stx let-bound) -> syntax)
@ -118,19 +111,20 @@
;; This function substitutes let bound variables names for the ;; This function substitutes let bound variables names for the
;; expressions that they represent. This only works if a ;; expressions that they represent. This only works if a
;; subexpression of exp-stx is bound in the let-bound list. ;; 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) (define (sub-expr-subst exp-stx let-bound)
(syntax-case exp-stx () (syntax-case exp-stx ()
[(access sub-exp rest ...) [(access sub-exp rest ...)
(let ([binding (get-bind #'sub-exp let-bound)]) (let ([binding (get-bind #'sub-exp let-bound)])
;;(write (syntax sub-exp))(newline) (write binding)(newline)
(if binding (if binding
#`(access #,(bind-get-new-exp binding) rest ...) #`(access #,(binding-new-exp binding) rest ...)
#`(access #,(sub-expr-subst #'sub-exp let-bound) rest ...)))] #`(access #,(sub-expr-subst #'sub-exp let-bound) rest ...)))]
[_ exp-stx])) [_ exp-stx]))
; helper for the following functions ; helper for the following functions
(define ((equal-bind-get exp) e) (define ((equal-bind-get exp) e)
(equal? exp (bind-get-exp e))) (equal? exp (binding-exp e)))
;;!(function get-bind ;;!(function get-bind
;; (form (get-bind exp let-bound) -> binding) ;; (form (get-bind exp let-bound) -> binding)
@ -164,6 +158,9 @@
;; yeilding one function that when invoked will compile the whole ;; yeilding one function that when invoked will compile the whole
;; original match expression. ;; original match expression.
(define (meta-couple rendered-list failure-func let-bound bvsf) (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) (if (null? rendered-list)
failure-func failure-func
;; here we erase the previously bound variables ;; here we erase the previously bound variables
@ -173,11 +170,16 @@
((meta-couple (cdr rendered-list) ((meta-couple (cdr rendered-list)
failure-func failure-func
let-bound let-bound
bvsf) sf bvsf)))]) bvsf)
sf bvsf)))])
(couple-tests (caar rendered-list) (couple-tests (caar rendered-list)
(cdar rendered-list) ;; successfunc needs (cdar rendered-list) ;; successfunc needs
;; failure method ;; failure method
failed ;; needs let-bound failed ;; needs let-bound
let-bound ;; initial-let bindings let-bound ;; initial-let bindings
)))) ;; fail-func )))) ;; fail-func
(require (lib "trace.ss"))
;(trace meta-couple)
;(trace couple-tests)
) )

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

@ -7,7 +7,7 @@
"coupling-and-binding.scm") "coupling-and-binding.scm")
(require-for-template mzscheme) (require-for-template mzscheme)
;;!(function emit ;;!(function emit
;; (form (emit act-test-func ae let-bound sf bv kf ks) ;; (form (emit act-test-func ae let-bound sf bv kf ks)
;; -> ;; ->
@ -28,76 +28,69 @@
;; determined to be a false property emit calls the fail function. ;; determined to be a false property emit calls the fail function.
;; emit adds implied truths to the test seen so far list so that ;; emit adds implied truths to the test seen so far list so that
;; these truths can be checked against later. ;; these truths can be checked against later.
(define emit (define (emit act-test-func ae let-bound sf bv kf ks)
(lambda (act-test-func ae let-bound sf bv kf ks) (let ([test (syntax-object->datum (act-test-func ae))])
(let ((test (syntax-object->datum (act-test-func ae)))) (cond
(cond [(in test sf) (ks sf bv)]
((in test sf) (ks sf bv)) [(in `(not ,test) sf) (kf sf bv)]
((in `(not ,test) sf) (kf sf bv)) [else
(else (let* ([pred (car test)]
(let* ((pred (car test)) [exp (cadr test)]
(exp (cadr test)) [implied (implied test)]
(implied (implied test)) [not-imp
(not-imp (if (equal? pred 'list?)
(if (equal? pred 'list?) (list `(not (null? ,exp)))
(list `(not (null? ,exp))) '())]
'())) [s (ks (cons test (append implied sf)) bv)]
(s (ks (cons test (append implied sf)) bv)) [k (kf (cons `(not ,test) (append not-imp sf)) bv)]
(k (kf (cons `(not ,test) (append not-imp sf)) bv)) [the-test (act-test-func (subst-bindings ae let-bound))])
(the-test (act-test-func (subst-bindings ae let-bound)))) (assm (syntax-case the-test (struct-pred)
(assm (syntax-case the-test (struct-pred) [(struct-pred pred parent-list exp) #'(pred exp)]
((struct-pred pred parent-list exp) (syntax (pred exp))) [reg #'reg])
(reg (syntax reg))) k s))])))
k s)))))))
;;!(function assm ;;!(function assm
;; (form (assm tst main-fail main-succ) -> syntax) ;; (form (assm tst main-fail main-succ) -> syntax)
;; (contract (syntax syntax syntax) -> syntax)) ;; (contract (syntax syntax syntax) -> syntax))
;; assm - this function is responsible for constructing the actual ;; assm - this function is responsible for constructing the actual
;; if statements. It performs minor expansion optimizations. ;; if statements. It performs minor expansion optimizations.
(define assm (define (assm tst main-fail main-succ)
(lambda (tst main-fail main-succ) (node-count (add1 (node-count)))
(let ((s (syntax-object->datum main-succ)) (cond
(f (syntax-object->datum main-fail))) [(stx-equal? main-succ main-fail)
;; this is for match-count (begin
;;(write (syntax-object->datum tst))(newline) (when (stx-equal? main-succ #'(match-failure))
(node-count (add1 (node-count))) (node-count (sub1 (node-count))))
(cond ((equal? s f) main-succ)]
(begin [(and (eq? (syntax-e main-succ) #t) (eq? (syntax-e main-fail) #f)) tst]
(when (equal? s '(match-failure)) [else
(node-count (sub1 (node-count))) (syntax-case main-succ (if
;(write 'here)(newline) and
'() let/ec
) lambda
main-succ)) let) ;free-identifier=? ;stx-equal?
((and (eq? s #t) (eq? f #f)) tst) [(if (and tsts ...) true-act fail-act)
(else (stx-equal? main-fail #'fail-act)
(syntax-case main-succ (if (quasisyntax/loc
and tst
call/ec (if (and #,tst tsts ...) true-act fail-act))]
lambda [(if tst-prev true-act fail-act)
let) ;free-identifier=? ;stx-equal? (stx-equal? main-fail #'fail-act)
((if (and tsts ...) true-act fail-act) (quasisyntax/loc
(equal? f (syntax-object->datum (syntax fail-act))) tst
(quasisyntax/loc (if (and #,tst tst-prev) true-act fail-act))]
tst [(let/ec k (let ((fail (lambda () (_ f2)))) s2))
(if (and #,tst tsts ...) true-act fail-act))) (stx-equal? main-fail #'f2)
((if tst-prev true-act fail-act) (begin
(equal? f (syntax-object->datum (syntax fail-act))) (error "never happens")
(quasisyntax/loc (printf "got here!~n")
tst (quasisyntax/loc
(if (and #,tst tst-prev) true-act fail-act))) tst
((call/ec (let/ec k
(lambda (k) (let ((fail (lambda () (_ f2)))) s2))) (let ((fail (lambda () (k #,main-fail))))
(equal? f (syntax-object->datum (syntax f2))) #,(assm tst (syntax/loc tst (fail)) (syntax s2))))))]
(quasisyntax/loc ;; leaving out pattern that is never used in original
tst [_ (quasisyntax/loc
(call/ec tst
(lambda (k) (if #,tst #,main-succ #,main-fail))])]))
(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)))))))))
) )

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

@ -18,6 +18,8 @@
(lib "etc.ss") (lib "etc.ss")
"match-error.ss") "match-error.ss")
;;!(function mark-patlist ;;!(function mark-patlist
;; (form (mark-patlist clauses) -> marked-clause-list) ;; (form (mark-patlist clauses) -> marked-clause-list)
;; (contract list -> list)) ;; (contract list -> list))
@ -74,31 +76,16 @@
(lambda (sf bv) (lambda (sf bv)
;; mark this pattern as reached ;; mark this pattern as reached
(set-cdr! car-patlist #t) (set-cdr! car-patlist #t)
(if fail-sym (with-syntax ([fail-var fail-sym]
#`(let/ec fail-cont [(bound-vars ...) (map car bv)]
(let [(args ...) (map (lambda (b) (subst-bindings (cdr b) let-bound)) bv)]
((failure [body body])
(lambda () (if fail-sym
(fail-cont #`(let/ec fail-cont
; it seems like fail is called (let ([fail-var (lambda () (fail-cont #,(fail sf bv)))]
; twice in this situation [bound-vars args] ...)
#,( fail sf bv))))) . body))
((lambda (#,fail-sym #'(let ([bound-vars args] ...) . body))))
#,@(map car bv))
#,@body)
failure
#,@(map (lambda (b)
(subst-bindings
(cdr b)
let-bound))
bv))))
#`((lambda #,(map car bv)
#,@body)
#,@(map
(lambda (b) (subst-bindings
(cdr b)
let-bound))
bv))))
(lambda (sf bv) (lambda (sf bv)
;; mark this pattern as reached ;; mark this pattern as reached
(set-cdr! car-patlist #t) (set-cdr! car-patlist #t)
@ -113,6 +100,40 @@
(define test-list (render-test-list pat exp (lambda (x) x) stx)) (define test-list (render-test-list pat exp (lambda (x) x) stx))
(cons test-list success)) (cons test-list success))
;;!(function gen
;; (form (gen exp tsf patlist stx failure-func opt success-func)
;; ->
;; syntax)
;; (contract (syntax list list syntax
;; (() -> void) bool (list list -> syntax))
;; ->
;; syntax))
;; This function is primarily called by gen-help and takes the the
;; newly marked clauses and the failure-func which is really a
;; variable-name which will bound to the failure in the runtime
;; code. This function then This function
;; then takes these lists of partially compiled tests and reorders
;; them in an attempt to reduce the size of the final compiled
;; match expression. Binding counts are also updated to help
;; determind which supexpressions of the expression to be matched
;; need to be bound by let expressions. After all of this the
;; tests are "coupled" together for final compilation.
#;(define (gen exp tsf patlist stx failure-func opt success-func)
;; iterate through list and render each pattern to a list of tests
;; and success functions
(define rendered-list
(map (lambda (clause) (test-list-with-success-func
exp clause stx success-func))
patlist))
(update-counts rendered-list)
(tag-negate-tests rendered-list)
(update-binding-counts rendered-list)
((meta-couple (reorder-all-lists rendered-list)
(lambda (sf bv) failure-func)
'()
'())
'() '()))
;;!(function gen-match ;;!(function gen-match
;; (form (gen-match exp tsf patlist stx [success-func]) ;; (form (gen-match exp tsf patlist stx [success-func])
;; -> ;; ->
@ -121,10 +142,8 @@
;; (list list -> syntax-object)) ;; (list list -> syntax-object))
;; -> ;; ->
;; syntax-object)) ;; syntax-object))
;; <p>gen-match is the gateway through which match, match-lambda, ;; <p>gen-match is the gateway through which match accesses the match
;; match-lambda*, ;; pattern compiler.
;; match-let, match-let*, match-letrec, match-define access the match
;; expression compiler.
;; ;;
;; <p>exp - the expression that is to be tested against the pattern. ;; <p>exp - the expression that is to be tested against the pattern.
;; This should normally be a piece of syntax that indirectly ;; This should normally be a piece of syntax that indirectly
@ -150,75 +169,45 @@
;; of the recursion tree. The success function must take two arguments ;; of the recursion tree. The success function must take two arguments
;; and it should return a syntax object. ;; and it should return a syntax object.
(define gen-match (define gen-match
(opt-lambda (exp tsf patlist stx [success-func #f]) (opt-lambda (exp tsf patlist stx [success-func #f])
(initer)
;;!(function gen-help (when (stx-null? patlist)
;; (form (gen-help exp tsf patlist stx [success-func]) -> (match:syntax-err stx "null clause list"))
;; syntax-object) (print-time "entering gen-match")
;; (contract (syntax-object list list syntax-object (let* (;; We set up the list of
;; (list list -> syntax-object)) ;; clauses so that one can mark that they have been "reached".
;; -> [marked-clauses (mark-patlist patlist)]
;; syntax-object)) [failure-func #'(match-failure)]
;; This function does some basic house keeping before forwarding ;; iterate through list and render each pattern to a list of partially compiled tests
;; the compilation to the gen function. It sets up the list of ;; and success functions.
;; clauses so that one can mark that they have been "reached". It ;; These are partially compiled
;; also wraps the final compilation in syntax which binds the ;; because the test structures containa a function that needs to
;; match-failure function. ;; be coupled with the other functions of the other test
(define (gen-help opt) ;; structures before actual compilation results.
(when (stx-null? patlist) [rendered-list (map (lambda (clause) (test-list-with-success-func
(match:syntax-err stx "null clause list")) exp clause stx success-func))
(let* ([marked-clauses (mark-patlist patlist)] marked-clauses)]
[compiled-match [_ (begin
#`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))]) (print-time "finished render-list")
#,(gen exp tsf marked-clauses (update-counts rendered-list)
stx (tag-negate-tests rendered-list)
#'(match-failure) (update-binding-counts rendered-list))]
opt ;; couple the partially compiled tests together into the final result.
success-func))]) [compiled-exp
(unreachable marked-clauses stx) (begin
compiled-match)) (print-time "starting coupling")
((meta-couple (reorder-all-lists rendered-list)
(lambda (sf bv) failure-func)
'()
'())
'() '()))]
;;!(function gen ;; Also wrap the final compilation in syntax which binds the
;; (form (gen exp tsf patlist stx failure-func opt success-func) ;; match-failure function.
;; -> [compiled-match
;; syntax) #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))])
;; (contract (syntax list list syntax #,compiled-exp)])
;; (() -> void) bool (list list -> syntax)) (print-time "finished coupling")
;; -> (unreachable marked-clauses stx)
;; syntax)) (print-time "done")
;; This function is primarily called by gen-help and takes the the compiled-match)))
;; newly marked clauses and the failure-func which is really a
;; variable-name which will bound to the failure in the runtime
;; code. This function then makes successive calls to
;; test-list-with-success-func which gives us a list of partially
;; compiled tests for each clause. I say 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. This function
;; then takes these lists of partially compiled tests and reorders
;; them in an attempt to reduce the size of the final compiled
;; match expression. Binding counts are also updated to help
;; determind which supexpressions of the expression to be matched
;; need to be bound by let expressions. After all of this the
;; tests are "coupled" together for final compilation.
(define (gen exp tsf patlist stx failure-func opt success-func)
;; iterate through list and render each pattern to a list of tests
;; and success functions
(define rendered-list
(map (lambda (clause) (test-list-with-success-func
exp clause stx success-func))
patlist))
(update-counts rendered-list)
(tag-negate-tests rendered-list)
(update-binding-counts rendered-list)
((meta-couple (reorder-all-lists rendered-list)
(lambda (sf bv) failure-func)
'()
'())
'() '()))
(gen-help #f)))
) )

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

@ -36,10 +36,9 @@
kf kf
ks ks
cert cert
[stx (syntax '())] [stx (syntax '())])
[opt #f])
(next-outer-helper p ae sf bv let-bound (next-outer-helper p ae sf bv let-bound
(lambda (x) kf) (lambda (a b) ks) cert stx opt)) (lambda (x) kf) (lambda (a b) ks) cert stx))
;;!(function next-outer-helper ;;!(function next-outer-helper
;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool) ;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool)
@ -63,8 +62,7 @@
kf-func kf-func
ks-func ks-func
cert cert
[stx (syntax '())] [stx (syntax '())])
[opt #f])
;; right now this does not bind new variables ;; right now this does not bind new variables
(let ((rendered-list (render-test-list p ae cert stx))) (let ((rendered-list (render-test-list p ae cert stx)))
;; no need to reorder lists although I suspect that it may be ;; no need to reorder lists although I suspect that it may be

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

@ -5,11 +5,12 @@
;; (define-match-expander id transformer-for-plt-match ;; (define-match-expander id [#:plt-match transformer-for-plt-match]
;; [transformer-for-match] ;; [#:match transformer-for-match]
;; [transformer-outside-of-match]) ;; [#:expression transformer-outside-of-match])
;; if only three args, the third is assumed to be the transformer-outside-of-match
;; I wish I had keyword macro args ;; 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-syntax (define-match-expander stx)
(define (lookup v alist) (define (lookup v alist)
@ -52,37 +53,16 @@
[nm #'std-xform])) [nm #'std-xform]))
(syntax-local-certifier))) (syntax-local-certifier)))
#'(define-syntax id (make-match-expander plt-match-xform match-xform 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) [(_ id plt-match-xform match-xform std-xform)
(if (identifier? (syntax std-xform)) #'(define-match-expander id #:plt-match plt-match-xform #:match match-xform #:expression 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))))]
[(_ id plt-match-xform std-xform) [(_ id plt-match-xform std-xform)
(if (identifier? (syntax std-xform)) #'(define-match-expander id #:plt-match plt-match-xform #:expression std-xform)]
#`(define-syntax id (make-match-expander plt-match-xform
#f
(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 #f std-xform (syntax-local-certifier))))]
[(_ id plt-match-xform) [(_ id plt-match-xform)
#'(define-syntax id #'(define-match-expander id #:plt-match plt-match-xform)]
(make-match-expander
plt-match-xform
#f
(lambda (stx)
(match:syntax-err stx "This match expander must be used inside match"))
(syntax-local-certifier)))]
;; error checking
[_ (match:syntax-err stx "Invalid use of define-match-expander")] [_ (match:syntax-err stx "Invalid use of define-match-expander")]
)) ))

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

@ -55,9 +55,9 @@
;; (values pred accessors mutators parental-chain)) ;; (values pred accessors mutators parental-chain))
;; (contract (syntax-object) ;; (contract (syntax-object)
;; -> ;; ->
;; (values (any -> bool) list list))) ;; (values (any -> bool) list list list)))
;; This function takes a syntax-object that is the name of a structure ;; This function takes a syntax-object that is the name of a structure.
;; as well as a failure thunk. It returns three values. The first is ;; It returns four values. The first is
;; a predicate for the structure. The second is a list of accessors ;; a predicate for the structure. The second is a list of accessors
;; in the same order as the fields of the structure declaration. The ;; 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 ;; third is a list of mutators for the structure also in the same
@ -82,6 +82,8 @@
(values (reverse accs) (values (reverse accs)
(reverse muts)))) (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) (define (get-lineage struct-name)
(let ([super (list-ref (let ([super (list-ref
(local-val struct-name) (local-val struct-name)
@ -89,20 +91,18 @@
(cond [(equal? super #t) '()] ;; no super type exists (cond [(equal? super #t) '()] ;; no super type exists
[(equal? super #f) '()] ;; super type is unknown [(equal? super #f) '()] ;; super type is unknown
[else (cons super (get-lineage super))]))) [else (cons super (get-lineage super))])))
(define info-on-struct (local-val struct-name)) (define info-on-struct (local-val struct-name))
(define (get-info info-on-struct) (define (ref-info i) (list-ref info-on-struct i))
(let-values ([(accs muts)
(handle-acc/mut-lists
(list-ref info-on-struct accessors-index)
(list-ref info-on-struct mutators-index))])
(values accs muts
(list-ref info-on-struct pred-index))))
(unless (struct-declaration-info? info-on-struct) (failure-thunk)) (unless (struct-declaration-info? info-on-struct) (failure-thunk))
(let-values ([(accessors mutators pred) (get-info info-on-struct)] (let*-values ([(acc-list) (ref-info accessors-index)]
[(parental-chain) (get-lineage struct-name)]) [(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))) (values pred accessors mutators (cons struct-name parental-chain)))
) )
@ -467,4 +467,18 @@
(define match-equality-test (make-parameter equal?)) (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)))))
) )

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

@ -55,7 +55,7 @@
#'(letrec ([name (match-lambda* ((list pat ...) . body))]) #'(letrec ([name (match-lambda* ((list pat ...) . body))])
(name exp ...))] (name exp ...))]
[(_ ([pat exp] ...) . body) [(_ ([pat exp] ...) . body)
#'((match-lambda* ((list pat ...) . body)) exp ...)])) #'(match (list exp ...) [(list pat ...) . body])]))
(define-syntax (match-let* stx) (define-syntax (match-let* stx)
(syntax-case stx () (syntax-case stx ()

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

@ -52,46 +52,47 @@
(,@pat (,@pat
(q-error (syntax ,@pat) "unquote-splicing not nested in list")) (q-error (syntax ,@pat) "unquote-splicing not nested in list"))
((x . y) ((x . y)
(let* ((list-type 'list) (let* ([list-type 'list]
(result [result
(let loop (let loop
((l (syntax-e (syntax (x . y))))) ((l (syntax-e (syntax (x . y)))))
;(write l)(newline) ;(write l)(newline)
(cond ((null? l) '()) (cond [(null? l) '()]
((and (stx-pair? (car l)) [(and (stx-pair? (car l))
(equal? (car (syntax-object->datum (car l))) (equal? (car (syntax-object->datum (car l)))
'unquote-splicing)) 'unquote-splicing))
(let ((first-car (let ([first-car
(syntax-case (car l) (syntax-case (car l)
(unquote-splicing quasiquote) (unquote-splicing quasiquote)
(,@`p ;; have to parse forward here [,@`p ;; have to parse forward here
(let ((pq (parse-q (syntax p)))) (let ((pq (parse-q (syntax p))))
(if (stx-list? pq) (if (stx-list? pq)
(cdr (syntax->list pq)) (cdr (syntax->list pq))
(q-error (syntax ,@`p) (q-error (syntax ,@`p)
"unquote-splicing not followed by list")))) "unquote-splicing not followed by list")))]
(,@p [,@p
(if (stx-list? (syntax p)) (if (and (stx-list? (syntax p))
(eq? (syntax-e (car (syntax->list #'p))) 'list))
(cdr (syntax->list (syntax p))) (cdr (syntax->list (syntax p)))
(begin ; (write (syntax-e (syntax p))) (begin ; (write (syntax-e (syntax p)))
(q-error (syntax ,@p) (q-error (syntax ,@p)
"unquote-splicing not followed by list"))))))) "unquote-splicing not followed by list")))])])
(syntax-case (cdr l) (unquote unquote-splicing) (syntax-case (cdr l) (unquote unquote-splicing)
(,@p (q-error (syntax ,@p) [,@p (q-error (syntax ,@p)
"unquote-splicing can not follow dot notation")) "unquote-splicing can not follow dot notation")]
(,p [,p
(let ((res (parse-q (syntax ,p)))) (let ((res (parse-q (syntax ,p))))
(set! list-type 'list-rest) (set! list-type 'list-rest)
`(,@first-car ,res))) `(,@first-car ,res))]
(p (or (stx-pair? (syntax p)) [p (or (stx-pair? (syntax p))
(stx-null? (syntax p))) (stx-null? (syntax p)))
(append first-car (append first-car
(loop (syntax-e (syntax p))))) (loop (syntax-e (syntax p))))]
(p ;; must be an atom [p ;; must be an atom
(let ((res (parse-q (syntax p)))) (let ([res (parse-q (syntax p))])
(set! list-type 'list-rest) (set! list-type 'list-rest)
`(,@first-car ,res)))))) `(,@first-car ,res))]))]
(else [else
(syntax-case (cdr l) (unquote unquote-splicing) (syntax-case (cdr l) (unquote unquote-splicing)
(,@p (q-error (syntax p) (,@p (q-error (syntax p)
"unquote-splicing can not follow dot notation")) "unquote-splicing can not follow dot notation"))
@ -107,7 +108,7 @@
(begin (begin
(set! list-type 'list-rest) (set! list-type 'list-rest)
(list (parse-q (car l)) (list (parse-q (car l))
(parse-q (syntax p))))))))))) (parse-q (syntax p))))))]))])
(quasisyntax/loc stx (#,list-type #,@result)))) (quasisyntax/loc stx (#,list-type #,@result))))
(p (p
(vector? (syntax-object->datum (syntax p))) (vector? (syntax-object->datum (syntax p)))

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

@ -223,8 +223,7 @@
(`quasi-pat (`quasi-pat
(render-test-list (parse-quasi #'quasi-pat) ae cert stx)) (render-test-list (parse-quasi #'quasi-pat) ae cert stx))
;; check for predicate patterns
;; check for predicate patterns
;; could we check to see if a predicate is a procedure here? ;; could we check to see if a predicate is a procedure here?
((? pred?) ((? pred?)
(list (reg-test (list (reg-test
@ -233,8 +232,8 @@
ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))) ae (lambda (exp) #`(#,(cert #'pred?) #,exp)))))
;; predicate patterns with binders are redundant with and patterns ;; predicate patterns with binders are redundant with and patterns
((? pred? pats ...) [(? pred? pats ...)
(render-test-list #'(and (? pred?) pats ...) ae cert stx)) (render-test-list #'(and (? pred?) pats ...) ae cert stx)]
;; syntax checking ;; syntax checking
((? anything ...) ((? anything ...)
@ -264,15 +263,8 @@
(if (zero? (length (syntax-e #'op))) (if (zero? (length (syntax-e #'op)))
"an operation pattern must have a procedure following the app" "an operation pattern must have a procedure following the app"
"there should be one pattern following the operator"))) "there should be one pattern following the operator")))
((and . pats) [(and . pats) (map-append (lambda (pat) (render-test-list pat ae cert stx))
(let loop (syntax->list #'pats))]
((p #'pats))
(syntax-case p ()
;; empty and always succeeds
[() '()] ;(ks seensofar boundvars let-bound))
[(pat . rest)
(append (render-test-list #'pat ae cert stx)
(loop #'rest))])))
((or . pats) ((or . pats)
(list (make-act (list (make-act

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

@ -115,6 +115,8 @@
(define (shape-test? test) (define (shape-test? test)
(test-shape test)) (test-shape test))
(define (negate-test? test) (define (negate-test? test)
(test-closest-shape-tst test)) (test-closest-shape-tst test))
) )

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

@ -5,7 +5,8 @@
(provide update-counts) (provide update-counts)
(require "test-structure.scm" (require "test-structure.scm"
"match-helper.ss") "match-helper.ss"
(lib "list.ss"))
;;!(function test-filter ;;!(function test-filter
;; (form (test-filter test-list) -> test-list) ;; (form (test-filter test-list) -> test-list)
@ -13,7 +14,10 @@
;; This function filters out tests that do not need to be to have ;; This function filters out tests that do not need to be to have
;; their counts updated for reordering purposes. These are the ;; their counts updated for reordering purposes. These are the
;; more complex patterns such as or-patterns or ddk patterns. ;; more complex patterns such as or-patterns or ddk patterns.
(define test-filter
(define (test-filter tlist)
(filter (lambda (t) (not (= -1 (test-times-used t)))) tlist))
#;(define test-filter
(lambda (tlist) (lambda (tlist)
(if (null? tlist) (if (null? tlist)
'() '()
@ -54,13 +58,29 @@
(logical-equal? item cur)) (logical-equal? item cur))
lst))) lst)))
(define logical-equal? (define (logical-equal? a b)
(or (equal? a b) #t
(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)))))
;; this implements the above code
#;(define logical-equal?
(lambda x (lambda x
(if (pair? x) (if (pair? x)
(let ((exp8163 (cdr x))) (let ((exp8163 (cdr x)))
(if (and (pair? exp8163) (null? (cdr exp8163))) (if (and (pair? exp8163) (null? (cdr exp8163)))
(if (equal? (car exp8163) (car x)) (if (equal? (car exp8163) (car x))
((lambda (a) #t) (car x)) #t
(let ((exp8164 (car x))) (let ((exp8164 (car x)))
(if (and (pair? exp8164) (equal? (car exp8164) 'list?)) (if (and (pair? exp8164) (equal? (car exp8164) 'list?))
(let ((exp8165 (cdr exp8164))) (let ((exp8165 (cdr exp8164)))
@ -167,7 +187,7 @@
(if (null? tml) (if (null? tml)
'() '()
(begin (begin
(map (lambda (t) (for-each (lambda (t)
(set-test-times-used! t 1) (set-test-times-used! t 1)
(set-test-used-set! (set-test-used-set!
t t