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

Use the form name from match*/derived to improve error messages.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2014-03-28 10:04:54 -04:00
parent 52c5d9fde6
commit 431ba2e88b
2 changed files with 9 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
racket/collects/racket/match/gen-match.rkt
View File

@ -26,6 +26,12 @@
(parameterize ([orig-stx stx]) (parameterize ([orig-stx stx])
(unless (syntax->list es) (unless (syntax->list es)
(raise-syntax-error 'match* "expected a sequence of expressions to match" es))) (raise-syntax-error 'match* "expected a sequence of expressions to match" es)))
(define/with-syntax form-name
(syntax-case stx ()
[(fname . _)
(identifier? #'fname)
(syntax-e #'fname)]
[_ 'match]))
(define len (length (syntax->list es))) (define len (length (syntax->list es)))
(define srcloc-list (list #`(quote #,(syntax-source stx)) (define srcloc-list (list #`(quote #,(syntax-source stx))
#`(quote #,(syntax-line stx)) #`(quote #,(syntax-line stx))
@ -36,7 +42,7 @@
(define/with-syntax (exprs ...) es) (define/with-syntax (exprs ...) es)
(define/with-syntax outer-fail (generate-temporary #'fail)) (define/with-syntax outer-fail (generate-temporary #'fail))
(define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...))) (define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...)))
(define/with-syntax raise-error (quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list))))) (define/with-syntax raise-error (quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)) 'form-name)))
(define parsed-clauses (define parsed-clauses
(for/list ([clause (syntax->list clauses)] (for/list ([clause (syntax->list clauses)]
[pats (syntax->list #'(pats ...))] [pats (syntax->list #'(pats ...))]

4
racket/collects/racket/match/runtime.rkt
View File

@ -18,8 +18,8 @@
#:property prop:exn:srclocs (lambda (ex) (exn:misc:match-srclocs ex))) #:property prop:exn:srclocs (lambda (ex) (exn:misc:match-srclocs ex)))
(define (match:error val srclocs) (define (match:error val srclocs form-name)
(raise (make-exn:misc:match (format "match: no matching clause for ~e" val) (raise (make-exn:misc:match (format "~a: no matching clause for ~e" form-name val)
(current-continuation-marks) (current-continuation-marks)
val val
srclocs))) srclocs)))