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))
(with-syntax* ([((names prods ...) ...) 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
(record-nts-disappeared-bindings #'lang-name (syntax->list #'(nt-ids ...)))])
(record-nts-disappeared-bindings #'lang-name (syntax->list #'(all-names ...)))])
(quasisyntax/loc stx
(begin
bindings
@ -1886,7 +1882,7 @@
(identifier? #'x)
#'define-language-name]))
'(all-names ...)
(to-table #'lang-name #'(nt-ids ...)))))
(to-table #'lang-name #'(all-names ...)))))
(define define-language-name
#,(syntax/loc stx (language form-name lang-name (all-names ...) (names prods ...) ...))))))))]))
@ -2009,10 +2005,7 @@
[n2 (if (syntax? n2) (syntax-e n2) n2)])
(eq? n1 n2))))]
[(define-language-name) (generate-temporaries #'(name))]
[(nt-ids ...)
(for/list ([nt-def (in-list (syntax->list #'nt-defs))])
(syntax-case nt-def ()
[(x . whatever) #'x]))]
[(nt-ids ...) (apply append (map car non-terms))]
[uses
(record-nts-disappeared-bindings #'orig-lang (syntax->list #'(nt-ids ...)) 'disappeared-use)]
[bindings
@ -2196,7 +2189,7 @@
(identifier? #'x)
#'define-language-name]))
'(all-names ...)
(to-table #'())))))))]))
(to-table #'name #'())))))))]))
(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-use1 (identifier L1))
(define base-lang-use2 (identifier L1))
(define base-lang-use3 (identifier L1))
(define extended-lang-def (identifier L2))
(define extended-lang-use (identifier L2))
(define base-nt-name (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-use (identifier e))
(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
(list extended-lang-def extended-lang-use))
(define base-nt-bindings
(list base-nt-name extended-nt-name base-nt-use))
(define extended-nt-bindings
(list extended-nt-name extended-nt-use))
(define alias-bindings
(list base-nt-alias alias-use))
(parameterize ([current-annotations annotations]
[current-namespace module-namespace])
(add-syntax
(expand #`(let ()
(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
(#,extended-nt-name .... variable))
(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))
(test (send annotations collected-arrows)
@ -200,7 +206,8 @@
(list base-lang-bindings
extended-lang-bindings
base-nt-bindings
extended-nt-bindings))))
extended-nt-bindings
alias-bindings))))