Remove duplicate non-terminals in define-extended-language

Fixes a problem with `define-union-language`
This commit is contained in:
Asumu Takikawa 2013-02-28 00:09:56 -05:00
parent 2236363696
commit 5790667054
2 changed files with 59 additions and 1 deletions

View File

@ -1758,7 +1758,16 @@
(let ([old-names (language-id-nts #'orig-lang 'define-extended-language)]
[non-terms (parse-non-terminals #'nt-defs stx)])
(with-syntax ([((names prods ...) ...) non-terms]
[(all-names ...) (apply append old-names (map car non-terms))]
[(all-names ...)
;; The names may have duplicates if the extended language
;; extends non-terminals in the parent language. They need
;; to be removed for `define-union-language`
(remove-duplicates
(apply append old-names (map car non-terms))
(λ (n1 n2)
(let ([n1 (if (syntax? n1) (syntax-e n1) n1)]
[n2 (if (syntax? n2) (syntax-e n2) n2)])
(eq? n1 n2))))]
[(define-language-name) (generate-temporaries #'(name))])
#'(begin
(define define-language-name (extend-language orig-lang (all-names ...) (names prods ...) ...))

View File

@ -424,6 +424,55 @@
(test (and (redex-match L -b 100) #t) #t)
(test (redex-match L -b 3) #f))
;; The following two tests make sure that `define-union-language`
;; works with extended languages
(let ()
(define-language LBase
(e (+ e e)
number))
(define-extended-language L1 LBase
(e ....
(- e e)))
(define-extended-language L2 LBase
(e ....
(* e e)))
(define-union-language LMerge (one. L1) (two. L2))
#|
The error that used to be raised:
define-union-language: two sublanguages both contribute the non-terminal: one.e in:
(one. L1)
(one. L1)
|#
(test (and (redex-match LMerge one.e (term (- 0 0))) #t) #t)
(test (and (redex-match LMerge two.e (term (* 0 0))) #t) #t))
(let ()
(define-language UT
(e (e e)
(λ (x) e)
x))
(define-language WT
(e (e e)
(λ (x t) e)
x)
(t ( t t)
num))
(define-extended-language UT+ UT
(e ....
(foo e e)))
(define-union-language B (ut. UT+) (wt. WT))
(test (and (redex-match B ut.e (term (foo x x))) #t) #t)
(test (redex-match B wt.e (term (foo x x))) #f))
(let ()
(test (redex-match empty-language number 'a) #f)
(test (redex-match empty-language (in-hole hole number) 'a) #f))