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)
(syntax-case stx ()
[(k [(pats ...) . rhs] ...)
(let* ([pss (syntax->list #'((pats ...) ...))]
[len (length (syntax->list (car pss)))])
[(k [pats . rhs] ...)
(let* ([pss (syntax->list #'(pats ...))]
[ps1 (car pss)]
[len (length (syntax->list ps1))])
(for/list ([ps pss])
(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))])
(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"
(only-in srfi/1 delete-duplicates))
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err
matchable?)
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err match-expander-transform 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)
(or (string? e) (bytes? e)))
;; raise an error, blaming stx
(define (match:syntax-err stx msg)
(raise-syntax-error #f msg stx))

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

@ -18,21 +18,12 @@
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(expander args ...)
(and (identifier? #'expander)
;; for debugging
(syntax-transforming?)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(let* ([expander (syntax-local-value (cert #'expander))]
[transformer (match-expander-legacy-xform expander)])
(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 (identifier? #'expander)
;; for debugging
(syntax-transforming?)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(match-expander-transform parse/legacy/cert cert #'expander stx match-expander-legacy-xform
"This expander only works with the standard match syntax")]
[(and p ...)
(make-And (map parse (syntax->list #'(p ...))))]
[(or p ...)

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

@ -22,19 +22,10 @@
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(expander args ...)
(and (identifier? #'expander)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(let* ([expander (syntax-local-value (cert #'expander))]
[transformer (match-expander-match-xform expander)])
(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*)))]
(and (identifier? #'expander)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(match-expander-transform parse/cert cert #'expander stx match-expander-match-xform
"This expander only works with the legacy match syntax")]
[(var v)
(identifier? #'v)
(make-Var #'v)]