- syntax-case now raises a syntax violation when _ appears in the
literals - syntax-rules points to the invalid literal when raising an exception.
This commit is contained in:
parent
5c21f9995e
commit
f8b0e949d9
|
@ -1 +1 @@
|
||||||
1470
|
1471
|
||||||
|
|
|
@ -1588,13 +1588,7 @@
|
||||||
((_ (lits ...)
|
((_ (lits ...)
|
||||||
(pat* tmp*) ...)
|
(pat* tmp*) ...)
|
||||||
(begin
|
(begin
|
||||||
(unless (for-all
|
(verify-literals lits e)
|
||||||
(lambda (x)
|
|
||||||
(and (id? x)
|
|
||||||
(not (free-id=? x (scheme-stx '...)))
|
|
||||||
(not (free-id=? x (scheme-stx '_)))))
|
|
||||||
lits)
|
|
||||||
(stx-error e "invalid literals"))
|
|
||||||
(bless `(lambda (x)
|
(bless `(lambda (x)
|
||||||
(syntax-case x ,lits
|
(syntax-case x ,lits
|
||||||
,@(map (lambda (pat tmp)
|
,@(map (lambda (pat tmp)
|
||||||
|
@ -2295,6 +2289,17 @@
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(and (id? x) (free-id=? x (scheme-stx '...)))))
|
(and (id? x) (free-id=? x (scheme-stx '...)))))
|
||||||
|
|
||||||
|
(define underscore?
|
||||||
|
(lambda (x)
|
||||||
|
(and (id? x) (free-id=? x (scheme-stx '_)))))
|
||||||
|
|
||||||
|
(define (verify-literals lits expr)
|
||||||
|
(for-each
|
||||||
|
(lambda (x)
|
||||||
|
(when (or (not (id? x)) (ellipsis? x) (underscore? x))
|
||||||
|
(syntax-violation #f "invalid literal" expr x)))
|
||||||
|
lits))
|
||||||
|
|
||||||
(define syntax-case-transformer
|
(define syntax-case-transformer
|
||||||
(let ()
|
(let ()
|
||||||
(define build-dispatch-call
|
(define build-dispatch-call
|
||||||
|
@ -2391,8 +2396,7 @@
|
||||||
(syntax-match e ()
|
(syntax-match e ()
|
||||||
((_ expr (keys ...) clauses ...)
|
((_ expr (keys ...) clauses ...)
|
||||||
(begin
|
(begin
|
||||||
(unless (for-all (lambda (x) (and (id? x) (not (ellipsis? x)))) keys)
|
(verify-literals keys e)
|
||||||
(stx-error e "invalid literals"))
|
|
||||||
(let ((x (gen-lexical 'tmp)))
|
(let ((x (gen-lexical 'tmp)))
|
||||||
(let ((body (gen-syntax-case x keys clauses r mr)))
|
(let ((body (gen-syntax-case x keys clauses r mr)))
|
||||||
(build-application no-source
|
(build-application no-source
|
||||||
|
|
Loading…
Reference in New Issue