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

Removed obsolete mzlib/private/plt-match directory.

Browse Source 
Moved match implementation to new mzlib/private/match directory.

Implement keyword arguments to define-match-expander.

svn: r3943
This commit is contained in:
Sam Tobin-Hochstadt 2006-08-03 20:01:39 +00:00
parent 2fde0eeab7
commit 931d214b69
45 changed files with 53 additions and 4036 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/mzlib/match.ss
View File

@ -122,16 +122,16 @@
;; FIXME: match-helper and match-error should each be split
;; into a compile-time part and a run-time part.
(require-for-syntax "private/convert-pat.ss"
"private/match-helper.ss")
(require-for-syntax "private/match/convert-pat.ss"
"private/match/match-helper.ss")
(require-for-template mzscheme)
(require (prefix plt: "private/match-internal-func.ss")
"private/match-expander.ss"
"private/match-helper.ss"
"private/match-error.ss"
"private/test-no-order.ss")
(require (prefix plt: "private/match/match-internal-func.ss")
"private/match/match-expander.ss"
"private/match/match-helper.ss"
"private/match/match-error.ss"
"private/match/test-no-order.ss")
(define-syntax match-definer

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

@ -144,11 +144,11 @@
match-equality-test
define-match-expander)
(require "private/match-internal-func.ss"
"private/match-expander.ss"
"private/match-helper.ss"
"private/match-error.ss"
"private/test-no-order.ss")
(require "private/match/match-internal-func.ss"
"private/match/match-expander.ss"
"private/match/match-helper.ss"
"private/match/match-error.ss"
"private/match/test-no-order.ss")
)

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

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

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

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

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

0
collects/mzlib/private/gen-match.ss → collects/mzlib/private/match/gen-match.ss
View File

0
collects/mzlib/private/getbindings.ss → collects/mzlib/private/match/getbindings.ss
View File

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

0
collects/mzlib/private/match-error.ss → collects/mzlib/private/match/match-error.ss
View File

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

39
collects/mzlib/private/match-expander.ss → collects/mzlib/private/match/match-expander.ss
View File

@ -12,7 +12,46 @@
;; I wish I had keyword macro args
(define-syntax (define-match-expander stx)
(define (lookup v alist)
(cond [(assoc v alist) => cadr]
[else #f]))
(define (parse args)
(let loop ([args args]
[alist '()])
(if (null? args)
alist
(let* ([stx-v (car args)]
[v (syntax-e stx-v)])
(cond
[(not (keyword? v))
(match:syntax-err stx-v "Argument must be a keyword")]
[(not (member v '(#:macro #:plt-match #:match)))
(match:syntax-err stx-v "Keyword argument is not a correct keyword")]
[else
(loop (cddr args)
(cons (list v (cadr args))
alist))])))))
(syntax-case stx ()
[(_ id kw . rest)
(keyword? (syntax-e #'kw))
(let* ([args (syntax->list #'(kw . rest))]
[parsed-args (parse args)])
(with-syntax
([match-xform (lookup #:match parsed-args)]
[plt-match-xform (lookup #:plt-match parsed-args)]
[std-xform (or (lookup #:macro parsed-args)
#'(lambda (stx)
(match:syntax-err stx "This match expander must be used inside match")))])
(if (identifier? #'std-xform)
#`(define-syntax id (make-match-expander plt-match-xform
match-xform
(lambda (stx)
(syntax-case stx (set!)
#;[(set! id v) #'(set! std-xform v)]
[(nm args (... ...)) #'(std-xform args (... ...))]
[nm #'std-xform]))
(syntax-local-certifier)))
#'(define-syntax id (make-match-expander plt-match-xform match-xform std-xform (syntax-local-certifier))))))]
[(_ id plt-match-xform match-xform std-xform)
(if (identifier? (syntax std-xform))
#`(define-syntax id (make-match-expander plt-match-xform

0
collects/mzlib/private/match-helper.ss → collects/mzlib/private/match/match-helper.ss
View File

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

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

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

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

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

@ -157,7 +157,7 @@
(let ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)])
(render-test-list
(introducer (transformer (introducer #'(expander args ...))))
(introducer (transformer (introducer p)))
ae
(lambda (id)
(certifier (cert id) #f introducer))
@ -253,7 +253,7 @@
((pregexp reg-exp pat)
(regexp-matcher ae stx #'(app (lambda (x) (pregexp-match-with-error reg-exp x)) pat) cert))
;; app patterns just apply their operation. I'm not sure why they exist.
;; app patterns just apply their operation.
((app op pat)
(render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx))

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

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

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

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

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

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

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

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

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

301
collects/mzlib/private/plt-match/coupling-and-binding-new.scm
View File

@ -1,301 +0,0 @@
;; This library is used by match.ss
(define-values (couple-tests meta-couple subst-bindings)
(letrec
(
;;!(function couple-tests
;; (form (couple-tests test-list ks-func kf-func let-bound)
;; ->
;; ((list list) -> syntax))
;; (contract (list
;; ((((list list) -> syntax) list) ->
;; ((list list) -> syntax))
;; (list -> ((list list) -> syntax))
;; list)
;; ->
;; ((list list) -> syntax)))
;; This is a major function of the compiler. This function
;; couples a list of tests together. Here is where state is
;; passed around to the various partially compiled tests so that
;; compilation can be completed. This returns a function that takes a
;; list of tests so far and a list of bound pattern variables.
(couple-tests
(lambda (test-list ks-func kf-func let-bound)
(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* ((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 ((coup-res
(((test-comp (car test-list))
(couple-tests (cdr test-list)
ks-func
(if (negate-test? cur-test)
(lambda (let-bound)
(lambda (sf bv)
(quasisyntax/loc
(test-bind-exp-stx cur-test)
(match-failure))))
kf-func)
;kf-func
let-bound)
kf let-bound) sf bv)))
(if (equal? (syntax-object->datum coup-res)
'(match-failure))
coup-res
(quasisyntax/loc
(test-bind-exp-stx cur-test)
(let ((#,new-exp
#,(sub-expr-subst (bind-get-exp-stx binding)
let-bound)))
#,coup-res))))))
(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)
(quasisyntax/loc
(test-bind-exp-stx cur-test)
(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.
(bind-get-exp
(lambda (binding)
(car binding)))
;;!(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.
(bind-get-exp-stx
(lambda (binding)
(cadr binding)))
;;!(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.
(bind-get-new-exp
(lambda (binding)
(caddr binding)))
;;!(function subst-bindings
;; (form (subst-bindings exp-stx let-bound) -> syntax)
;; (contract (syntax list) -> syntax)
;; (example (subst-bindings (syntax (car (cdr x)))
;; (list (list '(cdr x)
;; (syntax (cdr x))
;; 'exp5)))
;; -> (syntax (car 'exp5))))
;; This function substitutes let bound variables names for the
;; expressions that they represent.
(subst-bindings
(lambda (exp-stx let-bound)
(let* ((exp (syntax-object->datum exp-stx))
(binding (get-bind exp let-bound)))
(if binding
(bind-get-new-exp binding)
(sub-expr-subst exp-stx let-bound)))))
;;!(function sub-exp-subst
;; (form (sub-exp-subst exp-stx let-bound) -> syntax)
;; (contract (syntax list) -> syntax)
;; (example (subst-bindings (syntax (car (cdr x)))
;; (list (list '(cdr x)
;; (syntax (cdr x))
;; 'exp5)))
;; -> (syntax (car 'exp5))))
;; This function substitutes let bound variables names for the
;; expressions that they represent. This only works if a
;; subexpression of exp-stx is bound in the let-bound list.
(sub-expr-subst
(lambda (exp-stx let-bound)
(syntax-case exp-stx ()
((access sub-exp rest ...)
(let ((binding (get-bind
(syntax-object->datum (syntax sub-exp))
let-bound)))
(if binding
(quasisyntax/loc
exp-stx (access #,(bind-get-new-exp binding) rest ...))
(quasisyntax/loc
exp-stx (access #,(sub-expr-subst (syntax sub-exp)
let-bound)
rest ...)))))
(other (syntax other)))))
;;!(function get-bind
;; (form (get-bind exp let-bound) -> binding)
;; (contract (any list) -> list))
;; This function looks up the binding for a given expression exp
;; in the binding list let-bound. If the binding is found then the
;; binding is returned if not then #f is returned.
(get-bind
(lambda (exp let-bound)
(cond ((null? let-bound) #f)
((equal? exp (bind-get-exp (car let-bound))) (car let-bound))
(else (get-bind exp (cdr let-bound))))))
;;!(function exp-already-bound?
;; (form (exp-already-bound? exp let-bound) -> binding)
;; (contract (any list) -> list))
;; This function looks up the binding for a given expression exp
;; in the binding list let-bound. If the binding is found then #t
;; binding is returned if not then #f is returned.
(exp-already-bound?
(lambda (exp let-bound)
(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
;; (form (meta-couple rendered-list failure-func
;; let-bound bvsf)
;; ->
;; ((list list) -> syntax))
;; (contract (list ((list list) -> syntax) list list)
;; ->
;; ((list list) -> syntax)))
;; This function takes a list of rendered clauses which also have
;; success functions attached and couples the whole lot together
;; yeilding one function that when invoked will compile the whole
;; original match expression.
(meta-couple
(lambda (rendered-list failure-func let-bound bvsf)
;; here we are going to tag the rendered-list before moving on
(let* ((count 0)
(rendered-list
(map (lambda (x)
(begin
(set! count (add1 count))
(cons count x)))
rendered-list)))
(meta-couple-help rendered-list failure-func let-bound bvsf))))
;; so the shape of the data is ((index test-list . success-func) ...)
(tests-index (lambda (x) (car x)))
(tests-list (lambda (x) (cadr x)))
(tests-succ-func (lambda (x) (cddr x)))
(no-group? (lambda (x) (<= (length (test-used-set x)) 1)))
(meta-couple-help
(lambda (rendered-list failure-func let-bound bvsf)
(cond ((null? rendered-list) failure-func)
;; if the top list is null
;; or the first item of the top list
;; has no group associated with it
;; or is a negate test
;; handle list normally
((let ((tlist (tests-list (car rendered-list))))
(or (null? tlist)
(or (negate-test? (car tlist))
(no-group? (car tlist)))))
;; here we erase the previously bound (bv) variables
(let* ((failed
(lambda (let-bound)
(lambda (sf bv)
((meta-couple-help (cdr rendered-list)
failure-func
let-bound
bvsf) sf bvsf)))))
(couple-tests (tests-list (car rendered-list))
(tests-succ-func (car rendered-list)) ;; successfunc needs
;; failure method
failed ;; needs let-bound
let-bound ;; initial-let bindings
)))
(else
(let ((upper-left-test
(car (tests-list (car rendered-list)))))
(let-values (((top-group remainder-of-list)
(lift-out-group (test-used-set
upper-left-test)
rendered-list)))
(let* ((failed
(lambda (let-bound)
(lambda (sf bv)
((meta-couple-help remainder-of-list
failure-func
let-bound
bvsf) sf bvsf)))))
(couple-tests (list upper-left-test)
(lambda (fail let-bound)
(lambda (sf bv)
((meta-couple-help
(cons
(cons (tests-index (car top-group))
(cons
(cdr (tests-list (car top-group)))
(tests-succ-func (car top-group))))
(map
(lambda (tests)
(cons
(tests-index tests)
(cons
(eliminate-test-from-list
upper-left-test
(tests-list tests)
)
(tests-succ-func tests))))
(cdr top-group)))
fail
let-bound
bv)
sf bv)))
failed
let-bound))))))))
;; returns a list containing the separated group and the
;; the rest of the rendered list
(lift-out-group
(lambda (group-list rendered-list)
(let loop ((rl rendered-list)
(k (lambda (grp rest)
(values grp rest))))
(when (null? group-list) (error 'null-group-list))
(if (null? rl)
(k '() '())
(if (member (caar rl) group-list)
(loop (cdr rl)
(lambda (g r)
(k (cons (car rl) g)
r)))
(loop (cdr rl)
(lambda (g r)
(k g
(cons (car rl) r)))))))))
(eliminate-test-from-list
(lambda (test tl)
(filter
(lambda (t)
(or (action-test? t)
(not (in (test-tst t) (list (test-tst test))))))
tl)))
)
(values couple-tests meta-couple subst-bindings)))

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

@ -1,203 +0,0 @@
;; This library is used by match.ss
(define-values (couple-tests meta-couple subst-bindings)
(letrec
(
;;!(function couple-tests
;; (form (couple-tests test-list ks-func kf-func let-bound)
;; ->
;; ((list list) -> syntax))
;; (contract (list
;; ((((list list) -> syntax) list) ->
;; ((list list) -> syntax))
;; (list -> ((list list) -> syntax))
;; list)
;; ->
;; ((list list) -> syntax)))
;; This is a major function of the compiler. This function
;; couples a list of tests together. Here is where state is
;; passed around to the various partially compiled tests so that
;; compilation can be completed. This returns a function that takes a
;; list of tests so far and a list of bound pattern variables.
(couple-tests
(lambda (test-list ks-func kf-func let-bound)
(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* ((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)
(quasisyntax/loc
(test-bind-exp-stx cur-test)
(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)
(quasisyntax/loc
(test-bind-exp-stx cur-test)
(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)
(quasisyntax/loc
(test-bind-exp-stx cur-test)
(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.
(bind-get-exp
(lambda (binding)
(car binding)))
;;!(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.
(bind-get-exp-stx
(lambda (binding)
(cadr binding)))
;;!(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.
(bind-get-new-exp
(lambda (binding)
(caddr binding)))
;;!(function subst-bindings
;; (form (subst-bindings exp-stx let-bound) -> syntax)
;; (contract (syntax list) -> syntax)
;; (example (subst-bindings (syntax (car (cdr x)))
;; (list (list '(cdr x)
;; (syntax (cdr x))
;; 'exp5)))
;; -> (syntax (car 'exp5))))
;; This function substitutes let bound variables names for the
;; expressions that they represent.
(subst-bindings
(lambda (exp-stx let-bound)
(let* ((exp (syntax-object->datum exp-stx))
(binding (get-bind exp let-bound)))
(if binding
(bind-get-new-exp binding)
(sub-expr-subst exp-stx let-bound)))))
;;!(function sub-exp-subst
;; (form (sub-exp-subst exp-stx let-bound) -> syntax)
;; (contract (syntax list) -> syntax)
;; (example (subst-bindings (syntax (car (cdr x)))
;; (list (list '(cdr x)
;; (syntax (cdr x))
;; 'exp5)))
;; -> (syntax (car 'exp5))))
;; This function substitutes let bound variables names for the
;; expressions that they represent. This only works if a
;; subexpression of exp-stx is bound in the let-bound list.
(sub-expr-subst
(lambda (exp-stx let-bound)
(syntax-case exp-stx ()
((access sub-exp rest ...)
(let ((binding (get-bind
(syntax-object->datum (syntax sub-exp))
let-bound)))
;;(write (syntax sub-exp))(newline) (write binding)(newline)
(if binding
(quasisyntax/loc
exp-stx (access #,(bind-get-new-exp binding) rest ...))
(quasisyntax/loc
exp-stx (access #,(sub-expr-subst (syntax sub-exp)
let-bound)
rest ...)))))
(other (syntax other)))))
;;!(function get-bind
;; (form (get-bind exp let-bound) -> binding)
;; (contract (any list) -> list))
;; This function looks up the binding for a given expression exp
;; in the binding list let-bound. If the binding is found then the
;; binding is returned if not then #f is returned.
(get-bind
(lambda (exp let-bound)
(cond ((null? let-bound) #f)
((equal? exp (bind-get-exp (car let-bound))) (car let-bound))
(else (get-bind exp (cdr let-bound))))))
;;!(function exp-already-bound?
;; (form (exp-already-bound? exp let-bound) -> binding)
;; (contract (any list) -> list))
;; This function looks up the binding for a given expression exp
;; in the binding list let-bound. If the binding is found then #t
;; binding is returned if not then #f is returned.
(exp-already-bound?
(lambda (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
;; (form (meta-couple rendered-list failure-func
;; let-bound bvsf)
;; ->
;; ((list list) -> syntax))
;; (contract (list ((list list) -> syntax) list list)
;; ->
;; ((list list) -> syntax)))
;; This function takes a list of rendered clauses which also have
;; success functions attached and couples the whole lot together
;; yeilding one function that when invoked will compile the whole
;; original match expression.
(meta-couple
(lambda (rendered-list failure-func let-bound bvsf)
(if (null? rendered-list)
failure-func
;; here we erase the previously bound variables
(let* ((failed
(lambda (let-bound)
(lambda (sf bv)
((meta-couple (cdr rendered-list)
failure-func
let-bound
bvsf) sf bvsf)))))
(couple-tests (caar rendered-list)
(cdar rendered-list) ;; successfunc needs
;; failure method
failed ;; needs let-bound
let-bound ;; initial-let bindings
))))) ;; fail-func
)
(values couple-tests meta-couple subst-bindings)))

653
collects/mzlib/private/plt-match/ddk-handlers.scm
View File

@ -1,653 +0,0 @@
;; This library is used by match.ss
(define (get-bind-val b-var bv-list)
(let ((res (assq
b-var
bv-list)))
(if res (cdr res)
(let ((res
(assq
(syntax-object->datum b-var)
(map (lambda (x)
(cons
(syntax-object->datum (car x)) (cdr x)))
bv-list))))
(if res (cdr res) (error 'var-not-found))))))
;;!(function handle-end-ddk-list
;; (form (handle-end-ddk-list ae kf ks pat
;; dot-dot-k stx
;; let-bound)
;; ->
;; ((list list) -> syntax))
;; (contract (syntax
;; ((list list) -> syntax)
;; ((list list) -> syntax)
;; syntax
;; syntax
;; syntax
;; list)
;; ->
;; ((list list) -> syntax)))
;; This returns a function which generates the code for
;; a pattern that ends with a ddk. This function is only applied to the
;; last pattern and the ddk.
;; Args:
;; ae - the expression being matched
;; kf - a failure function
;; ks - a success function
;; pat - the pattern to be matched repeatedly
;; dot-dot-k - the ddk pattern
;; stx - the source stx for error purposes
;; let-bound - a list of let bindings
(define handle-end-ddk-list
(lambda (ae kf ks pat dot-dot-k stx let-bound)
(lambda (sf bv)
(let* ((k (stx-dot-dot-k? dot-dot-k))
(ksucc (lambda (sf bv)
(let ((bound (getbindings pat)))
(if (syntax? bound)
(kf sf bv)
(syntax-case pat (_)
(_ (ks sf bv))
(the-pat
(null? bound)
(with-syntax ((exp-sym (syntax exp-sym)))
(let* ((ptst (next-outer
pat
(syntax exp-sym)
sf
bv
let-bound
(lambda (sf bv) (syntax #f))
(lambda (sf bv) (syntax #t))))
(tst (syntax-case ptst ()
((pred eta)
(and (identifier?
(syntax pred))
;free-identifier=?
(stx-equal?
(syntax eta)
(syntax exp-sym)))
(syntax pred))
(whatever
(quasisyntax/loc
stx
(lambda (exp-sym)
#,ptst))))))
(assm (quasisyntax/loc
stx
(andmap #,tst
#,(subst-bindings ae let-bound)))
(kf sf bv)
(ks sf bv)))))
(id
(and (identifier? (syntax id))
(stx-equal? (syntax id)
(car bound)))
(next-outer (syntax id) ae sf bv let-bound kf ks))
(the-pat
(let ((binding-list-names
(map (lambda (x)
(datum->syntax-object
(quote-syntax here)
(symbol-append
(gensym (syntax-object->datum x))
'-bindings)))
bound))
(loop-name (quasisyntax/loc
(syntax the-pat)
#,(gensym 'loop)))
(exp-name (quasisyntax/loc
(syntax the-pat)
#,(gensym 'exp))))
(quasisyntax/loc
stx
(let #,loop-name
((#,exp-name #,(subst-bindings ae let-bound))
#,@(map
(lambda (x)
(quasisyntax/loc
stx
(#,x '())))
binding-list-names))
(if (null? #,exp-name)
#,(ks sf
(append
(map cons
bound
(map
(lambda (x)
(quasisyntax/loc
stx
(reverse #,x)))
binding-list-names))
bv))
#,(next-outer (syntax the-pat)
(quasisyntax/loc
(syntax the-pat)
(car #,exp-name))
sf
bv ;; we always start
;; over with the old
;; bindings
let-bound
kf
(lambda (sf bv)
(quasisyntax/loc
stx
(#,loop-name
(cdr #,exp-name)
#,@(map
(lambda
(b-var
bindings-var)
(quasisyntax/loc
stx
(cons
#,(get-bind-val
b-var
bv)
#,bindings-var)))
bound binding-list-names))))))))))))))))
(case k
((0) (ksucc sf bv))
((1) (emit (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
ae
let-bound
sf bv kf ksucc))
(else (emit (lambda (exp) (quasisyntax/loc stx (>= (length #,exp) #,k)))
ae
let-bound
sf bv kf ksucc)))))))
;;!(function handle-inner-ddk-list
;; (form (handle-inner-ddk-list ae kf ks pat
;; dot-dot-k pat-rest stx
;; let-bound)
;; ->
;; ((list list) -> syntax))
;; (contract (syntax
;; ((list list) -> syntax)
;; ((list list) -> syntax)
;; syntax
;; syntax
;; syntax
;; syntax
;; list)
;; ->
;; ((list list) -> syntax)))
;; This returns a function which generates the code for a list
;; pattern that contains with a ddk that occurs before the end of
;; the list. This code is extremely similar to the code in
;; handle-end-ddk-list but there are enough differences to warrant
;; having a separate method for readability.
;; Args:
;; ae - the expression being matched
;; kf - a failure function
;; ks - a success function
;; pat - the pattern that preceeds the ddk
;; dot-dot-k - the ddk pattern
;; pat-rest - the rest of the list pattern that occurs after the ddk
;; stx - the source stx for error purposes
;; let-bound - a list of let bindings
(define handle-inner-ddk-list
(lambda (ae kf ks pat dot-dot-k pat-rest stx let-bound)
(lambda (sf bv)
(let* ((k (stx-dot-dot-k? dot-dot-k)))
(let ((bound (getbindings pat)))
(if (syntax? bound)
(kf sf bv)
(syntax-case pat (_)
(_
(stx-null? pat-rest)
(ks sf bv))
(the-pat
(null? bound)
(with-syntax ((exp-sym (syntax exp-sym)))
(let* ((ptst (next-outer
pat
(syntax exp-sym)
sf
bv
let-bound
(lambda (sf bv) (syntax #f))
(lambda (sf bv) (syntax #t))))
(tst (syntax-case ptst ()
((pred eta)
(and (identifier?
(syntax pred))
;free-identifier=?
(stx-equal?
(syntax eta)
(syntax exp-sym)))
(syntax pred))
(whatever
(quasisyntax/loc stx (lambda (exp-sym)
#,ptst)))))
(loop-name (gensym 'ddnnl))
(exp-name (gensym 'exp))
(count-name (gensym 'count)))
(quasisyntax/loc
(syntax the-pat)
(let #,loop-name ((#,exp-name
#,(subst-bindings ae let-bound))
(#,count-name 0))
(if (and (not (null? #,exp-name))
;; added for improper ddk
(pair? #,exp-name)
(#,tst (car #,exp-name)))
(#,loop-name (cdr #,exp-name)
(add1 #,count-name))
;; testing the count is not neccessary
;; if the count is zero
#,(let ((succ (next-outer
pat-rest
(quasisyntax/loc
(syntax the-pat) #,exp-name)
sf
bv
let-bound
kf
ks)))
(if (zero? k)
succ
(quasisyntax/loc
(syntax the-pat)
(if (>= #,count-name #,k)
#,succ
#,(kf sf bv)))))))))))
(the-pat
(let* ((binding-list-names
(map (lambda (x)
(datum->syntax-object
(quote-syntax here)
(symbol-append
(gensym (syntax-object->datum x))
'-bindings)))
bound))
(loop-name (quasisyntax/loc
(syntax the-pat)
#,(gensym 'loop)))
(exp-name (quasisyntax/loc
(syntax the-pat)
#,(gensym 'exp)))
(fail-name (quasisyntax/loc
(syntax the-pat)
#,(gensym 'fail)))
(count-name (quasisyntax/loc
(syntax the-pat)
#,(gensym 'count)))
(new-bv (append
(map cons
bound
(map
(lambda (x)
(quasisyntax/loc stx (reverse #,x)))
binding-list-names)) bv)))
(quasisyntax/loc
(syntax the-pat)
(let #,loop-name
((#,exp-name #,(subst-bindings ae let-bound))
(#,count-name 0)
#,@(map
(lambda (x) (quasisyntax/loc
(syntax the-pat)
(#,x '())))
binding-list-names))
(let ((#,fail-name
(lambda ()
#,(let ((succ (next-outer
pat-rest
(quasisyntax/loc
(syntax the-pat)
#,exp-name)
sf
new-bv
let-bound
kf
ks)))
(if (zero? k)
succ
(quasisyntax/loc
(syntax the-pat)
(if (>= #,count-name #,k)
#,succ
#,(kf sf new-bv))))))))
(if (or (null? #,exp-name)
(not (pair? #,exp-name)))
(#,fail-name)
#,(next-outer (syntax the-pat)
(quasisyntax/loc
(syntax the-pat)
(car #,exp-name))
sf
bv ;; we always start
;; over with the old
;; bindings
let-bound
(lambda (sf bv)
(quasisyntax/loc
(syntax the-pat)
(#,fail-name)))
(lambda (sf bv)
(quasisyntax/loc
stx
(#,loop-name
(cdr #,exp-name)
(add1 #,count-name)
#,@(map
(lambda
(b-var
bindings-var)
(quasisyntax/loc
stx
(cons
#,(get-bind-val
b-var
bv)
#,bindings-var)))
bound
binding-list-names))))))))))))))))))
;;!(function handle-ddk-vector
;; (form (handle-ddk-vector ae kf ks pt let-bound)
;; ->
;; ((list list) -> syntax))
;; (contract (syntax
;; ((list list) -> syntax)
;; ((list list) -> syntax)
;; syntax
;; list)
;; ->
;; ((list list) -> syntax)))
;; This returns a function which generates the code for a vector
;; pattern that contains a ddk that occurs at the end of the
;; vector.
;; Args:
;; ae - the expression being matched
;; kf - a failure function
;; ks - a success function
;; pt - the whole vector pattern
;; let-bound - a list of let bindings
(define handle-ddk-vector
(lambda (ae kf ks pt stx let-bound)
(let* ((vec-stx (syntax-e pt))
(vlen (- (vector-length vec-stx) 2)) ;; length minus
;; the pat ...
(k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen))))
(minlen (+ vlen k))
;; get the bindings for the second to last element:
;; 'pat' in pat ...
(bound (getbindings (vector-ref vec-stx vlen)))
(exp-name (gensym 'exnm)))
(lambda (sf bv)
(if (syntax? bound)
(kf sf bv)
(quasisyntax/loc
pt
(let ((#,exp-name #,(subst-bindings ae let-bound)))
#,(assm (quasisyntax/loc
stx
(>= (vector-length #,exp-name) #,minlen))
(kf sf bv)
((let vloop ((n 0))
(lambda (sf bv)
(cond
((not (= n vlen))
(next-outer
(vector-ref vec-stx n)
(quasisyntax/loc
stx
(vector-ref #,exp-name #,n))
sf
bv
let-bound
kf
(vloop (+ 1 n))))
((eq? (syntax-object->datum
(vector-ref vec-stx vlen))
'_)
(ks sf bv))
(else
(let* ((binding-list-names
(map (lambda (x)
(datum->syntax-object
(quote-syntax here)
(symbol-append
(gensym (syntax-object->datum x))
'-bindings)))
bound))
(vloop-name (gensym 'vloop))
(index-name (gensym 'index)))
(quasisyntax/loc
stx
(let #,vloop-name
((#,index-name (- (vector-length #,exp-name) 1))
#,@(map (lambda (x)
(quasisyntax/loc stx (#,x '())))
binding-list-names))
(if (> #,vlen #,index-name)
#,(ks sf
(append (map cons bound
binding-list-names)
bv))
#,(next-outer
(vector-ref vec-stx n)
(quasisyntax/loc
stx
(vector-ref #,exp-name #,index-name))
sf
bv ;; we alway start over
;; with the old bindings
let-bound
kf
(lambda (sf bv)
(quasisyntax/loc
stx (#,vloop-name
(- #,index-name 1)
#,@(map
(lambda (b-var
bindings-var)
(quasisyntax/loc
stx
(cons
#,(get-bind-val
b-var
bv)
#,bindings-var)))
bound
binding-list-names)))))))))))))
sf
bv)))))))))
;;!(function handle-ddk-vector-inner
;; (form (handle-ddk-vector-inner ae kf ks pt let-bound)
;; ->
;; ((list list) -> syntax))
;; (contract (syntax
;; ((list list) -> syntax)
;; ((list list) -> syntax)
;; syntax
;; list)
;; ->
;; ((list list) -> syntax)))
;; This returns a function which generates the code for a vector
;; pattern that contains a ddk that occurs before another pattern
;; in the list.
;; Args:
;; ae - the expression being matched
;; kf - a failure function
;; ks - a success function
;; pt - the whole vector pattern
;; let-bound - a list of let bindings
(define handle-ddk-vector-inner
(lambda (ae kf ks pt stx let-bound)
(let* ((vec-stx (syntax-e pt))
;; vlen as an index points at the pattern before the ddk
(vlen (- (vector-length vec-stx) 2)) ;; length minus
;; the pat ...
(vec-len (vector-length vec-stx))
(total-k (ddk-in-vec? vec-stx pt))
;; (k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen))))
(minlen (+ vec-len total-k))
(length-of-vector-name (gensym 'lv))
(exp-name (gensym 'exnm)))
;; get the bindings for the second to last element:
;; 'pat' in pat ...
;;(bound (getbindings (vector-ref vec-stx vlen))))
;; we have to look at the first pattern and see if a ddk follows it
;; if so handle that case else handle the pattern
(lambda (sf bv)
;; minlen here could be the lentgh plus the k's - 1 for each ddk
(quasisyntax/loc
pt
(let ((#,exp-name #,(subst-bindings ae let-bound)))
(let ((#,length-of-vector-name (vector-length #,exp-name)))
#,(assm (quasisyntax/loc pt (>= #,length-of-vector-name #,minlen))
(kf sf bv)
(let ((current-index-name (gensym 'curr-ind)))
(quasisyntax/loc
pt
(let ((#,current-index-name 0))
#,((let vloop ((n 0)
(count-offset-name-passover
current-index-name))
(lambda (sf bv)
(cond
((= n vec-len) ;; at the end of the patterns
(quasisyntax/loc
pt
(if (>= #,count-offset-name-passover
#,length-of-vector-name)
#,(ks sf bv)
#,(kf sf bv))))
((stx-dot-dot-k? (vector-ref vec-stx n))
;;this could be it
(match:syntax-err
stx
"should not get here"))
;; if the next one is not a ddk do a normal pattern match
;; on element
((or (= n (sub1 vec-len))
(not (stx-dot-dot-k? (vector-ref vec-stx
(add1 n)))))
(quasisyntax/loc
pt
(if (= #,count-offset-name-passover
#,length-of-vector-name)
#,(kf sf bv)
#,(next-outer
(vector-ref vec-stx n) ;this could be it
(quasisyntax/loc
stx
(vector-ref #,exp-name #,count-offset-name-passover))
'() ;we don't want these tests to take part in future
; elimination or to be eliminated
bv
let-bound
kf
(lambda (bsf bv)
;(set! current-index-name #`(add1 #,current-index-name))
(let ((cindnm (gensym 'cindnm)))
(quasisyntax/loc
pt
(let ((#,cindnm (add1 #,count-offset-name-passover)))
#,((vloop (+ 1 n) cindnm) sf bv)))))))))
((and (eq? (syntax-object->datum
(vector-ref vec-stx n)) ;this could be it
'_)
(>= (- vec-len n 1)
(stx-dot-dot-k? (vector-ref vec-stx (add1 n)))))
(ks sf bv))
(else ;; we now know that the next pattern is a ddk
(let ((bound (getbindings (vector-ref vec-stx n))))
(if (syntax? bound)
(kf sf bv)
(let* ((k (stx-dot-dot-k? (vector-ref vec-stx (add1 n))))
(binding-list-names
(map (lambda (x)
(datum->syntax-object
(quote-syntax here)
(symbol-append
(gensym (syntax-object->datum x))
'-bindings)))
bound))
(vloop-name (gensym 'vloop))
(count-name (gensym 'count))
(index-name (gensym 'index)))
(quasisyntax/loc
stx
(let #,vloop-name
((#,count-name #,count-offset-name-passover)
#,@(map (lambda (x) (quasisyntax/loc stx (#,x '())))
binding-list-names))
#,(let ((fail-name (gensym 'fail))
(count-offset-name (gensym 'count-offset))
(index-name (gensym 'index))
)
(quasisyntax/loc
pt
(let ((#,fail-name
(lambda (#,count-offset-name #,index-name)
#,(let ((body ((vloop (+ n 2) index-name) sf
(append (map (lambda (b bln)
(cons b
(quasisyntax/loc
pt
(reverse #,bln))))
bound
binding-list-names)
bv)
)))
(if (> k 0)
(quasisyntax/loc
pt
(if (>= #,count-offset-name #,k)
#,body
#,(kf sf bv)))
body)))))
(if (= #,length-of-vector-name #,count-name)
(#,fail-name
(- #,count-name #,count-offset-name-passover)
#,count-name)
#,(next-outer
(vector-ref vec-stx n) ;this could be it
(quasisyntax/loc
stx
(vector-ref #,exp-name #,count-name))
'() ;sf
bv ;; we alway start over
;; with the old bindings
let-bound
(lambda (sf bv)
(quasisyntax/loc
pt
(#,fail-name
(- #,count-name
#,count-offset-name-passover)
#,count-name)))
(lambda (sf bv)
(quasisyntax/loc
stx
(let ((arglist
(list
#,@(map
(lambda (b-var
bindings-var)
(quasisyntax/loc
stx
(cons
#,(get-bind-val
b-var
bv)
#,bindings-var)))
bound
binding-list-names))))
(apply
#,vloop-name
(add1 #,count-name)
arglist))))))))))))))))))
sf
bv))))))))))))

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

@ -1,94 +0,0 @@
;; This library is used by match.ss
;;!(function emit
;; (form (emit act-test-func ae let-bound sf bv kf ks)
;; ->
;; syntax)
;; (contract ((syntax -> syntax)
;; syntax
;; list
;; list
;; list
;; (list list -> syntax)
;; (list list -> syntax))
;; ->
;; syntax))
;; emit's true function is to manage the tests-seen-so-far lists
;; it decides whether a new test needs to be added to the list
;; or whether this condition has already been tested for and if
;; it is true emit calls the success function. If it has been
;; determined to be a false property emit calls the fail function.
;; emit adds implied truths to the test seen so far list so that
;; these truths can be checked against later.
(define emit
(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)))))))
;;!(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)
(set! node-count (add1 node-count))
(cond ((equal? s f)
(begin
(when (equal? s '(match-failure))
(set! 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)))))))))

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

@ -1,129 +0,0 @@
;; This library is used by match.ss
;;!(function setter
;; (form (setter e ident let-bound) -> syntax)
;; (contract (syntax syntax list) -> syntax)
;; (example (setter (syntax (car x)) (syntax here) '())
;; ->
;; (syntax (lambda (y) (set-car! x y)))))
;; This function takes an expression and returns syntax which
;; represents a function that is able to set the value that the
;; expression points to.
(define setter (lambda (e ident let-bound)
(let ((mk-setter (lambda (s)
(symbol-append 'set- s '!))))
(syntax-case e (vector-ref unbox car cdr)
(p
(not (stx-pair? (syntax p)))
(match:syntax-err
ident
"set! pattern should be nested inside of a list, vector or box"))
((vector-ref vector index)
(quasisyntax/loc
ident
(let ((x #,(subst-bindings (syntax vector)
let-bound)))
(lambda (y)
(vector-set!
x
index
y)))))
((unbox boxed)
(quasisyntax/loc
ident (let ((x #,(subst-bindings (syntax boxed)
let-bound)))
(lambda (y)
(set-box! x y)))))
((car exp)
(quasisyntax/loc
ident
(let ((x #,(subst-bindings (syntax exp)
let-bound)))
(lambda (y)
(set-car! x y)))))
((cdr exp)
(quasisyntax/loc
ident
(let ((x #,(subst-bindings (syntax exp)
let-bound)))
(lambda (y)
(set-cdr! x y)))))
((acc exp)
(let ((a (assq (syntax-object->datum (syntax acc))
get-c---rs)))
(if a
(quasisyntax/loc
ident
(let ((x (#,(cadr a)
#,(subst-bindings (syntax exp)
let-bound))))
(lambda (y)
(#,(mk-setter (cddr a)) x y))))
(quasisyntax/loc
ident
(let ((x #,(subst-bindings (syntax exp)
let-bound)))
(lambda (y)
(#,(mk-setter
(syntax-object->datum (syntax acc)))
x y)))))))))))
;;!(function getter
;; (form (getter e ident let-bound) -> syntax)
;; (contract (syntax syntax list) -> syntax)
;; (example (getter (syntax (car x)) (syntax here) '())
;; ->
;; (syntax (lambda () (car x)))))
;; This function takes an expression and returns syntax which
;; represents a function that is able to get the value that the
;; expression points to.
(define getter (lambda (e ident let-bound)
(syntax-case e (vector-ref unbox car cdr)
(p
(not (stx-pair? (syntax p)))
(match:syntax-err
ident
"get! pattern should be nested inside of a list, vector or box"))
((vector-ref vector index)
(quasisyntax/loc
ident
(let ((x #,(subst-bindings (syntax vector)
let-bound)))
(lambda ()
(vector-ref
x
index)))))
((unbox boxed)
(quasisyntax/loc
ident
(let ((x #,(subst-bindings (syntax boxed)
let-bound)))
(lambda () (unbox x)))))
((car exp)
(quasisyntax/loc
ident
(let ((x #,(subst-bindings (syntax exp)
let-bound)))
(lambda () (car x)))))
((cdr exp)
(quasisyntax/loc
ident
(let ((x #,(subst-bindings (syntax exp)
let-bound)))
(lambda () (cdr x)))))
((acc exp)
(let ((a (assq (syntax-object->datum (syntax acc))
get-c---rs)))
(if a
(quasisyntax/loc
ident
(let ((x (#,(cadr a)
#,(subst-bindings (syntax exp)
let-bound))))
(lambda () (#,(cddr a) x))))
(quasisyntax/loc
ident
(let ((x #,(subst-bindings (syntax exp)
let-bound)))
(lambda ()
(acc x))))))))))

345
collects/mzlib/private/plt-match/match-inc.scm
View File

@ -1,345 +0,0 @@
;; This library is usedby match.ss and plt-match.ss
;;! (function match:syntax-err
;; (form (match:syntax-err object message . detail) -> void)
;; (contract (any string . any) -> void)
;; (example (match:syntax-err (syntax here) "Bad error" (vector))
;; -> void)
;; (contract object -> (normally a syntax object that
;; that helps determine the source location
;; of the error)))
;; This function is used to report malformed match expressions.
(define match:syntax-err (lambda (obj msg . detail)
(apply
raise-syntax-error
'match
msg
obj
detail)))
;;! (function pattern-var?
;; (form (pattern-var? pattern-element) -> bool)
;; (contract any -> bool)
;; (example (pattern-var? 'x) -> t)
;; )
;; This function takes an object and determines if it
;; qualifies as a pattern variable.
(define pattern-var?
(lambda (x)
(and (symbol? x)
(not (dot-dot-k? x))
(not (memq x
'(
_
quasiquote
quote
unquote
unquote-splicing
; hash-table
; list-no-order
; list-rest
; list
; app
; struct
; var
; vector
; box
; ?
; and
; or
; not
; set!
; get!
))))))
;;!(function dot-dot-k?
;; (form (dot-dot-k? s) -> bool)
;; (contract any -> bool)
;; (example (stx-dot-dot-k? '..3) -> #t))
;; This function is a predicate that returns true if the argument
;; is a symbol '... or '___ where the last dot or
;; underscore can be an integer
(define dot-dot-k? (lambda (s)
(and (symbol? s)
(if (memq s '(... ___))
0
(let* ((s (symbol->string s))
(n (string-length s)))
(and (<= 3 n)
(memq (string-ref s 0)
'(#\. #\_))
(memq (string-ref s 1)
'(#\. #\_))
(andmap
char-numeric?
(string->list
(substring s 2 n)))
(string->number
(substring s 2 n))))))))
;;!(function gen-match
;; (form (gen-match exp tsf patlist stx [success-func])
;; ->
;; compiled-pattern)
;; (contract (syntax-object list list syntax-object
;; (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>exp - the expression that is to be tested against the pattern.
;; This should normally be a piece of syntax that indirectly
;; represents the expression. Because if it is the syntax of the
;; expression itself it will be duplicated many times throughout
;; the generated match test.
;;
;; <p>tsf - is a list of tests-seen-so-far and is used to
;; prevent generating tests for the same condition twice
;;
;; <p>patlist - is a list of the pattern clauses of the match expr
;; these can be of either form (pat body ...) or
;; (pat (=> fail) body ...)x
;;
;; <p>stx is the original syntax of the match expression.
;; This is only used for error reporting.
;;
;; <p>success-func - an optional argument which allows one to
;; specify how a successful match is treated. This made
;; the creation of match-letrec and match-define macros simple.
;; The reason for this function is that most of the information
;; about a match (namely the bound match variables) is at the bottom
;; of the recursion tree. The success function must take two arguments
;; and it should return a syntax object.
(define gen-match
(opt-lambda (exp tsf patlist stx [success-func #f])
(include "test-structure.scm")
;(include "coupling-and-binding-new.scm")
(include "coupling-and-binding.scm")
(include "render-test-list.scm")
(include "reorder-tests.scm")
(include "update-counts.scm")
(include "update-binding-counts.scm")
(include "match-util.scm")
(include "tag-negate-tests.scm")
;;!(function unreachable
;; (form (unreachable plist match-expr) -> void)
;; (contract (list syntax-object) -> void)
;; (contract plist -> (is a list of unreached pattern clauses))
;; (contract match-expr -> (is the origional match expr
;; the clauses came from)))
;; This function takes a list of unreached clauses and the original
;; match expression and prints a warning for each of the unreached
;; match clauses to the current error port
(define unreachable
(lambda (plist match-expr)
(map
(lambda (x)
(if (not (cdr x))
(fprintf
(current-error-port)
"Warning: unreachable match clause ~e in ~e~n"
(syntax-object->datum (car x))
(syntax-object->datum match-expr))))
plist)))
;;!(function gen-match-opt
;; (form (gen-match exp tsf patlist stx [success-func])
;; ->
;; compiled-pattern)
;; (contract (syntax-object list list syntax-object
;; (list list -> syntax-object))
;; ->
;; syntax-object))
;; This function is left over from an experiment that explored the
;; idea that certain "shape" tests can be ommited if the input for
;; a match expression is known.
;; For example if one knows that the the match expression is only
;; ever going to be applied to a list of four items. Then it
;; would behoove us to eliminate the extraneous tests that verify
;; this.
(define gen-match-opt
(opt-lambda (exp tsf patlist stx [success-func #f])
(gen-help exp tsf patlist stx #t success-func)))
;;!(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-lambda (exp tsf patlist stx opt [success-func #f])
(when
(stx-null? patlist)
(match:syntax-err stx "null clause list"))
(let* ((marked-clauses (mark-patlist patlist))
(compiled-match
(quasisyntax/loc stx
(let ((match-failure
(lambda ()
(match:error #,exp (quote #,stx)))))
#,(gen exp tsf marked-clauses
stx
(syntax (match-failure))
opt
success-func)))))
(unreachable marked-clauses stx)
compiled-match)))
;;!(function mark-patlist
;; (form (mark-patlist clauses) -> marked-clause-list)
;; (contract list -> list))
;; This function takes each clause from the match expression and
;; pairs it with the dummy value #f. This value will be set! when
;; the pattern matcher compiles a possible successful match for
;; the clause. If it is not set to #t then the clause is
;; unreachable which is an indication of programmer error.
(define mark-patlist
(lambda (clauses)
(map (lambda (x) (cons x #f)) (syntax->list clauses))))
;;!(function test-list-with-success-func
;; (form (test-list-with-success-func exp car-patlist
;; stx success-func)
;; ->
;; (test-list success-func))
;; (contract (syntax-object pair syntax-object
;; (list list -> syntax-object))
;; ->
;; (list ((list list -> syntax) list ->
;; (list list -> syntax)))))
;; This function takes an exp which is to be matched, a marked
;; clause, and a syntax-object that is fro reporting errors. It
;; returns a pair the car of which is a list of test structs which
;; are in essense partially evaluated tests. The cdr of the
;; result is a function which takes a failure function and a list
;; of let-bound expressions and returns a success-function.
(define test-list-with-success-func
(opt-lambda (exp car-patlist stx [success-func #f])
(let ((clause1 (car car-patlist)))
(let-values (((pat body fail-sym)
(syntax-case clause1 (=>)
((pat (=> fail-sym) body1 bodys ...)
(values (syntax pat)
(syntax (body1 bodys ...))
(syntax fail-sym)))
((pat body1 bodys ...)
(values (syntax pat)
(syntax (body1 bodys ...)) #f))
((pat) (match:syntax-err
(syntax pat)
"missing action for pattern"))
(pat (match:syntax-err
(syntax pat)
"syntax error in clause")))))
(let* (
(success
(lambda (fail let-bound)
(if (not success-func)
(lambda (sf bv)
;; mark this pattern as reached
(set-cdr! car-patlist #t)
(if fail-sym
(quasisyntax/loc
stx
(call/ec
(lambda (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))))))
(quasisyntax/loc
stx
((lambda #,(map car bv)
#,@body)
#,@(map
(lambda (b) (subst-bindings
(cdr b)
let-bound))
bv)))))
(lambda (sf bv)
;; mark this pattern as reached
(set-cdr! car-patlist #t)
(let ((bv (map
(lambda (bind)
(cons (car bind)
(subst-bindings
(cdr bind)
let-bound)))
bv)))
(success-func sf bv))))))
(test-list (render-test-list pat exp 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 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
(opt-lambda (exp tsf patlist stx failure-func opt [success-func #f])
;; iterate through list and render each pattern to a list of tests
;; and success functions
(let ((rendered-list
(let loop ((clause-list patlist))
(if (null? clause-list)
'()
(cons (test-list-with-success-func exp
(car clause-list)
stx
success-func)
(loop (cdr clause-list)))))))
(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 exp tsf patlist stx #f success-func)))

404
collects/mzlib/private/plt-match/match-util.scm
View File

@ -1,404 +0,0 @@
;; This library is used by match.ss
;
;;! (function stx-length
;; (form (syntax-length syntax-obj) -> int)
;; (contract syntax-object -> int)
;; (example (syntax-length (syntax iraq war idiocy)) -> 3))
;; Returns the length of the top-level syntax list.
(define stx-length (lambda (syntax-obj)
(length (syntax->list syntax-obj))))
;;! (function stx-?
;; (form (stx? test val) -> bool)
;; (contract ((any -> bool) syntax-object) -> bool)
;; (example (stx-? number? (syntax 4)) -> #t))
;; Applies predicate test to the syntax object val and returns the resulting
;; boolean value.
(define stx-? (lambda (test val)
(test (syntax-object->datum val))))
;;!(function stx-equal?
;; (form (stx-equal? a b) -> bool)
;; (contract (syntax-object syntax-object) -> bool)
;; (example (stx-equal? (syntax 5) (syntax 5)) -> #t))
;; Check the equality of two syntax objects by after applying
;; syntax-object->datum to the objects first. Checks equaltiy of
;; syntax objects after they have had all syntax data stripped away.
(define stx-equal? (lambda (a b)
(equal? (syntax-object->datum a)
(syntax-object->datum b))))
;;!(function symbol-append
;; (form (symbol-append . args) -> symbol)
;; (contract ((symbol or number) ...) -> symbol)
;; (example (symbol-append 'hello 5 'goodbye) -> 'hello5goodbye))
;; This function takes any number of arguments which can be either
;; symbols or numbers and returns one symbol which is the
;; concatenation of the input.
(define symbol-append (lambda l
(string->symbol
(apply
string-append
(map (lambda (x)
(cond
((symbol? x) (symbol->string x))
((number? x) (number->string x))
(else x)))
l)))))
;;!(function struct-pred-accessors-mutators
;; (form (struct-pred-accessors-mutators struct-name failure-thunk)
;; ->
;; (values pred accessors mutators parental-chain))
;; (contract (syntax-object (any -> void))
;; ->
;; (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
;; a predicate for the structure. The second is a list of accessors
;; in the same order as the fields of the structure declaration. The
;; third is a list of mutators for the structure also in the same
;; order. The last is a list of supertypes of this struct. The
;; failure thunk is invoked if the struct-name is not bound to a
;; structure.
(define struct-pred-accessors-mutators
(let ((accessors-index 3)
(mutators-index 4)
(pred-index 2)
(super-type-index 5)
(handle-acc-list
(lambda (l)
(letrec ((RC
(lambda (ac-list)
(cond ((null? ac-list) '())
((not (car ac-list)) '())
(else (cons (car ac-list)
(RC (cdr ac-list))))))))
(reverse (RC l))))))
(lambda (struct-name failure-thunk)
(letrec ((get-lineage
(lambda (struct-name)
(let ((super
(list-ref
(syntax-local-value struct-name
failure-thunk)
super-type-index)))
(cond ((equal? super #t) '())
((equal? super #f) '()) ;; not sure what to do in case where super-type is unknown
(else
(cons super (get-lineage super))))))))
(let ((info-on-struct (syntax-local-value struct-name failure-thunk)))
(if (struct-declaration-info? info-on-struct)
(let ((accessors (handle-acc-list
(list-ref info-on-struct accessors-index)))
(mutators (handle-acc-list
(list-ref info-on-struct mutators-index)))
(pred (list-ref info-on-struct pred-index))
(parental-chain (get-lineage struct-name)))
(values pred accessors mutators (cons struct-name parental-chain)))
(failure-thunk)))))))
;;!(function get-exp-var
;; (form (get-exp-var) -> syntax)
;; (contract () -> syntax)
;; (example (get-exp-var) -> (syntax exp754)))
;; This function just produces unique identifiers for expressions.
(define get-exp-var (lambda () #`#,(gensym 'exp)))
;;!(function in
;; (form (in e l) -> bool)
;; (contract (s-exp list) -> bool)
;; (example (in '(number? x) (list '(number? x))) -> #t))
;; This function is responsible for determining which tests are
;; redundant. If e can be determined to be true from the list of
;; tests l then e is "in" l.
(define in (lambda (e l)
(or
(ormap
(lambda (el)
(or (equal? e el)
(and
(eq? (car e) 'struct-pred)
(eq? (car el) 'struct-pred)
(member (caaddr e) (caddr el))
(equal? (cadddr e) (cadddr el))))) l)
(and (eq? (car e) 'list?)
(or (member `(null? ,(cadr e)) l)
(member `(pair? ,(cadr e)) l)))
(and (eq? (car e) 'not)
(let* ((srch (cadr e))
(const-class (equal-test? srch)))
;(write srch)
(cond
((equal? (car srch) 'struct-pred)
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(if (and (equal? (car x)
'struct-pred)
(not (equal? (cadr x) (cadr srch)))
; the current struct type should not
; be a member of the parental-chain of
(not (member (caaddr x) (caddr srch)))
(equal? (cadddr x) (cadddr srch)))
#t
(mem (cdr l)))))))
(const-class
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (equal?
(cadr x)
(cadr srch))
(disjoint? x)
(not (equal?
const-class
(car x))))
(equal?
x
`(not (,const-class
,(cadr srch))))
(and (equal?
(cadr x)
(cadr srch))
(equal-test?
x)
(not (equal?
(caddr
srch)
(caddr
x))))
(mem (cdr l)))))))
((disjoint? srch)
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (disjoint? x)
(not (equal?
(car x)
(car srch)))
(cond ((equal?
(car srch)
'struct-pred)
(equal?
(cadr x)
;; we use cadddr here to access the expression
;; because struct predicates carry some extra baggage
;; They have the form (struct-pred <predicate> <list of super types> <exp>)
(cadddr srch)))
((equal?
(car x)
'struct-pred)
(equal?
(cadr srch)
;; we use cadddr here to access the expression
;; because struct predicates carry some extra baggage
(cadddr x)))
(else (equal?
(cadr x)
(cadr srch)))))
(mem (cdr l)))))))
((eq? (car srch) 'list?)
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (equal?
(cadr x)
(cadr srch))
(disjoint?
x)
(not (memq (car x)
'(list?
pair?
null?))))
(mem (cdr l)))))))
((vec-structure? srch)
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (equal?
(cadr x)
(cadr srch))
(or (disjoint?
x)
(vec-structure?
x))
(not (equal?
(car x)
'vector?))
(not (equal?
(car x)
(car srch))))
(equal?
x
`(not (vector?
,(cadr srch))))
(mem (cdr l)))))))
(else #f)))))))
;;!(function equal-test?
;; (form (equal-test? tst) -> (or symbol
;; #f))
;; (contract s-exp -> (or symbol
;; #f))
;; (example (equal-test? '(equal? x 5))
;; -> 'number?)
;; (example (equal-test? '(symbol? x))
;; -> #f))
;; This function returns false if the s-exp does not represent an
;; "equal?" test. If it does then this function returns a
;; predicate for the data type that the test is testing.
(define equal-test? (lambda (tst)
(and (eq? (car tst) 'equal?)
(let ((p (caddr tst)))
(cond
((string? p) 'string?)
((boolean? p) 'boolean?)
((char? p) 'char?)
((number? p) 'number?)
((and (pair? p)
(pair? (cdr p))
(null? (cddr p))
(eq? 'quote (car p))
(symbol? (cadr p))) 'symbol?)
(else #f))))))
(define match:disjoint-predicates
'(struct-pred null? pair? symbol? boolean? number? string? char?
procedure? vector?
box? promise?))
(define match:vector-structures '())
;;!(function disjoint?
;; (form (disjoint? tst))
;; (contract s-exp -> bool)
;; (example (disjoint? 'pair?) -> #t))
;; This function retirns true if the predicate is disjoint.
(define disjoint?
(lambda (tst)
(memq (car tst) match:disjoint-predicates)))
(define vec-structure? (lambda (tst)
(memq (car tst) match:vector-structures)))
;;!(function add-a
;; (form (add-a exp-syntax) -> syntax)
;; (contract syntax -> syntax)
;; (example (add-a (syntax (cdr x))) -> (syntax (cadr x))))
;; Add car operation, ie. given (c...r x), return (ca...r x).
(define add-a
(lambda (exp-syntax)
(syntax-case exp-syntax ()
((car-thing exp)
(let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
(if new
(quasisyntax/loc exp-syntax (#,(cadr new) exp))
(syntax/loc exp-syntax (car (car-thing exp))))))
(exp (syntax/loc exp-syntax (car exp))))))
;;!(function add-d
;; (form (add-d exp-syntax) -> syntax)
;; (contract syntax -> syntax)
;; (example (add-a (syntax (cdr x))) -> (syntax (cddr x))))
;; Add cdr operation, ie. given (c...r x), return (cd...r x).
(define add-d
(lambda (exp-syntax)
(syntax-case exp-syntax ()
((car-thing exp)
(let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
(if new
(quasisyntax/loc exp-syntax (#,(cddr new) exp))
(syntax/loc exp-syntax (cdr (car-thing exp))))))
(exp (syntax/loc exp-syntax (cdr exp))))))
(define c---rs '((car caar . cdar)
(cdr cadr . cddr)
(caar caaar . cdaar)
(cadr caadr . cdadr)
(cdar cadar . cddar)
(cddr caddr . cdddr)
(caaar caaaar . cdaaar)
(caadr caaadr . cdaadr)
(cadar caadar . cdadar)
(caddr caaddr . cdaddr)
(cdaar cadaar . cddaar)
(cdadr cadadr . cddadr)
(cddar caddar . cdddar)
(cdddr cadddr . cddddr)))
(define get-c---rs '((caar car . car)
(cadr cdr . car)
(cdar car . cdr)
(cddr cdr . cdr)
(caaar caar . car)
(caadr cadr . car)
(cadar cdar . car)
(caddr cddr . car)
(cdaar caar . cdr)
(cdadr cadr . cdr)
(cddar cdar . cdr)
(cdddr cddr . cdr)
(caaaar caaar . car)
(caaadr caadr . car)
(caadar cadar . car)
(caaddr caddr . car)
(cadaar cdaar . car)
(cadadr cdadr . car)
(caddar cddar . car)
(cadddr cdddr . car)
(cdaaar caaar . cdr)
(cdaadr caadr . cdr)
(cdadar cadar . cdr)
(cdaddr caddr . cdr)
(cddaar cdaar . cdr)
(cddadr cdadr . cdr)
(cdddar cddar . cdr)
(cddddr cdddr . cdr)))
;;!(function stx-dot-dot-k?
;; (form (stx-dot-dot-k? syn) -> bool)
;; (contract syntax -> bool)
;; (example (stx-dot-dot-k? (syntax ..3)) -> #t))
;; This function is a predicate that returns true if the argument
;; is syntax represents a ... or ___ syntax where the last dot or
;; underscore can be an integer
(define stx-dot-dot-k?
(lambda (syn)
(dot-dot-k? (syntax-object->datum syn))))
;;!(function implied
;; (form (implied test) -> list)
;; (contract s-exp -> list))
;; This function is given a s-expression for a test and returns a
;; list of tests that are implied by that test. The implied test
;; would have to be true if the argument is true.
(define (implied test)
(let* ((pred (car test))
(exp (cadr test)))
(cond
((equal? pred 'equal?)
(let ((ex (caddr test)))
(cond ((string? ex)
(list `(string? ,ex)))
((boolean? ex)
(list `(boolean? ,exp)))
((char? ex)
(list `(char? ,exp)))
((number? ex)
(list `(number? ,exp)))
((and (pair? ex)
(eq? 'quote (car ex)))
(list `(symbol? ,exp)))
(else '()))))
((equal? pred 'null?)
(list `(list? ,exp)))
(else '()))))

76
collects/mzlib/private/plt-match/newsyntax.txt
View File

@ -1,76 +0,0 @@
This is the proposed pattern grammar.
Asterisks mark rules that have changed.
pat ::=
identifier anything, can not be ooo
| _ anything
| #t #t
| #f #f
| string a string
| number a number
| character a character
| 'sexp an s-expression
| 'symbol a symbol (special case of s-expr)
* | (list lvp_1 ... lvp_n) list of n elements
* | (list-rest lvp_1 ... lvp_n lvp_{n+1}) list of n or more
* | (vector lvp_1 ... lvp_n) vector of n elements
* | (box pat) box
* | (struct struct-name (pat_1 ... pat_n)) a structure
;; this may be better as '$' ?
| (list-no-order pat ...) matches a list with no regard for
the order of the
items in the list
| (list-no-order pat ... pat_n ooo) pat_n matches the remaining
unmatched items
| (hash-table pat ...) matches the elements of a hash table
| (hash-table pat ... pat_n ooo) pat_n must match the remaining
unmatched elements
* | (app field pat) a field of a structure (field is
an accessor)
Actually field can be any function
which can be
applied to the data being matched.
Ex: (match 5 ((= add1 b) b)) => 6
| (and pat_1 ... pat_n) if all of pat_1 thru pat_n match
| (or pat_1 ... pat_n) if any of pat_1 thru pat_n match
| (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match
* | (? predicate pat_1 ... pat_n) if predicate is true and all of
pat_1 thru pat_n match
| (set! identifier) anything, and binds setter
| (get! identifier) anything, and binds getter
| `qp a quasi-pattern
lvp ::= pat ooo greedily matches n or more of pat,
each element must match pat
| pat matches pat
ooo ::= ... zero or more
| ___ zero or more
| ..k k or more
| __k k or more
quasi-patterns: matches:
qp ::= () the empty list
| #t #t
| #f #f
| string a string
| number a number
| character a character
| identifier a symbol
| (qp_1 ... qp_n) list of n elements
| (qp_1 ... qp_n . qp_{n+1}) list of n or more
| (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each element
of remainder must match qp_n+1
| #(qp_1 ... qp_n) vector of n elements
| #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each element
of remainder must match qp_n+1
| #&qp box
| ,pat a pattern
| ,@(lvp . . . lvp-n)
| ,@(lvp-1 . . . lvp-n . lvp-{n+1})
| ,@`qp qp must evaluate to a list as
so that this rule resembles the
above two rules

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

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

125
collects/mzlib/private/plt-match/pattern-predicates.scm
View File

@ -1,125 +0,0 @@
;; This library is used by match.ss
;;!(function proper-hash-table-pattern?
;; (form (proper-hash-table-pattern? pat-list) -> bool)
;; (contract list-of-syntax -> bool))
;; This function returns true if there is no ddk in the list of
;; patterns or there is only a ddk at the end of the list.
(define (proper-hash-table-pattern? pat-list)
(cond ((null? pat-list) #t)
(else
(let ((ddk-list (ddk-in-list? pat-list)))
(or (not ddk-list)
(and ddk-list
(ddk-only-at-end-of-list? pat-list)))))))
;;!(function ddk-in-list?
;; (form (ddk l) -> bool)
;; (contract list-of-syntax -> bool))
;; This is a predicate that returns true if there is a ddk in the
;; list.
(define (ddk-in-list? l)
(not (andmap (lambda (x) (not (stx-dot-dot-k? x))) l)))
;;!(function ddk-only-at-end-of-list?
;; (form (ddk-only-at-end-of-list? l) -> bool)
;; (contract list-of-syntax -> bool))
;; This is a predicate that returns true if there is a ddk at the
;; end of the list and the list has at least one item before the ddk.
(define ddk-only-at-end-of-list?
(lambda (l)
'(match
l
(((not (? stx-dot-dot-k?)) ..1 a) (stx-dot-dot-k? a)))
(let ((x l))
(if (list? x)
(let ddnnl26305 ((exp26306 x) (count26307 0))
(if (and (not (null? exp26306))
((lambda (exp-sym) (if (stx-dot-dot-k? exp-sym) #f #t))
(car exp26306)))
(ddnnl26305 (cdr exp26306) (add1 count26307))
(if (>= count26307 1)
(if (and (pair? exp26306) (null? (cdr exp26306)))
((lambda (a) (stx-dot-dot-k? a)) (car exp26306))
#f)
#f)))
#f))))
;;!(function ddk-only-at-end-of-vector?
;; (form (ddk-only-at-end-of-vector? vec) -> bool)
;; (contract vector -> bool))
;; This is a predicate that returns true if there is a ddk at the
;; end of the vector and the list has at least one item before the ddk.
(define ddk-only-at-end-of-vector?
(lambda (vec)
'(match
vec
(#((not (? stx-dot-dot-k?)) ..1 a) #t))
;; the following is expanded from the above match expression
(let ((x vec))
(let ((match-failure
(lambda () #f)))
(if (vector? x)
(let ((lv32956 (vector-length x)))
(if (>= lv32956 2)
(let ((curr-ind32957 0))
(let vloop32958 ((count32959 curr-ind32957))
(let ((fail32961
(lambda (count-offset32962 index32963)
(if (>= count-offset32962 1)
(if (= index32963 lv32956)
(match-failure)
(let ((cindnm32965 (add1 index32963)))
(if (>= cindnm32965 lv32956)
((lambda (a) #t)
(vector-ref x index32963))
(match-failure))))
(match-failure)))))
(if (= lv32956 count32959)
(fail32961 (- count32959 curr-ind32957) count32959)
(if (stx-dot-dot-k? (vector-ref x count32959))
(fail32961 (- count32959 curr-ind32957)
count32959)
(let ((arglist (list)))
(apply vloop32958 (add1 count32959)
arglist)))))))
(match-failure)))
(match-failure))))))
;;!(function ddk-in-vec?
;; (form (ddk-in-vec? vec stx) -> (integer or #f))
;; (contract (vector syntax) -> (integer or bool)))
;; this function returns the total of the k's in a vector of syntax
;; it also insure that the ..k's are not consecutive
(define ddk-in-vec?
(lambda (vec stx)
;; make sure first element is not ddk
(if (stx-dot-dot-k? (vector-ref vec 0))
(match:syntax-err
stx
"vector pattern cannot start with ..k syntax")
(let ((vlength (vector-length vec))
(flag #f))
(letrec ((check-vec
(lambda (last-stx index)
(if (= index vlength)
0
(let ((k-prev (stx-dot-dot-k? last-stx))
(k-curr (stx-dot-dot-k? (vector-ref vec
index))))
(cond
((and k-prev k-curr)
(match:syntax-err
stx
"consecutive ..k markers are not allowed"))
(k-curr
(begin
(set! flag #t)
(+ (- k-curr 2) (check-vec (vector-ref vec
index)
(add1 index)))))
(else
(check-vec (vector-ref vec index)
(add1 index)))))))))
(let ((res (check-vec (vector-ref vec 0) 1)))
(if flag res #f)))))))

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

@ -1,822 +0,0 @@
;; This library is used by match.ss
;;!(function render-test-list
;; (form (render-test-list p ae stx) -> test-list)
;; (contract (syntax syntax syntax) -> list))
;; This is the most important function of the entire compiler.
;; This is where the functionality of each pattern is implemented.
;; This function maps out how each pattern is compiled. While it
;; only returns a list of tests, the comp field of those tests
;; contains a function which inturn knows enough to compile the
;; pattern.
;; <p>This is implemented in what Wright terms as mock-continuation-passing
;; style. The functions that create the syntax for a match success and failure
;; are passed forward
;; but they are always called in emit. This is extremely effective for
;; handling the different structures that are matched. This way we can
;; specify ahead of time how the rest of the elements of a list or vector
;; should be handled. Otherwise we would have to pass more information
;; forward in the argument list of next and then test for it later and
;; then take the appropriate action. To understand this better take a
;; look at how proper and improper lists are handled.
(define (render-test-list p ae stx)
(include "special-generators.scm")
(include "ddk-handlers.scm")
(include "getter-setter.scm")
(include "emit-assm.scm")
(include "parse-quasi.scm")
(include "pattern-predicates.scm")
(define (append-if-necc sym stx)
(syntax-case stx ()
(() (syntax (list)))
((a ...)
(quasisyntax/loc stx (#,sym a ...)))
(p (syntax p))))
(syntax-case*
p
(_ list quote quasiquote vector box ? app and or not struct set! var
list-rest get! ... ___ unquote unquote-splicing
list-no-order hash-table regexp pregexp) stx-equal?
(_ '()) ;(ks sf bv let-bound))
(pt
(and (identifier? (syntax pt))
(pattern-var? (syntax-object->datum (syntax pt)))
(not (stx-dot-dot-k? (syntax pt))))
(render-test-list (syntax/loc stx (var pt)) ae stx))
((var pt)
(identifier? (syntax pt))
(list (make-act `bind-var-pat
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(let ((raw-id (syntax-object->datum (syntax pt))))
(cond ((ormap (lambda (x)
(if (equal? raw-id (syntax-object->datum (car x)))
(cdr x) #f)) bv)
=> (lambda (bound-exp)
(emit (lambda (exp)
(quasisyntax/loc
p
(equal? #,exp #,(subst-bindings bound-exp let-bound))))
ae
let-bound
sf bv kf ks)))
(else
(ks sf (cons (cons (syntax pt) ae) bv))))))))))
((list)
(list
(make-reg-test
`(null? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp)
(quasisyntax/loc p (null? #,exp)))
ae
let-bound
sf
bv
kf
ks))))))
('()
(list
(make-reg-test
`(null? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp)
(quasisyntax/loc p (null? #,exp)))
ae
let-bound
sf
bv
kf
ks)))))
)
(pt
;; could convert the syntax once
(or (stx-? string? (syntax pt))
(stx-? boolean? (syntax pt))
(stx-? char? (syntax pt))
(stx-? number? (syntax pt)))
(list
(make-reg-test
`(equal? ,(syntax-object->datum ae)
,(syntax-object->datum (syntax pt)))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp) (quasisyntax/loc p (equal? #,exp pt)))
ae
let-bound
sf bv kf ks))))))
;(pt
; (stx-? regexp? (syntax pt))
; (render-test-list (syntax/loc p (regex pt)) ae stx))
((quote _)
(list
(make-reg-test
`(equal? ,(syntax-object->datum ae)
,(syntax-object->datum p))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp) (quasisyntax/loc p (equal? #,exp #,p)))
ae
let-bound
sf bv kf ks))))))
(`quasi-pat
(render-test-list (parse-quasi (syntax quasi-pat)) ae stx))
('item
(list (make-reg-test
`(equal? ,(syntax-object->datum ae)
,(syntax-object->datum p))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp) (quasisyntax/loc p (equal? #,exp #,p)))
ae
let-bound
sf bv kf ks))))))
;;('(items ...)
;;(emit (quasisyntax/loc p (equal? #,e #,p)) sf bv kf ks))
((? pred? pat1 pats ...)
(render-test-list (syntax (and (? pred?) pat1 pats ...)) ae stx))
;; could we check to see if a predicate is a procedure here?
((? pred?)
(list (make-reg-test
`(,(syntax-object->datum (syntax pred?))
,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp) (quasisyntax/loc p (pred? #,exp)))
ae
let-bound
sf bv kf ks))))))
;; syntax checking
((? pred? ...)
(match:syntax-err
p
(if (zero? (length (syntax-e (syntax (pred? ...)))))
"a predicate pattern must have a predicate following the ?"
"syntax error in predicate pattern")))
((regexp reg-exp)
(render-test-list (quasisyntax/loc
p
(and (? string?)
(? (lambda (x) (regexp-match reg-exp x)))))
ae
stx))
((pregexp reg-exp)
(render-test-list (quasisyntax/loc
p
(and (? string?)
(? (lambda (x) (pregexp-match-with-error
reg-exp x)))))
ae
stx))
((regexp reg-exp pat)
(render-test-list (quasisyntax/loc
p
(and (? string?)
(app (lambda (x) (regexp-match reg-exp x)) pat)))
ae
stx))
((pregexp reg-exp pat)
(render-test-list (quasisyntax/loc
p
(and (? string?)
(app (lambda (x) (pregexp-match-with-error
reg-exp x)) pat)))
ae
stx))
((app op pat)
(render-test-list (syntax pat)
(quasisyntax/loc p (op #,ae))
stx))
;; syntax checking
((app op ...)
(match:syntax-err
p
(if (zero? (length (syntax-e (syntax (op ...)))))
"an operation pattern must have a procedure following the app"
"there should be one pattern following the operator")))
((and pats ...)
(let loop
((p (syntax (pats ...))))
(syntax-case p ()
(() '()) ;(ks seensofar boundvars let-bound))
((pat1 pats ...)
(append (render-test-list (syntax pat1) ae stx)
(loop (syntax (pats ...))))))))
((or pats ...)
(list (make-act
'or-pat ;`(or-pat ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(or-gen ae (syntax-e (syntax (pats ...)))
stx sf bv ks kf let-bound))))))
; backtracking or
; ((or pats ...)
; (let* ((pat-list (syntax->list (syntax (pats ...)))))
; (let* ((bound (getbindings (stx-car (syntax (pats ...)))))
; (bind-map
; (map (lambda (x)
; (cons x
; #`#,(gensym (syntax-object->datum x))))
; bound))
; (id (begin (set! or-id (add1 or-id)) (sub1 or-id))))
; (write id)(newline)
; (write (syntax-object->datum (syntax (pats ...))))(newline)
; (list
; (make-act
; 'or-pat
; ae
; (lambda (ks kf let-bound)
; (lambda (sf bv)
; (write id)(newline)
; (if (stx-null? (syntax (pats ...)))
; (kf sf bv)
; #`(let #,(map (lambda (b)
; #`(#,(cdr b) '()))
; bind-map)
; (if (or
; #,@(map (lambda (p)
; #`(#,(create-test-func
; p
; sf
; let-bound
; bind-map
; #f) #,(subst-bindings ae
; let-bound)))
; pat-list))
; #,(ks sf (append bind-map bv))
; #,(kf sf bv)))))))))))
((not pat)
(list (make-act
'not-pat ;`(not-pat ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
;; swap success and fail
(next-outer (syntax pat) ae sf bv let-bound ks kf))))))
;; could try to catch syntax local value error and rethrow syntax error
((list-no-order pats ...)
(if (stx-null? (syntax (pats ...)))
(render-test-list (syntax/loc p (list)) ae stx)
(let* ((pat-list (syntax->list (syntax (pats ...))))
(ddk-list (ddk-in-list? pat-list))
(ddk (ddk-only-at-end-of-list? pat-list)))
(if (or (not ddk-list)
(and ddk-list ddk))
(let* ((bound (getbindings (append-if-necc 'list
(syntax (pats ...)))))
(bind-map
(map (lambda (x)
(cons x
#`#,(gensym (syntax-object->datum x))))
bound)))
(list
(make-shape-test
`(list? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp)
(quasisyntax/loc stx (list? #,exp)))
ae
let-bound
sf
bv
kf
ks))))
(make-act
'list-no-order
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(let ((last-test
(if ddk
(let ((pl (cdr (reverse pat-list))))
(begin
(set! pat-list (reverse (cdr pl)))
(create-test-func (car pl)
sf
let-bound
bind-map
#t)))
#f)))
#`(let #,(map (lambda (b)
#`(#,(cdr b) '()))
bind-map)
(let ((last-test #,last-test)
(test-list
(list
#,@(map (lambda (p)
(create-test-func
p
sf
let-bound
bind-map
#f))
pat-list))))
(if (match:test-no-order test-list
#,ae
last-test
#,ddk)
#,(ks sf (append bind-map bv))
#,(kf sf bv))))))))))
(match:syntax-err
p
(string-append "dot dot k can only appear at "
"the end of unordered match patterns"))))))
((hash-table pats ...)
;; must check the structure
(proper-hash-table-pattern? (syntax->list (syntax (pats ...))))
(list
(make-shape-test
`(hash-table? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp) (quasisyntax/loc stx (hash-table? #,exp)))
ae
let-bound
sf
bv
kf
ks))))
(let ((mod-pat
(lambda (pat)
(syntax-case pat ()
((key value) (syntax (list key value)))
(ddk
(stx-dot-dot-k? (syntax ddk))
(syntax ddk))
(id
(and (identifier? (syntax id))
(pattern-var? (syntax-object->datum (syntax id)))
(not (stx-dot-dot-k? (syntax id))))
(syntax id))
(p (match:syntax-err
(syntax/loc stx p)
"poorly formed hash-table pattern"))))))
(make-act
'hash-table-pat
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(let ((hash-name (gensym 'hash)))
#`(let ((#,hash-name
(hash-table-map #,(subst-bindings ae
let-bound)
(lambda (k v) (list k v)))))
#,(next-outer #`(list-no-order #,@(map mod-pat (syntax->list (syntax (pats ...)))))
#`#,hash-name
sf
;; these tests have to be true
;;(append (list
;; '(pair? exp)
;; '(pair? (cdr exp))
;; '(null? (cdr (cdr exp))))
;; sf)
bv
let-bound
kf
ks)))))))))
((hash-table pats ...)
(match:syntax-err
p
"improperly formed hash table pattern"))
((struct struct-name (fields ...))
(identifier? (syntax struct-name))
(let ((num-of-fields (stx-length (syntax (fields ...)))))
(let-values (((pred accessors mutators parental-chain)
(struct-pred-accessors-mutators
(syntax struct-name)
(lambda ()
(match:syntax-err
(syntax struct-name)
"not a defined structure")))))
(let ((dif (- (length accessors) num-of-fields)))
(if (not (zero? dif))
(match:syntax-err
p
(string-append
(if (> dif 0) "not enough " "too many ")
"fields for structure in pattern"))
(cons
(make-shape-test
`(struct-pred ,(syntax-object->datum pred)
,(map syntax-object->datum parental-chain)
,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp)
(quasisyntax/loc stx (struct-pred #,pred #,parental-chain #,exp)))
ae
let-bound
sf
bv
kf
ks))))
(let ((field-pats (syntax->list (syntax (fields ...)))))
(let rloop ((n 0))
(if (= n num-of-fields)
'()
(append
(let ((cur-pat (list-ref field-pats n)))
(syntax-case cur-pat (set! get!)
((set! setter-name)
(list (make-act
'set!-pat
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(ks sf
(cons (cons (syntax setter-name)
#`(lambda (y)
(#,(list-ref
mutators
n)
#,ae y)))
bv)))))))
((get! getter-name)
(list (make-act
'get!-pat
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(ks sf
(cons (cons (syntax getter-name)
#`(lambda ()
(#,(list-ref
accessors
n)
#,ae)))
bv)))))))
(_
(render-test-list
cur-pat
(quasisyntax/loc
stx
(#,(list-ref accessors n) #,ae))
stx))))
(rloop (+ 1 n))))))))))))
;; syntax checking
((struct ident ...)
(match:syntax-err
p
(if (zero? (length (syntax-e (syntax (ident ...)))))
(format "~a~n~a~n~a"
"a structure pattern must have the name "
"of a defined structure followed by a list of patterns "
"to match each field of that structure")
"syntax error in structure pattern")))
((set! ident)
(identifier? (syntax ident))
(list (make-act
'set!-pat
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(ks sf (cons (cons (syntax ident)
(setter ae p let-bound))
bv)))))))
;; syntax checking
((set! ident ...)
(let ((x (length (syntax-e (syntax (ident ...))))))
(match:syntax-err
p
(if (= x 1)
"there should be an identifier after set! in pattern"
(string-append "there should "
(if (zero? x) "" "only ")
"be one identifier after set! in pattern")))))
((get! ident)
(identifier? (syntax ident))
(list (make-act
'get!-pat
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(ks sf (cons (cons (syntax ident)
(getter ae p let-bound))
bv)))))))
((get! ident ...)
(let ((x (length (syntax-e (syntax (ident ...))))))
(match:syntax-err
p
(if (= x 1)
"there should be an identifier after get! in pattern"
(string-append "there should "
(if (zero? x) "" "only ")
"be one identifier after get! in pattern")))))
((list pat dot-dot-k pat-rest ...)
(and (not (or (memq (syntax-e (syntax pat))
'(unquote unquote-splicing ... ___))
(stx-dot-dot-k? (syntax pat))))
(stx-dot-dot-k? (syntax dot-dot-k)))
(list
(make-shape-test
`(list? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
;;(write 'here)(write let-bound)(newline)
(lambda (sf bv)
(emit
(lambda (exp) (quasisyntax/loc stx (list? #,exp)))
ae
let-bound
sf
bv
kf
ks))))
(make-act
'list-ddk-pat
ae
(lambda (ks kf let-bound)
(if (stx-null? (syntax (pat-rest ...)))
(handle-end-ddk-list ae kf ks
(syntax pat)
(syntax dot-dot-k)
stx let-bound)
(handle-inner-ddk-list ae kf ks
(syntax pat)
(syntax dot-dot-k)
(append-if-necc 'list
(syntax (pat-rest ...)))
stx
let-bound))))))
((list-rest pat dot-dot-k pat-rest ...)
(and (not (or (memq (syntax-e (syntax pat))
'(unquote unquote-splicing ... ___))
(stx-dot-dot-k? (syntax pat))
(stx-null? (syntax (pat-rest ...)))))
(stx-dot-dot-k? (syntax dot-dot-k)))
(list
(make-shape-test
`(pair? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
;;(write 'here)(write let-bound)(newline)
(lambda (sf bv)
(emit
(lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
ae
let-bound
sf
bv
kf
ks))))
(make-act
'list-ddk-pat
ae
(lambda (ks kf let-bound)
(handle-inner-ddk-list
ae kf ks
(syntax pat)
(syntax dot-dot-k)
(if (= 1 (length
(syntax->list (syntax (pat-rest ...)))))
(stx-car (syntax (pat-rest ...)))
(append-if-necc 'list-rest
(syntax (pat-rest ...))))
stx
let-bound)))))
;; handle proper and improper lists
((list-rest car-pat cdr-pat) ;pattern ;(pat1 pats ...)
(not (or (memq (syntax-e (syntax car-pat))
'(unquote unquote-splicing))
(stx-dot-dot-k? (syntax car-pat))))
(cons
(make-shape-test
`(pair? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
;;(write 'here)(write let-bound)(newline)
(lambda (sf bv)
(emit
(lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
ae
let-bound
sf
bv
kf
ks))))
(append
(render-test-list (syntax car-pat)
(quasisyntax/loc (syntax car-pat) (car #,ae))
stx) ;(add-a e)
(render-test-list
(syntax cdr-pat)
(quasisyntax/loc (syntax cdr-pat) (cdr #,ae))
stx))))
((list-rest car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
(not (or (memq (syntax-e (syntax car-pat))
'(unquote unquote-splicing))
(stx-dot-dot-k? (syntax car-pat))))
(cons
(make-shape-test
`(pair? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
;;(write 'here)(write let-bound)(newline)
(lambda (sf bv)
(emit
(lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
ae
let-bound
sf
bv
kf
ks))))
(append
(render-test-list (syntax car-pat)
(quasisyntax/loc (syntax car-pat) (car #,ae))
stx) ;(add-a e)
(render-test-list
(append-if-necc 'list-rest (syntax (cdr-pat ...)))
(quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae))
stx))))
((list car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
(not (or (memq (syntax-e (syntax car-pat))
'(unquote unquote-splicing))
(stx-dot-dot-k? (syntax car-pat))))
(cons
(make-shape-test
`(pair? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
;;(write 'here)(write let-bound)(newline)
(lambda (sf bv)
(emit
(lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
ae
let-bound
sf
bv
kf
ks))))
(append
(render-test-list (syntax car-pat)
(quasisyntax/loc (syntax car-pat) (car #,ae))
stx) ;(add-a e)
(if (stx-null? (syntax (cdr-pat ...)))
(list
(make-shape-test
`(null? (cdr ,(syntax-object->datum ae)))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp)
(quasisyntax/loc p (null? #,exp)))
(quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae));ae
let-bound
sf
bv
kf
ks)))))
(render-test-list
(append-if-necc 'list (syntax (cdr-pat ...)))
(quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae))
stx)))))
((vector pats ...)
(ddk-only-at-end-of-list? (syntax-e (syntax (pats ...))))
(list
(make-shape-test
`(vector? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
ae
let-bound
sf
bv
kf
ks))))
(make-act
'vec-ddk-pat
ae
(lambda (ks kf let-bound)
(handle-ddk-vector ae kf ks
(syntax/loc p #(pats ...))
stx let-bound)))))
((vector pats ...)
(let* ((temp (syntax-e (syntax (pats ...))))
(len (length temp)))
(and (>= len 2)
(ddk-in-list? temp)))
;; make this contains ddk with no ddks consecutive
;;(stx-dot-dot-k? (vector-ref temp (sub1 len))))))
(list
(make-shape-test
`(vector? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit (lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
ae
let-bound
sf
bv
kf
ks))))
;; we have to look at the first pattern and see if a ddk follows it
;; if so handle that case else handle the pattern
(make-act
'vec-ddk-pat
ae
(lambda (ks kf let-bound)
(handle-ddk-vector-inner ae kf ks
(syntax/loc p #(pats ...))
stx let-bound)))))
((vector pats ...)
(let* ((syntax-vec (list->vector (syntax->list (syntax (pats ...)))))
(vlen (vector-length syntax-vec)))
(cons
(make-shape-test
`(vector? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit
(lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
ae
let-bound
sf bv kf ks))))
(cons
(make-shape-test
`(equal? (vector-length ,(syntax-object->datum ae)) ,vlen)
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit
(lambda (exp) (quasisyntax/loc
stx
(equal? (vector-length #,exp) #,vlen)))
ae
let-bound
sf bv kf ks))))
(let vloop ((n 0))
(if (= n vlen)
'()
(append
(render-test-list
(vector-ref syntax-vec n)
(quasisyntax/loc stx (vector-ref #,ae #,n))
stx)
(vloop (+ 1 n)))))))))
((box pat)
(cons
(make-shape-test
`(box? ,(syntax-object->datum ae))
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
(emit
(lambda (exp) (quasisyntax/loc stx (box? #,exp)))
ae
let-bound
sf bv kf ks))))
(render-test-list
(syntax pat)
(quasisyntax/loc stx (unbox #,ae))
stx)))
(got-too-far
(match:syntax-err
(syntax/loc stx got-too-far)
"syntax error in pattern"))))

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

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

150
collects/mzlib/private/plt-match/special-generators.scm
View File

@ -1,150 +0,0 @@
;; This library is used by match.ss
;;!(function or-gen
;; (form (or-gen exp orpatlist stx sf bv ks kf let-bound)
;; ->
;; syntax)
;; (contract (syntax list syntax list list (list list -> syntax)
;; (list list -> syntax) list)
;; ->
;; syntax))
;; The function or-gen is very similar to the function gen except
;; that it is called when an or pattern is compiled. An or
;; pattern is essentially the same as a match pattern with several
;; clauses. The key differences are that it exists within a
;; larger pattern and the state of compilation has information
;; that will help optimaize its compilation. And the success of
;; any pattern results in the same outcome.
(define or-gen
(lambda (exp orpatlist stx sf bv ks kf let-bound)
(let ((rendered-list
(map
(lambda (pat)
(cons (render-test-list pat exp stx)
(lambda (fail let-bound)
(lambda (sf bv)
(let ((bv (map
(lambda (bind)
(cons (car bind)
(subst-bindings (cdr bind)
let-bound)))
bv)))
(ks sf bv))))))
orpatlist)))
(update-counts rendered-list)
(update-binding-counts rendered-list)
(let* ((rendered-list
(reorder-all-lists rendered-list)
)
(output ((meta-couple rendered-list kf let-bound bv) sf bv)))
output))))
;;!(function next-outer
;; (form (next-outer p ae sf bv let-bound kf ks syntax bool)
;; ->
;; syntax)
;; (contract (syntax syntax list list list (list list -> syntax)
;; (list list -> syntax) syntax bool)
;; ->
;; syntax))
;; The function next-outer is basically a throw-back to the next
;; function of the original match compiler. It compiles a pattern
;; or sub-pattern of a clause and does not yield a list of
;; partially compiled test structs. This function is called
;; inside of test constructs that cannot be eliminated because of
;; a related presence in the test-so-far list. So, instead of
;; partially compiling patterns this function fully compiles patterns.
(define next-outer
(opt-lambda (p
ae ;; this is the actual expression
sf
bv
let-bound
kf
ks
[stx (syntax '())]
[opt #f])
(next-outer-helper p ae sf bv let-bound
(lambda (x) kf) (lambda (a b) ks) stx opt)))
;;!(function next-outer-helper
;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool)
;; ->
;; syntax)
;; (contract (syntax syntax list list list (list list -> syntax)
;; (list list -> syntax) syntax bool)
;; ->
;; syntax))
;; The function next-outer-helper contains the meat of next-outer
;; and allows the programmer to pass higher order functions
;; ks-func and kf-func that will be given compile time imformation
;; about let-bindings etc. which in turn will allow the programmer
;; to take advantage of this info.
(define next-outer-helper
(opt-lambda (p
ae ;; this is the actual expression
sf
bv
let-bound
kf-func
ks-func
[stx (syntax '())]
[opt #f])
;; right now this does not bind new variables
(let ((rendered-list (render-test-list p ae stx)))
;; no need to reorder lists although I suspect that it may be
;; better to put shape tests first
(update-binding-count rendered-list)
((couple-tests rendered-list ks-func kf-func let-bound) sf bv))))
;;!(function create-test-func
;; (form (create-test-func p sf let-bound bind-map last-test)
;; ->
;; syntax)
;; (contract (syntax list list a-list bool) -> syntax))
;; This function creates a runtime function that is used as an
;; individual test in a list of tests for the list-no-order
;; pattern.
;; <pre>
;; bindmap - a-list of bindings mapped to their expressions
;; last-test - a boolean value that indicates whether this function
;; is collecting one value or a list of values.</pre>
(define (create-test-func p sf let-bound bind-map last-test)
(quasisyntax/loc
p
(lambda (exp)
#,(next-outer-helper
p #'exp sf '() let-bound
(lambda (let-bound)
(lambda (sf bv)
#'#f))
(lambda (fail let-bound)
(lambda (sf bv)
#`(begin
#,@(map (lambda (bind)
(let ((binding-name (get-bind-val (car bind) bind-map))
(exp-to-bind
(subst-bindings (cdr bind) let-bound)))
(if last-test
#`(set! #,binding-name
(cons #,exp-to-bind #,binding-name))
#`(set! #,binding-name
#,exp-to-bind))))
bv)
#t)))))))
;;!(function getbindings
;; (form (getbindings pat-syntax) -> list)
;; (contract syntax -> list))
;; This function given a pattern returns a list of pattern
;; variable names which are found in the pattern.
(define (getbindings pat-syntax)
(let/cc out
(next-outer
pat-syntax
(quote-syntax dummy)
'()
'()
'()
(lambda (sf bv) #'(dummy-symbol))
(lambda (sf bv) (out (map car bv))))))

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

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

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

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

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

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

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

@ -1,181 +0,0 @@
;; This library is used by match.ss
;; This requires the test data structure.
(define-values (update-counts)
(letrec
(
;;!(function test-filter
;; (form (test-filter test-list) -> test-list)
;; (contract list -> list))
;; This function filters out tests that do not need to be to have
;; their counts updated for reordering purposes. These are the
;; more complex patterns such as or-patterns or ddk patterns.
(test-filter
(lambda (tlist)
(if (null? tlist)
'()
(if (= -1 (test-times-used (car tlist)))
(test-filter (cdr tlist))
(cons (car tlist)
(test-filter (cdr tlist)))))))
;; !(function inverse-in
;; (form (inverse-in test test-list) -> bool)
;; (contract (s-exp list) -> bool))
;; This function checks to see if any of the members of the test-list
;; would be eliminated by the function if the test was in the test so far
;; list. This is the opposite of what the in function does.
(inverse-in
(lambda (test test-list)
(or (pos-inverse-in test test-list)
(neg-inverse-in test test-list))))
(pos-inverse-in
(lambda (test test-list)
(let ((test-with-implied (cons test (implied test))))
(ormap (lambda (t) (in t test-with-implied))
test-list)
)))
(neg-inverse-in
(lambda (test test-list)
(let ((test-with-implied (cons test (implied test))))
(ormap (lambda (t) (in `(not ,t) test-with-implied))
test-list)
)))
(logical-member
(lambda (item lst)
(ormap (lambda (cur)
(logical-equal? item cur))
lst)))
(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))
(let ((exp8164 (car x)))
(if (and (pair? exp8164) (equal? (car exp8164) 'list?))
(let ((exp8165 (cdr exp8164)))
(if (and (pair? exp8165) (null? (cdr exp8165)))
(let ((exp8166 (car exp8163)))
(if (and (pair? exp8166) (equal? (car exp8166) 'null?))
(let ((exp8167 (cdr exp8166)))
(if (and (pair? exp8167)
(null? (cdr exp8167))
(equal? (car exp8167) (car exp8165)))
((lambda (x) #t) (car exp8165))
((lambda (else) #f) x)))
((lambda (else) #f) x)))
((lambda (else) #f) x)))
((lambda (else) #f) x))))
((lambda (else) #f) x)))
((lambda (else) #f) x))))
(truncate
(lambda (pos used-set-neg)
(cond ((null? used-set-neg)
'())
((>= pos (car used-set-neg))
(list pos))
(else
(cons (car used-set-neg)
(truncate pos (cdr used-set-neg)))))))
(truncate-neg
(lambda (pos used-set-neg)
(cond ((null? used-set-neg)
'())
((>= pos (car used-set-neg))
'())
(else
(cons (car used-set-neg)
(truncate-neg pos (cdr used-set-neg)))))))
;;!(function update-count
;; (form (update-count test tests-rest pos) -> void)
;; (contract (test-struct list integer) -> void))
;; This function updates the test-times-used and test-used-set
;; fields of the test structs. These fields are essential to
;; determining the order of the tests.
(update-count
(lambda (test tests-rest pos mem-table)
(let loop ((l tests-rest)
(p (add1 pos)))
(if (null? l)
(begin
;; memoize
(hash-table-get mem-table (test-tst test)
(lambda ()
(hash-table-put!
mem-table
(test-tst test) (list (test-used-set test)
(test-used-set-neg test)))))
)
(let ((entry-pair
(hash-table-get mem-table (test-tst test)
(lambda ()
(when (
;member
logical-member
;inverse-in
(test-tst test) (car l))
(set-test-times-used! test (add1 (test-times-used test)))
(set-test-used-set! test (cons p (test-used-set test)))
(set-test-equal-set! test (cons p (test-equal-set test)))
)
(when (neg-inverse-in (test-tst test) (car l))
(set-test-used-set-neg! test (cons p (test-used-set-neg test))))
(loop (cdr l) (add1 p))
))))
(when (and (list? entry-pair) (not (null? entry-pair)))
(let ((trun-used (truncate pos (car entry-pair))))
(set-test-used-set! test trun-used)
(set-test-equal-set! test trun-used)
(set-test-times-used! test (length trun-used))
(set-test-used-set-neg! test (truncate-neg pos (cadr entry-pair)))))
)))))
;;!(function update-counts
;; (form (update-counts render-list) -> void)
;; (contract list -> void))
;; This function essentially calls update-count on every test in
;; all of the test lists.
(update-counts
(lambda (render-list)
(let* ((mem-table (make-hash-table 'equal))
(test-master-list (map test-filter
(map car render-list)))
(test-so-far-lists ;; horrible name
(map
(lambda (tl)
(let ((f (map test-tst (test-filter tl))))
f))
test-master-list)))
(let loop ((tml test-master-list)
(tsf test-so-far-lists)
(pos 1))
(if (null? tml)
'()
(begin
(map (lambda (t)
(set-test-times-used! t 1)
(set-test-used-set!
t
(cons pos (test-used-set t)))
(set-test-equal-set!
t
(cons pos (test-equal-set t)))
(update-count t (cdr tsf) pos mem-table))
(car tml))
(loop (cdr tml) (cdr tsf) (add1 pos))))))))
)
(values update-counts)))