Redex: fix term-let/#:lang keyword interaction

Account for the fact that define-language bindings may get
shadowed by term-let when using the same identifier as the language.
This commit is contained in:
Burke Fetscher 2013-04-04 20:38:08 -05:00
parent 8483a1493f
commit 4410ecceb2
3 changed files with 24 additions and 6 deletions

View File

@ -34,7 +34,7 @@
(make-struct-type 'term-fn #f 1 0))
(define term-fn-get-id (make-struct-field-accessor term-fn-get 0))
(define-struct term-id (id depth))
(define-struct term-id (id depth prev-id))
(define (transformer-predicate p? stx)
(and (identifier? stx)

View File

@ -44,7 +44,11 @@
stx
(syntax-e #'form))])
(if (syntax->datum #'lang-stx)
(let ([lang-nts (language-id-nts #'lang-stx 'term)])
(let ([lang-nts (let loop ([ls #'lang-stx])
(define slv (syntax-local-value ls))
(if (term-id? slv)
(loop (term-id-prev-id slv))
(language-id-nts ls 'term)))])
#`(term/nts t #,lang-nts))
#'(term/nts t #f)))]))
@ -390,10 +394,7 @@
(syntax
(datum-case rhs1 ()
[new-x1
;; syntax local value on an id to check if it's bound correctly in
;; a term
;; term (term #:lang L (x_1 y_2)) term -> optional argument with lang
(let-syntax ([orig-names (make-term-id #'new-names depths)] ...)
(let-syntax ([orig-names (make-term-id #'new-names depths #'orig-names)] ...)
(term-let/error-name error-name ((x rhs) ...) body1 body2 ...))]
[_ no-match]))))]
[(_ error-name () body1 body2 ...)

View File

@ -661,6 +661,23 @@
(in-domain? (f y)))
#f))
(let ()
(define-language foo)
(test (term-let ([bar 23])
(term 5 #:lang foo))
5)
(test (term-let ([foo 23])
(term 6 #:lang foo))
6)
(test (term-let ([foo 12])
(term-let ([foo 23])
(term 7 #:lang foo)))
7)
)
; Extension reinterprets the base meta-function's contract
; according to the new language.
(let ()