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

move error reporting out of `define-syntax-rule' expansion

Browse Source
This commit is contained in:
Matthew Flatt 2011-07-09 06:32:41 -06:00
parent 5452a16479
commit 8decf99f34
1 changed files with 14 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/racket/private/misc.rkt
View File

@ -9,6 +9,19 @@
;; ------------------------------------------------------------------------- ;; -------------------------------------------------------------------------
(define-for-syntax (pattern-failure user-stx pattern)
(let*-values ([(sexpr) (syntax->datum user-stx)]
[(msg)
(if (pair? sexpr)
(format "use does not match pattern: ~.s"
(cons (car sexpr) pattern))
(if (symbol? sexpr)
(format "use does not match pattern: ~.s"
(cons sexpr pattern))
(error 'internal-error
"something bad happened")))])
(raise-syntax-error #f msg user-stx)))
(define-syntax define-syntax-rule (define-syntax define-syntax-rule
(lambda (stx) (lambda (stx)
(let-values ([(err) (lambda (what . xs) (let-values ([(err) (lambda (what . xs)
@ -22,18 +35,7 @@
(lambda (user-stx) (lambda (user-stx)
(syntax-case** dr #t user-stx () free-identifier=? (syntax-case** dr #t user-stx () free-identifier=?
[(_ . pattern) (syntax-protect (syntax/loc user-stx template))] [(_ . pattern) (syntax-protect (syntax/loc user-stx template))]
[_ (let*-values [_ (pattern-failure user-stx 'pattern)]))))]
([(sexpr) (syntax->datum user-stx)]
[(msg)
(if (pair? sexpr)
(format "use does not match pattern: ~.s"
(cons (car sexpr) 'pattern))
(if (symbol? sexpr)
(format "use does not match pattern: ~.s"
(cons sexpr 'pattern))
(error 'internal-error
"something bad happened")))])
(raise-syntax-error #f msg user-stx))]))))]
[(_ (name . ptrn) tmpl) (err "expected an identifier" #'name)] [(_ (name . ptrn) tmpl) (err "expected an identifier" #'name)]
[(_ (name . ptrn)) (err "missing template")] [(_ (name . ptrn)) (err "missing template")]
[(_ (name . ptrn) tmpl etc . _) (err "too many forms" #'etc)] [(_ (name . ptrn) tmpl etc . _) (err "too many forms" #'etc)]