d1fe9f9645
Remove pointless optional arguments in getbindings. Don't create unneccessary match-lambda*. Implement keyword arguments to define-match-expander. Lots of refactoring of gen-match for general clarity. Use combinators instead of writing our own loops. Simplify struct info accessor. Add timing printer. Refactor coupling/binding for general clarity. Rewrite logical-equal not to use the expansion of match. General replacement of () with []. svn: r4192
185 lines
8.5 KiB
Scheme
185 lines
8.5 KiB
Scheme
|
|
(module coupling-and-binding mzscheme
|
|
;; This library is used by match.ss
|
|
|
|
(provide couple-tests meta-couple subst-bindings)
|
|
|
|
(require "test-structure.scm"
|
|
"match-helper.ss"
|
|
(lib "pretty.ss")
|
|
(lib "list.ss"))
|
|
|
|
(require-for-template mzscheme)
|
|
|
|
;; a structure representing bindings of portions of the matched data
|
|
;; exp: the expression that is bound in s-exp form
|
|
;; exp-stx: the expression that is bound in syntax form
|
|
;; new-exp: the new symbol that will represent the expression
|
|
(define-struct binding (exp exp-stx new-exp))
|
|
|
|
;;!(function couple-tests
|
|
;; (form (couple-tests test-list ks-func kf-func let-bound)
|
|
;; ->
|
|
;; ((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.
|
|
(define (couple-tests test-list ks-func kf-func let-bound)
|
|
;(print-time "entering couple-tests")
|
|
;(printf "test-list: ~a~n" (map test-tst test-list))
|
|
;(printf "test-list size: ~a~n" (length test-list))
|
|
(if (null? test-list)
|
|
(ks-func (kf-func let-bound) let-bound)
|
|
(let* ([cur-test (car test-list)]
|
|
[rest-tests (cdr test-list)]
|
|
;; this couples together the rest of the test
|
|
;; it is passed a list of the already bound expressions
|
|
;; only used in test/rest
|
|
[couple-rest (lambda (let-bound)
|
|
(couple-tests rest-tests
|
|
ks-func
|
|
(if (negate-test? cur-test)
|
|
(lambda (let-bound)
|
|
(lambda (sf bv)
|
|
#`(match-failure)))
|
|
kf-func)
|
|
let-bound))]
|
|
;; this generates the current test as well as the rest of the match expression
|
|
;; it is passed a list of the already bound expressions
|
|
[test/rest (lambda (let-bound)
|
|
((test-comp cur-test)
|
|
(couple-rest let-bound)
|
|
(kf-func let-bound)
|
|
let-bound))])
|
|
(if (and
|
|
;; the expression is referenced twice
|
|
(>= (test-bind-count cur-test) 2)
|
|
;; and it's not already bound to some variable
|
|
(not (exp-already-bound?
|
|
(test-bind-exp cur-test)
|
|
let-bound)))
|
|
;; then generate a new binding for this expression
|
|
(let* ([new-exp (get-exp-var)]
|
|
[binding (make-binding (test-bind-exp cur-test)
|
|
(test-bind-exp-stx cur-test)
|
|
new-exp)]
|
|
[let-bound (cons binding let-bound)])
|
|
(with-syntax (;; the new variable
|
|
[v new-exp]
|
|
;; the expression being bound
|
|
;; with appropriate substitutions for the already bound portions
|
|
[expr (sub-expr-subst (binding-exp-stx binding) let-bound)])
|
|
(lambda (sf bv)
|
|
#`(let ([v expr])
|
|
;; the new body, using the new binding (through let-bound)
|
|
#,((test/rest let-bound) sf bv)))))
|
|
|
|
;; otherwise it doesn't need a binding, and we can just do the test
|
|
(test/rest let-bound)))))
|
|
|
|
;;!(function subst-bindings
|
|
;; (form (subst-bindings exp-stx let-bound) -> syntax)
|
|
;; (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.
|
|
(define (subst-bindings exp-stx let-bound)
|
|
(cond [(get-bind exp-stx let-bound) => binding-new-exp]
|
|
[else (sub-expr-subst exp-stx let-bound)]))
|
|
|
|
;;!(function sub-exp-subst
|
|
;; (form (sub-exp-subst exp-stx let-bound) -> syntax)
|
|
;; (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.
|
|
;; This function assumes that all accessors are of the form
|
|
;; (acc obj other-args ...) (such as list-ref)
|
|
(define (sub-expr-subst exp-stx let-bound)
|
|
(syntax-case exp-stx ()
|
|
[(access sub-exp rest ...)
|
|
(let ([binding (get-bind #'sub-exp let-bound)])
|
|
(if binding
|
|
#`(access #,(binding-new-exp binding) rest ...)
|
|
#`(access #,(sub-expr-subst #'sub-exp let-bound) rest ...)))]
|
|
[_ exp-stx]))
|
|
|
|
; helper for the following functions
|
|
(define ((equal-bind-get exp) e)
|
|
(equal? exp (binding-exp e)))
|
|
|
|
;;!(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.
|
|
(define (get-bind exp let-bound)
|
|
(cond [(memf (equal-bind-get (syntax-object->datum exp)) let-bound) => car]
|
|
[else #f]))
|
|
|
|
;;!(function exp-already-bound?
|
|
;; (form (exp-already-bound? exp let-bound) -> binding)
|
|
;; (contract (any list) -> boolean))
|
|
;; 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.
|
|
(define (exp-already-bound? exp let-bound)
|
|
(ormap (equal-bind-get exp) 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.
|
|
(define (meta-couple rendered-list failure-func let-bound bvsf)
|
|
#;(print-time "entering meta-couple")
|
|
;(printf "rendered-list ~n")
|
|
;(pretty-print (map (lambda (x) (map test-tst (car x))) rendered-list))
|
|
(if (null? rendered-list)
|
|
failure-func
|
|
;; here we erase the previously bound variables
|
|
(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
|
|
|
|
(require (lib "trace.ss"))
|
|
;(trace meta-couple)
|
|
;(trace couple-tests)
|
|
) |