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

Merged changes from branch:

Browse Source 
http://svn.plt-scheme.org/plt/branches/samth/match2
revisions 4220:4417
Included Matthew's version of regexp-error change, not Sam's.
Major changes:
 - simplification pass
 - define match-letrec in terms of match-define
 - show steps of match-expander in macro stepper
 - substantial refactoring of gen-match
 - removed unused times-used-neg field of test struct
 - added match:internal-error
 - general refactoring
 - bug fix in parsing of quasi-patterns

svn: r4418
This commit is contained in:
Sam Tobin-Hochstadt 2006-09-22 18:35:22 +00:00
commit 605c510b9e
10 changed files with 494 additions and 473 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,8 +1,9 @@
(module convert-pat mzscheme
(require "match-error.ss"
"match-helper.ss"
"match-expander-struct.ss")
"match-expander-struct.ss"
"observe-step.ss")
(require-for-template mzscheme
"match-error.ss")
@ -10,73 +11,61 @@
;; these functions convert the patterns from the old syntax
;; to the new syntax
(define (handle-clause stx)
(syntax-case stx ()
[(pat . rest) (quasisyntax/loc stx (#,(convert-pat #'pat) . rest))]))
(define (handle-clauses stx) (syntax-map handle-clause stx))
(define (convert-pats stx)
(with-syntax ([new-pats (syntax-map convert-pat stx)])
#'new-pats))
(define (imp-list? x stx)
(define (keyword? x)
(member (syntax-object->datum x)
'(
quote
quasiquote
?
=
and
or
not
$
set!
get!
;unquote
;unquote-splicing
)))
(let/ec out
(let loop ((x x))
(cond ((null? x) (out #f))
((or (not (pair? x))
(and (list? x)
(keyword? (car x))))
(list
(quasisyntax/loc stx #,x)))
(else (cons (car x) (loop (cdr x))))))))
(define (imp-list? stx)
(define datum (syntax-e stx))
(define (keyword? x)
(memq (syntax-object->datum x)
'(quote quasiquote ? = and or not $ set! get!)))
(let/ec out
(let loop ([x datum])
(cond [(null? x) (out #f)]
[(or (not (pair? x))
(and (list? x)
(keyword? (car x))))
(list
(quasisyntax/loc stx #,x))]
[else (cons (car x) (loop (cdr x)))]))))
(define (convert-quasi stx)
(syntax-case stx (unquote quasiquote unquote-splicing)
[,pat (quasisyntax/loc stx ,#,(convert-pat (syntax pat)))]
[,@pat (quasisyntax/loc stx ,@#,(convert-pat (syntax pat)))]
[(x . y)
(quasisyntax/loc
stx (#,(convert-quasi (syntax x)) . #,(convert-quasi (syntax y))))]
[pat
(vector? (syntax-e stx))
(quasisyntax/loc
stx
#,(list->vector (map convert-quasi
(vector->list (syntax-e stx)))))]
[pat
(box? (syntax-e stx))
(quasisyntax/loc
stx #,(box (convert-quasi (unbox (syntax-e stx)))))]
[pat stx]))
(define (convert-quasi stx)
(syntax-case stx (unquote quasiquote unquote-splicing)
[,pat #`,#,(convert-pat (syntax pat))]
[,@pat #`,@#,(convert-pat (syntax pat))]
((x . y)
(quasisyntax/loc
stx (#,(convert-quasi (syntax x)) . #,(convert-quasi (syntax y)))))
(pat
(vector? (syntax-e stx))
(quasisyntax/loc
stx
#,(list->vector (map convert-quasi
(vector->list (syntax-e stx))))))
(pat
(box? (syntax-e stx))
(quasisyntax/loc
stx #,(box (convert-quasi (unbox (syntax-e stx))))))
(pat stx)))
(define (convert-pat stx)
(convert-pat/cert stx (lambda (x) x)))
(define (convert-pat/cert stx cert)
(let ([convert-pat (lambda (x) (convert-pat/cert x cert))])
(syntax-case*
stx
(_ ? = and or not $ set! get! quasiquote
quote unquote unquote-splicing) stx-equal?
(_ ? = and or not $ set! get! quasiquote
quote unquote unquote-splicing) stx-equal?
[(expander . args)
(and (identifier? #'expander)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
@ -84,61 +73,59 @@
[xformer (match-expander-match-xform expander)])
(if (not xformer)
(match:syntax-err #'expander
"This expander only works with plt-match.")
(let ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)])
(convert-pat/cert
(introducer (xformer (introducer stx)))
(lambda (id)
(certifier (cert id) #f introducer))))))]
"This expander only works with plt-match.ss.")
(let* ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)]
[mstx (introducer stx)]
[mresult (xformer mstx)]
[result (introducer mresult)]
[cert* (lambda (id) (certifier (cert id) #f introducer))])
(observe-step stx mstx mresult result)
(convert-pat/cert result cert*))))]
[p
(dot-dot-k? (syntax-object->datum #'p))
stx]
[_ stx]
[() #'(list)]
['() #'(list)]
[() (syntax/loc stx (list))]
['() (syntax/loc stx (list))]
['item stx]
[p
(let ((old-pat (syntax-e #'p)))
(or (string? old-pat)
(boolean? old-pat)
(char? old-pat)
(number? old-pat)))
stx]
[(? pred) #`(? #,(cert #'pred))]
[p (constant-data? (syntax-e stx)) stx]
[(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))]
[(? pred . a)
(with-syntax ([pred (cert #'pred)]
[pats (syntax-map convert-pat #'a)])
#'(? pred . pats))]
[`pat #``#,(convert-quasi #'pat)]
[(= op pat) #`(app #,(cert #'op) #,(convert-pat #'pat))]
(syntax/loc stx (? pred . pats)))]
[`pat (quasisyntax/loc stx `#,(convert-quasi #'pat))]
[(= op pat) (quasisyntax/loc stx (app #,(cert #'op) #,(convert-pat #'pat)))]
[(and . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)])
#'(and . new-pats))]
(syntax/loc stx (and . new-pats)))]
[(or . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)])
#'(or . new-pats))]
[(not pat) #`(not #,(convert-pat #'pat))]
(syntax/loc stx (or . new-pats)))]
[(not . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)])
(syntax/loc stx (not . new-pats)))]
[($ struct-name . fields)
(with-syntax ([struct-name (cert #'struct-name)]
[new-fields (syntax-map convert-pat #'fields)])
#'(struct struct-name new-fields))]
(syntax/loc stx (struct struct-name new-fields)))]
[(get! id) (with-syntax ([id (cert #'id)])
#'(get! id))]
(syntax/loc stx (get! id)))]
[(set! id) (with-syntax ([id (cert #'id)])
#'(set! id))]
(syntax/loc stx (set! id)))]
[(quote p) stx]
[(car-pat . cdr-pat)
(let ([l (imp-list? (syntax-e stx) stx)])
(if l #`(list-rest #,@(map convert-pat l))
#`(list #,@(map convert-pat (syntax-e stx)))))]
[pt
[(car-pat . cdr-pat)
(let ([l (imp-list? stx)])
(if l (quasisyntax/loc stx (list-rest #,@(map convert-pat l)))
(quasisyntax/loc stx (list #,@(syntax-map convert-pat stx)))))]
[pt
(vector? (syntax-e stx))
(with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))])
#'(vector . new-pats))]
(syntax/loc stx (vector . new-pats)))]
[pt
(box? (syntax-e stx))
#`(box #,(convert-pat (unbox (syntax-e stx))))]
(quasisyntax/loc stx (box #,(convert-pat (unbox (syntax-e stx)))))]
[pt
(identifier? stx)
(cert stx)]

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

@ -10,19 +10,17 @@
"update-counts.scm"
"update-binding-counts.scm"
"render-test-list.scm"
"render-helpers.ss"
"reorder-tests.scm"
"tag-negate-tests.scm"
"simplify-patterns.ss"
"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))
;; mark-patlist : listof[x] -> listof[(cons x #f)]
;; 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
@ -53,29 +51,20 @@
[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)))))
;; test-list-with-success-func : syntax (cons syntax boolean) syntax success-func -> (cons test-list success-func)
;; This function takes an exp which is to be matched, a marked
;; clause, and a syntax-object that is fro reporting errors. It
;; clause, and a syntax-object that is for 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 (test-list-with-success-func exp pat/mark stx success-func)
(define-values (pat body fail-sym) (parse-clause (car pat/mark)))
(define (success fail let-bound)
(if (not success-func)
(lambda (sf bv)
;; mark this pattern as reached
(set-cdr! car-patlist #t)
(set-cdr! pat/mark #t)
(with-syntax ([fail-var fail-sym]
[(bound-vars ...) (map car bv)]
[(args ...) (map (lambda (b) (subst-bindings (cdr b) let-bound)) bv)]
@ -88,7 +77,7 @@
#'(let ([bound-vars args] ...) . body))))
(lambda (sf bv)
;; mark this pattern as reached
(set-cdr! car-patlist #t)
(set-cdr! pat/mark #t)
(let ((bv (map
(lambda (bind)
(cons (car bind)
@ -97,51 +86,14 @@
let-bound)))
bv)))
(success-func sf bv)))))
(define test-list (render-test-list pat exp (lambda (x) x) stx))
(define test-list
(let* ([cert (lambda (x) x)]
[simplified-pat (simplify pat cert)])
(render-test-list simplified-pat exp cert 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)
'()
'())
'() '()))
;; gen-match : syntax list list syntax success-func -> syntax
;;!(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.
;;
@ -156,7 +108,7 @@
;;
;; <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
;; (pat (=> fail) body ...)
;;
;; <p>stx is the original syntax of the match expression.
;; This is only used for error reporting.
@ -168,46 +120,38 @@
;; 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)
(define/opt (gen-match exp patlist stx [success-func #f])
(begin-with-definitions
(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
;; We set up the list of
;; clauses so that one can mark that they have been "reached".
(define marked-clauses (mark-patlist patlist))
(define 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.
(define 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)))
marked-clauses))
(update-counts rendered-list)
(tag-negate-tests rendered-list)
(update-binding-counts rendered-list)
;; couple the partially compiled tests together into the final result.
(define compiled-exp
((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.
(define compiled-match
#`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))])
#,compiled-exp))
(unreachable marked-clauses stx)
compiled-match))
)

3
collects/mzlib/private/match/match-error.ss
View File

@ -38,6 +38,9 @@
obj
detail)))
(define (match:internal-err obj msg . detail)
(apply raise-syntax-error '|internal match error| msg obj detail))
;;!(function unreachable

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

@ -1,28 +1,28 @@
(module match-internal-func mzscheme
(provide (all-defined))
(require-for-syntax "gen-match.ss"
"match-helper.ss"
"match-error.ss")
(require (lib "etc.ss")
(lib "list.ss")
"match-expander.ss"
"match-error.ss")
(define-syntax (match stx)
(syntax-case stx ()
[(_ exp . clauses)
(with-syntax ([body (gen-match #'x '() #'clauses stx)])
(with-syntax ([body (gen-match #'x #'clauses stx)])
#`(let ([x exp]) body))]))
(define-syntax (match-lambda stx)
(syntax-case stx ()
[(k . clauses)
#'(lambda (exp) (match exp . clauses))]))
(define-syntax (match-lambda* stx)
(syntax-case stx ()
[(k . clauses)
@ -65,57 +65,40 @@
((_ ([pat exp] rest ...) body ...)
(if (pattern-var? (syntax pat))
#'(let ([pat exp])
(match-let* (rest ...) body ...))
(match-let* (rest ...) body ...))
#'(match exp [pat (match-let* (rest ...) body ...)]))
)))
(define-syntax (match-letrec stx)
(syntax-case stx ()
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
[(_ ([pat exp] ...) . body)
(andmap pattern-var?
(syntax->list #'(pat ...)))
#'(letrec ([pat exp] ...) . body)]
[(_ ([pat exp] ...) . body)
(let* ((**match-bound-vars** '())
(compiled-match
(gen-match #'the-exp
'()
#'(((list pat ...) never-used))
stx
(lambda (sf bv)
(set! **match-bound-vars** bv)
#`(begin
#,@(map (lambda (x) #`(set! #,(car x) #,(cdr x)))
(reverse bv))
. body )))))
#`(letrec (#,@(map
(lambda (x) #`(#,(car x) #f))
(reverse **match-bound-vars**))
(the-exp (list exp ...)))
#,compiled-match))]))
(syntax-case stx ()
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
[(_ ([pat exp] ...) . body)
(andmap pattern-var?
(syntax->list #'(pat ...)))
#'(letrec ([pat exp] ...) . body)]
[(_ ([pat exp] ...) . body)
#'(let ()
(match-define (list pat ...) (list exp ...))
. body)]))
(define-syntax (match-define stx)
(syntax-case stx ()
[(_ pat exp)
(identifier? #'pat)
#'(define pat exp)]
[(_ pat exp)
(let* ((**match-bound-vars** '())
(compiled-match
(gen-match #'the-exp
'()
#'((pat never-used))
stx
(lambda (sf bv)
(set! **match-bound-vars** bv)
#`(begin
#,@(map (lambda (x)
#`(set! #,(car x) #,(cdr x)))
(reverse bv)))))))
#`(begin #,@(map
(lambda (x) #`(define #,(car x) #f))
(reverse **match-bound-vars**))
(let ((the-exp exp))
#,compiled-match)))]))
[(_ pat exp)
(identifier? #'pat)
#'(define pat exp)]
[(_ pat exp)
(let ([**match-bound-vars** '()])
(with-syntax ([compiled-match
(gen-match #'the-exp
#'((pat never-used))
stx
(lambda (sf bv)
(set! **match-bound-vars** bv)
(with-syntax ([((vars . vals) ...) (reverse bv)])
#'(begin (set! vars vals) ...))))]
[(vars ...) (map car (reverse **match-bound-vars**))])
#'(begin
(define vars #f) ...
(let ([the-exp exp])
compiled-match))))]))
)

43
collects/mzlib/private/match/observe-step.ss Normal file
View File

@ -0,0 +1,43 @@
(module observe-step mzscheme
(provide observe-step)
(define current-expand-observe
(dynamic-require '#%expobs 'current-expand-observe))
(define (observe-step pre mpre mpost post)
(define (call-obs ev . args)
(let ([obs (current-expand-observe)])
(if obs
(let ([evn (case ev
[(visit) 0]
[(enter-prim) 6]
[(prim-stop) 100]
[(exit-prim) 7]
[(return) 2]
[(macro-enter) 8]
[(macro-exit) 9]
[(macro-pre) 21]
[(macro-post) 22]
[(local-enter) 130]
[(local-exit) 131]
[(local-pre) 132]
[(local-post) 133])])
(apply obs evn args)))))
(call-obs 'local-enter pre)
(call-obs 'local-pre pre)
(call-obs 'visit pre)
(call-obs 'macro-enter pre)
(call-obs 'macro-pre mpre)
(call-obs 'macro-post mpost)
(call-obs 'macro-exit post)
(call-obs 'visit post)
(call-obs 'enter-prim post)
(call-obs 'prim-stop #f)
(call-obs 'exit-prim post)
(call-obs 'return post)
(call-obs 'local-post post)
(call-obs 'local-exit post)
)
)

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

@ -72,7 +72,7 @@
"unquote-splicing not followed by list")))]
[,@p
(if (and (stx-list? (syntax p))
(eq? (syntax-e (car (syntax->list #'p))) 'list))
(memq (syntax-e (car (syntax->list #'p))) '(list list-rest)))
(cdr (syntax->list (syntax p)))
(begin ; (write (syntax-e (syntax p)))
(q-error (syntax ,@p)

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

@ -139,6 +139,7 @@
;; then take the appropriate action. To understand this better take a
;; look at how proper and improper lists are handled.
(define/opt (render-test-list p ae cert [stx #'here])
(define ae-datum (syntax-object->datum ae))
(syntax-case*
p
(_ list quote quasiquote vector box ? app and or not struct set! var
@ -163,15 +164,9 @@
(certifier (cert id) #f introducer))
stx))))]
;; underscore is reserved to match nothing
;; underscore is reserved to match anything and bind nothing
(_ '()) ;(ks sf bv let-bound))
;; plain identifiers expand into (var) patterns
(pt
(and (pattern-var? (syntax pt))
(not (stx-dot-dot-k? (syntax pt))))
(render-test-list #'(var pt) ae cert stx))
;; for variable patterns, we do bindings, and check if we've seen this variable before
((var pt)
(identifier? (syntax pt))
@ -194,16 +189,14 @@
(ks sf (cons (cons (syntax pt) ae) bv))]))))))
;; Recognize the empty list
((list) (emit-null ae))
('() (emit-null ae))
((list) (emit-null ae))
;; This recognizes constants such strings
[pt
(constant-data? (syntax-e #'pt))
(list
(reg-test
`(equal? ,(syntax-object->datum ae)
`(equal? ,ae-datum
,(syntax-object->datum (syntax pt)))
ae (lambda (exp) #`(equal? #,exp pt))))]
@ -213,62 +206,31 @@
;; match a quoted datum
;; this is very similar to the previous pattern, except for the second argument to equal?
((quote item)
[(quote item)
(list
(reg-test
`(equal? ,(syntax-object->datum ae)
`(equal? ,ae-datum
,(syntax-object->datum p))
ae (lambda (exp) #`(equal? #,exp #,p)))))
(`quasi-pat
(render-test-list (parse-quasi #'quasi-pat) ae cert stx))
ae (lambda (exp) #`(equal? #,exp #,p))))]
;; check for predicate patterns
;; could we check to see if a predicate is a procedure here?
((? pred?)
[(? pred?)
(list (reg-test
`(,(syntax-object->datum #'pred?)
,(syntax-object->datum ae))
ae (lambda (exp) #`(#,(cert #'pred?) #,exp)))))
;; predicate patterns with binders are redundant with and patterns
[(? pred? pats ...)
(render-test-list #'(and (? pred?) pats ...) ae cert stx)]
;; syntax checking
((? anything ...)
(match:syntax-err
p
(if (zero? (length (syntax-e #'(anything ...))))
"a predicate pattern must have a predicate following the ?"
"syntax error in predicate pattern")))
((regexp reg-exp)
(regexp-matcher ae stx #'(? (lambda (x) (regexp-match reg-exp x))) cert))
((pregexp reg-exp)
(regexp-matcher ae stx #'(? (lambda (x) (pregexp-match-with-error reg-exp x))) cert))
((regexp reg-exp pat)
(regexp-matcher ae stx #'(app (lambda (x) (regexp-match reg-exp x)) pat) cert))
((pregexp reg-exp pat)
(regexp-matcher ae stx #'(app (lambda (x) (pregexp-match-with-error reg-exp x)) pat) cert))
,ae-datum)
ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))]
;; app patterns just apply their operation.
((app op pat)
(render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx))
;; syntax checking
((app . op)
(match:syntax-err
p
(if (zero? (length (syntax-e #'op)))
"an operation pattern must have a procedure following the app"
"there should be one pattern following the operator")))
[(and . pats) (map-append (lambda (pat) (render-test-list pat ae cert stx))
(syntax->list #'pats))]
((or . pats)
(list (make-act
'or-pat ;`(or-pat ,(syntax-object->datum ae))
'or-pat ;`(or-pat ,ae-datum)
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
@ -279,16 +241,13 @@
((not pat)
(list (make-act
'not-pat ;`(not-pat ,(syntax-object->datum ae))
'not-pat ;`(not-pat ,ae-datum)
ae
(lambda (ks kf let-bound)
(lambda (sf bv)
;; swap success and fail
(next-outer #'pat ae sf bv let-bound ks kf cert))))))
;; (cons a b) == (list-rest a b)
[(cons p1 p2) (render-test-list #'(list-rest p1 p2) ae cert stx)]
;; could try to catch syntax local value error and rethrow syntax error
((list-no-order pats ...)
(if (stx-null? (syntax (pats ...)))
@ -308,7 +267,7 @@
(list
(shape-test
`(list? ,(syntax-object->datum ae))
`(list? ,ae-datum)
ae (lambda (exp) #`(list? #,exp)))
(make-act
'list-no-order
@ -355,26 +314,18 @@
((hash-table pats ...)
;; must check the structure
(proper-hash-table-pattern? (syntax->list (syntax (pats ...))))
#;(proper-hash-table-pattern? (syntax->list (syntax (pats ...))))
(list
(shape-test
`(hash-table? ,(syntax-object->datum ae))
`(hash-table? ,ae-datum)
ae (lambda (exp) #`(hash-table? #,exp)))
(let ((mod-pat
(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 (pattern-var? (syntax id))
(not (stx-dot-dot-k? (syntax id))))
(syntax id))
(p (match:syntax-err
(syntax/loc stx p)
"poorly formed hash-table pattern"))))))
(syntax-case* pat (var) stx-equal?
[(var id) pat]
[(keypat valpat) (syntax/loc pat (list keypat valpat))]
[_ pat]))])
(make-act
'hash-table-pat
ae
@ -385,7 +336,7 @@
(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 ...)))))
#,(next-outer #`(list-no-order #,@(syntax-map mod-pat #'(pats ...)))
#`#,hash-name
sf
;; these tests have to be true
@ -400,11 +351,6 @@
ks
cert)))))))))
((hash-table . pats)
(match:syntax-err
p
"improperly formed hash table pattern"))
((struct struct-name (fields ...))
(identifier? (syntax struct-name))
(let*-values ([(field-pats) (syntax->list (syntax (fields ...)))]
@ -423,7 +369,7 @@
(shape-test
`(struct-pred ,(syntax-object->datum pred)
,(map syntax-object->datum parental-chain)
,(syntax-object->datum ae))
,ae-datum)
ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp)))
(map-append
(lambda (cur-pat cur-mutator cur-accessor)
@ -439,7 +385,7 @@
(#,cur-accessor #,ae)))]
[_ (render-test-list
cur-pat
(quasisyntax/loc stx (#,cur-accessor #,ae))
(quasisyntax/loc cur-pat (#,cur-accessor #,ae))
cert
stx)]))
field-pats mutators accessors))))
@ -471,7 +417,7 @@
(stx-dot-dot-k? (syntax dot-dot-k)))
(list
(shape-test
`(list? ,(syntax-object->datum ae))
`(list? ,ae-datum)
ae (lambda (exp) #`(list? #,exp)))
(make-act
'list-ddk-pat
@ -500,7 +446,7 @@
(stx-dot-dot-k? (syntax dot-dot-k)))
(list
(shape-test
`(pair? ,(syntax-object->datum ae))
`(pair? ,ae-datum)
ae (lambda (exp) #`(pair? #,exp)))
(make-act
'list-ddk-pat
@ -526,7 +472,7 @@
(stx-dot-dot-k? (syntax car-pat))))
(cons
(shape-test
`(pair? ,(syntax-object->datum ae))
`(pair? ,ae-datum)
ae (lambda (exp) #`(pair? #,exp)))
(append
(render-test-list (syntax car-pat)
@ -546,7 +492,7 @@
(stx-dot-dot-k? (syntax car-pat))))
(cons
(shape-test
`(pair? ,(syntax-object->datum ae))
`(pair? ,ae-datum)
ae (lambda (exp) #`(pair? #,exp)))
(append
(render-test-list (syntax car-pat)
@ -566,7 +512,7 @@
(stx-dot-dot-k? (syntax car-pat))))
(cons
(shape-test
`(pair? ,(syntax-object->datum ae))
`(pair? ,ae-datum)
ae (lambda (exp) #`(pair? #,exp)))
(append
(render-test-list (syntax car-pat)
@ -576,7 +522,7 @@
(if (stx-null? (syntax (cdr-pat ...)))
(list
(shape-test
`(null? (cdr ,(syntax-object->datum ae)))
`(null? (cdr ,ae-datum))
ae (lambda (exp) #`(null? #,exp)) #`(cdr #,ae)))
(render-test-list
(append-if-necc 'list (syntax (cdr-pat ...)))
@ -589,7 +535,7 @@
(ddk-only-at-end-of-list? (syntax-e (syntax (pats ...))))
(list
(shape-test
`(vector? ,(syntax-object->datum ae))
`(vector? ,ae-datum)
ae (lambda (exp) #`(vector? #,exp)))
(make-act
'vec-ddk-pat
@ -601,7 +547,7 @@
cert)))))
;; vector pattern with ooo or ook, but not at end
((vector pats ...)
[(vector pats ...)
(let* ((temp (syntax-e (syntax (pats ...))))
(len (length temp)))
(and (>= len 2)
@ -610,7 +556,7 @@
;;(stx-dot-dot-k? (vector-ref temp (sub1 len))))))
(list
(shape-test
`(vector? ,(syntax-object->datum ae))
`(vector? ,ae-datum)
ae (lambda (exp) #`(vector? #,exp)))
;; we have to look at the first pattern and see if a ddk follows it
;; if so handle that case else handle the pattern
@ -621,18 +567,18 @@
(handle-ddk-vector-inner ae kf ks
#'#(pats ...)
let-bound
cert)))))
cert))))]
;; plain old vector pattern
((vector pats ...)
(let* ((syntax-vec (list->vector (syntax->list (syntax (pats ...)))))
(vlen (vector-length syntax-vec)))
[(vector pats ...)
(let* ([syntax-vec (list->vector (syntax->list (syntax (pats ...))))]
[vlen (vector-length syntax-vec)])
(list*
(shape-test
`(vector? ,(syntax-object->datum ae)) ae
`(vector? ,ae-datum) ae
(lambda (exp) #`(vector? #,exp)))
(shape-test
`(equal? (vector-length ,(syntax-object->datum ae)) ,vlen)
`(equal? (vector-length ,ae-datum) ,vlen)
ae (lambda (exp) #`(equal? (vector-length #,exp) #,vlen)))
(let vloop ((n 0))
(if (= n vlen)
@ -643,21 +589,21 @@
#`(vector-ref #,ae #,n)
cert
stx)
(vloop (+ 1 n))))))))
(vloop (+ 1 n)))))))]
((box pat)
[(box pat)
(cons
(shape-test
`(box? ,(syntax-object->datum ae))
`(box? ,ae-datum)
ae (lambda (exp) #`(box? #,exp)))
(render-test-list
#'pat #`(unbox #,ae) cert stx)))
#'pat #`(unbox #,ae) cert stx))]
;; This pattern wasn't a valid form.
(got-too-far
[got-too-far
(match:syntax-err
#'got-too-far
"syntax error in pattern"))))
"syntax error in pattern")]))
;; end of render-test-list@
))

173
collects/mzlib/private/match/simplify-patterns.ss Normal file
View File

@ -0,0 +1,173 @@
(module simplify-patterns mzscheme
(require (lib "stx.ss" "syntax"))
(require (rename (lib "1.ss" "srfi") map-append append-map))
(require "match-error.ss"
"match-helper.ss"
"test-structure.scm"
"coupling-and-binding.scm"
"update-counts.scm"
"update-binding-counts.scm"
"reorder-tests.scm"
"match-expander-struct.ss"
"render-helpers.ss"
"observe-step.ss")
(require "render-sigs.ss"
(lib "unitsig.ss"))
(require-for-syntax "match-helper.ss"
"match-expander-struct.ss"
"test-no-order.ss")
(require-for-template mzscheme
"match-error.ss"
"test-no-order.ss"
"match-helper.ss")
(provide simplify)
;; simplifies patterns by removing syntactic sugar and expanding match-expanders
;; simplify : syntax certifier-> syntax
(define (simplify stx cert)
;; convert and check sub patterns for hash-table patterns
(define (convert-hash-table-pat pat)
(syntax-case pat ()
[(p1 p2) #`(#,(simplify/i #'p1) #,(simplify/i #'p2))]
[i (and (identifier? #'i) (not (stx-dot-dot-k? #'i))) #'(var i)]
[_ (match:syntax-err pat "hash table subpattern must contain either two patterns or an identifier")]))
;; simple one-arg version, just passes the cert along
(define (simplify/i stx) (simplify stx cert))
(syntax-case*
stx
(_ list quote quasiquote vector box ? app and or not struct set! var
list-rest get! ... ___ unquote unquote-splicing cons
list-no-order hash-table regexp pregexp cons) stx-equal?
;; expand match-expanders
;; this doesn't work because we need to keep the certifier around
[(expander args ...)
(and (identifier? #'expander)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(let* ([expander (syntax-local-value (cert #'expander))]
[transformer (match-expander-plt-match-xform expander)])
(unless transformer
(match:syntax-err #'expander
"This expander only works with the match.ss library."))
(let* ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)]
[mstx (introducer stx)]
[mresult (transformer mstx)]
[result (introducer mresult)]
[cert* (lambda (id) (certifier (cert id) #f introducer))])
(observe-step stx mstx mresult result)
(simplify result cert*)))]
;; label variable patterns
[id
(and (pattern-var? #'id) (not (stx-dot-dot-k? #'id)))
#'(var id)]
;; match the empty list
['() (syntax/loc stx (list))]
;; other quoted data is untransformed
[(quote data) stx]
;; transform quasi-patterns into regular patterns
[`quasi-pat (simplify/i (parse-quasi #'quasi-pat))]
;; predicate patterns with binders are redundant with and patterns
[(? pred pat . pats) (simplify/i (syntax/loc stx (and (? pred) pat . pats)))]
[(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))]
[(? . anything)
(match:syntax-err
stx
(if (null? (syntax-e #'anything))
"a predicate pattern must have a predicate following the ?"
"syntax error in predicate pattern"))]
;; regexp patterns - FIXME: abstract here
[(regexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (regexp-match re x))))))]
[(pregexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (pregexp-match-with-error re x))))))]
[(regexp re pat) (simplify/i (syntax/loc stx (and (? string?) (app (lambda (x) (regexp-match re x)) pat))))]
[(pregexp re pat) (simplify/i (syntax/loc stx (and (? string?) (app (lambda (x) (pregexp-match-with-error re x)) pat))))]
[(regexp . re) (match:syntax-err stx "regexp pattern must have one or two subpatterns")]
[(pregexp . re) (match:syntax-err stx "pregexp pattern must have one or two subpatterns")]
;; cons is just list-rest with 2 arguments
[(cons p1 p2) (simplify/i (syntax/loc stx (list-rest p1 p2)))]
[(cons . rest) (match:syntax-err stx "cons pattern must have exactly two subpatterns")]
;; aggregates
[(kw pats ...)
(memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not))
(with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))])
(syntax/loc stx (kw pats* ...)))]
[(kw pats ... . rest)
(match:syntax-err stx (format "~a pattern must have a proper list of subpatterns" (syntax-e #'kw)))]
;; hash table patterns have their own syntax
[(hash-table pats ... ooo)
(stx-dot-dot-k? #'ooo)
(with-syntax
([(pats* ...) (syntax-map convert-hash-table-pat #'(pats ...))])
(syntax/loc stx (hash-table pats* ... ooo)))]
[(hash-table pats ...)
(with-syntax
([(pats* ...) (syntax-map convert-hash-table-pat #'(pats ...))])
(syntax/loc stx (hash-table pats* ...)))]
[(hash-table . rest) (match:syntax-err stx "syntax error in hash table pattern")]
;; struct patterns
[(struct st (pats ...)) (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))]
[st* (cert #'st)])
(syntax/loc stx (struct st* (pats* ...))))]
[(struct . rest)
(match:syntax-err
stx
(if (null? (syntax-e #'rest))
(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"))]
[(box pat) (quasisyntax/loc stx (box #,(simplify/i #'pat)))]
[(box . rest) (match:syntax-err stx "syntax error in box pattern")]
[(app e pat) (quasisyntax/loc stx (app #,(cert #'e) #,(simplify/i #'pat)))]
[(app . rest) (match:syntax-err stx "syntax error in app pattern")]
[(set! id)
(identifier? #'id)
stx]
[(set! . rest) (match:syntax-err stx "set! pattern must have one identifier")]
[(get! id)
(identifier? #'id)
stx]
[(get! . rest) (match:syntax-err stx "get! pattern must have one identifier")]
[(var id)
(identifier? #'id)
stx]
[(var . rest)
(match:syntax-err stx "var pattern must have one identifier")]
[__ stx])
)
)

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

@ -31,7 +31,6 @@
;; 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
;; times-used-neg - ??? (this appears to never be used)
;; used-set-neg - ???
;; closest-shape-tst - ???
;; equal-set - ???
@ -43,7 +42,6 @@
bind-exp-stx
bind-exp
bind-count
times-used-neg
used-set-neg
closest-shape-tst
equal-set)
@ -65,7 +63,7 @@
;; 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 '()))
(make-test test comp #t 0 '() exp (syntax-object->datum exp) 1 '() #f '()))
;;!(function make-reg-test
;; (form (make-shape-test test exp comp) -> test-struct)
@ -81,7 +79,7 @@
;; 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 '()))
(make-test test comp #f 0 '() exp (syntax-object->datum exp) 1 '() #f '()))
;;!(function make-act-test
;; (form (make-shape-test test exp comp) -> test-struct)
@ -99,7 +97,7 @@
;; 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 '()))
(make-test act-name comp #f -1 '() exp (syntax-object->datum exp) 1 '() #f '()))
;;!(function action-test?
;; (form (action-test? test) -> bool)

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

@ -6,6 +6,7 @@
(require "test-structure.scm"
"match-helper.ss"
(lib "etc.ss")
(lib "list.ss"))
;;!(function test-filter
@ -17,14 +18,6 @@
(define (test-filter tlist)
(filter (lambda (t) (not (= -1 (test-times-used t)))) tlist))
#;(define 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
@ -33,30 +26,26 @@
;; 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.
(define inverse-in
(lambda (test test-list)
(or (pos-inverse-in test test-list)
(neg-inverse-in test test-list))))
(define (inverse-in test test-list)
(or (pos-inverse-in test test-list)
(neg-inverse-in test test-list)))
(define 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)
)))
(define (pos-inverse-in test test-list)
(let ([test-with-implied (cons test (implied test))])
(ormap (lambda (t) (in t test-with-implied))
test-list)))
(define 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)
)))
(define (neg-inverse-in test test-list)
(let ([test-with-implied (cons test (implied test))])
(ormap (lambda (t) (in `(not ,t) test-with-implied))
test-list)))
(define logical-member
(lambda (item lst)
(ormap (lambda (cur)
(logical-equal? item cur))
lst)))
(define (logical-member item lst)
(ormap (lambda (cur)
(logical-equal? item cur))
lst))
(define (logical-equal? a b)
(or (equal? a b)
@ -72,132 +61,87 @@
(eq? (car a) 'list?)
(eq? (car b) 'null?)
(equal? (cadr a) (cadr b)))))
;; this implements the above code
#;(define logical-equal?
(lambda x
(if (pair? x)
(let ((exp8163 (cdr x)))
(if (and (pair? exp8163) (null? (cdr exp8163)))
(if (equal? (car exp8163) (car x))
#t
(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))))
(define truncate-list
(lambda (pos used-set-neg)
(cond ((null? used-set-neg)
'())
((>= pos (car used-set-neg))
(list pos))
(else
(cons (car used-set-neg)
(truncate-list pos (cdr used-set-neg)))))))
(define truncate-list-neg
(lambda (pos used-set-neg)
(cond ((null? used-set-neg)
'())
((>= pos (car used-set-neg))
'())
(else
(cons (car used-set-neg)
(truncate-list-neg pos (cdr used-set-neg)))))))
;; truncate-list : int listof[int] -> listof[int]
;; truncate-list-neg : int listof[int] -> listof[int]
;; truncate-list removes all elements of a list after the element at least as large as p
;; truncate-list-neg removes the found element as well
(define-values (truncate-list truncate-list-neg)
(let ([mk (lambda (pos-f)
(define (f p l)
(cond [(null? l)
'()]
[(>= p (car l))
(pos-f p)]
[else
(cons (car l)
(f p (cdr l)))]))
f)])
(values (mk list) (mk (lambda (x) '())))))
;;!(function update-count
;; (form (update-count test tests-rest pos) -> void)
;; (contract (test-struct list integer) -> void))
;; update-count : test listof[test] int -> 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.
(define update-count
(lambda (test tests-rest pos mem-table)
(let loop ((l tests-rest)
(p (add1 pos)))
(define (update-count 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 ()
(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))
(when (logical-member (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)))
)
(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))
))))
(loop (cdr l) (add1 p))))])
(when (and (list? entry-pair) (not (null? entry-pair)))
(let ((trun-used (truncate-list pos (car entry-pair))))
(let ([trun-used (truncate-list 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-list-neg pos (cadr entry-pair)))))
)))))
(set-test-used-set-neg! test (truncate-list-neg pos (cadr entry-pair)))))))))
;;!(function update-counts
;; (form (update-counts render-list) -> void)
;; (contract list -> void))
;; update-counts : listof[(cons test any)] -> void
;; This function essentially calls update-count on every test in
;; all of the test lists.
(define 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
(define (update-counts render-list)
(let* ([mem-table (make-hash-table 'equal)]
[test-master-list (map (compose test-filter 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))
(lambda (tl) (map test-tst (test-filter tl)))
test-master-list)])
(let loop ([tml test-master-list]
[tsf test-so-far-lists]
[pos 1])
(if (null? tml)
'()
(void)
(begin
(for-each (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))))))))
(for-each
(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)))))))
)