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

Fixed source locations for term' and term-let' errors.

Browse Source 
svn: r16592
This commit is contained in:
Casey Klein 2009-11-07 02:07:16 +00:00
parent 29184f50ca
commit 2011272c06
2 changed files with 67 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,9 @@
(module term-test scheme
(require "term.ss"
"matcher.ss"
"test-util.ss")
"test-util.ss"
errortrace/errortrace-lib
errortrace/errortrace-key)
(reset-count)
(test (term 1) 1)
@ -99,5 +101,62 @@
(term-let ((((x ...) ...) '((1 2) (3 4 5) (6))))
(term ((f x ...) ...))))
'(3 12 6))
(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)
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)
src))
(let ([src 'term-let-rhs])
(test
(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)
(list src)))
(print-tests-passed 'term-test.ss))

14
collects/redex/private/term.ss
View File

@ -65,7 +65,8 @@
(and (identifier? (syntax x))
(term-id? (syntax-local-value (syntax x) (λ () #f))))
(let ([id (syntax-local-value/catch (syntax x) (λ (x) #t))])
(values (term-id-id id) (term-id-depth id)))]
(values (datum->syntax (term-id-id id) (syntax-e (term-id-id id)) (syntax x))
(term-id-depth id)))]
[(unquote x)
(values (syntax (unsyntax x)) 0)]
[(unquote . x)
@ -101,10 +102,7 @@
(i-loop (cdr xs))])
(values (cons fst rst)
(max fst-max-depth rst-max-depth))))]))])
(with-syntax ([x-rewrite x-rewrite])
(values (syntax/loc stx x-rewrite)
max-depth)))]
(values (datum->syntax stx x-rewrite stx) max-depth))]
[_ (values stx 0)]))
@ -180,13 +178,15 @@
(with-syntax ([(orig-names ...) orig-names]
[(new-names ...) new-names]
[(depths ...) depths]
[new-x1 new-x1])
[new-x1 new-x1]
[no-match (syntax/loc (syntax rhs1)
(error 'error-name "term ~s does not match pattern ~s" rhs1 'x1))])
(syntax
(syntax-case rhs1 ()
[new-x1
(let-syntax ([orig-names (make-term-id #'new-names (syntax-e #'depths))] ...)
(term-let/error-name error-name ((x rhs) ...) body1 body2 ...))]
[_ (error 'error-name "term ~s does not match pattern ~s" rhs1 'x1)]))))]
[_ no-match]))))]
[(_ error-name () body1 body2 ...)
(syntax
(begin body1 body2 ...))]