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

PR 10027

Browse Source 
svn: r17179
This commit is contained in:
Casey Klein 2009-12-03 21:45:57 +00:00
parent c73b587e98
commit 8c5089c37f
5 changed files with 90 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/redex/private/matcher.ss
View File

@ -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)])

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

@ -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

102
collects/redex/private/term-test.ss
View File

@ -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))

24
collects/redex/private/test-util.ss
View File

@ -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)))

9
collects/redex/private/tl-test.ss
View File

@ -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)))
;
;