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

fix metafunction rewriting

Browse Source 
in the case that the bad use of the metafunction appears as the first
thing in a good metafunction application

closes PR 14618
This commit is contained in:
Robby Findler 2014-07-05 20:24:27 -05:00
parent 057aeaf0ed
commit a973556261
3 changed files with 20 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -123,11 +123,11 @@
(make-free-identifier-mapping))
(define (rewrite stx)
(let-values ([(rewritten _) (rewrite/max-depth stx 0 #f)])
(let-values ([(rewritten _) (rewrite/max-depth stx 0 #f #f)])
rewritten))
(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 #t)])
(let ([result-id (car (generate-temporaries '(f-results)))])
(with-syntax ([fn fn])
(let loop ([func (if (judgment-form-id? #'fn)
@ -150,10 +150,11 @@
(syntax (res (... ...)))
(sub1 args-depth)))))))))
(define (rewrite/max-depth stx depth ellipsis-allowed?)
(define (rewrite/max-depth stx depth ellipsis-allowed? continuing-an-application?)
(syntax-case stx (unquote unquote-splicing in-hole hole)
[(metafunc-name arg ...)
(and (identifier? (syntax metafunc-name))
(and (not continuing-an-application?)
(identifier? (syntax metafunc-name))
(if names
(not (memq (syntax->datum #'metafunc-name) names))
#t)
@ -164,7 +165,8 @@
#t)
(rewrite-application f (syntax/loc stx (arg ...)) depth stx))]
[(jf-name arg ...)
(and (identifier? (syntax jf-name))
(and (not continuing-an-application?)
(identifier? (syntax jf-name))
(if names
(not (memq (syntax->datum #'jf-name) names))
#t)
@ -237,7 +239,7 @@
(let-values ([(x-rewrite max-depth)
(let i-loop ([xs (syntax->list (syntax (x ...)))])
(cond
[(null? xs) (rewrite/max-depth #'y depth #t)]
[(null? xs) (rewrite/max-depth #'y depth #t #f)]
[else
(let ([new-depth (if (and (not (null? (cdr xs)))
(identifier? (cadr xs))
@ -246,7 +248,7 @@
(+ depth 1)
depth)])
(let-values ([(fst fst-max-depth)
(rewrite/max-depth (car xs) new-depth #t)]
(rewrite/max-depth (car xs) new-depth #t #f)]
[(rst rst-max-depth)
(i-loop (cdr xs))])
(values (cons fst rst)

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

@ -68,7 +68,7 @@
(map source-location (syntax->list #'(loc-piece ...)))
#'(let-syntax ([subst
(λ (stx)
(syntax-case stx ()
(syntax-case (syntax-local-introduce stx) ()
[(_ loc-name ... non-loc-name ...)
#'body]))])
(subst loc-piece ... non-loc-piece ...)

10
pkgs/redex-pkgs/redex-test/redex/tests/syn-err-tests/metafunction-definition.rktd
View File

@ -24,3 +24,13 @@
(define-metafunction syn-err-lang
[(func M_1 E_2)
(M_1 (E_2 not-non-term) M_1)]))
(#rx"metafunction must be in an application"
([z2 z])
(let ()
(define-metafunction syn-err-lang
[(i any) any])
(define-metafunction syn-err-lang
[(z any) (0)])
(let ()
(term (i z2 4)))))