Remove duplicate non-terminals in define-extended-language
Fixes a problem with `define-union-language`
This commit is contained in:
parent
2236363696
commit
5790667054
|
@ -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 ...) ...))
|
||||
|
|
|
@ -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))
|
||||
|
|
Loading…
Reference in New Issue
Block a user