diff --git a/collects/syntax-color/private/rb-token-tree.rkt b/collects/syntax-color/private/rb-token-tree.rkt
new file mode 100644
index 0000000000..fb6b864b5d
--- /dev/null
+++ b/collects/syntax-color/private/rb-token-tree.rkt
@@ -0,0 +1,478 @@
+#lang racket/base
+
+;; rbtree implementation of the token-tree% interface.
+;;
+;; We have to adapt a few things:
+;;
+;;     * rb-trees don't move around their root on search, so we need
+;;       to keep a separate "focus".
+;;
+;;     * We use rb:nil, but the original client uses #f to indicate
+;;     empty trees.
+
+;; For speed, we use the uncontracted forms in red-black.rkt.
+(require (prefix-in rb: (submod "red-black.rkt" uncontracted))
+         racket/class)
+
+
+(provide token-tree% 
+         insert-first! 
+         insert-last!
+         insert-last-spec!
+         insert-first-spec!
+         node? node-token-length node-token-data 
+         node-left-subtree-length node-left node-right)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-local-member-name
+  get-rb
+  set-rb!
+  set-focus!)
+
+
+(define token-tree%
+  (class object%
+    (init (length #f) (data #f))
+
+     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; state initialization
+    (define rb (rb:new-tree))  ;; rb is an instance of rb:tree.
+    (define focus rb:nil)      ;; focus is an instance of rb:node.
+    (define focus-pos -1)       ;; optimization: the position of the focus.
+    (when length
+      (rb:insert-last/data! rb data length)
+      (set-focus! (rb:tree-root rb) 0))
+    (super-new)
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+    ;; rb->token-tree: rb:tree -> token-tree%
+    ;; Wraps a red-black tree into a token tree.
+    (define (rb->token-tree an-rb)
+      (define t (new token-tree%))
+      (send t set-rb! an-rb)
+      (send t set-focus!
+            (rb:tree-first an-rb) 
+            (if (rb:nil-node? (rb:tree-root an-rb)) -1 0))
+      t)
+
+
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; private methods:
+    (define/public (get-rb) 
+      rb)
+
+    (define/public (set-rb! new-rb) 
+      (set! rb new-rb))
+
+    (define/public (set-focus! new-focus new-pos) 
+      (set! focus new-focus)
+      (set! focus-pos new-pos))
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; public methods:
+
+    ;; reset-tree: -> void
+    ;; Empty the contents of the tree.
+    (define/public (reset-tree)
+      (rb:reset! rb)
+      (set-focus! rb:nil -1))
+
+    (define/public (get-root)
+      (nil->false focus))
+    
+    (define/public (is-empty?)
+      (rb:nil-node? focus))
+
+    (define/public (get-root-length)
+      (cond
+        [(rb:nil-node? focus)
+         0]
+        [else
+         (rb:node-self-width focus)]))
+
+    (define/public (get-root-data)
+      (cond
+        [(rb:nil-node? focus)
+         #f]
+        [else
+         (rb:node-data focus)]))
+
+    (define/public (get-root-start-position)
+      (cond
+        [(rb:nil-node? focus)
+         0]
+        [else
+         focus-pos]))
+
+    (define/public (get-root-end-position)
+      (cond
+        [(rb:nil-node? focus)
+         0]
+        [else
+         (+ focus-pos (rb:node-self-width focus))]))
+ 
+    (define/public (add-to-root-length inc)
+      (unless (rb:nil-node? focus)
+        (rb:update-node-self-width! focus (+ (rb:node-self-width focus) inc))))
+
+    (define/public (search! key-position)
+      ;; TODO: add unit test that makes sure search works.  If there is no
+      ;; token, the original just jumps to the closest node.
+      (unless (rb:nil-node? focus)
+        (cond
+         [(<= key-position 0)
+          (set-focus! (rb:tree-first rb)
+                      (first-pos rb))]
+         [(>= key-position (rb:node-subtree-width (rb:tree-root rb)))
+          (set-focus! (rb:tree-last rb)
+                      (last-pos rb))]
+         [else
+          (cond
+           ;; optimization: are we already where we're searching?
+           [(= focus-pos key-position)
+            (void)]
+           ;; optimization: are we searching for the immediate successor?
+           [(= key-position (+ focus-pos (rb:node-self-width focus)))
+            (define succ (rb:successor focus))
+            (cond [(rb:nil-node? succ)
+                   (void)]
+                  [else
+                   (set-focus! succ key-position)])]
+           [else
+            (define-values (found-node residue) (rb:search/residual rb key-position))
+            (set-focus! found-node (- key-position residue))])])))
+    
+
+    ;; last-pos: rb:tree -> natural
+    ;; Returns the starting position of the last element in rb.
+    (define (last-pos rb)
+      (cond
+       [(rb:nil-node? (rb:tree-root rb))
+        -1]
+       [else
+        (define pos (- (rb:node-subtree-width (rb:tree-root rb))
+                       (rb:node-self-width (rb:tree-last rb))))
+        pos]))
+
+    (define (first-pos rb)
+      (cond
+       [(rb:nil-node? (rb:tree-root rb))
+        -1]
+       [else
+        0]))
+
+         
+    (define/public (search-max!)
+      (unless (rb:nil-node? focus)
+        (set-focus! (rb:tree-last rb) (last-pos rb))))
+    
+    (define/public (search-min!)
+      (unless (rb:nil-node? focus)
+        (set-focus! (rb:tree-first rb) 0)))
+
+    (define/public (remove-root!)
+      (unless (rb:nil-node? focus)
+        (define node-to-delete focus)
+        (define pred (rb:predecessor focus))
+        (cond [(rb:nil-node? pred)
+               (define succ (rb:successor focus))
+               (set-focus! succ (if (rb:nil-node? succ) -1 0))]
+              [else
+               (set-focus! pred (- focus-pos (rb:node-self-width pred)))])
+        (rb:delete! rb node-to-delete)))
+      
+
+
+    ;; split/data: natural -> (values natural natural token-tree% token-tree% boolean)
+    ;; Splits the tree into 2 trees, invalidating our own to nil.
+    ;;
+    ;; The first two returned values represent the start and end
+    ;; position of the token(s) at pos.  The next two values represent
+    ;; the tokens before pos and after pos, not including any tokens
+    ;; adjacent to pos.
+    ;;
+    ;; Thus if pos is on a token boundary, 2 tokens will be dropped.
+    ;;
+    ;; In this case, the start will be for the first dropped
+    ;; token and the stop will be for the second.
+    ;;
+    ;; The last value is the data at the searched position.
+    ;;
+    ;; The two tree's foci will be at the edges adjacent to where the split occurred.
+    (define/public (split/data pos)
+      (cond
+        [(rb:nil-node? focus)
+         (values 0 0 (new token-tree%) (new token-tree%) #f)]
+        [else
+
+         ;; We have a few cases to check for:
+         ;; Is the pivot on the edge boundary of the first or last tokens?
+         ;; Is the pivot on the boundary between two tokens?
+         (cond
+
+          ;; Case 1.
+          ;; At the start-edge of the first token?
+          [(<= pos 0)
+           ;; If so, just delete the first token.
+           (define first-token (rb:tree-first rb))
+           (rb:delete! rb first-token)
+           (define right-tree (rb->token-tree rb))
+           (send right-tree set-focus! 
+                 (rb:tree-first rb)
+                 (first-pos rb))
+           (set-focus! rb:nil -1)
+           (values 0 
+                   (rb:node-self-width first-token)
+                   (new token-tree%)
+                   right-tree 
+                   (rb:node-data first-token))]
+
+          ;; Case 2.
+          ;; At the end-edge of the last token?
+          [(>= pos (rb:node-subtree-width (rb:tree-root rb)))
+           (define total-width (rb:node-subtree-width (rb:tree-root rb)))
+           (define last-token (rb:tree-last rb))
+
+           (rb:delete! rb last-token)
+           (define left-tree (rb->token-tree rb))
+           (send left-tree set-focus! (rb:tree-last rb) (last-pos rb))
+           (set-focus! rb:nil -1)
+           (values (- total-width (rb:node-self-width last-token))
+                   total-width
+                   left-tree 
+                   (new token-tree%) 
+                   (rb:node-data last-token))]
+
+          [else
+           ;; Otherwise, pos is somewhere inside the range, and we're
+           ;; guaranteed to find the pivot somewhere.
+           (search! pos)
+           (cond
+            ;; If the residue after searching is zero, then we're right
+            ;; on the boundary between two tokens, and must delete both.
+            [(= focus-pos pos)
+             (define pivot-node focus)
+             (define-values (left right) (rb:split! rb pivot-node))
+
+             ;; We know the left is non-empty, since otherwise we would
+             ;; have hit case 1.
+             (define left-last (rb:tree-last left))
+             (rb:delete! left left-last)
+             (set-focus! rb:nil -1)
+             (define-values (left-tree right-tree)
+               (values (rb->token-tree left)
+                       (rb->token-tree right)))
+             (send left-tree set-focus! (rb:tree-last left) (last-pos left))
+             (send right-tree set-focus! (rb:tree-first right) (first-pos right))
+             (values (- pos (rb:node-self-width left-last))
+                     (+ pos (rb:node-self-width pivot-node))
+                     left-tree
+                     right-tree
+                     (rb:node-data pivot-node))]
+
+            [else
+             ;; Otherwise, the position is inside just one token.
+             (define pivot-node focus)
+             (define start-pos focus-pos)
+             (define end-pos (+ start-pos (rb:node-self-width pivot-node)))
+             (define-values (left right) (rb:split! rb pivot-node))
+             (set-focus! rb:nil -1)
+             (define-values (left-tree right-tree)
+               (values (rb->token-tree left)
+                       (rb->token-tree right)))
+             (send left-tree set-focus! (rb:tree-last left) (last-pos left))
+             (send right-tree set-focus! (rb:tree-first right) (first-pos right))
+             (values start-pos end-pos 
+                     left-tree
+                     right-tree
+                     (rb:node-data pivot-node))])])]))
+    
+
+
+    (define/public (split pos)
+      (define-values (start-pos end-pos left-tree right-tree data)
+        (split/data pos))
+      (values start-pos end-pos left-tree right-tree))
+
+
+
+    ;; split-after: -> token-tree% * token-tree%
+    ;; splits the tree into 2 trees, setting root to #f
+    ;; returns a tree including the focus and its predecessors
+    ;; then the focus's successors
+    ;;
+    ;; The left tree's focus is defined to be at its last,
+    ;; and the right tree's focus is defined to be at its first.
+    ;;
+    ;; FIXME: add test case checking semantics of focus after a split-after.
+    (define/public (split-after)
+      (cond
+        [(rb:nil-node? focus)
+         (values (new token-tree%) (new token-tree%))]
+        [else
+         (define-values (left right) (rb:split! rb focus))
+         (rb:insert-last! left focus)
+         (set-focus! rb:nil -1)
+         (define-values (left-tree right-tree)
+           (values (rb->token-tree left) (rb->token-tree right)))
+         (send right-tree set-focus! (rb:tree-first right) (first-pos right))
+         (send left-tree set-focus! (rb:tree-last left) (last-pos left))
+         (values left-tree right-tree)]))
+        
+
+    ;; split-before: -> token-tree% * token-tree%
+    ;; splits the tree into 2 trees, setting root to #f
+    ;; returns the focus's predecessors, and then a tree including the focus
+    ;; and its successors.
+    ;;
+    ;; The left tree's focus is defined to be at its last,
+    ;; and the right tree's focus is defined to be at its first.
+    ;;
+    ;; FIXME: add test case checking semantics of focus after a split-before.
+    (define/public (split-before)
+      (cond
+        [(rb:nil-node? focus)
+         (values (new token-tree%) (new token-tree%))]
+        [else
+         (define-values (left right) (rb:split! rb focus))
+         (rb:insert-first! right focus)
+         (set-focus! rb:nil -1)
+         (define-values (left-tree right-tree)
+           (values (rb->token-tree left) (rb->token-tree right)))
+         (send left-tree set-focus! (rb:tree-last left) (last-pos left))
+         (send right-tree set-focus! (rb:tree-first right) (first-pos right))
+         (values left-tree right-tree)]))
+
+
+    (define/public (to-list)
+      (cond
+        [(rb:nil-node? focus) '()]
+        [else
+         (reverse 
+          (rb:tree-fold-inorder rb
+                                (lambda (n acc)
+                                  (cons (vector (rb:node-self-width n)
+                                                (node-left-subtree-length n)
+                                                (rb:node-data n))
+                                        acc))
+                                '()))]))
+
+    (define/public (for-each f)
+      (cond
+        [(rb:nil-node? focus)
+         (void)]
+        [else
+         (rb:tree-fold-inorder rb
+                               (lambda (n acc)
+                                 (f acc 
+                                    (rb:node-self-width n)
+                                    (rb:node-data n))
+                                 (+ acc (rb:node-self-width n)))
+                               0)]))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;; insert-first!: token-tree% * token-tree% -> void
+;; insert tree2 into tree1 as the first thing.
+;;
+;; Effects:
+;;
+;; 1.  tree1 will contain the contents of tree2 + tree1
+;; 2.  tree2 will be reset to the empty tree.
+;;
+;; I'm not exactly sure if the behavior of where the tree is focused
+;; is something defined.
+(define (insert-first! tree1 tree2)
+  (define-values (rb1 rb2)
+    (values (send tree1 get-rb) (send tree2 get-rb)))
+  (define rb-joined (rb:join! rb2 rb1))
+  (send tree1 set-rb! rb-joined)
+  (send tree1 set-focus!
+        (rb:tree-root rb-joined) 
+        (node-left-subtree-length (rb:tree-root rb-joined)))
+  (send tree2 reset-tree))
+
+
+;; insert-last!: token-tree% * token-tree%  -> void
+;; insert tree2 into tree1 as the last thing.
+;;
+;; Effects:
+;;
+;; 1.  tree1 will contain the contents of tree1 + tree2
+;; 2.  tree2 will be reset to the empty tree.
+;;
+;; I'm not exactly sure if the behavior of where the tree is focused
+;; is something defined.
+(define (insert-last! tree1 tree2)
+  (define-values (rb1 rb2)
+    (values (send tree1 get-rb) (send tree2 get-rb)))
+  (define rb-joined (rb:join! rb1 rb2))
+  (send tree1 set-rb! rb-joined)
+  (send tree1 set-focus! 
+        (rb:tree-root rb-joined) 
+        (node-left-subtree-length (rb:tree-root rb-joined)))
+  (send tree2 reset-tree))
+
+
+
+;; insert-last-spec!: tree natural any -> void
+;; Inserts content at the end of the tree.
+;;
+;; I'm not exactly sure if the behavior of where the tree is focused
+;; is something defined.
+(define (insert-last-spec! tree length data)
+  ;; TODO: add unit test that makes sure insert-last-spec! works.  It's missing
+  ;; from the test suite.
+  (define the-rb (send tree get-rb))
+  (rb:insert-last/data! the-rb data length)
+  (send tree set-focus!
+        (rb:tree-root the-rb) 
+        (node-left-subtree-length (rb:tree-root the-rb))))
+
+
+;; insert-first-spec!: tree natural any -> void
+;; Inserts content at the beginning of the tree.
+(define (insert-first-spec! tree length data)
+  ;; TODO: add unit test that makes sure insert-last-spec! works.  It's missing
+  ;; from the test suite.
+  (define the-rb (send tree get-rb))
+  (rb:insert-first/data! the-rb data length)
+  (send tree set-focus! 
+        (rb:tree-root the-rb)
+        (node-left-subtree-length (rb:tree-root the-rb))))
+
+
+
+(define node? 
+  (procedure-rename rb:node? 'node?))
+(define node-token-data
+  (procedure-rename rb:node-data 'node-token-data))
+(define node-token-length
+  (procedure-rename rb:node-self-width 'node-token-length))
+(define (node-left-subtree-length n)
+  (rb:node-subtree-width (rb:node-left n)))
+
+(define (node-left n)
+  (cond [(eq? n #f) 
+         #f]
+        [else
+         (nil->false (rb:node-left n))]))
+
+(define (node-right n)
+  (cond [(eq? n #f) 
+         #f]
+        [else
+         (nil->false (rb:node-right n))]))
+
+(define-syntax-rule (nil->false n)
+  (if (eq? n rb:nil)
+      #f
+      n))
diff --git a/collects/syntax-color/private/red-black.rkt b/collects/syntax-color/private/red-black.rkt
index 277b0fd499..7a28d6eb15 100644
--- a/collects/syntax-color/private/red-black.rkt
+++ b/collects/syntax-color/private/red-black.rkt
@@ -54,6 +54,7 @@
 
 (provide [contract-out 
           [tree? (any/c . -> . boolean?)]
+
           [tree-root (tree? . -> . node?)]
           [tree-first (tree? . -> . node?)]
           [tree-last (tree? . -> . node?)]
@@ -87,14 +88,18 @@
           [insert-after/data! (tree? non-nil-node? any/c natural-number/c . -> . any)]
                        
           [delete! (->i ([t tree?] 
-                         [n (t) (non-nil-node-in-tree? t)])
+                         [n (t) (attached-in-tree/c t)])
                         [result any/c])]
-          [join! (tree? tree? . -> . tree?)]
-          [concat! (tree? singleton-node? tree? . -> . any)]
+          [join! (->i ([t1 tree?] [t2 (t1) (and/c tree? (not-eq?/c t1))])
+                      [result tree?])]
+          [rename public:concat! concat! 
+                  (->i ([t1 tree?] [n singleton-node?] [t2 (t1) (and/c tree? (not-eq?/c t1))])
+                       [result any/c])]
           [split! (->i ([t tree?] 
-                         [n (t) (non-nil-node-in-tree? t)])
+                         [n (t) (attached-in-tree/c t)])
                         (values [t1 tree?] [t2 tree?]))]
 
+          [reset! (tree? . -> . any)]
                        
           [search (tree? natural-number/c . -> . node?)]
           [search/residual (tree? natural-number/c . -> . (values node? natural-number/c))]
@@ -164,10 +169,12 @@
 
 
 
+;; attached-in-tree/c: tree -> contract
+;;
 ;; We use this function for contract checking with delete! and split!,
 ;; where the node being deleted must be in the tree in the first place.
-(define (non-nil-node-in-tree? t)
-  (flat-named-contract 'node-in-tree
+(define (attached-in-tree/c t)
+  (flat-named-contract 'attached-in-tree/c
                        (lambda (n)
                          (and (node? n)
                               (not (nil? n))
@@ -179,6 +186,15 @@
                                        (loop p)]))))))
 
 
+;; not-eq?/c: any -> flat-contract
+;; Returns a flat contract that checks that the value isn't eq? to x.
+(define (not-eq?/c x)
+  (flat-named-contract 'not-eq?/c
+                       (lambda (y)
+                         (not (eq? x y)))))
+
+
+
 
 ;; nil?: node -> boolean
 ;; Tell us if we're at the distinguished nil node.
@@ -308,6 +324,16 @@
 
 
 
+;; update-node-self-width!: node exact-nonnegative-integer -> void Updates
+;; the node's self width, and propagates that change up the tree.
+;; Internal note: do not confuse this with the similarly-named
+;; update-node-subtree-width, which does something different.
+(define (update-node-self-width! n w)
+  (set-node-self-width! n w)
+  (update-subtree-width-up-to-root! n))
+
+
+
 
 ;; insert-first!: tree (and/c (not nil?) node?) -> void
 ;; Insert node x as the first element in the tree.
@@ -577,6 +603,7 @@
                    (set-node-left! z nil)
                    (set-node-right! z nil)
                    (set-node-color! z red)
+                   (set-node-subtree-width! z (node-self-width z))
 
                    (values x y-original-color nil-parent)]
                   
@@ -591,6 +618,7 @@
                    (set-node-left! z nil)
                    (set-node-right! z nil)
                    (set-node-color! z red)
+                   (set-node-subtree-width! z (node-self-width z))
                    (values x y-original-color nil-parent)]
                   
                   ;; The hardest case is when z has non-nil left and right.
@@ -639,7 +667,8 @@
                      (set-node-left! z nil)
                      (set-node-right! z nil)
                      (set-node-color! z red)
- 
+                     (set-node-subtree-width! z (node-self-width z)) 
+
                      (values x y-original-color nil-parent))])])
     (cond [(eq? black y-original-color)
            (fix-after-delete! a-tree x nil-parent)]
@@ -841,9 +870,13 @@
 (define (join! t1 t2)
   (cond
     [(nil? (tree-root t2))
-     t1]
+     (define result (clone! t1))
+     (reset! t1)
+     result]
     [(nil? (tree-root t1))
-     t2]
+     (define result (clone! t2))
+     (reset! t2)
+     result]
     [else
      ;; First, remove element x from t2.  x will act as the
      ;; pivot point.
@@ -851,7 +884,31 @@
      (delete! t2 x)
      ;; Next, delegate to the more general concat! function, using
      ;; x as the pivot.
-     (concat! t1 x t2)]))
+     (public:concat! t1 x t2)]))
+
+
+
+;; public:concat!: tree node tree -> tree
+;; Joins t1, x, and t2 together, returning a new tree.
+;; Destructively modifies t1 and t2 to the empty trees.
+(define (public:concat! t1 x t2)
+  (define result (concat! t1 x t2))
+  (cond
+   [(eq? result t1)
+    (let ([result (clone! t1)])
+      (reset! t1)
+      (reset! t2)
+      result)]
+   [(eq? result t2)
+    (let ([result (clone! t2)])
+      (reset! t1)
+      (reset! t2)
+      result)]
+   [else
+    (reset! t1)
+    (reset! t2)
+    result]))
+
 
 
 ;; concat!: tree node tree -> tree
@@ -869,7 +926,6 @@
 ;; to how this is used by split!.
 (define (concat! t1 x t2)
   (cond
-
     [(nil? (tree-root t1))
      (set-node-left! x nil)
      (set-node-right! x nil)
@@ -893,7 +949,7 @@
      (define t1-bh (tree-bh t1))
      (define t2-bh (tree-bh t2))
      (cond
-      [(>= t1-bh t2-bh)     
+      [(>= t1-bh t2-bh) 
        ;; Note: even if tree-last is invalid, nothing gets hurt here.
        (set-tree-last! t1 (tree-last t2))
 
@@ -983,6 +1039,7 @@
 ;; split!: tree node -> (values tree tree)
 ;; Partitions the tree into two trees: the predecessors of x, and the
 ;; successors of x.  Also mutates x into a singleton node.
+;; Finally, modifies a-tree so it looks empty.
 ;;
 ;; Note: during the loop, the L and R trees do not necessarily have
 ;; a valid tree-first or tree-last.  I want to avoid recomputing
@@ -1000,6 +1057,10 @@
   (set-node-right! x nil)
   (set-node-left! x nil)
   (set-node-color! x red)
+  (set-node-subtree-width! x (node-self-width x))
+
+  ;; Clear out a-tree so it's unusable.
+  (reset! a-tree)
 
   ;; The loop walks the ancestors of x, adding the left and right
   ;; elements appropriately.
@@ -1047,13 +1108,27 @@
                (concat! R ancestor subtree))])])))
 
 
-;; update-node-self-width!: node exact-nonnegative-integer -> void Updates
-;; the node's self width, and propagates that change up the tree.
-;; Internal note: do not confuse this with the similarly-named
-;; update-node-subtree-width, which does something different.
-(define (update-node-self-width! n w)
-  (set-node-self-width! n w)
-  (update-subtree-width-up-to-root! n))
+;; reset!: tree -> void
+;; Resets a tree to empty.
+(define (reset! a-tree)
+  (set-tree-root! a-tree nil)
+  (set-tree-first! a-tree nil)
+  (set-tree-last! a-tree nil)
+  (set-tree-bh! a-tree 0))
+
+
+
+;; clone!: tree -> tree
+;; Shallow copy of the components of the tree.
+(define (clone! a-tree)
+  (tree (tree-root a-tree)
+        (tree-first a-tree)
+        (tree-last a-tree)
+        (tree-bh a-tree)))
+
+
+
+
 
 
 ;; force-tree-first!: tree -> void
@@ -1224,8 +1299,9 @@
            
            delete!
            join!
-           concat!
+           [rename-out [public:concat! concat!]]
            split!
+           reset!
 
            update-node-self-width!
            
@@ -1263,6 +1339,13 @@
            racket/list
            racket/class
            racket/promise)
+
+  (define (singleton-node? n)
+    (and (node? n)
+         (red? n)
+         (nil? (node-parent n))
+         (= (node-subtree-width n)
+            (node-self-width n))))
   
   
   ;; tree-items: tree -> (listof (list X number))
@@ -1658,7 +1741,19 @@
       (delete! t (search t 1))
       (check-rb-structure! t)
       (delete! t (search t 0))
+      (check-rb-structure! t))
+
+     
+     (test-case
+      "does deletion get subtree width right?"
+      (define t (new-tree))
+      (insert-last/data! t "hello" 5)
+      (insert-last/data! t "dyoo" 4)
+      (define r (tree-root t))
+      (delete! t r)
+      (insert-last! t r)
       (check-rb-structure! t))))
+      
   
   
   
@@ -1883,6 +1978,8 @@
       (define t1 (new-tree))
       (define t2 (new-tree))
       (define t1+t2 (join! t1 t2))
+      (check-true (nil? (tree-root t1)))
+      (check-true (nil? (tree-root t2)))
       (check-true (nil? (tree-root t1+t2)))
       (check-rb-structure! t1+t2))
      
@@ -1892,6 +1989,8 @@
       (define t2 (new-tree))
       (insert-last/data! t2 "hello" 5)
       (define t1+t2 (join! t1 t2))
+      (check-true (nil? (tree-root t1)))
+      (check-true (nil? (tree-root t2)))
       (check-equal? (map first (tree-items t1+t2))
                     '("hello"))
       (check-rb-structure! t1+t2))
@@ -1902,6 +2001,8 @@
       (define t2 (new-tree))
       (insert-last/data! t1 "hello" 5)
       (define t1+t2 (join! t1 t2))
+      (check-true (nil? (tree-root t1)))
+      (check-true (nil? (tree-root t2)))
       (check-equal? (map first (tree-items t1+t2))
                     '("hello"))
       (check-rb-structure! t1+t2))
@@ -1913,8 +2014,30 @@
       (insert-last/data! t1 "append" 5)
       (insert-last/data! t2 "this" 4)
       (define t1+t2 (join! t1 t2))
+      (check-true (nil? (tree-root t1)))
+      (check-true (nil? (tree-root t2)))
       (check-equal? (map first (tree-items t1+t2)) '("append" "this"))
       (check-rb-structure! t1+t2))
+
+
+     (test-case
+      "joining back and forth"
+      (define t (new-tree))
+      (for ([i (in-range 20)])
+        (define t2 (new-tree))
+        (insert-last/data! t2 i i)
+        (cond
+         [(even? i)
+          (set! t (join! t t2))
+          (check-true (nil? (tree-root t2)))]
+         [else
+          (set! t (join! t2 t))
+          (check-true (nil? (tree-root t2)))]))
+      (check-equal? (tree-items t)
+                    '((19 19) (17 17) (15 15) (13 13) (11 11) (9 9)
+                      (7 7) (5 5) (3 3) (1 1) (0 0) (2 2) (4 4) (6 6) 
+                      (8 8) (10 10) (12 12) (14 14) (16 16) (18 18)))
+      (check-rb-structure! t))
      
      
      (test-case
@@ -1925,6 +2048,8 @@
       (insert-last/data! t1 "and" 3)
       (insert-last/data! t2 "peace" 5)
       (define t1+t2 (join! t1 t2))
+      (check-true (nil? (tree-root t1)))
+      (check-true (nil? (tree-root t2)))
       (check-equal? (map first (tree-items t1+t2)) '("love" "and" "peace"))
       (check-rb-structure! t1+t2))
      
@@ -1936,6 +2061,8 @@
       (insert-last/data! t2 "and" 3)
       (insert-last/data! t2 "war" 3)
       (define t1+t2 (join! t1 t2))
+      (check-true (nil? (tree-root t1)))
+      (check-true (nil? (tree-root t2)))
       (check-equal? (map first (tree-items t1+t2)) '("love" "and" "war"))
       (check-rb-structure! t1+t2))
      
@@ -1951,6 +2078,8 @@
       (insert-last/data! t2 "years" 5)
       (insert-last/data! t2 "ago" 3)
       (define t1+t2 (join! t1 t2))
+      (check-true (nil? (tree-root t1)))
+      (check-true (nil? (tree-root t2)))
       (check-equal? (map first (tree-items t1+t2)) '("four" "score" "and" "seven" "years" "ago"))
       (check-rb-structure! t1+t2))
      
@@ -1990,6 +2119,9 @@
       (for ([word (in-list (string-split m3))])
         (insert-last/data! t3 word (string-length word)))
       (define speech-tree (join! (join! t1 t2) t3))
+      (check-true (nil? (tree-root t1)))
+      (check-true (nil? (tree-root t2)))
+      (check-true (nil? (tree-root t3)))
       (check-equal? (map first (tree-items speech-tree))
                     (string-split (string-append m1 " " m2 " " m3)))
       (check-rb-structure! speech-tree))))
@@ -2004,11 +2136,13 @@
       (insert-last/data! t "a" 1)
       (define n (search t 0))
       (define-values (l r) (split! t n))
+      (check-true (nil? (tree-root t)))
       (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '())
       (check-equal? (map first (tree-items r)) '())
       (check-rb-structure! l)
-      (check-rb-structure! r))
+      (check-rb-structure! r)
+      (check-rb-structure! t))
      
      (test-case
       "(a b) ---split-a--> () (b)"
@@ -2017,11 +2151,13 @@
       (insert-last/data! t "b" 1)
       (define n (search t 0))
       (define-values (l r) (split! t n))
+      (check-true (nil? (tree-root t)))
       (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '())
       (check-equal? (map first (tree-items r)) '("b"))
       (check-rb-structure! l)
-      (check-rb-structure! r))
+      (check-rb-structure! r)
+      (check-rb-structure! t))
      
      (test-case
       "(a b) ---split-b--> (a) ()"
@@ -2030,11 +2166,13 @@
       (insert-last/data! t "b" 1)
       (define n (search t 1))
       (define-values (l r) (split! t n))
+      (check-true (nil? (tree-root t)))
       (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '("a"))
       (check-equal? (map first (tree-items r)) '())
       (check-rb-structure! l)
-      (check-rb-structure! r))
+      (check-rb-structure! r)
+      (check-rb-structure! t))
      
      (test-case
       "(a b c) ---split-b--> (a) (c)"
@@ -2044,11 +2182,13 @@
       (insert-last/data! t "c" 1)
       (define n (search t 1))
       (define-values (l r) (split! t n))
+      (check-true (nil? (tree-root t)))
       (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '("a"))
       (check-equal? (map first (tree-items r)) '("c"))
       (check-rb-structure! l)
-      (check-rb-structure! r))
+      (check-rb-structure! r)
+      (check-rb-structure! t))
      
      (test-case
       "(a b c d) ---split-a--> () (b c d)"
@@ -2059,11 +2199,13 @@
       (insert-last/data! t "d" 1)
       (define n (search t 0))
       (define-values (l r) (split! t n))
+      (check-true (nil? (tree-root t)))
       (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '())
       (check-equal? (map first (tree-items r)) '("b" "c" "d"))
       (check-rb-structure! l)
-      (check-rb-structure! r))
+      (check-rb-structure! r)
+      (check-rb-structure! t))
      
      
      (test-case
@@ -2075,11 +2217,13 @@
       (insert-last/data! t "d" 1)
       (define n (search t 1))
       (define-values (l r) (split! t n))
+      (check-true (nil? (tree-root t)))
       (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '("a"))
       (check-equal? (map first (tree-items r)) '("c" "d"))
       (check-rb-structure! l)
-      (check-rb-structure! r))
+      (check-rb-structure! r)
+      (check-rb-structure! t))
      
      
      (test-case
@@ -2091,11 +2235,13 @@
       (insert-last/data! t "d" 1)
       (define n (search t 2))
       (define-values (l r) (split! t n))
+      (check-true (nil? (tree-root t)))
       (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '("a" "b"))
       (check-equal? (map first (tree-items r)) '("d"))
       (check-rb-structure! l)
-      (check-rb-structure! r))
+      (check-rb-structure! r)
+      (check-rb-structure! t))
      
      (test-case
       "(a b c d) ---split-d--> (a b c) ()"
@@ -2106,11 +2252,13 @@
       (insert-last/data! t "d" 1)
       (define n (search t 3))
       (define-values (l r) (split! t n))
+      (check-true (nil? (tree-root t)))
       (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '("a" "b" "c"))
       (check-equal? (map first (tree-items r)) '())
       (check-rb-structure! l)
-      (check-rb-structure! r))
+      (check-rb-structure! r)
+      (check-rb-structure! t))
      
      (test-case
       "(a ... z) ---split-m--> (a ... l) (n ...z)"
@@ -2120,11 +2268,13 @@
                            1))
       (define letter-m (search t 12))
       (define-values (l r) (split! t letter-m))
+      (check-true (nil? (tree-root t)))
       (check-true (singleton-node? letter-m))
       (check-equal? (map first (tree-items l)) '("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l"))
       (check-equal? (map first (tree-items r)) '("n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z"))
       (check-rb-structure! l)
-      (check-rb-structure! r))
+      (check-rb-structure! r)
+      (check-rb-structure! t))
      
      (test-case
       "(a ... z) ---split-n--> (a ... l) (n ...z)"
@@ -2136,12 +2286,14 @@
           (insert-last/data! t w 1))
         (define a-letter (search t n))
         (define-values (l r) (split! t a-letter))
+        (check-true (nil? (tree-root t)))
         (check-true (singleton-node? a-letter))
         (define-values (expected-l 1+expected-r) (split-at letters n))
         (check-equal? (map first (tree-items l)) expected-l)
         (check-equal? (map first (tree-items r)) (rest 1+expected-r))
         (check-rb-structure! l)
-        (check-rb-structure! r)))))
+        (check-rb-structure! r)
+        (check-rb-structure! t)))))
      
   
 
@@ -2313,6 +2465,7 @@
             ;; Delete a random word if we can.
             (define k (random (length known-model)))
             (delete-kth! k)))
+
         
         (define/public (insert-before/random!)
           (when (not (empty? known-model))
@@ -2369,6 +2522,7 @@
             (define offset (kth-offset k))
             (define node (search t offset))
             (define-values (l r) (split! t node))
+            (check-true (nil? (tree-root t)))
             (check-true (singleton-node? node))
             (set! t l)
             (send m2 catch-and-concat-at-front r (drop known-model (add1 k)))
@@ -2377,6 +2531,7 @@
         ;; private
         (define/public (catch-and-concat-at-front other-t other-known-model)
           (set! t (join! other-t t))
+          (check-true (nil? (tree-root other-t)))
           (set! known-model (append other-known-model known-model)))
 
         
@@ -2530,6 +2685,7 @@
           (time-acc 
            total-splitting-time
            (split! t pivot)))
+        (check-true (nil? (tree-root t)))
         (check-true (singleton-node? pivot))
         (define-values (expected-l 1+expected-r) (split-at elts n))
         (check-equal? (map first (tree-items l)) expected-l)
diff --git a/collects/syntax-color/red-black.scrbl b/collects/syntax-color/red-black.scrbl
index 59d8388353..8d81485fee 100644
--- a/collects/syntax-color/red-black.scrbl
+++ b/collects/syntax-color/red-black.scrbl
@@ -498,15 +498,14 @@ will become a singleton node.
 (tree-items t)
 ]
 
-Note that @racket[n] must be attached to tree @racket[t] or else an
-error will be raised:
+Note that @racket[n] must be attached to tree @racket[t] or else will raise
+a contract error:
 @interaction[#:eval my-eval
 (define t1 (new-tree))
-(define t2 (new-tree))
 (insert-first/data! t1 "tricky" 1)
-(insert-first/data! t2 "tricky" 1)
+(define n (new-node "tricky" 1))
 @code:comment{This should raise an error:}
-(delete! t1 (tree-root t2))
+(delete! t1 n)
 ]}
 
 
@@ -522,10 +521,17 @@ the elements in @racket[t2].
 @code:comment{Tier two characters:}
 (define t2 (new-tree))
 (for ([name (in-list '(yamcha tien chiaotzu bulma chi-chi
-                       oolong puar master-roshi))])
+                       roshi))])
   (insert-last/data! t2 name 1))
 (define tree-of-mighty-z-warriors (join! t1 t2))
-(tree-items tree-of-mighty-z-warriors)
+(map car (tree-items tree-of-mighty-z-warriors))
+]
+
+Note that @racket[t1] should not be @racket[eq?] to @racket[t2] or else will raise
+a contract error.
+@interaction[#:eval my-eval
+(define t1 (new-tree))
+(join! t1 t1)
 ]
 }
 
@@ -545,6 +551,14 @@ the elements in @racket[t2].
 (define poor-lost-circus-performers (concat! t1 x t2))
 (tree-items poor-lost-circus-performers)
 ]
+
+Note that @racket[t1] should not be @racket[eq?] to @racket[t2] or else will raise
+a contract error.
+@interaction[#:eval my-eval
+(define t1 (new-tree))
+(define n (new-node "a-node" 1))
+(concat! t1 n t1)
+]
 }
 
 
@@ -565,8 +579,8 @@ Afterwards, @racket[n] becomes a singleton node.
 (singleton-node? bob-node)
 ]
 
-Note that @racket[n] must be attached to tree @racket[t] or else
-an error will be raised.
+Note that @racket[n] must be attached to tree @racket[t] or else raise
+a contract error.
 @interaction[#:eval my-eval
 (define t (new-tree))
 (for ([name '(melchior caspar bob balthazar)])
@@ -578,6 +592,19 @@ an error will be raised.
 ]}
 
 
+@defproc[(reset! [t tree?]) void?]{
+Resets the contents of the tree to the empty state.
+@interaction[#:eval my-eval
+(define t (new-tree))
+(insert-last/data! t "house" 5)
+(insert-last/data! t "cleaning" 8)
+(tree-items t)
+(reset! t)
+(tree-items t)]
+}
+
+
+
 @defproc[(search [t tree?] [p natural-number/c]) node?]{
 Searches for the node at or within the given position @racket[p] of the tree.
 If the position is out of bounds, returns @racket[nil].