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

redex: keep syntax info for nt aliases

Browse Source
This commit is contained in:
Burke Fetscher 2014-10-29 16:19:21 -05:00
parent 8ffa22dab6
commit cd00bc0595
2 changed files with 15 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
pkgs/redex-pkgs/redex-lib/redex/private/reduction-semantics.rkt
View File

@ -1865,12 +1865,8 @@
(define non-terms (parse-non-terminals #'nt-defs stx)) (define non-terms (parse-non-terminals #'nt-defs stx))
(with-syntax* ([((names prods ...) ...) non-terms] (with-syntax* ([((names prods ...) ...) non-terms]
[(all-names ...) (apply append (map car non-terms))] [(all-names ...) (apply append (map car non-terms))]
[(nt-ids ...)
(for/list ([nt-def (in-list (syntax->list #'nt-defs))])
(syntax-case nt-def ()
[(x . whatever) #'x]))]
[bindings [bindings
(record-nts-disappeared-bindings #'lang-name (syntax->list #'(nt-ids ...)))]) (record-nts-disappeared-bindings #'lang-name (syntax->list #'(all-names ...)))])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
bindings bindings
@ -1886,7 +1882,7 @@
(identifier? #'x) (identifier? #'x)
#'define-language-name])) #'define-language-name]))
'(all-names ...) '(all-names ...)
(to-table #'lang-name #'(nt-ids ...))))) (to-table #'lang-name #'(all-names ...)))))
(define define-language-name (define define-language-name
#,(syntax/loc stx (language form-name lang-name (all-names ...) (names prods ...) ...))))))))])) #,(syntax/loc stx (language form-name lang-name (all-names ...) (names prods ...) ...))))))))]))
@ -2009,10 +2005,7 @@
[n2 (if (syntax? n2) (syntax-e n2) n2)]) [n2 (if (syntax? n2) (syntax-e n2) n2)])
(eq? n1 n2))))] (eq? n1 n2))))]
[(define-language-name) (generate-temporaries #'(name))] [(define-language-name) (generate-temporaries #'(name))]
[(nt-ids ...) [(nt-ids ...) (apply append (map car non-terms))]
(for/list ([nt-def (in-list (syntax->list #'nt-defs))])
(syntax-case nt-def ()
[(x . whatever) #'x]))]
[uses [uses
(record-nts-disappeared-bindings #'orig-lang (syntax->list #'(nt-ids ...)) 'disappeared-use)] (record-nts-disappeared-bindings #'orig-lang (syntax->list #'(nt-ids ...)) 'disappeared-use)]
[bindings [bindings
@ -2196,7 +2189,7 @@
(identifier? #'x) (identifier? #'x)
#'define-language-name])) #'define-language-name]))
'(all-names ...) '(all-names ...)
(to-table #'())))))))])) (to-table #'name #'())))))))]))
(define (union-language old-langs/prefixes) (define (union-language old-langs/prefixes)

15
pkgs/redex-pkgs/redex-test/redex/tests/check-syntax-test.rkt
View File

@ -167,32 +167,38 @@
(define base-lang-def (identifier L1)) (define base-lang-def (identifier L1))
(define base-lang-use1 (identifier L1)) (define base-lang-use1 (identifier L1))
(define base-lang-use2 (identifier L1)) (define base-lang-use2 (identifier L1))
(define base-lang-use3 (identifier L1))
(define extended-lang-def (identifier L2)) (define extended-lang-def (identifier L2))
(define extended-lang-use (identifier L2)) (define extended-lang-use (identifier L2))
(define base-nt-name (identifier e)) (define base-nt-name (identifier e))
(define base-nt-use (identifier e)) (define base-nt-use (identifier e))
(define base-nt-alias (identifier f))
(define alias-use (identifier f))
(define extended-nt-name (identifier e)) (define extended-nt-name (identifier e))
(define extended-nt-use (identifier e)) (define extended-nt-use (identifier e))
(define base-lang-bindings (define base-lang-bindings
(list base-lang-def base-lang-use1 base-lang-use2)) (list base-lang-def base-lang-use1 base-lang-use2 base-lang-use3))
(define extended-lang-bindings (define extended-lang-bindings
(list extended-lang-def extended-lang-use)) (list extended-lang-def extended-lang-use))
(define base-nt-bindings (define base-nt-bindings
(list base-nt-name extended-nt-name base-nt-use)) (list base-nt-name extended-nt-name base-nt-use))
(define extended-nt-bindings (define extended-nt-bindings
(list extended-nt-name extended-nt-use)) (list extended-nt-name extended-nt-use))
(define alias-bindings
(list base-nt-alias alias-use))
(parameterize ([current-annotations annotations] (parameterize ([current-annotations annotations]
[current-namespace module-namespace]) [current-namespace module-namespace])
(add-syntax (add-syntax
(expand #`(let () (expand #`(let ()
(define-language #,base-lang-def (define-language #,base-lang-def
(#,base-nt-name number)) ((#,base-nt-name #,base-nt-alias) number))
(define-extended-language #,extended-lang-def #,base-lang-use1 (define-extended-language #,extended-lang-def #,base-lang-use1
(#,extended-nt-name .... variable)) (#,extended-nt-name .... variable))
(redex-match #,base-lang-use2 #,base-nt-use 1) (redex-match #,base-lang-use2 #,base-nt-use 1)
(redex-match #,extended-lang-use #,extended-nt-use 'x)))) (redex-match #,extended-lang-use #,extended-nt-use 'x)
(redex-match #,base-lang-use3 #,alias-use 2))))
(done)) (done))
(test (send annotations collected-arrows) (test (send annotations collected-arrows)
@ -200,7 +206,8 @@
(list base-lang-bindings (list base-lang-bindings
extended-lang-bindings extended-lang-bindings
base-nt-bindings base-nt-bindings
extended-nt-bindings)))) extended-nt-bindings
alias-bindings))))