From 8c5089c37faacb6f255a14299fe386a2abb9606e Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 3 Dec 2009 21:45:57 +0000 Subject: [PATCH] PR 10027 svn: r17179 --- collects/redex/private/matcher.ss | 6 -- .../redex/private/rewrite-side-conditions.ss | 16 ++- collects/redex/private/term-test.ss | 102 ++++++++---------- collects/redex/private/test-util.ss | 24 ++++- collects/redex/private/tl-test.ss | 9 ++ 5 files changed, 90 insertions(+), 67 deletions(-) diff --git a/collects/redex/private/matcher.ss b/collects/redex/private/matcher.ss index 96bd946974..6e9a2beff3 100644 --- a/collects/redex/private/matcher.ss +++ b/collects/redex/private/matcher.ss @@ -712,12 +712,6 @@ before the pattern compiler is invoked. [(has-underscore? pattern) (let*-values ([(binder before-underscore) (let ([before (split-underscore pattern)]) - (unless (or (hash-maps? clang-ht before) - (memq before underscore-allowed)) - (error 'compile-pattern "before underscore must be either a non-terminal ~a or a built-in pattern, found ~a in ~s" - before - (format "~s" (list* 'one 'of: (hash-map clang-ht (λ (x y) x)))) - pattern)) (values pattern before))] [(match-raw-name has-hole?) (compile-id-pattern before-underscore)]) diff --git a/collects/redex/private/rewrite-side-conditions.ss b/collects/redex/private/rewrite-side-conditions.ss index 4f853a95fe..e0db2ae638 100644 --- a/collects/redex/private/rewrite-side-conditions.ss +++ b/collects/redex/private/rewrite-side-conditions.ss @@ -1,4 +1,4 @@ -(module rewrite-side-conditions scheme/base +(module rewrite-side-conditions scheme (require (lib "list.ss") "underscore-allowed.ss") (require (for-template @@ -74,6 +74,20 @@ [(cross a) #`(cross #,(loop #'a))] [(cross a ...) (expected-exact 'cross 1 term)] [cross (expected-arguments 'cross term)] + [_ + (identifier? term) + (match (regexp-match #rx"^([^_]*)_.*" (symbol->string (syntax-e term))) + [(list _ (app string->symbol s)) + (if (or (memq s (cons '... underscore-allowed)) + (memq s all-nts)) + term + (raise-syntax-error + what + (format "before underscore must be either a non-terminal or a built-in pattern, found ~a in ~s" + s (syntax-e term)) + orig-stx + term))] + [_ term])] [(terms ...) (map loop (syntax->list (syntax (terms ...))))] [else diff --git a/collects/redex/private/term-test.ss b/collects/redex/private/term-test.ss index 6d271f4eaf..25059c7bbf 100644 --- a/collects/redex/private/term-test.ss +++ b/collects/redex/private/term-test.ss @@ -1,9 +1,7 @@ (module term-test scheme (require "term.ss" "matcher.ss" - "test-util.ss" - errortrace/errortrace-lib - errortrace/errortrace-key) + "test-util.ss") (reset-count) (test (term 1) 1) @@ -105,87 +103,75 @@ (define-namespace-anchor here) (define ns (namespace-anchor->namespace here)) - (define (runtime-error-source sexp src) - (let/ec return - (cadar - (continuation-mark-set->list - (exn-continuation-marks - (with-handlers ((exn:fail? values)) - (parameterize ([current-namespace ns]) - (parameterize ([current-compile (make-errortrace-compile-handler)]) - (eval (read-syntax src (open-input-string (format "~s" sexp)))))) - (return 'no-source))) - errortrace-key)))) - (let ([src 'term-template]) (test - (runtime-error-source - '(term-let ([(x ...) '(a b c)] - [((y ...) ...) '((1 2) (4 5 6) (7 8 9))]) - (term (((x y) ...) ...))) - src) + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let ([(x ...) '(a b c)] + [((y ...) ...) '((1 2) (4 5 6) (7 8 9))]) + (term (((x y) ...) ...))) + src)) src)) (let ([src 'term-template-metafunc]) (test - (runtime-error-source - '(term-let-fn ((f car)) - (term-let ([(x ...) '(a b c)] - [((y ...) ...) '((1 2) (4 5 6) (7 8 9))]) - (term ((((f x) y) ...) ...)))) - src) + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let-fn ((f car)) + (term-let ([(x ...) '(a b c)] + [((y ...) ...) '((1 2) (4 5 6) (7 8 9))]) + (term ((((f x) y) ...) ...)))) + src)) src)) (let ([src 'ellipsis-args]) (test - (runtime-error-source - '(term-let-fn ((f car)) - (term-let ([(x ...) '(a b)] - [(y ...) '(c d e)]) - (term (f ((x y) ...))))) - src) + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let-fn ((f car)) + (term-let ([(x ...) '(a b)] + [(y ...) '(c d e)]) + (term (f ((x y) ...))))) + src)) src)) (let ([src 'ellipsis-args/map]) (test - (runtime-error-source - '(term-let-fn ((f car)) - (term-let ([(x ...) '(a b)] - [(y ...) '(c d e)]) - (term ((f (x y)) ...)))) - src) + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let-fn ((f car)) + (term-let ([(x ...) '(a b)] + [(y ...) '(c d e)]) + (term ((f (x y)) ...)))) + src)) src)) (let ([src 'ellipsis-args/in-hole]) (test - (runtime-error-source - '(term-let ([(x ...) '(a b)] - [(y ...) '(c d e)]) - (term ((in-hole hole (x y)) ...))) - src) + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let ([(x ...) '(a b)] + [(y ...) '(c d e)]) + (term ((in-hole hole (x y)) ...))) + src)) src)) (let ([src 'term-let-rhs]) (test - (runtime-error-source - '(term-let ([(x ...) 'a]) - 3) - src) + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let ([(x ...) 'a]) + 3) + src)) src)) - (define (syntax-error-sources sexp src) - (let ([p (read-syntax src (open-input-string (format "~s" sexp)))]) - (with-handlers ((exn:srclocs? (λ (x) (map srcloc-source ((exn:srclocs-accessor x) x))))) - (parameterize ([current-namespace ns]) - (expand p)) - null))) - (let ([src 'term-template]) (test - (syntax-error-sources - '(term-let ([(x ...) '(a b c)]) - (term x)) - src) + (parameterize ([current-namespace ns]) + (syntax-error-sources + '(term-let ([(x ...) '(a b c)]) + (term x)) + src)) (list src))) (print-tests-passed 'term-test.ss)) diff --git a/collects/redex/private/test-util.ss b/collects/redex/private/test-util.ss index e973b69762..283a6596a0 100644 --- a/collects/redex/private/test-util.ss +++ b/collects/redex/private/test-util.ss @@ -1,10 +1,13 @@ #lang scheme -(require "matcher.ss") +(require "matcher.ss" + errortrace/errortrace-lib + errortrace/errortrace-key) (provide test test-syn-err tests reset-count syn-err-test-namespace print-tests-passed - equal/bindings?) + equal/bindings? + runtime-error-source syntax-error-sources) (define syn-err-test-namespace (make-base-namespace)) (parameterize ([current-namespace syn-err-test-namespace]) @@ -108,3 +111,20 @@ ;; rib-lt : rib rib -> boolean (define (rib-lt r1 r2) (string<=? (format "~s" (bind-name r1)) (format "~s" (bind-name r2)))) + +(define (runtime-error-source sexp src) + (let/ec return + (cadar + (continuation-mark-set->list + (exn-continuation-marks + (with-handlers ((exn:fail? values)) + (parameterize ([current-compile (make-errortrace-compile-handler)]) + (eval (read-syntax src (open-input-string (format "~s" sexp))))) + (return 'no-source))) + errortrace-key)))) + +(define (syntax-error-sources sexp src) + (let ([p (read-syntax src (open-input-string (format "~s" sexp)))]) + (with-handlers ((exn:srclocs? (λ (x) (map srcloc-source ((exn:srclocs-accessor x) x))))) + (expand p) + null))) \ No newline at end of file diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index e6c82aa862..d59d570d7c 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -261,7 +261,16 @@ (term (f 1))) (test rhs-eval-count 2)) + (define-namespace-anchor here) + (define ns (namespace-anchor->namespace here)) + (let ([src 'bad-underscore]) + (test + (parameterize ([current-namespace ns]) + (syntax-error-sources + '(define-language L (n m_1)) + src)) + (list src))) ; ;