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

Add new simplification pass before render-test-list.

Browse Source 
Simplification expands match expanders and removes syntactic sugar.

Also, syntax errors are checked in the simplification phase, so better
error messages can be given.
This commit is contained in:
Sam Tobin-Hochstadt 2006-09-07 12:02:41 -04:00
parent 6034e5e0d5
commit 506c154ea8
3 changed files with 65 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -13,6 +13,7 @@
"render-helpers.ss" "render-helpers.ss"
"reorder-tests.scm" "reorder-tests.scm"
"tag-negate-tests.scm" "tag-negate-tests.scm"
"simplify-patterns.ss"
"convert-pat.ss") "convert-pat.ss")
(require-for-template mzscheme (require-for-template mzscheme
@ -85,7 +86,10 @@
let-bound))) let-bound)))
bv))) bv)))
(success-func sf 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)) (cons test-list success))
;; gen-match : syntax list list syntax success-func -> syntax ;; gen-match : syntax list list syntax success-func -> syntax

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

@ -220,34 +220,10 @@
,(syntax-object->datum ae)) ,(syntax-object->datum ae))
ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))) ae (lambda (exp) #`(#,(cert #'pred?) #,exp)))))
;; 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))
;; app patterns just apply their operation. ;; app patterns just apply their operation.
((app op pat) ((app op pat)
(render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx)) (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)) [(and . pats) (map-append (lambda (pat) (render-test-list pat ae cert stx))
(syntax->list #'pats))] (syntax->list #'pats))]
@ -271,9 +247,6 @@
;; swap success and fail ;; swap success and fail
(next-outer #'pat ae sf bv let-bound ks kf cert)))))) (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 ;; could try to catch syntax local value error and rethrow syntax error
((list-no-order pats ...) ((list-no-order pats ...)
(if (stx-null? (syntax (pats ...))) (if (stx-null? (syntax (pats ...)))
@ -340,26 +313,18 @@
((hash-table pats ...) ((hash-table pats ...)
;; must check the structure ;; must check the structure
(proper-hash-table-pattern? (syntax->list (syntax (pats ...)))) #;(proper-hash-table-pattern? (syntax->list (syntax (pats ...))))
(list (list
(shape-test (shape-test
`(hash-table? ,(syntax-object->datum ae)) `(hash-table? ,(syntax-object->datum ae))
ae (lambda (exp) #`(hash-table? #,exp))) ae (lambda (exp) #`(hash-table? #,exp)))
(let ((mod-pat (let ([mod-pat
(lambda (pat) (lambda (pat)
(syntax-case pat () (syntax-case* pat (var) stx-equal?
((key value) (syntax (list key value))) [(var id) pat]
(ddk [(keypat valpat) (syntax/loc pat (list keypat valpat))]
(stx-dot-dot-k? (syntax ddk)) [_ pat]))])
(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"))))))
(make-act (make-act
'hash-table-pat 'hash-table-pat
ae ae
@ -370,7 +335,7 @@
(hash-table-map #,(subst-bindings ae (hash-table-map #,(subst-bindings ae
let-bound) let-bound)
(lambda (k v) (list k v))))) (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 #`#,hash-name
sf sf
;; these tests have to be true ;; these tests have to be true
@ -385,11 +350,6 @@
ks ks
cert))))))))) cert)))))))))
((hash-table . pats)
(match:syntax-err
p
"improperly formed hash table pattern"))
((struct struct-name (fields ...)) ((struct struct-name (fields ...))
(identifier? (syntax struct-name)) (identifier? (syntax struct-name))
(let*-values ([(field-pats) (syntax->list (syntax (fields ...)))] (let*-values ([(field-pats) (syntax->list (syntax (fields ...)))]

76
collects/mzlib/private/match/simplify-patterns.ss
View File

@ -27,10 +27,21 @@
(provide simplify) (provide simplify)
;; simplifies patterns by removing syntactic sugar and expanding match-expanders ;; simplifies patterns by removing syntactic sugar and expanding match-expanders
;; simplify : syntax certifier-> syntax ;; simplify : syntax certifier-> syntax
(define (simplify stx cert) (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)) (define (simplify/i stx) (simplify stx cert))
(syntax-case* (syntax-case*
stx stx
(_ list quote quasiquote vector box ? app and or not struct set! var (_ list quote quasiquote vector box ? app and or not struct set! var
@ -65,54 +76,69 @@
[(quote data) stx] [(quote data) stx]
;; transform quasi-patterns into regular patterns ;; transform quasi-patterns into regular patterns
[`quasi-pat (simplify (parse-quasi #'quasi-pat))] [`quasi-pat (simplify/i (parse-quasi #'quasi-pat))]
;; predicate patterns with binders are redundant with and patterns ;; predicate patterns with binders are redundant with and patterns
[(? pred pat . pats) (simplify/i (syntax/loc stx (and (? pred) pat . pats)))] [(? pred pat . pats) (simplify/i (syntax/loc stx (and (? pred) pat . pats)))]
[(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))] [(? 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 patterns - FIXME: abstract here
[(regexp re) (simplify (syntax/loc stx (and (? string?) (? (lambda (x) (regexp-match re x))))))] [(regexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (regexp-match re x))))))]
[(pregexp re) (simplify (syntax/loc stx (and (? string?) (? (lambda (x) (pregexp-match-with-error re x))))))] [(pregexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (pregexp-match-with-error re x))))))]
[(regexp re pat) (simplify (syntax/loc stx (and (? string?) (app (lambda (x) (regexp-match re x)) pat))))] [(regexp re pat) (simplify/i (syntax/loc stx (and (? string?) (app (lambda (x) (regexp-match re x)) pat))))]
[(pregexp re pat) (simplify (syntax/loc stx (and (? string?) (app (lambda (x) (pregexp-match-with-error 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")] [(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")] [(pregexp . re) (match:syntax-err stx "pregexp pattern must have one or two subpatterns")]
;; cons is just list-rest with 2 arguments ;; cons is just list-rest with 2 arguments
[(cons p1 p2) (simplify (syntax/loc stx (list-rest p1 p2)))] [(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")] [(cons . rest) (match:syntax-err stx "cons pattern must have exactly two subpatterns")]
;; aggregates ;; aggregates
[(kw pats ...) [(kw pats ...)
(memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not)) (memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not))
(quasisyntax/loc stx (kw #,@(syntax-map simplify #'(pats ...))))] (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))])
(syntax/loc stx (kw pats* ...)))]
[(kw pats ... . rest) [(kw pats ... . rest)
(match:syntax-err stx (format "~a pattern must have a proper list of subpatterns" (syntax-e #'kw)))] (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 patterns have their own syntax
[(hash-table (pat1 pat2) ...) [(hash-table pats ... ooo)
(with-syntax ([(pat1* ...) (syntax-map simplify #'(pat1 ...))]
[(pat2* ...) (syntax-map simplify #'(pat2 ...))])
(syntax/loc stx (hash-table (pat1* pat2*) ...)))]
[(hash-table (pat1 pat2) ... ooo)
(stx-dot-dot-k? #'ooo) (stx-dot-dot-k? #'ooo)
(with-syntax ([(pat1* ...) (syntax-map simplify #'(pat1 ...))] (with-syntax
[(pat2* ...) (syntax-map simplify #'(pat2 ...))]) ([(pats* ...) (syntax-map convert-hash-table-pat #'(pats ...))])
(syntax/loc stx (hash-table (pat1* pat2*) ... ooo)))] (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")] [(hash-table . rest) (match:syntax-err stx "syntax error in hash table pattern")]
;; struct patterns ;; struct patterns
[(struct st (pats ...)) (with-syntax ([(pats* ...) (syntax-map simplify #'(pats ...))] [(struct st (pats ...)) (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))]
[st* (cert #'st)]) [st* (cert #'st)])
(syntax/loc stx (struct st* (pats* ...))))] (syntax/loc stx (struct st* (pats* ...))))]
[(struct . rest) (match:syntax-err stx "syntax error in struct pattern")] [(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 #'pat)))] [(box pat) (quasisyntax/loc stx (box #,(simplify/i #'pat)))]
[(box . rest) (match:syntax-err stx "syntax error in box pattern")] [(box . rest) (match:syntax-err stx "syntax error in box pattern")]
[(app e pat) (quasisyntax/loc stx (app #,(cert #'e) #,(simplify #'pat)))] [(app e pat) (quasisyntax/loc stx (app #,(cert #'e) #,(simplify/i #'pat)))]
[(app . rest) (match:syntax-err stx "syntax error in app pattern")] [(app . rest) (match:syntax-err stx "syntax error in app pattern")]
[(set! id) [(set! id)
@ -125,9 +151,13 @@
stx] stx]
[(get! . rest) (match:syntax-err stx "get! pattern must have one identifier")] [(get! . rest) (match:syntax-err stx "get! pattern must have one identifier")]
[(var . rest) (match:internal-err stx "var pattern found before simplification!")] [(var id)
(identifier? #'id)
stx]
[(var . rest)
(match:syntax-err stx "var pattern must have one identifier")]
[_ stx]) [__ stx])
) )