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

Factor out match expander code.

Browse Source 
Improve error message.

svn: r9068
This commit is contained in:
Sam Tobin-Hochstadt 2008-03-22 17:10:09 +00:00
parent 63df5e13f7
commit a37fe34a48
4 changed files with 38 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/scheme/match/define-forms.ss
View File

@ -36,14 +36,15 @@
(define-syntax (match-lambda** stx) (define-syntax (match-lambda** stx)
(syntax-case stx () (syntax-case stx ()
[(k [(pats ...) . rhs] ...) [(k [pats . rhs] ...)
(let* ([pss (syntax->list #'((pats ...) ...))] (let* ([pss (syntax->list #'(pats ...))]
[len (length (syntax->list (car pss)))]) [ps1 (car pss)]
[len (length (syntax->list ps1))])
(for/list ([ps pss]) (for/list ([ps pss])
(unless (= (length (syntax->list ps)) len) (unless (= (length (syntax->list ps)) len)
(raise-syntax-error 'match "unequal number of patterns in match clauses" stx ps))) (raise-syntax-error 'match "unequal number of patterns in match clauses" stx ps ps1)))
(with-syntax ([(vars ...) (generate-temporaries (car pss))]) (with-syntax ([(vars ...) (generate-temporaries (car pss))])
(syntax/loc stx (lambda (vars ...) (match* (vars ...) [(pats ...) . rhs] ...)))))])) (syntax/loc stx (lambda (vars ...) (match* (vars ...) [pats . rhs] ...)))))]))

24
collects/scheme/match/parse-helper.ss
View File

@ -8,12 +8,32 @@
"compiler.ss" "compiler.ss"
(only-in srfi/1 delete-duplicates)) (only-in srfi/1 delete-duplicates))
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err (provide ddk? parse-literal all-vars pattern-var? match:syntax-err match-expander-transform matchable?)
matchable?)
;; transform a match-expander application
;; parse/cert : stx certifier -> pattern
;; cert : certifier
;; expander : identifier
;; stx : the syntax of the match-expander application
;; accessor : match-expander -> syntax transformer/#f
;; error-msg : string
;; produces a parsed pattern
(define (match-expander-transform parse/cert cert expander stx accessor error-msg)
(let* ([expander (syntax-local-value (cert expander))]
[transformer (accessor expander)])
(unless transformer (raise-syntax-error #f error-msg #'expander))
(let* ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)]
[mstx (introducer (syntax-local-introduce stx))]
[mresult (transformer mstx)]
[result (syntax-local-introduce (introducer mresult))]
[cert* (lambda (id) (certifier (cert id) #f introducer))])
(parse/cert result cert*))))
(define (matchable? e) (define (matchable? e)
(or (string? e) (bytes? e))) (or (string? e) (bytes? e)))
;; raise an error, blaming stx ;; raise an error, blaming stx
(define (match:syntax-err stx msg) (define (match:syntax-err stx msg)
(raise-syntax-error #f msg stx)) (raise-syntax-error #f msg stx))

13
collects/scheme/match/parse-legacy.ss
View File

@ -22,17 +22,8 @@
;; for debugging ;; for debugging
(syntax-transforming?) (syntax-transforming?)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f)))) (match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(let* ([expander (syntax-local-value (cert #'expander))] (match-expander-transform parse/legacy/cert cert #'expander stx match-expander-legacy-xform
[transformer (match-expander-legacy-xform expander)]) "This expander only works with the standard match syntax")]
(unless transformer
(raise-syntax-error #f "This expander only works with the standard match syntax" #'expander))
(let* ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)]
[mstx (introducer (syntax-local-introduce stx))]
[mresult (transformer mstx)]
[result (syntax-local-introduce (introducer mresult))]
[cert* (lambda (id) (certifier (cert id) #f introducer))])
(parse/legacy/cert result cert*)))]
[(and p ...) [(and p ...)
(make-And (map parse (syntax->list #'(p ...))))] (make-And (map parse (syntax->list #'(p ...))))]
[(or p ...) [(or p ...)

13
collects/scheme/match/parse.ss
View File

@ -24,17 +24,8 @@
[(expander args ...) [(expander args ...)
(and (identifier? #'expander) (and (identifier? #'expander)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f)))) (match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(let* ([expander (syntax-local-value (cert #'expander))] (match-expander-transform parse/cert cert #'expander stx match-expander-match-xform
[transformer (match-expander-match-xform expander)]) "This expander only works with the legacy match syntax")]
(unless transformer
(raise-syntax-error #f "This expander only works with the legacy match syntax" #'expander))
(let* ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)]
[mstx (introducer (syntax-local-introduce stx))]
[mresult (transformer mstx)]
[result (syntax-local-introduce (introducer mresult))]
[cert* (lambda (id) (certifier (cert id) #f introducer))])
(parse/cert result cert*)))]
[(var v) [(var v)
(identifier? #'v) (identifier? #'v)
(make-Var #'v)] (make-Var #'v)]