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
213 lines
9.1 KiB
Scheme
213 lines
9.1 KiB
Scheme
(module gen-match mzscheme
|
|
|
|
(provide gen-match)
|
|
|
|
(require (lib "etc.ss")
|
|
(lib "stx.ss" "syntax")
|
|
"match-helper.ss"
|
|
"match-error.ss"
|
|
"coupling-and-binding.scm"
|
|
"update-counts.scm"
|
|
"update-binding-counts.scm"
|
|
"render-test-list.scm"
|
|
"reorder-tests.scm"
|
|
"tag-negate-tests.scm"
|
|
"convert-pat.ss")
|
|
|
|
(require-for-template mzscheme
|
|
(lib "etc.ss")
|
|
"match-error.ss")
|
|
|
|
|
|
|
|
;;!(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 clauses)
|
|
(syntax-map (lambda (x) (cons x #f)) clauses))
|
|
|
|
;; parse-clause : syntax -> syntax syntax maybe[syntax]
|
|
;; takes in a pattern
|
|
;; returns three values representing the pattern, the body and the failure symbol
|
|
|
|
(define (parse-clause clause)
|
|
(syntax-case clause (=>)
|
|
[(pat) (match:syntax-err clause
|
|
"missing action for pattern")]
|
|
[(pat (=> fail-sym))
|
|
(match:syntax-err clause
|
|
"missing action for pattern")]
|
|
[(pat (=> fail-sym) body ...)
|
|
(values #'pat
|
|
#'(body ...)
|
|
#'fail-sym)]
|
|
[(pat body ...)
|
|
(values #'pat
|
|
#'(body ...)
|
|
#f)]
|
|
[pat (match:syntax-err #'pat
|
|
"syntax error in clause")]))
|
|
|
|
;;!(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 exp car-patlist stx success-func)
|
|
(define-values (pat body fail-sym) (parse-clause (car car-patlist)))
|
|
(define (success fail let-bound)
|
|
(if (not success-func)
|
|
(lambda (sf bv)
|
|
;; mark this pattern as reached
|
|
(set-cdr! car-patlist #t)
|
|
(with-syntax ([fail-var fail-sym]
|
|
[(bound-vars ...) (map car bv)]
|
|
[(args ...) (map (lambda (b) (subst-bindings (cdr b) let-bound)) bv)]
|
|
[body body])
|
|
(if fail-sym
|
|
#`(let/ec fail-cont
|
|
(let ([fail-var (lambda () (fail-cont #,(fail sf bv)))]
|
|
[bound-vars args] ...)
|
|
. body))
|
|
#'(let ([bound-vars args] ...) . body))))
|
|
(lambda (sf bv)
|
|
;; mark this pattern as reached
|
|
(set-cdr! car-patlist #t)
|
|
(let ((bv (map
|
|
(lambda (bind)
|
|
(cons (car bind)
|
|
(subst-bindings
|
|
(cdr bind)
|
|
let-bound)))
|
|
bv)))
|
|
(success-func sf bv)))))
|
|
(define test-list (render-test-list pat exp (lambda (x) x) stx))
|
|
(cons test-list success))
|
|
|
|
;;!(function gen
|
|
;; (form (gen exp tsf patlist stx failure-func opt success-func)
|
|
;; ->
|
|
;; syntax)
|
|
;; (contract (syntax list list syntax
|
|
;; (() -> void) bool (list list -> syntax))
|
|
;; ->
|
|
;; syntax))
|
|
;; This function is primarily called by gen-help and takes the the
|
|
;; newly marked clauses and the failure-func which is really a
|
|
;; variable-name which will bound to the failure in the runtime
|
|
;; code. This function then This function
|
|
;; then takes these lists of partially compiled tests and reorders
|
|
;; them in an attempt to reduce the size of the final compiled
|
|
;; match expression. Binding counts are also updated to help
|
|
;; determind which supexpressions of the expression to be matched
|
|
;; need to be bound by let expressions. After all of this the
|
|
;; tests are "coupled" together for final compilation.
|
|
#;(define (gen exp tsf patlist stx failure-func opt success-func)
|
|
;; iterate through list and render each pattern to a list of tests
|
|
;; and success functions
|
|
(define rendered-list
|
|
(map (lambda (clause) (test-list-with-success-func
|
|
exp clause stx success-func))
|
|
patlist))
|
|
(update-counts rendered-list)
|
|
(tag-negate-tests rendered-list)
|
|
(update-binding-counts rendered-list)
|
|
((meta-couple (reorder-all-lists rendered-list)
|
|
(lambda (sf bv) failure-func)
|
|
'()
|
|
'())
|
|
'() '()))
|
|
|
|
;;!(function gen-match
|
|
;; (form (gen-match exp tsf patlist stx [success-func])
|
|
;; ->
|
|
;; compiled-pattern)
|
|
;; (contract (syntax-object list list syntax-object
|
|
;; (list list -> syntax-object))
|
|
;; ->
|
|
;; syntax-object))
|
|
;; <p>gen-match is the gateway through which match accesses the match
|
|
;; pattern compiler.
|
|
;;
|
|
;; <p>exp - the expression that is to be tested against the pattern.
|
|
;; This should normally be a piece of syntax that indirectly
|
|
;; 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])
|
|
(initer)
|
|
(when (stx-null? patlist)
|
|
(match:syntax-err stx "null clause list"))
|
|
(print-time "entering gen-match")
|
|
(let* (;; We set up the list of
|
|
;; clauses so that one can mark that they have been "reached".
|
|
[marked-clauses (mark-patlist patlist)]
|
|
[failure-func #'(match-failure)]
|
|
;; iterate through list and render each pattern to a list of partially compiled tests
|
|
;; and success functions.
|
|
;; These are partially compiled
|
|
;; because the test structures containa a function that needs to
|
|
;; be coupled with the other functions of the other test
|
|
;; structures before actual compilation results.
|
|
[rendered-list (map (lambda (clause) (test-list-with-success-func
|
|
exp clause stx success-func))
|
|
marked-clauses)]
|
|
[_ (begin
|
|
(print-time "finished render-list")
|
|
(update-counts rendered-list)
|
|
(tag-negate-tests rendered-list)
|
|
(update-binding-counts rendered-list))]
|
|
;; couple the partially compiled tests together into the final result.
|
|
[compiled-exp
|
|
(begin
|
|
(print-time "starting coupling")
|
|
((meta-couple (reorder-all-lists rendered-list)
|
|
(lambda (sf bv) failure-func)
|
|
'()
|
|
'())
|
|
'() '()))]
|
|
;; Also wrap the final compilation in syntax which binds the
|
|
;; match-failure function.
|
|
[compiled-match
|
|
#`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))])
|
|
#,compiled-exp)])
|
|
(print-time "finished coupling")
|
|
(unreachable marked-clauses stx)
|
|
(print-time "done")
|
|
compiled-match)))
|
|
) |