From b0db8798b634c90446aef198b3cfbf95242421c2 Mon Sep 17 00:00:00 2001
From: "William J. Bowman" <wjb@williamjbowman.com>
Date: Thu, 28 Feb 2013 13:45:50 -0500
Subject: [PATCH] Changed `define-union-language' to merge nonterminals and
 their right-hand-sides instead of causing an error when more than one
 language in the union defines the same nonterminal.

---
 collects/redex/examples/union-lang.rkt        | 40 +++++++++++++++++++
 .../redex/private/reduction-semantics.rkt     | 39 +++++++++++-------
 collects/redex/tests/tl-test.rkt              |  8 +++-
 3 files changed, 72 insertions(+), 15 deletions(-)
 create mode 100644 collects/redex/examples/union-lang.rkt

diff --git a/collects/redex/examples/union-lang.rkt b/collects/redex/examples/union-lang.rkt
new file mode 100644
index 0000000000..cd3010d459
--- /dev/null
+++ b/collects/redex/examples/union-lang.rkt
@@ -0,0 +1,40 @@
+#lang racket
+
+(provide LBase L1 L2 LMergeUntagged LMergeTagged)
+(require redex/reduction-semantics)
+
+;; ------------------------------------------------------------------------
+
+(define-language LBase
+  (e (+ e e) number))
+
+(define-extended-language L1 LBase
+  (e ....  (- e e)))
+
+(define-extended-language L2 LBase
+  (e ....  (* e e)))
+
+;; Untagged union of two languages that define the same nonterminal
+(define-union-language LMergeUntagged L1 L2)
+
+;; Tagged merge of two extended languages that define the same
+;; nonterminal
+(define-union-language LMergeTagged (f. L1) (d. L2))
+
+;; ------------------------------------------------------------------------
+
+(module+ test 
+
+  (for ([t (list (term 1) (term (* 1 1)) (term (+ 1 1)) (term (- 1 1)))])
+       (test-equal (redex-match? LMergeUntagged e t) #t))
+
+  (test-equal (redex-match? LMergeTagged f.e 1) #t)
+  (test-equal (redex-match? LMergeTagged d.e 1) #t)
+
+  (test-equal (redex-match? LMergeTagged f.e (term (+ 1 1))) #t)
+  (test-equal (redex-match? LMergeTagged f.e (term (- 1 1))) #t)
+  (test-equal (redex-match? LMergeTagged f.e (term (* 1 1))) #f)
+
+  (test-equal (redex-match? LMergeTagged d.e (term (+ 1 1))) #t)
+  (test-equal (redex-match? LMergeTagged d.e (term (* 1 1))) #t)
+  (test-equal (redex-match? LMergeTagged d.e (term (- 1 1))) #f))
diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt
index 6db2080c51..19e281a10d 100644
--- a/collects/redex/private/reduction-semantics.rkt
+++ b/collects/redex/private/reduction-semantics.rkt
@@ -1911,10 +1911,10 @@
                                        "malformed additional language"
                                        stx orig-lang)])))
        
-       ;; ht : sym -o> stx
+       ;; ht : sym -o> (listof stx)
        ;; maps each non-terminal (with its prefix) to the 
-       ;; syntax object that it comes from in the original
-       ;; define-union-language declaration
+       ;; list syntax object that they comes from in the original
+       ;; define-union-language declaration 
        (define names-table (make-hash))
        
        (for ([normalized-orig-lang (in-list normalized-orig-langs)])
@@ -1922,14 +1922,9 @@
          (for ([no-prefix-nt (in-list (list-ref normalized-orig-lang 2))])
            (define nt (string->symbol (string-append prefix (symbol->string no-prefix-nt))))
            (let ([prev (hash-ref names-table nt #f)])
-             (when prev
-               (raise-syntax-error 'define-union-language 
-                                   (format "two sublanguages both contribute the non-terminal: ~a" nt)
-                                   #f
-                                   #f
-                                   (list prev
-                                         (list-ref normalized-orig-lang 3))))
-             (hash-set! names-table nt (list-ref normalized-orig-lang 3)))))
+             (if prev
+               (hash-set! names-table nt (cons (list-ref normalized-orig-lang 3) prev))
+               (hash-set! names-table nt (list (list-ref normalized-orig-lang 3)))))))
        
        (with-syntax ([(all-names ...) (sort (hash-map names-table (λ (x y) x)) string<=? #:key symbol->string)]
                      [((prefix old-lang _1 _2) ...) normalized-orig-langs]
@@ -1969,10 +1964,26 @@
          (make-nt (string->symbol (string-append prefix (symbol->string (nt-name nt))))
                   (for/list ([rhs (in-list (nt-rhs nt))])
                     (make-rhs (prefix-nts prefix (rhs-pattern rhs)))))))))
-  
+
+  ;; Each language in the union might define the same nt, and might
+  ;; even define the same rhs for the same nt, so merge them to get a
+  ;; proper union.
+  ;; NOTE: This could probably be done when defining new-nts to
+  ;; eliminate a second pass over all the nts.
+  (define merge-nts
+    (let ()
+      (define names-table (make-hash))
+      (for/list ([nt (in-list new-nts)])
+        (let* ([name (nt-name nt)]
+               [prev (hash-ref names-table name #f)])
+          (if prev
+            (hash-set! names-table name (make-nt name (remove-duplicates (append (nt-rhs prev) (nt-rhs nt)))))
+            (hash-set! names-table name nt))))
+      (hash-map names-table (lambda (x y) y))))
+
   (compile-language #f
-                    new-nts
-                    new-nt-map))
+                    merge-nts
+                    (remove-duplicates new-nt-map)))
 
 
 ;; find-primary-nt : symbol lang -> symbol or #f
diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt
index 5ee0fe30c9..7c3611a1a4 100644
--- a/collects/redex/tests/tl-test.rkt
+++ b/collects/redex/tests/tl-test.rkt
@@ -448,8 +448,14 @@
       (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))
+    (test (and (redex-match LMerge two.e (term (* 0 0))) #t) #t)
+
+    (define-union-language LMergeUntagged L1 L2)
+
+    (for ([t (list (term 1) (term (* 1 1)) (term (+ 1 1)) (term (- 1 1)))])
+       (test (redex-match? LMergeUntagged e t) #t)))
 
   (let ()
     (define-language UT