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

Disallows unquote in Redex patterns

Browse Source 
Fixes PR 11296
This commit is contained in:
Casey Klein 2011-04-01 10:55:19 -05:00
parent 121f1761bd
commit a4644d4d49
3 changed files with 15 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/redex/private/reduction-semantics.rkt
View File

@ -1783,7 +1783,7 @@
(define-syntax (define-language stx)
(syntax-case stx ()
[(_ lang-name . nt-defs)
[(form-name lang-name . nt-defs)
(begin
(unless (identifier? #'lang-name)
(raise-syntax-error #f "expected an identifier" stx #'lang-name))
@ -1798,19 +1798,19 @@
(case-lambda
[(stx)
(syntax-case stx (set!)
[(set! x e) (raise-syntax-error 'define-language "cannot set! identifier" stx #'e)]
[(set! x e) (raise-syntax-error (syntax-e #'form-name) "cannot set! identifier" stx #'e)]
[(x e (... ...)) #'(define-language-name e (... ...))]
[x
(identifier? #'x)
#'define-language-name])])
'(all-names ...))))
(define define-language-name (language lang-name (all-names ...) (names prods ...) ...)))))))]))
(define define-language-name (language form-name lang-name (all-names ...) (names prods ...) ...)))))))]))
(define-struct binds (source binds))
(define-syntax (language stx)
(syntax-case stx ()
[(_ lang-id (all-names ...) (name rhs ...) ...)
[(_ form-name lang-id (all-names ...) (name rhs ...) ...)
(prune-syntax
(let ()
(let ([all-names (syntax->list #'(all-names ...))])
@ -1819,7 +1819,7 @@
(map (lambda (rhs)
(rewrite-side-conditions/check-errs
(map syntax-e all-names)
'language
(syntax-e #'form-name)
#f
rhs))
(syntax->list rhss)))

4
collects/redex/private/rewrite-side-conditions.rkt
View File

@ -43,7 +43,7 @@
(extract-names all-nts what bind-names? orig-stx)
(let loop ([term orig-stx])
(syntax-case term (side-condition variable-except variable-prefix hole name in-hole hide-hole side-condition cross)
(syntax-case term (side-condition variable-except variable-prefix hole name in-hole hide-hole side-condition cross unquote)
[(side-condition pre-pat (and))
;; rewriting metafunctions (and possibly other things) that have no where, etc clauses
;; end up with side-conditions that are empty 'and' expressions, so we just toss them here.
@ -90,6 +90,8 @@
term]
[(cross a ...) (expected-exact 'cross 1 term)]
[cross (expected-arguments 'cross term)]
[(unquote . _)
(raise-syntax-error what "unquote disallowed in patterns" orig-stx term)]
[_
(identifier? term)
(match (regexp-match #rx"^([^_]*)_.*" (symbol->string (syntax-e term)))

8
collects/redex/tests/tl-test.rkt
View File

@ -99,7 +99,13 @@
(define-language x (e ....))
12)))
'("...."))
(test-syn-err
(let ()
(define-language L
(n ,3))
(void))
#rx"define-language:.*unquote disallowed" 1)
(let ()
; error message shows correct form name