346 lines
16 KiB
Scheme
346 lines
16 KiB
Scheme
;; 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)))
|
|
|