Rewrite emit and assem to use better style.
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
parent
048686eade
commit
d1fe9f9645
|
|
@ -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)
|
||||
(not (exp-already-bound?
|
||||
(test-bind-exp cur-test)
|
||||
let-bound))) ;; if it is member of
|
||||
;;let-bound skip it
|
||||
(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 (list (test-bind-exp cur-test)
|
||||
(test-bind-exp-stx cur-test)
|
||||
new-exp)]
|
||||
[let-bound (cons binding let-bound)]
|
||||
[kf (kf-func 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))))))
|
||||
|
||||
;;!(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)
|
||||
[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)
|
||||
|
|
@ -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)))
|
||||
(define ((equal-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)
|
||||
)
|
||||
|
|
@ -7,7 +7,7 @@
|
|||
"coupling-and-binding.scm")
|
||||
|
||||
(require-for-template mzscheme)
|
||||
|
||||
|
||||
;;!(function emit
|
||||
;; (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.
|
||||
;; 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))))
|
||||
(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) (syntax (pred exp)))
|
||||
(reg (syntax reg)))
|
||||
k s)))))))
|
||||
(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
|
||||
(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)
|
||||
(node-count (add1 (node-count)))
|
||||
(cond ((equal? s f)
|
||||
(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
|
||||
(syntax-case main-succ (if
|
||||
and
|
||||
call/ec
|
||||
lambda
|
||||
let) ;free-identifier=? ;stx-equal?
|
||||
((if (and tsts ...) true-act fail-act)
|
||||
(equal? f (syntax-object->datum (syntax 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)))
|
||||
(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)))
|
||||
(quasisyntax/loc
|
||||
tst
|
||||
(call/ec
|
||||
(lambda (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)))))))))
|
||||
(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
|
||||
(error "never happens")
|
||||
(printf "got here!~n")
|
||||
(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))])]))
|
||||
)
|
||||
|
|
@ -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)
|
||||
(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))))
|
||||
(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-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
|
||||
|
|
@ -150,75 +169,45 @@
|
|||
;; of the recursion tree. The success function must take two arguments
|
||||
;; 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)
|
||||
(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
|
||||
;; 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)))
|
||||
(opt-lambda (exp tsf patlist stx [success-func #f])
|
||||
(initer)
|
||||
(when (stx-null? patlist)
|
||||
(match:syntax-err stx "null clause list"))
|
||||
(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.
|
||||
[rendered-list (map (lambda (clause) (test-list-with-success-func
|
||||
exp clause stx success-func))
|
||||
marked-clauses)]
|
||||
[_ (begin
|
||||
(print-time "finished render-list")
|
||||
(update-counts rendered-list)
|
||||
(tag-negate-tests 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)
|
||||
'()
|
||||
'())
|
||||
'() '()))]
|
||||
;; 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)))
|
||||
)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))))]
|
||||
|
||||
;; implement legacy syntax
|
||||
[(_ 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))))]
|
||||
#'(define-match-expander id #:plt-match plt-match-xform #:match match-xform #:expression std-xform)]
|
||||
[(_ 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))))]
|
||||
#'(define-match-expander id #:plt-match plt-match-xform #:expression std-xform)]
|
||||
[(_ 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)))]
|
||||
#'(define-match-expander id #:plt-match plt-match-xform)]
|
||||
|
||||
;; error checking
|
||||
[_ (match:syntax-err stx "Invalid use of define-match-expander")]
|
||||
))
|
||||
|
||||
|
|
|
|||
|
|
@ -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,20 +91,18 @@
|
|||
(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)]
|
||||
[(parental-chain) (get-lineage struct-name)])
|
||||
(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)))))
|
||||
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -223,8 +223,7 @@
|
|||
(`quasi-pat
|
||||
(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?
|
||||
((? pred?)
|
||||
(list (reg-test
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -115,6 +115,8 @@
|
|||
(define (shape-test? test)
|
||||
(test-shape test))
|
||||
|
||||
|
||||
(define (negate-test? test)
|
||||
(test-closest-shape-tst test))
|
||||
(test-closest-shape-tst test))
|
||||
|
||||
)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user