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

plt-match.ss/match.ss:

Browse Source 
- don't export match:test-no-order, which is only used in generated code

test-no-order.ss
- reformat code
- use ormap instead of let loop

render-test-list:
- add define/opt sugar
- remove a lot of pointless stx arguments
- remove a lot of [quasi]syntax/loc

gen-match:
- use internal define instead of let
- remove quasisyntax/loc
- reformat
- remove pointlessly optional argument

coupling-and-binding:
- reformat
- use memf instead of custom loops

svn: r908
This commit is contained in:
Sam Tobin-Hochstadt 2005-09-23 19:55:12 +00:00
parent 821aa78044
commit d96e47c4b7
6 changed files with 273 additions and 397 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mzlib/match.ss
View File

@ -117,8 +117,7 @@
match-equality-test match-equality-test
exn:misc:match? exn:misc:match?
exn:misc:match-value exn:misc:match-value
define-match-expander define-match-expander)
match:test-no-order)
;; FIXME: match-helper and match-error should each be split ;; FIXME: match-helper and match-error should each be split
;; into a compile-time part and a run-time part. ;; into a compile-time part and a run-time part.

3
collects/mzlib/plt-match.ss
View File

@ -142,8 +142,7 @@
exn:misc:match? exn:misc:match?
exn:misc:match-value exn:misc:match-value
match-equality-test match-equality-test
define-match-expander define-match-expander)
match:test-no-order)
(require "private/match-internal-func.ss" (require "private/match-internal-func.ss"
"private/match-expander.ss" "private/match-expander.ss"

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

@ -5,7 +5,8 @@
(provide couple-tests meta-couple subst-bindings) (provide couple-tests meta-couple subst-bindings)
(require "test-structure.scm" (require "test-structure.scm"
"match-helper.ss") "match-helper.ss"
(lib "list.ss"))
(require-for-template mzscheme) (require-for-template mzscheme)
@ -25,57 +26,49 @@
;; passed around to the various partially compiled tests so that ;; passed around to the various partially compiled tests so that
;; 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 (define (couple-tests test-list ks-func kf-func let-bound)
(lambda (test-list ks-func kf-func let-bound) (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)
(if (and (>= (test-bind-count cur-test) 2) (not (exp-already-bound?
(not (exp-already-bound? (test-bind-exp cur-test)
(test-bind-exp cur-test) let-bound))) ;; if it is member of
let-bound))) ;; if it is member of ;;let-bound skip it
;;let-bound skip it (let* ([new-exp (get-exp-var)]
(let* ((new-exp (get-exp-var)) [binding (list (test-bind-exp cur-test)
(binding (list (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 [kf (kf-func let-bound)])
let-bound)) (lambda (sf bv)
(kf (kf-func let-bound))) #`(let ((#,new-exp
(lambda (sf bv) #,(sub-expr-subst (bind-get-exp-stx binding)
(quasisyntax/loc let-bound)))
(test-bind-exp-stx cur-test) #,(((test-comp (car test-list))
(let ((#,new-exp (couple-tests (cdr test-list)
#,(sub-expr-subst (bind-get-exp-stx binding) ks-func
let-bound))) (if (negate-test? cur-test)
#,(((test-comp (car test-list)) (lambda (let-bound)
(couple-tests (cdr test-list) (lambda (sf bv)
ks-func #`(match-failure)))
(if (negate-test? cur-test) kf-func)
(lambda (let-bound) ;kf-func
(lambda (sf bv) let-bound)
(quasisyntax/loc kf let-bound) sf bv))))
(test-bind-exp-stx cur-test) (let* ([kf (kf-func let-bound)])
(match-failure)))) ((test-comp (car test-list))
kf-func) (couple-tests (cdr test-list)
;kf-func ks-func
let-bound) (if (negate-test? cur-test)
kf let-bound) sf bv))))) (lambda (let-bound)
(let* ((kf (kf-func let-bound))) (lambda (sf bv)
((test-comp (car test-list)) #`(match-failure)))
(couple-tests (cdr test-list) kf-func)
ks-func ;kf-func
(if (negate-test? cur-test) let-bound)
(lambda (let-bound) kf
(lambda (sf bv) let-bound))))))
(quasisyntax/loc
(test-bind-exp-stx cur-test)
(match-failure))))
kf-func)
;kf-func
let-bound)
kf
let-bound)))))))
;;!(function bind-get-exp ;;!(function bind-get-exp
;; (form (bind-get-exp binding) -> exp) ;; (form (bind-get-exp binding) -> exp)
@ -108,13 +101,11 @@
;; -> (syntax (car 'exp5)))) ;; -> (syntax (car 'exp5))))
;; 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 (define (subst-bindings exp-stx let-bound)
(lambda (exp-stx let-bound) (define binding (get-bind exp-stx let-bound))
(let* ((exp (syntax-object->datum exp-stx)) (if binding
(binding (get-bind exp let-bound))) (bind-get-new-exp binding)
(if binding (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)
@ -127,22 +118,19 @@
;; 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.
(define sub-expr-subst (define (sub-expr-subst exp-stx let-bound)
(lambda (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 ;;(write (syntax sub-exp))(newline) (write binding)(newline)
(syntax-object->datum (syntax sub-exp)) (if binding
let-bound))) #`(access #,(bind-get-new-exp binding) rest ...)
;;(write (syntax sub-exp))(newline) (write binding)(newline) #`(access #,(sub-expr-subst #'sub-exp let-bound) rest ...)))]
(if binding [_ exp-stx]))
(quasisyntax/loc
exp-stx (access #,(bind-get-new-exp binding) rest ...)) ; helper for the following functions
(quasisyntax/loc (define ((equal-bind-get exp) e)
exp-stx (access #,(sub-expr-subst (syntax sub-exp) (equal? exp (bind-get-exp e)))
let-bound)
rest ...)))))
(other (syntax other)))))
;;!(function get-bind ;;!(function get-bind
;; (form (get-bind exp let-bound) -> binding) ;; (form (get-bind exp let-bound) -> binding)
@ -150,24 +138,18 @@
;; This function looks up the binding for a given expression exp ;; This function looks up the binding for a given expression exp
;; in the binding list let-bound. If the binding is found then the ;; in the binding list let-bound. If the binding is found then the
;; binding is returned if not then #f is returned. ;; binding is returned if not then #f is returned.
(define get-bind (define (get-bind exp let-bound)
(lambda (exp let-bound) (cond [(memf (equal-bind-get (syntax-object->datum exp)) let-bound) => car]
(cond ((null? let-bound) #f) [else #f]))
((equal? exp (bind-get-exp (car let-bound))) (car let-bound))
(else (get-bind exp (cdr let-bound))))))
;;!(function exp-already-bound? ;;!(function exp-already-bound?
;; (form (exp-already-bound? exp let-bound) -> binding) ;; (form (exp-already-bound? exp let-bound) -> binding)
;; (contract (any list) -> list)) ;; (contract (any list) -> boolean))
;; This function looks up the binding for a given expression exp ;; This function looks up the binding for a given expression exp
;; in the binding list let-bound. If the binding is found then #t ;; in the binding list let-bound. If the binding is found then #t
;; binding is returned if not then #f is returned. ;; binding is returned if not then #f is returned.
(define exp-already-bound? (define (exp-already-bound? exp let-bound)
(lambda (exp let-bound) (ormap (equal-bind-get exp) let-bound))
;;(write exp) (newline) (write let-bound)(newline)
(cond ((null? let-bound) #f)
((equal? exp (bind-get-exp (car let-bound))) #t)
(else (exp-already-bound? exp (cdr let-bound))))))
;;!(function meta-couple ;;!(function meta-couple
;; (form (meta-couple rendered-list failure-func ;; (form (meta-couple rendered-list failure-func
@ -181,22 +163,21 @@
;; success functions attached and couples the whole lot together ;; success functions attached and couples the whole lot together
;; 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 (define (meta-couple rendered-list failure-func let-bound bvsf)
(lambda (rendered-list failure-func let-bound bvsf) (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 (let* ([failed
(let* ((failed (lambda (let-bound)
(lambda (let-bound) (lambda (sf bv)
(lambda (sf bv) ((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
) )

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

@ -68,54 +68,50 @@
;; result is a function which takes a failure function and a list ;; result is a function which takes a failure function and a list
;; of let-bound expressions and returns a success-function. ;; of let-bound expressions and returns a success-function.
(define (test-list-with-success-func exp car-patlist stx success-func) (define (test-list-with-success-func exp car-patlist stx success-func)
(let-values ([(pat body fail-sym) (parse-clause (car car-patlist))]) (define-values (pat body fail-sym) (parse-clause (car car-patlist)))
(define (success fail let-bound) (define (success fail let-bound)
(if (not success-func) (if (not success-func)
(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 (if fail-sym
(quasisyntax/loc #`(let/ec fail-cont
stx (let
(let/ec fail-cont ((failure
(let (lambda ()
((failure (fail-cont
(lambda () ; it seems like fail is called
(fail-cont ; twice in this situation
; it seems like fail is called #,( fail sf bv)))))
; twice in this situation ((lambda (#,fail-sym
#,( fail sf bv))))) #,@(map car bv))
((lambda (#,fail-sym #,@body)
#,@(map car bv)) failure
#,@body) #,@(map (lambda (b)
failure (subst-bindings
#,@(map (lambda (b) (cdr b)
(subst-bindings let-bound))
bv))))
#`((lambda #,(map car bv)
#,@body)
#,@(map
(lambda (b) (subst-bindings
(cdr b) (cdr b)
let-bound)) let-bound))
bv))))) bv))))
(quasisyntax/loc (lambda (sf bv)
stx ;; mark this pattern as reached
((lambda #,(map car bv) (set-cdr! car-patlist #t)
#,@body) (let ((bv (map
#,@(map (lambda (bind)
(lambda (b) (subst-bindings (cons (car bind)
(cdr b) (subst-bindings
let-bound)) (cdr bind)
bv))))) let-bound)))
(lambda (sf bv) bv)))
;; mark this pattern as reached (success-func sf bv)))))
(set-cdr! car-patlist #t) (define test-list (render-test-list pat exp stx))
(let ((bv (map (cons test-list success))
(lambda (bind)
(cons (car bind)
(subst-bindings
(cdr bind)
let-bound)))
bv)))
(success-func sf bv)))))
(define test-list (render-test-list pat exp stx))
(cons test-list success)))
;;!(function gen-match ;;!(function gen-match
;; (form (gen-match exp tsf patlist stx [success-func]) ;; (form (gen-match exp tsf patlist stx [success-func])
@ -169,20 +165,16 @@
;; also wraps the final compilation in syntax which binds the ;; also wraps the final compilation in syntax which binds the
;; match-failure function. ;; match-failure function.
(define (gen-help opt) (define (gen-help opt)
;(opt-lambda (exp tsf patlist stx opt [success-func #f])
(when (stx-null? patlist) (when (stx-null? patlist)
(match:syntax-err stx "null clause list")) (match:syntax-err stx "null clause list"))
(let* ((marked-clauses (mark-patlist patlist)) (let* ([marked-clauses (mark-patlist patlist)]
(compiled-match [compiled-match
(quasisyntax/loc stx #`(let ([match-failure (lambda () (match:error #,exp '#,stx))])
(let ((match-failure
(lambda ()
(match:error #,exp (quote #,stx)))))
#,(gen exp tsf marked-clauses #,(gen exp tsf marked-clauses
stx stx
(syntax (match-failure)) #'(match-failure)
opt opt
success-func))))) success-func))])
(unreachable marked-clauses stx) (unreachable marked-clauses stx)
compiled-match)) compiled-match))
@ -213,31 +205,20 @@
;; determind which supexpressions of the expression to be matched ;; determind which supexpressions of the expression to be matched
;; need to be bound by let expressions. After all of this the ;; need to be bound by let expressions. After all of this the
;; tests are "coupled" together for final compilation. ;; tests are "coupled" together for final compilation.
(define gen (define (gen exp tsf patlist stx failure-func opt success-func)
(opt-lambda (exp tsf patlist stx failure-func opt [success-func #f])
;; iterate through list and render each pattern to a list of tests ;; iterate through list and render each pattern to a list of tests
;; and success functions ;; and success functions
(let ((rendered-list (define rendered-list
(let loop ((clause-list patlist)) (map (lambda (clause) (test-list-with-success-func
(if (null? clause-list) exp clause stx success-func))
'() patlist))
(cons (test-list-with-success-func exp (update-counts rendered-list)
(car clause-list) (tag-negate-tests rendered-list)
stx (update-binding-counts rendered-list)
success-func) ((meta-couple (reorder-all-lists rendered-list)
(loop (cdr clause-list))))))) (lambda (sf bv) failure-func)
(update-counts rendered-list) '()
(tag-negate-tests rendered-list) '())
(update-binding-counts rendered-list) '() '()))
(let* ((rendered-list (reorder-all-lists rendered-list))
(output
(begin
;(pretty-print rendered-list)(newline)
((meta-couple rendered-list
(lambda (sf bv) failure-func)
'()
'())
'() '()))))
output))))
(gen-help #f))) (gen-help #f)))
) )

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

@ -4,7 +4,7 @@
(require (lib "etc.ss")) (require (lib "etc.ss"))
(require (lib "stx.ss" "syntax")) (require (lib "stx.ss" "syntax"))
(require (rename (lib "1.ss" "srfi") map-append append-map )) (require (rename (lib "1.ss" "srfi") map-append append-map))
(require "match-error.ss" (require "match-error.ss"
"match-helper.ss" "match-helper.ss"
@ -28,13 +28,18 @@
"test-no-order.ss" "test-no-order.ss"
"match-helper.ss") "match-helper.ss")
(define-syntax define/opt
(syntax-rules ()
[(_ (nm args ...) body ...)
(define nm (opt-lambda (args ...) body ...))]))
;; BEGIN SPECIAL-GENERATORS.SCM ;; BEGIN SPECIAL-GENERATORS.SCM
;;!(function or-gen ;;!(function or-gen
;; (form (or-gen exp orpatlist stx sf bv ks kf let-bound) ;; (form (or-gen exp orpatlist sf bv ks kf let-bound)
;; -> ;; ->
;; syntax) ;; syntax)
;; (contract (syntax list syntax list list (list list -> syntax) ;; (contract (syntax list list list (list list -> syntax)
;; (list list -> syntax) list) ;; (list list -> syntax) list)
;; -> ;; ->
;; syntax)) ;; syntax))
@ -45,29 +50,24 @@
;; larger pattern and the state of compilation has information ;; larger pattern and the state of compilation has information
;; that will help optimaize its compilation. And the success of ;; that will help optimaize its compilation. And the success of
;; any pattern results in the same outcome. ;; any pattern results in the same outcome.
(define or-gen (define (or-gen exp orpatlist sf bv ks kf let-bound)
(lambda (exp orpatlist stx sf bv ks kf let-bound) (define rendered-list
(let ((rendered-list (map
(map (lambda (pat)
(lambda (pat) (cons (render-test-list pat exp)
(cons (render-test-list pat exp stx) (lambda (fail let-bound)
(lambda (fail let-bound) (lambda (sf bv)
(lambda (sf bv) (let ((bv (map
(let ((bv (map (lambda (bind)
(lambda (bind) (cons (car bind)
(cons (car bind)
(subst-bindings (cdr bind) (subst-bindings (cdr bind)
let-bound))) let-bound)))
bv))) bv)))
(ks sf bv)))))) (ks sf bv))))))
orpatlist))) orpatlist))
(update-counts rendered-list) (update-counts rendered-list)
(update-binding-counts rendered-list) (update-binding-counts rendered-list)
(let* ((rendered-list ((meta-couple (reorder-all-lists rendered-list) kf let-bound bv) sf bv))
(reorder-all-lists rendered-list)
)
(output ((meta-couple rendered-list kf let-bound bv) sf bv)))
output))))
;;!(function next-outer ;;!(function next-outer
;; (form (next-outer p ae sf bv let-bound kf ks syntax bool) ;; (form (next-outer p ae sf bv let-bound kf ks syntax bool)
@ -84,18 +84,18 @@
;; inside of test constructs that cannot be eliminated because of ;; inside of test constructs that cannot be eliminated because of
;; a related presence in the test-so-far list. So, instead of ;; a related presence in the test-so-far list. So, instead of
;; partially compiling patterns this function fully compiles patterns. ;; partially compiling patterns this function fully compiles patterns.
(define next-outer (define/opt (next-outer
(opt-lambda (p p
ae ;; this is the actual expression ae ;; this is the actual expression
sf sf
bv bv
let-bound let-bound
kf kf
ks ks
[stx (syntax '())] [stx (syntax '())]
[opt #f]) [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) stx opt))) (lambda (x) kf) (lambda (a b) ks) stx opt))
;;!(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)
@ -110,24 +110,24 @@
;; ks-func and kf-func that will be given compile time imformation ;; ks-func and kf-func that will be given compile time imformation
;; about let-bindings etc. which in turn will allow the programmer ;; about let-bindings etc. which in turn will allow the programmer
;; to take advantage of this info. ;; to take advantage of this info.
(define next-outer-helper (define/opt (next-outer-helper
(opt-lambda (p p
ae ;; this is the actual expression ae ;; this is the actual expression
sf sf
bv bv
let-bound let-bound
kf-func kf-func
ks-func ks-func
[stx (syntax '())] [stx (syntax '())]
[opt #f]) [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 stx))) (let ((rendered-list (render-test-list p ae 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
;; better to put shape tests first ;; better to put shape tests first
(update-binding-count rendered-list) (update-binding-count rendered-list)
((couple-tests rendered-list ks-func kf-func let-bound) sf bv)))) ((couple-tests rendered-list ks-func kf-func let-bound) sf bv)))
;;!(function create-test-func ;;!(function create-test-func
;; (form (create-test-func p sf let-bound bind-map last-test) ;; (form (create-test-func p sf let-bound bind-map last-test)
;; -> ;; ->
;; syntax) ;; syntax)
@ -140,9 +140,7 @@
;; last-test - a boolean value that indicates whether this function ;; last-test - a boolean value that indicates whether this function
;; is collecting one value or a list of values.</pre> ;; is collecting one value or a list of values.</pre>
(define (create-test-func p sf let-bound bind-map last-test) (define (create-test-func p sf let-bound bind-map last-test)
(quasisyntax/loc #`(lambda (exp)
p
(lambda (exp)
#,(next-outer-helper #,(next-outer-helper
p #'exp sf '() let-bound p #'exp sf '() let-bound
(lambda (let-bound) (lambda (let-bound)
@ -161,7 +159,7 @@
#`(set! #,binding-name #`(set! #,binding-name
#,exp-to-bind)))) #,exp-to-bind))))
bv) bv)
#t))))))) #t))))))
;;!(function getbindings ;;!(function getbindings
;; (form (getbindings pat-syntax) -> list) ;; (form (getbindings pat-syntax) -> list)
@ -199,7 +197,7 @@
;;!(function handle-end-ddk-list ;;!(function handle-end-ddk-list
;; (form (handle-end-ddk-list ae kf ks pat ;; (form (handle-end-ddk-list ae kf ks pat
;; dot-dot-k stx ;; dot-dot-k
;; let-bound) ;; let-bound)
;; -> ;; ->
;; ((list list) -> syntax)) ;; ((list list) -> syntax))
@ -208,7 +206,6 @@
;; ((list list) -> syntax) ;; ((list list) -> syntax)
;; syntax ;; syntax
;; syntax ;; syntax
;; syntax
;; list) ;; list)
;; -> ;; ->
;; ((list list) -> syntax))) ;; ((list list) -> syntax)))
@ -221,9 +218,8 @@
;; ks - a success function ;; ks - a success function
;; pat - the pattern to be matched repeatedly ;; pat - the pattern to be matched repeatedly
;; dot-dot-k - the ddk pattern ;; dot-dot-k - the ddk pattern
;; stx - the source stx for error purposes
;; let-bound - a list of let bindings ;; let-bound - a list of let bindings
(define ((handle-end-ddk-list ae kf ks pat dot-dot-k stx let-bound) sf bv) (define ((handle-end-ddk-list ae kf ks pat dot-dot-k let-bound) sf bv)
(let* ((k (stx-dot-dot-k? dot-dot-k)) (let* ((k (stx-dot-dot-k? dot-dot-k))
(ksucc (lambda (sf bv) (ksucc (lambda (sf bv)
(let ((bound (getbindings pat))) (let ((bound (getbindings pat)))
@ -252,14 +248,10 @@
(syntax exp-sym))) (syntax exp-sym)))
(syntax pred)) (syntax pred))
(whatever (whatever
(quasisyntax/loc #`(lambda (exp-sym)
stx #,ptst)))))
(lambda (exp-sym) (assm #`(andmap #,tst
#,ptst)))))) #,(subst-bindings ae let-bound))
(assm (quasisyntax/loc
stx
(andmap #,tst
#,(subst-bindings ae let-bound)))
(kf sf bv) (kf sf bv)
(ks sf bv))))) (ks sf bv)))))
(id (id
@ -276,21 +268,13 @@
(gensym (syntax-object->datum x)) (gensym (syntax-object->datum x))
'-bindings))) '-bindings)))
bound)) bound))
(loop-name (quasisyntax/loc (loop-name (gensym 'loop))
(syntax the-pat) (exp-name (gensym 'exp)))
#,(gensym 'loop))) #`(let #,loop-name
(exp-name (quasisyntax/loc
(syntax the-pat)
#,(gensym 'exp))))
(quasisyntax/loc
stx
(let #,loop-name
((#,exp-name #,(subst-bindings ae let-bound)) ((#,exp-name #,(subst-bindings ae let-bound))
#,@(map #,@(map
(lambda (x) (lambda (x)
(quasisyntax/loc #`(#,x '()))
stx
(#,x '())))
binding-list-names)) binding-list-names))
(if (null? #,exp-name) (if (null? #,exp-name)
#,(ks sf #,(ks sf
@ -299,15 +283,11 @@
bound bound
(map (map
(lambda (x) (lambda (x)
(quasisyntax/loc #`(reverse #,x))
stx
(reverse #,x)))
binding-list-names)) binding-list-names))
bv)) bv))
#,(next-outer (syntax the-pat) #,(next-outer #'the-pat
(quasisyntax/loc #`(car #,exp-name)
(syntax the-pat)
(car #,exp-name))
sf sf
bv ;; we always start bv ;; we always start
;; over with the old ;; over with the old
@ -315,36 +295,32 @@
let-bound let-bound
kf kf
(lambda (sf bv) (lambda (sf bv)
(quasisyntax/loc #`(#,loop-name
stx
(#,loop-name
(cdr #,exp-name) (cdr #,exp-name)
#,@(map #,@(map
(lambda (lambda
(b-var (b-var
bindings-var) bindings-var)
(quasisyntax/loc #`(cons
stx
(cons
#,(get-bind-val #,(get-bind-val
b-var b-var
bv) bv)
#,bindings-var))) #,bindings-var))
bound binding-list-names)))))))))))))))) bound binding-list-names))))))))))))))
(case k (case k
((0) (ksucc sf bv)) ((0) (ksucc sf bv))
((1) (emit (lambda (exp) (quasisyntax/loc stx (pair? #,exp))) ((1) (emit (lambda (exp) #`(pair? #,exp))
ae ae
let-bound let-bound
sf bv kf ksucc)) sf bv kf ksucc))
(else (emit (lambda (exp) (quasisyntax/loc stx (>= (length #,exp) #,k))) (else (emit (lambda (exp) #`(>= (length #,exp) #,k))
ae ae
let-bound let-bound
sf bv kf ksucc))))) sf bv kf ksucc)))))
;;!(function handle-inner-ddk-list ;;!(function handle-inner-ddk-list
;; (form (handle-inner-ddk-list ae kf ks pat ;; (form (handle-inner-ddk-list ae kf ks pat
;; dot-dot-k pat-rest stx ;; dot-dot-k pat-rest
;; let-bound) ;; let-bound)
;; -> ;; ->
;; ((list list) -> syntax)) ;; ((list list) -> syntax))
@ -354,7 +330,6 @@
;; syntax ;; syntax
;; syntax ;; syntax
;; syntax ;; syntax
;; syntax
;; list) ;; list)
;; -> ;; ->
;; ((list list) -> syntax))) ;; ((list list) -> syntax)))
@ -370,9 +345,8 @@
;; pat - the pattern that preceeds the ddk ;; pat - the pattern that preceeds the ddk
;; dot-dot-k - the ddk pattern ;; dot-dot-k - the ddk pattern
;; pat-rest - the rest of the list pattern that occurs after the ddk ;; pat-rest - the rest of the list pattern that occurs after the ddk
;; stx - the source stx for error purposes
;; let-bound - a list of let bindings ;; let-bound - a list of let bindings
(define ((handle-inner-ddk-list ae kf ks pat dot-dot-k pat-rest stx let-bound) sf bv) (define ((handle-inner-ddk-list ae kf ks pat dot-dot-k pat-rest let-bound) sf bv)
(let* ((k (stx-dot-dot-k? dot-dot-k))) (let* ((k (stx-dot-dot-k? dot-dot-k)))
(let ((bound (getbindings pat))) (let ((bound (getbindings pat)))
(if (syntax? bound) (if (syntax? bound)
@ -402,8 +376,7 @@
(syntax exp-sym))) (syntax exp-sym)))
(syntax pred)) (syntax pred))
(whatever (whatever
(quasisyntax/loc stx (lambda (exp-sym) #`(lambda (exp-sym) #,ptst))))
#,ptst)))))
(loop-name (gensym 'ddnnl)) (loop-name (gensym 'ddnnl))
(exp-name (gensym 'exp)) (exp-name (gensym 'exp))
(count-name (gensym 'count))) (count-name (gensym 'count)))
@ -461,8 +434,7 @@
(map cons (map cons
bound bound
(map (map
(lambda (x) (lambda (x) #`(reverse #,x))
(quasisyntax/loc stx (reverse #,x)))
binding-list-names)) bv))) binding-list-names)) bv)))
(quasisyntax/loc (quasisyntax/loc
(syntax the-pat) (syntax the-pat)
@ -510,32 +482,27 @@
(syntax the-pat) (syntax the-pat)
(#,fail-name))) (#,fail-name)))
(lambda (sf bv) (lambda (sf bv)
(quasisyntax/loc #`(#,loop-name
stx
(#,loop-name
(cdr #,exp-name) (cdr #,exp-name)
(add1 #,count-name) (add1 #,count-name)
#,@(map #,@(map
(lambda (lambda
(b-var (b-var
bindings-var) bindings-var)
(quasisyntax/loc #`(cons
stx
(cons
#,(get-bind-val #,(get-bind-val
b-var b-var
bv) bv)
#,bindings-var))) #,bindings-var))
bound bound
binding-list-names)))))))))))))))) binding-list-names)))))))))))))))
;;!(function handle-ddk-vector ;;!(function handle-ddk-vector
;; (form (handle-ddk-vector ae kf ks pt let-bound) ;; (form (handle-ddk-vector ae kf ks let-bound)
;; -> ;; ->
;; ((list list) -> syntax)) ;; ((list list) -> syntax))
;; (contract (syntax ;; (contract (syntax
;; ((list list) -> syntax) ;; ((list list) -> syntax)
;; ((list list) -> syntax) ;; ((list list) -> syntax)
;; syntax
;; list) ;; list)
;; -> ;; ->
;; ((list list) -> syntax))) ;; ((list list) -> syntax)))
@ -548,7 +515,7 @@
;; ks - a success function ;; ks - a success function
;; pt - the whole vector pattern ;; pt - the whole vector pattern
;; let-bound - a list of let bindings ;; let-bound - a list of let bindings
(define (handle-ddk-vector ae kf ks pt stx let-bound) (define (handle-ddk-vector ae kf ks pt let-bound)
(let* ((vec-stx (syntax-e pt)) (let* ((vec-stx (syntax-e pt))
(vlen (- (vector-length vec-stx) 2)) ;; length minus (vlen (- (vector-length vec-stx) 2)) ;; length minus
;; the pat ... ;; the pat ...
@ -564,9 +531,7 @@
(quasisyntax/loc (quasisyntax/loc
pt pt
(let ((#,exp-name #,(subst-bindings ae let-bound))) (let ((#,exp-name #,(subst-bindings ae let-bound)))
#,(assm (quasisyntax/loc #,(assm #`(>= (vector-length #,exp-name) #,minlen)
stx
(>= (vector-length #,exp-name) #,minlen))
(kf sf bv) (kf sf bv)
((let vloop ((n 0)) ((let vloop ((n 0))
(lambda (sf bv) (lambda (sf bv)
@ -574,9 +539,7 @@
((not (= n vlen)) ((not (= n vlen))
(next-outer (next-outer
(vector-ref vec-stx n) (vector-ref vec-stx n)
(quasisyntax/loc #`(vector-ref #,exp-name #,n)
stx
(vector-ref #,exp-name #,n))
sf sf
bv bv
let-bound let-bound
@ -597,12 +560,9 @@
bound)) bound))
(vloop-name (gensym 'vloop)) (vloop-name (gensym 'vloop))
(index-name (gensym 'index))) (index-name (gensym 'index)))
(quasisyntax/loc #`(let #,vloop-name
stx
(let #,vloop-name
((#,index-name (- (vector-length #,exp-name) 1)) ((#,index-name (- (vector-length #,exp-name) 1))
#,@(map (lambda (x) #,@(map (lambda (x) #`(#,x '()))
(quasisyntax/loc stx (#,x '())))
binding-list-names)) binding-list-names))
(if (> #,vlen #,index-name) (if (> #,vlen #,index-name)
#,(ks sf #,(ks sf
@ -611,30 +571,25 @@
bv)) bv))
#,(next-outer #,(next-outer
(vector-ref vec-stx n) (vector-ref vec-stx n)
(quasisyntax/loc #`(vector-ref #,exp-name #,index-name)
stx
(vector-ref #,exp-name #,index-name))
sf sf
bv ;; we alway start over bv ;; we alway start over
;; with the old bindings ;; with the old bindings
let-bound let-bound
kf kf
(lambda (sf bv) (lambda (sf bv)
(quasisyntax/loc #`(#,vloop-name
stx (#,vloop-name
(- #,index-name 1) (- #,index-name 1)
#,@(map #,@(map
(lambda (b-var (lambda (b-var
bindings-var) bindings-var)
(quasisyntax/loc #`(cons
stx
(cons
#,(get-bind-val #,(get-bind-val
b-var b-var
bv) bv)
#,bindings-var))) #,bindings-var))
bound bound
binding-list-names))))))))))))) binding-list-names)))))))))))
sf sf
bv)))))))) bv))))))))
@ -658,8 +613,7 @@
;; ks - a success function ;; ks - a success function
;; pt - the whole vector pattern ;; pt - the whole vector pattern
;; let-bound - a list of let bindings ;; let-bound - a list of let bindings
(define handle-ddk-vector-inner (define (handle-ddk-vector-inner ae kf ks pt let-bound)
(lambda (ae kf ks pt stx let-bound)
(let* ((vec-stx (syntax-e pt)) (let* ((vec-stx (syntax-e pt))
;; vlen as an index points at the pattern before the ddk ;; vlen as an index points at the pattern before the ddk
(vlen (- (vector-length vec-stx) 2)) ;; length minus (vlen (- (vector-length vec-stx) 2)) ;; length minus
@ -677,16 +631,12 @@
;; if so handle that case else handle the pattern ;; if so handle that case else handle the pattern
(lambda (sf bv) (lambda (sf bv)
;; minlen here could be the lentgh plus the k's - 1 for each ddk ;; minlen here could be the lentgh plus the k's - 1 for each ddk
(quasisyntax/loc #`(let ((#,exp-name #,(subst-bindings ae let-bound)))
pt
(let ((#,exp-name #,(subst-bindings ae let-bound)))
(let ((#,length-of-vector-name (vector-length #,exp-name))) (let ((#,length-of-vector-name (vector-length #,exp-name)))
#,(assm (quasisyntax/loc pt (>= #,length-of-vector-name #,minlen)) #,(assm #`(>= #,length-of-vector-name #,minlen)
(kf sf bv) (kf sf bv)
(let ((current-index-name (gensym 'curr-ind))) (let ((current-index-name (gensym 'curr-ind)))
(quasisyntax/loc #`(let ((#,current-index-name 0))
pt
(let ((#,current-index-name 0))
#,((let vloop ((n 0) #,((let vloop ((n 0)
(count-offset-name-passover (count-offset-name-passover
current-index-name)) current-index-name))
@ -703,7 +653,7 @@
((stx-dot-dot-k? (vector-ref vec-stx n)) ((stx-dot-dot-k? (vector-ref vec-stx n))
;;this could be it ;;this could be it
(match:syntax-err (match:syntax-err
stx pt
"should not get here")) "should not get here"))
;; if the next one is not a ddk do a normal pattern match ;; if the next one is not a ddk do a normal pattern match
;; on element ;; on element
@ -717,9 +667,7 @@
#,(kf sf bv) #,(kf sf bv)
#,(next-outer #,(next-outer
(vector-ref vec-stx n) ;this could be it (vector-ref vec-stx n) ;this could be it
(quasisyntax/loc #`(vector-ref #,exp-name #,count-offset-name-passover)
stx
(vector-ref #,exp-name #,count-offset-name-passover))
'() ;we don't want these tests to take part in future '() ;we don't want these tests to take part in future
; elimination or to be eliminated ; elimination or to be eliminated
bv bv
@ -728,10 +676,8 @@
(lambda (bsf bv) (lambda (bsf bv)
;(set! current-index-name #`(add1 #,current-index-name)) ;(set! current-index-name #`(add1 #,current-index-name))
(let ((cindnm (gensym 'cindnm))) (let ((cindnm (gensym 'cindnm)))
(quasisyntax/loc #`(let ((#,cindnm (add1 #,count-offset-name-passover)))
pt #,((vloop (+ 1 n) cindnm) sf bv))))))))
(let ((#,cindnm (add1 #,count-offset-name-passover)))
#,((vloop (+ 1 n) cindnm) sf bv)))))))))
((and (eq? (syntax-object->datum ((and (eq? (syntax-object->datum
(vector-ref vec-stx n)) ;this could be it (vector-ref vec-stx n)) ;this could be it
'_) '_)
@ -754,19 +700,15 @@
(vloop-name (gensym 'vloop)) (vloop-name (gensym 'vloop))
(count-name (gensym 'count)) (count-name (gensym 'count))
(index-name (gensym 'index))) (index-name (gensym 'index)))
(quasisyntax/loc #`(let #,vloop-name
stx
(let #,vloop-name
((#,count-name #,count-offset-name-passover) ((#,count-name #,count-offset-name-passover)
#,@(map (lambda (x) (quasisyntax/loc stx (#,x '()))) #,@(map (lambda (x) #`(#,x '()))
binding-list-names)) binding-list-names))
#,(let ((fail-name (gensym 'fail)) #,(let ((fail-name (gensym 'fail))
(count-offset-name (gensym 'count-offset)) (count-offset-name (gensym 'count-offset))
(index-name (gensym 'index)) (index-name (gensym 'index))
) )
(quasisyntax/loc #`(let ((#,fail-name
pt
(let ((#,fail-name
(lambda (#,count-offset-name #,index-name) (lambda (#,count-offset-name #,index-name)
#,(let ((body ((vloop (+ n 2) index-name) sf #,(let ((body ((vloop (+ n 2) index-name) sf
(append (map (lambda (b bln) (append (map (lambda (b bln)
@ -791,52 +733,38 @@
#,count-name) #,count-name)
#,(next-outer #,(next-outer
(vector-ref vec-stx n) ;this could be it (vector-ref vec-stx n) ;this could be it
(quasisyntax/loc #`(vector-ref #,exp-name #,count-name)
stx
(vector-ref #,exp-name #,count-name))
'() ;sf '() ;sf
bv ;; we alway start over bv ;; we alway start over
;; with the old bindings ;; with the old bindings
let-bound let-bound
(lambda (sf bv) (lambda (sf bv)
(quasisyntax/loc #`(#,fail-name
pt
(#,fail-name
(- #,count-name (- #,count-name
#,count-offset-name-passover) #,count-offset-name-passover)
#,count-name))) #,count-name))
(lambda (sf bv) (lambda (sf bv)
(quasisyntax/loc #`(let ((arglist
stx
(let ((arglist
(list (list
#,@(map #,@(map
(lambda (b-var (lambda (b-var
bindings-var) bindings-var)
(quasisyntax/loc #`(cons
stx
(cons
#,(get-bind-val #,(get-bind-val
b-var b-var
bv) bv)
#,bindings-var))) #,bindings-var))
bound bound
binding-list-names)))) binding-list-names))))
(apply (apply
#,vloop-name #,vloop-name
(add1 #,count-name) (add1 #,count-name)
arglist)))))))))))))))))) arglist)))))))))))))))
sf sf
bv)))))))))))) bv)))))))))
;; END DDK-HANDLERS.SCM ;; END DDK-HANDLERS.SCM
;(include "ddk-handlers.scm")
;(include "getter-setter.scm")
;(include "emit-assm.scm")
;(include "parse-quasi.scm")
;(include "pattern-predicates.scm")
;; some convenient syntax for make-reg-test and make-shape-test ;; some convenient syntax for make-reg-test and make-shape-test
(define make-test-gen (define make-test-gen
(case-lambda (case-lambda
@ -906,7 +834,7 @@
;; forward in the argument list of next and then test for it later and ;; forward in the argument list of next and then test for it later and
;; then take the appropriate action. To understand this better take a ;; then take the appropriate action. To understand this better take a
;; look at how proper and improper lists are handled. ;; look at how proper and improper lists are handled.
(define (render-test-list p ae stx) (define/opt (render-test-list p ae [stx #'here])
(syntax-case* (syntax-case*
p p
(_ list quote quasiquote vector box ? app and or not struct set! var (_ list quote quasiquote vector box ? app and or not struct set! var
@ -1052,7 +980,7 @@
(lambda (ks kf let-bound) (lambda (ks kf let-bound)
(lambda (sf bv) (lambda (sf bv)
(or-gen ae (syntax-e #'pats) (or-gen ae (syntax-e #'pats)
stx sf bv ks kf let-bound)))))) sf bv ks kf let-bound))))))
((not pat) ((not pat)
@ -1204,11 +1132,11 @@
(syntax-case cur-pat (set! get!) (syntax-case cur-pat (set! get!)
[(set! . rest) [(set! . rest)
(unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields")) (unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields"))
(set/get-matcher 'set! ae stx (syntax rest) (set/get-matcher 'set! ae p #'rest
#`(lambda (y) #`(lambda (y)
(#,cur-mutator #,ae y)))] (#,cur-mutator #,ae y)))]
[(get! . rest) [(get! . rest)
(set/get-matcher 'get! ae stx (syntax rest) (set/get-matcher 'get! ae p #'rest
#`(lambda () #`(lambda ()
(#,cur-accessor #,ae)))] (#,cur-accessor #,ae)))]
[_ (render-test-list [_ (render-test-list
@ -1254,13 +1182,12 @@
(handle-end-ddk-list ae kf ks (handle-end-ddk-list ae kf ks
(syntax pat) (syntax pat)
(syntax dot-dot-k) (syntax dot-dot-k)
stx let-bound) let-bound)
(handle-inner-ddk-list ae kf ks (handle-inner-ddk-list ae kf ks
(syntax pat) (syntax pat)
(syntax dot-dot-k) (syntax dot-dot-k)
(append-if-necc 'list (append-if-necc 'list
(syntax (pat-rest ...))) (syntax (pat-rest ...)))
stx
let-bound)))))) let-bound))))))
;; list-rest pattern with a ooo or ook pattern ;; list-rest pattern with a ooo or ook pattern
@ -1287,7 +1214,6 @@
(stx-car (syntax (pat-rest ...))) (stx-car (syntax (pat-rest ...)))
(append-if-necc 'list-rest (append-if-necc 'list-rest
(syntax (pat-rest ...)))) (syntax (pat-rest ...))))
stx
let-bound))))) let-bound)))))
;; list-rest pattern for improper lists ;; list-rest pattern for improper lists
@ -1363,7 +1289,7 @@
(lambda (ks kf let-bound) (lambda (ks kf let-bound)
(handle-ddk-vector ae kf ks (handle-ddk-vector ae kf ks
#'#(pats ...) #'#(pats ...)
stx let-bound))))) let-bound)))))
;; vector pattern with ooo or ook, but not at end ;; vector pattern with ooo or ook, but not at end
((vector pats ...) ((vector pats ...)
@ -1385,7 +1311,7 @@
(lambda (ks kf let-bound) (lambda (ks kf let-bound)
(handle-ddk-vector-inner ae kf ks (handle-ddk-vector-inner ae kf ks
#'#(pats ...) #'#(pats ...)
stx let-bound))))) let-bound)))))
;; plain old vector pattern ;; plain old vector pattern
((vector pats ...) ((vector pats ...)

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

@ -18,31 +18,21 @@
(and (>= (length l) ddk-num) (and (>= (length l) ddk-num)
(andmap test l))) (andmap test l)))
(define (dep-first-test head rest tests) (define (dep-first-test head rest tests)
(cond ((null? tests) (cond [(null? tests)
(if last-test (if last-test
(handle-last-test last-test (cons head rest)) (handle-last-test last-test (cons head rest))
#f)) #f)]
((null? rest) [(null? rest)
(if last-test (if last-test
(and (= 0 ddk-num) (and (= 0 ddk-num)
(= 1 (length tests)) (= 1 (length tests))
((car tests) head)) ((car tests) head))
(and (= 1 (length tests)) (and (= 1 (length tests))
((car tests) head)))) ((car tests) head)))]
(else (and (pair? tests) [else (and (pair? tests)
((car tests) head) ((car tests) head)
(match:test-no-order (cdr tests) (match:test-no-order (cdr tests)
rest rest
last-test last-test
ddk-num))))) ddk-num))]))
; I think this is equivalent to (ormap (lambda (elem) (dep-first-test elem (remove elem l) tests)) l)))
#;(ormap (lambda (elem)
(dep-first-test elem
(remove elem l)
tests))
l)
(let loop ((lst l))
(if (null? lst)
#f
(or (dep-first-test (car lst) (remove (car lst) l) tests)
(loop (cdr lst)))))))