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

fix srcloc for metafunction errors

Browse Source
This commit is contained in:
Robby Findler 2014-04-30 21:56:27 -05:00
parent a628bf4040
commit b8d13706bf
2 changed files with 19 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
pkgs/redex-pkgs/redex-lib/redex/private/term.rkt
View File

@ -54,14 +54,14 @@
(loop (term-id-prev-id slv)) (loop (term-id-prev-id slv))
(values (language-id-nts ls 'term) (values (language-id-nts ls 'term)
(language-id-nt-identifiers ls 'term))))) (language-id-nt-identifiers ls 'term)))))
#`(term/nts t #,lang-nts #,lang-nt-ids)] (quasisyntax/loc stx (term/nts t #,lang-nts #,lang-nt-ids))]
[else [else
#'(term/nts t #f #f)]))])) (syntax/loc stx (term/nts t #f #f))]))]))
(define-syntax (term/nts stx) (define-syntax (term/nts stx)
(syntax-case stx () (syntax-case stx ()
[(_ arg nts nt-ids) [(_ arg nts nt-ids)
#'(#%expression (term/private arg nts nt-ids))])) (syntax/loc stx (#%expression (term/private arg nts nt-ids)))]))
(define-for-syntax current-id-stx-table (make-parameter #f)) (define-for-syntax current-id-stx-table (make-parameter #f))
@ -81,7 +81,7 @@
(define-syntax (mf-apply stx) (define-syntax (mf-apply stx)
(syntax-case stx () (syntax-case stx ()
[(_ mf) [(_ mf)
#'(λ (x) (mf x))])) (quasisyntax/loc stx (λ (x) #,(syntax/loc stx (mf x))))]))
(define-syntax (jf-apply stx) (define-syntax (jf-apply stx)
(syntax-case stx () (syntax-case stx ()
@ -125,13 +125,13 @@
(let-values ([(rewritten _) (rewrite/max-depth stx 0 #f)]) (let-values ([(rewritten _) (rewrite/max-depth stx 0 #f)])
rewritten)) rewritten))
(define (rewrite-application fn args depth) (define (rewrite-application fn args depth srcloc-stx)
(let-values ([(rewritten max-depth) (rewrite/max-depth args depth #t)]) (let-values ([(rewritten max-depth) (rewrite/max-depth args depth #t)])
(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 (if (judgment-form-id? #'fn) (let loop ([func (if (judgment-form-id? #'fn)
(syntax (jf-apply fn)) (syntax/loc srcloc-stx (jf-apply fn))
(syntax (mf-apply fn)))] (syntax/loc srcloc-stx (mf-apply fn)))]
[args-stx rewritten] [args-stx rewritten]
[res result-id] [res result-id]
[args-depth (min depth max-depth)]) [args-depth (min depth max-depth)])
@ -144,7 +144,7 @@
(cons (syntax [res (func (quasidatum args))]) (cons (syntax [res (func (quasidatum args))])
outer-bindings)) outer-bindings))
(values result-id (min depth max-depth))) (values result-id (min depth max-depth)))
(loop (syntax (mf-map func)) (loop (syntax (begin (mf-map func)))
(syntax/loc args-stx (args (... ...))) (syntax/loc args-stx (args (... ...)))
(syntax (res (... ...))) (syntax (res (... ...)))
(sub1 args-depth))))))))) (sub1 args-depth)))))))))
@ -161,7 +161,7 @@
(free-identifier-mapping-put! applied-metafunctions (free-identifier-mapping-put! applied-metafunctions
(datum->syntax f (syntax-e f) #'metafunc-name) (datum->syntax f (syntax-e f) #'metafunc-name)
#t) #t)
(rewrite-application f (syntax/loc stx (arg ...)) depth))] (rewrite-application f (syntax/loc stx (arg ...)) depth stx))]
[(jf-name arg ...) [(jf-name arg ...)
(and (identifier? (syntax jf-name)) (and (identifier? (syntax jf-name))
(if names (if names
@ -173,7 +173,7 @@
(raise-syntax-error 'term (raise-syntax-error 'term
"judgment forms with output mode (\"O\") positions disallowed" "judgment forms with output mode (\"O\") positions disallowed"
arg-stx stx)) arg-stx stx))
(rewrite-application #'jf-name (syntax/loc stx (arg ...)) depth))] (rewrite-application #'jf-name (syntax/loc stx (arg ...)) depth stx))]
[f [f
(and (identifier? (syntax f)) (and (identifier? (syntax f))
(if names (if names
@ -222,7 +222,7 @@
[(unquote-splicing . x) [(unquote-splicing . x)
(raise-syntax-error 'term "malformed unquote splicing" arg-stx stx)] (raise-syntax-error 'term "malformed unquote splicing" arg-stx stx)]
[(in-hole id body) [(in-hole id body)
(rewrite-application (syntax (λ (x) (apply plug x))) (syntax/loc stx (id body)) depth)] (rewrite-application (syntax (λ (x) (apply plug x))) (syntax/loc stx (id body)) depth stx)]
[(in-hole . x) [(in-hole . x)
(raise-syntax-error 'term "malformed in-hole" arg-stx stx)] (raise-syntax-error 'term "malformed in-hole" arg-stx stx)]
[hole (values (syntax (undatum the-hole)) 0)] [hole (values (syntax (undatum the-hole)) 0)]

8
pkgs/redex-pkgs/redex-test/redex/tests/err-loc-test.rkt
View File

@ -157,6 +157,14 @@
(exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd") (exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd")
(exec-runtime-error-tests "run-err-tests/judgment-form-ellipses.rktd")) (exec-runtime-error-tests "run-err-tests/judgment-form-ellipses.rktd"))
(parameterize ([current-namespace (make-base-namespace)])
(eval '(require redex/reduction-semantics))
(eval '(define-language L))
(eval '(define-metafunction L
∨ : boolean boolean -> boolean
[(∨ #f #f) #f]
[(∨ boolean boolean) #t]))
(exec-runtime-error-tests "run-err-tests/metafunction-no-match.rktd"))
(require redex/private/term (require redex/private/term
redex/private/lang-struct) redex/private/lang-struct)