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

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

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/redex/private/term-fn.rkt
View File

@ -34,7 +34,7 @@
(make-struct-type 'term-fn #f 1 0)) (make-struct-type 'term-fn #f 1 0))
(define term-fn-get-id (make-struct-field-accessor term-fn-get 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) (define (transformer-predicate p? stx)
(and (identifier? stx) (and (identifier? stx)

11
collects/redex/private/term.rkt
View File

@ -44,7 +44,11 @@
stx stx
(syntax-e #'form))]) (syntax-e #'form))])
(if (syntax->datum #'lang-stx) (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 #,lang-nts))
#'(term/nts t #f)))])) #'(term/nts t #f)))]))
@ -390,10 +394,7 @@
(syntax (syntax
(datum-case rhs1 () (datum-case rhs1 ()
[new-x1 [new-x1
;; syntax local value on an id to check if it's bound correctly in (let-syntax ([orig-names (make-term-id #'new-names depths #'orig-names)] ...)
;; 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)] ...)
(term-let/error-name error-name ((x rhs) ...) body1 body2 ...))] (term-let/error-name error-name ((x rhs) ...) body1 body2 ...))]
[_ no-match]))))] [_ no-match]))))]
[(_ error-name () body1 body2 ...) [(_ error-name () body1 body2 ...)

17
collects/redex/tests/tl-test.rkt
View File

@ -661,6 +661,23 @@
(in-domain? (f y))) (in-domain? (f y)))
#f)) #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 ; Extension reinterprets the base meta-function's contract
; according to the new language. ; according to the new language.
(let () (let ()