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

redex: differentiate nts from different langauges

Browse Source
This commit is contained in:
Burke Fetscher 2014-10-29 15:38:25 -05:00
parent f22d058aee
commit 8ffa22dab6
3 changed files with 70 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1870,7 +1870,7 @@
(syntax-case nt-def () (syntax-case nt-def ()
[(x . whatever) #'x]))] [(x . whatever) #'x]))]
[bindings [bindings
(record-nts-disappeared-bindings (syntax->list #'(nt-ids ...)))]) (record-nts-disappeared-bindings #'lang-name (syntax->list #'(nt-ids ...)))])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
bindings bindings
@ -1886,26 +1886,34 @@
(identifier? #'x) (identifier? #'x)
#'define-language-name])) #'define-language-name]))
'(all-names ...) '(all-names ...)
(to-table #'(nt-ids ...))))) (to-table #'lang-name #'(nt-ids ...)))))
(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 ...) ...))))))))]))
(define-for-syntax (record-nts-disappeared-bindings nt-ids) (define-for-syntax (record-nts-disappeared-bindings lang nt-ids [prop `disappeared-binding])
(let loop ([nt-ids nt-ids] (let loop ([nt-ids nt-ids]
[stx #'(void)]) [stx #'(void)])
(cond (cond
[(null? nt-ids) stx] [(null? nt-ids) stx]
[else [else
(define old (syntax-property stx 'disappeared-binding)) (define old (syntax-property stx prop))
(define new (syntax-local-introduce (car nt-ids))) (define new (syntax-local-introduce (lang-nt-id lang (car nt-ids))))
(loop (cdr nt-ids) (loop (cdr nt-ids)
(syntax-property stx (syntax-property stx
'disappeared-binding prop
(if old (cons new old) new)))]))) (if old (cons new old) new)))])))
(define-for-syntax (to-table x) (define-for-syntax (lang-nt-id lang-stx nt-stx)
(format-id nt-stx "~a:~a"
(syntax->datum lang-stx)
(syntax->datum nt-stx)
#:source nt-stx
#:props nt-stx))
(define-for-syntax (to-table lang x)
(for/hash ([id (in-list (syntax->list x))]) (for/hash ([id (in-list (syntax->list x))])
(values (syntax-e id) id))) (values (syntax-e id) (lang-nt-id lang id))))
(define-struct binds (source binds)) (define-struct binds (source binds))
@ -2005,10 +2013,13 @@
(for/list ([nt-def (in-list (syntax->list #'nt-defs))]) (for/list ([nt-def (in-list (syntax->list #'nt-defs))])
(syntax-case nt-def () (syntax-case nt-def ()
[(x . whatever) #'x]))] [(x . whatever) #'x]))]
[uses
(record-nts-disappeared-bindings #'orig-lang (syntax->list #'(nt-ids ...)) 'disappeared-use)]
[bindings [bindings
(record-nts-disappeared-bindings (syntax->list #'(nt-ids ...)))]) (record-nts-disappeared-bindings #'name (syntax->list #'(nt-ids ...)))])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
uses
bindings bindings
(define define-language-name (define define-language-name
#,(syntax/loc stx #,(syntax/loc stx
@ -2024,7 +2035,8 @@
(identifier? #'x) (identifier? #'x)
#'define-language-name])) #'define-language-name]))
'(all-names ...) '(all-names ...)
(to-table #'(nt-ids ...))))))))))])) (to-table #'name #'(nt-ids ...))))))))))]))
(define-syntax (extend-language stx) (define-syntax (extend-language stx)
(syntax-case stx () (syntax-case stx ()

4
pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt
View File

@ -107,7 +107,9 @@
(syntax-position id-stx) (syntax-position id-stx)
;; shorten the span so it covers only up to the underscore ;; shorten the span so it covers only up to the underscore
(string-length (symbol->string nt)))) (string-length (symbol->string nt))))
(define the-id (datum->syntax table-entry nt the-srcloc id-stx)) (define the-id (datum->syntax table-entry
(syntax-e table-entry)
the-srcloc id-stx))
(syntax-property the-id 'original-for-check-syntax #t)] (syntax-property the-id 'original-for-check-syntax #t)]
[else [else
#f])] #f])]

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

@ -159,4 +159,49 @@
(expected-arrows (expected-arrows
(list (list def-name use-name))))) (list (list def-name use-name)))))
;; extended language
(let ([annotations (new collector%)])
(define-values (add-syntax done)
(make-traversal module-namespace #f))
(define base-lang-def (identifier L1))
(define base-lang-use1 (identifier L1))
(define base-lang-use2 (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 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))
(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))
(parameterize ([current-annotations annotations]
[current-namespace module-namespace])
(add-syntax
(expand #`(let ()
(define-language #,base-lang-def
(#,base-nt-name 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))))
(done))
(test (send annotations collected-arrows)
(expected-arrows
(list base-lang-bindings
extended-lang-bindings
base-nt-bindings
extended-nt-bindings))))
(print-tests-passed 'check-syntax-test.rkt) (print-tests-passed 'check-syntax-test.rkt)