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

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

@ -6,10 +6,17 @@
(require "test-structure.scm"
"match-helper.ss"
(lib "pretty.ss")
(lib "list.ss"))
(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)
;; ->
@ -27,69 +34,57 @@
;; 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)])
(if (and (>= (test-bind-count cur-test) 2)
(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))) ;; if it is member of
;;let-bound skip it
let-bound)))
;; then generate a new binding for this expression
(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)
new-exp)]
[let-bound (cons binding let-bound)]
[kf (kf-func let-bound)])
[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 ((#,new-exp
#,(sub-expr-subst (bind-get-exp-stx binding)
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) 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))))))
#`(let ([v expr])
;; the new body, using the new binding (through let-bound)
#,((test/rest let-bound) sf bv)))))
;;!(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)
;; 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)
@ -102,10 +97,8 @@
;; This function substitutes let bound variables names for the
;; expressions that they represent.
(define (subst-bindings exp-stx let-bound)
(define binding (get-bind exp-stx let-bound))
(if binding
(bind-get-new-exp binding)
(sub-expr-subst 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)
@ -118,19 +111,20 @@
;; 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)])
;;(write (syntax sub-exp))(newline) (write binding)(newline)
(if binding
#`(access #,(bind-get-new-exp binding) rest ...)
#`(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 (bind-get-exp e)))
(equal? exp (binding-exp e)))
;;!(function get-bind
;; (form (get-bind exp let-bound) -> binding)
@ -164,6 +158,9 @@
;; 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
@ -173,11 +170,16 @@
((meta-couple (cdr rendered-list)
failure-func
let-bound
bvsf) sf bvsf)))])
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 (lib "trace.ss"))
;(trace meta-couple)
;(trace couple-tests)
)

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

@ -28,76 +28,69 @@
;; 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
(lambda (act-test-func ae let-bound sf bv kf ks)
(let ((test (syntax-object->datum (act-test-func ae))))
(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
[(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))))
'())]
[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) (syntax (pred exp)))
(reg (syntax reg)))
k s)))))))
[(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
(lambda (tst main-fail main-succ)
(let ((s (syntax-object->datum main-succ))
(f (syntax-object->datum main-fail)))
;; this is for match-count
;;(write (syntax-object->datum tst))(newline)
(define (assm tst main-fail main-succ)
(node-count (add1 (node-count)))
(cond ((equal? s f)
(cond
[(stx-equal? main-succ main-fail)
(begin
(when (equal? s '(match-failure))
(node-count (sub1 (node-count)))
;(write 'here)(newline)
'()
)
main-succ))
((and (eq? s #t) (eq? f #f)) tst)
(else
(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
call/ec
let/ec
lambda
let) ;free-identifier=? ;stx-equal?
((if (and tsts ...) true-act fail-act)
(equal? f (syntax-object->datum (syntax fail-act)))
[(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)
(equal? f (syntax-object->datum (syntax fail-act)))
(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)))
((call/ec
(lambda (k) (let ((fail (lambda () (_ f2)))) s2)))
(equal? f (syntax-object->datum (syntax f2)))
(if (and #,tst tst-prev) true-act fail-act))]
[(let/ec k (let ((fail (lambda () (_ f2)))) s2))
(stx-equal? main-fail #'f2)
(begin
(error "never happens")
(printf "got here!~n")
(quasisyntax/loc
tst
(call/ec
(lambda (k)
(let/ec k
(let ((fail (lambda () (k #,main-fail))))
#,(assm tst (syntax/loc tst (fail)) (syntax s2)))))))
#,(assm tst (syntax/loc tst (fail)) (syntax s2))))))]
;; leaving out pattern that is never used in original
(_ (quasisyntax/loc
[_ (quasisyntax/loc
tst
(if #,tst #,main-succ #,main-fail)))))))))
(if #,tst #,main-succ #,main-fail))])]))
)

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

@ -18,6 +18,8 @@
(lib "etc.ss")
"match-error.ss")
;;!(function mark-patlist
;; (form (mark-patlist clauses) -> marked-clause-list)
;; (contract list -> list))
@ -74,31 +76,16 @@
(lambda (sf bv)
;; mark this pattern as reached
(set-cdr! car-patlist #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
((failure
(lambda ()
(fail-cont
; it seems like fail is called
; twice in this situation
#,( fail sf bv)))))
((lambda (#,fail-sym
#,@(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))))
(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-cdr! car-patlist #t)
@ -113,6 +100,40 @@
(define test-list (render-test-list pat exp (lambda (x) x) stx))
(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
;; (form (gen-match exp tsf patlist stx [success-func])
;; ->
@ -121,10 +142,8 @@
;; (list list -> syntax-object))
;; ->
;; syntax-object))
;; <p>gen-match is the gateway through which match, match-lambda,
;; match-lambda*,
;; match-let, match-let*, match-letrec, match-define access the match
;; expression compiler.
;; <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
@ -151,74 +170,44 @@
;; and it should return a syntax object.
(define gen-match
(opt-lambda (exp tsf patlist stx [success-func #f])
;;!(function gen-help
;; (form (gen-help exp tsf patlist stx [success-func]) ->
;; syntax-object)
;; (contract (syntax-object list list syntax-object
;; (list list -> syntax-object))
;; ->
;; syntax-object))
;; This function does some basic house keeping before forwarding
;; the compilation to the gen function. It sets up the list of
;; clauses so that one can mark that they have been "reached". It
;; also wraps the final compilation in syntax which binds the
;; match-failure function.
(define (gen-help opt)
(initer)
(when (stx-null? patlist)
(match:syntax-err stx "null clause list"))
(let* ([marked-clauses (mark-patlist patlist)]
[compiled-match
#`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))])
#,(gen exp tsf marked-clauses
stx
#'(match-failure)
opt
success-func))])
(unreachable marked-clauses stx)
compiled-match))
;;!(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 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
(print-time "entering gen-match")
(let* (;; We set up the list of
;; clauses so that one can mark that they have been "reached".
[marked-clauses (mark-patlist patlist)]
[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. 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
;; structures before actual compilation results.
[rendered-list (map (lambda (clause) (test-list-with-success-func
exp clause stx success-func))
patlist))
marked-clauses)]
[_ (begin
(print-time "finished render-list")
(update-counts rendered-list)
(tag-negate-tests rendered-list)
(update-binding-counts rendered-list)
(update-binding-counts rendered-list))]
;; couple the partially compiled tests together into the final result.
[compiled-exp
(begin
(print-time "starting coupling")
((meta-couple (reorder-all-lists rendered-list)
(lambda (sf bv) failure-func)
'()
'())
'() '()))
(gen-help #f)))
'() '()))]
;; Also wrap the final compilation in syntax which binds the
;; match-failure function.
[compiled-match
#`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))])
#,compiled-exp)])
(print-time "finished coupling")
(unreachable marked-clauses stx)
(print-time "done")
compiled-match)))
)

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

@ -36,10 +36,9 @@
kf
ks
cert
[stx (syntax '())]
[opt #f])
[stx (syntax '())])
(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
;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool)
@ -63,8 +62,7 @@
kf-func
ks-func
cert
[stx (syntax '())]
[opt #f])
[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

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

@ -5,11 +5,12 @@
;; (define-match-expander id transformer-for-plt-match
;; [transformer-for-match]
;; [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
;; (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)
@ -52,37 +53,16 @@
[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 match-xform std-xform)
(if (identifier? (syntax 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)
(if (identifier? (syntax 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)
#'(define-syntax id
(make-match-expander
plt-match-xform
#f
(lambda (stx)
(match:syntax-err stx "This match expander must be used inside match"))
(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")]
))

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

@ -55,9 +55,9 @@
;; (values pred accessors mutators parental-chain))
;; (contract (syntax-object)
;; ->
;; (values (any -> bool) list list)))
;; 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
;; (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
@ -82,6 +82,8 @@
(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
(local-val struct-name)
@ -89,19 +91,17 @@
(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 (local-val struct-name))
(define (get-info info-on-struct)
(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))))
(define (ref-info i) (list-ref info-on-struct i))
(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)]
[(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)))
)
@ -467,4 +467,18 @@
(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))])
(name exp ...))]
[(_ ([pat exp] ...) . body)
#'((match-lambda* ((list pat ...) . body)) exp ...)]))
#'(match (list exp ...) [(list pat ...) . body])]))
(define-syntax (match-let* stx)
(syntax-case stx ()

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

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

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

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

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

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

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

@ -5,7 +5,8 @@
(provide update-counts)
(require "test-structure.scm"
"match-helper.ss")
"match-helper.ss"
(lib "list.ss"))
;;!(function test-filter
;; (form (test-filter test-list) -> test-list)
@ -13,7 +14,10 @@
;; 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
(define (test-filter tlist)
(filter (lambda (t) (not (= -1 (test-times-used t)))) tlist))
#;(define test-filter
(lambda (tlist)
(if (null? tlist)
'()
@ -54,13 +58,29 @@
(logical-equal? item cur))
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
(if (pair? x)
(let ((exp8163 (cdr x)))
(if (and (pair? exp8163) (null? (cdr exp8163)))
(if (equal? (car exp8163) (car x))
((lambda (a) #t) (car x))
#t
(let ((exp8164 (car x)))
(if (and (pair? exp8164) (equal? (car exp8164) 'list?))
(let ((exp8165 (cdr exp8164)))
@ -167,7 +187,7 @@
(if (null? tml)
'()
(begin
(map (lambda (t)
(for-each (lambda (t)
(set-test-times-used! t 1)
(set-test-used-set!
t