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:
parent
8483a1493f
commit
4410ecceb2
|
@ -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)
|
||||
|
|
|
@ -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 ...)
|
||||
|
|
|
@ -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 ()
|
||||
|
|
Loading…
Reference in New Issue
Block a user