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) (define-syntax (define-language stx)
(syntax-case stx () (syntax-case stx ()
[(_ lang-name . nt-defs) [(form-name lang-name . nt-defs)
(begin (begin
(unless (identifier? #'lang-name) (unless (identifier? #'lang-name)
(raise-syntax-error #f "expected an identifier" stx #'lang-name)) (raise-syntax-error #f "expected an identifier" stx #'lang-name))
@ -1798,19 +1798,19 @@
(case-lambda (case-lambda
[(stx) [(stx)
(syntax-case stx (set!) (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 e (... ...)) #'(define-language-name e (... ...))]
[x [x
(identifier? #'x) (identifier? #'x)
#'define-language-name])]) #'define-language-name])])
'(all-names ...)))) '(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-struct binds (source binds))
(define-syntax (language stx) (define-syntax (language stx)
(syntax-case stx () (syntax-case stx ()
[(_ lang-id (all-names ...) (name rhs ...) ...) [(_ form-name lang-id (all-names ...) (name rhs ...) ...)
(prune-syntax (prune-syntax
(let () (let ()
(let ([all-names (syntax->list #'(all-names ...))]) (let ([all-names (syntax->list #'(all-names ...))])
@ -1819,7 +1819,7 @@
(map (lambda (rhs) (map (lambda (rhs)
(rewrite-side-conditions/check-errs (rewrite-side-conditions/check-errs
(map syntax-e all-names) (map syntax-e all-names)
'language (syntax-e #'form-name)
#f #f
rhs)) rhs))
(syntax->list rhss))) (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) (extract-names all-nts what bind-names? orig-stx)
(let loop ([term 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)) [(side-condition pre-pat (and))
;; rewriting metafunctions (and possibly other things) that have no where, etc clauses ;; 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. ;; end up with side-conditions that are empty 'and' expressions, so we just toss them here.
@ -90,6 +90,8 @@
term] term]
[(cross a ...) (expected-exact 'cross 1 term)] [(cross a ...) (expected-exact 'cross 1 term)]
[cross (expected-arguments 'cross term)] [cross (expected-arguments 'cross term)]
[(unquote . _)
(raise-syntax-error what "unquote disallowed in patterns" orig-stx term)]
[_ [_
(identifier? term) (identifier? term)
(match (regexp-match #rx"^([^_]*)_.*" (symbol->string (syntax-e term))) (match (regexp-match #rx"^([^_]*)_.*" (symbol->string (syntax-e term)))

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

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