diff --git a/collects/redex/private/matcher-test.ss b/collects/redex/private/matcher-test.ss
index 9e3b8fcab5..38360fbb7f 100644
--- a/collects/redex/private/matcher-test.ss
+++ b/collects/redex/private/matcher-test.ss
@@ -516,24 +516,24 @@
                            (make-rhs '(+ exp ctxt) '())
                            (make-rhs 'hole '())))))
      (list
-      (make-nt 'exp-exp 
-               (list (make-rhs 'hole '()) 
-                     (make-rhs `(+ (cross exp-exp) exp) '()) 
-                     (make-rhs `(+ exp (cross exp-exp)) '())))
-      (make-nt 'exp-ctxt
-               (list (make-rhs `(+ (cross exp-ctxt) exp) '())
-                     (make-rhs `(+ ctxt (cross exp-exp)) '())
-                     (make-rhs `(+ (cross exp-exp) ctxt) '())
-                     (make-rhs `(+ exp (cross exp-ctxt)) '())))
-      (make-nt 'ctxt-exp
-               (list (make-rhs `(+ (cross ctxt-exp) exp) '())
-                     (make-rhs `(+ exp (cross ctxt-exp)) '())))
       (make-nt 'ctxt-ctxt
                (list (make-rhs 'hole '())
                      (make-rhs `(+ (cross ctxt-ctxt) exp) '())
                      (make-rhs `(+ ctxt (cross ctxt-exp)) '())
                      (make-rhs `(+ (cross ctxt-exp) ctxt) '())
-                     (make-rhs `(+ exp (cross ctxt-ctxt)) '())))))
+                     (make-rhs `(+ exp (cross ctxt-ctxt)) '())))
+      (make-nt 'ctxt-exp
+               (list (make-rhs `(+ (cross ctxt-exp) exp) '())
+                     (make-rhs `(+ exp (cross ctxt-exp)) '())))
+      (make-nt 'exp-ctxt
+               (list (make-rhs `(+ (cross exp-ctxt) exp) '())
+                     (make-rhs `(+ ctxt (cross exp-exp)) '())
+                     (make-rhs `(+ (cross exp-exp) ctxt) '())
+                     (make-rhs `(+ exp (cross exp-ctxt)) '())))
+      (make-nt 'exp-exp 
+               (list (make-rhs 'hole '()) 
+                     (make-rhs `(+ (cross exp-exp) exp) '()) 
+                     (make-rhs `(+ exp (cross exp-exp)) '())))))
     
     (run-test
      'compatible-context-language2
@@ -542,15 +542,7 @@
       (list (make-nt 'm (list (make-rhs '(m m) '()) (make-rhs '(+ m m) '()) (make-rhs 'v '())))
             (make-nt 'v (list (make-rhs 'number '()) (make-rhs '(lambda (x) m) '())))))
      (list
-      (make-nt 'm-m
-               (list
-                (make-rhs 'hole '())
-                (make-rhs (list (list 'cross 'm-m) 'm) '())
-                (make-rhs (list 'm (list 'cross 'm-m)) '())
-                (make-rhs (list '+ (list 'cross 'm-m) 'm) '())
-                (make-rhs (list '+ 'm (list 'cross 'm-m)) '())
-                (make-rhs (list 'cross 'm-v) '())))
-      (make-nt 'm-v (list (make-rhs (list 'lambda (list 'x) (list 'cross 'm-m)) '())))
+      (make-nt 'v-v (list (make-rhs 'hole '()) (make-rhs (list 'lambda (list 'x) (list 'cross 'v-m)) '())))
       (make-nt 'v-m
                (list
                 (make-rhs (list (list 'cross 'v-m) 'm) '())
@@ -558,7 +550,15 @@
                 (make-rhs (list '+ (list 'cross 'v-m) 'm) '())
                 (make-rhs (list '+ 'm (list 'cross 'v-m)) '())
                 (make-rhs (list 'cross 'v-v) '())))
-      (make-nt 'v-v (list (make-rhs 'hole '()) (make-rhs (list 'lambda (list 'x) (list 'cross 'v-m)) '())))))
+      (make-nt 'm-v (list (make-rhs (list 'lambda (list 'x) (list 'cross 'm-m)) '())))
+      (make-nt 'm-m
+               (list
+                (make-rhs 'hole '())
+                (make-rhs (list (list 'cross 'm-m) 'm) '())
+                (make-rhs (list 'm (list 'cross 'm-m)) '())
+                (make-rhs (list '+ (list 'cross 'm-m) 'm) '())
+                (make-rhs (list '+ 'm (list 'cross 'm-m)) '())
+                (make-rhs (list 'cross 'm-v) '())))))
     
     (run-test
      'compatible-context-language3
@@ -568,13 +568,26 @@
             (make-nt 'seven (list (make-rhs 7 '())))))
      `(,(make-nt
          'm-m
-         `(,(make-rhs 'hole '()) ,(make-rhs `((cross m-m) seven m) '()) ,(make-rhs `(m (cross m-seven) m) '()) ,(make-rhs `(m seven (cross m-m)) '())))
-       ,(make-nt 'm-seven `())
+         `(,(make-rhs 'hole '()) ,(make-rhs `((cross m-m) seven m) '()) ,(make-rhs `(m seven (cross m-m)) '())))
        ,(make-nt
          'seven-m
          `(,(make-rhs `((cross seven-m) seven m) '()) ,(make-rhs `(m (cross seven-seven) m) '()) ,(make-rhs `(m seven (cross seven-m)) '())))
        ,(make-nt 'seven-seven `(,(make-rhs 'hole '())))))
     
+    (run-test
+     'compatible-context-language4
+     (build-compatible-context-language
+      (mk-hasheq '((a . ()) (b . ()) (c . ())))
+      (list (make-nt 'a (list (make-rhs 'b '())))
+            (make-nt 'b (list (make-rhs 'c '())))
+            (make-nt 'c (list (make-rhs 3 '())))))
+     (list (make-nt 'c-c (list (make-rhs 'hole '())))
+           (make-nt 'c-b (list (make-rhs '(cross c-c) '())))
+           (make-nt 'c-a (list (make-rhs '(cross c-b) '())))
+           (make-nt 'b-b (list (make-rhs 'hole '())))
+           (make-nt 'b-a (list (make-rhs '(cross b-b) '())))
+           (make-nt 'a-a (list (make-rhs 'hole '())))))
+    
     #;
     (test-xab '(in-hole (cross exp) (+ number number))
               '(+ (+ 1 2) 3)
diff --git a/collects/redex/private/matcher.ss b/collects/redex/private/matcher.ss
index a94cda1004..35514a7cbc 100644
--- a/collects/redex/private/matcher.ss
+++ b/collects/redex/private/matcher.ss
@@ -147,7 +147,7 @@ before the pattern compiler is invoked.
                         (when may-be-list? (add-to-ht list-ht))
                         (unless (or may-be-non-list? may-be-list?)
                           (error 'compile-language 
-                                 "unable to determine whether pattern matches lists, non-lists, or both: ~s"
+                                 "internal error: unable to determine whether pattern matches lists, non-lists, or both: ~s"
                                  (rhs-pattern rhs))))))
                   (nt-rhs nt)))
                lang))]
@@ -283,22 +283,52 @@ before the pattern compiler is invoked.
           
   ;; build-compatible-context-language : lang -> lang
   (define (build-compatible-context-language clang-ht lang)
-    (apply
-     append
-     (map 
-      (lambda (nt1)
-        (map
-         (lambda (nt2)
-           (let ([compat-nt (build-compatible-contexts/nt clang-ht (nt-name nt1) nt2)])
-             (if (eq? (nt-name nt1) (nt-name nt2))
-                 (make-nt (nt-name compat-nt)
-                          (cons
-                           (make-rhs 'hole '())
-                           (nt-rhs compat-nt)))
-                 compat-nt)))
-         lang))
-      lang)))
+    (remove-empty-compatible-contexts
+     (apply
+      append
+      (map 
+       (lambda (nt1)
+         (map
+          (lambda (nt2)
+            (let ([compat-nt (build-compatible-contexts/nt clang-ht (nt-name nt1) nt2)])
+              (if (eq? (nt-name nt1) (nt-name nt2))
+                  (make-nt (nt-name compat-nt)
+                           (cons
+                            (make-rhs 'hole '())
+                            (nt-rhs compat-nt)))
+                  compat-nt)))
+          lang))
+       lang))))
+  
+  ;; remove-empty-compatible-contexts : lang -> lang
+  ;; Removes the empty compatible context non-terminals and the 
+  ;; rhss that reference them.
+  (define (remove-empty-compatible-contexts lang)
+    (define (has-cross? pattern crosses)
+      (match pattern
+        [`(cross ,(? symbol? nt)) (memq nt crosses)]
+        [(list-rest p '... rest) (has-cross? rest crosses)]
+        [(cons first rest) (or (has-cross? first crosses)
+                               (has-cross? rest crosses))]
+        [_ #f]))
+    (define (delete-empty nts)
+      (for/fold ([deleted null] [kept null]) ([nt nts])
+                (if (null? (nt-rhs nt))
+                    (values (cons nt deleted) kept)
+                    (values deleted (cons nt kept)))))
+    (define (delete-references deleted-names remaining-nts)
+      (map (λ (nt) 
+             (make-nt (nt-name nt)
+                      (filter (λ (rhs) (not (has-cross? (rhs-pattern rhs) deleted-names))) 
+                              (nt-rhs nt))))
+           remaining-nts))
     
+    (let loop ([nts lang])
+      (let-values ([(deleted kept) (delete-empty nts)])
+        (if (null? deleted)
+            kept
+            (loop (delete-references (map nt-name deleted) kept))))))
+  
   ;; build-compatible-contexts : clang-ht prefix nt -> nt
   ;; constructs the compatible closure evaluation context from nt.
   (define (build-compatible-contexts/nt clang-ht prefix nt)
diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss
index 657167b1cd..3da7b6dc67 100644
--- a/collects/redex/private/reduction-semantics.ss
+++ b/collects/redex/private/reduction-semantics.ss
@@ -1128,27 +1128,37 @@
                                 stx
                                 name)]))])))
 
+;; check-rhss-not-empty : syntax (listof syntax) -> void
+(define-for-syntax (check-rhss-not-empty def-lang-stx nt-def-stxs)
+  (for-each 
+   (λ (nt-def-stx)
+     (when (null? (cdr (syntax-e nt-def-stx)))
+       (raise-syntax-error 'define-language "non-terminal with no productions" def-lang-stx nt-def-stx)))
+   nt-def-stxs))
+
 (define-syntax (define-language stx)
   (syntax-case stx ()
     [(_ name (names rhs ...) ...)
      (identifier? (syntax name))
-     (with-syntax ([((nt-names orig) ...) (pull-out-names 'define-language stx #'(names ...))])
-       (with-syntax ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))])
-         (syntax/loc stx
-           (begin
-             (define-syntax name
-               (make-set!-transformer
-                (make-language-id
-                 (case-lambda
-                   [(stx)
-                    (syntax-case stx (set!)
-                      [(set! x e) (raise-syntax-error 'define-language "cannot set! identifier" stx #'e)]
-                      [(x e (... ...)) #'(define-language-name e (... ...))]
-                      [x 
-                       (identifier? #'x)
-                       #'define-language-name])])
-                 '(nt-names ...))))
-             (define define-language-name (language name (names rhs ...) ...))))))]))
+     (begin
+       (check-rhss-not-empty stx (cddr (syntax-e stx)))
+       (with-syntax ([((nt-names orig) ...) (pull-out-names 'define-language stx #'(names ...))])
+         (with-syntax ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))])
+           (syntax/loc stx
+             (begin
+               (define-syntax name
+                 (make-set!-transformer
+                  (make-language-id
+                   (case-lambda
+                     [(stx)
+                      (syntax-case stx (set!)
+                        [(set! x e) (raise-syntax-error 'define-language "cannot set! identifier" stx #'e)]
+                        [(x e (... ...)) #'(define-language-name e (... ...))]
+                        [x 
+                         (identifier? #'x)
+                         #'define-language-name])])
+                   '(nt-names ...))))
+               (define define-language-name (language name (names rhs ...) ...)))))))]))
 
 (define-struct binds (source binds))
 
@@ -1328,6 +1338,7 @@
          (raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'name))
        (unless (identifier? (syntax orig-lang))
          (raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'orig-lang))
+       (check-rhss-not-empty stx (cdddr (syntax-e stx)))
        (let ([old-names (language-id-nts #'orig-lang 'define-extended-language)])
          (with-syntax ([((new-nt-names orig) ...) (append (pull-out-names 'define-language stx #'(names ...)) 
                                                           (map (λ (x) #`(#,x #f)) old-names))])
diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss
index c89a39d4fc..0cb8c853a1 100644
--- a/collects/redex/private/rg-test.ss
+++ b/collects/redex/private/rg-test.ss
@@ -21,20 +21,20 @@
     (e x (e e) (λ (x) e))
     (x variable))
   (test (to-table (find-base-cases lc))
-        '((e . (1 2 2)) (x . (0)))))
+        '((e . (1 2 2)) (e-e . (0 2 2 1)) (x . (0)) (x-e . (1 2 2 2 2)) (x-x . (0)))))
 
 (let ()
-  (define-language lc
+  (define-language lang
     (e (e e)))
-  (test (to-table (find-base-cases lc))
-        '((e . (inf)))))
+  (test (to-table (find-base-cases lang))
+        '((e . (inf)) (e-e . (0 inf inf)))))
 
 (let ()
-  (define-language lc
+  (define-language lang
     (a 1 2 3)
     (b a (a_1 b_!_1)))
-  (test (to-table (find-base-cases lc))
-        '((a . (0 0 0)) (b . (1 2)))))
+  (test (to-table (find-base-cases lang))
+        '((a . (0 0 0)) (a-a . (0)) (a-b . (1)) (b . (1 2)) (b-b . (0)))))
 
 (let ()
   (define-language lc
@@ -46,7 +46,9 @@
        number)
     (x variable))
   (test (to-table (find-base-cases lc))
-        '((e . (2 2 1 1)) (v . (2 0)) (x . (0)))))
+        '((e . (2 2 1 1)) (e-e . (0 2 2 2 2 2)) (e-v . (1))
+          (v . (2 0)) (v-e . (2 2 2 2 1)) (v-v . (0 2))
+          (x . (0)) (x-e . (2 2 2 2 1 3)) (x-v . (2 2)) (x-x . (0)))))
 
 (let ()
   (define-language lang
@@ -278,8 +280,8 @@
 
 (let ()
   (define-language lang (x variable literal))
-  (test (is-nt? lang 'x) #t)
-  (test (is-nt? lang 'y) #f))
+  (test ((is-nt? lang) 'x) #t)
+  (test ((is-nt? lang) 'y) #f))
 
 (let ()
   (define-language lang
@@ -454,6 +456,17 @@
       (thunk))
     (get-output-string port)))
 
+;; `cross' pattern
+(let ()
+  (define-language lang
+    (e x (e e) v)
+    (v (λ (x) e))
+    (x variable-not-otherwise-mentioned))
+  (test (generate lang (cross e) 3 0 
+                  (decisions #:nt (patterns fourth first first second first first first)
+                             #:var (list (λ _ 'x) (λ _ 'y))))
+        (term (λ (x) (hole y)))))
+
 (let ()
   (define-language lang
     (d 5)
@@ -500,7 +513,9 @@
                          _
                          (list  (struct class (c_1)) (struct mismatch (i_1 '..._!_1)) 'x_1)))
                 (car (parse-pattern pattern)))
-    (test (unparse-pattern (parse-pattern pattern)) pattern)))
+    (test (unparse-pattern (parse-pattern pattern)) pattern)
+    (test (parse-pattern '(cross e)) '(cross e-e))
+    (test (parse-pattern '(cross e) #t) '(cross e))))
 
 (let ()
   (define-syntax test-class-reassignments
diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss
index 80d58b16ef..f5797d11ae 100644
--- a/collects/redex/private/rg.ss
+++ b/collects/redex/private/rg.ss
@@ -137,25 +137,23 @@ To do a better job of not generating programs with free variables,
   (define lang-chars (unique-chars lang-lits))
   (define base-table (find-base-cases lang))
   
-  (define (generate-nt nt fvt-id bound-vars size in-hole state)
-    (let loop ([nts (compiled-lang-lang lang)])
-      (cond
-        [(null? nts) (error 'generate-nt "didn't find non-terminal ~s" nt)]
-        [(eq? (nt-name (car nts)) nt)
-         (let*-values 
-             ([(rhs) 
-               ((next-non-terminal-decision) 
-                (if (zero? size) (min-prods (car nts) base-table) (nt-rhs (car nts)))
-                bound-vars size)]
-              [(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)]
-              [(nt-state) (make-state (map fvt-entry (rhs-var-info rhs)) #hash())]
-              [(term _)
-               (generate/pred 
-                (rhs-pattern rhs)
-                (λ (pat) (((generate-pat bound-vars (max 0 (sub1 size))) pat in-hole) nt-state))
-                (λ (_ env) (mismatches-satisfied? env)))])
-           (values term (extend-found-vars fvt-id term state)))]
-        [else (loop (cdr nts))])))
+  (define (generate-nt name fvt-id bound-vars size in-hole state)
+    (let*-values 
+        ([(nt) (findf (λ (nt) (eq? name (nt-name nt))) 
+                      (append (compiled-lang-lang lang)
+                              (compiled-lang-cclang lang)))]
+         [(rhs) 
+          ((next-non-terminal-decision) 
+           (if (zero? size) (min-prods nt base-table) (nt-rhs nt))
+           bound-vars size)]
+         [(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)]
+         [(nt-state) (make-state (map fvt-entry (rhs-var-info rhs)) #hash())]
+         [(term _)
+          (generate/pred 
+           (rhs-pattern rhs)
+           (λ (pat) (((generate-pat bound-vars (max 0 (sub1 size))) pat in-hole) nt-state))
+           (λ (_ env) (mismatches-satisfied? env)))])
+      (values term (extend-found-vars fvt-id term state))))
   
   (define (generate-sequence ellipsis generate state length)
     (define (split-environment env)
@@ -213,9 +211,13 @@ To do a better job of not generating programs with free variables,
   (define (fvt-entry binds)
     (make-found-vars (binds-binds binds) (binds-source binds) '() #f))
   
-  (define (((generate-pat bound-vars size) pat in-hole [fvt-id pat]) state)
+  (define (((generate-pat bound-vars size) pat in-hole) state)
     (define recur (generate-pat bound-vars size))
     (define (recur/pat pat) ((recur pat in-hole) state))
+    (define (generate-nt/built-in undecorated decorated)
+      (if ((is-nt? lang) undecorated)
+          (generate-nt undecorated decorated bound-vars size in-hole state)
+          (recur/pat undecorated)))
     
     (match pat
       [`number (values ((next-number-decision) random-numbers) state)]
@@ -249,21 +251,22 @@ To do a better job of not generating programs with free variables,
       [`any
        (let-values ([(lang nt) ((next-any-decision) lang)])
          (values (generate* lang nt size attempt decisions@) state))]
-      [(? (λ (p) (is-nt? lang p)))
-       (generate-nt pat fvt-id bound-vars size in-hole state)]
+      [(? (is-nt? lang))
+       (generate-nt pat pat bound-vars size in-hole state)]
       [(and (? symbol?) (app symbol->string (regexp named-nt-rx (list _ nt))))
        (let* ([undecorated (string->symbol nt)]
               [none (gensym)]
               [prior (hash-ref (state-env state) pat none)])
          (if (eq? prior none)
-             (let-values 
-                 ([(term state) ((recur undecorated in-hole pat) state)])
+             (let-values ([(term state) (generate-nt/built-in undecorated pat)])
                (values term (set-env state pat term)))
              (values prior state)))]
       [(struct mismatch (name group))
-       (let ([nt (string->symbol (cadr (regexp-match mismatch-nt-rx (symbol->string group))))])
-         (let-values ([(term state) ((recur nt in-hole name) state)])
+       (let ([undecorated (string->symbol (cadr (regexp-match mismatch-nt-rx (symbol->string group))))])
+         (let-values ([(term state) (generate-nt/built-in undecorated name)])
            (values term (set-env state pat term))))]
+      [`(cross ,(? symbol? cross-nt))
+       (generate-nt cross-nt #f bound-vars size in-hole state)]
       [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)]
       [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
        (let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)])
@@ -323,55 +326,58 @@ To do a better job of not generating programs with free variables,
       term))
 
 ;; find-base-cases : compiled-language -> hash-table
-  (define (find-base-cases lang)
-    (define nt-table (make-hasheq))
-    (define changed? #f)
-    (define (nt-get nt) (hash-ref nt-table nt 'inf))
-    (define (nt-set nt new) 
-      (let ([old (nt-get nt)])
-        (unless (equal? new old)
-          (set! changed? #t)
-          (hash-set! nt-table nt new))))
-    
-    (define (process-nt nt)
-      (nt-set (nt-name nt) (apply min/f (map process-rhs (nt-rhs nt)))))
-    
-    (define (process-rhs rhs)
-      (let ([nts (rhs->nts (rhs-pattern rhs))])
-        (if (null? nts) 
-            0
-            (add1/f (apply max/f (map nt-get nts))))))
-    
-    ;; rhs->path : pattern -> (listof symbol)
-    ;; determines all of the non-terminals in a pattern
-    (define (rhs->nts pat)
-      (let ([nts '()])
-        (let loop ([pat pat])
-          (match pat
-            [(? symbol? pat)
-             (when (is-nt? lang (symbol->nt pat))
-               (set! nts (cons (symbol->nt pat) nts)))]
-            [`() (void)]
-            [`(,a ,'... . ,b) 
-             (loop a)
-             (loop b)]
-            [`(,a . ,b)
-             (loop a)
-             (loop b)]
-            [_ (void)]))
-        nts))
-    
+(define (find-base-cases lang)
+  (define nt-table (make-hasheq))
+  (define changed? #f)
+  (define (nt-get nt) (hash-ref nt-table nt 'inf))
+  (define (nt-set nt new) 
+    (let ([old (nt-get nt)])
+      (unless (equal? new old)
+        (set! changed? #t)
+        (hash-set! nt-table nt new))))
+  
+  (define (process-nt nt)
+    (nt-set (nt-name nt) (apply min/f (map process-rhs (nt-rhs nt)))))
+  
+  (define (process-rhs rhs)
+    (let ([nts (rhs->nts (rhs-pattern rhs))])
+      (if (null? nts) 
+          0
+          (add1/f (apply max/f (map nt-get nts))))))
+  
+  ;; rhs->path : pattern -> (listof symbol)
+  ;; determines all of the non-terminals in a pattern
+  (define (rhs->nts pat)
+    (let ([nts '()])
+      (let loop ([pat pat])
+        (match pat
+          [(? symbol? pat)
+           (when ((is-nt? lang) (symbol->nt pat))
+             (set! nts (cons (symbol->nt pat) nts)))]
+          [`(cross ,(? symbol? x-nt))
+           (set! nts (cons x-nt nts))]
+          [`() (void)]
+          [`(,a ,'... . ,b) 
+           (loop a)
+           (loop b)]
+          [`(,a . ,b)
+           (loop a)
+           (loop b)]
+          [_ (void)]))
+      nts))
+  
+  (let ([nts (append (compiled-lang-lang lang) (compiled-lang-cclang lang))])
     (let loop ()
       (set! changed? #f)
-      (for-each process-nt (compiled-lang-lang lang))
+      (for-each process-nt nts)
       (when changed?
         (loop)))
     
     (let ([ht (make-hash)])
       (for-each
        (λ (nt) (hash-set! ht (nt-name nt) (map process-rhs (nt-rhs nt))))
-       (compiled-lang-lang lang))
-      ht))
+       nts)
+      ht)))
 
 (define min/f
   (case-lambda
@@ -394,7 +400,7 @@ To do a better job of not generating programs with free variables,
 (define (add1/f a) (if (eq? a 'inf) 'inf (+ a 1)))
 
 ;; is-nt? : compiled-lang any -> boolean
-(define (is-nt? lang x)
+(define ((is-nt? lang) x)
   (and (hash-ref (compiled-lang-ht lang) x #f) #t))
 
 (define named-nt-rx #rx"^([^_]+)_[^_]*$")
@@ -419,7 +425,7 @@ To do a better job of not generating programs with free variables,
 ;; parse-pattern : pattern -> parsed-pattern
 ;; Turns "pat ...", "pat ..._id", and "pat ..._!_id" into ellipsis structs
 ;; and "nt_!_id" into mismatch structs.
-(define (parse-pattern pattern)
+(define (parse-pattern pattern [cross? #f])
   (define (recur pat vars)
     (match pat
       [(and (? symbol?) (app symbol->string (regexp named-nt-rx)))
@@ -450,6 +456,9 @@ To do a better job of not generating programs with free variables,
                      [(vars) (append (list* class mismatch sub-pat-vars) vars)]
                      [(rest-parsed vars) (recur rest vars)])
          (values (cons seq rest-parsed) vars))]
+      [(and (? (λ (_) (not cross?))) `(cross ,(and (? symbol?) nt)))
+       (let ([nt-str (symbol->string nt)])
+         (values `(cross ,(string->symbol (string-append nt-str "-" nt-str))) vars))]
       [(cons first rest)
        (let-values ([(first-parsed vars) (recur first vars)])
          (let-values ([(rest-parsed vars) (recur rest vars)])
@@ -460,16 +469,15 @@ To do a better job of not generating programs with free variables,
 
 ;; parse-language: compiled-lang -> compiled-lang
 (define (parse-language lang)
+  (define ((parse-nt cross?) nt)
+    (make-nt (nt-name nt) (map (parse-rhs cross?) (nt-rhs nt))))
+  (define ((parse-rhs cross?) rhs)
+    (make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs) cross?))
+              (rhs-var-info rhs)))
   (struct-copy 
    compiled-lang lang
-   [lang
-    (map (λ (nt) 
-           (make-nt (nt-name nt)
-                    (map (λ (rhs) 
-                           (make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs))) 
-                                     (rhs-var-info rhs)))
-                         (nt-rhs nt))))
-         (compiled-lang-lang lang))]))
+   [lang (map (parse-nt #f) (compiled-lang-lang lang))]
+   [cclang (map (parse-nt #t) (compiled-lang-cclang lang))]))
 
 ;; unparse-pattern: parsed-pattern -> pattern
 (define unparse-pattern
diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss
index 36dabcc339..a41fd809d0 100644
--- a/collects/redex/private/tl-test.ss
+++ b/collects/redex/private/tl-test.ss
@@ -690,6 +690,11 @@
   (test-syn-err (define-language bad-lang1 (e name)) #rx"name")
   (test-syn-err (define-language bad-lang2 (name x)) #rx"name")
   (test-syn-err (define-language bad-lang3 (x_y x)) #rx"x_y")
+  (test-syn-err (define-language bad-lang4 (a 1 2) (b)) #rx"no productions")
+  (test-syn-err (let ()
+                  (define-language good-lang (a 1 2))
+                  (define-extended-language bad-lang5 good-lang (a) (b 2)))
+                #rx"no productions")
   
   ;; expect union with duplicate names to fail
   (test (with-handlers ((exn? (λ (x) 'passed)))