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

Fixed a case where `term' raised an exception without a source location.

Browse Source 
svn: r17172
This commit is contained in:
Casey Klein 2009-12-03 03:51:41 +00:00
parent 2634eccdc7
commit bf64d93c64
2 changed files with 34 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -136,6 +136,35 @@
src) src)
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)
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)
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)
src))
(let ([src 'term-let-rhs]) (let ([src 'term-let-rhs])
(test (test
(runtime-error-source (runtime-error-source

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

@ -32,11 +32,11 @@
(let ([result-id (car (generate-temporaries '(f-results)))]) (let ([result-id (car (generate-temporaries '(f-results)))])
(with-syntax ([fn fn]) (with-syntax ([fn fn])
(let loop ([func (syntax (λ (x) (fn (syntax->datum x))))] (let loop ([func (syntax (λ (x) (fn (syntax->datum x))))]
[args rewritten] [args-stx rewritten]
[res result-id] [res result-id]
[args-depth (min depth max-depth)]) [args-depth (min depth max-depth)])
(with-syntax ([func func] (with-syntax ([func func]
[args args] [args args-stx]
[res res]) [res res])
(if (zero? args-depth) (if (zero? args-depth)
(begin (begin
@ -45,7 +45,7 @@
outer-bindings)) outer-bindings))
(values result-id (min depth max-depth))) (values result-id (min depth max-depth)))
(loop (syntax (λ (l) (map func (syntax->list l)))) (loop (syntax (λ (l) (map func (syntax->list l))))
(syntax (args (... ...))) (syntax/loc args-stx (args (... ...)))
(syntax (res (... ...))) (syntax (res (... ...)))
(sub1 args-depth))))))))) (sub1 args-depth)))))))))
@ -55,7 +55,7 @@
(and (identifier? (syntax metafunc-name)) (and (identifier? (syntax metafunc-name))
(term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f)))) (term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f))))
(rewrite-application (term-fn-get-id (syntax-local-value/catch (syntax metafunc-name) (λ (x) #t))) (rewrite-application (term-fn-get-id (syntax-local-value/catch (syntax metafunc-name) (λ (x) #t)))
(syntax (arg ...)) (syntax/loc stx (arg ...))
depth)] depth)]
[f [f
(and (identifier? (syntax f)) (and (identifier? (syntax f))
@ -76,7 +76,7 @@
[(unquote-splicing . x) [(unquote-splicing . x)
(raise-syntax-error 'term "malformed unquote splicing" orig-stx stx)] (raise-syntax-error 'term "malformed unquote splicing" orig-stx stx)]
[(in-hole id body) [(in-hole id body)
(rewrite-application (syntax (λ (x) (apply plug x))) (syntax (id body)) depth)] (rewrite-application (syntax (λ (x) (apply plug x))) (syntax/loc stx (id body)) depth)]
[(in-hole . x) [(in-hole . x)
(raise-syntax-error 'term "malformed in-hole" orig-stx stx)] (raise-syntax-error 'term "malformed in-hole" orig-stx stx)]
[hole (values (syntax (unsyntax the-hole)) 0)] [hole (values (syntax (unsyntax the-hole)) 0)]