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

Fixed pattern parsing so that the components of variable-except,

Browse Source 
variable-prefix, and cross patterns are treated as identifiers, not
arbitrary patterns.

svn: r18064
This commit is contained in:
Casey Klein 2010-02-12 16:34:38 +00:00
parent e99b1d028c
commit 02f88787ff
2 changed files with 34 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/redex/private/rewrite-side-conditions.ss
View File

@ -32,6 +32,9 @@
stx)) stx))
(define (expected-arguments name stx) (define (expected-arguments name stx)
(raise-syntax-error what (format "~a expected to have arguments" name) orig-stx stx)) (raise-syntax-error what (format "~a expected to have arguments" name) orig-stx stx))
(define ((expect-identifier src) stx)
(unless (identifier? stx)
(raise-syntax-error what "expected an identifier" src 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)
[(side-condition pre-pat (and)) [(side-condition pre-pat (and))
@ -56,9 +59,13 @@
src-loc)))))] src-loc)))))]
[(side-condition a ...) (expected-exact 'side-condition 2 term)] [(side-condition a ...) (expected-exact 'side-condition 2 term)]
[side-condition (expected-arguments 'side-condition term)] [side-condition (expected-arguments 'side-condition term)]
[(variable-except a ...) #`(variable-except #,@(map loop (syntax->list (syntax (a ...)))))] [(variable-except a ...)
(for-each (expect-identifier term) (syntax->list #'(a ...)))
term]
[variable-except (expected-arguments 'variable-except term)] [variable-except (expected-arguments 'variable-except term)]
[(variable-prefix a) #`(variable-prefix #,(loop (syntax a)))] [(variable-prefix a)
((expect-identifier term) #'a)
term]
[(variable-prefix a ...) (expected-exact 'variable-prefix 1 term)] [(variable-prefix a ...) (expected-exact 'variable-prefix 1 term)]
[variable-prefix (expected-arguments 'variable-prefix term)] [variable-prefix (expected-arguments 'variable-prefix term)]
[hole term] [hole term]
@ -71,7 +78,9 @@
[(hide-hole a) #`(hide-hole #,(loop #'a))] [(hide-hole a) #`(hide-hole #,(loop #'a))]
[(hide-hole a ...) (expected-exact 'hide-hole 1 term)] [(hide-hole a ...) (expected-exact 'hide-hole 1 term)]
[hide-hole (expected-arguments 'hide-hole term)] [hide-hole (expected-arguments 'hide-hole term)]
[(cross a) #`(cross #,(loop #'a))] [(cross a)
((expect-identifier term) #'a)
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)]
[_ [_

29
collects/redex/tests/tl-test.ss
View File

@ -225,6 +225,14 @@
(void))) (void)))
"extend-language: new language does not have the same non-terminal aliases as the old, non-terminal P was not in the same group as X in the old language") "extend-language: new language does not have the same non-terminal aliases as the old, non-terminal P was not in the same group as X in the old language")
;; underscores in literals
(let ()
(define-language L
(x (variable-except a_b))
(y (variable-prefix a_b)))
(test (pair? (redex-match L x (term a_c))) #t)
(test (pair? (redex-match L y (term a_bc))) #t))
;; test caching ;; test caching
(let () (let ()
(define match? #t) (define match? #t)
@ -266,13 +274,20 @@
(define-namespace-anchor here) (define-namespace-anchor here)
(define ns (namespace-anchor->namespace here)) (define ns (namespace-anchor->namespace here))
(let ([src 'bad-underscore]) (define-syntax (test-syntax-error stx)
(test (syntax-case stx ()
(parameterize ([current-namespace ns]) [(_ x)
(syntax-error-sources (with-syntax ([expected (syntax/loc stx (list src))])
'(define-language L (n m_1)) #`(let ([src (gensym)])
src)) (test
(list src))) (parameterize ([current-namespace ns])
(syntax-error-sources 'x src))
expected)))]))
(test-syntax-error (define-language L (n m_1)))
(test-syntax-error (define-language L (n (variable-except a 2 c))))
(test-syntax-error (define-language L (n (variable-prefix 7))))
(test-syntax-error (define-language L (n (cross 7))))
; ;
; ;