diff --git a/collects/2htdp/private/check-aux.ss b/collects/2htdp/private/check-aux.ss
index b0a404c4d7..ff81e7b968 100644
--- a/collects/2htdp/private/check-aux.ss
+++ b/collects/2htdp/private/check-aux.ss
@@ -59,7 +59,7 @@
 (define (mouse-event->parts e)
   (define x (- (send e get-x) INSET))
   (define y (- (send e get-y) INSET))
-  (list x y (cond [(send e button-down?) 'button-down]
+  (values x y (cond [(send e button-down?) 'button-down]
                   [(send e button-up?)   'button-up]
                   [(send e dragging?)    'drag]
                   [(send e moving?)      'move]
diff --git a/collects/2htdp/private/universe.ss b/collects/2htdp/private/universe.ss
index f1dd4b08bd..a1aaec2b45 100644
--- a/collects/2htdp/private/universe.ss
+++ b/collects/2htdp/private/universe.ss
@@ -146,7 +146,6 @@
         (close-output-port (iworld-out p))
         (close-input-port (iworld-in p))
         (send gui add (format "~a !! closed port" (iworld-name p)))
-        (set! iworlds (remq p iworlds))
         (pdisconnect p)
         (cont))
       
@@ -228,9 +227,9 @@
 (define-struct iworld (in out name info) #:transparent)
 ;; World = (make-iworld IPort OPort Symbol [Listof Sexp])
 
-(define iworld1 (make-iworld (current-input-port) (current-output-port) 'sk '()))
-(define iworld2 (make-iworld (current-input-port) (current-output-port) 'mf '()))
-(define iworld3 (make-iworld (current-input-port) (current-output-port) 'rf '()))
+(define iworld1 (make-iworld (current-input-port) (current-output-port) 'iworld1 '()))
+(define iworld2 (make-iworld (current-input-port) (current-output-port) 'iworld2 '()))
+(define iworld3 (make-iworld (current-input-port) (current-output-port) 'iworld3 '()))
 
 (define (iworld=? u v)
   (check-arg 'iworld=? (iworld? u) 'iworld "first" u)
diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss
index 6daa9e326f..94ceb20d58 100644
--- a/collects/2htdp/private/world.ss
+++ b/collects/2htdp/private/world.ss
@@ -49,8 +49,10 @@
     (class* object% (start-stop<%>)
       (inspect #f)
       (init-field
-       world0 ;; World
-       (tick K))      ;; (U (World -> World) (list (World -> World) Nat))
+       world0            ;; World
+       (name #f)         ;; (U #f Symbol)
+       (register #f)     ;; (U #f IP)
+       (tick K))         ;; (U (World -> World) (list (World -> World) Nat))
       
       (init
        (on-key K)        ;; World KeyEvent -> World 
@@ -59,8 +61,7 @@
        (on-draw #f)      ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
        (stop-when False) ;; World -> Boolean 
        (record? #f)      ;; Boolean 
-       (register #f))    ;; (U #f String (list String Symbol))
-      
+       )
       ;; -----------------------------------------------------------------------
       (field (world  world0))
       
@@ -79,39 +80,31 @@
       
       ;; -----------------------------------------------------------------------
       (field [*out* #f] ;; (U #f OutputPort), where to send messages to 
-             [*rec* (make-custodian)] ;; Custodian, monitor traffic
-             [host  (cond
-                      [(string? register) register]
-                      [(pair? register) (car register)]
-                      [else register])]
-             [name  (cond
-                      [(string? register) (gensym 'world)]
-                      [(pair? register) (second register)]
-                      [else register])])
+             [*rec* (make-custodian)]) ;; Custodian, monitor traffic)
       
       (define/private (register-with-host)
         (define FMTtry "unable to register with ~a after ~s tries")
         (define FMTcom "unable to register with ~a due to protocol problems")
         ;; try to register with the server n times 
-        (define (register n)
-          (printf "trying to register with ~a ...\n" host)
+        (define (do-register n)
+          (printf "trying to register with ~a ...\n" register)
           (with-handlers ((tcp-eof? 
                            (lambda (x) 
-                             (error 'register FMTcom host)))
+                             (error 'register FMTcom register)))
                           (exn:fail:network? 
                            (lambda (x)
                              (if (= n 1) 
-                                 (error 'register FMTtry host TRIES)
+                                 (error 'register FMTtry register TRIES)
                                  (begin (sleep PAUSE)
-                                        (register (- n 1)))))))
-            (define-values (in out) (tcp-connect host SQPORT))
+                                        (do-register (- n 1)))))))
+            (define-values (in out) (tcp-connect register SQPORT))
             (tcp-send out `(REGISTER ,(if name name (gensym 'world))))
             (if (eq? (tcp-receive in) 'okay) 
                 (values in out)
                 (raise tcp-eof))))
         ;; --- now register, obtain connection, and spawn a thread for receiving
         (parameterize ([current-custodian *rec*])
-          (define-values (in out) (register TRIES))
+          (define-values (in out) (do-register TRIES))
           (define dis (text "the universe disappeared" 11 'red))
           (define (RECEIVE)
             (sync 
@@ -168,7 +161,7 @@
                              (define/augment (on-close)  
                                (callback-stop! 'frame-stop)
                                (custodian-shutdown-all play-back:cust)))
-                           (label (if name (format "~a's World" name) "World"))
+                           (label (if name (format "~a" name) "World"))
                            (stretchable-width #f)
                            (stretchable-height #f)
                            (style '(no-resize-border metal))))
@@ -180,10 +173,12 @@
                    (when live (pkey (send e get-key-code))))
                  ;; deal with mouse events if live and within range 
                  (define/override (on-event e)
-                   (define l (mouse-event->parts e))
+                   (define-values (x y me) (mouse-event->parts e))
                    (when live
-                     (when (and (<= 0 (first l) width) (<= 0 (second l) height))
-                       (pmouse . l)))))
+                     (cond
+                       [(and (<= 0 x width) (<= 0 y height)) (pmouse x y me)]
+                       [(memq me '(leave enter)) (pmouse x y me)]
+                       [else (void)]))))
                (parent frame)
                (editor visible)
                (style '(no-hscroll no-vscroll))
@@ -269,7 +264,7 @@
       
       (define/public (start!)
         (when draw (show-canvas))
-        (when host (register-with-host)))
+        (when register (register-with-host)))
       
       (define/public (stop! w)
         (set! live #f)
diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss
index d26ef51db2..d4d4d80981 100644
--- a/collects/2htdp/universe.ss
+++ b/collects/2htdp/universe.ss
@@ -117,8 +117,12 @@
               (lambda (p)
                 (syntax-case p ()
                   [(host) #`(ip> #,tag host)]
-                  [(ip name) #`(list (ip> #,tag ip) (symbol> #,tag name))]
                   [_ (err tag p)])))]
+  [name (lambda (tag)
+          (lambda (p)
+            (syntax-case p ()
+              [(n) #`(symbol> #,tag n)]
+              [_ (err tag p)])))]
   [record? (lambda (tag)
              (lambda (p)
                (syntax-case p ()
diff --git a/collects/at-exp/lang/reader.ss b/collects/at-exp/lang/reader.ss
new file mode 100644
index 0000000000..36f3680347
--- /dev/null
+++ b/collects/at-exp/lang/reader.ss
@@ -0,0 +1,63 @@
+#lang scheme/base
+
+;; FIXME: This code was largely cut-and-pasted from the planet reader. 
+
+(require syntax/readerr
+         (only-in scribble/reader make-at-readtable))
+
+(provide (rename-out [at-read read]
+                     [at-read-syntax read-syntax])
+         get-info)
+
+(define (at-get in export-sym src line col pos mk-fail-thunk)
+  (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]
+        [bad (lambda (str eof?)
+               ((if eof?
+                    raise-read-eof-error 
+                    raise-read-error)
+                (format "bad language path following at-exp~a~a"
+                        (if str ": " "")
+                        (or str ""))
+                src line col pos
+                (let-values ([(line col pos2) (port-next-location in)])
+                  (and pos pos2 (- pos2 pos)))))])
+    (if (or (not spec)
+            (equal? (cadr spec) ""))
+        (bad #f (eof-object? (peek-byte in)))
+        (let ([parsed-spec
+               (let ([s (string->symbol 
+                         (string-append (bytes->string/latin-1 (cadr spec))
+                                        "/lang/reader"))])
+                 (if (module-path? s)
+                     s
+                     #f))])
+          (if parsed-spec
+              (begin
+                ((current-reader-guard) parsed-spec)
+                (dynamic-require parsed-spec export-sym (mk-fail-thunk spec)))
+              (bad (cadr spec) #f))))))
+
+(define (get-info in mod line col pos)
+  (at-get in 'get-info (object-name in) line col pos
+              (lambda (spec) (lambda () (lambda (tag) #f)))))
+
+(define at-readtable (make-at-readtable))
+
+(define (at-read-fn in read-sym args src mod line col pos)
+  (let ([r (at-get in read-sym src #|mod|# line col pos
+                   (lambda (spec) 
+                     (lambda ()
+                       (error 'at "cannot find reader for `#lang at ~a'" spec))))])
+    (parameterize ([current-readtable at-readtable])
+      (if (and (procedure? r)
+               (procedure-arity-includes? r (+ 5 (length args))))
+          (apply r (append args
+                           (list in mod line col pos)))
+          (apply r (append args (list in)))))))
+
+(define (at-read inp mod line col pos)
+  (at-read-fn inp 'read null (object-name inp) mod line col pos))
+
+(define (at-read-syntax src inp mod line col pos)
+  (at-read-fn inp 'read-syntax (list src) src mod line col pos))
+
diff --git a/collects/browser/browser.scrbl b/collects/browser/browser.scrbl
index a1a4bf0de6..5a9df3288a 100644
--- a/collects/browser/browser.scrbl
+++ b/collects/browser/browser.scrbl
@@ -7,6 +7,8 @@
                    browser/htmltext
                    browser/external
                    browser/tool
+                   scheme/base
+                   scheme/class
                    scheme/gui/base
                    net/url
                    framework/framework))
diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss
index 169f2e84bf..da8dc8ebc9 100644
--- a/collects/drscheme/private/module-language.ss
+++ b/collects/drscheme/private/module-language.ss
@@ -368,7 +368,7 @@
                                [callback void]))
     (define auto-text-panel (new group-box-panel%
                                  [parent new-parent]
-                                 [label "Auto-text"])) ;!! need string-constant
+                                 [label (string-constant module-language-auto-text)]))
     (define auto-text-text-box (new text-field%
                                     [parent auto-text-panel]
                                     [label #f]
@@ -490,7 +490,10 @@
               (format "~s" vec))))
     
     (define (get-auto-text)
-      (string-append (send auto-text-text-box get-value) "\n"))
+      (let ([str (send auto-text-text-box get-value)])
+        (cond
+          [(equal? str "") ""]
+          [else (string-append str "\n")])))
     
     (define (install-auto-text str)
       (send auto-text-text-box set-value (regexp-replace #rx"\n$" str "")))
@@ -500,6 +503,7 @@
     
     (install-collection-paths '(default))
     (update-buttons)
+    (install-auto-text default-auto-text)
     
     (case-lambda
       [()
diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss
index 42f3eca0ca..110cb23119 100644
--- a/collects/drscheme/private/rep.ss
+++ b/collects/drscheme/private/rep.ss
@@ -1462,11 +1462,10 @@ TODO
       (define/private (reset-logger-messages) 
         (set! logger-messages '())
         (update-logger-gui #f))
-
+      
       (define/private (update-logger-gui command)
-        (let ([frame (get-frame)])
-          (when frame
-            (send frame update-logger-window command))))
+        (let ([tab (send definitions-text get-tab)])
+          (send tab update-logger-window command)))
                         
       (define/private (new-planet-info tag package) 
         (let ([frame (get-frame)])
diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss
index 1c7d3dadc1..b53792251b 100644
--- a/collects/drscheme/private/unit.ss
+++ b/collects/drscheme/private/unit.ss
@@ -1,11 +1,6 @@
 #lang scheme/base
 #|
 
-logger: multiple tabs need to save logger visibilty state
-
-logger: thread for collecting user messages should be created under user auspicies.
-logger: what about thread for forwarding log messages?
-
 closing:
   warning messages don't have frame as parent.....
 
@@ -1326,6 +1321,9 @@ module browser threading seems wrong.
           (send frame show/hide-log log-visible?))
         (define/public-final (update-log)
           (send frame show/hide-log log-visible?))
+        (define/public-final (update-logger-window command)
+          (when (is-current-tab?)
+            (send frame update-logger-window command)))
         
         (define current-planet-status #f)
         (define/public-final (new-planet-status a b)
@@ -1412,6 +1410,7 @@ module browser threading seems wrong.
         ;; this is #f when the GUI has not been built yet. After
         ;; it becomes a tab-panel, it is always a tab-panel (altho the tab panel might not always be shown)
         (define logger-gui-tab-panel #f)
+        (define logger-gui-canvas #f)
         
         ;; logger-gui-text: (or/c #f (is-a?/c tab-panel%))
         ;; this is #f when the GUI has not been built or when the logging panel is hidden
@@ -1437,12 +1436,14 @@ module browser threading seems wrong.
                           l]
                          [show? 
                           (new-logger-text)
+                          (send logger-gui-canvas set-editor logger-gui-text)
                           (update-logger-window #f)
                           (send logger-menu-item set-label (string-constant hide-log))
                           (append (remq logger-panel l) (list logger-panel))]
                          [else
                           (send logger-menu-item set-label (string-constant show-log))
                           (set! logger-gui-text #f)
+                          (send logger-gui-canvas set-editor #f)
                           (remq logger-panel l)])))]
               [else
                (when show? ;; if we want to hide and it isn't built yet, do nothing
@@ -1455,7 +1456,8 @@ module browser threading seems wrong.
                              (λ (tp evt)
                                (update-logger-window #f))]))
                  (new-logger-text)
-                 (new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text])
+                 (set! logger-gui-canvas 
+                       (new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text]))
                  (send logger-menu-item set-label (string-constant hide-log))
                  (update-logger-window #f)
                  (send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))])
diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss
index 0e8256683e..370b2bb615 100644
--- a/collects/drscheme/syncheck.ss
+++ b/collects/drscheme/syncheck.ss
@@ -1499,7 +1499,7 @@ If the namespace does not, they are colored the unbound color.
              (λ (vars)
                (when jump-to-id
                  (for-each (λ (id)
-                             (let ([binding (identifier-binding id)])
+                             (let ([binding (identifier-binding id 0)])
                                (when (pair? binding)
                                  (let ([nominal-source-id (list-ref binding 3)])
                                    (when (eq? nominal-source-id jump-to-id)
@@ -1598,7 +1598,7 @@ If the namespace does not, they are colored the unbound color.
                  ;; tops are used here because a binding free use of a set!'d variable
                  ;; is treated just the same as (#%top . x).
                  (when (syntax-original? (syntax var))
-                   (if (identifier-binding (syntax var))
+                   (if (identifier-binding (syntax var) 0)
                        (add-id varrefs (syntax var))
                        (add-id tops (syntax var))))
                  
@@ -1813,11 +1813,23 @@ If the namespace does not, they are colored the unbound color.
             [unused-require-for-syntaxes (make-hash)]
             [unused-require-for-templates (make-hash)]
             [unused-require-for-labels (make-hash)]
+            [requires/phases (make-hash)]
+            [unused/phases (make-hash)]
             ;; there is no define-for-template form, thus no for-template binders
             [template-binders (make-id-set)]
             [label-binders (make-id-set)]
             [id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)])
         
+        (hash-set! requires/phases 0 requires)
+        (hash-set! requires/phases 1 require-for-syntaxes)
+        (hash-set! requires/phases -1 require-for-templates)
+        (hash-set! requires/phases #f require-for-labels)
+
+        (hash-set! unused/phases 0 unused-requires)
+        (hash-set! unused/phases 1 unused-require-for-syntaxes)
+        (hash-set! unused/phases -1 unused-require-for-templates)
+        (hash-set! unused/phases #f unused-require-for-labels)
+        
         (hash-for-each requires
                        (λ (k v) (hash-set! unused-requires k #t)))
         (hash-for-each require-for-syntaxes
@@ -1830,8 +1842,8 @@ If the namespace does not, they are colored the unbound color.
         (for-each (λ (vars) 
                     (for-each (λ (var)
                                 (when (syntax-original? var)
-                                  (color-variable var identifier-binding)
-                                  (document-variable var identifier-binding)
+                                  (color-variable var 0)
+                                  (document-variable var 0)
                                   (record-renamable-var rename-ht var)))
                               vars))
                   (append (get-idss high-binders)
@@ -1839,14 +1851,14 @@ If the namespace does not, they are colored the unbound color.
         
         (for-each (λ (vars) (for-each 
                              (λ (var)
-                               (color-variable var identifier-binding)
-                               (document-variable var identifier-binding)
+                               (color-variable var 0)
+                               (document-variable var 0)
                                (connect-identifier var
                                                    rename-ht
                                                    low-binders
-                                                   unused-requires
-                                                   requires
-                                                   identifier-binding
+                                                   unused/phases
+                                                   requires/phases
+                                                   0
                                                    user-namespace 
                                                    user-directory
                                                    #t))
@@ -1855,14 +1867,14 @@ If the namespace does not, they are colored the unbound color.
         
         (for-each (λ (vars) (for-each 
                              (λ (var)
-                               (color-variable var identifier-transformer-binding)
-                               (document-variable var identifier-transformer-binding)
+                               (color-variable var 1)
+                               (document-variable var 1)
                                (connect-identifier var
                                                    rename-ht
                                                    high-binders
-                                                   unused-require-for-syntaxes
-                                                   require-for-syntaxes
-                                                   identifier-transformer-binding
+                                                   unused/phases
+                                                   requires/phases
+                                                   1
                                                    user-namespace 
                                                    user-directory
                                                    #t))
@@ -1875,36 +1887,36 @@ If the namespace does not, they are colored the unbound color.
                                     (connect-identifier var
                                                         rename-ht
                                                         low-binders
-                                                        unused-requires
-                                                        requires
-                                                        identifier-binding
+                                                        unused/phases
+                                                        requires/phases
+                                                        0
                                                         user-namespace
                                                         user-directory
                                                         #f)
                                     (connect-identifier var
                                                         rename-ht
                                                         high-binders
-                                                        unused-require-for-syntaxes
-                                                        require-for-syntaxes
-                                                        identifier-transformer-binding
+                                                        unused/phases
+                                                        requires/phases
+                                                        1
                                                         user-namespace
                                                         user-directory
                                                         #f)
                                     (connect-identifier var
                                                         rename-ht
                                                         template-binders ;; dummy; always empty
-                                                        unused-require-for-templates
-                                                        require-for-templates
-                                                        identifier-template-binding
+                                                        unused/phases
+                                                        requires/phases
+                                                        -1
                                                         user-namespace
                                                         user-directory
                                                         #f)
                                     (connect-identifier var
                                                         rename-ht
                                                         label-binders ;; dummy; always empty
-                                                        unused-require-for-labels
-                                                        require-for-labels
-                                                        identifier-label-binding
+                                                        unused/phases
+                                                        requires/phases
+                                                        #f
                                                         user-namespace
                                                         user-directory
                                                         #f))
@@ -1952,7 +1964,7 @@ If the namespace does not, they are colored the unbound color.
     ;;                      id-set 
     ;;                      (union #f hash-table)
     ;;                      (union #f hash-table)
-    ;;                      (union identifier-binding identifier-transformer-binding)
+    ;;                      integer or 'lexical or #f
     ;;                      (listof id-set)
     ;;                      namespace
     ;;                      directory
@@ -1960,18 +1972,20 @@ If the namespace does not, they are colored the unbound color.
     ;;                   -> void
     ;; adds arrows and rename menus for binders/bindings
     (define (connect-identifier var rename-ht all-binders
-                                unused requires get-binding user-namespace user-directory actual?)
+                                unused/phases requires/phases
+                                phase-level user-namespace user-directory actual?)
       (connect-identifier/arrow var all-binders 
-                                unused requires get-binding user-namespace user-directory actual?)
+                                unused/phases requires/phases
+                                phase-level user-namespace user-directory actual?)
       (when (and actual? (get-ids all-binders var))
         (record-renamable-var rename-ht var)))
     
-    ;; id-level : identifier-binding-function identifier -> symbol
-    (define (id-level get-binding id)
+    ;; id-level : integer-or-#f-or-'lexical identifier -> symbol
+    (define (id-level phase-level id)
       (define (self-module? mpi)
         (let-values ([(a b) (module-path-index-split mpi)])
           (and (not a) (not b))))
-      (let ([binding (get-binding id)])
+      (let ([binding (identifier-binding id phase-level)])
         (cond [(list? binding)
                (if (self-module? (car binding))
                    'top-level
@@ -1987,19 +2001,23 @@ If the namespace does not, they are colored the unbound color.
     ;;                            boolean
     ;;                         -> void
     ;; adds the arrows that correspond to binders/bindings
-    (define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?)
+    (define (connect-identifier/arrow var all-binders unused/phases requires/phases phase-level user-namespace user-directory actual?)
       (let ([binders (get-ids all-binders var)])
         (when binders
           (for-each (λ (x)
                       (when (syntax-original? x)
-                        (connect-syntaxes x var actual? (id-level get-binding x))))
+                        (connect-syntaxes x var actual? (id-level phase-level x))))
                     binders))
         
-        (when (and unused requires)
-          (let ([req-path/pr (get-module-req-path (get-binding var))])
+        (when (and unused/phases requires/phases)
+          (let ([req-path/pr (get-module-req-path (identifier-binding var phase-level)
+                                                  phase-level)])
             (when req-path/pr
-              (let* ([req-path (car req-path/pr)]
-                     [id (cdr req-path/pr)]
+              (let* ([req-path (list-ref req-path/pr 0)]
+                     [id (list-ref req-path/pr 1)]
+                     [req-phase-level (list-ref req-path/pr 2)]
+                     [unused (hash-ref unused/phases req-phase-level)]
+                     [requires (hash-ref requires/phases req-phase-level)]
                      [req-stxes (hash-ref requires req-path (λ () #f))])
                 (when req-stxes
                   (hash-remove! unused req-path)
@@ -2018,7 +2036,7 @@ If the namespace does not, they are colored the unbound color.
                                                  (syntax-e var)
                                                  req-path))
                                 (connect-syntaxes req-stx var actual?
-                                                  (id-level get-binding var))))
+                                                  (id-level phase-level var))))
                             req-stxes))))))))
     
     (define (id/require-match? var id req-stx)
@@ -2043,15 +2061,23 @@ If the namespace does not, they are colored the unbound color.
     
     ;; get-module-req-path : binding -> (union #f (cons require-sexp sym))
     ;; argument is the result of identifier-binding or identifier-transformer-binding
-    (define (get-module-req-path binding)
+    (define (get-module-req-path binding phase-level)
       (and (pair? binding)
+           (or (not (number? phase-level))
+               (= phase-level
+                  (+ (list-ref binding 5)
+                     (list-ref binding 6))))
            (let ([mod-path (list-ref binding 2)])
              (cond
                [(module-path-index? mod-path)
                 (let-values ([(base offset) (module-path-index-split mod-path)])
-                  (cons base (list-ref binding 3)))]
+                  (list base
+                        (list-ref binding 3)
+                        (list-ref binding 5)))]
                [(symbol? mod-path)
-                (cons mod-path (list-ref binding 3))]))))
+                (list mod-path 
+                      (list-ref binding 3)
+                      (list-ref binding 5))]))))
     
     ;; color/connect-top : namespace directory id-set syntax -> void
     (define (color/connect-top rename-ht user-namespace user-directory binders var)
@@ -2064,11 +2090,11 @@ If the namespace does not, they are colored the unbound color.
         (if top-bound?
             (color var lexically-bound-variable-style-name)
             (color var error-style-name))
-        (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory #t)))
+        (connect-identifier var rename-ht binders #f #f 0 user-namespace user-directory #t)))
     
-    ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void
-    (define (color-variable var get-binding)
-      (let* ([b (get-binding var)]
+    ;; color-variable : syntax phase-level -> void
+    (define (color-variable var phase-level)
+      (let* ([b (identifier-binding var phase-level)]
              [lexical? 
               (or (not b)
                   (eq? b 'lexical)
@@ -2528,12 +2554,12 @@ If the namespace does not, they are colored the unbound color.
 ;                                                                                             
 
     
-    ;; document-variable : stx identifier-binding -> void
-    (define (document-variable stx get-binding)
+    ;; document-variable : stx phase-level -> void
+    (define (document-variable stx phase-level)
       (when (syntax-original? stx)
         (let ([defs-text (currently-processing-definitions-text)])
           (when defs-text
-            (let ([binding-info (get-binding stx)])
+            (let ([binding-info (identifier-binding stx phase-level)])
               (when (and (pair? binding-info)
                          (syntax-position stx)
                          (syntax-span stx))
diff --git a/collects/ffi/objc.scrbl b/collects/ffi/objc.scrbl
index 6a5d0c810a..a43ccb9713 100644
--- a/collects/ffi/objc.scrbl
+++ b/collects/ffi/objc.scrbl
@@ -2,7 +2,8 @@
 @(require scribble/manual
           scribble/eval
           (for-label scheme/base
-                     scheme/foreign
+                     scheme/contract
+                     (except-in scheme/foreign ->)
                      "private/objc-doc-unsafe.ss"))
 
 @(define objc-eval (make-base-eval))
diff --git a/collects/file/gif.ss b/collects/file/gif.ss
index 50750f5ed4..bc612b517a 100644
--- a/collects/file/gif.ss
+++ b/collects/file/gif.ss
@@ -14,8 +14,8 @@
  *****************************************************************************/
 |#
 
-#reader scribble/reader
-#lang scheme/base
+#lang at-exp scheme/base
+
 (require scheme/contract
          scribble/srcdoc
          (prefix-in octree: file/private/octree-quantize))
diff --git a/collects/framework/main.ss b/collects/framework/main.ss
index 13817b08a7..f3617ea598 100644
--- a/collects/framework/main.ss
+++ b/collects/framework/main.ss
@@ -1,5 +1,4 @@
-#reader scribble/reader
-#lang scheme/gui
+#lang at-exp scheme/gui
 
 (require mred/mred-unit
          mred/mred-sig
diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss
index cce4a88ec9..63711e616a 100644
--- a/collects/framework/private/text.ss
+++ b/collects/framework/private/text.ss
@@ -21,11 +21,7 @@ WARNING: printf is rebound in the body of the unit to always
          (prefix-in srfi1: srfi/1))
 (require setup/xref
          scribble/xref
-         scribble/struct
-         scribble/manual-struct
-         scribble/decode
-         scribble/basic
-         (prefix-in s/m: scribble/manual))
+         scribble/manual-struct)
 
 (import mred^
         [prefix icon: framework:icon^]
diff --git a/collects/games/chat-noir/5x5-empty-board.png b/collects/games/chat-noir/5x5-empty-board.png
deleted file mode 100644
index 126e4074d8..0000000000
Binary files a/collects/games/chat-noir/5x5-empty-board.png and /dev/null differ
diff --git a/collects/games/chat-noir/README b/collects/games/chat-noir/README
index 9ab6d8f03f..4d401ef9d8 100644
--- a/collects/games/chat-noir/README
+++ b/collects/games/chat-noir/README
@@ -2,44 +2,20 @@ These are the files for the literate version of Chat Noir.  The files
 not mentioned are actually in use for Chat Noir that you get via PLT
 Games.
 
- - chat-noir-literate.ss: the actual file containing the literate
-   description of the chat noir game, as well as the game itself, in
-   the chunks.
-
- - chat-noir-doc.ss: the wrapper file that you run via scribble to get
-   the rendered output.
-
- - literate-lang.ss: the language for running literate programs
-   (contains the tangler).
-
- - literate-reader.ss: the reader used for chat-noir-literate.ss to
-   put it into the literate-lang.ss.
-
-Files that begin with "literate" are the files that need to move to a
-scribble library, if this experiment is successful.
-
 Problems:
 
- - the code is not hyperlinked in the scribble output-- this is due to
-   the confusion about how the requires should work in the two modes.
+ - Run in the module language doesn't seem to work anymore, in that
+   definitions in the literate program don't show up in the REPL.
 
- - The char-noir-doc.ss file should be built when setup-plt runs on
-   this collection to build the documentation, ie, this file should
-   eventually be merged together with ../scribblings/chat-noir.scrbl.
+ - Need to make 'a-chunk' be a real macro, I expect. (used in
+   scribble/private/lp.ss)
 
  - hyperlink bound top-level identifiers to their bindings?
 
  - do unbound chunk ids signal syntax errors? How about unused ones?
 
- - toc entries should not be underlined.
-
- - identifiers in @chunks[] that refer to other chunks
-   should link to the (first) chunk definition. 
-
-   Or maybe just have a @chunkref[]?
-
 To document:
 
   @chunk
-  @chunkref
-  scribble/lp (when it is added).
\ No newline at end of file
+  scribble/lp (when it is added).
+  scribble/lp-include
diff --git a/collects/games/chat-noir/cat-distance-example.png b/collects/games/chat-noir/cat-distance-example.png
new file mode 100644
index 0000000000..a4c90eb07d
Binary files /dev/null and b/collects/games/chat-noir/cat-distance-example.png differ
diff --git a/collects/games/chat-noir/chat-noir-doc.ss b/collects/games/chat-noir/chat-noir-doc.ss
deleted file mode 100644
index ccbe5ad660..0000000000
--- a/collects/games/chat-noir/chat-noir-doc.ss
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang scribble/doc
-@(require "literate-doc-wrapper.ss")
-@(include "chat-noir-literate.ss")
diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss
index 661bb91bdb..1a500a1991 100644
--- a/collects/games/chat-noir/chat-noir-literate.ss
+++ b/collects/games/chat-noir/chat-noir-literate.ss
@@ -1,9 +1,14 @@
-#reader "literate-reader.ss"
+#lang scribble/lp
 
-@(require scheme/local scheme/list scheme/bool scheme/math
-          (for-syntax scheme/base))
+@(require (for-label scheme/math) ;; for 'pi' below
+          scheme/math
+          games/scribblings/common)
 
-@title{Chat Noir}
+@gametitle*["Chat Noir" "chat-noir" "Puzzle Game" #:style '(toc)]
+
+@author[(link "http://www.eecs.northwestern.edu/~robby" "Robby Findler")
+        (link "http://www.barzilay.org/" "Eli Barzilay")
+        (link "http://www.cs.utah.edu/~mflatt/" "Matthew Flatt")]
 
 The goal of Chat Noir is to stop the cat from escaping the board. Each
 turn you click on a circle, which prevents the cat from stepping on
@@ -11,45 +16,63 @@ that space, and the cat responds by taking a step. If the cat is
 completely boxed in and thus unable reach the border, you win. If the
 cat does reach the border, you lose.
 
+@play-margin-note["Chat Noir"]
+
 To get some insight into the cat's behavior, hold down the ``h''
 key. It will show you the cells that are on the cat's shortest path to
 the edge, assuming that the cell underneath the mouse has been
 blocked, so you can experiment to see how the shortest paths change
 by moving your mouse around.
 
-The game was inspired by this one the one at
+The game was inspired by the one at
 @link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game
 Design} and has essentially the same rules. It also inspired the final
 project for the introductory programming course at the University of
 Chicago in the fall of 2008.
 
 The remainder of this document explains the implementation of 
-the Chat Noir game.
+the Chat Noir game in a 
+@link["http://www.literateprogramming.com/"]{Literate Programming} style.
+
+@local-table-of-contents[]
 
 @section{Overview}
 
 Chat Noir is implemented using @link["http://www.htdp.org/"]{HtDP}'s universe
-library:  @schememodname[teachpack/2htdp/universe] 
+library:  @schememodname[2htdp/universe] 
 (although it only uses the ``world'' portions of that library). 
 The program is divided up into
 six parts: the world data definition, an implementation of breadth-first search,
 code that handles drawing of the world, code that handles user input,
 and some code that builds an initial world and starts the game.
- 
+
 @chunk[<main>
-       (require htdp/world lang/posn)
+       (require scheme/list scheme/math
+                lang/private/imageeq ;; don't like this require, but need it for image?
+                (for-syntax scheme/base))
+       (require 2htdp/universe lang/posn scheme/contract)
        <world>
-       <graph>
+       <breadth-first-search>
+       <board->graph>
+       <cats-path>
+       <drawing-the-cat>
+       <drawing>
+       <input>
        <tests>
-       <everything-else>]
+       <go>]
 
 Each section also comes with a series of test cases that are collected into the 
-@chunkref[<tests>] chunk at the end of the program.
+@scheme[<tests>]
+chunk at the end of the program.
 
 @chunk[<tests>
        <test-infrastructure>
-       <graph-tests>
-       <world-tests>]
+       <world-tests>
+       <board->graph-tests>
+       <breadth-first-search-tests>
+       <cats-path-tests>
+       <drawing-tests>
+       <input-tests>]
 
 Each test case uses either @scheme[test], a simple form that accepts two
 arguments and compares them with @scheme[equal?], or @scheme[test/set]
@@ -66,15 +89,25 @@ The main data structure for Chat Noir is @tt{world}. It comes with a few functio
 construct empty worlds and test cases for them.
 
 @chunk[<world> 
-       <data-definitions> <empty-world> <empty-board>]
+       <cell-struct> <world-struct> <empty-world> <empty-board> 
+       <blocked-cells> <block-cell>]
 
 @chunk[<world-tests>
-       <empty-world-test> <empty-board-test>]
+       <empty-world-test> <empty-board-test> <blocked-cells-tests>]
 
 The main structure definition is the @scheme[world] struct.
 
-@chunk[<data-definitions>
-(define-struct world (board cat state size mouse-posn h-down?)
+@chunk[<world-struct>
+(define-struct/contract world ([board (listof cell?)]
+                               [cat posn?]
+                               [state (or/c 'playing 
+                                            'cat-won
+                                            'cat-lost)]
+                               [size (and/c natural-number/c
+                                            odd?
+                                            (>=/c 3))]
+                               [mouse-posn (or/c #f posn?)]
+                               [h-down? boolean?])
   #:transparent)
 ]
 
@@ -109,58 +142,77 @@ It consists of a structure with six fields:
 
 A @scheme[cell] is a structure with two fields:
 
-@chunk[<data-definitions>
-       (define-struct cell (p blocked?) #:transparent)]
+@chunk[<cell-struct>
+       (define-struct/contract cell ([p posn?]
+                                     [blocked? boolean?])
+         #:transparent)]
        
-The first field contains a @scheme[posn] struct.  The coordinates of
-the posn indicate a position on the hexagonal grid.  The @tt{y} field
+The coordinates of
+the @scheme[posn] in the first field
+indicate a position on the hexagonal grid. 
+This program reprsents the hexagon grid as a series of rows that
+are offset from each other by 1/2 the size of the each cell.
+The @tt{y} field
 of the @scheme[posn] refers to the row of the cell, and the @tt{x}
 coordinate the position in the row.  This means that, for example,
-@scheme[(make-posn 0 1)] is centered above @scheme[(make-posn 1 0)]
-and @scheme[(make-posn 1 1)].  (See @scheme[cell-center-x] and
-@scheme[cell-center-y] below for the conversion of those positions to
-screen coordinates.)
+@scheme[(make-posn 1 0)] is centered above @scheme[(make-posn 1 0)]
+and @scheme[(make-posn 1 1)]. 
 
-The @tt{blocked?} field is a boolean indicating if the cell has been
+The boolean in the @tt{blocked?} field indicates if the cell has been
 clicked on, thus blocking the cat from stepping there.
 
 The @scheme[empty-board] function builds a list of @scheme[cell]s
 that correspond to an empty board. For example, here's what an empty
-3x3 board looks like, as a list of cells.
+7x7 board looks like, as a list of cells.
+
+@image["chat-noir/7x7-empty-board.png"]
+
+It contains 7 rows and, with the exception of the first and last rows,
+each row contains 7 cells. Notice how the even and odd rows are offset
+from each other by 1/2 of the size of the cell.
+The first and last row are missing their left-most cells
+because those cells are useless, from the perspective of the gameplay, 
+Specifically, all of the neighbors of the missing cells
+are also on the boundary and thus
+the cat would win if it ever steps on one of those neighboring cells,
+ending the game.
+
+The 3x3 board also has the same property that it consists of three
+rows, each with three cells, but where the first and last row are missing
+their left-most cells.
+
+@image["chat-noir/3x3-empty-board.png"]
+
+And here is how that board looks as a list of cells.
 
 @chunk[<empty-board-test>
        
-       (test (empty-world 3)
-             (make-world (list
-                          (make-cell (make-posn 0 1) false)
-                          (make-cell (make-posn 1 0) false)
-                          (make-cell (make-posn 1 1) false)
-                          (make-cell (make-posn 1 2) false)
-                          (make-cell (make-posn 2 0) false)
-                          (make-cell (make-posn 2 1) false)
-                          (make-cell (make-posn 2 2) false))
-                         (make-posn 1 1)
-                         'playing
-                         3
-                         (make-posn 0 0)
-                         false))]
+       (test (empty-board 3)
+             (list
+              (make-cell (make-posn 0 1) #f)
+              (make-cell (make-posn 1 0) #f)
+              (make-cell (make-posn 1 1) #f)
+              (make-cell (make-posn 1 2) #f)
+              (make-cell (make-posn 2 0) #f)
+              (make-cell (make-posn 2 1) #f)
+              (make-cell (make-posn 2 2) #f)))]
 
-and here is what that board look like, when rendered.
-
-@image["3x3-empty-board.png"]
-@image["5x5-empty-board.png"]
-@image["7x7-empty-board.png"]
+The @scheme[empty-board] function consists
+of two (nested) calls to @scheme[build-list] 
+that build a list of lists of cells, one for
+each pair of coordinates between @scheme[0]
+and @scheme[board-size]. Then, @scheme[append]
+flattens the nested lists and the
+@scheme[filter] expression removes the corners.
 
 @chunk[<empty-board>
-       ;; empty-board : number -> (listof cell)
-       (define (empty-board board-size)
+       (define/contract (empty-board board-size)
+         (-> (and/c natural-number/c odd? (>=/c 3))
+             (listof cell?))
          (filter
-          (lambda (c)
-            (not (and (= 0 (posn-x (cell-p c)))
-                      (or (= 0 (posn-y (cell-p c)))
-                          (= (- board-size 1)
-                             (posn-y (cell-p c)))))))
-          (append-all
+          (not-corner? board-size)
+          (apply
+           append
            (build-list
             board-size
             (lambda (i)
@@ -168,35 +220,105 @@ and here is what that board look like, when rendered.
                board-size
                (lambda (j)
                  (make-cell (make-posn i j)
-                            false))))))))]
+                            #f))))))))
+       
+       (define/contract ((not-corner? board-size) c)
+         (-> (and/c natural-number/c odd? (>=/c 3))
+             (-> cell?
+                 boolean?))
+         (not (and (= 0 (posn-x (cell-p c)))
+                   (or (= 0 (posn-y (cell-p c)))
+                       (= (- board-size 1)
+                          (posn-y (cell-p c)))))))]
+
+Building an empty world is simply 
+a matter of building an empty board, finding 
+the initial position of the cat and filling
+in all of the fields of the @scheme[world] struct.
+For example, this is the empty world of size @scheme[3].
+It puts the cat at @scheme[(make-posn 1 1)],
+sets the state to @scheme['playing], records the
+size @scheme[3], and sets the current mouse position
+to @scheme[#f] and the state of the ``h'' key to
+@scheme[#f].
+
+@chunk[<empty-world-test>
+       
+       (test (empty-world 3)
+             (make-world (empty-board 3)
+                         (make-posn 1 1)
+                         'playing
+                         3
+                         #f
+                         #f))]
+
+
+The @scheme[empty-world] function
+generalizes the exmaple by computing the
+cats initial position as the center spot on the board.
 
 @chunk[<empty-world>
        
-       ;; empty-world : number -> world
-       (define (empty-world board-size)
+       (define/contract (empty-world board-size)
+         (-> (and/c natural-number/c odd? (>=/c 3))
+             world?)
          (make-world (empty-board board-size)
                      (make-posn (quotient board-size 2)
                                 (quotient board-size 2))
                      'playing
                      board-size
-                     (make-posn 0 0)
-                     false))]
+                     #f
+                     #f))]
 
-@chunk[<empty-world-test>
-       
-       (test (empty-board 3)
-             (list
-              (make-cell (make-posn 0 1) false)
-              (make-cell (make-posn 1 0) false)
-              (make-cell (make-posn 1 1) false)
-              (make-cell (make-posn 1 2) false)
-              (make-cell (make-posn 2 0) false)
-              (make-cell (make-posn 2 1) false)
-              (make-cell (make-posn 2 2) false)))]
+The @scheme[add-n-random-blocked-cells] function accepts a list of cells
+and returns a new list of cells where @scheme[n] of the unblocked cells
+in @scheme[all-cells] are now blocked.
+
+If @scheme[n] is zero, of course, no more cells should be blocked,
+so the result is just @scheme[all-cells]. Otherwise, 
+the function computes @scheme[unblocked-cells], a list of all
+of the unblocked cells (except the cat's initial location),
+and then randomly picks a cell from it,
+calling @scheme[block-cell] to actually block that cell.
+
+@chunk[<blocked-cells>
+       (define/contract (add-n-random-blocked-cells n all-cells board-size)
+         (-> natural-number/c (listof cell?) (and/c natural-number/c odd? (>=/c 3))
+             (listof cell?))
+         (cond
+           [(zero? n) all-cells]
+           [else
+            (let* ([unblocked-cells
+                    (filter (lambda (x)
+                              (let ([cat-cell? (and (= (posn-x (cell-p x))
+                                                       (quotient board-size 2))
+                                                    (= (posn-y (cell-p x))
+                                                       (quotient board-size 2)))])
+                                
+                                (and (not (cell-blocked? x))
+                                     (not cat-cell?))))
+                            all-cells)]
+                   [to-block (list-ref unblocked-cells
+                                       (random (length unblocked-cells)))])
+              (add-n-random-blocked-cells
+               (sub1 n)
+               (block-cell (cell-p to-block) all-cells)
+               board-size))]))]
 
 
+The @scheme[block-cell] function accepts a @scheme[posn]
+and a list of @scheme[cell] structs and updates the
+relevant cell, setting its @tt{blocked?} field to @scheme[#t].
 
-@section{Graph}
+@chunk[<block-cell>
+       (define/contract (block-cell to-block board)
+         (-> posn? (listof cell?) (listof cell?))
+         (map (lambda (c) (if (equal? to-block (cell-p c))
+                              (make-cell to-block #t)
+                              c))
+              board))]
+
+@section{Breadth-first Search}
 
 The cat's move decision is based on a breadth-first search of a graph.
 The graph's nodes are the cells on the board plus a special
@@ -206,45 +328,70 @@ there are edges
 between each pair of adjacent cells, unless one of the cells is
 blocked, in which case it has no edges at all (even to the boundary).
 
-The code for the breadth-first search is organized into
-X parts ....
+This section describes the implementation of the breadth-first search, leaving
+details of how the graph connectivity is computed from the board to the next section.
 
-@chunk[<graph>
+@chunk[<breadth-first-search>
        <dist-cell-data-definition>
-       <build-bfs-table>
        <lookup-in-table>
-       <on-cats-path?>
-       <neighbors>
-       <adjacent>
-       <in-bounds?>
-       <on-boundary?>
-       <extended-arithmetic-ops>]
-
-@chunk[<graph-tests>
-       <extended-arithmetic-ops-tests>
-       <on-boundary?-tests>
-       <in-bounds?-tests>
-       <adjacent-tests>
-       <neighbors-tests>
-       <on-cats-path?-tests>
-       <lookup-in-table-tests>
-       <build-bfs-table-tests>
+       <build-bfs-table>]
        
-       ]
+@chunk[<breadth-first-search-tests>
+       <lookup-in-table-tests>
+       <build-bfs-table-tests>]
 
 The breadth-first function constructs a @scheme[distance-map],
 which is a list of @scheme[dist-cell] structs:
 
 @chunk[<dist-cell-data-definition>
-(define-struct dist-cell (p n) #:transparent)]
+       (define-struct/contract dist-cell ([p (or/c 'boundary posn?)]
+                                          [n natural-number/c])
+         #:transparent)]
 
 Each @tt{p} field in the @scheme[dist-cell] is a position on the board
-and the @tt{n} field is a natural number or @scheme['∞], indicating
+and the @tt{n} field is a natural number, indicating
 the distance of the shortest path from the node to some fixed point on
-the board. The fixed point is not represented in the
-@scheme[distance-map], but is required when constructing one.
+the board. 
 
-The @scheme[build-bfs-table] accepts a world and 
+The function @scheme[lookup-in-table] returns the distance from the fixed
+point to the given posn, returning @scheme['∞] if the posn is not in the
+table.
+
+@chunk[<lookup-in-table>
+       (define/contract (lookup-in-table t p)
+         (-> (listof dist-cell?) posn?
+             (or/c '∞ natural-number/c))
+         (cond
+           [(empty? t) '∞]
+           [else (cond
+                   [(equal? p (dist-cell-p (first t)))
+                    (dist-cell-n (first t))]
+                   [else
+                    (lookup-in-table (rest t) p)])]))]
+
+The @scheme[build-bfs-table] accepts a world and a cell 
+(indicating the fixed point) 
+and returns a distance map encoding the distance to that cell.
+For example, here is the distance map for the distance to the boundary.
+
+@chunk[<build-bfs-table-tests>
+       (test/set (build-bfs-table (empty-world 3)
+                                  'boundary)
+                 (list
+                  (make-dist-cell 'boundary 0)
+                  
+                  (make-dist-cell (make-posn 1 0) 1)
+                  (make-dist-cell (make-posn 2 0) 1)
+                  
+                  (make-dist-cell (make-posn 0 1) 1)
+                  (make-dist-cell (make-posn 1 1) 2)
+                  (make-dist-cell (make-posn 2 1) 1)
+                  
+                  (make-dist-cell (make-posn 1 2) 1)
+                  (make-dist-cell (make-posn 2 2) 1)))]
+
+The boundary is zero steps away; each of the cells that are on the boundary
+are one step away and the center is two steps away.
 
 The core of the breadth-first search is this function,
 @scheme[bst]. It accepts a queue of the pending nodes to visit
@@ -259,7 +406,12 @@ and that @scheme[posn]'s  distance.
 
 @chunk[<bfs>
        
-       (define (bfs queue dist-table)
+       (define/contract (bfs queue dist-table)
+         (-> (listof (vector/c (or/c 'boundary posn?) natural-number/c))
+             hash?
+             hash?)
+         #:freevar neighbors/w (-> (or/c 'boundary posn?)
+                                   (listof (or/c 'boundary posn?)))
          (cond
            [(empty? queue) dist-table]
            [else
@@ -285,38 +437,19 @@ is in @scheme[dist-table]. If it is, we just move on to the
 next element in the queue. If that node is not in the @scheme[dist-table],
 then we add all of the neighbors to the queue, in the @scheme[append]
 expression, and update the @scheme[dist-table] with the distance to 
-this node.
+this node. Because we always add the new children to the end of the queue
+and always look at the front of the queue, we are guaranteed that
+the first time we see a node, it will be with the shortest distance.
 
 The @scheme[build-bfs-table] function packages up @scheme[bfs]
-function. It accepts a @tt{world} and an initial position
+function. It accepts a @scheme[world] and an initial position
 and returns a @scheme[distance-table].
 
-As an example, here is one of the test cases. It supplies
-an empty world of size @scheme[3] to @scheme[build-bfs-table]
-and @scheme['boundary], thus asking for the distance from 
-the boundary to each cell.
-
-@chunk[<build-bfs-table-tests>
-       (test/set (build-bfs-table (empty-world 3)
-                                  'boundary)
-                 (list
-                  (make-dist-cell 'boundary 0)
-                  
-                  (make-dist-cell (make-posn 1 0) 1)
-                  (make-dist-cell (make-posn 2 0) 1)
-                  
-                  (make-dist-cell (make-posn 0 1) 1)
-                  (make-dist-cell (make-posn 1 1) 2)
-                  (make-dist-cell (make-posn 2 1) 1)
-                  
-                  (make-dist-cell (make-posn 1 2) 1)
-                  (make-dist-cell (make-posn 2 2) 1)))]
-
-The result is a list 
-
 @chunk[<build-bfs-table>
        
-       (define (build-bfs-table world init-point)
+       (define/contract (build-bfs-table world init-point)
+         (-> world? (or/c 'boundary posn?)
+             (listof dist-cell?))
          (define neighbors/w (neighbors world))
          <bfs>
          
@@ -327,20 +460,1002 @@ The result is a list
 
 As you can see, the first thing it does is bind the free variable in @scheme[bfs]
 to the result of calling the @scheme[neighbors] function (defined in the chunk
-@chunkref[<neighbors>]) and then it has the @scheme[bfs] function. In the body
-                        
-and finally it calls the bfs function
+@scheme[<neighbors>]) and then it has the @scheme[<bfs>] chunk. In the body
+it calls the @scheme[bfs] function 
 and then transforms the result, using
-@scheme[hash-map].
+@scheme[hash-map], into a list of @scheme[cell]s.
 
-The test suite for the @scheme[build-bfs-table] function
-uses @scheme[test/set] to avoid having to deal with the
-ordering issues in @scheme[build-bfs-table]'s result. 
+@section{Board to Graph}
+
+As far as the @scheme[build-bfs-table] function goes,
+all of the information specific to Chat Noir is
+encoded in the neighbors function. 
+It accepts a world and returns a function
+that computes the neighbors of the boundary
+and of nodes. This section describes how
+it is implemented.
+
+@chunk[<board->graph>
+       <neighbors>
+       <neighbors-blocked/boundary>
+       <adjacent>
+       <in-bounds?>
+       <on-boundary?>]
+
+@chunk[<board->graph-tests>
+       <on-boundary?-tests>
+       <in-bounds?-tests>
+       <adjacent-tests>
+       <neighbors-tests>]
+
+The neighbors functions accepts a @scheme[world] and then
+returns a function that computes the neighbors of a @scheme[posn]
+and of the @scheme['boundary].
+
+For example, @scheme[(make-posn 1 0)] has four
+neighbors:
+
+@chunk[<neighbors-tests>
+       (test ((neighbors (empty-world 7)) (make-posn 1 0))
+             (list 'boundary
+                   (make-posn 2 0)
+                   (make-posn 0 1)
+                   (make-posn 1 1)))]
+
+and @scheme[(make-posn 0 1)] has four neighbors:
+
+@chunk[<neighbors-tests>
+       (test ((neighbors (empty-world 7)) (make-posn 0 1))
+             (list 'boundary
+                   (make-posn 1 0)
+                   (make-posn 1 1)
+                   (make-posn 0 2)
+                   (make-posn 1 2)))]
+
+as you can see in the earlier pictures of the 7x7 empty board.
+Also, there are 6 neighbors of the boundary in the 3x3 board:
+
+@chunk[<neighbors-tests>
+       (test ((neighbors (empty-world 3)) 'boundary)
+             (list (make-posn 0 1)
+                   (make-posn 1 0)
+                   (make-posn 1 2)
+                   (make-posn 2 0)
+                   (make-posn 2 1)
+                   (make-posn 2 2)))]
+
+This is the neighbors function. After it accepts the @scheme[world],
+it builds a list of the blocked cells in the world and a
+list of the cells that are on the boundary (and not blocked). Then it
+returns a function that is specialized to those values.
+
+@chunk[<neighbors>
+(define/contract (neighbors w)
+  (-> world?
+      (-> (or/c 'boundary posn?)
+          (listof (or/c 'boundary posn?))))
+  (define blocked
+    (map cell-p
+         (filter (lambda (c)
+                   (or (cell-blocked? c)
+                       (equal? (cell-p c) (world-mouse-posn w))))
+                 (world-board w))))
+  (define boundary-cells
+    (filter (lambda (p)
+              (and (not (member p blocked))
+                   (on-boundary? p (world-size w))))
+            (map cell-p (world-board w))))
+  (λ (p)
+    (neighbors-blocked/boundary blocked
+                                boundary-cells
+                                (world-size w)
+                                p)))]
+
+The @scheme[neighbors-blocked/boundary] function is given next.
+If @scheme[p] is blocked, it returns the empty list. If it is
+on the boundary, the function simply returns @scheme[boundary-cells].
+Otherwise, @scheme[neighbors-blocked/boundary] calls
+@scheme[adjacent] to compute the posns that are adjacent to @scheme[p],
+filtering out the blocked @scheme[posn]s and binds that to @scheme[adjacent-posns].
+It then filters out the @scheme[posn]s that would be outside of the board.
+If those two lists are the same, then @scheme[p] is not on the boundary,
+so we just return @scheme[in-bounds]. If the lists are different, then
+we know that @scheme[p] must have been on the boundary, so we add
+@scheme['boundary] to the result list.
+
+@chunk[<neighbors-blocked/boundary>
+(define/contract (neighbors-blocked/boundary blocked 
+                                             boundary-cells
+                                             size
+                                             p)
+  (-> (listof posn?)
+      (listof posn?)
+      natural-number/c
+      (or/c 'boundary posn?)
+      (listof (or/c 'boundary posn?)))
+
+  (cond
+    [(member p blocked)
+     '()]
+    [(equal? p 'boundary)
+     boundary-cells]
+    [else
+     (let* ([x (posn-x p)]
+            [adjacent-posns 
+             (filter (λ (x) (not (member x blocked)))
+                     (adjacent p))]
+            [in-bounds
+             (filter (λ (x) (in-bounds? x size))
+                     adjacent-posns)])
+       (cond
+         [(equal? in-bounds adjacent-posns)
+          in-bounds]
+         [else
+          (cons 'boundary in-bounds)]))]))]
+
+
+There are the three functions that build the basic graph structure
+from a board as used by @scheme[neighbors].
+
+The first function is @scheme[adjacent]. It consumes a
+@scheme[posn] and returns six @scheme[posn]s that
+indicate what the neighbors are, without consideration
+of the size of the board (or the missing corner pieces).
+
+For example, these are the @scheme[posn]s that are adjacent
+to @scheme[(make-posn 0 1)]; note that the first and the third
+are not on the board and do not show up in 
+@scheme[neighbors] function example above.
+
+@chunk[<adjacent-tests>
+       (test (adjacent (make-posn 0 1))
+             (list (make-posn 0 0)
+                   (make-posn 1 0)
+                   (make-posn -1 1)
+                   (make-posn 1 1)
+                   (make-posn 0 2)
+                   (make-posn 1 2)))]
+
+The adjacent function has two main cases; first when the
+@scheme[y] coordinate of the @scheme[posn] is even and 
+second when it is odd. In each case, it is just a matter
+of looking at the board and calculating coordinate offsets.
+
+@chunk[<adjacent>
+       (define/contract (adjacent p)
+         (-> posn? 
+             (and/c (listof posn?)
+                    (lambda (l) (= 6 (length l)))))
+         (let ([x (posn-x p)]
+               [y (posn-y p)])
+           (cond
+             [(even? y)
+              (list (make-posn (- x 1) (- y 1))
+                    (make-posn x (- y 1))
+                    (make-posn (- x 1) y)
+                    (make-posn (+ x 1) y)
+                    (make-posn (- x 1) (+ y 1))
+                    (make-posn x (+ y 1)))]
+             [else
+              (list (make-posn x (- y 1))
+                    (make-posn (+ x 1) (- y 1))
+                    (make-posn (- x 1) y)
+                    (make-posn (+ x 1) y)
+                    (make-posn x (+ y 1))
+                    (make-posn (+ x 1) (+ y 1)))])))]
+
+The @scheme[on-boundary?] function returns @scheme[#t] when 
+the posn would be on the boundary of a board of size
+@scheme[board-size]. Note that this function does not
+have to special case the missing @scheme[posn]s from the corners.
+
+@chunk[<on-boundary?>
+       (define/contract (on-boundary? p board-size)
+         (-> posn? natural-number/c 
+             boolean?)
+         (or (= (posn-x p) 0)
+             (= (posn-y p) 0)
+             (= (posn-x p) (- board-size 1))
+             (= (posn-y p) (- board-size 1))))]
+
+The @scheme[in-bounds?] function returns @scheme[#t]
+when the @scheme[posn] is actually on the board, meaning
+that the coordinates of the @scheme[posn] are within the
+board's size, and that the @scheme[posn] is not one
+of the two corners that have been removed.
+
+@chunk[<in-bounds?>
+       (define/contract (in-bounds? p board-size)
+         (-> posn? natural-number/c
+             boolean?)
+         (and (<= 0 (posn-x p) (- board-size 1))
+              (<= 0 (posn-y p) (- board-size 1))
+              (not (equal? p (make-posn 0 0)))
+              (not (equal? p (make-posn 0 (- board-size 1))))))]
+
+@section{The Cat's Path}
+
+Once we have a breadth-first search all sorted out, we can use it to build a function that 
+determines where the shortest paths from the cat's current position to the boundary are.
+
+@chunk[<cats-path>
+       <on-cats-path?>
+       <+/f>]
+
+@chunk[<cats-path-tests>
+       <on-cats-path?-tests>
+       <+/f-tests>]
+
+The function @scheme[on-cats-path?] accepts a world and returns a predicate
+on the @scheme[posn]s in the world. The predicate indicates if the given
+@scheme[posn] is on the shortest path. 
+
+For example, in a world of size @scheme[7] with the cat at
+@scheme[(make-posn 2 2)], the circles with white centers
+are on the shortest path to the boundary:
+
+@image["chat-noir/cat-distance-example.png"]
+
+So we can formulate two test cases using this world, one
+in the white circles and one not:
+
+@chunk[<on-cats-path?-tests>
+       (let ([on-the-path?
+              (on-cats-path? (make-world (empty-board 7)
+                                         (make-posn 2 2)
+                                         'playing
+                                         7
+                                         #f
+                                         #t))])
+         (test (on-the-path? (make-posn 1 0))
+               #t)
+         (test (on-the-path? (make-posn 4 4))
+               #f))]
+
+The computation of the shortest path to the boundary proceeds by computing
+two distance maps; the distance map to the boundary and the distance map
+to the cat. Then, a node is on one of the shortest paths if the distance
+to the cat plus the distance to the boundary is equal to the distance from
+the cat to the boundary. 
+
+The code is essentially that, plus two other special cases. Specifically if the
+``h'' key is not pressed down, then we just consider no cells to be on that shortest
+path. And if the distance to the cat is @scheme['∞], then again no nodes are on the
+path. The second situation happens when the cat is completely boxed in and has
+lost the game.
+
+@chunk[<on-cats-path?>
+       (define/contract (on-cats-path? w)
+         (-> world? (-> posn? boolean?))
+         (cond
+           [(world-h-down? w)
+            (let ()
+              (define edge-distance-map (build-bfs-table w 'boundary))
+              (define cat-distance-map (build-bfs-table w (world-cat w)))
+              (define cat-distance
+                (lookup-in-table edge-distance-map (world-cat w)))
+              (cond
+                [(equal? cat-distance '∞)
+                 (lambda (p) #f)]
+                [else
+                 (lambda (p)
+                   (equal? (+/f (lookup-in-table cat-distance-map p)
+                                (lookup-in-table edge-distance-map p))
+                           cat-distance))]))]
+           [else
+            (lambda (p) #f)]))]
+
+Finally, the helper function @scheme[+/f] is just like @scheme[+], except that
+it returns @scheme['∞] if either argument is @scheme['∞].
+
+@chunk[<+/f>
+       (define (+/f x y)
+         (cond
+           [(or (equal? x '∞) (equal? y '∞))
+            '∞]
+           [else
+            (+ x y)]))]
+
+@section{Drawing the Cat}
+
+This code is three large, similar constants,
+bundled up into the @scheme[cat] function. 
+The @scheme[thinking-cat] is the one that 
+is visible when the game is being played. It
+differs from the others in that it does not
+have a mouth. The @scheme[mad-cat] is the one
+that you see when the cat loses. It differs
+from the others in that its pinks turn pink.
+Finally, the @scheme[happy-cat] shows up when
+the cat wins and it is just like the @scheme[thinking-cat]
+except it has a smile.
+
+@chunk[<drawing-the-cat>
+       (define/contract (cat mode)
+         (-> (or/c 'mad 'happy 'thinking) image?)
+         (define face-width 36)
+         (define face-height 22)
+         
+         (define face-color
+           (cond
+             [(eq? mode 'mad) 'pink]
+             [else 'lightgray]))
+         
+         (define left-ear 
+           (regular-polygon 3 8 'solid 'black (/ pi -3)))
+         (define right-ear
+           (regular-polygon 3 8 'solid 'black 0))
+         (define ear-x-offset 14)
+         (define ear-y-offset 9)
+         
+         (define eye (overlay (ellipse 12 8 'solid 'black)
+                              (ellipse 6 4 'solid 'limegreen)))
+         (define eye-x-offset 8)
+         (define eye-y-offset 3)
+         
+         (define nose
+           (regular-polygon 3 5 'solid 'black (/ pi 2)))
+         
+         (define mouth-happy
+           (overlay (ellipse 8 8 'solid face-color)
+                    (ellipse 8 8 'outline 'black)
+                    (move-pinhole
+                     (rectangle 10 5 'solid face-color)
+                     0
+                     4)))
+         (define mouth-no-expression
+           (overlay (ellipse 8 8 'solid face-color)
+                    (ellipse 8 8 'outline face-color)
+                    (rectangle 10 5 'solid face-color)))
+         
+         (define mouth
+           (cond
+             [(eq? mode 'happy) mouth-happy]
+             [else mouth-no-expression]))
+         (define mouth-x-offset 4)
+         (define mouth-y-offset -5)
+         
+         (define (whiskers img)
+           (add-line
+            (add-line
+             (add-line
+              (add-line
+               (add-line
+                (add-line
+                 img
+                 6 4 30 12 'black)
+                6 4 30 4 'black)
+               6 4 30 -4 'black)
+              -6 4 -30 12 'black)
+             -6 4 -30 4 'black)
+            -6 4 -30 -4 'black))
+         (whiskers
+          (overlay
+           (move-pinhole left-ear (- ear-x-offset) ear-y-offset)
+           (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset)
+           (ellipse (+ face-width 4) (+ face-height 4) 'solid 'black)
+           (ellipse face-width face-height 'solid face-color)
+           (move-pinhole mouth (- mouth-x-offset) mouth-y-offset)
+           (move-pinhole mouth mouth-x-offset mouth-y-offset)
+           (move-pinhole eye (- eye-x-offset) eye-y-offset)
+           (move-pinhole eye eye-x-offset eye-y-offset)
+           (move-pinhole nose -1 -4))))
        
+       (define thinking-cat (cat 'thinking))
+       (define happy-cat (cat 'happy))
+       (define mad-cat (cat 'mad))]
+
+
+@section{Drawing the World}
+
+@chunk[<drawing>
+       <constants>
+       <render-world>
+       <chop-whiskers>
+       <render-board>
+       <render-cell>
+       <world-width>
+       <world-height>
+       <cell-center-x>
+       <cell-center-y>]
+
+@chunk[<drawing-tests>
+       <cell-center-x-tests>
+       <cell-center-y-tests>
+       <world-size-tests>
+       <render-cell-tests>
+       <render-board-tests>
+       <chop-whiskers-tests>
+       <render-world-tests>]
+
+There are a number of constants
+that are given names to make the code
+more readable. 
+
+These first two constants give the radius
+of the circles that are drawn on the board,
+plus the radius of an invisible circle
+that, if they were drawn on top of
+the circles, would touch
+each other. Accordingly, @scheme[circle-spacing]
+is used when computing the positions of the circles,
+but the circles are drawn using @scheme[circle-radius].
+
+@chunk[<constants>
+       (define circle-radius 20)
+       (define circle-spacing 22)]
+
+The other four constants specify the colors of the circles.
+
+@chunk[<constants>
+       (define normal-color 'lightskyblue)
+       (define on-shortest-path-color 'white)
+       (define blocked-color 'black)
+       (define under-mouse-color 'black)]
+
+The main function for drawing a world is @scheme[render-world].
+It is a fairly straightforward composition of helper functions.
+First, it builds the image of a board, and then puts the cat on it.
+Lastly, since the whiskers of the cat might now hang off of the edge
+of the board (if the cat is on a leftmost or rightmost cell),
+it trims them. This ensures that the image is always the same size
+and that the pinhole is always in the upper-left corner of the window.
+
+@chunk[<render-world>
+       (define/contract (render-world w)
+         (-> world? image?)
+         (chop-whiskers
+          (overlay/xy (render-board (world-board w)
+                                    (world-size w)
+                                    (on-cats-path? w)
+                                    (world-mouse-posn w))
+                      (cell-center-x (world-cat w))
+                      (cell-center-y (world-cat w))
+                      (cond
+                        [(equal? (world-state w) 'cat-won) happy-cat]
+                        [(equal? (world-state w) 'cat-lost) mad-cat]
+                        [else thinking-cat]))))]
+
+Trimming the cat's whiskers amounts to removing any extra
+space in the image that appears to the left or above the pinhole.
+For example, the @scheme[rectangle] function returns
+an image with a pinhole in the middle. So trimming 5x5
+rectangle results in a 3x3 rectangle with the pinhole
+at (0,0).
+
+@chunk[<chop-whiskers-tests>
+       (test (chop-whiskers (rectangle 5 5 'solid 'black))
+             (put-pinhole (rectangle 3 3 'solid 'black) 0 0))]
+
+The function uses @scheme[shrink] to remove all of the material above
+and to the left of the pinhole.
+
+@chunk[<chop-whiskers>
+(define/contract (chop-whiskers img)
+  (-> image? image?)
+  (shrink img
+          0
+          0
+          (- (image-width img) (pinhole-x img) 1)
+          (- (image-height img) (pinhole-y img) 1)))]
+
+The @scheme[render-board] function uses @scheme[for/fold] to iterate
+over all of the @scheme[cell]s in @scheme[cs]. It starts with
+an empty rectangle and, one by one, puts the cells on @scheme[image].
+
+@chunk[<render-board>
+       ;; render-board : board number (posn -> boolean) posn-or-#f -> image
+       (define/contract (render-board cs world-size on-cat-path? mouse)
+         (-> (listof cell?) 
+             natural-number/c
+             (-> posn? boolean?)
+             (or/c #f posn?)
+             image?)
+         (for/fold ([image (nw:rectangle (world-width world-size)
+                                         (world-height world-size)
+                                         'solid
+                                         'white)])
+                   ([c cs])
+           (overlay image
+                    (render-cell c
+                                 (on-cat-path? (cell-p c))
+                                 (and (posn? mouse)
+                                      (equal? mouse (cell-p c)))))))]
+
+The @scheme[render-cell] function accepts a @scheme[cell], 
+a boolean indicating if the cell is on the shortest path between
+the cat and the boundary, and a second boolean indicating
+if the cell is underneath the mouse. It returns an image 
+of the cell, with the pinhole placed in such a way that overlaying
+the image on an empty image with pinhole in the upper-left corner
+results in the cell being placed in the right place.
+
+@chunk[<render-cell>
+       (define/contract (render-cell c on-short-path? under-mouse?)
+         (-> cell? boolean? boolean? image?)
+         (let ([x (cell-center-x (cell-p c))]
+               [y (cell-center-y (cell-p c))]
+               [main-circle
+                (cond
+                  [(cell-blocked? c)
+                   (circle circle-radius 'solid blocked-color)]
+                  [else
+                   (circle circle-radius 'solid normal-color)])])
+           (move-pinhole
+            (cond
+              [under-mouse?
+               (overlay main-circle
+                        (circle (quotient circle-radius 2) 'solid under-mouse-color))]
+              [on-short-path?
+               (overlay main-circle
+                        (circle (quotient circle-radius 2) 'solid
+                                on-shortest-path-color))]
+              [else
+               main-circle])
+            (- x)
+            (- y))))]
+
+The @scheme[world-width] function computes the width of the rendered world,
+given the world's size by finding the center of the rightmost posn,
+and then adding an additional radius.
+
+@chunk[<world-width>
+       (define/contract (world-width board-size)
+         (-> natural-number/c number?)
+         (let ([rightmost-posn
+                (make-posn (- board-size 1) (- board-size 2))])
+           (+ (cell-center-x rightmost-posn) circle-radius)))]
+
+Similarly, the @scheme[world-height] function computest the 
+height of the rendered world, given the world's size.
+
+@chunk[<world-height>
+       (define/contract (world-height board-size)
+         (-> natural-number/c number?)
+         (let ([bottommost-posn
+                (make-posn (- board-size 1) (- board-size 1))])
+           (ceiling (+ (cell-center-y bottommost-posn) 
+                       circle-radius))))]
+
+The @scheme[cell-center-x] function returns the
+@tt{x} coordinate of the center of the cell specified
+by @scheme[p].
+
+For example, the first cell in
+the third row (counting from @scheme[0]) is
+flush with the edge of the screen, so its
+center is just the radius of the circle that
+is drawn.
+
+@chunk[<cell-center-x-tests>
+       (test (cell-center-x (make-posn 0 2))
+             circle-radius)]
+
+
+The first cell in the second row, in contrast
+is offset from the third row by
+@scheme[circle-spacing].
+
+@chunk[<cell-center-x-tests>
+       (test (cell-center-x (make-posn 0 1))
+             (+ circle-spacing circle-radius))]
+
+
+The definition of @scheme[cell-center-x] 
+multiplies the @scheme[x] coordinate of 
+@scheme[p] by twice @scheme[circle-spacing]
+and then adds @scheme[circle-radius] to move
+over for the first circle. In addition
+if the @scheme[y] coordinate is odd, then
+it adds @scheme[circle-spacing], shifting 
+the entire line over.
+
+@chunk[<cell-center-x>
+       (define/contract (cell-center-x p)
+         (-> posn? number?)
+         (let ([x (posn-x p)]
+               [y (posn-y p)])
+           (+ circle-radius
+              (* x circle-spacing 2)
+              (if (odd? y)
+                  circle-spacing
+                  0))))]
+
+The @scheme[cell-center-y] function computes the
+@scheme[y] coordinate of a cell's location on
+the screen. For example, the @scheme[y] 
+coordinate of the first row is 
+the radius of a circle, ensuring that
+the first row is flush against the top of
+the screen.
+
+@chunk[<cell-center-y-tests>
+       (test (cell-center-y (make-posn 1 0))
+             circle-radius)]
+
+Because the grid is hexagonal, the @scheme[y] coordinates
+of the rows do not have the same spacing as the @scheme[x]
+coordinates. In particular, they are off by
+@tt{sin(pi/3)}. We approximate that by @scheme[866/1000]
+in order to keep the computations and test cases simple
+and using exact numbers.
+A more precise approximation would be
+@(scheme #,(sin (/ pi 3))), but it is not necessary at
+the screen resolution.
+
+@chunk[<cell-center-y>
+       (define/contract (cell-center-y p)
+         (-> posn? number?)
+         (+ circle-radius
+            (* (posn-y p) 
+               circle-spacing 2
+               866/1000)))]
+       
+@section{Handling Input}
+
+Input handling consists of handling two different kinds of events: key events, and mouse events, 
+plus various helper functions.
+
+@chunk[<input>
+       <change>
+       <clack>
+       <update-world-posn>
+       <player-moved?>
+       <block-cell/world>
+       <move-cat>
+       <find-best-positions>
+       <lt/f>
+       <circle-at-point>
+       <point-in-this-circle?>]
+
+@chunk[<input-tests>
+       <change-tests>
+       <point-in-this-circle?-tests>
+       <circle-at-point-tests>
+       <lt/f-tests>
+       <find-best-positions-tests>
+       <move-cat-tests>
+       <update-world-posn-tests>
+       <clack-tests>]
+
+The @scheme[change] function handles keyboard input and merely updates the @tt{h-down?} field
+based on the state of the key event.
+
+@chunk[<change>
+       ;; change : world key-event -> world
+       (define (change w ke)
+         (make-world (world-board w)
+                     (world-cat w)
+                     (world-state w)
+                     (world-size w)
+                     (world-mouse-posn w)
+                     (key=? ke #\h)))]
+
+The @scheme[clack] function handles mouse input. It has three tasks and each corresponds 
+to a helper function:
+@itemize{
+@item{block the clicked cell (@scheme[block-cell/world]),}
+@item{move the cat (@scheme[move-cat]), and}
+@item{update the black dot as the mouse moves around (@scheme[update-world-posn]).}}
+The helper functions are combined in the body of @scheme[clack],
+first checking to see if the mouse event corresponds to a 
+player's move (via the @scheme[player-moved?] function.
+
+@chunk[<clack>
+       (define/contract (clack world x y evt)
+         (-> world? integer? integer? any/c 
+             world?)
+         (let ([moved-world
+                (cond
+                  [(player-moved? world x y evt)
+                   => 
+                   (λ (circle)
+                     (move-cat
+                      (block-cell/world circle world)))]
+                  [else world])])
+           (update-world-posn
+            moved-world
+            (and (eq? (world-state moved-world) 'playing)
+                 (not (eq? evt 'leave))
+                 (make-posn x y)))))]
+
+The @scheme[player-moved?] predicate returns
+a @scheme[posn] indicating where the player chose
+to move when the mouse event corresponds to a player move,
+and returns @scheme[#f]. It first checks to see if the
+mouse event is a button up event and that the game
+is not over, and then it just calls @scheme[circle-at-point].
+
+@chunk[<player-moved?>
+       (define/contract (player-moved? world x y evt)
+         (-> world? integer? integer? any/c 
+             (or/c posn? #f))
+         (and (equal? evt 'button-up)
+              (equal? 'playing (world-state world))
+              (circle-at-point (world-board world) x y)))]
+
+The @scheme[circle-at-point] function returns a @scheme[posn] when
+the coordinate (@scheme[x],@scheme[y]) is inside a circle
+on the given board. Instead of computing the nearest
+circle to the coordinates, it simply iterates over the cells on the
+board and returns the @scheme[posn] of the matching cell.
+
+@chunk[<circle-at-point>
+       (define/contract (circle-at-point board x y)
+         (-> (listof cell?) real? real? 
+             (or/c posn? #f))
+         (ormap (λ (cell)
+                  (and (point-in-this-circle? (cell-p cell) x y)
+                       (cell-p cell)))
+                board))]
+
+
+The @scheme[point-in-this-circle?] function returns @scheme[#t]
+when the point (@scheme[x],@scheme[y]) on the screen
+falls within the circle located at the @scheme[posn] @scheme[p].
+
+This is precise about checking the circles. For example, 
+a point that is (14,14) away from the center of a circle
+is still in the circle:
+
+@chunk[<point-in-this-circle?-tests>
+       (test (point-in-this-circle? 
+              (make-posn 1 0)
+              (+ (cell-center-x (make-posn 1 0)) 14)
+              (+ (cell-center-y (make-posn 1 0)) 14))
+             #t)]
+
+but one that is (15,15) away is no longer in the circle,
+since it crosses the boundary away from a circle of radius
+20 at that point.
+
+@chunk[<point-in-this-circle?-tests>
+       (test (point-in-this-circle? 
+              (make-posn 1 0)
+              (+ (cell-center-x (make-posn 1 0)) 15)
+              (+ (cell-center-y (make-posn 1 0)) 15))
+             #f)]
+
+The implementation of @scheme[point-in-this-circle?] uses
+complex numbers to represent both points on the screen
+and directional vectors. In particular, the 
+variable @scheme[center] is a complex number whose
+real part is the @tt{x} coordinate of the center of
+the cell at @scheme[p], and its imaginary part is 
+@tt{y} coordinate. Similarly, @scheme[mp] is bound
+to a complex number corresponding to the position of
+the mouse, at (@scheme[x], @scheme[y]). Then, the
+function computes the vector between the two points
+by subtracting the complex numbers from each
+other and extracting the magnitude from that vector.
+
+@chunk[<point-in-this-circle?>
+       (define/contract (point-in-this-circle? p x y)
+         (-> posn? real? real? boolean?)
+         (let ([center (+ (cell-center-x p)
+                          (* (sqrt -1)
+                             (cell-center-y p)))]
+               [mp (+ x (* (sqrt -1) y))])
+           (<= (magnitude (- center mp)) 
+               circle-radius)))]
+
+In the event that @scheme[player-moved?] returns a @scheme[posn],
+the @scheme[clack] function blocks the clicked on cell using
+@scheme[block-cell/world], which simply calls @scheme[block-cell].
+
+@chunk[<block-cell/world>
+       (define/contract (block-cell/world to-block w)
+         (-> posn? world? world?)
+         (make-world (block-cell to-block (world-board w))
+                     (world-cat w)
+                     (world-state w)
+                     (world-size w)
+                     (world-mouse-posn w)
+                     (world-h-down? w)))]
+
+The @scheme[move-cat] function uses calls @scheme[build-bfs-table]
+to find the shortest distance from all of the cells to the boundary,
+and then uses @scheme[find-best-positions] to compute the
+list of neighbors of the cat that have the shortest distance
+to the boundary. If that list is empty, then @scheme[next-cat-position]
+is @scheme[#f], and otherwise, it is a random element from that list.
+
+@chunk[<move-cat>
+       (define/contract (move-cat world)
+         (-> world? world?)
+         (let* ([cat-position (world-cat world)]
+                [table (build-bfs-table world 'boundary)]
+                [neighbors (adjacent cat-position)]
+                [next-cat-positions
+                 (find-best-positions neighbors
+                                      (map (lambda (p) (lookup-in-table table p))
+                                           neighbors))]
+                [next-cat-position
+                 (cond
+                   [(boolean? next-cat-positions) #f]
+                   [else
+                    (list-ref next-cat-positions
+                              (random (length next-cat-positions)))])])
+           
+           <moved-cat-world>))]
+
+Once @scheme[next-cat-position] has been computed, it is used to update
+the @tt{cat} and @tt{state} fields of the world, recording the cat's new
+position and whether or not the cat won.
+
+@chunk[<moved-cat-world>
+       (make-world (world-board world)
+                   (cond
+                     [(boolean? next-cat-position)
+                      cat-position]
+                     [else next-cat-position])
+                   (cond
+                     [(boolean? next-cat-position)
+                      'cat-lost]
+                     [(on-boundary? next-cat-position (world-size world))
+                      'cat-won]
+                     [else 'playing])
+                   (world-size world)
+                   (world-mouse-posn world)
+                   (world-h-down? world))]
+
+
+The @scheme[find-best-positions] function accepts
+two parallel lists, one of @scheme[posn]s, and one
+of scores for those @scheme[posn]s, and it 
+returns either a non-empty list of @scheme[posn]s
+that have tied for the best score, or it
+returns @scheme[#f], if the best score is 
+@scheme['∞].
+
+@chunk[<find-best-positions>
+       (define/contract (find-best-positions posns scores)
+         (-> (cons/c posn? (listof posn?))
+             (cons/c (or/c number? '∞) (listof (or/c number? '∞)))
+             (or/c (cons/c posn? (listof posn?)) #f))
+         (let ([best-score
+                (foldl (lambda (x sofar)
+                         (if (<=/f x sofar)
+                             x
+                             sofar))
+                       (first scores)
+                       (rest scores))])
+           (cond
+             [(symbol? best-score) #f]
+             [else
+              (map
+               second
+               (filter (lambda (x) (equal? (first x) best-score))
+                       (map list scores posns)))])))]
+
+This is a helper function that behaves like
+@scheme[<=], but is extended to deal properly with
+@scheme['∞].
+
+@chunk[<lt/f>
+       (define/contract (<=/f a b)
+         (-> (or/c number? '∞) 
+             (or/c number? '∞)
+             boolean?)
+         (cond
+           [(equal? b '∞) #t]
+           [(equal? a '∞) #f]
+           [else (<= a b)]))]
+
+
+Finally, to complete the mouse event handling, the @scheme[update-world-posn]
+function is called from @scheme[clack]. It updates the @tt{mouse-down}
+field of the @scheme[world]. If the @scheme[p] argument is a @scheme[posn],
+it corresponds to the location of the mouse, in graphical coordinates.
+So, the function converts it to a cell position on the board and uses that.
+Otherwise, when @scheme[p] is @scheme[#f], the @tt{mouse-down} field
+is just updated to @scheme[#f].
+
+@chunk[<update-world-posn>
+       (define/contract (update-world-posn w p)
+         (-> world? (or/c #f posn?)
+             world?)
+         (cond
+           [(posn? p)
+            (let ([mouse-spot
+                   (circle-at-point (world-board w)
+                                    (posn-x p)
+                                    (posn-y p))])
+              (make-world (world-board w)
+                          (world-cat w)
+                          (world-state w)
+                          (world-size w)
+                          (cond
+                            [(equal? mouse-spot (world-cat w))
+                             #f]
+                            [else
+                             mouse-spot])
+                          (world-h-down? w)))]
+           [else
+            (make-world (world-board w)
+                        (world-cat w)
+                        (world-state w)
+                        (world-size w)
+                        #f
+                        (world-h-down? w))]))]
+
+
+@section{Tests}
+
+This section consists of some infrastructure for
+maintaining tests, plus a pile of additional tests
+for the other functions in this document.
+
+The @scheme[test] and @scheme[test/set] macros
+package up their arguments into thunks and then
+simply call @scheme[test/proc], supplying 
+information about the source location of the test
+case. The @scheme[test/proc] function runs the tests
+and reports the results.
+
+@chunk[<test-infrastructure>
+
+(define-syntax (test stx)
+  (syntax-case stx ()
+    [(_ actual expected)
+     (with-syntax ([line (syntax-line stx)]
+                   [pos (syntax-position stx)])
+       #'(test/proc (λ () actual)
+                    (λ () expected)
+                    equal?
+                    line
+                    'actual))]))
+
+(define-syntax (test/set stx)
+  (syntax-case stx ()
+    [(_ actual expected)
+     (with-syntax ([line (syntax-line stx)]
+                   [pos (syntax-position stx)])
+       #'(test/proc (λ () actual)
+                    (λ () expected)
+                    (λ (x y) (same-sets? x y))
+                    line
+                    'actual))]))
+
+(define test-count 0)
+
+(define (test/proc actual-thunk expected-thunk cmp line sexp)
+  (set! test-count (+ test-count 1))
+  (let ([actual (actual-thunk)]
+        [expected (expected-thunk)])
+    (unless (cmp actual expected)
+      (error 'check-expect "test #~a~a\n  ~s\n  ~s\n"
+             test-count
+             (if line
+                 (format " on line ~a failed:" line)
+                 (format " failed: ~s" sexp))
+             actual
+             expected))))
+
+
+(define (same-sets? l1 l2)
+  (and (andmap (lambda (e1) (member e1 l2)) l1)
+       (andmap (lambda (e2) (member e2 l1)) l2)
+       #t))
+
+(test (same-sets? (list) (list)) #t)
+(test (same-sets? (list) (list 1)) #f)
+(test (same-sets? (list 1) (list)) #f)
+(test (same-sets? (list 1 2) (list 2 1)) #t)]
+
+@chunk[<lookup-in-table-tests>
+       (test (lookup-in-table empty (make-posn 1 2)) '∞)
+       (test (lookup-in-table (list (make-dist-cell (make-posn 1 2) 3))
+                              (make-posn 1 2))
+             3)
+       (test (lookup-in-table (list (make-dist-cell (make-posn 2 1) 3))
+                              (make-posn 1 2))
+             '∞)]
+
 @chunk[<build-bfs-table-tests>
        (test/set (build-bfs-table
                   (make-world (empty-board 3) (make-posn 1 1)
-                              'playing 3 (make-posn 0 0) false)
+                              'playing 3 (make-posn 0 0) #f)
                   (make-posn 1 1))
                  (list
                   (make-dist-cell 'boundary 2)
@@ -358,18 +1473,18 @@ ordering issues in @scheme[build-bfs-table]'s result.
        (test/set (build-bfs-table
                   (make-world
                    (list
-                    (make-cell (make-posn 0 1) true)
-                    (make-cell (make-posn 1 0) true)
-                    (make-cell (make-posn 1 1) false)
-                    (make-cell (make-posn 1 2) true)
-                    (make-cell (make-posn 2 0) true)
-                    (make-cell (make-posn 2 1) true)
-                    (make-cell (make-posn 2 2) true))
+                    (make-cell (make-posn 0 1) #t)
+                    (make-cell (make-posn 1 0) #t)
+                    (make-cell (make-posn 1 1) #f)
+                    (make-cell (make-posn 1 2) #t)
+                    (make-cell (make-posn 2 0) #t)
+                    (make-cell (make-posn 2 1) #t)
+                    (make-cell (make-posn 2 2) #t))
                    (make-posn 1 1)
                    'playing
                    3
                    (make-posn 0 0)
-                   false)
+                   #f)
                   'boundary)
                  (list
                   (make-dist-cell 'boundary 0)))
@@ -380,7 +1495,7 @@ ordering issues in @scheme[build-bfs-table]'s result.
                               'playing
                               5
                               (make-posn 0 0)
-                              false)
+                              #f)
                   'boundary)
                  (list
                   (make-dist-cell 'boundary 0)
@@ -421,7 +1536,7 @@ ordering issues in @scheme[build-bfs-table]'s result.
                               'playing
                               5
                               (make-posn 0 0)
-                              false)
+                              #f)
                   'boundary)
                  (list
                   (make-dist-cell 'boundary 0)
@@ -459,7 +1574,7 @@ ordering issues in @scheme[build-bfs-table]'s result.
                               'playing
                               5
                               (make-posn 0 0)
-                              false)
+                              #f)
                   (make-posn 2 2))
                  (list
                   (make-dist-cell 'boundary 3)
@@ -498,1416 +1613,747 @@ ordering issues in @scheme[build-bfs-table]'s result.
                                            'playing
                                            5
                                            (make-posn 0 0)
-                                           false)
+                                           #f)
                                (make-posn 2 2))
               (make-posn 1 4))
              2)]
 
-@chunk[<lookup-in-table>
-;; lookup-in-table : distance-map posn -> number or '∞
-;; looks for the distance as recorded in the table t,
-;; if not found returns a distance of '∞
-(define (lookup-in-table t p)
-  (cond
-    [(empty? t) '∞]
-    [else (cond
-            [(equal? p (dist-cell-p (first t)))
-             (dist-cell-n (first t))]
-            [else
-             (lookup-in-table (rest t) p)])]))]
-
-@chunk[<lookup-in-table-tests>
-
-(test (lookup-in-table empty (make-posn 1 2)) '∞)
-(test (lookup-in-table (list (make-dist-cell (make-posn 1 2) 3))
-                               (make-posn 1 2))
-              3)
-(test (lookup-in-table (list (make-dist-cell (make-posn 2 1) 3))
-                               (make-posn 1 2))
-              '∞)]
-
-
-@chunk[<on-cats-path?>
-;; on-cats-path? : world -> posn -> boolean
-;; returns true when the posn is on the shortest path
-;; from the cat to the edge of the board, in the given world
-(define (on-cats-path? w)
-  (cond
-    [(world-h-down? w)
-     (local [(define edge-distance-map (build-bfs-table w 'boundary))
-             (define cat-distance-map (build-bfs-table w (world-cat w)))
-             (define cat-distance (lookup-in-table edge-distance-map
-                                                   (world-cat w)))]
-       (cond
-         [(equal? cat-distance '∞)
-          (lambda (p) false)]
-         [else
-          (lambda (p)
-            (equal? (+/f (lookup-in-table cat-distance-map p)
-                         (lookup-in-table edge-distance-map p))
-                    cat-distance))]))]
-    [else
-     (lambda (p) false)]))]
-
-@chunk[<on-cats-path?-tests>
-(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1)
-                                          'playing 5 (make-posn 0 0) true))
-               (make-posn 1 0))
-              true)
-(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1)
-                                          'playing 5 (make-posn 0 0) false))
-               (make-posn 1 0))
-              false)
-(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1)
-                                          'playing 5 (make-posn 0 0) true))
-               (make-posn 2 1))
-              false)
-(test ((on-cats-path?
-                (make-world (list
-                             (make-cell (make-posn 0 1) true)
-                             (make-cell (make-posn 1 0) true)
-                             (make-cell (make-posn 1 1) false)
-                             (make-cell (make-posn 1 2) true)
-                             (make-cell (make-posn 2 0) true)
-                             (make-cell (make-posn 2 1) true)
-                             (make-cell (make-posn 2 2) true))
-                            (make-posn 1 1)
-                            'cat-lost
-                            3
-                            (make-posn 0 0)
-                            true))
-               (make-posn 0 1))
-              false)]
-
-@chunk[<neighbors>
-;; neighbors : world -> (or/c 'boundary posn) -> (listof (or/c 'boundary posn))
-;; computes the neighbors of a posn, for a given board size
-(define (neighbors w)
-  (local [(define blocked
-            (map cell-p
-                 (filter (lambda (c)
-                           (or (cell-blocked? c)
-                               (equal? (cell-p c) (world-mouse-posn w))))
-                         (world-board w))))
-          (define boundary-cells
-            (filter (lambda (p)
-                      (and (not (member p blocked))
-                           (on-boundary? p (world-size w))))
-                    (map cell-p (world-board w))))]
-    (lambda (p)
-      (cond
-        [(member p blocked)
-         '()]
-        [(equal? p 'boundary)
-         boundary-cells]
-        [else
-         (local [(define x (posn-x p))
-                 (define y (posn-y p))
-                 (define adjacent-posns (adjacent p (world-size w)))
-                 (define in-bounds
-                   (filter (lambda (x) (in-bounds? x (world-size w)))
-                           adjacent-posns))]
-           (filter
-            (lambda (x) (not (member x blocked)))
-            (cond
-              [(equal? in-bounds adjacent-posns)
-               in-bounds]
-              [else
-               (cons 'boundary in-bounds)])))]))))]
-
 @chunk[<neighbors-tests>
-(test ((neighbors (empty-world 11))  (make-posn 1 1))
-              (adjacent (make-posn 1 1) 11))
-(test ((neighbors (empty-world 11)) (make-posn 2 2))
-              (adjacent (make-posn 2 2) 11))
-(test ((neighbors (empty-world 3)) 'boundary)
-              (list (make-posn 0 1)
-                    (make-posn 1 0)
-                    (make-posn 1 2)
-                    (make-posn 2 0)
-                    (make-posn 2 1)
-                    (make-posn 2 2)))
-(test ((neighbors (empty-world 11)) (make-posn 1 0))
-              (list 'boundary
-                    (make-posn 2 0)
-                    (make-posn 0 1)
-                    (make-posn 1 1)))
-(test ((neighbors (make-world (list
-                                       (make-cell (make-posn 0 1) false)
-                                       (make-cell (make-posn 1 0) false)
-                                       (make-cell (make-posn 1 1) true)
-                                       (make-cell (make-posn 1 2) false)
-                                       (make-cell (make-posn 2 0) false)
-                                       (make-cell (make-posn 2 1) false)
-                                       (make-cell (make-posn 2 2) false))
-                                      (make-posn 1 1)
-                                      'playing
-                                      3
-                                      (make-posn 0 0)
-                                      false))
-               (make-posn 1 1))
-              '())
-(test ((neighbors (make-world (list
-                                       (make-cell (make-posn 0 1) false)
-                                       (make-cell (make-posn 1 0) false)
-                                       (make-cell (make-posn 1 1) true)
-                                       (make-cell (make-posn 1 2) false)
-                                       (make-cell (make-posn 2 0) false)
-                                       (make-cell (make-posn 2 1) false)
-                                       (make-cell (make-posn 2 2) false))
-                                      (make-posn 1 1)
-                                      'playing
-                                      3
-                                      (make-posn 0 0)
-                                      false))
-               (make-posn 1 0))
-              (list 'boundary (make-posn 2 0) (make-posn 0 1)))
-]
-
-@chunk[<adjacent>
-;; adjacent : posn number -> (listof posn)
-;; returns a list of the posns that are adjacent to
-;; `p' on an infinite hex grid
-(define (adjacent p board-size)
-  (local [(define x (posn-x p))
-          (define y (posn-y p))]
-    (cond
-      [(even? y)
-       (list (make-posn (- x 1) (- y 1))
-             (make-posn x (- y 1))
-             (make-posn (- x 1) y)
-             (make-posn (+ x 1) y)
-             (make-posn (- x 1) (+ y 1))
-             (make-posn x (+ y 1)))]
-      [else
-       (list (make-posn x (- y 1))
-             (make-posn (+ x 1) (- y 1))
-             (make-posn (- x 1) y)
-             (make-posn (+ x 1) y)
-             (make-posn x (+ y 1))
-             (make-posn (+ x 1) (+ y 1)))])))]
+       (test ((neighbors (empty-world 11))  (make-posn 1 1))
+             (adjacent (make-posn 1 1)))
+       (test ((neighbors (empty-world 11)) (make-posn 2 2))
+             (adjacent (make-posn 2 2)))
+       (test ((neighbors (empty-world 3)) 'boundary)
+             (list (make-posn 0 1)
+                   (make-posn 1 0)
+                   (make-posn 1 2)
+                   (make-posn 2 0)
+                   (make-posn 2 1)
+                   (make-posn 2 2)))
+       (test ((neighbors (make-world (list
+                                      (make-cell (make-posn 0 1) #f)
+                                      (make-cell (make-posn 1 0) #f)
+                                      (make-cell (make-posn 1 1) #t)
+                                      (make-cell (make-posn 1 2) #f)
+                                      (make-cell (make-posn 2 0) #f)
+                                      (make-cell (make-posn 2 1) #f)
+                                      (make-cell (make-posn 2 2) #f))
+                                     (make-posn 1 1)
+                                     'playing
+                                     3
+                                     (make-posn 0 0)
+                                     #f))
+              (make-posn 1 1))
+             '())
+       (test ((neighbors (make-world (list
+                                      (make-cell (make-posn 0 1) #f)
+                                      (make-cell (make-posn 1 0) #f)
+                                      (make-cell (make-posn 1 1) #t)
+                                      (make-cell (make-posn 1 2) #f)
+                                      (make-cell (make-posn 2 0) #f)
+                                      (make-cell (make-posn 2 1) #f)
+                                      (make-cell (make-posn 2 2) #f))
+                                     (make-posn 1 1)
+                                     'playing
+                                     3
+                                     (make-posn 0 0)
+                                     #f))
+              (make-posn 1 0))
+             (list 'boundary (make-posn 2 0) (make-posn 0 1)))]
 
 @chunk[<adjacent-tests>
-(test (adjacent (make-posn 1 1) 11)
-              (list (make-posn 1 0)
-                    (make-posn 2 0)
-                    (make-posn 0 1)
-                    (make-posn 2 1)
-                    (make-posn 1 2)
-                    (make-posn 2 2)))
-(test (adjacent (make-posn 2 2) 11)
-              (list (make-posn 1 1)
-                    (make-posn 2 1)
-                    (make-posn 1 2)
-                    (make-posn 3 2)
-                    (make-posn 1 3)
-                    (make-posn 2 3)))]
+       (test (adjacent (make-posn 1 1))
+             (list (make-posn 1 0)
+                   (make-posn 2 0)
+                   (make-posn 0 1)
+                   (make-posn 2 1)
+                   (make-posn 1 2)
+                   (make-posn 2 2)))
+       (test (adjacent (make-posn 2 2))
+             (list (make-posn 1 1)
+                   (make-posn 2 1)
+                   (make-posn 1 2)
+                   (make-posn 3 2)
+                   (make-posn 1 3)
+                   (make-posn 2 3)))]
 
-@chunk[<on-boundary?>
-;; on-boundary? : posn number -> boolean
-(define (on-boundary? p board-size)
-  (or (= (posn-x p) 0)
-      (= (posn-y p) 0)
-      (= (posn-x p) (- board-size 1))
-      (= (posn-y p) (- board-size 1))))]
 
 @chunk[<on-boundary?-tests>
-(test (on-boundary? (make-posn 0 1) 13) true)
-(test (on-boundary? (make-posn 1 0) 13) true)
-(test (on-boundary? (make-posn 12 1) 13) true)
-(test (on-boundary? (make-posn 1 12) 13) true)
-(test (on-boundary? (make-posn 1 1) 13) false)
-(test (on-boundary? (make-posn 10 10) 13) false)]
+       (test (on-boundary? (make-posn 0 1) 13) #t)
+       (test (on-boundary? (make-posn 1 0) 13) #t)
+       (test (on-boundary? (make-posn 12 1) 13) #t)
+       (test (on-boundary? (make-posn 1 12) 13) #t)
+       (test (on-boundary? (make-posn 1 1) 13) #f)
+       (test (on-boundary? (make-posn 10 10) 13) #f)]
 
-@chunk[<in-bounds?>
-
-;; in-bounds? : posn number -> boolean
-(define (in-bounds? p board-size)
-  (and (<= 0 (posn-x p) (- board-size 1))
-       (<= 0 (posn-y p) (- board-size 1))
-       (not (equal? p (make-posn 0 0)))
-       (not (equal? p (make-posn 0 (- board-size 1))))))]
 
 @chunk[<in-bounds?-tests>
-(test (in-bounds? (make-posn 0 0) 11) false)
-(test (in-bounds? (make-posn 0 1) 11) true)
-(test (in-bounds? (make-posn 1 0) 11) true)
-(test (in-bounds? (make-posn 10 10) 11) true)
-(test (in-bounds? (make-posn 0 -1) 11) false)
-(test (in-bounds? (make-posn -1 0) 11) false)
-(test (in-bounds? (make-posn 0 11) 11) false)
-(test (in-bounds? (make-posn 11 0) 11) false)
-(test (in-bounds? (make-posn 10 0) 11) true)
-(test (in-bounds? (make-posn 0 10) 11) false)]
+       (test (in-bounds? (make-posn 0 0) 11) #f)
+       (test (in-bounds? (make-posn 0 1) 11) #t)
+       (test (in-bounds? (make-posn 1 0) 11) #t)
+       (test (in-bounds? (make-posn 10 10) 11) #t)
+       (test (in-bounds? (make-posn 0 -1) 11) #f)
+       (test (in-bounds? (make-posn -1 0) 11) #f)
+       (test (in-bounds? (make-posn 0 11) 11) #f)
+       (test (in-bounds? (make-posn 11 0) 11) #f)
+       (test (in-bounds? (make-posn 10 0) 11) #t)
+       (test (in-bounds? (make-posn 0 10) 11) #f)]
 
-@chunk[<extended-arithmetic-ops>
-;; <=/f : (number or '∞) (number or '∞) -> boolean
-(define (<=/f a b)
-  (cond
-    [(equal? b '∞) true]
-    [(equal? a '∞) false]
-    [else (<= a b)]))
+@chunk[<on-cats-path?-tests>
+       (test ((on-cats-path? (make-world (empty-board 5)
+                                         (make-posn 1 1)
+                                         'playing
+                                         5
+                                         (make-posn 0 0)
+                                         #t))
+              (make-posn 1 0))
+             #t)
+       (test ((on-cats-path? (make-world (empty-board 5)
+                                         (make-posn 1 1)
+                                         'playing
+                                         5 
+                                         (make-posn 0 0)
+                                         #f))
+              (make-posn 1 0))
+             #f)
 
-(define (+/f x y)
-  (cond
-    [(or (equal? x '∞) (equal? y '∞))
-     '∞]
-    [else
-     (+ x y)]))]
-
-@chunk[<extended-arithmetic-ops-tests>
-(test (<=/f 1 2) true)
-(test (<=/f 2 1) false)
-(test (<=/f '∞ 1) false)
-(test (<=/f 1 '∞) true)
-(test (<=/f '∞ '∞) true)
-
-(test (+/f '∞ '∞) '∞)
-(test (+/f '∞ 1) '∞)
-(test (+/f 1 '∞) '∞)
-(test (+/f 1 2) 3)]
-
-@section{Init Junk}
-
-@chunk[<init-junk>
-]
-
-@chunk[<test-infrastructure>
-
-(define-syntax (test stx)
-  (syntax-case stx ()
-    [(_ actual expected)
-     (with-syntax ([line (syntax-line stx)])
-       #'(test/proc (λ () actual)
-                    (λ () expected)
-                    equal?
-                    line))]))
-
-(define-syntax (test/set stx)
-  (syntax-case stx ()
-    [(_ actual expected)
-     (with-syntax ([line (syntax-line stx)])
-       #'(test/proc (λ () actual)
-                    (λ () expected)
-                    (λ (x y) (same-sets? x y))
-                    line))]))
-
-(define test-count 0)
-(define test-procs '())
-
-(define (test/proc actual-thunk expected-thunk cmp line)
-  (set! test-procs
-        (cons
-         (λ ()
-           (set! test-count (+ test-count 1))
-           (let ([actual (actual-thunk)]
-                 [expected (expected-thunk)])
-             (unless (cmp actual expected)
-               (error 'check-expect "test ~a on line ~a failed:\n  ~s\n  ~s\n"
-                      test-count
-                      line
-                      actual
-                      expected))))
-         test-procs)))
+       (test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1)
+                                         'playing 5 (make-posn 0 0) #t))
+              (make-posn 2 1))
+             #f)
+       (test ((on-cats-path?
+               (make-world (list
+                            (make-cell (make-posn 0 1) #t)
+                            (make-cell (make-posn 1 0) #t)
+                            (make-cell (make-posn 1 1) #f)
+                            (make-cell (make-posn 1 2) #t)
+                            (make-cell (make-posn 2 0) #t)
+                            (make-cell (make-posn 2 1) #t)
+                            (make-cell (make-posn 2 2) #t))
+                           (make-posn 1 1)
+                           'cat-lost
+                           3
+                           (make-posn 0 0)
+                           #t))
+              (make-posn 0 1))
+             #f)]
 
 
-(define (same-sets? l1 l2)
-  (and (andmap (lambda (e1) (member e1 l2)) l1)
-       (andmap (lambda (e2) (member e2 l1)) l2)
-       #t))
+@chunk[<+/f-tests>       
+       (test (+/f '∞ '∞) '∞)
+       (test (+/f '∞ 1) '∞)
+       (test (+/f 1 '∞) '∞)
+       (test (+/f 1 2) 3)]
 
-(test (same-sets? (list) (list)) true)
-(test (same-sets? (list) (list 1)) false)
-(test (same-sets? (list 1) (list)) false)
-(test (same-sets? (list 1 2) (list 2 1)) true)
+@chunk[<render-world-tests>
 
-(define (run-tests)
-  (for-each (λ (t) (t)) (reverse test-procs))
-  (printf "passed ~s tests\n" test-count)
-  (flush-output))]
+       (test
+        (render-world
+         (make-world (list (make-cell (make-posn 0 1) #f))
+                     (make-posn 0 1)
+                     'playing
+                     3
+                     (make-posn 0 0)
+                     #f))
+        (overlay
+         (render-board (list (make-cell (make-posn 0 1) #f))
+                       3
+                       (lambda (x) #t)
+                       #f)
+         (move-pinhole thinking-cat
+                       (- (cell-center-x (make-posn 0 1)))
+                       (- (cell-center-y (make-posn 0 1))))))
+       
+       (test
+        (render-world
+         (make-world (list (make-cell (make-posn 0 1) #f))
+                     (make-posn 0 1)
+                     'cat-won
+                     3
+                     #f
+                     #f))
+        (overlay
+         (render-board (list (make-cell (make-posn 0 1) #f))
+                       3
+                       (lambda (x) #t)
+                       #f)
+         (move-pinhole happy-cat
+                       (- (cell-center-x (make-posn 0 1)))
+                       (- (cell-center-y (make-posn 0 1))))))
+       
+       (test
+        (render-world
+         (make-world (list (make-cell (make-posn 0 1) #f))
+                     (make-posn 0 1)
+                     'cat-lost
+                     3
+                     #f
+                     #f))
+        (overlay
+         (render-board (list (make-cell (make-posn 0 1) #f))
+                       3
+                       (lambda (x) #t)
+                       #f)
+         (move-pinhole mad-cat
+                       (- (cell-center-x (make-posn 0 1)))
+                       (- (cell-center-y (make-posn 0 1))))))
+       
+       (test
+        (render-world
+         (make-world (list
+                      (make-cell (make-posn 0 1) #t)
+                      (make-cell (make-posn 1 0) #t)
+                      (make-cell (make-posn 1 1) #f)
+                      (make-cell (make-posn 1 2) #t)
+                      (make-cell (make-posn 2 0) #t)
+                      (make-cell (make-posn 2 1) #t)
+                      (make-cell (make-posn 2 2) #t))
+                     (make-posn 1 1)
+                     'cat-lost
+                     3
+                     #f
+                     #f))
+        (overlay
+         (render-board (list
+                        (make-cell (make-posn 0 1) #t)
+                        (make-cell (make-posn 1 0) #t)
+                        (make-cell (make-posn 1 1) #f)
+                        (make-cell (make-posn 1 2) #t)
+                        (make-cell (make-posn 2 0) #t)
+                        (make-cell (make-posn 2 1) #t)
+                        (make-cell (make-posn 2 2) #t))
+                       3
+                       (lambda (x) #f)
+                       #f)
+         (move-pinhole mad-cat
+                       (- (cell-center-x (make-posn 1 1)))
+                       (- (cell-center-y (make-posn 1 1))))))
+       
+       (test
+        (render-world
+         (make-world (list
+                      (make-cell (make-posn 0 1) #f)
+                      (make-cell (make-posn 1 0) #f)
+                      (make-cell (make-posn 1 1) #f)
+                      (make-cell (make-posn 1 2) #f)
+                      (make-cell (make-posn 2 0) #f)
+                      (make-cell (make-posn 2 1) #f)
+                      (make-cell (make-posn 2 2) #f))
+                     (make-posn 1 1)
+                     'cat-lost
+                     3
+                     (make-posn (cell-center-x (make-posn 0 1))
+                                (cell-center-y (make-posn 0 1)))
+                     #t))
+        
+        (overlay
+         (render-board (list
+                        (make-cell (make-posn 0 1) #f)
+                        (make-cell (make-posn 1 0) #f)
+                        (make-cell (make-posn 1 1) #f)
+                        (make-cell (make-posn 1 2) #f)
+                        (make-cell (make-posn 2 0) #f)
+                        (make-cell (make-posn 2 1) #f)
+                        (make-cell (make-posn 2 2) #f))
+                       3
+                       (lambda (x) #t)
+                       (make-posn (cell-center-x (make-posn 0 1))
+                                  (cell-center-y (make-posn 0 1))))
+         (move-pinhole mad-cat
+                       (- (cell-center-x (make-posn 1 1)))
+                       (- (cell-center-y (make-posn 1 1))))))]
+
+@chunk[<chop-whiskers-tests>
+       (test (chop-whiskers (rectangle 6 6 'solid 'black))
+             (put-pinhole (rectangle 3 3 'solid 'black) 0 0))
+
+       (test
+        (pinhole-x
+         (render-world
+          (make-world
+           (empty-board 3)
+           (make-posn 0 0)
+           'playing
+           3
+           (make-posn 0 0)
+           #f)))
+        0)
+       (test
+        (pinhole-x
+         (render-world
+          (make-world
+           (empty-board 3)
+           (make-posn 0 1)
+           'playing
+           3
+           (make-posn 0 0)
+           #f)))
+        0)]
+
+@chunk[<render-board-tests>
+       (test (render-board (list (make-cell (make-posn 0 0) #f))
+                           3
+                           (lambda (x) #f)
+                           #f)
+             (overlay
+              (nw:rectangle (world-width 3)
+                            (world-height 3)
+                            'solid
+                            'white)
+              (render-cell (make-cell (make-posn 0 0) #f)
+                           #f
+                           #f)))
+       
+       (test (render-board (list (make-cell (make-posn 0 0) #f))
+                           3
+                           (lambda (x) #t)
+                           #f)
+             (overlay
+              (nw:rectangle (world-width 3)
+                            (world-height 3)
+                            'solid
+                            'white)
+              (render-cell (make-cell (make-posn 0 0) #f)
+                           #t
+                           #f)))
+       
+       
+       (test (render-board (list (make-cell (make-posn 0 0) #f))
+                           3
+                           (lambda (x) #f)
+                           #f)
+             (overlay
+              (nw:rectangle (world-width 3)
+                            (world-height 3)
+                            'solid
+                            'white)
+              (render-cell (make-cell (make-posn 0 0) #f)
+                           #f
+                           #f)))
+       
+       (test (render-board (list (make-cell (make-posn 0 0) #f)
+                                 (make-cell (make-posn 0 1) #f))
+                           3
+                           (lambda (x) (equal? x (make-posn 0 1)))
+                           #f)
+             (overlay
+              (nw:rectangle (world-width 3)
+                            (world-height 3)
+                            'solid
+                            'white)
+              (render-cell (make-cell (make-posn 0 0) #f)
+                           #f
+                           #f)
+              (render-cell (make-cell (make-posn 0 1) #f)
+                           #t
+                           #f)))
+       
+       (test (render-board (list (make-cell (make-posn 0 0) #f)
+                                 (make-cell (make-posn 0 1) #f))
+                           3
+                           (lambda (x) (equal? x (make-posn 0 1)))
+                           (make-posn 0 0))
+             (overlay
+              (nw:rectangle (world-width 3)
+                            (world-height 3)
+                            'solid
+                            'white)
+              (render-cell (make-cell (make-posn 0 0) #f)
+                           #f
+                           #t)
+              (render-cell (make-cell (make-posn 0 1) #f)
+                           #t
+                           #f)))]
 
 
-@section{Everything Else}
+@chunk[<render-cell-tests>
+       (test (render-cell (make-cell (make-posn 0 0) #f) #f #f)
+             (move-pinhole (circle circle-radius 'solid normal-color)
+                           (- circle-radius)
+                           (- circle-radius)))
+       (test (render-cell (make-cell (make-posn 0 0) #t) #f #f)
+             (move-pinhole (circle circle-radius 'solid 'black)
+                           (- circle-radius)
+                           (- circle-radius)))
+       (test (render-cell (make-cell (make-posn 0 0) #f) #t #f)
+             (move-pinhole (overlay (circle circle-radius 'solid normal-color)
+                                    (circle (quotient circle-radius 2) 'solid
+                                            on-shortest-path-color))
+                           (- circle-radius)
+                           (- circle-radius)))
+       (test (render-cell (make-cell (make-posn 0 0) #f) #t #t)
+             (move-pinhole (overlay (circle circle-radius 'solid normal-color)
+                                    (circle (quotient circle-radius 2) 'solid
+                                            under-mouse-color))
+                           (- circle-radius)
+                           (- circle-radius)))]
 
 
-@chunk[<everything-else>
+@chunk[<world-size-tests>
+       (test (world-width 3) 150)
+       (test (world-height 3) 117)]
 
-#;'()
+@chunk[<cell-center-x-tests>
+       (test (cell-center-x (make-posn 0 0))
+             circle-radius)
+       (test (cell-center-x (make-posn 1 0))
+             (+ (* 2 circle-spacing) circle-radius))
+       (test (cell-center-x (make-posn 1 1))
+             (+ (* 3 circle-spacing) circle-radius))]
+
+@chunk[<cell-center-y-tests>
+       (test (cell-center-y (make-posn 1 1))
+             (+ circle-radius (* 2 circle-spacing 866/1000)))]
 
 
-;; constants
-(define circle-radius 20)
-(define circle-spacing 22)
-
-(define normal-color 'lightskyblue)
-(define on-shortest-path-color 'white)
-(define blocked-color 'black)
-(define under-mouse-color 'black)
-
-
-;                                                                          
-;                                                                          
-;                                                                          
-;                                                                          
-;          ;;                                     ;;;;                     
-;       ;;;;                                      ;;;;;                    
-;        ;;;                              ;                                
-;    ;;; ;;;    ; ;;;;   ;;;;   ;;;;;;  ;;  ;;;;     ;;;;;;  ;;   ;;;; ;;; 
-;   ;;;;;;;;;;;;;; ;;;; ;;;;;;;;;  ;;   ;;   ;   ;;;;;  ;;; ;;;;  ;;;;;;;  
-;  ;;;;;;;;;  ;;; ;;;;;;;;;;;;;;; ;;;   ;;   ;;    ;;;  ;;; ;;;;  ;   ;;;; 
-;  ;;;   ;;;  ;;; ;;;; ;;;    ;;; ;;;   ;;;  ;;;   ;;;  ;;;; ;;;  ;;   ;;; 
-;  ;;   ;;;;  ;;;      ;;    ;;;; ;;;   ;;;; ;;;   ;;;  ;;;  ;;;   ;;;;;;; 
-;  ;;;;;;;;   ;;;      ;;;;;;;;;; ;;;   ;; ;;;;;  ;;;;  ;;;  ;;;       ;;; 
-;   ;;;;;;;;;;;;;;;;   ;;;;;;;;;;; ;;; ;;;  ;;;  ;;;;;;;;;;  ;;;  ;;;; ;;; 
-;                       ;;;;;        ;;;;                   ;;;; ;;;;; ;;; 
-;                                                             ;;;;;;; ;;;  
-;                                                                 ;;;;;;   
-;                                                                          
-
-
-;; render-world : world -> image
-(define (render-world w)
-  (chop-whiskers
-   (overlay (board->image (world-board w)
-                          (world-size w)
-                          (on-cats-path? w)
-                          (world-mouse-posn w))
-            (move-pinhole
-             (cond
-               [(equal? (world-state w) 'cat-won) happy-cat]
-               [(equal? (world-state w) 'cat-lost) sad-cat]
-               [else thinking-cat])
-             (- (cell-center-x (world-cat w)))
-             (- (cell-center-y (world-cat w)))))))
-
-(test
- (render-world
-  (make-world (list (make-cell (make-posn 0 1) false))
-              (make-posn 0 1)
-              'playing
-              2
-              (make-posn 0 0)
-              false))
- (overlay
-  (board->image (list (make-cell (make-posn 0 1) false))
-                2
-                (lambda (x) true)
-                false)
-  (move-pinhole thinking-cat
-                (- (cell-center-x (make-posn 0 1)))
-                (- (cell-center-y (make-posn 0 1))))))
-
-(test
- (render-world
-  (make-world (list (make-cell (make-posn 0 1) false))
-              (make-posn 0 1)
-              'cat-won
-              2
-              false
-              false))
- (overlay
-  (board->image (list (make-cell (make-posn 0 1) false))
-                2
-                (lambda (x) true)
-                false)
-  (move-pinhole happy-cat
-                (- (cell-center-x (make-posn 0 1)))
-                (- (cell-center-y (make-posn 0 1))))))
-
-(test
- (render-world
-  (make-world (list (make-cell (make-posn 0 1) false))
-              (make-posn 0 1)
-              'cat-lost
-              2
-              false
-              false))
- (overlay
-  (board->image (list (make-cell (make-posn 0 1) false))
-                2
-                (lambda (x) true)
-                false)
-  (move-pinhole sad-cat
-                (- (cell-center-x (make-posn 0 1)))
-                (- (cell-center-y (make-posn 0 1))))))
-
-(test
- (render-world
-  (make-world (list
-               (make-cell (make-posn 0 1) true)
-               (make-cell (make-posn 1 0) true)
-               (make-cell (make-posn 1 1) false)
-               (make-cell (make-posn 1 2) true)
-               (make-cell (make-posn 2 0) true)
-               (make-cell (make-posn 2 1) true)
-               (make-cell (make-posn 2 2) true))
-              (make-posn 1 1)
-              'cat-lost
-              3
-              false
-              false))
- (overlay
-  (board->image (list
-                 (make-cell (make-posn 0 1) true)
-                 (make-cell (make-posn 1 0) true)
-                 (make-cell (make-posn 1 1) false)
-                 (make-cell (make-posn 1 2) true)
-                 (make-cell (make-posn 2 0) true)
-                 (make-cell (make-posn 2 1) true)
-                 (make-cell (make-posn 2 2) true))
-                3
-                (lambda (x) false)
-                false)
-  (move-pinhole sad-cat
-                (- (cell-center-x (make-posn 1 1)))
-                (- (cell-center-y (make-posn 1 1))))))
-
-(test
- (render-world
-  (make-world (list
-               (make-cell (make-posn 0 1) false)
-               (make-cell (make-posn 1 0) false)
-               (make-cell (make-posn 1 1) false)
-               (make-cell (make-posn 1 2) false)
-               (make-cell (make-posn 2 0) false)
-               (make-cell (make-posn 2 1) false)
-               (make-cell (make-posn 2 2) false))
-              (make-posn 1 1)
-              'cat-lost
-              3
-              (make-posn (cell-center-x (make-posn 0 1))
-                         (cell-center-y (make-posn 0 1)))
-              true))
-
- (overlay
-  (board->image (list
-                 (make-cell (make-posn 0 1) false)
-                 (make-cell (make-posn 1 0) false)
-                 (make-cell (make-posn 1 1) false)
-                 (make-cell (make-posn 1 2) false)
-                 (make-cell (make-posn 2 0) false)
-                 (make-cell (make-posn 2 1) false)
-                 (make-cell (make-posn 2 2) false))
-                3
-                (lambda (x) true)
-                (make-posn (cell-center-x (make-posn 0 1))
-                           (cell-center-y (make-posn 0 1))))
-  (move-pinhole sad-cat
-                (- (cell-center-x (make-posn 1 1)))
-                (- (cell-center-y (make-posn 1 1))))))
-
-;; chop-whiskers : image -> image
-;; crops the image so that anything above or to the left of the pinhole is gone
-(define (chop-whiskers img)
-  (shrink img
-          0
-          0
-          (- (image-width img) (pinhole-x img) 1)
-          (- (image-height img) (pinhole-y img) 1)))
-
-(test (chop-whiskers (rectangle 5 5 'solid 'black))
-              (put-pinhole (rectangle 3 3 'solid 'black) 0 0))
-(test (chop-whiskers (rectangle 6 6 'solid 'black))
-              (put-pinhole (rectangle 3 3 'solid 'black) 0 0))
-
-(test
- (pinhole-x
-  (render-world
-   (make-world
-    (empty-board 3)
-    (make-posn 0 0)
-    'playing
-    3
-    (make-posn 0 0)
-    false)))
- 0)
-(test
- (pinhole-x
-  (render-world
-   (make-world
-    (empty-board 3)
-    (make-posn 0 1)
-    'playing
-    3
-    (make-posn 0 0)
-    false)))
- 0)
-
-
-;; board->image : board number (posn -> boolean) posn-or-false -> image
-(define (board->image cs world-size on-cat-path? mouse)
-  (foldl (lambda (x y) (overlay y x))
-         (nw:rectangle (world-width world-size)
-                       (world-height world-size)
-                       'solid
-                       'white)
-         (map (lambda (c)
-                (cell->image c
-                             (on-cat-path? (cell-p c))
-                             (and (posn? mouse)
-                                  (equal? mouse (cell-p c)))
-                             #;
-                             (and (posn? mouse)
-                                  (point-in-this-circle? (cell-p c)
-                                                         (posn-x mouse)
-                                                         (posn-y mouse)))))
-              cs)))
-
-(test (board->image (list (make-cell (make-posn 0 0) false))
-                            3
-                            (lambda (x) false)
-                            false)
-              (overlay
-               (nw:rectangle (world-width 3)
-                             (world-height 3)
-                             'solid
-                             'white)
-               (cell->image (make-cell (make-posn 0 0) false)
-                            false
-                            false)))
-
-(test (board->image (list (make-cell (make-posn 0 0) false))
-                            3
-                            (lambda (x) true)
-                            false)
-              (overlay
-               (nw:rectangle (world-width 3)
-                             (world-height 3)
-                             'solid
-                             'white)
-               (cell->image (make-cell (make-posn 0 0) false)
-                            true
-                            false)))
-
-
-(test (board->image (list (make-cell (make-posn 0 0) false))
-                            3
-                            (lambda (x) false)
-                            false)
-              (overlay
-               (nw:rectangle (world-width 3)
-                             (world-height 3)
-                             'solid
-                             'white)
-               (cell->image (make-cell (make-posn 0 0) false)
-                            false
-                            false)))
-
-(test (board->image (list (make-cell (make-posn 0 0) false)
-                                  (make-cell (make-posn 0 1) false))
-                            3
-                            (lambda (x) (equal? x (make-posn 0 1)))
-                            false)
-              (overlay
-               (nw:rectangle (world-width 3)
-                             (world-height 3)
-                             'solid
-                             'white)
-               (cell->image (make-cell (make-posn 0 0) false)
-                            false
-                            false)
-               (cell->image (make-cell (make-posn 0 1) false)
-                            true
-                            false)))
-
-(test (board->image (list (make-cell (make-posn 0 0) false)
-                                  (make-cell (make-posn 0 1) false))
-                            3
-                            (lambda (x) (equal? x (make-posn 0 1)))
-                            (make-posn 0 0))
-              (overlay
-               (nw:rectangle (world-width 3)
-                             (world-height 3)
-                             'solid
-                             'white)
-               (cell->image (make-cell (make-posn 0 0) false)
-                            false
-                            true)
-               (cell->image (make-cell (make-posn 0 1) false)
-                            true
-                            false)))
-
-;; cell->image : cell boolean boolean -> image
-(define (cell->image c on-short-path? under-mouse?)
-  (local [(define x (cell-center-x (cell-p c)))
-          (define y (cell-center-y (cell-p c)))
-          (define main-circle
-            (cond
-              [(cell-blocked? c)
-               (circle circle-radius 'solid blocked-color)]
-              [else
-               (circle circle-radius 'solid normal-color)]))]
-    (move-pinhole
-     (cond
-       [under-mouse?
-        (overlay main-circle
-                 (circle (quotient circle-radius 2) 'solid under-mouse-color))]
-       [on-short-path?
-        (overlay main-circle
-                 (circle (quotient circle-radius 2) 'solid
-                         on-shortest-path-color))]
-       [else
-        main-circle])
-     (- x)
-     (- y))))
-
-(test (cell->image (make-cell (make-posn 0 0) false) false false)
-              (move-pinhole (circle circle-radius 'solid normal-color)
-                            (- circle-radius)
-                            (- circle-radius)))
-(test (cell->image (make-cell (make-posn 0 0) true) false false)
-              (move-pinhole (circle circle-radius 'solid 'black)
-                            (- circle-radius)
-                            (- circle-radius)))
-(test (cell->image (make-cell (make-posn 0 0) false) true false)
-              (move-pinhole (overlay (circle circle-radius 'solid normal-color)
-                                     (circle (quotient circle-radius 2) 'solid
-                                             on-shortest-path-color))
-                            (- circle-radius)
-                            (- circle-radius)))
-(test (cell->image (make-cell (make-posn 0 0) false) true true)
-              (move-pinhole (overlay (circle circle-radius 'solid normal-color)
-                                     (circle (quotient circle-radius 2) 'solid
-                                             under-mouse-color))
-                            (- circle-radius)
-                            (- circle-radius)))
-
-;; world-width : number -> number
-;; computes the width of the drawn world in terms of its size
-(define (world-width board-size)
-  (local [(define rightmost-posn
-            (make-posn (- board-size 1) (- board-size 2)))]
-    (+ (cell-center-x rightmost-posn) circle-radius)))
-
-(test (world-width 3) 150)
-
-;; world-height : number -> number
-;; computes the height of the drawn world in terms of its size
-(define (world-height board-size)
-  (local [(define bottommost-posn
-            (make-posn (- board-size 1) (- board-size 1)))]
-    (+ (cell-center-y bottommost-posn) circle-radius)))
-(test (world-height 3) 116.208)
-
-
-;; cell-center-x : posn -> number
-(define (cell-center-x p)
-  (local [(define x (posn-x p))
-          (define y (posn-y p))]
-    (+ circle-radius
-       (* x circle-spacing 2)
-       (if (odd? y)
-           circle-spacing
-           0))))
-
-(test (cell-center-x (make-posn 0 0))
-              circle-radius)
-(test (cell-center-x (make-posn 0 1))
-              (+ circle-spacing circle-radius))
-(test (cell-center-x (make-posn 1 0))
-              (+ (* 2 circle-spacing) circle-radius))
-(test (cell-center-x (make-posn 1 1))
-              (+ (* 3 circle-spacing) circle-radius))
-
-;; cell-center-y : posn -> number
-(define (cell-center-y p)
-  (local [(define y (posn-y p))]
-    (+ circle-radius
-       (* y circle-spacing 2
-          .866 ;; .866 is an exact approximate to sin(pi/3)
-          ))))
-
-(test (cell-center-y (make-posn 1 1))
-              (+ circle-radius (* 2 circle-spacing .866)))
-(test (cell-center-y (make-posn 1 0))
-              circle-radius)
-
-
-;                                          
-;                                          
-;                                          
-;                                          
-;                                          
-;          ;;;;;  ;;;;         ;;;;;;      
-;            ;;;  ;;;;;          ;;;;      
-;            ;;;                 ;;;       
-;    ;;;;;;  ;;;     ;   ;;;;;;  ;;;  ;;;; 
-;   ;;; ;;;; ;;; ;;;;;  ;;; ;;;; ;;; ;;;;;;
-;  ;;; ;;;;; ;;;   ;;; ;;; ;;;;; ;;; ;;;;; 
-;  ;;;  ;;;; ;;;   ;;; ;;;  ;;;; ;;;;      
-;  ;;;       ;;    ;;; ;;;        ;;;;;;   
-;  ;;;    ; ;;;   ;;;; ;;;    ;   ;;    ;; 
-;   ;;;  ;  ;;;; ;;;;;;;;;;  ;  ;;;;;  ;;;;
-;    ;;;;                ;;;;              
-;                                          
-;                                          
-;                                          
-
-
-(define (clack world x y evt)
-  (cond
-    [(equal? evt 'button-up)
-     (cond
-       [(and (equal? 'playing (world-state world))
-             (point-in-a-circle? (world-board world) x y))
-        (move-cat
-         (update-world-posn
-          (make-world (add-obstacle (world-board world) x y)
-                      (world-cat world)
-                      (world-state world)
-                      (world-size world)
-                      (world-mouse-posn world)
-                      (world-h-down? world))
-          (make-posn x y)))]
-       [else (update-world-posn world (make-posn x y))])]
-    [(equal? evt 'button-down)
-     world]
-    [(equal? evt 'drag) world]
-    [(equal? evt 'move)
-     (update-world-posn world (make-posn x y))]
-    [(equal? evt 'enter)
-     (update-world-posn world (make-posn x y))]
-    [(equal? evt 'leave)
-     (update-world-posn world false)]))
-
-(test (clack (make-world '() (make-posn 0 0) 'playing 1 false false)
-                     1 1 'button-down)
-              (make-world '() (make-posn 0 0) 'playing 1 false false))
-(test (clack (make-world '() (make-posn 0 0) 'playing 1 false false)
-                     1 1 'drag)
-              (make-world '() (make-posn 0 0) 'playing 1 false false))
-(test (clack (make-world (list (make-cell (make-posn 0 0) false))
-                                 (make-posn 0 1)
-                                 'playing
-                                 1
-                                 false
-                                 false)
-                     (cell-center-x (make-posn 0 0))
-                     (cell-center-y (make-posn 0 0))
-                     'move)
-              (make-world (list (make-cell (make-posn 0 0) false))
+@chunk[<clack-tests>
+       (test (clack 
+              (make-world '() (make-posn 0 0) 'playing 3 #f #f)
+              1 1 'button-down)
+             (make-world '() (make-posn 0 0) 'playing 3 #f #f))
+       (test (clack
+              (make-world '() (make-posn 0 0) 'playing 3 #f #f)
+              1 1 'drag)
+             (make-world '() (make-posn 0 0) 'playing 3 #f #f))
+       (test (clack 
+              (make-world (list (make-cell (make-posn 0 0) #f))
                           (make-posn 0 1)
                           'playing
-                          1
-                          (make-posn 0 0)
-                          false))
-(test (clack (make-world (list (make-cell (make-posn 0 0) false))
-                                 (make-posn 0 1)
-                                 'playing
-                                 1
-                                 false
-                                 false)
-                     (cell-center-x (make-posn 0 0))
-                     (cell-center-y (make-posn 0 0))
-                     'enter)
-              (make-world (list (make-cell (make-posn 0 0) false))
-                          (make-posn 0 1)
-                          'playing
-                          1
-                          (make-posn 0 0)
-                          false))
-(test (clack (make-world '() (make-posn 0 0)
-                                 'playing 1 (make-posn 0 0) false)
-                     1 1 'leave)
-              (make-world '() (make-posn 0 0) 'playing 1 false false))
-
-(test (clack (make-world '() (make-posn 0 0)
-                                 'playing 1 (make-posn 0 0) false)
-                     10
-                     10
-                     'button-down)
-              (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false))
-
-(test (clack (make-world (list (make-cell (make-posn 0 0) false)
-                                       (make-cell (make-posn 1 1) false))
-                                 (make-posn 1 1)
-                                 'playing
-                                 3
-                                 (make-posn 0 0)
-                                 false)
-                     (cell-center-x (make-posn 0 0))
-                     (cell-center-y (make-posn 0 0))
-                     'button-up)
-              (make-world (list (make-cell (make-posn 0 0) true)
-                                (make-cell (make-posn 1 1) false))
-                          (make-posn 1 1)
-                          'cat-lost
                           3
-                          (make-posn 0 0)
-                          false))
-
-
-(test (clack (make-world '() (make-posn 0 0)
-                                 'cat-lost 1 (make-posn 0 0) false)
-                     10
-                     10
-                     'button-up)
-              (make-world '() (make-posn 0 0)
-                          'cat-lost 1 (make-posn 0 0) false))
-(test (clack
-               (make-world
-                (list (make-cell (make-posn 1 0) false)
-                      (make-cell (make-posn 2 0) true)
-                      (make-cell (make-posn 0 1) true)
-                      (make-cell (make-posn 1 1) false)
-                      (make-cell (make-posn 2 1) true)
-                      (make-cell (make-posn 1 2) true)
-                      (make-cell (make-posn 2 2) true))
-                (make-posn 1 1)
-                'playing
-                3
-                false
-                false)
-               (cell-center-x (make-posn 1 0))
-               (cell-center-y (make-posn 1 0))
-               'button-up)
-              (make-world
-               (list (make-cell (make-posn 1 0) true)
-                     (make-cell (make-posn 2 0) true)
-                     (make-cell (make-posn 0 1) true)
-                     (make-cell (make-posn 1 1) false)
-                     (make-cell (make-posn 2 1) true)
-                     (make-cell (make-posn 1 2) true)
-                     (make-cell (make-posn 2 2) true))
-               (make-posn 1 1)
-               'cat-lost
-               3
-               (make-posn 1 0)
-               false))
-
-(test (clack
-               (make-world
-                (list (make-cell (make-posn 1 0) false)
-                      (make-cell (make-posn 2 0) false)
-                      (make-cell (make-posn 0 1) true)
-                      (make-cell (make-posn 1 1) false)
-                      (make-cell (make-posn 2 1) true)
-                      (make-cell (make-posn 1 2) true)
-                      (make-cell (make-posn 2 2) true))
-                (make-posn 1 1)
-                'playing
-                3
-                false
-                false)
-               (cell-center-x (make-posn 1 0))
-               (cell-center-y (make-posn 1 0))
-               'button-up)
-              (make-world
-               (list (make-cell (make-posn 1 0) true)
-                     (make-cell (make-posn 2 0) false)
-                     (make-cell (make-posn 0 1) true)
-                     (make-cell (make-posn 1 1) false)
-                     (make-cell (make-posn 2 1) true)
-                     (make-cell (make-posn 1 2) true)
-                     (make-cell (make-posn 2 2) true))
-               (make-posn 2 0)
-               'cat-won
-               3
-               (make-posn 1 0)
-               false))
-
-;; update-world-posn/playing : world posn-or-false -> world
-(define (update-world-posn w p)
-  (cond
-    [(equal? (world-state w) 'playing)
-     (cond
-       [(posn? p)
-        (local [(define mouse-spot
-                  (circle-at-point (world-board w)
-                                   (posn-x p)
-                                   (posn-y p)))]
-          (make-world (world-board w)
-                      (world-cat w)
-                      (world-state w)
-                      (world-size w)
-                      (cond
-                        [(equal? mouse-spot (world-cat w))
-                         false]
-                        [else
-                         mouse-spot])
-                      (world-h-down? w)))]
-       [else
-        (make-world (world-board w)
-                    (world-cat w)
-                    (world-state w)
-                    (world-size w)
-                    false
-                    (world-h-down? w))])]
-    [else w]))
-
-(test (update-world-posn
-               (make-world (list (make-cell (make-posn 0 0) false))
-                           (make-posn 0 1) 'playing 1 false false)
-               (make-posn (cell-center-x (make-posn 0 0))
-                          (cell-center-y (make-posn 0 0))))
-               (make-world (list (make-cell (make-posn 0 0) false))
-                           (make-posn 0 1) 'playing 1 (make-posn 0 0) false))
-
-(test (update-world-posn
-               (make-world (list (make-cell (make-posn 0 0) false))
-                           (make-posn 0 0) 'playing 1 false false)
-               (make-posn (cell-center-x (make-posn 0 0))
-                          (cell-center-y (make-posn 0 0))))
-               (make-world (list (make-cell (make-posn 0 0) false))
-                           (make-posn 0 0) 'playing 1 false false))
-
-(test (update-world-posn
-               (make-world (list (make-cell (make-posn 0 0) false))
-                           (make-posn 0 1) 'playing 1 (make-posn 0 0) false)
-               (make-posn 0 0))
-               (make-world (list (make-cell (make-posn 0 0) false))
-                           (make-posn 0 1) 'playing 1 false false))
-(test (update-world-posn
-               (make-world (list (make-cell (make-posn 0 0) false))
-                           (make-posn 0 1) 'cat-won 1 false false)
-               (make-posn (cell-center-x (make-posn 0 0))
-                          (cell-center-y (make-posn 0 0))))
-               (make-world (list (make-cell (make-posn 0 0) false))
-                           (make-posn 0 1) 'cat-won 1 false false))
-(test (update-world-posn
-               (make-world (list (make-cell (make-posn 0 0) false))
-                           (make-posn 0 1) 'cat-lost 1 false false)
-               (make-posn (cell-center-x (make-posn 0 0))
-                          (cell-center-y (make-posn 0 0))))
-               (make-world (list (make-cell (make-posn 0 0) false))
-                           (make-posn 0 1) 'cat-lost 1 false false))
-
-;; move-cat : world -> world
-(define (move-cat world)
-  (local [(define cat-position (world-cat world))
-          (define table (build-bfs-table world 'boundary))
-          (define neighbors (adjacent cat-position (world-size world)))
-          (define next-cat-positions
-            (find-best-positions neighbors
-                                 (map (lambda (p) (lookup-in-table table p))
-                                      neighbors)))
-          (define next-cat-position
-            (cond
-              [(boolean? next-cat-positions) false]
-              [else
-               (list-ref next-cat-positions
-                         (random (length next-cat-positions)))]))]
-    (make-world (world-board world)
-                (cond
-                  [(boolean? next-cat-position)
-                   cat-position]
-                  [else next-cat-position])
-                (cond
-                  [(boolean? next-cat-position)
-                   'cat-lost]
-                  [(on-boundary? next-cat-position (world-size world))
-                   'cat-won]
-                  [else 'playing])
-                (world-size world)
-                (world-mouse-posn world)
-                (world-h-down? world))))
-
-
-(test
- (move-cat
-  (make-world (list (make-cell (make-posn 1 0) false)
-                    (make-cell (make-posn 2 0) false)
-                    (make-cell (make-posn 3 0) false)
-                    (make-cell (make-posn 4 0) false)
-
-                    (make-cell (make-posn 0 1) false)
-                    (make-cell (make-posn 1 1) true)
-                    (make-cell (make-posn 2 1) true)
-                    (make-cell (make-posn 3 1) false)
-                    (make-cell (make-posn 4 1) false)
-
-                    (make-cell (make-posn 0 2) false)
-                    (make-cell (make-posn 1 2) true)
-                    (make-cell (make-posn 2 2) false)
-                    (make-cell (make-posn 3 2) true)
-                    (make-cell (make-posn 4 2) false)
-
-                    (make-cell (make-posn 0 3) false)
-                    (make-cell (make-posn 1 3) true)
-                    (make-cell (make-posn 2 3) false)
-                    (make-cell (make-posn 3 3) false)
-                    (make-cell (make-posn 4 3) false)
-
-                    (make-cell (make-posn 1 4) false)
-                    (make-cell (make-posn 2 4) false)
-                    (make-cell (make-posn 3 4) false)
-                    (make-cell (make-posn 4 4) false))
-              (make-posn 2 2)
+                          #f
+                          #f)
+              (cell-center-x (make-posn 0 0))
+              (cell-center-y (make-posn 0 0))
+              'move)
+             (make-world
+              (list (make-cell (make-posn 0 0) #f))
+              (make-posn 0 1)
               'playing
-              5
+              3
               (make-posn 0 0)
-              false))
- (make-world (list (make-cell (make-posn 1 0) false)
-                   (make-cell (make-posn 2 0) false)
-                   (make-cell (make-posn 3 0) false)
-                   (make-cell (make-posn 4 0) false)
+              #f))
+       (test (clack 
+              (make-world (list (make-cell (make-posn 0 0) #f))
+                          (make-posn 0 1)
+                          'playing
+                          3
+                          #f
+                          #f)
+              (cell-center-x (make-posn 0 0))
+              (cell-center-y (make-posn 0 0))
+              'enter)
+             (make-world
+              (list (make-cell (make-posn 0 0) #f))
+              (make-posn 0 1)
+              'playing
+              3
+              (make-posn 0 0)
+              #f))
+       (test (clack 
+              (make-world '() (make-posn 0 0)
+                          'playing 3 (make-posn 0 0) #f)
+                    1 1 'leave)
+             (make-world '() (make-posn 0 0) 'playing 3 #f #f))
+       
+       (test (clack (make-world '() (make-posn 0 0)
+                                'playing 3 (make-posn 0 0) #f)
+                    10
+                    10
+                    'button-down)
+             (make-world '() (make-posn 0 0) 'playing 3 #f #f))
+       
+       (test (clack (make-world (list (make-cell (make-posn 0 0) #f)
+                                      (make-cell (make-posn 1 1) #f))
+                                (make-posn 1 1)
+                                'playing
+                                3
+                                (make-posn 0 0)
+                                #f)
+                    (cell-center-x (make-posn 0 0))
+                    (cell-center-y (make-posn 0 0))
+                    'button-up)
+             (make-world (list (make-cell (make-posn 0 0) #t)
+                               (make-cell (make-posn 1 1) #f))
+                         (make-posn 1 1)
+                         'cat-lost
+                         3
+                         #f
+                         #f))
+       
+       
+       (test (clack (make-world '() (make-posn 0 0)
+                                'cat-lost 3 (make-posn 0 0) #f)
+                    10
+                    10
+                    'button-up)
+             (make-world '() (make-posn 0 0)
+                         'cat-lost 3 #f #f))
+       (test (clack
+              (make-world
+               (list (make-cell (make-posn 1 0) #f)
+                     (make-cell (make-posn 2 0) #t)
+                     (make-cell (make-posn 0 1) #t)
+                     (make-cell (make-posn 1 1) #f)
+                     (make-cell (make-posn 2 1) #t)
+                     (make-cell (make-posn 1 2) #t)
+                     (make-cell (make-posn 2 2) #t))
+               (make-posn 1 1)
+               'playing
+               3
+               #f
+               #f)
+              (cell-center-x (make-posn 1 0))
+              (cell-center-y (make-posn 1 0))
+              'button-up)
+             (make-world
+              (list (make-cell (make-posn 1 0) #t)
+                    (make-cell (make-posn 2 0) #t)
+                    (make-cell (make-posn 0 1) #t)
+                    (make-cell (make-posn 1 1) #f)
+                    (make-cell (make-posn 2 1) #t)
+                    (make-cell (make-posn 1 2) #t)
+                    (make-cell (make-posn 2 2) #t))
+              (make-posn 1 1)
+              'cat-lost
+              3
+              #f
+              #f))
+       
+       (test (clack
+              (make-world
+               (list (make-cell (make-posn 1 0) #f)
+                     (make-cell (make-posn 2 0) #f)
+                     (make-cell (make-posn 0 1) #t)
+                     (make-cell (make-posn 1 1) #f)
+                     (make-cell (make-posn 2 1) #t)
+                     (make-cell (make-posn 1 2) #t)
+                     (make-cell (make-posn 2 2) #t))
+               (make-posn 1 1)
+               'playing
+               3
+               #f
+               #f)
+              (cell-center-x (make-posn 1 0))
+              (cell-center-y (make-posn 1 0))
+              'button-up)
+             (make-world
+              (list (make-cell (make-posn 1 0) #t)
+                    (make-cell (make-posn 2 0) #f)
+                    (make-cell (make-posn 0 1) #t)
+                    (make-cell (make-posn 1 1) #f)
+                    (make-cell (make-posn 2 1) #t)
+                    (make-cell (make-posn 1 2) #t)
+                    (make-cell (make-posn 2 2) #t))
+              (make-posn 2 0)
+              'cat-won
+              3
+              #f
+              #f))]
 
-                   (make-cell (make-posn 0 1) false)
-                   (make-cell (make-posn 1 1) true)
-                   (make-cell (make-posn 2 1) true)
-                   (make-cell (make-posn 3 1) false)
-                   (make-cell (make-posn 4 1) false)
+@chunk[<update-world-posn-tests>
 
-                   (make-cell (make-posn 0 2) false)
-                   (make-cell (make-posn 1 2) true)
-                   (make-cell (make-posn 2 2) false)
-                   (make-cell (make-posn 3 2) true)
-                   (make-cell (make-posn 4 2) false)
-
-                   (make-cell (make-posn 0 3) false)
-                   (make-cell (make-posn 1 3) true)
-                   (make-cell (make-posn 2 3) false)
-                   (make-cell (make-posn 3 3) false)
-                   (make-cell (make-posn 4 3) false)
-
-                   (make-cell (make-posn 1 4) false)
-                   (make-cell (make-posn 2 4) false)
-                   (make-cell (make-posn 3 4) false)
-                   (make-cell (make-posn 4 4) false))
-             (make-posn 2 3)
-             'playing
-             5
-             (make-posn 0 0)
-             false))
-
-;; find-best-positions : (nelistof posn) (nelistof number or '∞)
-;;                       -> (nelistof posn) or false
-(define (find-best-positions posns scores)
-  (local [(define best-score (foldl (lambda (x sofar)
-                                      (if (<=/f x sofar)
-                                          x
-                                          sofar))
-                                    (first scores)
-                                    (rest scores)))]
-    (cond
-      [(symbol? best-score) false]
-      [else
-       (map
-        second
-        (filter (lambda (x) (equal? (first x) best-score))
-                (map list scores posns)))])))
-(test (find-best-positions (list (make-posn 0 0)) (list 1))
-              (list (make-posn 0 0)))
-(test (find-best-positions (list (make-posn 0 0)) (list '∞))
-              false)
-(test (find-best-positions (list (make-posn 0 0)
-                                         (make-posn 1 1))
-                                   (list 1 2))
-              (list (make-posn 0 0)))
-(test (find-best-positions (list (make-posn 0 0)
-                                         (make-posn 1 1))
-                                   (list 1 1))
-              (list (make-posn 0 0)
-                    (make-posn 1 1)))
-(test (find-best-positions (list (make-posn 0 0)
-                                         (make-posn 1 1))
-                                   (list '∞ 2))
-              (list (make-posn 1 1)))
-(test (find-best-positions (list (make-posn 0 0)
-                                         (make-posn 1 1))
-                                   (list '∞ '∞))
-              false)
-
-;; add-obstacle : board number number -> board
-(define (add-obstacle board x y)
-  (cond
-    [(empty? board) board]
-    [else
-     (local [(define cell (first board))
-             (define cx (cell-center-x (cell-p cell)))
-             (define cy (cell-center-y (cell-p cell)))]
-       (cond
-         [(and (<= (- cx circle-radius) x (+ cx circle-radius))
-               (<= (- cy circle-radius) y (+ cy circle-radius)))
-          (cons (make-cell (cell-p cell) true)
-                (rest board))]
-         [else
-          (cons cell (add-obstacle (rest board) x y))]))]))
-
-(test (add-obstacle (list (make-cell (make-posn 0 0) false))
-                            circle-spacing circle-spacing)
-              (list (make-cell (make-posn 0 0) true)))
-(test (add-obstacle (list (make-cell (make-posn 0 0) false)) 100 100)
-              (list (make-cell (make-posn 0 0) false)))
-(test (add-obstacle (list (make-cell (make-posn 0 0) false)
-                                  (make-cell (make-posn 0 1) false))
-                            circle-spacing circle-spacing)
-              (list (make-cell (make-posn 0 0) true)
-                    (make-cell (make-posn 0 1) false)))
-
-;; circle-at-point : board number number -> posn-or-false
-;; returns the posn corresponding to cell where the x,y coordinates are
-(define (circle-at-point board x y)
-  (cond
-    [(empty? board) false]
-    [else
-     (cond
-       [(point-in-this-circle? (cell-p (first board)) x y)
-        (cell-p (first board))]
-       [else
-        (circle-at-point (rest board) x y)])]))
-(test (circle-at-point empty 0 0) false)
-(test (circle-at-point (list (make-cell (make-posn 0 0) false))
-                               (cell-center-x (make-posn 0 0))
-                               (cell-center-y (make-posn 0 0)))
+       (test (update-world-posn
+              (make-world (list (make-cell (make-posn 0 0) #f))
+                          (make-posn 0 1) 'playing 3 #f #f)
+              (make-posn (cell-center-x (make-posn 0 0))
+                         (cell-center-y (make-posn 0 0))))
+             (make-world (list (make-cell (make-posn 0 0) #f))
+                         (make-posn 0 1) 'playing 3 (make-posn 0 0) #f))
+       
+       (test (update-world-posn
+              (make-world (list (make-cell (make-posn 0 0) #f))
+                          (make-posn 0 0) 'playing 3 #f #f)
+              (make-posn (cell-center-x (make-posn 0 0))
+                         (cell-center-y (make-posn 0 0))))
+             (make-world (list (make-cell (make-posn 0 0) #f))
+                         (make-posn 0 0) 'playing 3 #f #f))
+       
+       (test (update-world-posn
+              (make-world (list (make-cell (make-posn 0 0) #f))
+                          (make-posn 0 1) 'playing 3 (make-posn 0 0) #f)
               (make-posn 0 0))
-(test (circle-at-point (list (make-cell (make-posn 0 0) false))
-                               0 0)
-              false)
+             (make-world (list (make-cell (make-posn 0 0) #f))
+                         (make-posn 0 1) 'playing 3 #f #f))]
 
+@chunk[<move-cat-tests>
+       (test
+        (move-cat
+         (make-world (list (make-cell (make-posn 1 0) #f)
+                           (make-cell (make-posn 2 0) #f)
+                           (make-cell (make-posn 3 0) #f)
+                           (make-cell (make-posn 4 0) #f)
+                           
+                           (make-cell (make-posn 0 1) #f)
+                           (make-cell (make-posn 1 1) #t)
+                           (make-cell (make-posn 2 1) #t)
+                           (make-cell (make-posn 3 1) #f)
+                           (make-cell (make-posn 4 1) #f)
+                           
+                           (make-cell (make-posn 0 2) #f)
+                           (make-cell (make-posn 1 2) #t)
+                           (make-cell (make-posn 2 2) #f)
+                           (make-cell (make-posn 3 2) #t)
+                           (make-cell (make-posn 4 2) #f)
+                           
+                           (make-cell (make-posn 0 3) #f)
+                           (make-cell (make-posn 1 3) #t)
+                           (make-cell (make-posn 2 3) #f)
+                           (make-cell (make-posn 3 3) #f)
+                           (make-cell (make-posn 4 3) #f)
+                           
+                           (make-cell (make-posn 1 4) #f)
+                           (make-cell (make-posn 2 4) #f)
+                           (make-cell (make-posn 3 4) #f)
+                           (make-cell (make-posn 4 4) #f))
+                     (make-posn 2 2)
+                     'playing
+                     5
+                     (make-posn 0 0)
+                     #f))
+        (make-world (list (make-cell (make-posn 1 0) #f)
+                          (make-cell (make-posn 2 0) #f)
+                          (make-cell (make-posn 3 0) #f)
+                          (make-cell (make-posn 4 0) #f)
+                          
+                          (make-cell (make-posn 0 1) #f)
+                          (make-cell (make-posn 1 1) #t)
+                          (make-cell (make-posn 2 1) #t)
+                          (make-cell (make-posn 3 1) #f)
+                          (make-cell (make-posn 4 1) #f)
+                          
+                          (make-cell (make-posn 0 2) #f)
+                          (make-cell (make-posn 1 2) #t)
+                          (make-cell (make-posn 2 2) #f)
+                          (make-cell (make-posn 3 2) #t)
+                          (make-cell (make-posn 4 2) #f)
+                          
+                          (make-cell (make-posn 0 3) #f)
+                          (make-cell (make-posn 1 3) #t)
+                          (make-cell (make-posn 2 3) #f)
+                          (make-cell (make-posn 3 3) #f)
+                          (make-cell (make-posn 4 3) #f)
+                          
+                          (make-cell (make-posn 1 4) #f)
+                          (make-cell (make-posn 2 4) #f)
+                          (make-cell (make-posn 3 4) #f)
+                          (make-cell (make-posn 4 4) #f))
+                    (make-posn 2 3)
+                    'playing
+                    5
+                    (make-posn 0 0)
+                    #f))]
 
-;; point-in-a-circle? : board number number -> boolean
-(define (point-in-a-circle? board x y)
-  (posn? (circle-at-point board x y)))
-(test (point-in-a-circle? empty 0 0) false)
-(test (point-in-a-circle? (list (make-cell (make-posn 0 0) false))
-                                  (cell-center-x (make-posn 0 0))
-                                  (cell-center-y (make-posn 0 0)))
-              true)
-(test (point-in-a-circle? (list (make-cell (make-posn 0 0) false))
-                                  0 0)
-              false)
-
-;; point-in-this-circle? : posn number number -> boolean
-(define (point-in-this-circle? p x y)
-  (local [(define center (+ (cell-center-x p)
-                            (* (sqrt -1) (cell-center-y p))))
-          (define p2 (+ x (* (sqrt -1) y)))]
-    (<= (magnitude (- center p2)) circle-radius)))
-
-(test (point-in-this-circle? (make-posn 0 0)
-                                     (cell-center-x (make-posn 0 0))
-                                     (cell-center-y (make-posn 0 0)))
-              true)
-(test (point-in-this-circle? (make-posn 0 0) 0 0)
-              false)
-
-;; change : world key-event -> world
-(define (change w ke)
-  (make-world (world-board w)
-              (world-cat w)
-              (world-state w)
-              (world-size w)
-              (world-mouse-posn w)
-              (key=? ke #\h)))
-
-(test (change (make-world '() (make-posn 1 1)
-                                  'playing 1 (make-posn 0 0) false)
-                      #\h)
-              (make-world '() (make-posn 1 1)
-                          'playing 1 (make-posn 0 0) true))
-(test (change (make-world '() (make-posn 1 1)
-                                  'playing 1 (make-posn 0 0) true)
-                      'release)
-              (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) false))
+@chunk[<change-tests>
+       (test (change (make-world '() (make-posn 1 1)
+                                 'playing 3 (make-posn 0 0) #f)
+                     #\h)
+             (make-world '() (make-posn 1 1)
+                         'playing 3 (make-posn 0 0) #t))
+       (test (change (make-world '() (make-posn 1 1)
+                                 'playing 3 (make-posn 0 0) #t)
+                     'release)
+             (make-world '() (make-posn 1 1) 'playing 3 (make-posn 0 0) #f))]
 
 
 
 
-;                                
-;                                
-;                                
-;                                
-;                                
-;                        ;;;;    
-;                        ;;;     
-;                        ;;;   ; 
-;    ;;;;;;   ;;;;   ;;;;;;;;;;; 
-;   ;;; ;;;; ;;;;;;;;;   ;;;   ;;
-;  ;;; ;;;;;;;;;;;;;;;  ;;;      
-;  ;;;  ;;;;;;;    ;;;  ;;; ;;;; 
-;  ;;;      ;;    ;;;;  ;;; ;;;;;
-;  ;;;    ; ;;;;;;;;;;  ;;;  ;;;;
-;   ;;;  ;  ;;;;;;;;;;; ;;;   ;; 
-;    ;;;;    ;;;;;       ;;;;;   
-;                                
-;                                
-;                                
+@chunk[<point-in-this-circle?-tests>
+       (test (point-in-this-circle? (make-posn 0 0)
+                                    (cell-center-x (make-posn 0 0))
+                                    (cell-center-y (make-posn 0 0)))
+             #t)
+       (test (point-in-this-circle? (make-posn 0 0) 0 0)
+             #f)]
 
+@chunk[<find-best-positions-tests>
+       (test (find-best-positions (list (make-posn 0 0)) (list 1))
+             (list (make-posn 0 0)))
+       (test (find-best-positions (list (make-posn 0 0)) (list '∞))
+             #f)
+       (test (find-best-positions (list (make-posn 0 0)
+                                        (make-posn 1 1))
+                                  (list 1 2))
+             (list (make-posn 0 0)))
+       (test (find-best-positions (list (make-posn 0 0)
+                                        (make-posn 1 1))
+                                  (list 1 1))
+             (list (make-posn 0 0)
+                   (make-posn 1 1)))
+       (test (find-best-positions (list (make-posn 0 0)
+                                        (make-posn 1 1))
+                                  (list '∞ 2))
+             (list (make-posn 1 1)))
+       (test (find-best-positions (list (make-posn 0 0)
+                                        (make-posn 1 1))
+                                  (list '∞ '∞))
+             #f)]
 
-;; cat : symbol -> image
-(define (cat mode)
-  (local [(define face-color
-            (cond
-              [(symbol=? mode 'sad) 'pink]
-              [else 'lightgray]))
+@chunk[<lt/f-tests>
+       (test (<=/f 1 2) #t)
+       (test (<=/f 2 1) #f)
+       (test (<=/f '∞ 1) #f)
+       (test (<=/f 1 '∞) #t)
+       (test (<=/f '∞ '∞) #t)]
 
-          (define left-ear (regular-polygon 3 8 'solid 'black (/ pi -3)))
-          (define right-ear (regular-polygon 3 8 'solid 'black 0))
-          (define ear-x-offset 14)
-          (define ear-y-offset 9)
+@chunk[<circle-at-point-tests>
+       (test (circle-at-point empty 0 0) #f)
+       (test (circle-at-point (list (make-cell (make-posn 0 0) #f))
+                              (cell-center-x (make-posn 0 0))
+                              (cell-center-y (make-posn 0 0)))
+             (make-posn 0 0))
+       (test (circle-at-point (list (make-cell (make-posn 0 0) #f)
+                                    (make-cell (make-posn 0 1) #f))
+                              (cell-center-x (make-posn 0 1))
+                              (cell-center-y (make-posn 0 1)))
+             (make-posn 0 1))
+       (test (circle-at-point (list (make-cell (make-posn 0 0) #f))
+                              0 0)
+             #f)]
 
-          (define eye (overlay (ellipse 12 8 'solid 'black)
-                               (ellipse 6 4 'solid 'limegreen)))
-          (define eye-x-offset 8)
-          (define eye-y-offset 3)
+@chunk[<blocked-cells-tests>
+       (test (block-cell (make-posn 1 1)
+                         (list (make-cell (make-posn 0 0) #f)
+                               (make-cell (make-posn 1 1) #f)
+                               (make-cell (make-posn 2 2) #f)))
+             (list (make-cell (make-posn 0 0) #f)
+                   (make-cell (make-posn 1 1) #t)
+                   (make-cell (make-posn 2 2) #f)))
+       
+       (test (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0)
+                                                            #t))
+                                         3)
+             (list (make-cell (make-posn 0 0) #t)))
+       (test (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0)
+                                                            #f))
+                                         3)
+             (list (make-cell (make-posn 0 0) #t)))]
 
-          (define nose (regular-polygon 3 5 'solid 'black (/ pi 2)))
+@section{Run, program, run}
 
-          (define mouth-happy
-            (overlay (ellipse 8 8 'solid face-color)
-                     (ellipse 8 8 'outline 'black)
-                     (move-pinhole
-                      (rectangle 10 5 'solid face-color)
-                      0
-                      4)))
-          (define mouth-no-expression
-            (overlay (ellipse 8 8 'solid face-color)
-                     (ellipse 8 8 'outline face-color)
-                     (rectangle 10 5 'solid face-color)))
+This section contains the main expression that starts
+the Chat Noir game going. 
 
-          (define mouth
-            (cond
-              [(symbol=? mode 'happy) mouth-happy]
-              [else mouth-no-expression]))
-          (define mouth-x-offset 4)
-          (define mouth-y-offset -5)]
-
-    (add-line
-     (add-line
-      (add-line
-       (add-line
-        (add-line
-         (add-line
-          (overlay (move-pinhole left-ear (- ear-x-offset) ear-y-offset)
-                   (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset)
-                   (ellipse 40 26 'solid 'black)
-                   (ellipse 36 22 'solid face-color)
-                   (move-pinhole mouth (- mouth-x-offset) mouth-y-offset)
-                   (move-pinhole mouth mouth-x-offset mouth-y-offset)
-                   (move-pinhole eye (- eye-x-offset) eye-y-offset)
-                   (move-pinhole eye eye-x-offset eye-y-offset)
-                   (move-pinhole nose -1 -4))
-          6 4 30 12 'black)
-         6 4 30 4 'black)
-        6 4 30 -4 'black)
-       -6 4 -30 12 'black)
-      -6 4 -30 4 'black)
-     -6 4 -30 -4 'black)))
-
-(define happy-cat (cat 'happy))
-(define sad-cat (cat 'sad))
-(define thinking-cat (cat 'thinking))
-
-
-;                                                        
-;                                                        
-;                                                        
-;                                                        
-;                                                        
-;   ;;;;            ;;;;   ;;;;     ;;;;           ;;;;; 
-;   ;;;;;           ;;;;;  ;;;      ;;;;;            ;;; 
-;                          ;;;   ;                   ;;; 
-;      ;;;;;;  ;;      ; ;;;;;;;;;     ;   ;;;;   ;; ;;; 
-;  ;;;;;  ;;; ;;;; ;;;;;   ;;;   ;;;;;;;  ;;;;;;;;;  ;;; 
-;    ;;;  ;;; ;;;;   ;;;  ;;;        ;;; ;;;;;;;;;;  ;;; 
-;    ;;;  ;;;; ;;;   ;;;  ;;; ;;;;   ;;; ;;;    ;;;  ;;; 
-;    ;;;  ;;;  ;;;   ;;;  ;;; ;;;;;  ;;; ;;    ;;;;  ;;  
-;   ;;;;  ;;;  ;;;  ;;;;  ;;;  ;;;; ;;;; ;;;;;;;;;; ;;;  
-;  ;;;;;;;;;;  ;;; ;;;;;;;;;;   ;; ;;;;;;;;;;;;;;;;;;;;; 
-;             ;;;;         ;;;;;          ;;;;;          
-;               ;;;                                      
-;                                                        
-;                                                        
-;                                                    
-;                                                    
-;                                                    
-;                                                    
-;                                                    
-;  ;;;;;                                           ;;
-;   ;;;;                                        ;;;; 
-;   ;;;                                          ;;; 
-;   ;;; ;;;    ;;;;;    ;;;;   ;;   ; ;;;;   ;;; ;;; 
-;   ;;;;;;;;  ;;;;;;;  ;;;;;;;;;;;;;;; ;;;; ;;;;;;;; 
-;   ;;;;;;;; ;;;;;;;; ;;;;;;;;;;  ;;; ;;;;;;;;;;;;;; 
-;   ;;;   ;; ;;     ; ;;;    ;;;  ;;; ;;;; ;;;   ;;; 
-;   ;;;   ;; ;     ;; ;;    ;;;;  ;;;      ;;   ;;;; 
-;   ;;;;;;;  ;;;;;;;; ;;;;;;;;;;  ;;;      ;;;;;;;;  
-;  ;;;;;;;    ;;;;;;  ;;;;;;;;;;;;;;;;;;    ;;;;;;;;;
-;              ;;;;    ;;;;;                         
-;                                                    
-;                                                    
-;                                                    
-
-;; append-all : (listof (list X)) -> (listof X)
-(define (append-all ls)
-  (foldr append empty ls))
-
-(test (append-all empty) empty)
-(test (append-all (list (list 1 2 3))) (list 1 2 3))
-(test (append-all (list (list 1) (list 2) (list 3)))
-              (list 1 2 3))
-
-;; add-n-random-blocked-cells : number (listof cell) number -> (listof cell)
-(define (add-n-random-blocked-cells n all-cells board-size)
-  (cond
-    [(zero? n) all-cells]
-    [else
-     (local [(define unblocked-cells
-               (filter (lambda (x)
-                         (let ([cat-cell? (and (= (posn-x (cell-p x))
-                                                  (quotient board-size 2))
-                                               (= (posn-y (cell-p x))
-                                                  (quotient board-size 2)))])
-
-                           (and (not (cell-blocked? x))
-                                (not cat-cell?))))
-                       all-cells))
-             (define to-block (list-ref unblocked-cells
-                                        (random (length unblocked-cells))))]
-       (add-n-random-blocked-cells
-        (sub1 n)
-        (block-cell (cell-p to-block) all-cells)
-        board-size))]))
-
-;; block-cell : posn board -> board
-(define (block-cell to-block board)
-  (map (lambda (c) (if (equal? to-block (cell-p c))
-                       (make-cell to-block true)
-                       c))
-       board))
-(test (block-cell (make-posn 1 1)
-                          (list (make-cell (make-posn 0 0) false)
-                                (make-cell (make-posn 1 1) false)
-                                (make-cell (make-posn 2 2) false)))
-              (list (make-cell (make-posn 0 0) false)
-                    (make-cell (make-posn 1 1) true)
-                    (make-cell (make-posn 2 2) false)))
-
-(test (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0)
-                                                             true))
-                                          10)
-              (list (make-cell (make-posn 0 0) true)))
-(test (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0)
-                                                             false))
-                                          10)
-              (list (make-cell (make-posn 0 0) true)))
-
-(define dummy
-  (local
-    [(define board-size 11)
-     (define initial-board
-       (add-n-random-blocked-cells
-        6
-        (empty-board board-size)
-        board-size))
-     (define initial-world
-       (make-world initial-board
-                   (make-posn (quotient board-size 2)
-                              (quotient board-size 2))
-                   'playing
-                   board-size
-                   false
-                   false))]
-
-    (and
-     (big-bang (world-width board-size)
-               (world-height board-size)
-               1
-               initial-world)
-     (on-redraw render-world)
-     (on-key-event change)
-     (on-mouse-event clack))))
-
-(run-tests)
-]
+@chunk[<go>
+       (let* ([board-size 11]
+              [initial-board
+               (add-n-random-blocked-cells
+                6
+                (empty-board board-size)
+                board-size)]
+              [initial-world
+               (make-world initial-board
+                           (make-posn (quotient board-size 2)
+                                      (quotient board-size 2))
+                           'playing
+                           board-size
+                           #f
+                           #f)])
+         
+         (big-bang initial-world
+                   (on-draw render-world
+                            (world-width board-size)
+                            (world-height board-size))
+                   (on-key change)
+                   (on-mouse clack)
+                   (name '|Chat Noir|))
+         (void))]
diff --git a/collects/games/chat-noir/chat-noir-module.ss b/collects/games/chat-noir/chat-noir-module.ss
deleted file mode 100644
index b00cff6de0..0000000000
--- a/collects/games/chat-noir/chat-noir-module.ss
+++ /dev/null
@@ -1,5 +0,0 @@
-(module chat-noir-module lang/htdp-intermediate-lambda
-  (require (lib "world.ss" "htdp"))
-;  (require "hash.ss")
-  (require (lib "include.ss" "scheme"))
-  (include "chat-noir.ss"))
diff --git a/collects/games/chat-noir/chat-noir-unit.ss b/collects/games/chat-noir/chat-noir-unit.ss
index 26bd3b08e1..d6407a9ef0 100644
--- a/collects/games/chat-noir/chat-noir-unit.ss
+++ b/collects/games/chat-noir/chat-noir-unit.ss
@@ -10,27 +10,36 @@
 
 (provide game@)
 (define orig-namespace (current-namespace))
-(define-runtime-path chat-noir "chat-noir-module.ss")
+(define-runtime-path chat-noir "chat-noir-literate.ss")
 
 (define-unit game@
   (import)
   (export)
   (define ns (make-base-namespace))
-  (parameterize ([current-namespace ns])
-    (namespace-attach-module orig-namespace '(lib "mred.ss" "mred"))
-    (namespace-attach-module orig-namespace '(lib "class.ss" "scheme"))
-    (dynamic-require chat-noir #f))
   
   ;; a hack.
   ;; this adds a help button to the world.ss window
-  (let ([fs (get-top-level-windows)])
-    (unless (null? fs)
-      (let ([f (car fs)]
-            [show-help
-             (show-scribbling
-              '(lib "games/scribblings/games.scrbl")
-              "chat-noir")])
-        (new button% 
-             [parent f]
-             [callback (λ (x y) (show-help))]
-             [label (string-constant help)])))))
+  (thread
+   (λ ()
+     (let loop ([n 0])
+       (when (n . < . 100)
+         (sleep 1/10)
+         (let ([fs (get-top-level-windows)])
+           (cond
+             [(null? fs)
+              (loop (+ n 1))]
+             [else
+              (let ([f (car fs)]
+                    [show-help
+                     (show-scribbling
+                      '(lib "games/scribblings/games.scrbl")
+                      "chat-noir")])
+                (new button% 
+                     [parent f]
+                     [callback (λ (x y) (show-help))]
+                     [label (string-constant help)]))]))))))
+  
+  (parameterize ([current-namespace ns])
+    (namespace-attach-module orig-namespace '(lib "mred.ss" "mred"))
+    (namespace-attach-module orig-namespace '(lib "class.ss" "scheme"))
+    (dynamic-require chat-noir #f)))
diff --git a/collects/games/chat-noir/chat-noir.ss b/collects/games/chat-noir/chat-noir.ss
deleted file mode 100644
index 4b0ddf7c71..0000000000
--- a/collects/games/chat-noir/chat-noir.ss
+++ /dev/null
@@ -1,1628 +0,0 @@
-;#lang scheme (require htdp/world lang/posn) (define-syntax (check-expect stx) #'(void))
-
-(require "hash.ss")
-
-;; constants
-(define circle-radius 20)
-(define circle-spacing 22)
-
-(define normal-color 'lightskyblue)
-(define on-shortest-path-color 'white)
-(define blocked-color 'black)
-(define under-mouse-color 'black)
-
-;; data definitions
-
-;; a world is:
-;;  (make-world board posn state number mouse posn-or-false boolean)
-(define-struct world (board cat state size mouse-posn h-down?))
-
-;; a state is either:
-;;   - 'playing
-;;   - 'cat-won
-;;   - 'cat-lost
-
-;; a board is
-;;  (listof cell)
-
-;; a cell is
-;; (make-cell (make-posn int[0-board-size]
-;;                       int[0-board-size])
-;;            boolean)
-(define-struct cell (p blocked?))
-
-
-;                                                     
-;                                                     
-;                                                     
-;                                                     
-;                                                     
-;                                           ;;;;;     
-;                                            ;;;;     
-;                                            ;;;      
-;   ;;;; ;;;    ; ;;;;   ;;;;   ;;  ; ;;;;   ;;;   ;  
-;   ;;;;;;; ;;;;;; ;;;; ;;;;;;;;; ;;;;;;;;;  ;;;  ;;; 
-;   ;   ;;;;  ;;; ;;;;;;;;;;;;;;;  ;;    ;;  ;;; ;;;; 
-;   ;;   ;;;  ;;; ;;;; ;;;    ;;;  ;     ;;  ;;;; ;;; 
-;    ;;;;;;;  ;;;      ;;    ;;;;  ;    ;;;  ;;;  ;;; 
-;        ;;;  ;;;      ;;;;;;;;;;  ;;;;;;;    ;;  ;;; 
-;   ;;;; ;;;;;;;;;;;   ;;;;;;;;;;; ;; ;;;     ;;  ;;; 
-;  ;;;;; ;;;            ;;;;;      ;;        ;;;; ;;; 
-;  ;;;; ;;;                        ;;               ;;
-;   ;;;;;;                        ;                   
-;                                                     
-
-;; a distance-map is 
-;;  (listof dist-cells)
-
-;; a dist-cell is
-;;  - (make-dist-cell posn (number or '∞))
-(define-struct dist-cell (p n))
-
-
-;; build-bfs-table : world (or/c 'boundary posn) -> distance-table
-(define (build-bfs-table world init-point)
-  (local [;; posn : posn
-          ;; dist : number
-          (define-struct queue-ent (posn dist))
-          
-          (define neighbors/w (neighbors world))
-          
-          (define (bfs queue dist-table)
-            (cond
-              [(empty? queue) dist-table]
-              [else
-               (local [(define hd (first queue))]
-                 (cond
-                   [(boolean? (hash-ref dist-table (queue-ent-posn hd) #f))
-                    (local [(define dist (queue-ent-dist hd))
-                            (define p (queue-ent-posn hd))]
-                      (bfs 
-                       (append (rest queue) 
-                               (map (lambda (p) (make-queue-ent p (+ dist 1)))
-                                    (neighbors/w p)))
-                       (hash-set dist-table p dist)))]
-                   [else
-                    (bfs (rest queue) dist-table)]))]))]
-                    
-    (hash-map 
-     (bfs (list (make-queue-ent init-point 0))
-          (make-immutable-hash/list-init))
-     make-dist-cell)))
-
-;; same-sets? : (listof X) (listof X) -> boolean
-(define (same-sets? l1 l2)
-  (and (andmap (lambda (e1) (member e1 l2)) l1)
-       (andmap (lambda (e2) (member e2 l1)) l2)))
-
-(check-expect (same-sets? (list) (list)) true)
-(check-expect (same-sets? (list) (list 1)) false)
-(check-expect (same-sets? (list 1) (list)) false)
-(check-expect (same-sets? (list 1 2) (list 2 1)) true)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(check-expect (same-sets? 
-               (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3 (make-posn 0 0) false)
-                                'boundary)
-               (list
-                (make-dist-cell 'boundary 0)
-                
-                (make-dist-cell (make-posn 1 0) 1)
-                (make-dist-cell (make-posn 2 0) 1)
-                
-                (make-dist-cell (make-posn 0 1) 1)
-                (make-dist-cell (make-posn 1 1) 2)
-                (make-dist-cell (make-posn 2 1) 1)
-                
-                (make-dist-cell (make-posn 1 2) 1)
-                (make-dist-cell (make-posn 2 2) 1)))
-              true)
-
-(check-expect (same-sets? 
-               (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3 (make-posn 0 0) false)
-                                (make-posn 1 1))
-               (list
-                (make-dist-cell 'boundary 2)
-
-                (make-dist-cell (make-posn 1 0) 1)
-                (make-dist-cell (make-posn 2 0) 1)
-                
-                (make-dist-cell (make-posn 0 1) 1)
-                (make-dist-cell (make-posn 1 1) 0)
-                (make-dist-cell (make-posn 2 1) 1)
-                
-                (make-dist-cell (make-posn 1 2) 1)
-                (make-dist-cell (make-posn 2 2) 1)))
-              true)
-
-(check-expect (same-sets? 
-               (build-bfs-table (make-world (list
-                                             (make-cell (make-posn 0 1) true)
-                                             (make-cell (make-posn 1 0) true)
-                                             (make-cell (make-posn 1 1) false)
-                                             (make-cell (make-posn 1 2) true)
-                                             (make-cell (make-posn 2 0) true)
-                                             (make-cell (make-posn 2 1) true)
-                                             (make-cell (make-posn 2 2) true))
-                                            (make-posn 1 1)
-                                            'playing
-                                            3
-                                            (make-posn 0 0)
-                                            false)
-                                'boundary)
-               (list
-                (make-dist-cell 'boundary 0)))
-              true)
-
-(check-expect (same-sets? 
-               (build-bfs-table (make-world (empty-board 5)
-                                            (make-posn 2 2)
-                                            'playing
-                                            5
-                                            (make-posn 0 0)
-                                            false)
-                                'boundary)
-               (list
-                (make-dist-cell 'boundary 0)
-
-                (make-dist-cell (make-posn 1 0) 1)
-                (make-dist-cell (make-posn 2 0) 1)
-                (make-dist-cell (make-posn 3 0) 1)
-                (make-dist-cell (make-posn 4 0) 1)
-                
-                (make-dist-cell (make-posn 0 1) 1)
-                (make-dist-cell (make-posn 1 1) 2)
-                (make-dist-cell (make-posn 2 1) 2)
-                (make-dist-cell (make-posn 3 1) 2)
-                (make-dist-cell (make-posn 4 1) 1)
-                
-                (make-dist-cell (make-posn 0 2) 1)
-                (make-dist-cell (make-posn 1 2) 2)
-                (make-dist-cell (make-posn 2 2) 3)
-                (make-dist-cell (make-posn 3 2) 2)
-                (make-dist-cell (make-posn 4 2) 1)
-
-                (make-dist-cell (make-posn 0 3) 1)
-                (make-dist-cell (make-posn 1 3) 2)
-                (make-dist-cell (make-posn 2 3) 2)
-                (make-dist-cell (make-posn 3 3) 2)
-                (make-dist-cell (make-posn 4 3) 1)
-
-                
-                (make-dist-cell (make-posn 1 4) 1)
-                (make-dist-cell (make-posn 2 4) 1)
-                (make-dist-cell (make-posn 3 4) 1)
-                (make-dist-cell (make-posn 4 4) 1)))
-              true)
-
-(check-expect (same-sets? 
-               (build-bfs-table (make-world (block-cell
-                                             (make-posn 4 2)
-                                             (empty-board 5))
-                                            (make-posn 2 2)
-                                            'playing
-                                            5
-                                            (make-posn 0 0)
-                                            false)
-                                'boundary)
-               (list
-                (make-dist-cell 'boundary 0)
-
-                (make-dist-cell (make-posn 1 0) 1)
-                (make-dist-cell (make-posn 2 0) 1)
-                (make-dist-cell (make-posn 3 0) 1)
-                (make-dist-cell (make-posn 4 0) 1)
-                
-                (make-dist-cell (make-posn 0 1) 1)
-                (make-dist-cell (make-posn 1 1) 2)
-                (make-dist-cell (make-posn 2 1) 2)
-                (make-dist-cell (make-posn 3 1) 2)
-                (make-dist-cell (make-posn 4 1) 1)
-                
-                (make-dist-cell (make-posn 0 2) 1)
-                (make-dist-cell (make-posn 1 2) 2)
-                (make-dist-cell (make-posn 2 2) 3)
-                (make-dist-cell (make-posn 3 2) 3)
-
-                (make-dist-cell (make-posn 0 3) 1)
-                (make-dist-cell (make-posn 1 3) 2)
-                (make-dist-cell (make-posn 2 3) 2)
-                (make-dist-cell (make-posn 3 3) 2)
-                (make-dist-cell (make-posn 4 3) 1)
-
-                
-                (make-dist-cell (make-posn 1 4) 1)
-                (make-dist-cell (make-posn 2 4) 1)
-                (make-dist-cell (make-posn 3 4) 1)
-                (make-dist-cell (make-posn 4 4) 1)))
-              true)
-
-(check-expect (same-sets? 
-               (build-bfs-table (make-world (empty-board 5)
-                                            (make-posn 2 2)
-                                            'playing
-                                            5
-                                            (make-posn 0 0)
-                                            false)
-                                (make-posn 2 2))
-               (list
-                (make-dist-cell 'boundary 3)
-                
-                (make-dist-cell (make-posn 1 0) 2)
-                (make-dist-cell (make-posn 2 0) 2)
-                (make-dist-cell (make-posn 3 0) 2)
-                (make-dist-cell (make-posn 4 0) 3)
-                
-                (make-dist-cell (make-posn 0 1) 2)
-                (make-dist-cell (make-posn 1 1) 1)
-                (make-dist-cell (make-posn 2 1) 1)
-                (make-dist-cell (make-posn 3 1) 2)
-                (make-dist-cell (make-posn 4 1) 3)
-                
-                (make-dist-cell (make-posn 0 2) 2)
-                (make-dist-cell (make-posn 1 2) 1)
-                (make-dist-cell (make-posn 2 2) 0)
-                (make-dist-cell (make-posn 3 2) 1)
-                (make-dist-cell (make-posn 4 2) 2)
-
-                (make-dist-cell (make-posn 0 3) 2)
-                (make-dist-cell (make-posn 1 3) 1)
-                (make-dist-cell (make-posn 2 3) 1)
-                (make-dist-cell (make-posn 3 3) 2)
-                (make-dist-cell (make-posn 4 3) 3)
-
-                
-                (make-dist-cell (make-posn 1 4) 2)
-                (make-dist-cell (make-posn 2 4) 2)
-                (make-dist-cell (make-posn 3 4) 2)
-                (make-dist-cell (make-posn 4 4) 3)))
-              true)
-
-(check-expect (lookup-in-table
-               (build-bfs-table (make-world (empty-board 5)
-                                            (make-posn 2 2)
-                                            'playing
-                                            5
-                                            (make-posn 0 0)
-                                            false)
-                                (make-posn 2 2))
-               (make-posn 1 4))
-              2)
-
-
-;; lookup-in-table : distance-map posn -> number or '∞
-;; looks for the distance as recorded in the table t, 
-;; if not found returns a distance of '∞
-(define (lookup-in-table t p)
-  (cond
-    [(empty? t) '∞]
-    [else (cond
-            [(equal? p (dist-cell-p (first t)))
-             (dist-cell-n (first t))]
-            [else
-             (lookup-in-table (rest t) p)])]))
-
-(check-expect (lookup-in-table empty (make-posn 1 2)) '∞)
-(check-expect (lookup-in-table (list (make-dist-cell (make-posn 1 2) 3))
-                               (make-posn 1 2))
-              3)
-(check-expect (lookup-in-table (list (make-dist-cell (make-posn 2 1) 3))
-                               (make-posn 1 2))
-              '∞)
-
-
-;; p : world -> posn -> boolean
-;; returns true when the posn is on the shortest path 
-;; from the cat to the edge of the board, in the given world
-(define (on-cats-path? w)
-  (cond
-    [(world-h-down? w)
-     (local [(define edge-distance-map (build-bfs-table w 'boundary))
-             (define cat-distance-map (build-bfs-table w (world-cat w)))
-             (define cat-distance (lookup-in-table edge-distance-map 
-                                                   (world-cat w)))]
-       (cond
-         [(equal? cat-distance '∞)
-          (lambda (p) false)]
-         [else
-          (lambda (p)
-            (equal? (+/f (lookup-in-table cat-distance-map p)
-                         (lookup-in-table edge-distance-map p))
-                    cat-distance))]))]
-    [else
-     (lambda (p) false)]))
-
-(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) true))
-               (make-posn 1 0))
-              true)
-(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) false))
-               (make-posn 1 0))
-              false)
-(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) true))
-               (make-posn 2 1))
-              false)
-(check-expect ((on-cats-path?
-                (make-world (list
-                             (make-cell (make-posn 0 1) true)
-                             (make-cell (make-posn 1 0) true)
-                             (make-cell (make-posn 1 1) false)
-                             (make-cell (make-posn 1 2) true)
-                             (make-cell (make-posn 2 0) true)
-                             (make-cell (make-posn 2 1) true)
-                             (make-cell (make-posn 2 2) true))
-                            (make-posn 1 1)
-                            'cat-lost
-                            3
-                            (make-posn 0 0)
-                            true))
-               (make-posn 0 1))
-              false)
-
-;; neighbors : world -> (or/c 'boundary posn) -> (listof (or/c 'boundary posn))
-;; computes the neighbors of a posn, for a given board size
-(define (neighbors w)
-  (local [(define blocked 
-            (map cell-p
-                 (filter (lambda (c) 
-                           (or (cell-blocked? c)
-                               (equal? (cell-p c) (world-mouse-posn w))))
-                         (world-board w))))
-          (define boundary-cells (filter (lambda (p) 
-                                           (and (not (member p blocked))
-                                                (on-boundary? p (world-size w))))
-                                         (map cell-p (world-board w))))]
-    (lambda (p)
-      (cond 
-        [(member p blocked)
-         '()]
-        [(equal? p 'boundary)
-         boundary-cells]
-        [else
-         (local [(define x (posn-x p))
-                 (define y (posn-y p))
-                 (define adjacent-posns (adjacent p (world-size w)))
-                 (define in-bounds
-                   (filter (lambda (x) (in-bounds? x (world-size w)))
-                           adjacent-posns))]
-           (filter
-            (lambda (x) (not (member x blocked)))
-            (cond
-              [(equal? in-bounds adjacent-posns)
-               in-bounds]
-              [else
-               (cons 'boundary in-bounds)])))]))))
-
-(check-expect ((neighbors (empty-world 11))  (make-posn 1 1))
-              (adjacent (make-posn 1 1) 11))
-(check-expect ((neighbors (empty-world 11)) (make-posn 2 2))
-              (adjacent (make-posn 2 2) 11))
-(check-expect ((neighbors (empty-world 3)) 'boundary)
-              (list (make-posn 0 1) 
-                    (make-posn 1 0) 
-                    (make-posn 1 2) 
-                    (make-posn 2 0) 
-                    (make-posn 2 1) 
-                    (make-posn 2 2)))
-(check-expect ((neighbors (empty-world 11)) (make-posn 1 0))
-              (list 'boundary 
-                    (make-posn 2 0)
-                    (make-posn 0 1)
-                    (make-posn 1 1)))
-(check-expect ((neighbors (make-world (list
-                                       (make-cell (make-posn 0 1) false)
-                                       (make-cell (make-posn 1 0) false)
-                                       (make-cell (make-posn 1 1) true)
-                                       (make-cell (make-posn 1 2) false)
-                                       (make-cell (make-posn 2 0) false)
-                                       (make-cell (make-posn 2 1) false)
-                                       (make-cell (make-posn 2 2) false))
-                                      (make-posn 1 1)
-                                      'playing
-                                      3
-                                      (make-posn 0 0)
-                                      false))
-               (make-posn 1 1))
-              '())
-(check-expect ((neighbors (make-world (list
-                                       (make-cell (make-posn 0 1) false)
-                                       (make-cell (make-posn 1 0) false)
-                                       (make-cell (make-posn 1 1) true)
-                                       (make-cell (make-posn 1 2) false)
-                                       (make-cell (make-posn 2 0) false)
-                                       (make-cell (make-posn 2 1) false)
-                                       (make-cell (make-posn 2 2) false))
-                                      (make-posn 1 1)
-                                      'playing
-                                      3
-                                      (make-posn 0 0)
-                                      false))
-               (make-posn 1 0))
-              (list 'boundary (make-posn 2 0) (make-posn 0 1)))
-
-
-;; adjacent : posn number -> (listof posn)
-;; returns a list of the posns that are adjacent to 
-;; `p' on an infinite hex grid
-(define (adjacent p board-size)
-  (local [(define x (posn-x p))
-          (define y (posn-y p))]
-    (cond
-      [(even? y)
-       (list (make-posn (- x 1) (- y 1))
-             (make-posn x (- y 1))
-             (make-posn (- x 1) y)
-             (make-posn (+ x 1) y)
-             (make-posn (- x 1) (+ y 1))
-             (make-posn x (+ y 1)))]
-      [else
-       (list (make-posn x (- y 1))
-             (make-posn (+ x 1) (- y 1))
-             (make-posn (- x 1) y)
-             (make-posn (+ x 1) y)
-             (make-posn x (+ y 1))
-             (make-posn (+ x 1) (+ y 1)))])))
-
-(check-expect (adjacent (make-posn 1 1) 11)
-              (list (make-posn 1 0)
-                    (make-posn 2 0)
-                    (make-posn 0 1)
-                    (make-posn 2 1)
-                    (make-posn 1 2)
-                    (make-posn 2 2)))
-(check-expect (adjacent (make-posn 2 2) 11)
-              (list (make-posn 1 1)
-                    (make-posn 2 1)
-                    (make-posn 1 2)
-                    (make-posn 3 2)
-                    (make-posn 1 3)
-                    (make-posn 2 3)))
-
-
-
-;; on-boundary? : posn number -> boolean
-(define (on-boundary? p board-size)
-  (or (= (posn-x p) 0)
-      (= (posn-y p) 0)
-      (= (posn-x p) (- board-size 1))
-      (= (posn-y p) (- board-size 1))))
-
-(check-expect (on-boundary? (make-posn 0 1) 13) true)
-(check-expect (on-boundary? (make-posn 1 0) 13) true)
-(check-expect (on-boundary? (make-posn 12 1) 13) true)
-(check-expect (on-boundary? (make-posn 1 12) 13) true)
-(check-expect (on-boundary? (make-posn 1 1) 13) false)
-(check-expect (on-boundary? (make-posn 10 10) 13) false)
-
-
-;; in-bounds? : posn number -> boolean
-(define (in-bounds? p board-size)
-  (and (<= 0 (posn-x p) (- board-size 1))
-       (<= 0 (posn-y p) (- board-size 1))
-       (not (equal? p (make-posn 0 0)))
-       (not (equal? p (make-posn 0 (- board-size 1))))))
-(check-expect (in-bounds? (make-posn 0 0) 11) false)
-(check-expect (in-bounds? (make-posn 0 1) 11) true)
-(check-expect (in-bounds? (make-posn 1 0) 11) true)
-(check-expect (in-bounds? (make-posn 10 10) 11) true)
-(check-expect (in-bounds? (make-posn 0 -1) 11) false)
-(check-expect (in-bounds? (make-posn -1 0) 11) false)
-(check-expect (in-bounds? (make-posn 0 11) 11) false)
-(check-expect (in-bounds? (make-posn 11 0) 11) false)
-(check-expect (in-bounds? (make-posn 10 0) 11) true)
-(check-expect (in-bounds? (make-posn 0 10) 11) false)
-
-;; <=/f : (number or '∞) (number or '∞) -> boolean
-(define (<=/f a b)
-  (cond
-    [(equal? b '∞) true]
-    [(equal? a '∞) false]
-    [else (<= a b)]))
-(check-expect (<=/f 1 2) true)
-(check-expect (<=/f 2 1) false)
-(check-expect (<=/f '∞ 1) false)
-(check-expect (<=/f 1 '∞) true)
-(check-expect (<=/f '∞ '∞) true)
-
-(define (+/f x y)
-  (cond
-    [(or (equal? x '∞) (equal? y '∞))
-     '∞]
-    [else 
-     (+ x y)]))
-
-(check-expect (+/f '∞ '∞) '∞)
-(check-expect (+/f '∞ 1) '∞)
-(check-expect (+/f 1 '∞) '∞)
-(check-expect (+/f 1 2) 3)
-
-
-;                                                                          
-;                                                                          
-;                                                                          
-;                                                                          
-;                                                                          
-;          ;;                                     ;;;;                     
-;       ;;;;                                      ;;;;;                    
-;        ;;;                              ;                                
-;    ;;; ;;;    ; ;;;;   ;;;;   ;;;;;;  ;;  ;;;;     ;;;;;;  ;;   ;;;; ;;; 
-;   ;;;;;;;;;;;;;; ;;;; ;;;;;;;;;  ;;   ;;   ;   ;;;;;  ;;; ;;;;  ;;;;;;;  
-;  ;;;;;;;;;  ;;; ;;;;;;;;;;;;;;; ;;;   ;;   ;;    ;;;  ;;; ;;;;  ;   ;;;; 
-;  ;;;   ;;;  ;;; ;;;; ;;;    ;;; ;;;   ;;;  ;;;   ;;;  ;;;; ;;;  ;;   ;;; 
-;  ;;   ;;;;  ;;;      ;;    ;;;; ;;;   ;;;; ;;;   ;;;  ;;;  ;;;   ;;;;;;; 
-;  ;;;;;;;;   ;;;      ;;;;;;;;;; ;;;   ;; ;;;;;  ;;;;  ;;;  ;;;       ;;; 
-;   ;;;;;;;;;;;;;;;;   ;;;;;;;;;;; ;;; ;;;  ;;;  ;;;;;;;;;;  ;;;  ;;;; ;;; 
-;                       ;;;;;        ;;;;                   ;;;; ;;;;; ;;; 
-;                                                             ;;;;;;; ;;;  
-;                                                                 ;;;;;;   
-;                                                                          
-
-
-;; render-world : world -> image
-(define (render-world w)
-  (chop-whiskers
-   (overlay (board->image (world-board w) 
-                          (world-size w)
-                          (on-cats-path? w)
-                          (world-mouse-posn w))
-            (move-pinhole
-             (cond
-               [(equal? (world-state w) 'cat-won) happy-cat]
-               [(equal? (world-state w) 'cat-lost) sad-cat]
-               [else thinking-cat])
-             (- (cell-center-x (world-cat w)))
-             (- (cell-center-y (world-cat w)))))))
-
-(check-expect
- (render-world
-  (make-world (list (make-cell (make-posn 0 1) false))
-              (make-posn 0 1)
-              'playing
-              2
-              (make-posn 0 0)
-              false))
- (overlay
-  (board->image (list (make-cell (make-posn 0 1) false))
-                2
-                (lambda (x) true)
-                false)
-  (move-pinhole thinking-cat 
-                (- (cell-center-x (make-posn 0 1)))
-                (- (cell-center-y (make-posn 0 1))))))
-
-(check-expect
- (render-world
-  (make-world (list (make-cell (make-posn 0 1) false))
-              (make-posn 0 1)
-              'cat-won
-              2
-              false
-              false))
- (overlay
-  (board->image (list (make-cell (make-posn 0 1) false))
-                2
-                (lambda (x) true)
-                false)
-  (move-pinhole happy-cat 
-                (- (cell-center-x (make-posn 0 1)))
-                (- (cell-center-y (make-posn 0 1))))))
-
-(check-expect
- (render-world
-  (make-world (list (make-cell (make-posn 0 1) false))
-              (make-posn 0 1)
-              'cat-lost
-              2
-              false
-              false))
- (overlay
-  (board->image (list (make-cell (make-posn 0 1) false))
-                2
-                (lambda (x) true)
-                false)
-  (move-pinhole sad-cat 
-                (- (cell-center-x (make-posn 0 1)))
-                (- (cell-center-y (make-posn 0 1))))))
-
-(check-expect
- (render-world
-  (make-world (list
-               (make-cell (make-posn 0 1) true)
-               (make-cell (make-posn 1 0) true)
-               (make-cell (make-posn 1 1) false)
-               (make-cell (make-posn 1 2) true)
-               (make-cell (make-posn 2 0) true)
-               (make-cell (make-posn 2 1) true)
-               (make-cell (make-posn 2 2) true))
-              (make-posn 1 1)
-              'cat-lost
-              3
-              false
-              false))
- (overlay
-  (board->image (list
-                 (make-cell (make-posn 0 1) true)
-                 (make-cell (make-posn 1 0) true)
-                 (make-cell (make-posn 1 1) false)
-                 (make-cell (make-posn 1 2) true)
-                 (make-cell (make-posn 2 0) true)
-                 (make-cell (make-posn 2 1) true)
-                 (make-cell (make-posn 2 2) true))
-                3
-                (lambda (x) false)
-                false)
-  (move-pinhole sad-cat 
-                (- (cell-center-x (make-posn 1 1)))
-                (- (cell-center-y (make-posn 1 1))))))
-
-(check-expect
- (render-world
-  (make-world (list
-               (make-cell (make-posn 0 1) false)
-               (make-cell (make-posn 1 0) false)
-               (make-cell (make-posn 1 1) false)
-               (make-cell (make-posn 1 2) false)
-               (make-cell (make-posn 2 0) false)
-               (make-cell (make-posn 2 1) false)
-               (make-cell (make-posn 2 2) false))
-              (make-posn 1 1)
-              'cat-lost
-              3
-              (make-posn (cell-center-x (make-posn 0 1))
-                         (cell-center-y (make-posn 0 1)))
-              true))
- 
- (overlay
-  (board->image (list
-                 (make-cell (make-posn 0 1) false)
-                 (make-cell (make-posn 1 0) false)
-                 (make-cell (make-posn 1 1) false)
-                 (make-cell (make-posn 1 2) false)
-                 (make-cell (make-posn 2 0) false)
-                 (make-cell (make-posn 2 1) false)
-                 (make-cell (make-posn 2 2) false))
-                3
-                (lambda (x) true)
-                (make-posn (cell-center-x (make-posn 0 1))
-                           (cell-center-y (make-posn 0 1))))
-  (move-pinhole sad-cat 
-                (- (cell-center-x (make-posn 1 1)))
-                (- (cell-center-y (make-posn 1 1))))))
-
-;; chop-whiskers : image -> image
-;; crops the image so that anything above or to the left of the pinhole is gone
-(define (chop-whiskers img)
-  (shrink img 
-          0 
-          0
-          (- (image-width img) (pinhole-x img) 1) 
-          (- (image-height img) (pinhole-y img) 1)))
-
-(check-expect (chop-whiskers (rectangle 5 5 'solid 'black))
-              (put-pinhole (rectangle 3 3 'solid 'black) 0 0))
-(check-expect (chop-whiskers (rectangle 6 6 'solid 'black))
-              (put-pinhole (rectangle 3 3 'solid 'black) 0 0))
-
-(check-expect
- (pinhole-x
-  (render-world 
-   (make-world
-    (empty-board 3)
-    (make-posn 0 0)
-    'playing
-    3
-    (make-posn 0 0)
-    false)))
- 0)
-(check-expect
- (pinhole-x
-  (render-world
-   (make-world
-    (empty-board 3)
-    (make-posn 0 1)
-    'playing
-    3
-    (make-posn 0 0)
-    false)))
- 0)
-
-
-;; board->image : board number (posn -> boolean) posn-or-false -> image
-(define (board->image cs world-size on-cat-path? mouse)
-  (foldl (lambda (x y) (overlay y x))
-         (nw:rectangle (world-width world-size)
-                       (world-height world-size)
-                       'solid
-                       'white)
-         (map (lambda (c) (cell->image c 
-                                       (on-cat-path? (cell-p c)) 
-                                       (and (posn? mouse)
-                                            (equal? mouse (cell-p c)))
-                                       #;
-                                       (and (posn? mouse)
-                                            (point-in-this-circle? (cell-p c) 
-                                                                   (posn-x mouse)
-                                                                   (posn-y mouse)))))
-              cs)))
-
-(check-expect (board->image (list (make-cell (make-posn 0 0) false))
-                            3
-                            (lambda (x) false)
-                            false)
-              (overlay
-               (nw:rectangle (world-width 3)
-                             (world-height 3)
-                             'solid
-                             'white)
-               (cell->image (make-cell (make-posn 0 0) false)
-                            false
-                            false)))
-
-(check-expect (board->image (list (make-cell (make-posn 0 0) false))
-                            3
-                            (lambda (x) true)
-                            false)
-              (overlay
-               (nw:rectangle (world-width 3)
-                             (world-height 3)
-                             'solid
-                             'white)
-               (cell->image (make-cell (make-posn 0 0) false)
-                            true
-                            false)))
-
-
-(check-expect (board->image (list (make-cell (make-posn 0 0) false))
-                            3
-                            (lambda (x) false)
-                            false)
-              (overlay
-               (nw:rectangle (world-width 3)
-                             (world-height 3)
-                             'solid
-                             'white)
-               (cell->image (make-cell (make-posn 0 0) false)
-                            false
-                            false)))
-
-(check-expect (board->image (list (make-cell (make-posn 0 0) false)
-                                  (make-cell (make-posn 0 1) false))
-                            3
-                            (lambda (x) (equal? x (make-posn 0 1)))
-                            false)
-              (overlay
-               (nw:rectangle (world-width 3)
-                             (world-height 3)
-                             'solid
-                             'white)
-               (cell->image (make-cell (make-posn 0 0) false)
-                            false
-                            false)
-               (cell->image (make-cell (make-posn 0 1) false)
-                            true
-                            false)))
-
-(check-expect (board->image (list (make-cell (make-posn 0 0) false)
-                                  (make-cell (make-posn 0 1) false))
-                            3
-                            (lambda (x) (equal? x (make-posn 0 1)))
-                            (make-posn 0 0))
-              (overlay
-               (nw:rectangle (world-width 3)
-                             (world-height 3)
-                             'solid
-                             'white)
-               (cell->image (make-cell (make-posn 0 0) false)
-                            false
-                            true)
-               (cell->image (make-cell (make-posn 0 1) false)
-                            true
-                            false)))
-
-;; cell->image : cell boolean boolean -> image
-(define (cell->image c on-short-path? under-mouse?)
-  (local [(define x (cell-center-x (cell-p c)))
-          (define y (cell-center-y (cell-p c)))
-          (define main-circle 
-            (cond
-              [(cell-blocked? c)
-               (circle circle-radius 'solid blocked-color)]
-              [else
-               (circle circle-radius 'solid normal-color)]))]
-    (move-pinhole 
-     (cond
-       [under-mouse?
-        (overlay main-circle
-                 (circle (quotient circle-radius 2) 'solid under-mouse-color))]
-       [on-short-path?
-        (overlay main-circle
-                 (circle (quotient circle-radius 2) 'solid on-shortest-path-color))]
-       [else
-        main-circle])
-     (- x)
-     (- y))))
-
-(check-expect (cell->image (make-cell (make-posn 0 0) false) false false)
-              (move-pinhole (circle circle-radius 'solid normal-color)
-                            (- circle-radius)
-                            (- circle-radius)))
-(check-expect (cell->image (make-cell (make-posn 0 0) true) false false)
-              (move-pinhole (circle circle-radius 'solid 'black)
-                            (- circle-radius)
-                            (- circle-radius)))
-(check-expect (cell->image (make-cell (make-posn 0 0) false) true false)
-              (move-pinhole (overlay (circle circle-radius 'solid normal-color)
-                                     (circle (quotient circle-radius 2) 'solid on-shortest-path-color))
-                            (- circle-radius)
-                            (- circle-radius)))
-(check-expect (cell->image (make-cell (make-posn 0 0) false) true true)
-              (move-pinhole (overlay (circle circle-radius 'solid normal-color)
-                                     (circle (quotient circle-radius 2) 'solid under-mouse-color))
-                            (- circle-radius)
-                            (- circle-radius)))
-
-;; world-width : number -> number
-;; computes the width of the drawn world in terms of its size
-(define (world-width board-size)
-  (local [(define rightmost-posn 
-            (make-posn (- board-size 1) (- board-size 2)))]
-    (+ (cell-center-x rightmost-posn) circle-radius)))
-
-(check-expect (world-width 3) 150)
-
-;; world-height : number -> number
-;; computes the height of the drawn world in terms of its size
-(define (world-height board-size)
-  (local [(define bottommost-posn
-            (make-posn (- board-size 1) (- board-size 1)))]
-    (+ (cell-center-y bottommost-posn) circle-radius)))
-(check-expect (world-height 3) 116.208)
-
-
-;; cell-center-x : posn -> number
-(define (cell-center-x p)
-  (local [(define x (posn-x p))
-          (define y (posn-y p))]
-    (+ circle-radius
-       (* x circle-spacing 2)
-       (if (odd? y)
-           circle-spacing
-           0))))
-
-(check-expect (cell-center-x (make-posn 0 0))
-              circle-radius)
-(check-expect (cell-center-x (make-posn 0 1))
-              (+ circle-spacing circle-radius))
-(check-expect (cell-center-x (make-posn 1 0))
-              (+ (* 2 circle-spacing) circle-radius))
-(check-expect (cell-center-x (make-posn 1 1))
-              (+ (* 3 circle-spacing) circle-radius))
-
-;; cell-center-y : posn -> number
-(define (cell-center-y p)
-  (local [(define y (posn-y p))]
-    (+ circle-radius
-       (* y circle-spacing 2 
-          .866 ;; .866 is an exact approximate to sin(pi/3)
-          ))))
-
-(check-expect (cell-center-y (make-posn 1 1))
-              (+ circle-radius (* 2 circle-spacing .866)))
-(check-expect (cell-center-y (make-posn 1 0))
-              circle-radius)
-
-
-;                                          
-;                                          
-;                                          
-;                                          
-;                                          
-;          ;;;;;  ;;;;         ;;;;;;      
-;            ;;;  ;;;;;          ;;;;      
-;            ;;;                 ;;;       
-;    ;;;;;;  ;;;     ;   ;;;;;;  ;;;  ;;;; 
-;   ;;; ;;;; ;;; ;;;;;  ;;; ;;;; ;;; ;;;;;;
-;  ;;; ;;;;; ;;;   ;;; ;;; ;;;;; ;;; ;;;;; 
-;  ;;;  ;;;; ;;;   ;;; ;;;  ;;;; ;;;;      
-;  ;;;       ;;    ;;; ;;;        ;;;;;;   
-;  ;;;    ; ;;;   ;;;; ;;;    ;   ;;    ;; 
-;   ;;;  ;  ;;;; ;;;;;;;;;;  ;  ;;;;;  ;;;;
-;    ;;;;                ;;;;              
-;                                          
-;                                          
-;                                          
-
-
-(define (clack world x y evt)
-  (cond
-    [(equal? evt 'button-up)
-     (cond
-       [(and (equal? 'playing (world-state world))
-             (point-in-a-circle? (world-board world) x y))
-        (move-cat 
-         (update-world-posn 
-          (make-world (add-obstacle (world-board world) x y)
-                      (world-cat world)
-                      (world-state world)
-                      (world-size world)
-                      (world-mouse-posn world)
-                      (world-h-down? world))
-          (make-posn x y)))]
-       [else (update-world-posn world (make-posn x y))])]
-    [(equal? evt 'button-down)
-     world]
-    [(equal? evt 'drag) world]
-    [(equal? evt 'move)
-     (update-world-posn world (make-posn x y))]
-    [(equal? evt 'enter)
-     (update-world-posn world (make-posn x y))]
-    [(equal? evt 'leave)
-     (update-world-posn world false)]))
-
-(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 false false)
-                     1 1 'button-down)
-              (make-world '() (make-posn 0 0) 'playing 1 false false))
-(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 false false)
-                     1 1 'drag)
-              (make-world '() (make-posn 0 0) 'playing 1 false false))
-(check-expect (clack (make-world (list (make-cell (make-posn 0 0) false))
-                                 (make-posn 0 1)
-                                 'playing
-                                 1
-                                 false
-                                 false)
-                     (cell-center-x (make-posn 0 0))
-                     (cell-center-y (make-posn 0 0))
-                     'move)
-              (make-world (list (make-cell (make-posn 0 0) false))
-                          (make-posn 0 1)
-                          'playing
-                          1
-                          (make-posn 0 0)
-                          false))
-(check-expect (clack (make-world (list (make-cell (make-posn 0 0) false))
-                                 (make-posn 0 1)
-                                 'playing
-                                 1
-                                 false
-                                 false)
-                     (cell-center-x (make-posn 0 0))
-                     (cell-center-y (make-posn 0 0))
-                     'enter)
-              (make-world (list (make-cell (make-posn 0 0) false))
-                          (make-posn 0 1)
-                          'playing
-                          1
-                          (make-posn 0 0)
-                          false))
-(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false)
-                     1 1 'leave)
-              (make-world '() (make-posn 0 0) 'playing 1 false false))
-
-(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false)
-                     10
-                     10
-                     'button-down)
-              (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false))
-
-(check-expect (clack (make-world (list (make-cell (make-posn 0 0) false)
-                                       (make-cell (make-posn 1 1) false))
-                                 (make-posn 1 1)
-                                 'playing
-                                 3
-                                 (make-posn 0 0)
-                                 false)
-                     (cell-center-x (make-posn 0 0)) 
-                     (cell-center-y (make-posn 0 0))
-                     'button-up)
-              (make-world (list (make-cell (make-posn 0 0) true)
-                                (make-cell (make-posn 1 1) false))
-                          (make-posn 1 1)
-                          'cat-lost
-                          3
-                          (make-posn 0 0)
-                          false))
-
-
-(check-expect (clack (make-world '() (make-posn 0 0) 'cat-lost 1 (make-posn 0 0) false)
-                     10
-                     10
-                     'button-up)
-              (make-world '() (make-posn 0 0) 'cat-lost 1 (make-posn 0 0) false))
-(check-expect (clack 
-               (make-world
-                (list (make-cell (make-posn 1 0) false)
-                      (make-cell (make-posn 2 0) true)
-                      (make-cell (make-posn 0 1) true)
-                      (make-cell (make-posn 1 1) false)
-                      (make-cell (make-posn 2 1) true)
-                      (make-cell (make-posn 1 2) true)
-                      (make-cell (make-posn 2 2) true))
-                (make-posn 1 1)
-                'playing
-                3
-                false
-                false)
-               (cell-center-x (make-posn 1 0))
-               (cell-center-y (make-posn 1 0))
-               'button-up)
-              (make-world 
-               (list (make-cell (make-posn 1 0) true)
-                     (make-cell (make-posn 2 0) true)
-                     (make-cell (make-posn 0 1) true)
-                     (make-cell (make-posn 1 1) false)
-                     (make-cell (make-posn 2 1) true)
-                     (make-cell (make-posn 1 2) true)
-                     (make-cell (make-posn 2 2) true))
-               (make-posn 1 1)
-               'cat-lost
-               3
-               (make-posn 1 0)
-               false))
-
-(check-expect (clack 
-               (make-world
-                (list (make-cell (make-posn 1 0) false)
-                      (make-cell (make-posn 2 0) false)
-                      (make-cell (make-posn 0 1) true)
-                      (make-cell (make-posn 1 1) false)
-                      (make-cell (make-posn 2 1) true)
-                      (make-cell (make-posn 1 2) true)
-                      (make-cell (make-posn 2 2) true))
-                (make-posn 1 1)
-                'playing
-                3
-                false
-                false)
-               (cell-center-x (make-posn 1 0))
-               (cell-center-y (make-posn 1 0))
-               'button-up)
-              (make-world 
-               (list (make-cell (make-posn 1 0) true)
-                     (make-cell (make-posn 2 0) false)
-                     (make-cell (make-posn 0 1) true)
-                     (make-cell (make-posn 1 1) false)
-                     (make-cell (make-posn 2 1) true)
-                     (make-cell (make-posn 1 2) true)
-                     (make-cell (make-posn 2 2) true))
-               (make-posn 2 0)
-               'cat-won
-               3
-               (make-posn 1 0)
-               false))
-
-;; update-world-posn/playing : world posn-or-false -> world
-(define (update-world-posn w p)
-  (cond
-    [(equal? (world-state w) 'playing)
-     (cond
-       [(posn? p)
-        (local [(define mouse-spot 
-                  (circle-at-point (world-board w) 
-                                   (posn-x p)
-                                   (posn-y p)))]
-          (make-world (world-board w)
-                      (world-cat w)
-                      (world-state w)
-                      (world-size w)
-                      (cond
-                        [(equal? mouse-spot (world-cat w))
-                         false]
-                        [else
-                         mouse-spot])
-                      (world-h-down? w)))]
-       [else
-        (make-world (world-board w)
-                    (world-cat w)
-                    (world-state w)
-                    (world-size w)
-                    false
-                    (world-h-down? w))])]
-    [else w]))
-
-(check-expect (update-world-posn 
-               (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 false false)
-               (make-posn (cell-center-x (make-posn 0 0))
-                          (cell-center-y (make-posn 0 0))))
-               (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 (make-posn 0 0) false))
-
-(check-expect (update-world-posn 
-               (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 0) 'playing 1 false false)
-               (make-posn (cell-center-x (make-posn 0 0))
-                          (cell-center-y (make-posn 0 0))))
-               (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 0) 'playing 1 false false))
-
-(check-expect (update-world-posn 
-               (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 (make-posn 0 0) false)
-               (make-posn 0 0))
-               (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 false false))
-(check-expect (update-world-posn 
-               (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-won 1 false false)
-               (make-posn (cell-center-x (make-posn 0 0))
-                          (cell-center-y (make-posn 0 0))))
-               (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-won 1 false false))
-(check-expect (update-world-posn 
-               (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-lost 1 false false)
-               (make-posn (cell-center-x (make-posn 0 0))
-                          (cell-center-y (make-posn 0 0))))
-               (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-lost 1 false false))
-
-;; move-cat : world -> world
-(define (move-cat world)
-  (local [(define cat-position (world-cat world))
-          (define table (build-bfs-table world 'boundary))
-          (define neighbors (adjacent cat-position (world-size world)))
-          (define next-cat-positions
-            (find-best-positions neighbors
-                                 (map (lambda (p) (lookup-in-table table p))
-                                      neighbors)))
-          (define next-cat-position
-            (cond
-              [(boolean? next-cat-positions) false]
-              [else
-               (list-ref next-cat-positions
-                         (random (length next-cat-positions)))]))]
-    (make-world (world-board world)
-                (cond 
-                  [(boolean? next-cat-position)
-                   cat-position]
-                  [else next-cat-position])
-                (cond
-                  [(boolean? next-cat-position)
-                   'cat-lost]
-                  [(on-boundary? next-cat-position (world-size world))
-                   'cat-won]
-                  [else 'playing])
-                (world-size world)
-                (world-mouse-posn world)
-                (world-h-down? world))))
-
-
-(check-expect
- (move-cat
-  (make-world (list (make-cell (make-posn 1 0) false)
-                    (make-cell (make-posn 2 0) false)
-                    (make-cell (make-posn 3 0) false)
-                    (make-cell (make-posn 4 0) false)
-                    
-                    (make-cell (make-posn 0 1) false)
-                    (make-cell (make-posn 1 1) true)
-                    (make-cell (make-posn 2 1) true)
-                    (make-cell (make-posn 3 1) false)
-                    (make-cell (make-posn 4 1) false)
-                    
-                    (make-cell (make-posn 0 2) false)
-                    (make-cell (make-posn 1 2) true)
-                    (make-cell (make-posn 2 2) false)
-                    (make-cell (make-posn 3 2) true)
-                    (make-cell (make-posn 4 2) false)
-                    
-                    (make-cell (make-posn 0 3) false)
-                    (make-cell (make-posn 1 3) true)
-                    (make-cell (make-posn 2 3) false)
-                    (make-cell (make-posn 3 3) false)
-                    (make-cell (make-posn 4 3) false)
-                    
-                    (make-cell (make-posn 1 4) false)
-                    (make-cell (make-posn 2 4) false)
-                    (make-cell (make-posn 3 4) false)
-                    (make-cell (make-posn 4 4) false))
-              (make-posn 2 2)
-              'playing
-              5
-              (make-posn 0 0)
-              false))
- (make-world (list (make-cell (make-posn 1 0) false)
-                   (make-cell (make-posn 2 0) false)
-                   (make-cell (make-posn 3 0) false)
-                   (make-cell (make-posn 4 0) false)
-                   
-                   (make-cell (make-posn 0 1) false)
-                   (make-cell (make-posn 1 1) true)
-                   (make-cell (make-posn 2 1) true)
-                   (make-cell (make-posn 3 1) false)
-                   (make-cell (make-posn 4 1) false)
-                   
-                   (make-cell (make-posn 0 2) false)
-                   (make-cell (make-posn 1 2) true)
-                   (make-cell (make-posn 2 2) false)
-                   (make-cell (make-posn 3 2) true)
-                   (make-cell (make-posn 4 2) false)
-                   
-                   (make-cell (make-posn 0 3) false)
-                   (make-cell (make-posn 1 3) true)
-                   (make-cell (make-posn 2 3) false)
-                   (make-cell (make-posn 3 3) false)
-                   (make-cell (make-posn 4 3) false)
-                   
-                   (make-cell (make-posn 1 4) false)
-                   (make-cell (make-posn 2 4) false)
-                   (make-cell (make-posn 3 4) false)
-                   (make-cell (make-posn 4 4) false))
-             (make-posn 2 3)
-             'playing
-             5
-             (make-posn 0 0)
-             false))
-
-;; find-best-positions : (nelistof posn) (nelistof number or '∞) -> (nelistof posn) or false
-(define (find-best-positions posns scores)
-  (local [(define best-score (foldl (lambda (x sofar)
-                                      (if (<=/f x sofar)
-                                          x
-                                          sofar))
-                                    (first scores)
-                                    (rest scores)))]
-    (cond
-      [(symbol? best-score) false]
-      [else
-       (map
-        second
-        (filter (lambda (x) (equal? (first x) best-score))
-                (map list scores posns)))])))
-(check-expect (find-best-positions (list (make-posn 0 0)) (list 1))
-              (list (make-posn 0 0)))
-(check-expect (find-best-positions (list (make-posn 0 0)) (list '∞))
-              false)
-(check-expect (find-best-positions (list (make-posn 0 0)
-                                         (make-posn 1 1))
-                                   (list 1 2))
-              (list (make-posn 0 0)))
-(check-expect (find-best-positions (list (make-posn 0 0)
-                                         (make-posn 1 1))
-                                   (list 1 1))
-              (list (make-posn 0 0)
-                    (make-posn 1 1)))
-(check-expect (find-best-positions (list (make-posn 0 0)
-                                         (make-posn 1 1))
-                                   (list '∞ 2))
-              (list (make-posn 1 1)))
-(check-expect (find-best-positions (list (make-posn 0 0)
-                                         (make-posn 1 1))
-                                   (list '∞ '∞))
-              false)
-
-;; add-obstacle : board number number -> board
-(define (add-obstacle board x y)
-  (cond
-    [(empty? board) board]
-    [else 
-     (local [(define cell (first board))
-             (define cx (cell-center-x (cell-p cell)))
-             (define cy (cell-center-y (cell-p cell)))]
-       (cond
-         [(and (<= (- cx circle-radius) x (+ cx circle-radius))
-               (<= (- cy circle-radius) y (+ cy circle-radius)))
-          (cons (make-cell (cell-p cell) true)
-                (rest board))]
-         [else
-          (cons cell (add-obstacle (rest board) x y))]))]))
-
-(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false))
-                            circle-spacing circle-spacing)
-              (list (make-cell (make-posn 0 0) true)))
-(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false)) 100 100)
-              (list (make-cell (make-posn 0 0) false)))
-(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false)
-                                  (make-cell (make-posn 0 1) false))
-                            circle-spacing circle-spacing)
-              (list (make-cell (make-posn 0 0) true)
-                    (make-cell (make-posn 0 1) false)))
-
-;; circle-at-point : board number number -> posn-or-false
-;; returns the posn corresponding to cell where the x,y coordinates are
-(define (circle-at-point board x y)
-  (cond
-    [(empty? board) false]
-    [else 
-     (cond
-       [(point-in-this-circle? (cell-p (first board)) x y)
-        (cell-p (first board))]
-       [else
-        (circle-at-point (rest board) x y)])]))
-(check-expect (circle-at-point empty 0 0) false)
-(check-expect (circle-at-point (list (make-cell (make-posn 0 0) false))
-                               (cell-center-x (make-posn 0 0))
-                               (cell-center-y (make-posn 0 0)))
-              (make-posn 0 0))
-(check-expect (circle-at-point (list (make-cell (make-posn 0 0) false))
-                               0 0)
-              false)
-
-     
-;; point-in-a-circle? : board number number -> boolean
-(define (point-in-a-circle? board x y)
-  (posn? (circle-at-point board x y)))
-(check-expect (point-in-a-circle? empty 0 0) false)
-(check-expect (point-in-a-circle? (list (make-cell (make-posn 0 0) false))
-                                  (cell-center-x (make-posn 0 0))
-                                  (cell-center-y (make-posn 0 0)))
-              true)
-(check-expect (point-in-a-circle? (list (make-cell (make-posn 0 0) false))
-                                  0 0)
-              false)
-
-;; point-in-this-circle? : posn number number -> boolean
-(define (point-in-this-circle? p x y)
-  (local [(define center (+ (cell-center-x p)
-                            (* (sqrt -1) (cell-center-y p))))
-          (define p2 (+ x (* (sqrt -1) y)))]
-    (<= (magnitude (- center p2)) circle-radius)))
-
-(check-expect (point-in-this-circle? (make-posn 0 0)
-                                     (cell-center-x (make-posn 0 0))
-                                     (cell-center-y (make-posn 0 0)))
-              true)
-(check-expect (point-in-this-circle? (make-posn 0 0) 0 0)
-              false)
-              
-;; change : world key-event -> world
-(define (change w ke)
-  (make-world (world-board w)
-              (world-cat w)
-              (world-state w)
-              (world-size w)
-              (world-mouse-posn w)
-              (key=? ke #\h)))
-
-(check-expect (change (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) false)
-                      #\h)
-              (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) true))
-(check-expect (change (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) true)
-                      'release)
-              (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) false))
-
-
-
-
-;                                
-;                                
-;                                
-;                                
-;                                
-;                        ;;;;    
-;                        ;;;     
-;                        ;;;   ; 
-;    ;;;;;;   ;;;;   ;;;;;;;;;;; 
-;   ;;; ;;;; ;;;;;;;;;   ;;;   ;;
-;  ;;; ;;;;;;;;;;;;;;;  ;;;      
-;  ;;;  ;;;;;;;    ;;;  ;;; ;;;; 
-;  ;;;      ;;    ;;;;  ;;; ;;;;;
-;  ;;;    ; ;;;;;;;;;;  ;;;  ;;;;
-;   ;;;  ;  ;;;;;;;;;;; ;;;   ;; 
-;    ;;;;    ;;;;;       ;;;;;   
-;                                
-;                                
-;                                
-
-
-;; cat : symbol -> image
-(define (cat mode)
-  (local [(define face-color 
-            (cond
-              [(symbol=? mode 'sad) 'pink]
-              [else 'lightgray]))
-          
-          (define left-ear (regular-polygon 3 8 'solid 'black (/ pi -3)))
-          (define right-ear (regular-polygon 3 8 'solid 'black 0))
-          (define ear-x-offset 14)
-          (define ear-y-offset 9)
-          
-          (define eye (overlay (ellipse 12 8 'solid 'black)
-                               (ellipse 6 4 'solid 'limegreen)))
-          (define eye-x-offset 8)
-          (define eye-y-offset 3)
-          
-          (define nose (regular-polygon 3 5 'solid 'black (/ pi 2)))
-          
-          (define mouth-happy 
-            (overlay (ellipse 8 8 'solid face-color)
-                     (ellipse 8 8 'outline 'black)
-                     (move-pinhole
-                      (rectangle 10 5 'solid face-color)
-                      0
-                      4)))
-          (define mouth-no-expression
-            (overlay (ellipse 8 8 'solid face-color)
-                     (ellipse 8 8 'outline face-color)
-                     (rectangle 10 5 'solid face-color)))
-          
-          (define mouth 
-            (cond
-              [(symbol=? mode 'happy) mouth-happy]
-              [else mouth-no-expression]))
-          (define mouth-x-offset 4)
-          (define mouth-y-offset -5)]
-    
-    (add-line
-     (add-line
-      (add-line
-       (add-line
-        (add-line
-         (add-line
-          (overlay (move-pinhole left-ear (- ear-x-offset) ear-y-offset)
-                   (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset)
-                   (ellipse 40 26 'solid 'black)
-                   (ellipse 36 22 'solid face-color)
-                   (move-pinhole mouth (- mouth-x-offset) mouth-y-offset)
-                   (move-pinhole mouth mouth-x-offset mouth-y-offset)
-                   (move-pinhole eye (- eye-x-offset) eye-y-offset)
-                   (move-pinhole eye eye-x-offset eye-y-offset)
-                   (move-pinhole nose -1 -4))
-          6 4 30 12 'black)
-         6 4 30 4 'black)
-        6 4 30 -4 'black)
-       -6 4 -30 12 'black)
-      -6 4 -30 4 'black)
-     -6 4 -30 -4 'black)))
-
-(define happy-cat (cat 'happy))
-(define sad-cat (cat 'sad))
-(define thinking-cat (cat 'thinking))
-
-
-;                                                        
-;                                                        
-;                                                        
-;                                                        
-;                                                        
-;   ;;;;            ;;;;   ;;;;     ;;;;           ;;;;; 
-;   ;;;;;           ;;;;;  ;;;      ;;;;;            ;;; 
-;                          ;;;   ;                   ;;; 
-;      ;;;;;;  ;;      ; ;;;;;;;;;     ;   ;;;;   ;; ;;; 
-;  ;;;;;  ;;; ;;;; ;;;;;   ;;;   ;;;;;;;  ;;;;;;;;;  ;;; 
-;    ;;;  ;;; ;;;;   ;;;  ;;;        ;;; ;;;;;;;;;;  ;;; 
-;    ;;;  ;;;; ;;;   ;;;  ;;; ;;;;   ;;; ;;;    ;;;  ;;; 
-;    ;;;  ;;;  ;;;   ;;;  ;;; ;;;;;  ;;; ;;    ;;;;  ;;  
-;   ;;;;  ;;;  ;;;  ;;;;  ;;;  ;;;; ;;;; ;;;;;;;;;; ;;;  
-;  ;;;;;;;;;;  ;;; ;;;;;;;;;;   ;; ;;;;;;;;;;;;;;;;;;;;; 
-;             ;;;;         ;;;;;          ;;;;;          
-;               ;;;                                      
-;                                                        
-;                                                        
-;                                                    
-;                                                    
-;                                                    
-;                                                    
-;                                                    
-;  ;;;;;                                           ;;
-;   ;;;;                                        ;;;; 
-;   ;;;                                          ;;; 
-;   ;;; ;;;    ;;;;;    ;;;;   ;;   ; ;;;;   ;;; ;;; 
-;   ;;;;;;;;  ;;;;;;;  ;;;;;;;;;;;;;;; ;;;; ;;;;;;;; 
-;   ;;;;;;;; ;;;;;;;; ;;;;;;;;;;  ;;; ;;;;;;;;;;;;;; 
-;   ;;;   ;; ;;     ; ;;;    ;;;  ;;; ;;;; ;;;   ;;; 
-;   ;;;   ;; ;     ;; ;;    ;;;;  ;;;      ;;   ;;;; 
-;   ;;;;;;;  ;;;;;;;; ;;;;;;;;;;  ;;;      ;;;;;;;;  
-;  ;;;;;;;    ;;;;;;  ;;;;;;;;;;;;;;;;;;    ;;;;;;;;;
-;              ;;;;    ;;;;;                         
-;                                                    
-;                                                    
-;                                                    
-
-;; append-all : (listof (list X)) -> (listof X)
-(define (append-all ls)
-  (foldr append empty ls))
-
-(check-expect (append-all empty) empty)
-(check-expect (append-all (list (list 1 2 3))) (list 1 2 3))
-(check-expect (append-all (list (list 1) (list 2) (list 3)))
-              (list 1 2 3))
-
-;; add-n-random-blocked-cells : number (listof cell) number -> (listof cell)
-(define (add-n-random-blocked-cells n all-cells board-size)
-  (cond
-    [(zero? n) all-cells]
-    [else
-     (local [(define unblocked-cells 
-               (filter (lambda (x) 
-                         (let ([cat-cell? (and (= (posn-x (cell-p x)) (quotient board-size 2))
-                                               (= (posn-y (cell-p x)) (quotient board-size 2)))])
-                           
-                           (and (not (cell-blocked? x))
-                                (not cat-cell?))))
-                       all-cells))
-             (define to-block (list-ref unblocked-cells 
-                                        (random (length unblocked-cells))))]
-       (add-n-random-blocked-cells
-        (sub1 n)
-        (block-cell (cell-p to-block) all-cells)
-        board-size))]))
-
-;; block-cell : posn board -> board
-(define (block-cell to-block board)
-  (map (lambda (c) (if (equal? to-block (cell-p c))
-                       (make-cell to-block true)
-                       c))
-       board))
-(check-expect (block-cell (make-posn 1 1)
-                          (list (make-cell (make-posn 0 0) false)
-                                (make-cell (make-posn 1 1) false)
-                                (make-cell (make-posn 2 2) false)))
-              (list (make-cell (make-posn 0 0) false)
-                    (make-cell (make-posn 1 1) true)
-                    (make-cell (make-posn 2 2) false)))
-
-(check-expect (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0) true)) 10)
-              (list (make-cell (make-posn 0 0) true)))
-(check-expect (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0) false)) 10)
-              (list (make-cell (make-posn 0 0) true)))
-
-;; empty-board : number -> (listof cell)
-(define (empty-board board-size)
-  (filter
-   (lambda (c)
-     (not (and (= 0 (posn-x (cell-p c)))
-               (or (= 0 (posn-y (cell-p c)))
-                   (= (- board-size 1)
-                      (posn-y (cell-p c)))))))
-   (append-all
-    (build-list
-     board-size
-     (lambda (i)
-       (build-list
-        board-size
-        (lambda (j) 
-          (make-cell (make-posn i j) 
-                     false))))))))
-
-(check-expect (empty-board 3)
-              (list
-               (make-cell (make-posn 0 1) false)
-               (make-cell (make-posn 1 0) false)
-               (make-cell (make-posn 1 1) false)
-               (make-cell (make-posn 1 2) false)
-               (make-cell (make-posn 2 0) false)
-               (make-cell (make-posn 2 1) false)
-               (make-cell (make-posn 2 2) false)))
-
-;; empty-world : number -> world
-(define (empty-world board-size)
-  (make-world (empty-board board-size)
-              (make-posn (quotient board-size 2)
-                         (quotient board-size 2))
-              'playing
-              board-size
-              (make-posn 0 0)
-              false))
-
-(check-expect (empty-world 3)
-              (make-world (list
-                           (make-cell (make-posn 0 1) false)
-                           (make-cell (make-posn 1 0) false)
-                           (make-cell (make-posn 1 1) false)
-                           (make-cell (make-posn 1 2) false)
-                           (make-cell (make-posn 2 0) false)
-                           (make-cell (make-posn 2 1) false)
-                           (make-cell (make-posn 2 2) false))
-                          (make-posn 1 1)
-                          'playing
-                          3
-                          (make-posn 0 0)
-                          false))
-
-(define dummy
-  (local
-    [(define board-size 11)
-     (define initial-board
-       (add-n-random-blocked-cells
-        6
-        (empty-board board-size)
-        board-size))
-     (define initial-world
-       (make-world initial-board
-                   (make-posn (quotient board-size 2)
-                              (quotient board-size 2))
-                   'playing
-                   board-size
-                   false
-                   false))]
-    
-    (and 
-     (big-bang (world-width board-size)
-               (world-height board-size)
-               1 
-               initial-world)
-     (on-redraw render-world)
-     (on-key-event change)
-     (on-mouse-event clack))))
diff --git a/collects/games/chat-noir/literate-doc-wrapper.ss b/collects/games/chat-noir/literate-doc-wrapper.ss
deleted file mode 100644
index 030b3af629..0000000000
--- a/collects/games/chat-noir/literate-doc-wrapper.ss
+++ /dev/null
@@ -1,57 +0,0 @@
-#lang scheme/base
-
-;; Use this module to create literate doc wrappers -- files that require the
-;; literate code in a way that makes it a scribble file.
-
-(provide include chunk chunkref
-         (all-from-out scribble/manual))
-
-(require scribble/manual scribble/decode scribble/struct scheme/include
-         (for-syntax scheme/base syntax/boundmap))
-
-(begin-for-syntax
-  ;; maps chunk identifiers to a counter, so we can distinguish multiple uses
-  ;; of the same name
-  (define chunk-numbers (make-free-identifier-mapping))
-  (define (get-chunk-number id)
-    (let ([n (add1 (free-identifier-mapping-get chunk-numbers id
-                                                (lambda () 0)))])
-      (free-identifier-mapping-put! chunk-numbers id n)
-      n)))
-
-;; This is the doc-view implementation of `chunk', see "literate-lang.ss" for
-;; the cide-view implementation.  Defines `chunk' as a macro that typesets the
-;; contained code.
-(define-syntax (chunk stx)
-  (syntax-case stx ()
-    [(_ name expr ...)
-     ;; no need for more error checking, using chunk for the code will do that
-     (identifier? #'name)
-     (let ([n (get-chunk-number #'name)]
-           [str (symbol->string (syntax-e #'name))])
-       (with-syntax ([tag (if (n . > . 1) (format "~a:~a" str n) str)]
-                     [(more ...) (if (n . > . 1)
-                                     #`((subscript (smaller #,(format "~a" n))))
-                                     #`())]
-                     [str str])
-         #`(make-splice
-            (list (make-toc-element
-                   #f
-                   (list (elemtag '(chunk tag)
-                                  (bold (italic (scheme name)) " ::=")))
-                   (list (smaller (elemref '(chunk tag) #:underline? #f
-                                           str more ...))))
-                  (schemeblock expr ...)))))]))
-
-(define-syntax (chunkref stx)
-  (syntax-case stx ()
-    [(_ id)
-     (identifier? #'id)
-     (with-syntax ([str (format "~a" (syntax-e #'id))])
-       #'(elemref '(chunk str) #:underline? #f str))]))
-
-;; HACK: provide a fake `module', which makes it possible to include a module
-;; and get only its code in.
-(provide module)
-(define-syntax-rule (module name base body ...)
-  (begin body ...))
diff --git a/collects/games/chat-noir/literate-lang.ss b/collects/games/chat-noir/literate-lang.ss
deleted file mode 100644
index f25595809f..0000000000
--- a/collects/games/chat-noir/literate-lang.ss
+++ /dev/null
@@ -1,103 +0,0 @@
-#lang scheme/base
-
-(provide (except-out (all-from-out scheme/base) #%module-begin)
-         (rename-out [module-begin #%module-begin])
-         chunk)
-
-(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase))
-
-(begin-for-syntax
-  (define main-id #f)
-  (define (mapping-get mapping id)
-    (free-identifier-mapping-get mapping id (lambda () '())))
-  ;; maps a chunk identifier to its collected expressions
-  (define chunks (make-free-identifier-mapping))
-  ;; maps a chunk identifier to all identifiers that are used to define it
-  (define chunk-groups (make-free-identifier-mapping))
-  (define (get-chunk id)
-    (map syntax-local-introduce (mapping-get chunks id)))
-  (define (add-to-chunk! id exprs)
-    (unless main-id (set! main-id id))
-    (free-identifier-mapping-put!
-     chunk-groups id
-     (cons (syntax-local-introduce id) (mapping-get chunk-groups id)))
-    (free-identifier-mapping-put!
-     chunks id
-     `(,@(mapping-get chunks id) ,@(map syntax-local-introduce exprs)))))
-
-;; This is the code-view implementation of `chunk', see
-;; "literate-doc-wrapper.ss" for the doc-view implementation.  Defines
-;; `chunk' as a macro that collects the code to be later reassembled
-;; by `tangle'.
-(define-syntax (chunk stx)
-  (syntax-case stx ()
-    [(_ name expr ...)
-     (cond [(not (identifier? #'name))
-            (raise-syntax-error #f "expected a chunk name" stx #'name)]
-           [(not (regexp-match? #rx"^<.*>$" (symbol->string (syntax-e #'name))))
-            (raise-syntax-error
-             #f "chunk names must begin and end with angle brackets, <...>"
-             stx #'name)]
-           [else (add-to-chunk! #'name (syntax->list #'(expr ...)))
-                 #'(void)])]))
-
-(define-syntax (tangle stx)
-  (define chunk-mentions '())
-  (define body
-    (let loop ([block (get-chunk main-id)])
-      (append-map
-       (lambda (expr)
-         (if (identifier? expr)
-           (let ([subs (get-chunk expr)])
-             (if (pair? subs)
-               (begin (set! chunk-mentions (cons expr chunk-mentions))
-                      (loop subs))
-               (list expr)))
-           (let ([subs (syntax->list expr)])
-             (if subs
-               (list (loop subs))
-               (list expr)))))
-       block)))
-  (with-syntax ([(body ...) body]
-                ;; construct arrows manually
-                [((b-use b-id) ...)
-                 (append-map (lambda (m)
-                               (map (lambda (u)
-                                      (list m (syntax-local-introduce u)))
-                                    (mapping-get chunk-groups m)))
-                             chunk-mentions)])
-    #`(begin body ... (let ([b-id (void)]) b-use) ...)))
-
-(define-syntax (module-begin stx)
-  (syntax-case stx ()
-    [(module-begin expr ...)
-     (with-syntax
-         ([(body-code ...)
-           (let loop ([exprs (syntax->list #'(expr ...))])
-             (cond
-               [(null? exprs) null]
-               [else
-                (let ([expanded
-                       (local-expand (car exprs)
-                                     'module
-                                     (append (kernel-form-identifier-list)
-                                             (syntax->list #'(provide
-                                                              require
-                                                              #%provide
-                                                              #%require))))])
-                  (syntax-case expanded (begin)
-                    [(begin rest ...)
-                     (append (loop (syntax->list #'(rest ...)))
-                             (loop (cdr exprs)))]
-                    [(id . rest)
-                     (ormap (lambda (kw) (free-identifier=? #'id kw))
-                            (syntax->list #'(require
-                                             provide
-                                             chunk
-                                             #%require
-                                             #%provide)))
-                     (cons expanded (loop (cdr exprs)))]
-                    [else (loop (cdr exprs))]))]))])
-       #'(#%module-begin
-          body-code ...
-          (tangle)))]))
diff --git a/collects/games/scribblings/chat-noir.scrbl b/collects/games/scribblings/chat-noir.scrbl
index d5ba2790dc..e705a0c166 100644
--- a/collects/games/scribblings/chat-noir.scrbl
+++ b/collects/games/scribblings/chat-noir.scrbl
@@ -1,69 +1,3 @@
 #lang scribble/doc
-@(require "common.ss")
-@(require scheme/runtime-path (for-syntax scheme/port scheme/base scheme/path))
-@(define-runtime-path cn "../chat-noir/chat-noir.ss")
-
-@gametitle["Chat Noir" "chat-noir" "Puzzle Game"]
-
-The goal of the game is to stop the cat from escaping the board. Each
-turn you click on a circle, which prevents the cat from stepping on
-that space, and the cat responds by taking a step. If the cat is
-completely boxed in and thus unable reach the border, you win. If the
-cat does reach the border, you lose.
-
-To get some insight into the cat's behavior, hold down the ``h''
-key. It will show you the cells that are on the cat's shortest path to
-the edge, assuming that the cell underneath the mouse has been
-blocked, so you can experiment to see how the shortest paths change
-by moving your mouse around.
-
-The game was inspired by this one the one at
-@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game
-Design} and has essentially the same rules. It also inspired the final
-project for the introductory programming course at the University of
-Chicago in the fall of 2008.
-
-@;{
-
-This is commented out, waiting for the literate programming stuff.
-
-This game is written in the
-@link["http://www.htdp.org/"]{How to Design Programs}
-Intermediate language. It is a model solution to the final project for
-the introductory programming course at the University of Chicago in
-the fall of 2008, as below.
-
-@(define-syntax (m stx)
-   (call-with-input-file
-       (build-path (path-only (syntax-source stx))
-                   'up "chat-noir" "chat-noir.ss")
-     (lambda (port)
-       (port-count-lines! port)
-       #`(schemeblock
-          #,@
-          (let loop ()
-            (let* ([p (peeking-input-port port)]
-                   [l (read-line p)])
-              (cond
-                [(eof-object? l) '()]
-                [(regexp-match #rx"^[ \t]*$" l)
-                 (read-line port)
-                 (loop)]
-                [(regexp-match #rx"^ *;+" l)
-                 =>
-                 (lambda  (m)
-                   (let-values ([(line col pos) (port-next-location port)])
-                     (read-line port)
-                     (let-values ([(line2 col2 pos2) (port-next-location port)])
-                       (cons (datum->syntax 
-                              #f
-                              `(code:comment ,(regexp-replace* #rx" " l "\u00a0"))
-                              (list "chat-noir.ss" line col pos (- pos2 pos)))
-                             (loop)))))]
-                [else
-                 (cons (read-syntax "chat-noir.ss" port)
-                       (loop))])))))
-     #:mode 'text))
-
-@m[]
-}
+@(require scribble/lp-include)
+@(lp-include "../chat-noir/chat-noir-literate.ss")
diff --git a/collects/games/scribblings/common.ss b/collects/games/scribblings/common.ss
index 8dfedc8bcb..8cac002f69 100644
--- a/collects/games/scribblings/common.ss
+++ b/collects/games/scribblings/common.ss
@@ -6,26 +6,36 @@
          setup/main-collects)
 (provide (all-from-out scribble/manual)
          selflink
-         gametitle
+         gametitle gametitle* play-margin-note
          game)
 
 (define (selflink str) (link str (tt str)))
 
 (define game onscreen)
 
-(define (gametitle name subcol subtitle)
+(define (gametitle name subcol subtitle 
+                   #:style [style #f])
   (make-splice
    (list
-    (title #:tag subcol 
-           (make-element
-            "noborder"
-            (list
-             (image (path->main-collects-relative
-                     (build-path (collection-path "games" subcol)
-                                 (format "~a.png" subcol))))))
-           " " (onscreen name) " --- " subtitle)
-    (margin-note "To play "
-                 (onscreen name)
-                 ", run the "
-                 (exec "PLT Games") " program."
-                 " (Under Unix, it's called " (exec "plt-games") ")."))))
+    (gametitle* name subcol subtitle #:style style)
+    (play-margin-note name))))
+
+(define (gametitle* name subcol subtitle 
+                    #:style [style #f])
+  (title #:tag subcol 
+         #:style style
+         (make-element
+          "noborder"
+          (list
+           (image (path->main-collects-relative
+                   (build-path (collection-path "games" subcol)
+                               (format "~a.png" subcol))))))
+         " " (onscreen name) " --- " subtitle))
+
+(define (play-margin-note name)
+  (margin-note "To play "
+               (onscreen name)
+               ", run the "
+               (exec "PLT Games") " program."
+               " (Under Unix, it's called " (exec "plt-games") ")."))
+
diff --git a/collects/games/scribblings/jewel.scrbl b/collects/games/scribblings/jewel.scrbl
index aabe96c91d..a40ac11507 100644
--- a/collects/games/scribblings/jewel.scrbl
+++ b/collects/games/scribblings/jewel.scrbl
@@ -3,6 +3,8 @@
 
 @gametitle["Jewel" "jewel" "3-D Skill Game"]
 
+@author["Peter Ivanyi"]
+
 The board is an 8 by 8 array of jewels of 7 types.  You need to get 3
 or more in a row horizontally or vertically in order to score points.
 You can swap any two jewels that are next to each other up and down or
diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss
index 1176dfbaaa..c5fd648bba 100644
--- a/collects/handin-server/checker.ss
+++ b/collects/handin-server/checker.ss
@@ -334,8 +334,7 @@
            (if (memq unknown vals)
              exn
              (apply (struct-type-make-constructor struct-type)
-                    (string->immutable-string
-                     (format "while evaluating ~s:\n  ~a" expr (car vals)))
+                    (format "while evaluating ~s:\n  ~a" expr (car vals))
                     (cdr vals))))
          exn))))
   (with-handlers ([exn? reraise]) (eval expr)))
diff --git a/collects/honu/main.ss b/collects/honu/main.ss
index a3573f4885..2e5501d0fd 100644
--- a/collects/honu/main.ss
+++ b/collects/honu/main.ss
@@ -1,14 +1,18 @@
-(module main "private/mzscheme.ss"
+#lang scheme/base
+
+  (require (for-syntax
+             syntax/stx
+             scheme/base
+             syntax/kerncase
+             syntax/define
+             syntax/context
+             syntax/name
+             "private/ops.ss"
+             "private/util.ss"
+             "private/contexts.ss"
+             ))
 
-  (require-for-syntax syntax/stx
-		      "private/ops.ss"
-		      "private/util.ss"
-		      syntax/kerncase
-                      syntax/name
-		      "private/contexts.ss")
-  
   (begin-for-syntax
-
    ;; these definitions are used as stop-lists in local-expand
    (define kernel-forms (kernel-form-identifier-list))
    (define prop-expand-stop-forms (list* #'honu-typed
@@ -20,6 +24,7 @@
    (define type-name-expand-stop-forms (list
                                         #'honu-type-name))
 
+
    ;; --------------------------------------------------------
    ;; Transformer procedure property and basic struct
 
@@ -64,7 +69,7 @@
           [(forall (id ...) rhs bindings)
            (append (map syntax-e (syntax->list #'(id ...)))
                    (list '>-> (format-type #'rhs)))]
-          [_else `(??? ,(syntax-object->datum t))])))
+          [_else `(??? ,(syntax->datum t))])))
 
    ;; --------------------------------------------------------
    ;; Parsing blocks
@@ -83,7 +88,7 @@
      (and (identifier? stx)
 	  (not (ormap (lambda (i) (delim-identifier=? stx i)) (list #'\; #'\,)))
 	  (not (operator? stx))))
-   
+
    (define (get-transformer stx)
      ;; if its an identifier and bound to a transformer return it
      (define (bound-transformer stx)
@@ -113,7 +118,7 @@
                        [else (loop (cdr l))])))]
                 [(and (stx-pair? first)
                       (identifier? (stx-car first))
-                      (module-identifier=? #'#%angles (stx-car first)))
+                      (free-identifier=? #'#%angles (stx-car first)))
                  (let ([v (syntax-local-value (stx-car first) (lambda () #f))])
                    (and (honu-transformer? v) v))]
                 [else #f]))))
@@ -133,7 +138,8 @@
        => (lambda (transformer)
 	    (let-values ([(code rest) (transformer body ctx)])
 	      (k code rest)))]
-      [else (let-values ([(expr-stxs after-expr terminator) (extract-until body (list #'\;))])
+      [else (let-values ([(expr-stxs after-expr terminator)
+                          (extract-until body (list #'\;))])
 	      (unless expr-stxs
 		(raise-syntax-error
 		 #f
@@ -177,7 +183,7 @@
          ;; Since we're parsing an expression in a
          ;; declaration context, we're responsible for
          ;; getting the whole expression:
-         (let ([placeholder (datum->syntax-object #f (gensym))])
+         (let ([placeholder (datum->syntax #f (gensym))])
            (let-values ([(expr-stxs after-expr terminator) (extract-until (cons placeholder rest) (list #'\;))])
              (unless expr-stxs
                (raise-syntax-error
@@ -188,11 +194,11 @@
                                   (cond
                                    [(eq? in-expr placeholder) expr]
                                    [(syntax? in-expr)
-                                    (datum->syntax-object in-expr
-                                                          (loop (syntax-e in-expr))
-                                                          in-expr
-                                                          in-expr
-                                                          in-expr)]
+                                    (datum->syntax in-expr
+                                                   (loop (syntax-e in-expr))
+                                                   in-expr
+                                                   in-expr
+                                                   in-expr)]
                                    [(pair? in-expr) (cons (loop (car in-expr))
                                                           (loop (cdr in-expr)))]
                                    [else in-expr]))])
@@ -272,9 +278,9 @@
                                   (delim-identifier=? #'#%parens id)
                                   (delim-identifier=? #'#%angles id))))
                        (and (identifier? (stx-car stx))
-			    (hash-table-get op-table
-					    (syntax-e (stx-car stx))
-					    (lambda () #f))))
+			    (hash-ref op-table
+                                      (syntax-e (stx-car stx))
+                                      (lambda () #f))))
 	     (raise-syntax-error
 	      'expression
 	      "expected an operator, but found something else"
@@ -362,8 +368,8 @@
 		  [(not (op? (stx-car seq)))
 		   (loop (cdr seq) before op (cons (car seq) since))]
 		  [((if (prefix? op) >= >)
-                    (hash-table-get precedence-table (prec-key (car seq)) (lambda () 0))
-                    (hash-table-get precedence-table (prec-key op) (lambda () 0)))
+                    (hash-ref precedence-table (prec-key (car seq)) (lambda () 0))
+                    (hash-ref precedence-table (prec-key op) (lambda () 0)))
 		   (loop (cdr seq) 
 			 (if op
 			     (append since (list op) before)
@@ -550,11 +556,11 @@
 					   (stx-car orig-stx)
 					   #'id))
 		     (if (and (or (value-definition-context? ctx)
-                                  (not (module-identifier=? #'id #'function)))
+                                  (not (free-identifier=? #'id #'function)))
                               (not (function-definition-context? ctx))
                               (not (prototype-context? ctx))
                               (identifier? (stx-car #'rest))
-			      (module-identifier=? #'set! (stx-car #'rest)))
+			      (free-identifier=? #'set! (stx-car #'rest)))
 			 ;; -- Non-procedure declaration
 			 (if (function-definition-context? ctx)
 			     (raise-syntax-error 
@@ -595,7 +601,7 @@
 				  (with-syntax ([((arg arg-type arg-type-name arg-pred-id arg-protect-id) ...) args]
 						[(temp-id ...) (generate-temporaries (map car args))]
                                                 [def-id (if (and (not (definition-context? ctx))
-                                                                 (module-identifier=? #'id #'function))
+                                                                 (free-identifier=? #'id #'function))
                                                             (or (syntax-local-infer-name #'id)
                                                                 (car (generate-temporaries '(function))))
                                                             #'id)])
@@ -614,7 +620,7 @@
                                                        (define-typed arg #f id arg-type arg-type-name arg-pred-id arg-protect-id temp-id) ...
                                                        (honu-unparsed-block def-id type-name type-name-expr pred-id #t . body))))])
                                           (if (and (not (definition-context? ctx))
-                                                   (module-identifier=? #'id #'function))
+                                                   (free-identifier=? #'id #'function))
                                               ;; Anonymous function:
                                               ;;  We may have to continue parsing...
                                               (finish-parsing-expression "anonymous function"
@@ -663,7 +669,7 @@
      (let-values ([(args-stx ->-stx result-stx) 
 		   (let loop ([stx (stx-cdr (stx-car form))][args null])
 		     (if (and (identifier? (stx-car stx))
-			      (module-identifier=? #'-> (stx-car stx)))
+			      (free-identifier=? #'-> (stx-car stx)))
 			 (values (reverse args) (stx-car stx) (stx-cdr stx))
 			 (loop (stx-cdr stx) (cons (stx-car stx) args))))])
        (when (stx-null? result-stx)
@@ -732,7 +738,7 @@
      (let-values ([(args-stx >->-stx result-stx) 
 		   (let loop ([stx (stx-cdr (stx-car form))][args null])
 		     (if (and (identifier? (stx-car stx))
-			      (module-identifier=? #'>-> (stx-car stx)))
+			      (free-identifier=? #'>-> (stx-car stx)))
 			 (values (reverse args) (stx-car stx) (stx-cdr stx))
 			 (loop (stx-cdr stx) (cons (stx-car stx) args))))])
        (when (stx-null? result-stx)
@@ -789,7 +795,7 @@
         (identifier? t)
         (or (and (identifier? t)
                  (ormap (lambda (orig new)
-                          (and (module-identifier=? t orig)
+                          (and (free-identifier=? t orig)
                                new))
                         orig-ids new-types))
             t)]
@@ -821,8 +827,8 @@
          [(boolean? (syntax-e val-expr)) #'bool]
          [(identifier? val-expr)
           (cond
-           [(module-identifier=? #'false val-expr) #'bool]
-           [(module-identifier=? #'true val-expr) #'bool]
+           [(free-identifier=? #'false val-expr) #'bool]
+           [(free-identifier=? #'true val-expr) #'bool]
            [else #'obj])]
          [else #'obj])]))
        
@@ -833,22 +839,22 @@
      (syntax-case target-type (-> forall)
        [ttid
         (identifier? target-type)
-        (or (module-identifier=? #'obj target-type)
+        (or (free-identifier=? #'obj target-type)
             (and (identifier? val-type)
-                 (module-identifier=? val-type target-type))
+                 (free-identifier=? val-type target-type))
             (let ([val-type
                    (if (not val-type)
                        (apparent-type val-expr)
                        val-type)])
               (or (and (identifier? val-type)
-                       (or (module-identifier=? val-type target-type)
-                           (and (module-identifier=? #'num target-type)
-                                (or (module-identifier=? val-type #'int)
-                                    (module-identifier=? val-type #'real)))
-                           (and (module-identifier=? #'real target-type)
-                                (or (module-identifier=? val-type #'int)))))
+                       (or (free-identifier=? val-type target-type)
+                           (and (free-identifier=? #'num target-type)
+                                (or (free-identifier=? val-type #'int)
+                                    (free-identifier=? val-type #'real)))
+                           (and (free-identifier=? #'real target-type)
+                                (or (free-identifier=? val-type #'int)))))
                   (if (and (identifier? val-type)
-                           (module-identifier=? val-type #'obj))
+                           (free-identifier=? val-type #'obj))
                       #f
                       (fail-k orig-val-expr val-type target-type)))))]
        [(-> (t-result-type t-result-protect-id) (t-arg-type t-arg-type-name t-arg-pred) ...)
@@ -871,7 +877,7 @@
                                                        (do-fail))))
                             t-args v-args)))]
             [_else
-             (if (module-identifier=? val-type #'obj)
+             (if (free-identifier=? val-type #'obj)
                  #f
                  (do-fail))]))]
        [(forall (poly-id ...) poly-t bindings)
@@ -892,7 +898,7 @@
                    (do-fail)))]
             [else
              (if (and (identifier? val-type)
-                      (module-identifier=? val-type #'obj))
+                      (free-identifier=? val-type #'obj))
                  #f
                  (do-fail))]))]
        [_else
@@ -979,7 +985,7 @@
                                v)]))]
       [(lv ([(lhs ...) expr] ...) ... body)
        (ormap (lambda (id)
-                (module-identifier=? #'lv id))
+                (free-identifier=? #'lv id))
               (list #'let-values #'letrec-values #'letrec-syntaxes+values))
        (extract-type #'body)]
       [(begin e ... last-expr)
@@ -1146,9 +1152,9 @@
       [(_ #%angles a (b ...))
        #'(honu-type-app a b ...)]
       [(_ a b ...) 
-       (datum->syntax-object #'a
-                             (cons #'a #'(b ...))
-                             #'a)]))
+       (datum->syntax #'a
+                      (cons #'a #'(b ...))
+                      #'a)]))
 
   (define-syntax (op-cast stx)
     (syntax-case stx (#%parens)
@@ -1292,7 +1298,7 @@
       
   (define-syntax (honu-type-info stx) (raise-syntax-error #f "shouldn't appear unquoted!" stx))
 
-  (require-for-syntax syntax/context)
+  ;; (require-for-syntax syntax/context)
   (define-syntax (honu-block stx)
     ;; A block can have mixed exprs and defns. Wrap expressions with
     ;; `(define-values () ... (values))' as needed, and add a (void)
@@ -1353,7 +1359,7 @@
 				    (begin
 				      (unless (or (not proc-id)
 						  (not (syntax-e proc-id))
-						  (module-identifier=? #'type-name #'obj))
+						  (free-identifier=? #'type-name #'obj))
 					(error "no expression for type check; should have been "
 					       "caught earlier"))
 				      (reverse prev-exprs)))
@@ -1362,8 +1368,8 @@
 				    null))]
 		[(and (stx-pair? (car exprs))
                       (identifier? (stx-car (car exprs)))
-		      (or (module-identifier=? #'define-values (stx-car (car exprs)))
-			  (module-identifier=? #'define-syntaxes (stx-car (car exprs)))))
+		      (or (free-identifier=? #'define-values (stx-car (car exprs)))
+			  (free-identifier=? #'define-syntaxes (stx-car (car exprs)))))
 		 (loop (cdr exprs)
 		       (cons (car exprs)
 			     (append
@@ -1417,7 +1423,7 @@
   ;; --------------------------------------------------------
   ;; Defining a new transformer or new type
 
-  (require-for-syntax syntax/define)
+  ;; (require-for-syntax syntax/define)
   (define-syntax (define-honu-syntax stx)
     (let-values ([(id rhs) (normalize-definition stx #'lambda #f)])
       (with-syntax ([id id]
@@ -1622,7 +1628,7 @@
                               ;; Assume anything else is ok:
                               (loop #'rest (cons #'something accum))]))])
              (unless (block-context? ctx)
-               (unless (module-identifier=? id #'function)
+               (unless (free-identifier=? id #'function)
                  (raise-syntax-error #f 
                                      (format
                                       "named generic allowed only in a block context, not in ~a context" 
@@ -1632,7 +1638,7 @@
              (with-syntax ([(poly-id ...) ids]
                            [(poly-pred-id ...) (generate-temporaries ids)]
                            [(poly-name-id ...) (generate-temporaries ids)]
-                           [def-id (if (module-identifier=? id #'function)
+                           [def-id (if (free-identifier=? id #'function)
                                        (or (syntax-local-infer-name id)
                                            (car (generate-temporaries '(function))))
                                        id)]
@@ -1685,7 +1691,7 @@
                                         (new-id honu-safe-use-hack)
                                         new-id)))))])
 
-                    (if (module-identifier=? id #'function)
+                    (if (free-identifier=? id #'function)
                         ;; Anonymous function:
                         ;;  We may have to continue parsing...
                         (finish-parsing-expression "anonymous generic function"
@@ -2035,6 +2041,7 @@
 			(honu-unparsed-begin #,@rest)))]))
 
   (define-syntax (#%dynamic-honu-module-begin stx)
+    ;; (printf "honu raw sexp ~a\n" (syntax->datum stx))
     #`(#%plain-module-begin
 	(honu-unparsed-begin #,@(stx-cdr stx))))
   
@@ -2071,31 +2078,39 @@
 	   string
            -> >->
 	   \;
-           (rename set! =)
-	   (rename honu-return return)
-	   (rename honu-if if) ? :
-           (rename honu-time time)
-	   (rename honu-class class)
-	   (rename honu+ +) (rename honu- -) (rename honu* *) 
-           / (rename modulo %)
-           < > <= >= (rename equal? ==) !=
+           ? :
            && \|\|
-	   (rename string->number stringToNumber)
-	   (rename number->string numberToString)
-	   cons list
-	   (rename car first) 
-	   (rename cdr rest)
-	   (rename null empty)
-	   (rename null? isEmpty)
-	   (rename pair? isCons)
-	   true false
+           /
+           < > <= >=
+           !=
+           cons list
+           true false
 	   display write newline
 	   #%datum
-	   #%top
+           #%top
 	   #%parens #%brackets #%braces #%angles
            #%prefix #%postfix
-	   (rename #%dynamic-honu-module-begin #%module-begin)
-	   (rename honu-#%app #%app)
-	   define-honu-syntax
-           (rename honu-provide provide)
-           (rename honu-require require)))
+           define-honu-syntax
+
+           (rename-out (set! =)
+                       (honu-return return)
+                       (honu-if if)
+                       (honu-time time)
+                       (honu-class class)
+                       (honu+ +)
+                       (honu- -)
+                       (honu* *) 
+                       (modulo %)
+                       (equal? ==)
+                       (string->number stringToNumber)
+                       (number->string numberToString)
+                       (car first) 
+                       (cdr rest)
+                       (null empty)
+                       (null? isEmpty)
+                       (pair? isCons)
+                       (#%dynamic-honu-module-begin #%module-begin)
+                       (honu-#%app #%app)
+                       (honu-provide provide)
+                       (honu-require require)))
+
diff --git a/collects/htdp/image.ss b/collects/htdp/image.ss
index 4c58afff08..0b51021648 100644
--- a/collects/htdp/image.ss
+++ b/collects/htdp/image.ss
@@ -77,6 +77,13 @@ plt/collects/tests/mzscheme/htdp-image.ss
 
 ;; ----------------------------------------
 
+(define (floor0 n)
+  (cond
+    [(< n 0) (- (floor (- n)))]
+    [else (floor n)]))
+
+;; ----------------------------------------
+
 (define (check name p? v desc arg-posn) (check-arg name (p? v) desc arg-posn v))
 
 (define (check-coordinate name val arg-posn) (check name finite-real? val "finite real number" arg-posn))
@@ -169,8 +176,8 @@ plt/collects/tests/mzscheme/htdp-image.ss
            (width w)
            (height h)
            (argb (send i get-argb/no-compute))
-           (px (+ px dx))
-           (py (+ py dy))))))
+           (px (+ px (floor0 dx)))
+           (py (+ py (floor0 dy)))))))
 
 (define (put-pinhole raw-i px py)
   (check-image 'put-pinhole raw-i "first")
@@ -184,8 +191,8 @@ plt/collects/tests/mzscheme/htdp-image.ss
            (width w)
            (height h)
            (argb (send i get-argb/no-compute))
-           (px (floor px))
-           (py (floor py))))))
+           (px (floor0 px))
+           (py (floor0 py))))))
 
 (define (overlay a b . cs)
   (check-image 'overlay a "first")
@@ -209,8 +216,8 @@ plt/collects/tests/mzscheme/htdp-image.ss
   (check-image 'overlay/xy b "fourth")
   (real-overlay/xy 'overlay/xy 
                    a
-                   (floor (if (exact? dx) dx (inexact->exact dx)))
-                   (floor (if (exact? dy) dy (inexact->exact dy)))
+                   (floor0 (if (exact? dx) dx (inexact->exact dx)))
+                   (floor0 (if (exact? dy) dy (inexact->exact dy)))
                    b))
 
 (define (real-overlay/xy name raw-a raw-delta-x raw-delta-y raw-b)
@@ -256,10 +263,10 @@ plt/collects/tests/mzscheme/htdp-image.ss
   (check-size/0 'shrink in-up "third")
   (check-size/0 'shrink in-right "fourth")
   (check-size/0 'shrink in-down "fifth")
-  (let ([left (inexact->exact (floor in-left))]
-        [up (inexact->exact (floor in-up))]
-        [right (inexact->exact (floor in-right))]
-        [down (inexact->exact (floor in-down))]
+  (let ([left (inexact->exact (floor0 in-left))]
+        [up (inexact->exact (floor0 in-up))]
+        [right (inexact->exact (floor0 in-right))]
+        [down (inexact->exact (floor0 in-down))]
         [img (coerce-to-cache-image-snip raw-img)])
     (let-values ([(i-px i-py) (send img get-pinhole)]
                  [(i-width i-height) (send img get-size)])
@@ -289,16 +296,16 @@ plt/collects/tests/mzscheme/htdp-image.ss
   (check-image 'shrink-tl raw-img "first")
   (check-size 'shrink-tl in-x "second")
   (check-size 'shrink-tl in-y "third")
-  (let ([x (inexact->exact (floor in-x))]
-        [y (inexact->exact (floor in-y))])
+  (let ([x (inexact->exact (floor0 in-x))]
+        [y (inexact->exact (floor0 in-y))])
     (put-pinhole (shrink (put-pinhole raw-img 0 0) 0 0 (- x 1) (- y 1)) (/ x 2) (/ y 2))))
 
 (define (shrink-tr raw-img in-x in-y)
   (check-image 'shrink-tr raw-img "first")
   (check-size 'shrink-tr in-x "second")
   (check-size 'shrink-tr in-y "third")
-  (let ([x (inexact->exact (floor in-x))]
-        [y (inexact->exact (floor in-y))])
+  (let ([x (inexact->exact (floor0 in-x))]
+        [y (inexact->exact (floor0 in-y))])
     (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) 0) (- x 1) 0 0 (- y 1))
                  (/ x 2)
                  (/ y 2))))
@@ -307,8 +314,8 @@ plt/collects/tests/mzscheme/htdp-image.ss
   (check-image 'shrink-bl raw-img "first")
   (check-size 'shrink-bl in-x "second")
   (check-size 'shrink-bl in-y "third")
-  (let ([x (inexact->exact (floor in-x))]
-        [y (inexact->exact (floor in-y))])
+  (let ([x (inexact->exact (floor0 in-x))]
+        [y (inexact->exact (floor0 in-y))])
     (put-pinhole (shrink (put-pinhole raw-img 0 (- (image-height raw-img) 1)) 0 (- y 1) (- x 1) 0) 
                  (/ x 2)
                  (/ y 2))))
@@ -317,8 +324,8 @@ plt/collects/tests/mzscheme/htdp-image.ss
   (check-image 'shrink-br raw-img "first")
   (check-size 'shrink-br in-x "second")
   (check-size 'shrink-br in-y "third")
-  (let ([x (inexact->exact (floor in-x))]
-        [y (inexact->exact (floor in-y))])
+  (let ([x (inexact->exact (floor0 in-x))]
+        [y (inexact->exact (floor0 in-y))])
     (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) (- (image-height raw-img) 1))
                          (- x 1)
                          (- y 1)
diff --git a/collects/html/html-mod.ss b/collects/html/html-mod.ss
new file mode 100644
index 0000000000..5356f9949d
--- /dev/null
+++ b/collects/html/html-mod.ss
@@ -0,0 +1,137 @@
+#lang scheme
+;; copyright by Paul Graunke June 2000 AD
+
+(require mzlib/file
+         mzlib/list
+         mzlib/etc
+         mzlib/include
+         "html-spec.ss"
+         "html-sig.ss"
+         (prefix-in sgml: "sgml-reader.ss")
+         xml)
+
+(provide-signature-elements html^)
+
+;; Html-content = Html-element | Pc-data | Entity   
+
+(include "html-structs.ss")
+(include "case.ss")
+
+;; xml->html : Document -> Html
+(define (xml->html doc)
+  (let ([root (document-element doc)])
+    (unless (eq? 'html (element-name root))
+      (error 'xml->html "This is not an html document.  Expected 'html, given ~a" (element-name root)))
+    (make-html (element-attributes root) (xml-contents->html (element-content root)))))
+
+
+;; xml-content->html : (listof Content) -> (listof Html-element)
+(define (xml-contents->html contents)
+  (foldr xml-single-content->html
+         null
+         contents))
+
+;; read-xhtml : [Input-port] -> Html
+(define read-xhtml (compose xml->html read-xml))
+
+;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content)
+(define (peel-f toss? to-toss acc0)
+  (foldr (lambda (x acc)
+           (if (toss? x)
+               (append (html-full-content x) acc)
+               (cons x acc)))
+         acc0
+         to-toss))
+
+;; repackage-html : (listof Html-content) -> Html
+(define (repackage-html contents)
+  (let* ([html (memf html? contents)]
+         [peeled (peel-f html? contents null)]
+         [body (memf body? peeled)])
+    (make-html (if html
+                   (html-element-attributes (car html))
+                   null)
+               (append (filter head? peeled)
+                       (list (make-body (if body
+                                            (html-element-attributes (car body))
+                                            null)
+                                        (filter (compose not head?) (peel-f body? peeled null))))))))
+
+;; clean-up-pcdata : (listof Content) -> (listof Content)
+;; Each pcdata inside a tag that isn't supposed to contain pcdata is either
+;; a) appended to the end of the previous subelement, if that subelement may contain pcdata
+;; b) prepended to the front of the next subelement, if that subelement may contain pcdata
+;; c) discarded
+;; unknown tags may contain pcdata
+;; the top level may contain pcdata
+(define clean-up-pcdata
+  ;; clean-up-pcdata : (listof Content) -> (listof Content)
+  (letrec ([clean-up-pcdata
+            (lambda (content)
+              (map (lambda (to-fix)
+                     (cond
+                       [(element? to-fix)
+                        (recontent-xml to-fix
+                                       (let ([possible (may-contain (element-name to-fix))]
+                                             [content (element-content to-fix)])
+                                         (if (or (not possible) (memq 'pcdata possible))
+                                             (clean-up-pcdata content)
+                                             (eliminate-pcdata content))))]
+                       [else to-fix]))
+                   content))]
+           [eliminate-pcdata
+            ;: (listof Content) -> (listof Content)
+            (lambda (content)
+              (let ([non-elements (first-non-elements content)]
+                    [more (memf element? content)])
+                (if more
+                    (let* ([el (car more)]
+                           [possible (may-contain (element-name el))])
+                      (if (or (not possible) (memq 'pcdata possible))
+                          (cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more)))))
+                                (or (memf element? (cdr more)) null))
+                          (cons (recontent-xml el (eliminate-pcdata (element-content el)))
+                                (eliminate-pcdata (cdr more)))))
+                    null)))])
+    clean-up-pcdata))
+
+;; first-non-elements : (listof Content) -> (listof Content)
+(define (first-non-elements content)
+  (cond
+    [(null? content) null]
+    [else (if (element? (car content))
+              null
+              (cons (car content) (first-non-elements (cdr content))))]))
+
+;; recontent-xml : Element (listof Content) -> Element
+(define (recontent-xml e c)
+  (make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c))
+
+;; implicit-starts : Symbol Symbol -> (U #f Symbol)
+(define (implicit-starts parent child)
+  (or (and (eq? child 'tr) (eq? parent 'table) 'tbody)
+      (and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr)))
+
+;; may-contain : Kid-lister
+(define may-contain
+  (sgml:gen-may-contain html-spec))
+
+(define may-contain-anything
+  (sgml:gen-may-contain null))
+
+(define use-html-spec (make-parameter #t))
+
+;; read-html-as-xml : [Input-port] -> (listof Content)
+(define read-html-as-xml
+  (case-lambda 
+    [(port)
+     ((if (use-html-spec) clean-up-pcdata values)
+      ((sgml:gen-read-sgml (if (use-html-spec)
+                               may-contain 
+                               may-contain-anything)
+                           implicit-starts) port))]
+    [() (read-html-as-xml (current-input-port))]))
+
+;; read-html : [Input-port] -> Html
+(define read-html
+  (compose repackage-html xml-contents->html read-html-as-xml))
\ No newline at end of file
diff --git a/collects/html/html-sig.ss b/collects/html/html-sig.ss
index d0b57a7e23..600cff884a 100644
--- a/collects/html/html-sig.ss
+++ b/collects/html/html-sig.ss
@@ -1,11 +1,9 @@
 ;; copyright by Paul Graunke June 2000 AD
+#lang scheme
 
-(module html-sig mzscheme
-  (require mzlib/unitsig)
+(define-signature html-structs^ ((struct html-element (attributes)) (struct html-full (content)) (struct html ()) (struct div ()) (struct center ()) (struct blockquote ()) (struct ins ()) (struct del ()) (struct dd ()) (struct li ()) (struct th ()) (struct td ()) (struct iframe ()) (struct noframes ()) (struct noscript ()) (struct style ()) (struct script ()) (struct basefont ()) (struct br ()) (struct area ()) (struct link ()) (struct img ()) (struct param ()) (struct hr ()) (struct input ()) (struct col ()) (struct isindex ()) (struct base ()) (struct meta ()) (struct option ()) (struct textarea ()) (struct title ()) (struct head ()) (struct tr ()) (struct colgroup ()) (struct thead ()) (struct tfoot ()) (struct tbody ()) (struct tt ()) (struct i ()) (struct b ()) (struct u ()) (struct s ()) (struct strike ()) (struct big ()) (struct small ()) (struct em ()) (struct strong ()) (struct dfn ()) (struct code ()) (struct samp ()) (struct kbd ()) (struct var ()) (struct cite ()) (struct abbr ()) (struct acronym ()) (struct sub ()) (struct sup ()) (struct span ()) (struct bdo ()) (struct font ()) (struct p ()) (struct h1 ()) (struct h2 ()) (struct h3 ()) (struct h4 ()) (struct h5 ()) (struct h6 ()) (struct q ()) (struct dt ()) (struct legend ()) (struct caption ()) (struct table ()) (struct button ()) (struct fieldset ()) (struct optgroup ()) (struct select ()) (struct label ()) (struct form ()) (struct ol ()) (struct ul ()) (struct dir ()) (struct menu ()) (struct dl ()) (struct pre ()) (struct object ()) (struct applet ()) (struct -map ()) (struct a ()) (struct address ()) (struct body ())))
 
-  (define-signature html-structs^ ((struct html-element (attributes)) (struct html-full (content)) (struct html ()) (struct div ()) (struct center ()) (struct blockquote ()) (struct ins ()) (struct del ()) (struct dd ()) (struct li ()) (struct th ()) (struct td ()) (struct iframe ()) (struct noframes ()) (struct noscript ()) (struct style ()) (struct script ()) (struct basefont ()) (struct br ()) (struct area ()) (struct link ()) (struct img ()) (struct param ()) (struct hr ()) (struct input ()) (struct col ()) (struct isindex ()) (struct base ()) (struct meta ()) (struct option ()) (struct textarea ()) (struct title ()) (struct head ()) (struct tr ()) (struct colgroup ()) (struct thead ()) (struct tfoot ()) (struct tbody ()) (struct tt ()) (struct i ()) (struct b ()) (struct u ()) (struct s ()) (struct strike ()) (struct big ()) (struct small ()) (struct em ()) (struct strong ()) (struct dfn ()) (struct code ()) (struct samp ()) (struct kbd ()) (struct var ()) (struct cite ()) (struct abbr ()) (struct acronym ()) (struct sub ()) (struct sup ()) (struct span ()) (struct bdo ()) (struct font ()) (struct p ()) (struct h1 ()) (struct h2 ()) (struct h3 ()) (struct h4 ()) (struct h5 ()) (struct h6 ()) (struct q ()) (struct dt ()) (struct legend ()) (struct caption ()) (struct table ()) (struct button ()) (struct fieldset ()) (struct optgroup ()) (struct select ()) (struct label ()) (struct form ()) (struct ol ()) (struct ul ()) (struct dir ()) (struct menu ()) (struct dl ()) (struct pre ()) (struct object ()) (struct applet ()) (struct -map ()) (struct a ()) (struct address ()) (struct body ())))
+(define-signature html^ (read-xhtml read-html read-html-as-xml (open html-structs^)
+                                    use-html-spec))  
 
-  (define-signature html^ (read-xhtml read-html read-html-as-xml (open html-structs^)
-				      use-html-spec))  
-
-  (provide html^))
+(provide html^)
\ No newline at end of file
diff --git a/collects/html/html-unit.ss b/collects/html/html-unit.ss
index ce4927b3dc..ae540f38cb 100644
--- a/collects/html/html-unit.ss
+++ b/collects/html/html-unit.ss
@@ -1,142 +1,141 @@
+#lang scheme
 ;; copyright by Paul Graunke June 2000 AD
 
-(module html-unit mzscheme
-  (require mzlib/unitsig
-	   mzlib/file
-	   mzlib/list
-	   mzlib/etc
-	   mzlib/include
-           "html-spec.ss"
-	   "html-sig.ss"
-	   "sgml-reader-sig.ss"
-	   xml/xml-sig)
+(require mzlib/file
+         mzlib/list
+         mzlib/etc
+         mzlib/include
+         "html-spec.ss"
+         "html-sig.ss"
+         "sgml-reader-sig.ss"
+         xml/private/sig)
 
-  (provide html@)
+(provide html@)
 
-  (define html@
-    (unit/sig html^
-      (import xml^ (sgml : sgml-reader^))
-      
-      ;; Html-content = Html-element | Pc-data | Entity   
-      
-      (include "html-structs.ss")
-      (include "case.ss")
-      
-      ;; xml->html : Document -> Html
-      (define (xml->html doc)
-	(let ([root (document-element doc)])
-	  (unless (eq? 'html (element-name root))
-	    (error 'xml->html "This is not an html document.  Expected 'html, given ~a" (element-name root)))
-	  (make-html (element-attributes root) (xml-contents->html (element-content root)))))
-      
-      
-      ;; xml-content->html : (listof Content) -> (listof Html-element)
-      (define (xml-contents->html contents)
-	(foldr xml-single-content->html
-	       null
-	       contents))
-      
-      ;; read-xhtml : [Input-port] -> Html
-      (define read-xhtml (compose xml->html read-xml))
-      
-      ;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content)
-      (define (peel-f toss? to-toss acc0)
-	(foldr (lambda (x acc)
-		 (if (toss? x)
-		     (append (html-full-content x) acc)
-		     (cons x acc)))
-	       acc0
-	       to-toss))
-      
-      ;; repackage-html : (listof Html-content) -> Html
-      (define (repackage-html contents)
-	(let* ([html (memf html? contents)]
-	       [peeled (peel-f html? contents null)]
-	       [body (memf body? peeled)])
-	  (make-html (if html
-			 (html-element-attributes (car html))
-			 null)
-		     (append (filter head? peeled)
-			     (list (make-body (if body
-						  (html-element-attributes (car body))
-						  null)
-					      (filter (compose not head?) (peel-f body? peeled null))))))))
-      
-      ;; clean-up-pcdata : (listof Content) -> (listof Content)
-      ;; Each pcdata inside a tag that isn't supposed to contain pcdata is either
-      ;; a) appended to the end of the previous subelement, if that subelement may contain pcdata
-      ;; b) prepended to the front of the next subelement, if that subelement may contain pcdata
-      ;; c) discarded
-      ;; unknown tags may contain pcdata
-      ;; the top level may contain pcdata
-      (define clean-up-pcdata
-	;; clean-up-pcdata : (listof Content) -> (listof Content)
-	(letrec ([clean-up-pcdata
-		  (lambda (content)
-		    (map (lambda (to-fix)
-			   (cond
-			    [(element? to-fix)
-			     (recontent-xml to-fix
-					    (let ([possible (may-contain (element-name to-fix))]
-						  [content (element-content to-fix)])
-					      (if (or (not possible) (memq 'pcdata possible))
-						  (clean-up-pcdata content)
-						  (eliminate-pcdata content))))]
-			    [else to-fix]))
-			 content))]
-		 [eliminate-pcdata
-					;: (listof Content) -> (listof Content)
-		  (lambda (content)
-		    (let ([non-elements (first-non-elements content)]
-			  [more (memf element? content)])
-		      (if more
-			  (let* ([el (car more)]
-				 [possible (may-contain (element-name el))])
-			    (if (or (not possible) (memq 'pcdata possible))
-				(cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more)))))
-				      (or (memf element? (cdr more)) null))
-				(cons (recontent-xml el (eliminate-pcdata (element-content el)))
-				      (eliminate-pcdata (cdr more)))))
-			  null)))])
-	  clean-up-pcdata))
-      
-      ;; first-non-elements : (listof Content) -> (listof Content)
-      (define (first-non-elements content)
-	(cond
-	 [(null? content) null]
-	 [else (if (element? (car content))
-		   null
-		   (cons (car content) (first-non-elements (cdr content))))]))
-      
-      ;; recontent-xml : Element (listof Content) -> Element
-      (define (recontent-xml e c)
-	(make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c))
-      
-      ;; implicit-starts : Symbol Symbol -> (U #f Symbol)
-      (define (implicit-starts parent child)
-	(or (and (eq? child 'tr) (eq? parent 'table) 'tbody)
-	    (and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr)))
-      
-      ;; may-contain : Kid-lister
-      (define may-contain
-	(sgml:gen-may-contain html-spec))
-
-      (define may-contain-anything
-	(sgml:gen-may-contain null))
-
-      (define use-html-spec (make-parameter #t))
-      
-      ;; read-html-as-xml : [Input-port] -> (listof Content)
-      (define read-html-as-xml
-	(case-lambda 
-	 [(port)
-	  ((if (use-html-spec) clean-up-pcdata values)
-	   ((sgml:gen-read-sgml (if (use-html-spec)
-				    may-contain 
-				    may-contain-anything)
-				implicit-starts) port))]
-	 [() (read-html-as-xml (current-input-port))]))
-      
-      ;; read-html : [Input-port] -> Html
-      (define read-html
-	(compose repackage-html xml-contents->html read-html-as-xml)))))
+(define-unit html@
+  (import xml-structs^ reader^ (prefix sgml: sgml-reader^))
+  (export html^)
+  
+  ;; Html-content = Html-element | Pc-data | Entity   
+  
+  (include "html-structs.ss")
+  (include "case.ss")
+  
+  ;; xml->html : Document -> Html
+  (define (xml->html doc)
+    (let ([root (document-element doc)])
+      (unless (eq? 'html (element-name root))
+        (error 'xml->html "This is not an html document.  Expected 'html, given ~a" (element-name root)))
+      (make-html (element-attributes root) (xml-contents->html (element-content root)))))
+  
+  
+  ;; xml-content->html : (listof Content) -> (listof Html-element)
+  (define (xml-contents->html contents)
+    (foldr xml-single-content->html
+           null
+           contents))
+  
+  ;; read-xhtml : [Input-port] -> Html
+  (define read-xhtml (compose xml->html read-xml))
+  
+  ;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content)
+  (define (peel-f toss? to-toss acc0)
+    (foldr (lambda (x acc)
+             (if (toss? x)
+                 (append (html-full-content x) acc)
+                 (cons x acc)))
+           acc0
+           to-toss))
+  
+  ;; repackage-html : (listof Html-content) -> Html
+  (define (repackage-html contents)
+    (let* ([html (memf html? contents)]
+           [peeled (peel-f html? contents null)]
+           [body (memf body? peeled)])
+      (make-html (if html
+                     (html-element-attributes (car html))
+                     null)
+                 (append (filter head? peeled)
+                         (list (make-body (if body
+                                              (html-element-attributes (car body))
+                                              null)
+                                          (filter (compose not head?) (peel-f body? peeled null))))))))
+  
+  ;; clean-up-pcdata : (listof Content) -> (listof Content)
+  ;; Each pcdata inside a tag that isn't supposed to contain pcdata is either
+  ;; a) appended to the end of the previous subelement, if that subelement may contain pcdata
+  ;; b) prepended to the front of the next subelement, if that subelement may contain pcdata
+  ;; c) discarded
+  ;; unknown tags may contain pcdata
+  ;; the top level may contain pcdata
+  (define clean-up-pcdata
+    ;; clean-up-pcdata : (listof Content) -> (listof Content)
+    (letrec ([clean-up-pcdata
+              (lambda (content)
+                (map (lambda (to-fix)
+                       (cond
+                         [(element? to-fix)
+                          (recontent-xml to-fix
+                                         (let ([possible (may-contain (element-name to-fix))]
+                                               [content (element-content to-fix)])
+                                           (if (or (not possible) (memq 'pcdata possible))
+                                               (clean-up-pcdata content)
+                                               (eliminate-pcdata content))))]
+                         [else to-fix]))
+                     content))]
+             [eliminate-pcdata
+              ;: (listof Content) -> (listof Content)
+              (lambda (content)
+                (let ([non-elements (first-non-elements content)]
+                      [more (memf element? content)])
+                  (if more
+                      (let* ([el (car more)]
+                             [possible (may-contain (element-name el))])
+                        (if (or (not possible) (memq 'pcdata possible))
+                            (cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more)))))
+                                  (or (memf element? (cdr more)) null))
+                            (cons (recontent-xml el (eliminate-pcdata (element-content el)))
+                                  (eliminate-pcdata (cdr more)))))
+                      null)))])
+      clean-up-pcdata))
+  
+  ;; first-non-elements : (listof Content) -> (listof Content)
+  (define (first-non-elements content)
+    (cond
+      [(null? content) null]
+      [else (if (element? (car content))
+                null
+                (cons (car content) (first-non-elements (cdr content))))]))
+  
+  ;; recontent-xml : Element (listof Content) -> Element
+  (define (recontent-xml e c)
+    (make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c))
+  
+  ;; implicit-starts : Symbol Symbol -> (U #f Symbol)
+  (define (implicit-starts parent child)
+    (or (and (eq? child 'tr) (eq? parent 'table) 'tbody)
+        (and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr)))
+  
+  ;; may-contain : Kid-lister
+  (define may-contain
+    (sgml:gen-may-contain html-spec))
+  
+  (define may-contain-anything
+    (sgml:gen-may-contain null))
+  
+  (define use-html-spec (make-parameter #t))
+  
+  ;; read-html-as-xml : [Input-port] -> (listof Content)
+  (define read-html-as-xml
+    (case-lambda 
+      [(port)
+       ((if (use-html-spec) clean-up-pcdata values)
+        ((sgml:gen-read-sgml (if (use-html-spec)
+                                 may-contain 
+                                 may-contain-anything)
+                             implicit-starts) port))]
+      [() (read-html-as-xml (current-input-port))]))
+  
+  ;; read-html : [Input-port] -> Html
+  (define read-html
+    (compose repackage-html xml-contents->html read-html-as-xml)))
diff --git a/collects/html/html.scrbl b/collects/html/html.scrbl
index 9b7564591b..6dc7c7b514 100644
--- a/collects/html/html.scrbl
+++ b/collects/html/html.scrbl
@@ -78,7 +78,7 @@ Reads HTML from a port, producing an @xexpr compatible with the
   (code:comment #, @t{Pulls out the pcdata strings from an-html-element.})
   (define (extract-pcdata-from-element an-html-element)
     (match an-html-element
-      [(struct h:html-full (content))
+      [(struct h:html-full (attributes content))
        (apply append (map extract-pcdata content))]
       
       [(struct h:html-element (attributes))
diff --git a/collects/html/html.ss b/collects/html/html.ss
index de547502d4..381e05f8f7 100644
--- a/collects/html/html.ss
+++ b/collects/html/html.ss
@@ -1,30 +1,22 @@
+#lang scheme
 ;; copyright by Paul Graunke June 2000 AD
 
-(module html mzscheme
-  (require mzlib/unitsig
-	   "html-sig.ss" 
-	   "html-unit.ss"
-	   "sgml-reader-sig.ss"
-	   "sgml-reader-unit.ss"
-	   xml/xml
-	   xml/xml-sig
-	   xml/private/sig
-	   xml/xml-unit)
+(require "html-mod.ss" "html-sig.ss" "sgml-reader.ss")
 
-  ;; To get read-comments from sgml-reader, we have to
-  ;;  avoid the read-comments from XML, so we rename it
-  ;;  to read-html-comments.
+#;(require "html-sig.ss" 
+         "html-unit.ss"
+         "sgml-reader-sig.ss"
+         "sgml-reader-unit.ss"
+         xml/private/structures
+         xml/private/reader
+         xml/private/sig)
 
-  (define-values/invoke-unit/sig
-    ((open html^) read-html-comments)
-    (compound-unit/sig
-     (import [x : xml^])
-     (link
-      [s : sgml-reader^ (sgml-reader@ (x : xml-structs^))]
-      [h : html^ (html@ x s)])
-     (export (open h) (var (s read-comments) read-html-comments)))
-    #f
-    xml^)
+#;(define-compound-unit/infer the-html@
+  (import)
+  (export html^ sgml-reader^)
+  (link html@ sgml-reader@ xml-structs@ reader@))
 
-  (provide-signature-elements html^)
-  (provide read-html-comments))
+#;(define-values/invoke-unit/infer the-html@)
+
+(provide-signature-elements html^)
+(provide read-html-comments)
diff --git a/collects/html/sgml-reader-sig.ss b/collects/html/sgml-reader-sig.ss
index 9ac150c2ac..3454b2ea4e 100644
--- a/collects/html/sgml-reader-sig.ss
+++ b/collects/html/sgml-reader-sig.ss
@@ -1,8 +1,6 @@
 ;; copyright by Paul Graunke June 2000 AD
+#lang scheme
 
-(module sgml-reader-sig mzscheme
-  (require mzlib/unitsig)
+(define-signature sgml-reader^ (read-html-comments trim-whitespace gen-may-contain gen-read-sgml))
 
-  (define-signature sgml-reader^ (read-comments trim-whitespace gen-may-contain gen-read-sgml))
-  
-  (provide sgml-reader^))
+(provide sgml-reader^)
diff --git a/collects/html/sgml-reader-unit.ss b/collects/html/sgml-reader-unit.ss
index 30be92f0b7..ee8403d257 100644
--- a/collects/html/sgml-reader-unit.ss
+++ b/collects/html/sgml-reader-unit.ss
@@ -1,296 +1,294 @@
 ;; copyright by Paul Graunke June 2000 AD
 ;; warning - this was copied from the XML collection.
 ;; It needs to be abstracted back in.
+#lang scheme
+(require mzlib/list
+         mzlib/string
+         "sgml-reader-sig.ss"
+         xml/private/sig)
 
-(module sgml-reader-unit mzscheme
-  (require mzlib/unitsig
-	   mzlib/list
-	   mzlib/string
-	   "sgml-reader-sig.ss"
-	   xml/private/sig)
+(provide sgml-reader@)
 
-  (provide sgml-reader@)
-
-  (define sgml-reader@
-    (unit/sig sgml-reader^
-      (import xml-structs^)
-      
-      ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
-      (define-struct (start-tag source) (name attrs))
-      
-      ;; End-tag ::= (make-end-tag Location Location Symbol)
-      (define-struct (end-tag source) (name))
-      
-      ;; Token ::= Contents | Start-tag | End-tag | Eof
-      
-      (define read-comments (make-parameter #f))
-      (define trim-whitespace (make-parameter #f))
-      
-      ;; Kid-lister : (Symbol -> (U (listof Symbol) #f))
-      
-      ;; gen-may-contain : Spec -> Kid-lister
-      (define (gen-may-contain spec)
-	(let ([table (make-hash-table)])
-	  (for-each (lambda (def)
-		      (let ([rhs (cdr def)])
-			(for-each (lambda (name) (hash-table-put! table name rhs))
-				  (car def))))
-		    spec)
-	  (lambda (name)
-	    (hash-table-get table name (lambda () #f)))))
-      
-      ;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content)
-      (define (gen-read-sgml may-contain auto-insert)
-	(case-lambda
-	 [(in) (read-from-port may-contain auto-insert in)]
-	 [() (read-from-port may-contain auto-insert (current-input-port))]))
-      
-      ;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content)
-      (define (read-from-port may-contain auto-insert in)
-	(let loop ([tokens (let read-tokens ()
-			     (let ([tok (lex in)])
-			       (cond
-				[(eof-object? tok) null]
-				[else (cons tok (read-tokens))])))])
-	  (cond
-	   [(null? tokens) null]
-	   [else
-	    (let ([tok (car tokens)] [rest-tokens (cdr tokens)])
-	      (cond
-	       [(start-tag? tok)
-		(let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)])
-		  (cons el (loop more-tokens)))]
-	       [(end-tag? tok) (loop rest-tokens)]
-	       [else (let ([rest-contents (loop rest-tokens)])
-		       (expand-content tok rest-contents))]))])))
-      
-      ;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token)
-      ;; Note: How elements nest depends on their content model.
-      ;;   If a kind of element can't contain anything, then its start tags are implicitly ended, and
-      ;;   end tags are implicitly started.
-      ;;   Unknown elements can contain anything and can go inside anything.
-      ;;   Otherwise, only the subelements listed in the content model can go inside an element.
-      ;; more here - may-contain shouldn't be used to decide if an element is known or not.
-      ;;             The edgar dtd puts tags in may-contain's range that aren't in its domain.
-      ;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the
-      ;;                      tag nesting depth.  However, this only should be a problem when the tag is there,
-      ;;                      but far back.  That shouldn't happen often.  I'm guessing n will be about 3.
-      (define (read-element start-tag context may-contain auto-insert tokens)
-	(let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens])
-	  (let* ([start-name (start-tag-name start-tag)]
-		 [ok-kids (may-contain start-name)])
-	    (let-values ([(content remaining)
-			  (cond
-			   [(null? ok-kids) (values null tokens)]
-			   [else 
-			    ;; read-content : (listof Token) -> (listof Content) (listof Token)
-			    (let read-content ([tokens tokens])
-			      (cond
-			       [(null? tokens) (values null tokens)]
-			       [else
-				(let ([tok (car tokens)] [next-tokens (cdr tokens)])
-				  (cond
-				   [(start-tag? tok)
-				    (let* ([name (start-tag-name tok)]
-					   [auto-start (auto-insert start-name name)])
-				      (if auto-start
-					  (read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens))
-					  (if (and ok-kids
-						   (not (memq name ok-kids))
-						   (may-contain name))
-					      (values null tokens)
-					      (let*-values ([(element post-element)
-							     (read-el tok (cons name context) next-tokens)]
-							    [(more-contents left-overs) (read-content post-element)])
-						(values (cons element more-contents) left-overs)))))]
-				   [(end-tag? tok)
-				    (let ([name (end-tag-name tok)])
-				      (if (eq? name start-name)
-					  (values null next-tokens)
-					  (if (memq name context)
-					      (values null tokens)
-					      (read-content next-tokens))))]
-				   [else ;; content
-				    (let-values ([(more-contents left-overs) (read-content next-tokens)])
-				      (values
-				       (expand-content tok more-contents)
-				       left-overs))]))]))])])
-	      (values (make-element (source-start start-tag)
-				    (source-stop start-tag)
-				    start-name
-				    (start-tag-attrs start-tag)
-				    content)
-		      remaining)))))
-      
-      ;; expand-content : Content (listof Content) -> (listof Content)
-      (define (expand-content x lst)
-	(cond
-	 [(entity? x) (cons (expand-entity x) lst)]
-	 [(comment? x) (if (read-comments)
-			   (cons x lst)
-			   lst)]
-	 [else (cons x lst)]))
-      
-      ;; expand-entity : Entity -> (U Entity Pcdata)
-      ;; more here - allow expansion of user defined entities
-      (define (expand-entity x)
-	(let ([expanded (default-entity-table (entity-text x))])
-	  (if expanded
-	      (make-pcdata (source-start x) (source-stop x) expanded)
-	      x)))
-      
-      ;; default-entity-table : Symbol -> (U #f String)
-      (define (default-entity-table name)
-	(case name
-	  [(amp) "&"]
-	  [(lt) "<"]
-	  [(gt) ">"]
-	  [(quot) "\""]
-	  [(apos) "'"]
-	  [else #f]))
-      
-      ;; lex : Input-port -> Token
-      (define (lex in)
-	(when (trim-whitespace)
-	  (skip-space in))
-	(let ([c (peek-char in)])
-	  (cond
-	   [(eof-object? c) c]
-	   [(eq? c #\&) (lex-entity in)]
-	   [(eq? c #\<) (lex-tag-cdata-pi-comment in)]
-	   [else (lex-pcdata in)])))
-      
-      ;; lex-entity : Input-port -> Token
-      ;; This might not return an entity if it doesn't look like one afterall.
-      (define (lex-entity in)
-	(let ([start (file-position in)])
-	  (read-char in)
-	  (case (peek-char in)
-	    ;; more here - read while it's numeric (or hex) not until #\;
-	    [(#\#)
-	     (read-char in)
-	     (let* ([hex? (if (equal? #\x (peek-char in))
-			      (and (read-char in) #t)
-			      #f)]
-		    [str (read-until #\; in)]
-		    [n (cond
-			[hex?
-			 (string->number str 16)]
-			[else (string->number str)])])
-	       (if (number? n)
-		   (make-entity start (file-position in) n)
-		   (make-pcdata start (file-position in) (string-append "&#" str))))]
-	    [else
-	     (let ([name (lex-name/case-sensitive in)]
-		   [c (peek-char in)])
-	       (if (eq? c #\;)
-		   (begin (read-char in) (make-entity start (file-position in) name))
-		   (make-pcdata start (file-position in) (format "&~a" name))))])))
-      
-      ;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
-      (define (lex-tag-cdata-pi-comment in)
-	(let ([start (file-position in)])
-	  (read-char in)
-	  (case (peek-char in)
-	    [(#\!)
-	     (read-char in)
-	     (case (peek-char in)
-	       [(#\-) (read-char in)
-		(let ([c (read-char in)])
-		  (cond
-		   [(eq? c #\-)
-		    (let ([data (lex-comment-contents in)])
-		      (make-comment data))]
-		   [else (make-pcdata start (file-position in) (format "<!-~a" c))]))]
-	       [(#\[) (read-char in)
-		(let ([s (read-string 6 in)])
-		  (if (string=? s "CDATA[")
-		      (let ([data (lex-cdata-contents in)])
-			(make-pcdata start (file-position in) data))
-		      (make-pcdata start (file-position in) (format "<[~a" s))))]
-	       [else (skip-dtd in) (lex in)])]
-	    [(#\?) (read-char in)
-	     (let ([name (lex-name in)])
-	       (skip-space in)
-	       (let ([data (lex-pi-data in)])
-		 (make-pi start (file-position in) name data)))]
-	    [(#\/) (read-char in)
-	     (let ([name (lex-name in)])
-	       (skip-space in)
-	       (read-char in) ;; skip #\> or whatever else is there
-	       (make-end-tag start (file-position in) name))]
-	    [else
-	     (let ([name (lex-name in)]
-		   [attrs (lex-attributes in)])
-	       (skip-space in)
-	       (case (read-char in)
-		 [(#\/)
-		  (read-char in) ;; skip #\> or something
-		  (make-element start (file-position in) name attrs null)]
-		 [else (make-start-tag start (file-position in) name attrs)]))])))
-
-
-      ;; lex-attributes : Input-port -> (listof Attribute)
-      (define (lex-attributes in)
-	(sort (let loop ()
-                (skip-space in)
-                (cond [(name-start? (peek-char in))
-		       (cons (lex-attribute in) (loop))]
-		      [else null]))
-              (lambda (a b)
-                (string<? (symbol->string (attribute-name a))
-                          (symbol->string (attribute-name b))))))
-
-      ;; lex-attribute : Input-port -> Attribute
-      ;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax
-      (define (lex-attribute in)
-	(let ([start (file-position in)]
-	      [name (lex-name in)])
-	  (skip-space in)
-	  (cond
-	   [(eq? (peek-char in) #\=)
-	    (read-char in)
-	    (skip-space in)
-	    (let* ([delimiter (read-char in)]
-		   [value (list->string
-			   (case delimiter
-			     [(#\' #\")
-			      (let read-more ()
-				(let ([c (read-char in)])
-				  (cond
-				   [(or (eq? c delimiter) (eof-object? c)) null]
-				   [else (cons c (read-more))])))]
-			     [else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))])
-	      (make-attribute start (file-position in) name value))]
-	   [else (make-attribute start (file-position in) name (symbol->string name))])))
-      
-      ;; skip-space : Input-port -> Void
-      ;; deviation - should sometimes insist on at least one space
-      (define (skip-space in)
-	(let loop ()
-	  (let ([c (peek-char in)])
-	    (when (and (not (eof-object? c)) (char-whitespace? c))
-	      (read-char in)
-	      (loop)))))
-
-      ;; lex-pcdata : Input-port -> Pcdata
-      ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec 
-      (define (lex-pcdata in)
-	(let ([start (file-position in)])
-	  ;; The following regexp match must use bytes, not chars, because
-	  ;; `in' might not be a well-formed UTF-8 sequence. If it isn't,
-	  ;; and it goes wrong with the first byte sequence, then a char-based
-	  ;; pattern would match 0 characters. Meanwhile, the caller of this function
-	  ;; expects characters to be read.
-	  (let ([s (regexp-match #rx#"^[^&<]*" in)])
-	    (make-pcdata start
-			 (file-position in)
-			 (bytes->string/utf-8
-			  (if (trim-whitespace)
-			      (regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"")
-			      (car s))
-			  #\?)))))
-#|
+(define-unit sgml-reader@
+  (import xml-structs^)
+  (export sgml-reader^)
+  
+  ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
+  (define-struct (start-tag source) (name attrs))
+  
+  ;; End-tag ::= (make-end-tag Location Location Symbol)
+  (define-struct (end-tag source) (name))
+  
+  ;; Token ::= Contents | Start-tag | End-tag | Eof
+  
+  (define read-html-comments (make-parameter #f))
+  (define trim-whitespace (make-parameter #f))
+  
+  ;; Kid-lister : (Symbol -> (U (listof Symbol) #f))
+  
+  ;; gen-may-contain : Spec -> Kid-lister
+  (define (gen-may-contain spec)
+    (let ([table (make-hash)])
+      (for-each (lambda (def)
+                  (let ([rhs (cdr def)])
+                    (for-each (lambda (name) (hash-set! table name rhs))
+                              (car def))))
+                spec)
+      (lambda (name)
+        (hash-ref table name (lambda () #f)))))
+  
+  ;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content)
+  (define (gen-read-sgml may-contain auto-insert)
+    (case-lambda
+      [(in) (read-from-port may-contain auto-insert in)]
+      [() (read-from-port may-contain auto-insert (current-input-port))]))
+  
+  ;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content)
+  (define (read-from-port may-contain auto-insert in)
+    (let loop ([tokens (let read-tokens ()
+                         (let ([tok (lex in)])
+                           (cond
+                             [(eof-object? tok) null]
+                             [else (cons tok (read-tokens))])))])
+      (cond
+        [(null? tokens) null]
+        [else
+         (let ([tok (car tokens)] [rest-tokens (cdr tokens)])
+           (cond
+             [(start-tag? tok)
+              (let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)])
+                (cons el (loop more-tokens)))]
+             [(end-tag? tok) (loop rest-tokens)]
+             [else (let ([rest-contents (loop rest-tokens)])
+                     (expand-content tok rest-contents))]))])))
+  
+  ;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token)
+  ;; Note: How elements nest depends on their content model.
+  ;;   If a kind of element can't contain anything, then its start tags are implicitly ended, and
+  ;;   end tags are implicitly started.
+  ;;   Unknown elements can contain anything and can go inside anything.
+  ;;   Otherwise, only the subelements listed in the content model can go inside an element.
+  ;; more here - may-contain shouldn't be used to decide if an element is known or not.
+  ;;             The edgar dtd puts tags in may-contain's range that aren't in its domain.
+  ;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the
+  ;;                      tag nesting depth.  However, this only should be a problem when the tag is there,
+  ;;                      but far back.  That shouldn't happen often.  I'm guessing n will be about 3.
+  (define (read-element start-tag context may-contain auto-insert tokens)
+    (let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens])
+      (let* ([start-name (start-tag-name start-tag)]
+             [ok-kids (may-contain start-name)])
+        (let-values ([(content remaining)
+                      (cond
+                        [(null? ok-kids) (values null tokens)]
+                        [else 
+                         ;; read-content : (listof Token) -> (listof Content) (listof Token)
+                         (let read-content ([tokens tokens])
+                           (cond
+                             [(null? tokens) (values null tokens)]
+                             [else
+                              (let ([tok (car tokens)] [next-tokens (cdr tokens)])
+                                (cond
+                                  [(start-tag? tok)
+                                   (let* ([name (start-tag-name tok)]
+                                          [auto-start (auto-insert start-name name)])
+                                     (if auto-start
+                                         (read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens))
+                                         (if (and ok-kids
+                                                  (not (memq name ok-kids))
+                                                  (may-contain name))
+                                             (values null tokens)
+                                             (let*-values ([(element post-element)
+                                                            (read-el tok (cons name context) next-tokens)]
+                                                           [(more-contents left-overs) (read-content post-element)])
+                                               (values (cons element more-contents) left-overs)))))]
+                                  [(end-tag? tok)
+                                   (let ([name (end-tag-name tok)])
+                                     (if (eq? name start-name)
+                                         (values null next-tokens)
+                                         (if (memq name context)
+                                             (values null tokens)
+                                             (read-content next-tokens))))]
+                                  [else ;; content
+                                   (let-values ([(more-contents left-overs) (read-content next-tokens)])
+                                     (values
+                                      (expand-content tok more-contents)
+                                      left-overs))]))]))])])
+          (values (make-element (source-start start-tag)
+                                (source-stop start-tag)
+                                start-name
+                                (start-tag-attrs start-tag)
+                                content)
+                  remaining)))))
+  
+  ;; expand-content : Content (listof Content) -> (listof Content)
+  (define (expand-content x lst)
+    (cond
+      [(entity? x) (cons (expand-entity x) lst)]
+      [(comment? x) (if (read-html-comments)
+                        (cons x lst)
+                        lst)]
+      [else (cons x lst)]))
+  
+  ;; expand-entity : Entity -> (U Entity Pcdata)
+  ;; more here - allow expansion of user defined entities
+  (define (expand-entity x)
+    (let ([expanded (default-entity-table (entity-text x))])
+      (if expanded
+          (make-pcdata (source-start x) (source-stop x) expanded)
+          x)))
+  
+  ;; default-entity-table : Symbol -> (U #f String)
+  (define (default-entity-table name)
+    (case name
+      [(amp) "&"]
+      [(lt) "<"]
+      [(gt) ">"]
+      [(quot) "\""]
+      [(apos) "'"]
+      [else #f]))
+  
+  ;; lex : Input-port -> Token
+  (define (lex in)
+    (when (trim-whitespace)
+      (skip-space in))
+    (let ([c (peek-char in)])
+      (cond
+        [(eof-object? c) c]
+        [(eq? c #\&) (lex-entity in)]
+        [(eq? c #\<) (lex-tag-cdata-pi-comment in)]
+        [else (lex-pcdata in)])))
+  
+  ;; lex-entity : Input-port -> Token
+  ;; This might not return an entity if it doesn't look like one afterall.
+  (define (lex-entity in)
+    (let ([start (file-position in)])
+      (read-char in)
+      (case (peek-char in)
+        ;; more here - read while it's numeric (or hex) not until #\;
+        [(#\#)
+         (read-char in)
+         (let* ([hex? (if (equal? #\x (peek-char in))
+                          (and (read-char in) #t)
+                          #f)]
+                [str (read-until #\; in)]
+                [n (cond
+                     [hex?
+                      (string->number str 16)]
+                     [else (string->number str)])])
+           (if (number? n)
+               (make-entity start (file-position in) n)
+               (make-pcdata start (file-position in) (string-append "&#" str))))]
+        [else
+         (let ([name (lex-name/case-sensitive in)]
+               [c (peek-char in)])
+           (if (eq? c #\;)
+               (begin (read-char in) (make-entity start (file-position in) name))
+               (make-pcdata start (file-position in) (format "&~a" name))))])))
+  
+  ;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
+  (define (lex-tag-cdata-pi-comment in)
+    (let ([start (file-position in)])
+      (read-char in)
+      (case (peek-char in)
+        [(#\!)
+         (read-char in)
+         (case (peek-char in)
+           [(#\-) (read-char in)
+                  (let ([c (read-char in)])
+                    (cond
+                      [(eq? c #\-)
+                       (let ([data (lex-comment-contents in)])
+                         (make-comment data))]
+                      [else (make-pcdata start (file-position in) (format "<!-~a" c))]))]
+           [(#\[) (read-char in)
+                  (let ([s (read-string 6 in)])
+                    (if (string=? s "CDATA[")
+                        (let ([data (lex-cdata-contents in)])
+                          (make-pcdata start (file-position in) data))
+                        (make-pcdata start (file-position in) (format "<[~a" s))))]
+           [else (skip-dtd in) (lex in)])]
+        [(#\?) (read-char in)
+               (let ([name (lex-name in)])
+                 (skip-space in)
+                 (let ([data (lex-pi-data in)])
+                   (make-pi start (file-position in) name data)))]
+        [(#\/) (read-char in)
+               (let ([name (lex-name in)])
+                 (skip-space in)
+                 (read-char in) ;; skip #\> or whatever else is there
+                 (make-end-tag start (file-position in) name))]
+        [else
+         (let ([name (lex-name in)]
+               [attrs (lex-attributes in)])
+           (skip-space in)
+           (case (read-char in)
+             [(#\/)
+              (read-char in) ;; skip #\> or something
+              (make-element start (file-position in) name attrs null)]
+             [else (make-start-tag start (file-position in) name attrs)]))])))
+  
+  
+  ;; lex-attributes : Input-port -> (listof Attribute)
+  (define (lex-attributes in)
+    (sort (let loop ()
+            (skip-space in)
+            (cond [(name-start? (peek-char in))
+                   (cons (lex-attribute in) (loop))]
+                  [else null]))
+          (lambda (a b)
+            (string<? (symbol->string (attribute-name a))
+                      (symbol->string (attribute-name b))))))
+  
+  ;; lex-attribute : Input-port -> Attribute
+  ;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax
+  (define (lex-attribute in)
+    (let ([start (file-position in)]
+          [name (lex-name in)])
+      (skip-space in)
+      (cond
+        [(eq? (peek-char in) #\=)
+         (read-char in)
+         (skip-space in)
+         (let* ([delimiter (read-char in)]
+                [value (list->string
+                        (case delimiter
+                          [(#\' #\")
+                           (let read-more ()
+                             (let ([c (read-char in)])
+                               (cond
+                                 [(or (eq? c delimiter) (eof-object? c)) null]
+                                 [else (cons c (read-more))])))]
+                          [else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))])
+           (make-attribute start (file-position in) name value))]
+        [else (make-attribute start (file-position in) name (symbol->string name))])))
+  
+  ;; skip-space : Input-port -> Void
+  ;; deviation - should sometimes insist on at least one space
+  (define (skip-space in)
+    (let loop ()
+      (let ([c (peek-char in)])
+        (when (and (not (eof-object? c)) (char-whitespace? c))
+          (read-char in)
+          (loop)))))
+  
+  ;; lex-pcdata : Input-port -> Pcdata
+  ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec 
+  (define (lex-pcdata in)
+    (let ([start (file-position in)])
+      ;; The following regexp match must use bytes, not chars, because
+      ;; `in' might not be a well-formed UTF-8 sequence. If it isn't,
+      ;; and it goes wrong with the first byte sequence, then a char-based
+      ;; pattern would match 0 characters. Meanwhile, the caller of this function
+      ;; expects characters to be read.
+      (let ([s (regexp-match #rx#"^[^&<]*" in)])
+        (make-pcdata start
+                     (file-position in)
+                     (bytes->string/utf-8
+                      (if (trim-whitespace)
+                          (regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"")
+                          (car s))
+                      #\?)))))
+  #|
       ;; Original slow version:
       (define (lex-pcdata in)
 	(let ([start (file-position in)]
@@ -311,22 +309,22 @@
 		       (list->string data))))
   |#
   
-
-      ;; lex-name : Input-port -> Symbol
-      (define (lex-name in)
-	(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
-	  (string->symbol
-	   ;; Common case: string is already lowercased
-	   (if (regexp-match-positions #rx"[A-Z]" s)
-	       (begin
-		 (string-lowercase! s)
-		 s)
-	       s))))
-      ;; lex-name/case-sensitive : Input-port -> Symbol
-      (define (lex-name/case-sensitive in)
-	(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
-	  (string->symbol s)))
-#|
+  
+  ;; lex-name : Input-port -> Symbol
+  (define (lex-name in)
+    (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
+      (string->symbol
+       ;; Common case: string is already lowercased
+       (if (regexp-match-positions #rx"[A-Z]" s)
+           (begin
+             (string-lowercase! s)
+             s)
+           s))))
+  ;; lex-name/case-sensitive : Input-port -> Symbol
+  (define (lex-name/case-sensitive in)
+    (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
+      (string->symbol s)))
+  #|
       (define (lex-name in)
         (string->symbol
          (list->string
@@ -336,101 +334,100 @@
               (cons (char-downcase (read-char in)) (lex-rest))]
              [else null])))))
 |#
-
-    
-      ;; skip-dtd : Input-port -> Void
-      (define (skip-dtd in)
-	(let skip ()
-	  (let ([c (read-char in)])
-	    (if (eof-object? c)
-		(void)
-		(case c
-		  [(#\') (read-until #\' in) (skip)]
-		  [(#\") (read-until #\" in) (skip)]
-		  [(#\<)
-		   (case (read-char in)
-		     [(#\!) (case (read-char in)
-			      [(#\-) (read-char in) (lex-comment-contents in) (skip)]
-			      [else (skip) (skip)])]
-		     [(#\?) (lex-pi-data in) (skip)]
-		     [else (skip) (skip)])]
-		  [(#\>) (void)]
-		  [else (skip)])))))
-      
-      ;; name-start? : TST -> Bool
-      (define (name-start? ch)
-	(and (char? ch) (char-name-start? ch)))
-      
-      ;; char-name-start? : Char -> Bool
-      (define (char-name-start? ch)
-	(or (char-alphabetic? ch) 
-	    (eq? ch #\_)
-	    (eq? ch #\:)))
-      
-      ;; name-char? : TST -> Bool
-      (define (name-char? ch)
-	(and (char? ch)
-	     (or (char-name-start? ch)
-		 (char-numeric? ch)
-		 (eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database
-		 (eq? ch #\.)
-		 (eq? ch #\-))))
-      
-      ;; read-up-to : (Char -> Bool) Input-port -> (listof Char)
-      ;; abstract this with read-until
-      (define (read-up-to p? in)
-	(let loop ()
-	  (let ([c (peek-char in)])
-	    (cond
-	     [(or (eof-object? c) (p? c)) null]
-	     [else (cons (read-char in) (loop))]))))
-      
-      ;; read-until : Char Input-port -> String
-      ;; discards the stop character, too
-      (define (read-until char in)
-	(list->string
-	 (let read-more ()
-	   (let ([c (read-char in)])
-	     (cond
-	      [(or (eof-object? c) (eq? c char)) null]
-	      [else (cons c (read-more))])))))
-      
-      ;; gen-read-until-string : String -> Input-port -> String
-      ;; uses Knuth-Morris-Pratt from
-      ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
-      ;; discards stop from input
-      (define (gen-read-until-string stop)
-	(let* ([len (string-length stop)]
-	       [prefix (make-vector len 0)]
-	       [fall-back
-		(lambda (k c)
-		  (let ([k (let loop ([k k])
-			     (cond
-			      [(and (> k 0) (not (eq? (string-ref stop k) c)))
-			       (loop (vector-ref prefix (sub1 k)))]
-			      [else k]))])
-		    (if (eq? (string-ref stop k) c)
-			(add1 k)
-			k)))])
-	  (let init ([k 0] [q 1])
-	    (when (< q len)
-	      (let ([k (fall-back k (string-ref stop q))])
-		(vector-set! prefix q k)
-		(init k (add1 q)))))
-	  ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
-	  (lambda (in)
-	    (list->string
-	     (let/ec out
-	       (let loop ([matched 0] [out out])
-		 (let* ([c (read-char in)]
-			[matched (fall-back matched c)])
-		   (cond
-		    [(or (eof-object? c) (= matched len)) (out null)]
-		    [(zero? matched) (cons c (let/ec out (loop matched out)))]
-		    [else (cons c (loop matched out))]))))))))
-      
-      ;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore.
-      (define lex-comment-contents (gen-read-until-string "-->"))
-      (define lex-pi-data (gen-read-until-string "?>"))
-      (define lex-cdata-contents (gen-read-until-string "]]>")))))
-
+  
+  
+  ;; skip-dtd : Input-port -> Void
+  (define (skip-dtd in)
+    (let skip ()
+      (let ([c (read-char in)])
+        (if (eof-object? c)
+            (void)
+            (case c
+              [(#\') (read-until #\' in) (skip)]
+              [(#\") (read-until #\" in) (skip)]
+              [(#\<)
+               (case (read-char in)
+                 [(#\!) (case (read-char in)
+                          [(#\-) (read-char in) (lex-comment-contents in) (skip)]
+                          [else (skip) (skip)])]
+                 [(#\?) (lex-pi-data in) (skip)]
+                 [else (skip) (skip)])]
+              [(#\>) (void)]
+              [else (skip)])))))
+  
+  ;; name-start? : TST -> Bool
+  (define (name-start? ch)
+    (and (char? ch) (char-name-start? ch)))
+  
+  ;; char-name-start? : Char -> Bool
+  (define (char-name-start? ch)
+    (or (char-alphabetic? ch) 
+        (eq? ch #\_)
+        (eq? ch #\:)))
+  
+  ;; name-char? : TST -> Bool
+  (define (name-char? ch)
+    (and (char? ch)
+         (or (char-name-start? ch)
+             (char-numeric? ch)
+             (eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database
+             (eq? ch #\.)
+             (eq? ch #\-))))
+  
+  ;; read-up-to : (Char -> Bool) Input-port -> (listof Char)
+  ;; abstract this with read-until
+  (define (read-up-to p? in)
+    (let loop ()
+      (let ([c (peek-char in)])
+        (cond
+          [(or (eof-object? c) (p? c)) null]
+          [else (cons (read-char in) (loop))]))))
+  
+  ;; read-until : Char Input-port -> String
+  ;; discards the stop character, too
+  (define (read-until char in)
+    (list->string
+     (let read-more ()
+       (let ([c (read-char in)])
+         (cond
+           [(or (eof-object? c) (eq? c char)) null]
+           [else (cons c (read-more))])))))
+  
+  ;; gen-read-until-string : String -> Input-port -> String
+  ;; uses Knuth-Morris-Pratt from
+  ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
+  ;; discards stop from input
+  (define (gen-read-until-string stop)
+    (let* ([len (string-length stop)]
+           [prefix (make-vector len 0)]
+           [fall-back
+            (lambda (k c)
+              (let ([k (let loop ([k k])
+                         (cond
+                           [(and (> k 0) (not (eq? (string-ref stop k) c)))
+                            (loop (vector-ref prefix (sub1 k)))]
+                           [else k]))])
+                (if (eq? (string-ref stop k) c)
+                    (add1 k)
+                    k)))])
+      (let init ([k 0] [q 1])
+        (when (< q len)
+          (let ([k (fall-back k (string-ref stop q))])
+            (vector-set! prefix q k)
+            (init k (add1 q)))))
+      ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
+      (lambda (in)
+        (list->string
+         (let/ec out
+           (let loop ([matched 0] [out out])
+             (let* ([c (read-char in)]
+                    [matched (fall-back matched c)])
+               (cond
+                 [(or (eof-object? c) (= matched len)) (out null)]
+                 [(zero? matched) (cons c (let/ec out (loop matched out)))]
+                 [else (cons c (loop matched out))]))))))))
+  
+  ;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore.
+  (define lex-comment-contents (gen-read-until-string "-->"))
+  (define lex-pi-data (gen-read-until-string "?>"))
+  (define lex-cdata-contents (gen-read-until-string "]]>")))
diff --git a/collects/html/sgml-reader.ss b/collects/html/sgml-reader.ss
new file mode 100644
index 0000000000..6de4bbb93b
--- /dev/null
+++ b/collects/html/sgml-reader.ss
@@ -0,0 +1,429 @@
+;; copyright by Paul Graunke June 2000 AD
+;; warning - this was copied from the XML collection.
+;; It needs to be abstracted back in.
+#lang scheme
+(require mzlib/list
+         mzlib/string
+         "sgml-reader-sig.ss"
+         xml)
+
+(provide-signature-elements sgml-reader^)
+
+;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
+(define-struct (start-tag source) (name attrs))
+
+;; End-tag ::= (make-end-tag Location Location Symbol)
+(define-struct (end-tag source) (name))
+
+;; Token ::= Contents | Start-tag | End-tag | Eof
+
+(define read-html-comments (make-parameter #f))
+(define trim-whitespace (make-parameter #f))
+
+;; Kid-lister : (Symbol -> (U (listof Symbol) #f))
+
+;; gen-may-contain : Spec -> Kid-lister
+(define (gen-may-contain spec)
+  (let ([table (make-hash)])
+    (for-each (lambda (def)
+                (let ([rhs (cdr def)])
+                  (for-each (lambda (name) (hash-set! table name rhs))
+                            (car def))))
+              spec)
+    (lambda (name)
+      (hash-ref table name (lambda () #f)))))
+
+;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content)
+(define (gen-read-sgml may-contain auto-insert)
+  (case-lambda
+    [(in) (read-from-port may-contain auto-insert in)]
+    [() (read-from-port may-contain auto-insert (current-input-port))]))
+
+;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content)
+(define (read-from-port may-contain auto-insert in)
+  (let loop ([tokens (let read-tokens ()
+                       (let ([tok (lex in)])
+                         (cond
+                           [(eof-object? tok) null]
+                           [else (cons tok (read-tokens))])))])
+    (cond
+      [(null? tokens) null]
+      [else
+       (let ([tok (car tokens)] [rest-tokens (cdr tokens)])
+         (cond
+           [(start-tag? tok)
+            (let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)])
+              (cons el (loop more-tokens)))]
+           [(end-tag? tok) (loop rest-tokens)]
+           [else (let ([rest-contents (loop rest-tokens)])
+                   (expand-content tok rest-contents))]))])))
+
+;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token)
+;; Note: How elements nest depends on their content model.
+;;   If a kind of element can't contain anything, then its start tags are implicitly ended, and
+;;   end tags are implicitly started.
+;;   Unknown elements can contain anything and can go inside anything.
+;;   Otherwise, only the subelements listed in the content model can go inside an element.
+;; more here - may-contain shouldn't be used to decide if an element is known or not.
+;;             The edgar dtd puts tags in may-contain's range that aren't in its domain.
+;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the
+;;                      tag nesting depth.  However, this only should be a problem when the tag is there,
+;;                      but far back.  That shouldn't happen often.  I'm guessing n will be about 3.
+(define (read-element start-tag context may-contain auto-insert tokens)
+  (let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens])
+    (let* ([start-name (start-tag-name start-tag)]
+           [ok-kids (may-contain start-name)])
+      (let-values ([(content remaining)
+                    (cond
+                      [(null? ok-kids) (values null tokens)]
+                      [else 
+                       ;; read-content : (listof Token) -> (listof Content) (listof Token)
+                       (let read-content ([tokens tokens])
+                         (cond
+                           [(null? tokens) (values null tokens)]
+                           [else
+                            (let ([tok (car tokens)] [next-tokens (cdr tokens)])
+                              (cond
+                                [(start-tag? tok)
+                                 (let* ([name (start-tag-name tok)]
+                                        [auto-start (auto-insert start-name name)])
+                                   (if auto-start
+                                       (read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens))
+                                       (if (and ok-kids
+                                                (not (memq name ok-kids))
+                                                (may-contain name))
+                                           (values null tokens)
+                                           (let*-values ([(element post-element)
+                                                          (read-el tok (cons name context) next-tokens)]
+                                                         [(more-contents left-overs) (read-content post-element)])
+                                             (values (cons element more-contents) left-overs)))))]
+                                [(end-tag? tok)
+                                 (let ([name (end-tag-name tok)])
+                                   (if (eq? name start-name)
+                                       (values null next-tokens)
+                                       (if (memq name context)
+                                           (values null tokens)
+                                           (read-content next-tokens))))]
+                                [else ;; content
+                                 (let-values ([(more-contents left-overs) (read-content next-tokens)])
+                                   (values
+                                    (expand-content tok more-contents)
+                                    left-overs))]))]))])])
+        (values (make-element (source-start start-tag)
+                              (source-stop start-tag)
+                              start-name
+                              (start-tag-attrs start-tag)
+                              content)
+                remaining)))))
+
+;; expand-content : Content (listof Content) -> (listof Content)
+(define (expand-content x lst)
+  (cond
+    [(entity? x) (cons (expand-entity x) lst)]
+    [(comment? x) (if (read-html-comments)
+                      (cons x lst)
+                      lst)]
+    [else (cons x lst)]))
+
+;; expand-entity : Entity -> (U Entity Pcdata)
+;; more here - allow expansion of user defined entities
+(define (expand-entity x)
+  (let ([expanded (default-entity-table (entity-text x))])
+    (if expanded
+        (make-pcdata (source-start x) (source-stop x) expanded)
+        x)))
+
+;; default-entity-table : Symbol -> (U #f String)
+(define (default-entity-table name)
+  (case name
+    [(amp) "&"]
+    [(lt) "<"]
+    [(gt) ">"]
+    [(quot) "\""]
+    [(apos) "'"]
+    [else #f]))
+
+;; lex : Input-port -> Token
+(define (lex in)
+  (when (trim-whitespace)
+    (skip-space in))
+  (let ([c (peek-char in)])
+    (cond
+      [(eof-object? c) c]
+      [(eq? c #\&) (lex-entity in)]
+      [(eq? c #\<) (lex-tag-cdata-pi-comment in)]
+      [else (lex-pcdata in)])))
+
+;; lex-entity : Input-port -> Token
+;; This might not return an entity if it doesn't look like one afterall.
+(define (lex-entity in)
+  (let ([start (file-position in)])
+    (read-char in)
+    (case (peek-char in)
+      ;; more here - read while it's numeric (or hex) not until #\;
+      [(#\#)
+       (read-char in)
+       (let* ([hex? (if (equal? #\x (peek-char in))
+                        (and (read-char in) #t)
+                        #f)]
+              [str (read-until #\; in)]
+              [n (cond
+                   [hex?
+                    (string->number str 16)]
+                   [else (string->number str)])])
+         (if (number? n)
+             (make-entity start (file-position in) n)
+             (make-pcdata start (file-position in) (string-append "&#" str))))]
+      [else
+       (let ([name (lex-name/case-sensitive in)]
+             [c (peek-char in)])
+         (if (eq? c #\;)
+             (begin (read-char in) (make-entity start (file-position in) name))
+             (make-pcdata start (file-position in) (format "&~a" name))))])))
+
+;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
+(define (lex-tag-cdata-pi-comment in)
+  (let ([start (file-position in)])
+    (read-char in)
+    (case (peek-char in)
+      [(#\!)
+       (read-char in)
+       (case (peek-char in)
+         [(#\-) (read-char in)
+                (let ([c (read-char in)])
+                  (cond
+                    [(eq? c #\-)
+                     (let ([data (lex-comment-contents in)])
+                       (make-comment data))]
+                    [else (make-pcdata start (file-position in) (format "<!-~a" c))]))]
+         [(#\[) (read-char in)
+                (let ([s (read-string 6 in)])
+                  (if (string=? s "CDATA[")
+                      (let ([data (lex-cdata-contents in)])
+                        (make-pcdata start (file-position in) data))
+                      (make-pcdata start (file-position in) (format "<[~a" s))))]
+         [else (skip-dtd in) (lex in)])]
+      [(#\?) (read-char in)
+             (let ([name (lex-name in)])
+               (skip-space in)
+               (let ([data (lex-pi-data in)])
+                 (make-p-i start (file-position in) name data)))]
+      [(#\/) (read-char in)
+             (let ([name (lex-name in)])
+               (skip-space in)
+               (read-char in) ;; skip #\> or whatever else is there
+               (make-end-tag start (file-position in) name))]
+      [else
+       (let ([name (lex-name in)]
+             [attrs (lex-attributes in)])
+         (skip-space in)
+         (case (read-char in)
+           [(#\/)
+            (read-char in) ;; skip #\> or something
+            (make-element start (file-position in) name attrs null)]
+           [else (make-start-tag start (file-position in) name attrs)]))])))
+
+
+;; lex-attributes : Input-port -> (listof Attribute)
+(define (lex-attributes in)
+  (sort (let loop ()
+          (skip-space in)
+          (cond [(name-start? (peek-char in))
+                 (cons (lex-attribute in) (loop))]
+                [else null]))
+        (lambda (a b)
+          (string<? (symbol->string (attribute-name a))
+                    (symbol->string (attribute-name b))))))
+
+;; lex-attribute : Input-port -> Attribute
+;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax
+(define (lex-attribute in)
+  (let ([start (file-position in)]
+        [name (lex-name in)])
+    (skip-space in)
+    (cond
+      [(eq? (peek-char in) #\=)
+       (read-char in)
+       (skip-space in)
+       (let* ([delimiter (read-char in)]
+              [value (list->string
+                      (case delimiter
+                        [(#\' #\")
+                         (let read-more ()
+                           (let ([c (read-char in)])
+                             (cond
+                               [(or (eq? c delimiter) (eof-object? c)) null]
+                               [else (cons c (read-more))])))]
+                        [else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))])
+         (make-attribute start (file-position in) name value))]
+      [else (make-attribute start (file-position in) name (symbol->string name))])))
+
+;; skip-space : Input-port -> Void
+;; deviation - should sometimes insist on at least one space
+(define (skip-space in)
+  (let loop ()
+    (let ([c (peek-char in)])
+      (when (and (not (eof-object? c)) (char-whitespace? c))
+        (read-char in)
+        (loop)))))
+
+;; lex-pcdata : Input-port -> Pcdata
+;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec 
+(define (lex-pcdata in)
+  (let ([start (file-position in)])
+    ;; The following regexp match must use bytes, not chars, because
+    ;; `in' might not be a well-formed UTF-8 sequence. If it isn't,
+    ;; and it goes wrong with the first byte sequence, then a char-based
+    ;; pattern would match 0 characters. Meanwhile, the caller of this function
+    ;; expects characters to be read.
+    (let ([s (regexp-match #rx#"^[^&<]*" in)])
+      (make-pcdata start
+                   (file-position in)
+                   (bytes->string/utf-8
+                    (if (trim-whitespace)
+                        (regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"")
+                        (car s))
+                    #\?)))))
+#|
+      ;; Original slow version:
+      (define (lex-pcdata in)
+	(let ([start (file-position in)]
+	      [data (let loop ([c (read-char in)])
+		      (let ([next (peek-char in)])
+			(cond
+			 [(or (eof-object? next) (eq? next #\&) (eq? next #\<))
+			  (list c)]
+			 [(and (char-whitespace? next) (trim-whitespace))
+			  (skip-space in)
+			  (let ([lst (loop #\space)])
+			    (cond
+			     [(null? (cdr lst)) (list c)]
+			     [else (cons c lst)]))]
+			 [else (cons c (loop (read-char in)))])))])
+	  (make-pcdata start
+		       (file-position in)
+		       (list->string data))))
+  |#
+
+
+;; lex-name : Input-port -> Symbol
+(define (lex-name in)
+  (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
+    (string->symbol
+     ;; Common case: string is already lowercased
+     (if (regexp-match-positions #rx"[A-Z]" s)
+         (begin
+           (string-lowercase! s)
+           s)
+         s))))
+;; lex-name/case-sensitive : Input-port -> Symbol
+(define (lex-name/case-sensitive in)
+  (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
+    (string->symbol s)))
+#|
+      (define (lex-name in)
+        (string->symbol
+         (list->string
+          (let lex-rest ()
+            (cond
+             [(name-char? (peek-char in))
+              (cons (char-downcase (read-char in)) (lex-rest))]
+             [else null])))))
+|#
+
+
+;; skip-dtd : Input-port -> Void
+(define (skip-dtd in)
+  (let skip ()
+    (let ([c (read-char in)])
+      (if (eof-object? c)
+          (void)
+          (case c
+            [(#\') (read-until #\' in) (skip)]
+            [(#\") (read-until #\" in) (skip)]
+            [(#\<)
+             (case (read-char in)
+               [(#\!) (case (read-char in)
+                        [(#\-) (read-char in) (lex-comment-contents in) (skip)]
+                        [else (skip) (skip)])]
+               [(#\?) (lex-pi-data in) (skip)]
+               [else (skip) (skip)])]
+            [(#\>) (void)]
+            [else (skip)])))))
+
+;; name-start? : TST -> Bool
+(define (name-start? ch)
+  (and (char? ch) (char-name-start? ch)))
+
+;; char-name-start? : Char -> Bool
+(define (char-name-start? ch)
+  (or (char-alphabetic? ch) 
+      (eq? ch #\_)
+      (eq? ch #\:)))
+
+;; name-char? : TST -> Bool
+(define (name-char? ch)
+  (and (char? ch)
+       (or (char-name-start? ch)
+           (char-numeric? ch)
+           (eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database
+           (eq? ch #\.)
+           (eq? ch #\-))))
+
+;; read-up-to : (Char -> Bool) Input-port -> (listof Char)
+;; abstract this with read-until
+(define (read-up-to p? in)
+  (let loop ()
+    (let ([c (peek-char in)])
+      (cond
+        [(or (eof-object? c) (p? c)) null]
+        [else (cons (read-char in) (loop))]))))
+
+;; read-until : Char Input-port -> String
+;; discards the stop character, too
+(define (read-until char in)
+  (list->string
+   (let read-more ()
+     (let ([c (read-char in)])
+       (cond
+         [(or (eof-object? c) (eq? c char)) null]
+         [else (cons c (read-more))])))))
+
+;; gen-read-until-string : String -> Input-port -> String
+;; uses Knuth-Morris-Pratt from
+;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
+;; discards stop from input
+(define (gen-read-until-string stop)
+  (let* ([len (string-length stop)]
+         [prefix (make-vector len 0)]
+         [fall-back
+          (lambda (k c)
+            (let ([k (let loop ([k k])
+                       (cond
+                         [(and (> k 0) (not (eq? (string-ref stop k) c)))
+                          (loop (vector-ref prefix (sub1 k)))]
+                         [else k]))])
+              (if (eq? (string-ref stop k) c)
+                  (add1 k)
+                  k)))])
+    (let init ([k 0] [q 1])
+      (when (< q len)
+        (let ([k (fall-back k (string-ref stop q))])
+          (vector-set! prefix q k)
+          (init k (add1 q)))))
+    ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
+    (lambda (in)
+      (list->string
+       (let/ec out
+         (let loop ([matched 0] [out out])
+           (let* ([c (read-char in)]
+                  [matched (fall-back matched c)])
+             (cond
+               [(or (eof-object? c) (= matched len)) (out null)]
+               [(zero? matched) (cons c (let/ec out (loop matched out)))]
+               [else (cons c (loop matched out))]))))))))
+
+;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore.
+(define lex-comment-contents (gen-read-until-string "-->"))
+(define lex-pi-data (gen-read-until-string "?>"))
+(define lex-cdata-contents (gen-read-until-string "]]>"))
diff --git a/collects/lang/private/teach.ss b/collects/lang/private/teach.ss
index 7e305d8989..5330e7b815 100644
--- a/collects/lang/private/teach.ss
+++ b/collects/lang/private/teach.ss
@@ -1183,6 +1183,16 @@
          (begin
            (check-string-form stx #'s)
            #'(require s))]
+        [(_ id)
+         (identifier? #'id)
+         (begin
+           (unless (module-path? (syntax-e #'id))
+             (teach-syntax-error
+              'require
+              stx
+              #'id
+              "bad syntax for a module path"))
+           #'(require id))]
         [(_ (lib . rest))
          (let ([s (syntax->list #'rest)])
            (unless ((length s) . >= . 2)
diff --git a/collects/lazy/lazy.scrbl b/collects/lazy/lazy.scrbl
index 6dc56ae1ab..059a73296f 100644
--- a/collects/lazy/lazy.scrbl
+++ b/collects/lazy/lazy.scrbl
@@ -1,6 +1,7 @@
 #lang scribble/doc
-@(require (for-label (except-in lazy delay force promise?)
-                     (only-in lazy/force ! !! !list !!list)))
+@(require (for-label (except-in lazy delay force)
+                     (only-in lazy/force ! !! !list !!list)
+                     scheme/contract))
 
 @(define-syntax-rule (deflazy mod def id)
    (begin
diff --git a/collects/mrlib/switchable-button.ss b/collects/mrlib/switchable-button.ss
index 4b56ab6170..b5563438c2 100644
--- a/collects/mrlib/switchable-button.ss
+++ b/collects/mrlib/switchable-button.ss
@@ -76,8 +76,16 @@
     (define/override (enable e?)
       (unless (equal? disabled? (not e?))
         (set! disabled? (not e?))
+        (set! down? #f)
+        (set! in? #f)
         (refresh)))
     (define/override (is-enabled?) (not disabled?))
+
+    (define/override (on-superwindow-show show?)
+      (unless show?
+        (set! in? #f)
+        (set! down? #f))
+      (super on-superwindow-show show?))
     
     (define/override (on-event evt)
       (cond
diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss
index a07bee76a0..ac8a793567 100644
--- a/collects/mzlib/contract.ss
+++ b/collects/mzlib/contract.ss
@@ -31,7 +31,8 @@
 
 (require (except-in scheme/private/contract
                     define/contract
-                    with-contract)
+                    with-contract
+                    define-struct/contract)
          scheme/private/contract-guts
          scheme/private/contract-ds
          scheme/private/contract-opt
diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss
index a3813b91e2..7289ad41fe 100644
--- a/collects/mzlib/private/unit-contract.ss
+++ b/collects/mzlib/private/unit-contract.ss
@@ -3,6 +3,7 @@
 (require (for-syntax scheme/base
                      stxclass
                      syntax/boundmap
+                     syntax/name
                      "unit-compiletime.ss"
                      "unit-contract-syntax.ss"
                      "unit-syntax.ss")
@@ -77,9 +78,13 @@ packed with the neg blame.
                                        #`(let ([old-v/c ((car #,vref))])
                                            (cons #,(wrap-with-proj 
                                                     ctc 
-                                                    #`(contract #,sig-ctc (car old-v/c)
-                                                                (cdr old-v/c) #,pos
-                                                                #,(id->contract-src-info var)))
+                                                    (with-syntax ([sig-ctc-stx
+                                                                   (syntax-property sig-ctc
+                                                                                    'inferred-name
+                                                                                    var)])
+                                                      #`(contract sig-ctc-stx (car old-v/c)
+                                                                  (cdr old-v/c) #,pos
+                                                                  #,(id->contract-src-info var))))
                                                  #,neg))
                                        (wrap-with-proj ctc #`((car #,vref))))])
                            old-v)))
@@ -89,9 +94,13 @@ packed with the neg blame.
                                  #,(if sig-ctc
                                        #`(cons #,(wrap-with-proj 
                                                   ctc 
-                                                  #`(contract #,sig-ctc (car v)
-                                                              (cdr v) #,neg
-                                                              #,(id->contract-src-info var)))
+                                                  (with-syntax ([sig-ctc-stx
+                                                                 (syntax-property sig-ctc
+                                                                                  'inferred-name
+                                                                                  var)])
+                                                    #`(contract sig-ctc-stx (car v)
+                                                                (cdr v) #,neg
+                                                                #,(id->contract-src-info var))))
                                                #,pos)
                                        (wrap-with-proj ctc #'v))])
                            ((cdr #,vref) new-v)))
@@ -126,7 +135,7 @@ packed with the neg blame.
 (define-for-syntax contract-imports (contract-imports/exports #t))
 (define-for-syntax contract-exports (contract-imports/exports #f))
 
-(define-for-syntax (unit/c/core stx)
+(define-for-syntax (unit/c/core name stx)
   (syntax-parse stx
     [(:import-clause/c :export-clause/c)
      (begin
@@ -217,7 +226,7 @@ packed with the neg blame.
                           (vector-immutable export-key ...)) ...)
                    src-info pos name)
                   (make-unit
-                   #f
+                   '#,name
                    (vector-immutable (cons 'import-name
                                            (vector-immutable import-key ...)) ...)
                    (vector-immutable (cons 'export-name 
@@ -261,7 +270,8 @@ packed with the neg blame.
 (define-syntax/err-param (unit/c stx)
   (syntax-case stx ()
     [(_ . sstx)
-     (unit/c/core #'sstx)]))
+     (let ([name (syntax-local-infer-name stx)])
+       (unit/c/core name #'sstx))]))
 
 (define (contract-check-helper sub-sig super-sig import? val src-info blame ctc)
   (define t (make-hash))
diff --git a/collects/mzlib/private/unit-utils.ss b/collects/mzlib/private/unit-utils.ss
index e4d8ac53bb..baf6a35cb1 100644
--- a/collects/mzlib/private/unit-utils.ss
+++ b/collects/mzlib/private/unit-utils.ss
@@ -43,13 +43,13 @@
   (for/list ([i (in-list (map car (car sig)))]
              [c (in-list (cadddr sig))])
     (let ([add-ctc
-           (λ (v stx)
-             (if c
-                 #`(let ([v/c ((car #,stx))])
-                     (contract (let ([#,v #,c]) #,v)
-                               (car v/c) (cdr v/c) #,blame
-                               #,(id->contract-src-info v)))
-                 #`((car #,stx))))])
+             (λ (v stx)
+                 (if c
+                     (with-syntax ([c-stx (syntax-property c 'inferred-name v)])
+                       #`(let ([v/c ((car #,stx))])
+                           (contract c-stx (car v/c) (cdr v/c) #,blame
+                                     #,(id->contract-src-info v))))
+                     #`((car #,stx))))])
       #`[#,i
          (make-set!-transformer
           (λ (stx)
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 8bfd095388..546e8a033e 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -1,6 +1,5 @@
 (module unit mzscheme
   (require-for-syntax mzlib/list
-                      scheme/pretty
                       stxclass
                       syntax/boundmap
                       syntax/context
@@ -31,6 +30,7 @@
            unit-from-context define-unit-from-context
            define-unit-binding
            unit/new-import-export define-unit/new-import-export
+           unit/s define-unit/s
            unit/c define-unit/contract)
  
   (define-syntax/err-param (define-signature-form stx)
@@ -459,11 +459,12 @@
                  
   (define-for-syntax (make-import-unboxing var loc ctc)
     (if ctc
-        (quasisyntax/loc (error-syntax)
-          (quote-syntax (let ([v/c ((car #,loc))])
-                          (contract #,ctc (car v/c) (cdr v/c)
-                                    (current-contract-region)
-                                    #,(id->contract-src-info var)))))
+        (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)])
+          (quasisyntax/loc (error-syntax)
+            (quote-syntax (let ([v/c ((car #,loc))])
+                            (contract ctc-stx (car v/c) (cdr v/c)
+                                      (current-contract-region)
+                                      #,(id->contract-src-info var))))))
         (quasisyntax/loc (error-syntax)
           (quote-syntax ((car #,loc))))))
   
@@ -790,30 +791,31 @@
                                   [rename-bindings (get-member-bindings def-table
                                                                         (bound-identifier-mapping-get sig-table var)
                                                                         #'(current-contract-region))])
-                             (if (or target-ctc ctc)
-                                 #`(cons
-                                    (λ ()
-                                      (let ([old-v #,(if ctc
-                                                         #`(let ([old-v/c ((car #,vref))])
-                                                             (contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
-                                                                       (car old-v/c) 
-                                                                       (cdr old-v/c) (current-contract-region)
-                                                                       #,(id->contract-src-info var)))
-                                                         #`((car #,vref)))])
-                                        #,(if target-ctc
-                                              #'(cons old-v (current-contract-region))
-                                              #'old-v)))
-                                    (λ (v) (let ([new-v #,(if ctc
-                                                              #`(contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
-                                                                          (car v)
-                                                                          (current-contract-region)
-                                                                          (cdr v)
-                                                                          #,(id->contract-src-info var))
-                                                              #'v)])
-                                             #,(if target-ctc
-                                                   #`((cdr #,vref) (cons new-v (current-contract-region)))
-                                                   #`((cdr #,vref) new-v)))))
-                                 vref)))
+                             (with-syntax ([ctc-stx (if ctc (syntax-property
+                                                             #`(letrec-syntax #,rename-bindings #,ctc)
+                                                             'inferred-name var)
+                                                        ctc)])
+                               (if (or target-ctc ctc)
+                                   #`(cons
+                                      (λ ()
+                                        (let ([old-v #,(if ctc
+                                                           #`(let ([old-v/c ((car #,vref))])
+                                                               (contract ctc-stx (car old-v/c) 
+                                                                         (cdr old-v/c) (current-contract-region)
+                                                                         #,(id->contract-src-info var)))
+                                                           #`((car #,vref)))])
+                                          #,(if target-ctc
+                                                #'(cons old-v (current-contract-region))
+                                                #'old-v)))
+                                      (λ (v) (let ([new-v #,(if ctc
+                                                                #`(contract ctc-stx (car v)
+                                                                            (current-contract-region) (cdr v)
+                                                                            #,(id->contract-src-info var))
+                                                                #'v)])
+                                               #,(if target-ctc
+                                                     #`((cdr #,vref) (cons new-v (current-contract-region)))
+                                                     #`((cdr #,vref) new-v)))))
+                                   vref))))
                          (car target-sig)
                          (cadddr target-sig)))
                       target-import-sigs))
@@ -1277,9 +1279,13 @@
                                (map (λ (tb i v c)
                                       #`(let ([v/c ((car #,tb))])
                                           #,(if c
-                                                #`(contract (letrec-syntax #,rename-bindings #,c) (car v/c) (cdr v/c)
-                                                            (current-contract-region)
-                                                            #,(id->contract-src-info v))
+                                                (with-syntax ([ctc-stx
+                                                               (syntax-property
+                                                                #`(letrec-syntax #,rename-bindings #,c)
+                                                                'inferred-name v)])
+                                                  #`(contract ctc-stx (car v/c) (cdr v/c)
+                                                              (current-contract-region)
+                                                              #,(id->contract-src-info v)))
                                                 #'v/c)))
                                     tbs
                                     (iota (length (car os)))
@@ -1476,6 +1482,7 @@
            (with-syntax ([new-unit exp]
                          [unit-contract
                           (unit/c/core
+                           #'name
                            (syntax/loc stx
                              ((import (import-tagged-sig-id [i.x i.c] ...) ...)
                               (export (export-tagged-sig-id [e.x e.c] ...) ...))))]
@@ -1786,5 +1793,28 @@
         (format "expected syntax matching (~a <define-unit-identifier>)"
                 (syntax-e (stx-car stx)))))))
   
+  (define-for-syntax (build-unit/s stx)
+    (syntax-case stx (import export init-depend)
+      [((import i ...) (export e ...) (init-depend d ...) u)
+       (let* ([ui (lookup-def-unit #'u)]
+              [unprocess (let ([i (make-syntax-delta-introducer #'u (unit-info-orig-binder ui))])
+                           (lambda (p)
+                             (unprocess-tagged-id (cons (car p) (i (cdr p))))))])
+         (with-syntax ([(isig ...) (map unprocess (unit-info-import-sig-ids ui))]
+                       [(esig ...) (map unprocess (unit-info-export-sig-ids ui))])
+           (build-unit/new-import-export
+            (syntax/loc stx
+              ((import i ...) (export e ...) (init-depend d ...) ((esig ...) u isig ...))))))]))
+
+  (define-syntax/err-param (define-unit/s stx)
+    (build-define-unit stx (λ (stx) (build-unit/s (check-unit-syntax stx)))
+      "missing unit name"))
+  
+  (define-syntax/err-param (unit/s stx)
+    (syntax-case stx ()
+      [(_ . stx)
+       (let-values ([(u x y z) (build-unit/s (check-unit-syntax #'stx))])
+         u)]))
+  
   )
 ;(load "test-unit.ss")
diff --git a/collects/planet/lang/reader.ss b/collects/planet/lang/reader.ss
index ade1f83ed8..6b42cd9cf9 100644
--- a/collects/planet/lang/reader.ss
+++ b/collects/planet/lang/reader.ss
@@ -9,7 +9,7 @@
          get-info)
 
 (define (planet-get in lang-mod export-sym src line col pos mk-fail-thunk)
-  (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(\\s|$)" in)]
+  (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]
         [bad (lambda (str eof?)
                ((if eof?
                     raise-read-eof-error 
@@ -35,7 +35,7 @@
               (bad (cadr spec) #f))))))
 
 (define (get-info in mod line col pos)
-  (planet-get in "/lang/langinfo" 'get-info (object-name in) line col pos
+  (planet-get in "/lang/reader" 'get-info (object-name in) line col pos
               (lambda (spec) (lambda () (lambda (tag) #f)))))
 
 (define (planet-read-fn in read-sym args src mod line col pos)
diff --git a/collects/redex/private/arrow.ss b/collects/redex/private/arrow.ss
index 023f748cb6..c8dad8c4a5 100644
--- a/collects/redex/private/arrow.ss
+++ b/collects/redex/private/arrow.ss
@@ -7,7 +7,7 @@
 (provide/contract
  [make-arrow-pict
   (-> string?
-      (symbols 'curvy 'straight 'straight-double)
+      (symbols 'curvy 'straight 'straight-double 'map)
       symbol?
       number?
       (-> pict?))])
@@ -71,6 +71,17 @@
             (case style
               [(curvy)
                (send dc draw-path path dx dy)]
+              [(map)
+               (send dc draw-line
+                     dx
+                     (- (+ dy line-pos) (/ head-height 2))
+                     dx
+                     (+ (+ dy line-pos) (/ head-height 2)))
+               (send dc draw-line 
+                     dx
+                     (+ dy line-pos)
+                     (+ dx w)
+                     (+ dy line-pos))]
               [(straight)
                (send dc draw-line 
                      dx
diff --git a/collects/redex/private/bitmap-test.ss b/collects/redex/private/bitmap-test.ss
index ed2fc014ef..8d84edfcb6 100644
--- a/collects/redex/private/bitmap-test.ss
+++ b/collects/redex/private/bitmap-test.ss
@@ -64,11 +64,11 @@
 
 (define-metafunction lang
   [(TL 1) (a
-           ,(term-let ((x 1))
+           ,(term-let ((x (term 1)))
                       (term x))
            below-only)]
   [(TL 2) (a
-           ,(term-let ((x 1))
+           ,(term-let ((x (term 1)))
                       (term x)) beside
            below)])
 
@@ -78,7 +78,7 @@
 
 (define-metafunction lang
   [(Name (name x-arg arg)) 
-   ,(term-let ((x-term-let 1))
+   ,(term-let ((x-term-let (term 1)))
               (term (x-where x-term-let)))
    (where x-where 2)])
 
diff --git a/collects/redex/private/bmps/metafunction-Name-vertical.png b/collects/redex/private/bmps/metafunction-Name-vertical.png
index cffd3e9f29..cde38b7b0f 100644
Binary files a/collects/redex/private/bmps/metafunction-Name-vertical.png and b/collects/redex/private/bmps/metafunction-Name-vertical.png differ
diff --git a/collects/redex/private/bmps/metafunction-Name.png b/collects/redex/private/bmps/metafunction-Name.png
index 68e075ab29..989837fdae 100644
Binary files a/collects/redex/private/bmps/metafunction-Name.png and b/collects/redex/private/bmps/metafunction-Name.png differ
diff --git a/collects/redex/private/bmps/metafunction-TL.png b/collects/redex/private/bmps/metafunction-TL.png
index ce08c4c321..81a744f06d 100644
Binary files a/collects/redex/private/bmps/metafunction-TL.png and b/collects/redex/private/bmps/metafunction-TL.png differ
diff --git a/collects/redex/private/bmps/metafunctions-multiple.png b/collects/redex/private/bmps/metafunctions-multiple.png
index f36bf7fc14..fc46812337 100644
Binary files a/collects/redex/private/bmps/metafunctions-multiple.png and b/collects/redex/private/bmps/metafunctions-multiple.png differ
diff --git a/collects/redex/private/lw-test.ss b/collects/redex/private/lw-test.ss
index 2ad176bb96..109b17c9a5 100644
--- a/collects/redex/private/lw-test.ss
+++ b/collects/redex/private/lw-test.ss
@@ -216,8 +216,7 @@
            (list 
             (make-lw "" 0 0 1 0 #t #f) 
             'spring
-            (make-lw 'x 0 0 7 1 #f #f)
-            'spring)
+            (make-lw 'x 0 0 7 1 #f #f))
            0 0 1 7 #t #f))
          0 0 0 8 #f #f))
 
diff --git a/collects/redex/private/pict.ss b/collects/redex/private/pict.ss
index 07a46343aa..43d3e8edff 100644
--- a/collects/redex/private/pict.ss
+++ b/collects/redex/private/pict.ss
@@ -344,6 +344,8 @@
 (define short-curvy-arrow-pict (mk-arrow-pict "m" 'curvy))
 (define double-arrow-pict (mk-arrow-pict "xxx" 'straight-double))
 (define short-double-arrow-pict (mk-arrow-pict "m" 'straight-double))
+(define map-arrow-pict (mk-arrow-pict "m" 'map))
+(define long-map-arrow-pict (mk-arrow-pict "xxx" 'map))
 
 (define user-arrow-table (make-hasheq))
 (define (set-arrow-pict! arr thunk)
@@ -362,7 +364,14 @@
           [(>->) (basic-text "\u21a3" (default-style))]
           [(~~>) (curvy-arrow-pict)]
           [(~>) (short-curvy-arrow-pict)]
-          [(:->) (basic-text "\u21a6" (default-style))]
+          [(:->) 
+           (if STIX?
+               (basic-text "\u21a6" (default-style))
+               (map-arrow-pict))]
+          [(:-->) 
+           (if STIX?
+               (basic-text "\u27fc" (default-style))
+               (long-map-arrow-pict))]
           [(c->) (basic-text "\u21aa" (default-style))]
           [(-->>) (basic-text "\u21a0" (default-style))]
           [(>--) (basic-text "\u291a" (default-style))]
diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss
index 979d5fa0b9..55a7978a09 100644
--- a/collects/redex/private/reduction-semantics.ss
+++ b/collects/redex/private/reduction-semantics.ss
@@ -318,8 +318,9 @@
                        [(fvars ...) fvars]
                        [((where-id where-expr) ...) withs]
                        [((bind-id . bind-pat) ...) 
-                        (append (extract-pattern-binds #'lhs)
-                                (extract-term-let-binds #'rhs))])
+                        (extract-pattern-binds #'lhs)]
+                       [((tl-id . tl-pat) ...)
+                       (extract-term-let-binds #'rhs)])
            #`(make-rule-pict 'arrow
                              (to-lw lhs)
                              (to-lw rhs)
@@ -329,6 +330,9 @@
                              (list (cons (to-lw bind-id)
                                          (to-lw bind-pat))
                                    ...
+                                   (cons (to-lw tl-id)
+                                         (to-lw/uq tl-pat))
+                                   ...
                                    (cons (to-lw where-id)
                                          (to-lw where-expr))
                                    ...))))]))
@@ -519,38 +523,15 @@
   (define (do-leaf stx orig-name lang name-table from to extras lang-id)
     (let* ([lang-nts (language-id-nts lang-id orig-name)]
            [rw-sc (λ (pat) (rewrite-side-conditions/check-errs lang-nts orig-name #t pat))])
-      (let-values ([(name fresh-vars side-conditions/withs) (process-extras stx orig-name name-table extras)])
+      (let-values ([(name sides/withs/freshs) (process-extras stx orig-name name-table extras)])
         (let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t from)])
           (with-syntax ([side-conditions-rewritten (rw-sc from)]
-                        [lhs-w/extras (rw-sc #`(side-condition #,from #,(bind-withs side-conditions/withs #'#t)))]
+                        [lhs-w/extras (rw-sc #`(side-condition #,from #,(bind-withs orig-name #'#t sides/withs/freshs #'#t)))]
                         [to to]
                         [name name]
                         [lang lang]
                         [(names ...) names]
-                        [(names/ellipses ...) names/ellipses]
-                        [(fresh-var-clauses ...) 
-                         (map (λ (fv-clause)
-                                (syntax-case fv-clause ()
-                                  [x
-                                   (identifier? #'x)
-                                   #'[x (variable-not-in main 'x)]]
-                                  [(x name)
-                                   (identifier? #'x)
-                                   #'[x (let ([the-name (term name)])
-                                          (verify-name-ok '#,orig-name the-name)
-                                          (variable-not-in main the-name))]]
-                                  [((y) (x ...))
-                                   #`[(y #,'...)
-                                      (variables-not-in main 
-                                                        (map (λ (_ignore_) 'y)
-                                                             (term (x ...))))]]
-                                  [((y) (x ...) names)
-                                   #`[(y #,'...)
-                                      (let ([the-names (term names)]
-                                            [len-counter (term (x ...))])
-                                        (verify-names-ok '#,orig-name the-names len-counter)
-                                        (variables-not-in main the-names))]]))
-                              fresh-vars)])
+                        [(names/ellipses ...) names/ellipses])
             #`(do-leaf-match
                name
                `side-conditions-rewritten
@@ -560,29 +541,52 @@
                  ;; show up in the `fresh' side-conditions, the bindings for the variables
                  ;; show up in the withs, and the withs show up in the 'fresh' side-conditions
                  (term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
-                           (term-let (fresh-var-clauses ...)
-                                     #,(bind-withs side-conditions/withs
-                                                   #'(make-successful (term to))))))))))))
+                           #,(bind-withs orig-name #'main sides/withs/freshs
+                                         #'(make-successful (term to)))))))))))
   
-  ;; the withs and side-conditions come in backwards order
-  (define (bind-withs stx body)
+  ;; the withs, freshs, and side-conditions come in backwards order
+  (define (bind-withs orig-name main stx body)
     (let loop ([stx stx]
                [body body])
-      (syntax-case stx (side-condition where)
+      (syntax-case stx (side-condition where fresh)
         [() body]
         [((where x e) y ...) 
          (loop #'(y ...) #`(term-let ([x (term e)]) #,body))]
         [((side-condition s ...) y ...)
-         (loop #'(y ...) #`(and s ... #,body))])))
+         (loop #'(y ...) #`(and s ... #,body))]
+        [((fresh x) y ...)
+         (identifier? #'x)
+         (loop #'(y ...) #`(term-let ([x (variable-not-in #,main 'x)]) #,body))]
+        [((fresh x name) y ...)
+         (identifier? #'x)
+         (loop #'(y ...)
+               #`(term-let ([x (let ([the-name (term name)])
+                                 (verify-name-ok '#,orig-name the-name)
+                                 (variable-not-in #,main the-name))])
+                   #,body))]
+        [((fresh (y) (x ...)) z ...)
+         (loop #'(z ...)
+               #`(term-let ([(y #,'...)
+                             (variables-not-in #,main 
+                                               (map (λ (_ignore_) 'y)
+                                                    (term (x ...))))])
+                   #,body))]
+        [((fresh (y) (x ...) names) z ...)
+         (loop #'(z ...)
+               #`(term-let ([(y #,'...)
+                             (let ([the-names (term names)]
+                                   [len-counter (term (x ...))])
+                               (verify-names-ok '#,orig-name the-names len-counter)
+                               (variables-not-in #,main the-names))])
+                   #,body))])))
   
   (define (process-extras stx orig-name name-table extras)
     (let ([the-name #f]
           [the-name-stx #f]
-          [fresh-vars '()]
-          [side-conditions/withs '()])
+          [sides/withs/freshs '()])
       (let loop ([extras extras])
         (cond
-          [(null? extras) (values the-name fresh-vars side-conditions/withs)]
+          [(null? extras) (values the-name sides/withs/freshs)]
           [else
            (syntax-case (car extras) (side-condition fresh where)
              [name 
@@ -614,39 +618,40 @@
                   (loop (cdr extras))))]
              [(fresh var ...)
               (begin
-                (set! fresh-vars 
+                (set! sides/withs/freshs
                       (append 
-                       (map (λ (x)
-                              (syntax-case x ()
-                                [x
-                                 (identifier? #'x)
-                                 #'x]
-                                [(x name)
-                                 (identifier? #'x)
-                                 #'(x name)]
-                                [((ys dots2) (xs dots1))
-                                 (and (eq? (syntax-e #'dots1) (string->symbol "..."))
-                                      (eq? (syntax-e #'dots2) (string->symbol "...")))
-                                 #'((ys) (xs dots1))]
-                                [((ys dots2) (xs dots1) names)
-                                 (and (eq? (syntax-e #'dots1) (string->symbol "..."))
-                                      (eq? (syntax-e #'dots2) (string->symbol "...")))
-                                 #'((ys) (xs dots1) names)]
-                                [x
-                                 (raise-syntax-error orig-name 
-                                                     "malformed fresh variable clause"
-                                                     stx
-                                                     #'x)]))
-                            (syntax->list #'(var ...)))
-                       fresh-vars))
+                       (reverse 
+                        (map (λ (x)
+                               (syntax-case x ()
+                                 [x
+                                  (identifier? #'x)
+                                  #'(fresh x)]
+                                 [(x name)
+                                  (identifier? #'x)
+                                  #'(fresh x name)]
+                                 [((ys dots2) (xs dots1))
+                                  (and (eq? (syntax-e #'dots1) (string->symbol "..."))
+                                       (eq? (syntax-e #'dots2) (string->symbol "...")))
+                                  #'(fresh (ys) (xs dots1))]
+                                 [((ys dots2) (xs dots1) names)
+                                  (and (eq? (syntax-e #'dots1) (string->symbol "..."))
+                                       (eq? (syntax-e #'dots2) (string->symbol "...")))
+                                  #'(fresh (ys) (xs dots1) names)]
+                                 [x
+                                  (raise-syntax-error orig-name 
+                                                      "malformed fresh variable clause"
+                                                      stx
+                                                      #'x)]))
+                             (syntax->list #'(var ...))))
+                       sides/withs/freshs))
                 (loop (cdr extras)))]
              [(side-condition exp ...)
               (begin 
-                (set! side-conditions/withs (cons (car extras) side-conditions/withs))
+                (set! sides/withs/freshs (cons (car extras) sides/withs/freshs))
                 (loop (cdr extras)))]
              [(where x e)
               (begin
-                (set! side-conditions/withs (cons (car extras) side-conditions/withs))
+                (set! sides/withs/freshs (cons (car extras) sides/withs/freshs))
                 (loop (cdr extras)))]
              [(where . x)
               (raise-syntax-error orig-name "malformed where clause" stx (car extras))]
@@ -973,9 +978,9 @@
                                                          [((tl-var tl-exp) ...) bindings])
                                              (syntax 
                                               (λ (name bindings)
-                                                (term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
-                                                          (term-let ([tl-var (term tl-exp)] ...)
-                                                                    (term-let-fn ((name name))
+                                                (term-let-fn ((name name))
+                                                             (term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
+                                                                       (term-let ([tl-var (term tl-exp)] ...)
                                                                                  (term rhs)))))))))
                                        (syntax->list (syntax (lhs ...)))
                                        (syntax->list (syntax (rhs ...)))
@@ -1027,7 +1032,7 @@
                                                          (to-lw bind-pat))
                                                    ...
                                                    (cons (to-lw rhs-bind-id)
-                                                         (to-lw rhs-bind-pat))
+                                                         (to-lw/uq rhs-bind-pat))
                                                    ...
                                                    (cons (to-lw where-id)
                                                          (to-lw where-pat))
@@ -1141,7 +1146,7 @@
                                   (cons (reverse side-conditions) side-conditionss)
                                   (cons (reverse bindings) bindingss))]
              [else 
-              (syntax-case (car stuff) (side-condition)
+              (syntax-case (car stuff) (where side-condition)
                 [(side-condition tl-side-conds ...) 
                  (s-loop (cdr stuff)
                          (append (syntax->list #'(tl-side-conds ...)) side-conditions)
diff --git a/collects/redex/private/rewrite-side-conditions.ss b/collects/redex/private/rewrite-side-conditions.ss
index aa666c2913..58da06c255 100644
--- a/collects/redex/private/rewrite-side-conditions.ss
+++ b/collects/redex/private/rewrite-side-conditions.ss
@@ -34,6 +34,10 @@
       (raise-syntax-error what (format "~a expected to have arguments" name) orig-stx stx))
     (let loop ([term orig-stx])
       (syntax-case term (side-condition variable-except variable-prefix hole name in-hole in-named-hole hide-hole side-condition cross)
+        [(side-condition pre-pat (and))
+         ;; rewriting metafunctions (and possibly other things) that have no where, etc clauses
+         ;; end up with side-conditions that are empty 'and' expressions, so we just toss them here.
+         (loop #'pre-pat)]
         [(side-condition pre-pat exp)
          (with-syntax ([pat (loop (syntax pre-pat))])
            (let-values ([(names names/ellipses) (extract-names all-nts what bind-names? (syntax pat))])
diff --git a/collects/redex/private/run-tests.ss b/collects/redex/private/run-tests.ss
index 10dc8f5382..2fb8108de6 100644
--- a/collects/redex/private/run-tests.ss
+++ b/collects/redex/private/run-tests.ss
@@ -16,10 +16,21 @@
 
 (define-runtime-path here ".")
 
+(define (flush)
+  ;; these flushes are here for running under cygwin, 
+  ;; which somehow makes mzscheme think it isn't using
+  ;; an interative port
+  (flush-output (current-error-port))
+  (flush-output (current-output-port)))
+
 (for-each
  (λ (test-file)
+   (flush)
    (printf "requiring ~a\n" test-file)
-   (dynamic-require (build-path here test-file) #f))
+   (flush)
+   (dynamic-require (build-path here test-file) #f)
+   (flush))
  test-files)
 
 (printf "\nWARNING: didn't run color-test.ss or subst-test.ss\n")
+(flush)
\ No newline at end of file
diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss
index cd4a61e802..049dda3d01 100644
--- a/collects/redex/private/tl-test.ss
+++ b/collects/redex/private/tl-test.ss
@@ -536,6 +536,16 @@
             'no-exn)
           'no-exn))
     
+  (let ()
+    ;; test that 'where' clauses can contain recursive calls.
+    (define-metafunction empty-language
+      [(f (any)) 
+       x
+       (where x (f any))]
+      [(f any) any])
+    (test (term (f ((((x))))))
+          (term x)))
+  
   ;; test that tracing works properly
   ;; note that caching comes into play here (which is why we don't see the recursive calls)
   (let ()
diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl
index c9242e3389..ddacfc7c34 100644
--- a/collects/redex/redex.scrbl
+++ b/collects/redex/redex.scrbl
@@ -16,7 +16,7 @@
      [(_ arg)
       (identifier? #'arg)
       (let ([as (symbol->string (syntax-e #'arg))])
-        #`(index '("Redex Pattern" #,as) (deftech #,as)))]))
+        #`(index '("Redex Pattern" #,as) (deftech #:style? #f @scheme[arg])))]))
 
 @(define-syntax (pattech stx)
    (syntax-case stx ()
@@ -27,8 +27,8 @@
 @(define-syntax (ttpattern stx)
    (syntax-case stx ()
     [(_ args ...)
-     #'((tech (tt "pattern")) args ...)]
-    [x (identifier? #'x) #'(tech (tt "pattern"))]))
+     #'((tech (schemevarfont "pattern")) args ...)]
+    [x (identifier? #'x) #'(tech (schemevarfont "pattern"))]))
 
 @(define-syntax (pattern stx)
    (syntax-case stx ()
@@ -39,8 +39,8 @@
 @(define-syntax (tttterm stx)
    (syntax-case stx ()
     [(_ args ...)
-     #'((tech (tt "term")) args ...)]
-    [x (identifier? #'x) #'(tech (tt "term"))]))
+     #'((tech (schemevarfont "term")) args ...)]
+    [x (identifier? #'x) #'(tech (schemevarfont "term"))]))
 
 @(define-syntax (tterm stx)
    (syntax-case stx ()
@@ -372,7 +372,7 @@ the visible representation of terms.
 The grammar of @deftech{term}s is (note that an ellipsis
 stands for repetition unless otherwise indicated):
 
-@(schemegrammar* #:literals (in-hole hole) 
+@(schemegrammar* #:literals (in-hole hole unquote unquote-splicing) 
    [term identifier
          (term-sequence ...)
          ,scheme-expression
@@ -387,28 +387,28 @@ stands for repetition unless otherwise indicated):
 
 @itemize{
 
-@item{A term written @tt{identifier} is equivalent to the
+@item{A term written @scheme[_identifier] is equivalent to the
 corresponding symbol, unless the identifier is bound by
 @scheme[term-let] (or in a @|pattern| elsewhere) or is
 @tt{hole} (as below).  }
 
-@item{A term written @tt{(term-sequence ...)} constructs a list of
+@item{A term written @scheme[(_term-sequence ...)] constructs a list of
 the terms constructed by the sequence elements.}
 
-@item{A term written @scheme[,scheme-expression] evaluates the
+@item{A term written @scheme[,_scheme-expression] evaluates the
 @scheme[scheme-expression] and substitutes its value into the term at
 that point.}
 
-@item{A term written @scheme[,@scheme-expression] evaluates the
+@item{A term written @scheme[,@_scheme-expression] evaluates the
 @scheme[scheme-expression], which must produce a list. It then splices
 the contents of the list into the expression at that point in the sequence.}
 
-@item{A term written @tt{(in-hole @|tttterm| @|tttterm|)}
- is the dual to the @pattern `in-hole' -- it accepts
+@item{A term written @scheme[(in-hole @|tttterm| @|tttterm|)]
+ is the dual to the @pattern @scheme[in-hole] -- it accepts
  a context and an expression and uses @scheme[plug] to combine
 them.}
 
-@item{A term written @tt{hole} produces a hole.}
+@item{A term written @scheme[hole] produces a hole.}
 
 @item{A term written as a literal boolean or a string
 produces the boolean or the string.}
@@ -418,13 +418,11 @@ produces the boolean or the string.}
 
 This form is used for construction of a term.
 
- in
-the right-hand sides of reductions. It behaves similarly to
-quasiquote except for a few special forms that are
-recognized (listed below) and that names bound by @scheme[term-let] are
-implicitly substituted with the values that those names were
-bound to, expanding ellipses as in-place sublists (in the
-same manner as syntax-case patterns).
+It behaves similarly to @scheme[quasiquote], except for a few special
+forms that are recognized (listed below) and that names bound by
+@scheme[term-let] are implicitly substituted with the values that
+those names were bound to, expanding ellipses as in-place sublists (in
+the same manner as syntax-case patterns).
 
 For example,
 
@@ -461,16 +459,15 @@ the id pattern to the appropriate value (described
 below). These bindings are then accessible to the `term'
 syntactic form.
 
-Note that each @scheme[ellipsis] should be the literal
-symbol consisting of three dots (and the ... elsewhere
-indicates repetition as usual). If @scheme[tl-pat] is an identifier,
-it matches any value and binds it to the identifier, for use
-inside @scheme[term]. If it is a list, it matches only if the value
-being matched is a list value and only if every subpattern
-recursively matches the corresponding list element. There
-may be a single ellipsis in any list pattern; if one is
-present, the pattern before the ellipses may match multiple
-adjacent elements in the list value (possibly none).  
+Note that each ellipsis should be the literal symbol consisting of
+three dots (and the ... elsewhere indicates repetition as usual). If
+@scheme[tl-pat] is an identifier, it matches any value and binds it to
+the identifier, for use inside @scheme[term]. If it is a list, it
+matches only if the value being matched is a list value and only if
+every subpattern recursively matches the corresponding list
+element. There may be a single ellipsis in any list pattern; if one is
+present, the pattern before the ellipses may match multiple adjacent
+elements in the list value (possibly none).
 
 This form is a lower-level form in Redex, and not really designed to
 be used directly. If you want a @scheme[let]-like form that uses
diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss
index a63781735b..0e5b68f305 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "16feb2009")
+#lang scheme/base (provide stamp) (define stamp "26feb2009")
diff --git a/collects/scheme/include.ss b/collects/scheme/include.ss
index 45657159a7..94cace375b 100644
--- a/collects/scheme/include.ss
+++ b/collects/scheme/include.ss
@@ -32,7 +32,9 @@
                                   [(pair? e) (or (loop (car e))
                                                  (loop (cdr e)))]
                                   [else #f])))
-                              read-syntax)])
+                              (lambda (src in)
+                                (parameterize ([read-accept-reader #t])
+                                  (read-syntax src in))))])
          (unless (and (procedure? read-syntax)
                       (procedure-arity-includes? read-syntax 2))
            (raise-syntax-error
diff --git a/collects/scheme/load.ss b/collects/scheme/load.ss
index 8794f28170..eb64965370 100644
--- a/collects/scheme/load.ss
+++ b/collects/scheme/load.ss
@@ -1,4 +1,5 @@
 #lang scheme
+(require syntax/strip-context)
 
 (provide (rename-out [module-begin #%module-begin]
                      [top-interaction #%top-interaction]))
@@ -40,24 +41,3 @@
         (lambda ()
           (set! namespace (current-namespace))
           (current-namespace ns)))))
-
-(define (strip-context e)
-  (cond
-   [(syntax? e)
-    (datum->syntax #f
-                   (strip-context (syntax-e e))
-                   e
-                   e)]
-   [(pair? e) (cons (strip-context (car e))
-                    (strip-context (cdr e)))]
-   [(vector? e) (list->vector
-                 (map strip-context
-                      (vector->list e)))]
-   [(box? e) (box (strip-context (unbox e)))]
-   [(prefab-struct-key e)
-    => (lambda (k)
-         (apply make-prefab-struct
-                (strip-context (cdr (vector->list (struct->vector e))))))]
-   [else e]))
-
-
diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss
index ed9a29eda4..757353d83c 100644
--- a/collects/scheme/private/contract-arrow.ss
+++ b/collects/scheme/private/contract-arrow.ss
@@ -1427,11 +1427,14 @@ v4 todo:
      src-info
      blame
      orig-str
-     "expected a ~a that accepts ~a~a argument~a~a, given: ~e"
+     "expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e"
      (if mtd? "method" "procedure")
      (if (zero? dom-length) "no" dom-length)
+     (if (null? optionals) "" " mandatory")
      (if (null? mandatory-kwds) "" " ordinary")
      (if (= 1 dom-length) "" "s")
+     (if (zero? optionals) ""
+         (format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s")))
      (keyword-error-text mandatory-kwds optional-keywords)
      val)))
 
diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss
index 185513882b..db02530008 100644
--- a/collects/scheme/private/contract.ss
+++ b/collects/scheme/private/contract.ss
@@ -12,6 +12,7 @@ improve method arity mismatch contract violation error messages?
 (provide (rename-out [-contract contract])
          recursive-contract
          provide/contract
+         define-struct/contract
          define/contract
          with-contract
          current-contract-region)
@@ -88,31 +89,268 @@ improve method arity mismatch contract violation error messages?
      (raise-syntax-error 'define/contract
                          "no body after contract"
                          define-stx)]
-    [(_ name contract-expr expr)
-     (identifier? #'name)
-     (syntax/loc define-stx
-       (with-contract #:type definition name
-         ([name contract-expr])
-         (define name expr)))]
-    [(_ name contract-expr expr0 expr ...)
-     (identifier? #'name)
+    [(_ name+arg-list contract #:freevars args . body)
+     (identifier? #'args)
      (raise-syntax-error 'define/contract
-                         "multiple expressions after identifier and contract"
-                         define-stx)]
+                         "expected list of identifier/contract pairs"
+                         #'args)]
+    [(_ name+arg-list contract #:freevars (arg ...) #:freevar x c . body)
+     (syntax/loc define-stx
+       (define/contract name+arg-list contract #:freevars (arg ... [x c]) . body))]
+    [(_ name+arg-list contract #:freevar x c . body)
+     (syntax/loc define-stx
+       (define/contract name+arg-list contract #:freevars () #:freevar x c . body))]
+    [(_ name+arg-list contract #:freevars args body0 body ...)
+     (begin
+       (when (and (identifier? #'name+arg-list)
+                  (not (null? (syntax->list #'(body ...)))))
+         (raise-syntax-error 'define/contract
+                             "multiple expressions after identifier and contract"
+                             #'(body ...)))
+       (let-values ([(name body-expr)
+                     (if (identifier? #'name+arg-list)
+                         (values #'name+arg-list #'body0)
+                         (normalize-definition
+                          (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list
+                                                             #'body0 #'(body ...)))
+                          #'lambda #t #t))])
+         (with-syntax ([name name]
+                       [body-expr body-expr]
+                       [type (if (identifier? #'name+arg-list) 'definition 'function)])
+           (syntax/loc define-stx
+             (with-contract #:type type name
+               ([name contract])
+               #:freevars args
+               (define name body-expr))))))]
     [(_ name+arg-list contract body0 body ...)
-     (let-values ([(name lam-expr)
-                   (normalize-definition
-                    (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list
-                                                       #'body0 #'(body ...)))
-                    #'lambda #t #t)])
-       (with-syntax ([name name]
-                     [lam-expr lam-expr])
-         (syntax/loc define-stx
-           (with-contract #:type function name
-             ([name (verify-contract 'define/contract contract)])
-             (define name lam-expr)))))]))
+     (syntax/loc define-stx
+       (define/contract name+arg-list contract #:freevars () body0 body ...))]))
 
+(define-syntax (define-struct/contract stx)
+  (define-struct field-info (stx ctc [mutable? #:mutable] auto?))
+  (define-struct s-info (auto-value-stx transparent? def-stxs? def-vals?))
+  
+  (define (build-struct-names name field-infos)
+    (let ([name-str (symbol->string (syntax-e name))])
+      (list* (datum->syntax 
+              name
+              (string->symbol
+               (string-append "struct:" name-str)))
+             (datum->syntax 
+              name
+              (string->symbol
+               (string-append "make-" name-str)))
+             (datum->syntax 
+              name
+              (string->symbol
+               (string-append name-str "?")))           
+             (apply append
+                    (for/list ([finfo field-infos])
+                      (let ([field-str (symbol->string (syntax-e (field-info-stx finfo)))])
+                        (cons (datum->syntax 
+                               name
+                               (string->symbol
+                                (string-append name-str "-" field-str)))
+                              (if (field-info-mutable? finfo)
+                                  (list (datum->syntax 
+                                         name
+                                         (string->symbol
+                                          (string-append "set-" name-str "-" field-str "!"))))
+                                  null))))))))
+  
+  (define (build-contracts stx pred field-infos)
+    (list* (quasisyntax/loc stx
+             (-> #,@(map field-info-ctc
+                        (filter (λ (f)
+                                  (not (field-info-auto? f)))
+                                field-infos)) any/c))
+           (syntax/loc stx any/c)
+           (apply append
+                  (for/list ([finfo field-infos])
+                    (let ([field-ctc (field-info-ctc finfo)])
+                      (cons (quasisyntax/loc stx
+                              (-> #,pred #,field-ctc))
+                            (if (field-info-mutable? finfo)
+                                (list 
+                                 (quasisyntax/loc stx
+                                   (-> #,pred #,field-ctc void?)))
+                                null)))))))
 
+  (define (check-field f ctc)
+    (let ([p-list (syntax->list f)])
+      (if p-list
+          (begin 
+            (when (null? p-list)
+              (raise-syntax-error 'define-struct/contract
+                                  "expected struct field"
+                                  f))
+            (unless (identifier? (car p-list))
+              (raise-syntax-error 'define-struct/contract
+                                  "expected identifier"
+                                  f))
+            (let loop ([rest (cdr p-list)]
+                       [mutable? #f]
+                       [auto? #f])
+              (if (null? rest) 
+                  (make-field-info (car p-list) ctc mutable? auto?)
+                  (let ([elem (syntax-e (car rest))])
+                    (if (keyword? elem)
+                        (cond
+                          [(eq? elem '#:mutable)
+                           (begin (when mutable?
+                                    (raise-syntax-error 'define-struct/contract
+                                            "redundant #:mutable"
+                                            (car rest)))
+                                  (loop (cdr rest) #t auto?))]
+                          [(eq? elem '#:auto)
+                           (begin (when auto?
+                                    (raise-syntax-error 'define-struct/contract
+                                            "redundant #:mutable"
+                                            (car rest)))
+                                  (loop (cdr rest) mutable? #t))]
+                          [else (raise-syntax-error 'define-struct/contract
+                                                    "expected #:mutable or #:auto"
+                                                    (car rest))])
+                        (raise-syntax-error 'define-struct/contract
+                                            "expected #:mutable or #:auto"
+                                            (car rest)))))))
+          (if (identifier? f)
+              (make-field-info f ctc #f #f)
+              (raise-syntax-error 'define-struct/contract
+                                  "expected struct field"
+                                  f)))))
+  (define (check-kwds kwd-list field-infos)
+    (let loop ([kwds kwd-list]
+               [auto-value-stx #f]
+               [mutable? #f]
+               [transparent? #f]
+               [def-stxs? #t]
+               [def-vals? #t])
+      (if (null? kwds)
+          (make-s-info auto-value-stx transparent? def-stxs? def-vals?)
+          (let ([kwd (syntax-e (car kwds))])
+            (when (not (keyword? kwd))
+              (raise-syntax-error 'define-struct/contract
+                                  "expected a keyword"
+                                  (car kwds)))
+            (cond
+              [(eq? kwd '#:auto-value)
+               (when (null? (cdr kwd-list))
+                 (raise-syntax-error 'define-struct/contract
+                                     "expected a following expression"
+                                     (car kwds)))
+               (loop (cddr kwd-list) (cadr kwd-list)
+                     transparent? mutable? def-stxs? def-vals?)]
+              [(eq? kwd '#:mutable)
+               (when mutable?
+                 (raise-syntax-error 'define-struct/contract
+                                     "redundant #:mutable"
+                                     (car kwds)))
+               (for ([finfo field-infos])
+                    (set-field-info-mutable?! finfo #t))
+               (loop (cdr kwd-list) auto-value-stx
+                     transparent? #t def-stxs? def-vals?)]
+              [(eq? kwd '#:transparent)
+               (when transparent?
+                 (raise-syntax-error 'define-struct/contract
+                                     "redundant #:transparent"
+                                     (car kwds)))
+               (loop (cdr kwd-list) auto-value-stx
+                     #t mutable? def-stxs? def-vals?)]
+              [(eq? kwd '#:omit-define-syntaxes)
+               (when (not def-stxs?)
+                 (raise-syntax-error 'define-struct/contract
+                                     "redundant #:omit-define-syntaxes"
+                                     (car kwds)))
+               (loop (cdr kwd-list) auto-value-stx
+                     transparent? mutable? #f def-vals?)]
+              [(eq? kwd '#:omit-define-values)
+               (when (not def-vals?)
+                 (raise-syntax-error 'define-struct/contract
+                                     "redundant #:omit-define-values"
+                                     (car kwds)))
+               (loop (cdr kwd-list) auto-value-stx
+                     transparent? mutable? def-stxs? #f)]
+              [else (raise-syntax-error 'define-struct/contract
+                                        "unexpected keyword"
+                                        (car kwds))])))))
+  (syntax-case stx ()
+    [(_ name ([field ctc] ...) kwds ...)
+     (let ([fields (syntax->list #'(field ...))])
+       (unless (identifier? #'name)
+         (raise-syntax-error 'define-struct/contract
+                             "expected identifier for struct name"
+                             #'name))
+       (let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))]
+              [sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)]
+              [names (build-struct-names #'name field-infos)]
+              [pred (caddr names)]
+              [ctcs (build-contracts stx pred field-infos)])
+         (let-values ([(non-auto-fields auto-fields)
+                       (let loop ([fields field-infos]
+                                  [nautos null]
+                                  [autos null])
+                         (if (null? fields)
+                             (values (reverse nautos)
+                                     (reverse autos))
+                             (if (field-info-auto? (car fields))
+                                 (loop (cdr fields)
+                                       nautos
+                                       (cons (car fields) autos))
+                                 (if (null? autos)
+                                     (loop (cdr fields)
+                                           (cons (car fields) nautos)
+                                           autos)
+                                     (raise-syntax-error 'define-struct/contract
+                                                         "non-auto field after auto fields"
+                                                         (field-info-stx (car fields)))))))])
+           (with-syntax ([ctc-bindings
+                          (let ([val-bindings (if (s-info-def-vals? sinfo)
+                                                  (map list (cdr names) ctcs)
+                                                  null)])
+                            (if (s-info-def-stxs? sinfo)
+                                (cons (car names) val-bindings)
+                                val-bindings))]
+                         [orig stx]
+                         [(auto-check ...)
+                          (let* ([av-stx (if (s-info-auto-value-stx sinfo)
+                                             (s-info-auto-value-stx sinfo)
+                                             #'#f)]
+                                 [av-id (datum->syntax av-stx
+                                                       (string->symbol
+                                                        (string-append (symbol->string (syntax-e #'name))
+                                                                       ":auto-value"))
+                                                       av-stx)])
+                            (for/list ([finfo auto-fields])
+                              #`(let ([#,av-id #,av-stx])
+                                  (-contract #,(field-info-ctc finfo)
+                                             #,av-id
+                                             '(struct name)
+                                             'cant-happen
+                                             #,(id->contract-src-info av-id)))))]
+                         [(non-auto-name ...)
+                          (map field-info-stx non-auto-fields)])
+             (syntax/loc stx
+               (begin
+                 (define-values () (begin auto-check ... (values)))
+                 (with-contract #:type struct name
+                   ctc-bindings
+                   (define-struct/derived orig name (field ...)
+                     kwds ...
+                     #:guard (λ (non-auto-name ... struct-name)
+                               (unless (eq? 'name struct-name)
+                                 (error (format "Cannot create subtype ~a of contracted struct ~a" 
+                                                struct-name 'name)))
+                               (values non-auto-name ...))))))))))]
+    [(_ name . bad-fields)
+     (identifier? #'name)
+     (raise-syntax-error 'define-struct/contract
+                         "expected a list of field name/contract pairs"
+                         #'bad-fields)]
+    [(_ . body)
+     (raise-syntax-error 'define-struct/contract
+                         "expected a structure name"
+                         #'body)]))
 
 ;                                                                                         
 ;                                                                                         
@@ -148,149 +386,75 @@ improve method arity mismatch contract violation error messages?
                               (syntax id))]
          [(f arg ...)
           (quasisyntax/loc stx
-            ((let ([f (-contract contract-stx
-                                 #,id
-                                 pos-blame-id
-                                 neg-blame-id
-                                 #,(id->contract-src-info id))])
-               f) arg ...))]
+            ((-contract contract-stx
+                        #,id
+                        pos-blame-id
+                        neg-blame-id
+                        #,(id->contract-src-info id))
+             arg ...))]
          [ident
           (identifier? (syntax ident))
           (quasisyntax/loc stx
-            (let ([ident (-contract contract-stx
-                                    #,id
-                                    pos-blame-id
-                                    neg-blame-id
-                                    #,(id->contract-src-info id))])
-              ident))])))))
+            (-contract contract-stx
+                       #,id
+                       pos-blame-id
+                       neg-blame-id
+                       #,(id->contract-src-info id)))])))))
 
-(define-for-syntax (partition-ids def-ids p/c-pairs unprotected-ids)
-  (let loop ([ids         def-ids]
-             [used-p/cs   null]
-             [used-us     null]
-             [unused-p/cs p/c-pairs]
-             [unused-us   unprotected-ids])
-    (if (null? ids)
-        (values used-p/cs used-us unused-p/cs unused-us)
-        (let*-values ([(first-id) (car ids)]
-                      [(matched no-match)
-                       (partition (λ (i)
-                                    (bound-identifier=? i first-id))
-                                  unused-us)])
-          (if (null? matched)
-              (let-values ([(matched no-match)
-                            (partition (λ (p/c)
-                                         (bound-identifier=? (car p/c) first-id))
-                                       unused-p/cs)])
-                (if (null? matched)
-                    (loop (cdr ids)
-                          used-p/cs
-                          used-us
-                          unused-p/cs
-                          unused-us)
-                    (loop (cdr ids)
-                          (append matched used-p/cs)
-                          used-us
-                          no-match
-                          unused-us)))
-              (loop (cdr ids)
-                    used-p/cs
-                    (append matched used-us)
-                    unused-p/cs
-                    no-match))))))
 
 (define-syntax (with-contract-helper stx)
   (syntax-case stx ()
-    [(_ marker blame-stx () ())
+    [(_ blame-stx () ())
      (begin #'(define-values () (values)))]
-    [(_ marker blame-stx ((p0 c0) (p c) ...) (u ...))
+    [(_ blame-stx (p0 p ...) (u ...))
      (raise-syntax-error 'with-contract
                          "no definition found for identifier"
                          #'p0)]
-    [(_ marker blame-stx () (u0 u ...))
+    [(_ blame-stx () (u0 u ...))
      (raise-syntax-error 'with-contract
                          "no definition found for identifier"
                          #'u0)]
-    [(_ marker blame-stx ((p c) ...) (u ...) body0 body ...)
+    [(_ blame-stx (p ...) (u ...) body0 body ...)
      (let ([expanded-body0 (local-expand #'body0
                                          (syntax-local-context)
-                                         (cons #'splicing-syntax-parameterize
-                                               (kernel-form-identifier-list)))])
-       (syntax-case expanded-body0 (begin define-values)
+                                         (kernel-form-identifier-list))])
+       (define (filter-ids to-filter to-remove)
+         (filter (λ (i1)
+                   (not (memf (λ (i2)
+                                (bound-identifier=? i1 i2))
+                              to-remove)))
+                 to-filter))
+       (syntax-case expanded-body0 (begin define-values define-syntaxes)
          [(begin sub ...)
           (syntax/loc stx
-            (with-contract-helper marker blame-stx ((p c) ...) (u ...) sub ... body ...))]
+            (with-contract-helper blame-stx (p ...) (u ...) sub ... body ...))]
+         [(define-syntaxes (id ...) expr)
+          (let ([ids (syntax->list #'(id ...))])
+            (for ([i1 (syntax->list #'(p ...))])
+                 (when (ormap (λ (i2)
+                                (bound-identifier=? i1 i2))
+                              ids)
+                   (raise-syntax-error 'with-contract
+                                       "cannot export syntax with a contract"
+                                       i1)))
+            (with-syntax ([def expanded-body0]
+                          [unused-us (filter-ids (syntax->list #'(u ...)) ids)])
+              (with-syntax ()
+                (syntax/loc stx
+                  (begin def (with-contract-helper blame-stx (p ...) unused-us body ...))))))]
          [(define-values (id ...) expr)
-          (let*-values ([(marker-f) (let ([marker (syntax-e #'marker)])
-                                      (lambda (stx)
-                                        (syntax-local-introduce
-                                         (marker (syntax-local-introduce stx)))))]
-                        [(used-p/cs used-us unused-p/cs unused-us)
-                         (partition-ids (syntax->list #'(id ...)) 
-                                        (map syntax->list (syntax->list #'((p c) ...)))
-                                        (syntax->list #'(u ...)))])
-            (with-syntax ([(u-def ...)
-                           (map (λ (u)
-                                  #`(define-syntaxes (#,u)
-                                      (make-rename-transformer (quote-syntax #,(marker-f u)))))
-                                used-us)]
-                          [(p/c-def ...)
-                           (apply append
-                                  (map (λ (p/c)
-                                         (let* ([p (car p/c)]
-                                                [c (cadr p/c)]
-                                                [contract-id
-                                                 (if (a:known-good-contract? c)
-                                                     #f
-                                                     (marker-f (a:mangle-id stx "with-contract-contract-id" p)))]
-                                                [always-defined
-                                                 (list #`(define-syntaxes (#,p)
-                                                           (make-with-contract-transformer
-                                                            (quote-syntax #,(if contract-id contract-id c))
-                                                            (quote-syntax #,(marker-f p))
-                                                            (quote-syntax blame-stx)))
-                                                       #`(define-values ()
-                                                           (begin
-                                                             (-contract #,(if contract-id contract-id c)
-                                                                        #,(marker-f p)
-                                                                        blame-stx
-                                                                        'cant-happen
-                                                                        #,(id->contract-src-info p))
-                                                             (values))))])
-                                           (if contract-id
-                                               (cons #`(define-values (#,contract-id)
-                                                         (verify-contract 'with-contract #,(marker-f c)))
-                                                     always-defined)
-                                               always-defined)))
-                                       used-p/cs))])
-              (quasisyntax/loc stx
-                (begin #,(marker-f expanded-body0)
-                       u-def ... p/c-def ...
-                       (with-contract-helper marker blame-stx #,unused-p/cs #,unused-us
-                                             body ...)))))]
-         [(splicing-syntax-parameterize bindings . ssp-body)
-          (let* ([marker-f (let ([marker (syntax-e #'marker)])
-                             (lambda (stx)
-                               (syntax-local-introduce
-                                (marker (syntax-local-introduce stx)))))]
-                 [expanded-ssp (local-expand (quasisyntax/loc expanded-body0
-                                               (splicing-syntax-parameterize bindings .
-                                                 #,(marker-f #'ssp-body)))
-                                             (syntax-local-context)
-                                             (kernel-form-identifier-list))])
-            (quasisyntax/loc stx
-              (begin #,expanded-ssp
-                     (with-contract-helper marker blame-stx ((p c) ...) (u ...) body ...))))]
+          (let ([ids (syntax->list #'(id ...))])
+            (with-syntax ([def expanded-body0]
+                          [unused-ps (filter-ids (syntax->list #'(p ...)) ids)]
+                          [unused-us (filter-ids (syntax->list #'(u ...)) ids)])
+              (syntax/loc stx
+                (begin def (with-contract-helper blame-stx unused-ps unused-us body ...)))))]
          [else
-          (let*-values ([(marker-f) (let ([marker (syntax-e #'marker)])
-                                      (lambda (stx)
-                                        (syntax-local-introduce
-                                         (marker (syntax-local-introduce stx)))))])
-            (quasisyntax/loc stx
-              (begin #,(marker-f expanded-body0)
-                     (with-contract-helper marker blame-stx ((p c) ...) (u ...) body ...))))]))]))
+          (quasisyntax/loc stx
+            (begin #,expanded-body0
+                   (with-contract-helper blame-stx (p ...) (u ...) body ...)))]))]))
 
-(define-for-syntax (check-and-split-with-contract-args args)
+(define-for-syntax (check-and-split-with-contracts single-allowed? args)
   (let loop ([args args]
              [unprotected null]
              [protected null]
@@ -299,6 +463,10 @@ improve method arity mismatch contract violation error messages?
       [(null? args)
        (values unprotected protected protections)]
       [(identifier? (car args))
+       (unless single-allowed?
+         (raise-syntax-error 'with-contract
+                           "expected (identifier contract)"
+                           (car args)))
        (loop (cdr args)
              (cons (car args) unprotected)
              protected
@@ -316,21 +484,69 @@ improve method arity mismatch contract violation error messages?
                (cons (second l) protections)))]
       [else
        (raise-syntax-error 'with-contract
-                           "expected an identifier or (identifier contract)"
+                           (format "expected ~a(identifier contract)"
+                                   (if single-allowed? "an identifier or " ""))
                            (car args))])))
 
+(define-for-syntax (make-free-var-transformer fv ctc pos-blame neg-blame)
+  (make-set!-transformer
+   (lambda (stx)
+     (syntax-case stx (set!)
+       [(set! id arg)
+        (raise-syntax-error 'with-contract
+                            "cannot set! a contracted variable"
+                            stx
+                            (syntax id))]
+       [(f arg ...)
+        (quasisyntax/loc stx
+          ((-contract #,ctc
+                      #,fv
+                      #,pos-blame
+                      #,neg-blame
+                      #,(id->contract-src-info fv))
+           arg ...))]
+       [ident
+        (identifier? (syntax ident))
+        (quasisyntax/loc stx
+          (-contract #,ctc
+                     #,fv
+                     #,pos-blame
+                     #,neg-blame
+                     #,(id->contract-src-info fv)))]))))
+
 (define-syntax (with-contract stx)
   (when (eq? (syntax-local-context) 'expression)
     (raise-syntax-error 'with-contract
                         "used in expression context"
                         stx))
   (syntax-case stx ()
-    [(_ #:type type blame (arg ...) body0 . body)
+    [(_ #:type type etc ...)
+     (not (identifier? #'type))
+     (raise-syntax-error 'with-contract
+                         "expected identifier for type"
+                         #'type)]
+    [(_ #:type type args etc ...)
+     (not (identifier? #'args))
+     (raise-syntax-error 'with-contract
+                         "expected identifier for blame"
+                         #'args)]
+    [(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body)
+     (identifier? #'x)
+     (syntax/loc stx
+       (with-contract #:type type blame (arg ...) #:freevars (fv ... [x c]) . body))]
+    [(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body)
+     (raise-syntax-error 'with-contract
+                         "use of #:freevar with non-identifier"
+                         #'x)]
+    [(_ #:type type blame (arg ...) #:freevars (fv ...) . body)
      (and (identifier? #'blame)
           (identifier? #'type))
      (let*-values ([(marker) (make-syntax-introducer)]
+                   [(cid-marker) (make-syntax-introducer)]
+                   [(no-need free-vars free-ctcs)
+                    (check-and-split-with-contracts #f (syntax->list #'(fv ...)))]
                    [(unprotected protected protections)
-                    (check-and-split-with-contract-args (syntax->list #'(arg ...)))])
+                    (check-and-split-with-contracts #t (syntax->list #'(arg ...)))])
        (begin
          (let ([dupd-id (check-duplicate-identifier (append unprotected protected))])
            (when dupd-id
@@ -338,35 +554,73 @@ improve method arity mismatch contract violation error messages?
                                  "identifier appears twice in exports"
                                  dupd-id)))
          (with-syntax ([blame-stx #''(type blame)]
-                       [((p c) ...) (map list protected protections)]
-                       [(u ...) unprotected])
+                       [blame-id (car (generate-temporaries (list #t)))]
+                       [(free-var ...) free-vars]
+                       [(free-var-id ...) (map marker free-vars)]
+                       [(free-ctc-id ...) (map cid-marker free-vars)]
+                       [(free-ctc ...) (map (λ (c v)
+                                              (syntax-property c 'inferred-name v))
+                                            free-ctcs
+                                            free-vars)]
+                       [(free-src-info ...) (map id->contract-src-info free-vars)]
+                       [(ctc-id ...) (map cid-marker protected)]
+                       [(ctc ...) (map (λ (c v)
+                                         (marker (syntax-property c 'inferred-name v)))
+                                       protections
+                                       protected)]
+                       [(p ...) protected]
+                       [(marked-p ...) (map marker protected)]
+                       [(src-info ...) (map (compose id->contract-src-info marker) protected)]
+                       [(u ...) unprotected]
+                       [(marked-u ...) (map marker unprotected)])
            (quasisyntax/loc stx
-             (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)])
-               (with-contract-helper #,marker blame-stx ((p c) ...) (u ...) body0 . body))))))]
-    [(_ #:type type blame (arg ...) body0 body ...)
-     (raise-syntax-error 'with-contract
-                         "expected identifier for blame"
-                         #'blame)]
-    [(_ #:type type blame (arg ...))
-     (identifier? #'blame)
-     (raise-syntax-error 'with-contract
-                         "empty body"
-                         stx)]
+             (begin
+               (define-values (free-ctc-id ...)
+                 (values (verify-contract 'with-contract free-ctc) ...))
+               (define blame-id
+                 (current-contract-region))
+               (define-values ()
+                 (begin (-contract free-ctc-id
+                                   free-var
+                                   blame-id
+                                   'cant-happen
+                                   free-src-info)
+                        ...
+                        (values)))
+               (define-syntaxes (free-var-id ...)
+                 (values (make-free-var-transformer
+                          (quote-syntax free-var)
+                          (quote-syntax free-ctc-id)
+                          (quote-syntax blame-id)
+                          (quote-syntax blame-stx)) ...))
+               (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)])
+                 (with-contract-helper blame-stx (marked-p ...) (marked-u ...) . #,(marker #'body)))
+               (define-values (ctc-id ...)
+                 (values (verify-contract 'with-contract ctc) ...))
+               (define-values ()
+                 (begin (-contract ctc-id
+                                   marked-p
+                                   blame-stx
+                                   'cant-happen
+                                   src-info)
+                        ...
+                        (values)))
+               (define-syntaxes (u ... p ...)
+                 (values (make-rename-transformer #'marked-u) ...
+                         (make-with-contract-transformer
+                          (quote-syntax ctc-id)
+                          (quote-syntax marked-p)
+                          (quote-syntax blame-stx)) ...)))))))]
+    [(_ #:type type blame (arg ...) #:freevar x c . body)
+     (syntax/loc stx
+       (with-contract #:type type blame (arg ...) #:freevars ([x c]) . body))]
+    [(_ #:type type blame (arg ...) . body)
+     (syntax/loc stx
+       (with-contract #:type type blame (arg ...) #:freevars () . body))]
     [(_ #:type type blame bad-args etc ...)
-     (identifier? #'blame)
      (raise-syntax-error 'with-contract
                          "expected list of identifier and/or (identifier contract)"
                          #'bad-args)]
-    [(_ #:type type args etc ...)
-     (not (identifier? #'args))
-     (raise-syntax-error 'with-contract
-                         "expected identifier for blame"
-                         #'args)]
-    [(_ #:type type etc ...)
-     (not (identifier? #'type))
-     (raise-syntax-error 'with-contract
-                         "expected identifier for type"
-                         #'type)]
     [(_ #:type type blame)
      (raise-syntax-error 'with-contract
                          "only blame"
diff --git a/collects/scheme/private/struct-info.ss b/collects/scheme/private/struct-info.ss
index 16e38f8f47..8ccef0325c 100644
--- a/collects/scheme/private/struct-info.ss
+++ b/collects/scheme/private/struct-info.ss
@@ -39,12 +39,16 @@
                   (error 'extract-struct-info
                          "struct-info procedure result not properly formed: ~e"
                          v))))
-          si)))
+          (if (set!-transformer? si)
+              (extract-struct-info (set!-transformer-procedure si))
+              si))))
 
   (define-values (struct-info?)
     (lambda (si)
       (or (struct-info-rec? si)
-          (struct-declaration-info? si))))
+          (struct-declaration-info? si)
+          (and (set!-transformer? si)
+               (struct-info-rec? (set!-transformer-procedure si))))))
 
   (define-values (struct-declaration-info?)
     (lambda (x)
diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss
index 92c53027e1..df7b0766c8 100644
--- a/collects/scheme/sandbox.ss
+++ b/collects/scheme/sandbox.ss
@@ -408,10 +408,9 @@
          [orig-ns (namespace-anchor->empty-namespace anchor)]
          [mods    (cdr specs)])
     (parameterize ([current-namespace orig-ns])
-      (for-each (lambda (mod) (dynamic-require mod #f)) mods))
+      (for ([mod (in-list mods)]) (dynamic-require mod #f)))
     (parameterize ([current-namespace new-ns])
-      (for-each (lambda (ms) (namespace-attach-module orig-ns ms))
-                mods))
+      (for ([mod (in-list mods)]) (namespace-attach-module orig-ns mod)))
     new-ns))
 
 (define (extract-required language requires)
@@ -457,7 +456,7 @@
                                    (list source n (and n 0) n (and n 1)))
                                   r))))]))))
 
-(define ((init-for-language language))
+(define ((init-hook-for-language language))
   (cond [(or (not (pair? language))
              (not (eq? 'special (car language))))
          (void)]
@@ -468,7 +467,12 @@
          (read-accept-infix-dot #f)]
         [(memq (cadr language) teaching-langs)
          (read-case-sensitive #t)
-         (read-decimal-as-inexact #f)]))
+         (read-decimal-as-inexact #f)
+         ;; needed to make the test-engine work
+         (let ([orig-ns (namespace-anchor->empty-namespace anchor)])
+           (parameterize ([current-namespace orig-ns])
+             (dynamic-require 'scheme/class #f))
+           (namespace-attach-module orig-ns 'scheme/class))]))
 
 ;; Returns a single (module ...) or (begin ...) expression (a `begin' list
 ;; will be evaluated one by one -- the language might not have a `begin').
@@ -509,17 +513,16 @@
   (call-with-continuation-prompt
    (lambda ()
      (if (null? exprs)
-         (void)
-         (let ([deftag (default-continuation-prompt-tag)])
-           (let loop ([expr (car exprs)] [exprs (cdr exprs)])
-             (if (null? exprs)
-                 (eval expr)
-                 (begin
-                   (call-with-continuation-prompt
-                    (lambda () (eval expr))
-                    deftag
-                    (lambda (x) (abort-current-continuation deftag x)))
-                   (loop (car exprs) (cdr exprs))))))))))
+       (void)
+       (let ([deftag (default-continuation-prompt-tag)])
+         (let loop ([expr (car exprs)] [exprs (cdr exprs)])
+           (if (null? exprs)
+             (eval expr)
+             (begin (call-with-continuation-prompt
+                     (lambda () (eval expr))
+                     deftag
+                     (lambda (x) (abort-current-continuation deftag x)))
+                    (loop (car exprs) (cdr exprs))))))))))
 
 ;; We need a powerful enough code inspector to invoke the errortrace library
 ;; (indirectly through private/sandbox-coverage).  But there is a small problem
@@ -532,8 +535,8 @@
 (define orig-code-inspector (current-code-inspector))
 
 (define (evaluate-program program limit-thunk uncovered!)
-  (parameterize ([current-code-inspector orig-code-inspector])
-    (when uncovered!
+  (when uncovered!
+    (parameterize ([current-code-inspector orig-code-inspector])
       (eval `(,#'#%require scheme/private/sandbox-coverage))))
   (let ([ns (syntax-case* program (module) literal-identifier=?
               [(module mod . body)
@@ -687,9 +690,11 @@
                   [(thunk) (limit-thunk (car (evaluator-message-args expr)))]
                   [(thunk*) (car (evaluator-message-args expr))]
                   [else (error 'sandbox "internal error (bad message)")])
-                (limit-thunk (lambda ()
-                               (set! n (add1 n))
-                               (eval* (input->code (list expr) 'eval n))))))
+                (limit-thunk
+                 (lambda ()
+                   (set! n (add1 n))
+                   (eval* (map (lambda (expr) (cons '#%top-interaction expr))
+                               (input->code (list expr) 'eval n)))))))
             (channel-put result-ch (cons 'vals (call-with-values run list))))
           (loop)))))
   (define (get-user-result)
@@ -877,7 +882,7 @@
                          r
                          `(file ,(path->string (simplify-path* r)))))
                      requires))])
-    (make-evaluator* (init-for-language lang)
+    (make-evaluator* (init-hook-for-language lang)
                      (append (extract-required (or (decode-language lang) lang)
                                                reqs)
                              allow)
diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss
index 0279f549ab..df0ca9e429 100644
--- a/collects/scribble/base-render.ss
+++ b/collects/scribble/base-render.ss
@@ -47,6 +47,30 @@
 
     ;; ----------------------------------------
 
+    (define/public (extract-part-style-files d tag stop-at-part?)
+      (let loop ([p d])
+        (let ([s (part-style p)])
+          (apply
+           append
+           (if (list? s)
+               (filter
+                values
+                (map (lambda (s)
+                       (and (list? s)
+                            (= 2 (length s))
+                            (eq? (car s) tag)
+                            (path-string? (cadr s))
+                            (cadr s)))
+                     s))
+               null)
+           (map (lambda (p)
+                  (if (stop-at-part? p)
+                      null
+                      (loop p)))
+                (part-parts p))))))
+  
+    ;; ----------------------------------------
+
     (define root (make-mobile-root root-path))
     
     (define-values (:path->root-relative
diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss
index d90ae6f127..80aed345a0 100644
--- a/collects/scribble/basic.ss
+++ b/collects/scribble/basic.ss
@@ -213,8 +213,8 @@
             h))
       (make-element 'hspace (list (make-string n #\space)))))
 
-(define (elem . str)
-  (make-element #f (decode-content str)))
+(define (elem #:style [style #f] . str)
+  (make-element style (decode-content str)))
 
 (define (aux-elem . s)
   (make-aux-element #f (decode-content s)))
diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
index d140e03e62..2f1bf1556f 100644
--- a/collects/scribble/html-render.ss
+++ b/collects/scribble/html-render.ss
@@ -4,6 +4,7 @@
          scheme/class
          scheme/path
          scheme/file
+         scheme/port
          scheme/list
          scheme/string
          mzlib/runtime-path
@@ -43,6 +44,7 @@
                "\n"))))
 
 (define-runtime-path scribble-css "scribble.css")
+(define-runtime-path scribble-prefix-html "scribble-prefix.html")
 (define-runtime-path scribble-js  "scribble-common.js")
 ;; utilities for render-one-part
 (define-values (scribble-css-contents scribble-js-contents)
@@ -232,13 +234,15 @@
              install-file
              get-dest-directory
              format-number
-             quiet-table-of-contents)
+             quiet-table-of-contents
+             extract-part-style-files)
 
     (init-field [css-path #f]
                 ;; up-path is either a link "up", or #t which uses
                 ;; goes to start page (using cookies to get to the
                 ;; user start page)
                 [up-path #f]
+                [prefix-file #f]
                 [style-file #f]
                 [style-extra-files null]
                 [script-path #f]
@@ -568,21 +572,34 @@
           (versioned-part-version d)
           (current-version)))
 
+    (define/public (extract-part-body-id d ri)
+      (or
+       (and (list? (part-style d))
+            (ormap (lambda (s)
+                     (and (list? s)
+                          (= 2 (length s))
+                          (eq? (car s) 'body-id)
+                          (string? (cadr s))
+                          (cadr s)))
+                   (part-style d)))
+       (let ([p (part-parent d ri)])
+         (and p (extract-part-body-id p ri)))))
+
     (define/public (render-one-part d ri fn number)
       (parameterize ([current-output-file fn])
-        (let* ([style-file  (or style-file scribble-css)]
+        (let* ([prefix-file (or prefix-file scribble-prefix-html)]
+               [style-file (or style-file scribble-css)]
                [script-file (or script-file scribble-js)]
                [title (cond [(part-title-content d)
                              => (lambda (c)
                                   `(title ,@(format-number number '(nbsp))
                                           ,(content->string c this d ri)))]
                             [else `(title)])])
-          (unless css-path    (install-file style-file))
-          (for-each (lambda (f) (install-file f)) style-extra-files)
+          (unless css-path   (install-file style-file))
           (unless script-path (install-file script-file))
-          (printf "<!DOCTYPE html PUBLIC ~s ~s>\n"
-                  "-//W3C//DTD HTML 4.0 Transitional//EN"
-                  "http://www.w3.org/TR/html4/loose.dtd")
+          (call-with-input-file* prefix-file
+            (lambda (in)
+              (copy-port in (current-output-port))))
           (xml:write-xml/content
            (xml:xexpr->xml
             `(html ()
@@ -592,10 +609,16 @@
                  ,title
                  ,(scribble-css-contents style-file  css-path)
                  ,@(map (lambda (style-file)
-                          (scribble-css-contents style-file  css-path))
-                        style-extra-files)
+                          (install-file style-file)
+                          (scribble-css-contents style-file #f))
+                        (append style-extra-files
+                                (extract-part-style-files
+                                 d
+                                 'css
+                                 (lambda (p) (part-whole-page? p ri)))))
                  ,(scribble-js-contents  script-file script-path))
-               (body ()
+               (body ((id ,(or (extract-part-body-id d ri)
+                               "scribble-plt-scheme-org")))
                  ,@(render-toc-view d ri)
                  (div ([class "maincolumn"])
                    (div ([class "main"])
@@ -1011,8 +1034,8 @@
                              (if (path? p)
                                (url->string (path->url (path->complete-path p)))
                                p))]
-                     . ,(attribs))
-                    ,@sz)))]
+                     ,@(attribs)
+                     ,@sz))))]
           [else (render*)])))
 
     (define/override (render-table t part ri need-inline?)
@@ -1021,22 +1044,24 @@
                           (with-attributes-style raw-style)
                           raw-style))
       (define t-style-get (if (and (pair? t-style) (list? t-style))
-                            (lambda (k) (assoc k t-style))
-                            (lambda (k) #f)))
+                              (lambda (k) (assoc k t-style))
+                              (lambda (k) #f)))
       (define (make-row flows style)
-        `(tr (,@(if style `([class ,style]) null))
+        `(tr (,@(if (string? style) `([class ,style]) null))
            ,@(let loop ([ds flows]
-                        [as (cdr (or (t-style-get 'alignment)
+                        [as (cdr (or (and (list? style) (assq 'alignment style))
                                      (cons #f (map (lambda (x) #f) flows))))]
-                        [vas (cdr (or (t-style-get 'valignment)
+                        [vas (cdr (or (and (list? style) (assq 'valignment style))
+                                      (cons #f (map (lambda (x) #f) flows))))]
+                        [sts (cdr (or (and (list? style) (assq 'style style))
                                       (cons #f (map (lambda (x) #f) flows))))]
                         [first? #t])
                (cond
                  [(null? ds) null]
                  [(eq? (car ds) 'cont)
-                  (loop (cdr ds) (cdr as) (cdr vas) first?)]
+                  (loop (cdr ds) (cdr as) (cdr vas) (cdr sts) first?)]
                  [else
-                  (let ([d (car ds)] [a (car as)] [va (car vas)])
+                  (let ([d (car ds)] [a (car as)] [va (car vas)] [st (car sts)])
                     (cons
                      `(td (,@(case a
                                [(#f) null]
@@ -1048,6 +1073,9 @@
                                [(top) '((valign "top"))]
                                [(baseline) '((valign "baseline"))]
                                [(bottom) '((valign "bottom"))])
+                           ,@(if (string? st)
+                                 `([class ,st])
+                                 null)
                            ,@(if (and (pair? (cdr ds))
                                       (eq? 'cont (cadr ds)))
                                `([colspan
@@ -1062,7 +1090,7 @@
                                      (omitable-paragraph? (car (flow-paragraphs d))))
                                 (render-content (paragraph-content (car (flow-paragraphs d))) part ri)
                                 (render-flow d part ri #f)))
-                     (loop (cdr ds) (cdr as) (cdr vas) #f)))]))))
+                     (loop (cdr ds) (cdr as) (cdr vas) (cdr sts) #f)))]))))
       `((table ([cellspacing "0"]
                 ,@(if need-inline?
                     '([style "display: inline-table; vertical-align: text-top;"])
diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss
index 0c6724b273..19ff53071b 100644
--- a/collects/scribble/latex-render.ss
+++ b/collects/scribble/latex-render.ss
@@ -17,6 +17,7 @@
 
 (define-struct (toc-paragraph paragraph) ())
 
+(define-runtime-path scribble-prefix-tex "scribble-prefix.tex")
 (define-runtime-path scribble-tex "scribble.tex")
 
 (define (gif-to-png p)
@@ -26,7 +27,8 @@
 
 (define (render-mixin %)
   (class %
-    (init-field [style-file #f]
+    (init-field [prefix-file #f]
+                [style-file #f]
                 [style-extra-files null])
 
     (define/override (get-suffix) #".tex")
@@ -35,16 +37,23 @@
              render-block
              render-content
              install-file
-             format-number)
+             format-number
+             extract-part-style-files)
 
     (define/override (render-one d ri fn)
-      (let ([style-file (or style-file scribble-tex)])
+      (let ([style-file (or style-file scribble-tex)]
+            [prefix-file (or prefix-file scribble-prefix-tex)])
         (for-each
          (lambda (style-file)
            (with-input-from-file style-file
              (lambda ()
                (copy-port (current-input-port) (current-output-port)))))
-         (cons style-file style-extra-files))
+         (list* prefix-file style-file 
+                (append style-extra-files
+                        (extract-part-style-files
+                         d
+                         'tex
+                         (lambda (p) #f)))))
         (printf "\\begin{document}\n\\preDoc\n")
         (when (part-title-content d)
           (let ([m (ormap (lambda (v)
@@ -136,7 +145,7 @@
             (printf "\\label{t:~a}"
                     (t-encode (tag-key (target-element-tag e) ri))))
           (when part-label?
-            (printf "\\S")
+            (printf "\\SecRef{")
             (render-content
              (let ([dest (resolve-get part ri (link-element-tag e))])
                (if dest
@@ -149,7 +158,7 @@
                           '("!!!")))
                  (list "???")))
              part ri)
-            (printf " ``"))
+            (printf "}{"))
           (let ([style (and (element? e)
                             (let ([s (flatten-style (element-style e))])
                               (if (with-attributes? s)
@@ -206,7 +215,7 @@
                            (image-file-scale style) fn)))]
               [else (super render-element e part ri)])))
         (when part-label?
-          (printf "''"))
+          (printf "}"))
         (when (and (link-element? e)
                    (show-link-page-numbers)
                    (not (done-link-page-numbers)))
@@ -228,14 +237,6 @@
     (define/override (render-table t part ri inline-table?)
       (let* ([boxed? (eq? 'boxed (table-style t))]
              [index? (eq? 'index (table-style t))]
-             [inline?
-              (and (not boxed?) (not index?)
-                   (or (null? (table-flowss t))
-                       (= 1 (length (car (table-flowss t)))))
-                   (let ([m (current-table-mode)])
-                     (and m
-                          (equal? "bigtabular" (car m))
-                          (= 1 (length (car (table-flowss (cadr m))))))))]
              [tableform
               (cond [index? "list"]
                     [(and (not (current-table-mode)) (not inline-table?))
@@ -244,7 +245,24 @@
              [opt (cond [(equal? tableform "bigtabular") "[l]"]
                         [(equal? tableform "tabular") "[t]"]
                         [else ""])]
-             [flowss (if index? (cddr (table-flowss t)) (table-flowss t))])
+             [flowss (if index? (cddr (table-flowss t)) (table-flowss t))]
+             [row-styles (cdr (or (and (list? (table-style t))
+                                       (assoc 'row-styles (table-style t)))
+                                  (cons #f (map (lambda (x) #f) flowss))))]
+             [inline?
+              (and (not boxed?) 
+                   (not index?)
+                   (ormap (lambda (rs) (equal? rs "inferencetop")) row-styles)
+                   (or (null? (table-flowss t))
+                       (= 1 (length (car (table-flowss t)))))
+                   (let ([m (current-table-mode)])
+                     (and m
+                          (equal? "bigtabular" (car m))
+                          (= 1 (length (car (table-flowss (cadr m))))))))]
+             [boxline "{\\setlength{\\unitlength}{\\linewidth}\\begin{picture}(1,0)\\put(0,0){\\line(1,0){1}}\\end{picture}}"]
+             [twidth (if (null? (table-flowss t))
+                         1
+                         (length (car (table-flowss t))))])
         (unless (or (null? flowss) (null? (car flowss)))
           (parameterize ([current-table-mode
                           (if inline? (current-table-mode) (list tableform t))]
@@ -254,14 +272,7 @@
               [index? (printf "\\begin{list}{}{\\parsep=0pt \\itemsep=1pt \\leftmargin=2ex \\itemindent=-2ex}\n")]
               [inline? (void)]
               [else
-               (printf "\n\n~a\\begin{~a}~a{@{}~a}\n"
-                       (if boxed?
-                         (format "{~a\\begin{picture}(1,0)\\put(0,0){\\line(1,0){1}}\\end{picture}}~a\n\\nopagebreak\n"
-                                 "\\setlength{\\unitlength}{\\linewidth}"
-                                 (if (equal? tableform "bigtabular")
-                                   "\\bigtabline"
-                                   "\n\n"))
-                         "")
+               (printf "\n\n\\begin{~a}~a{@{}~a}\n~a"
                        tableform
                        opt
                        (string-append*
@@ -276,15 +287,22 @@
                                            (assoc 'alignment
                                                   (or (table-style t) null)))
                                       (cons #f (map (lambda (x) #f)
-                                                    (car flowss))))))))])
+                                                    (car flowss)))))))
+                       (if boxed? 
+                           (if (equal? tableform "bigtabular")
+                               (format "~a \\endfirsthead\n" boxline)
+                               (format "\\multicolumn{~a}{@{}l@{}}{~a} \\\\\n" 
+                                       (length (car flowss))
+                                       boxline))
+                           ""))])
             (let loop ([flowss flowss]
-                       [row-styles
-                        (cdr (or (and (list? (table-style t))
-                                      (assoc 'row-styles (table-style t)))
-                                 (cons #f (map (lambda (x) #f) flowss))))])
+                       [row-styles row-styles])
               (let ([flows (car flowss)]
                     [row-style (car row-styles)])
-                (let loop ([flows flows])
+                (let loop ([flows flows]
+                           [col-v-styles (and (list? row-style)
+                                              (let ([p (assoc 'valignment row-style)])
+                                                (and p (cdr p))))])
                   (unless (null? flows)
                     (when index? (printf "\\item "))
                     (unless (eq? 'cont (car flows))
@@ -294,10 +312,12 @@
                                           (loop (cdr flows) (add1 n))]
                                          [else n]))])
                         (unless (= cnt 1) (printf "\\multicolumn{~a}{l}{" cnt))
-                        (render-table-flow (car flows) part ri)
+                        (render-table-flow (car flows) part ri twidth (and col-v-styles
+                                                                           (car col-v-styles)))
                         (unless (= cnt 1) (printf "}"))
                         (unless (null? (list-tail flows cnt)) (printf " &\n"))))
-                    (unless (null? (cdr flows)) (loop (cdr flows)))))
+                    (unless (null? (cdr flows)) (loop (cdr flows)
+                                                      (and col-v-styles (cdr col-v-styles))))))
                 (unless (or index? (null? (cdr flowss)))
                   (printf " \\\\\n")
                   (when (equal? row-style "inferencetop") (printf "\\hline\n")))
@@ -305,27 +325,44 @@
                   (loop (cdr flowss) (cdr row-styles)))))
             (unless inline?
               (printf "~a\n\n\\end{~a}\n"
-                      (if (equal? tableform "bigtabular") "\n\\\\" "")
+                      "" ; (if (equal? tableform "bigtabular") "\n\\\\" "")
                       tableform)))))
       null)
 
-    (define/private (render-table-flow p part ri)
-      ;; Emit a \\ between blocks:
-      (let loop ([ps (flow-paragraphs p)])
-        (cond
-         [(null? ps) (void)]
-         [else
-          (let ([minipage? (not (or (paragraph? (car ps))
-                                    (table? (car ps))))])
-            (when minipage?
-              (printf "\\begin{minipage}{\\linewidth}\n"))
-            (render-block (car ps) part ri #f)
-            (when minipage?
-              (printf " \\end{minipage}\n"))
-            (unless (null? (cdr ps))
-              (printf " \\\\\n")
-              (loop (cdr ps))))]))
-      null)
+    (define/private (render-table-flow p part ri twidth vstyle)
+      ;; Emit a \\ between blocks in single-column mode,
+      ;; used a nested table otherwise for multiple elements.
+      (let ([in-table? (or (and (not (= twidth 1))
+                                ((length (flow-paragraphs p)) . > . 1))
+                           (eq? vstyle 'top))])
+        (when in-table?
+          (printf "\\begin{tabular}~a{@{}l@{}}\n"
+                  (cond
+                   [(eq? vstyle 'top) "[t]"]
+                   [else ""])))
+        (let loop ([ps (flow-paragraphs p)])
+          (cond
+           [(null? ps) (void)]
+           [else
+            (let ([minipage? (not (or (paragraph? (car ps))
+                                      (table? (car ps))))])
+              (when minipage?
+                (printf "\\begin{minipage}~a{~a\\linewidth}\n"
+                        (cond
+                         [(eq? vstyle 'top) "[t]"]
+                         [else ""])
+                        (/ 1.0 twidth)))
+              (render-block (car ps) part ri #f)
+              (when minipage?
+                (printf " \\end{minipage}\n"))
+              (unless (null? (cdr ps))
+                (printf " \\\\\n")
+                (when in-table?
+                  (printf " ~ \\\\\n"))
+                (loop (cdr ps))))]))
+        (when in-table?
+          (printf "\n\\end{tabular}\n"))
+        null))
 
     (define/override (render-itemization t part ri)
       (printf "\n\n\\begin{itemize}\n")
@@ -405,6 +442,7 @@
                  [(#\u039B) "$\\Lambda$"]
                  [(#\u03BC) "$\\mu$"]
                  [(#\u03C0) "$\\pi$"]
+                 [(#\∞) "$\\infty$"]
                  [else c])))
             (loop (add1 i))))))
 
diff --git a/collects/scribble/lp-include.ss b/collects/scribble/lp-include.ss
new file mode 100644
index 0000000000..dfc75496a8
--- /dev/null
+++ b/collects/scribble/lp-include.ss
@@ -0,0 +1,20 @@
+#lang scheme/base
+
+(require scheme/include (for-syntax scheme/base)
+          (only-in scribble/private/lp chunk)
+          scribble/manual)
+
+(provide lp-include)
+
+(define-syntax (module stx)
+  (syntax-case stx ()
+    [(module name base body ...)
+     (begin
+       #'(begin body ...))]))
+
+(define-syntax (lp-include stx)
+  (syntax-case stx ()
+    [(_ name)
+     (with-syntax ([there (datum->syntax stx 'there)])
+       #'(include-at/relative-to here there name))]))
+
diff --git a/collects/scribble/lp.ss b/collects/scribble/lp.ss
new file mode 100644
index 0000000000..eebf6cd5a2
--- /dev/null
+++ b/collects/scribble/lp.ss
@@ -0,0 +1,4 @@
+#lang scheme
+
+(require scribble/private/lp)
+(provide chunk)
diff --git a/collects/scribble/lp/lang/lang.ss b/collects/scribble/lp/lang/lang.ss
new file mode 100644
index 0000000000..7ecc7353d5
--- /dev/null
+++ b/collects/scribble/lp/lang/lang.ss
@@ -0,0 +1,89 @@
+#lang scheme/base
+
+(provide (except-out (all-from-out scheme/base) #%module-begin)
+         (rename-out [module-begin #%module-begin]))
+
+(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase
+                     syntax/strip-context))
+
+(begin-for-syntax
+  (define first-id #f)
+  (define main-id #f)
+  (define (mapping-get mapping id)
+    (free-identifier-mapping-get mapping id (lambda () '())))
+  ;; maps a chunk identifier to its collected expressions
+  (define chunks (make-free-identifier-mapping))
+  ;; maps a chunk identifier to all identifiers that are used to define it
+  (define chunk-groups (make-free-identifier-mapping))
+  (define (get-chunk id) (mapping-get chunks id))
+  (define (add-to-chunk! id exprs)
+    (unless first-id (set! first-id id))
+    (when (eq? (syntax-e id) '<*>) (set! main-id id))
+    (free-identifier-mapping-put!
+     chunk-groups id
+     (cons id (mapping-get chunk-groups id)))
+    (free-identifier-mapping-put!
+     chunks id
+     `(,@(mapping-get chunks id) ,@exprs))))
+
+(define-syntax (tangle stx)
+  (define chunk-mentions '())
+  (define stupid-internal-definition-sytnax
+    (unless first-id
+      (raise-syntax-error 'scribble/lp "no chunks")))
+  (define orig-stx (syntax-case stx () [(_ orig) #'orig]))
+  (define (restore nstx d) (datum->syntax orig-stx d nstx nstx))
+  (define (shift nstx) (datum->syntax orig-stx (syntax-e nstx) nstx nstx))
+  (define body
+    (let ([main-id (or main-id first-id)])
+      (restore
+       main-id
+       (let loop ([block (get-chunk main-id)])
+         (append-map
+          (lambda (expr)
+            (if (identifier? expr)
+                (let ([subs (get-chunk expr)])
+                  (if (pair? subs)
+                      (begin (set! chunk-mentions (cons expr chunk-mentions))
+                             (loop subs))
+                      (list (shift expr))))
+                (let ([subs (syntax->list expr)])
+                  (if subs
+                      (list (restore expr (loop subs)))
+                      (list (shift expr))))))
+          block)))))
+  (with-syntax ([(body ...) body]
+                ;; construct arrows manually
+                [((b-use b-id) ...)
+                 (append-map (lambda (m)
+                               (map (lambda (u)
+                                      (list (syntax-local-introduce m) 
+                                            (syntax-local-introduce u)))
+                                    (mapping-get chunk-groups m)))
+                             chunk-mentions)])
+    #`(begin body ... (let ([b-id (void)]) b-use) ...)))
+
+(define-for-syntax (extract-chunks exprs)
+  (let loop ([exprs exprs])
+    (syntax-case exprs ()
+      [() (void)]
+      [(expr . exprs)
+       (syntax-case #'expr (define-syntax quote-syntax)
+         [(define-values (lifted) (quote-syntax (a-chunk id body ...)))
+          (eq? (syntax-e #'a-chunk) 'a-chunk)
+          (begin
+            (add-to-chunk! #'id (syntax->list #'(body ...)))
+            (loop #'exprs))]
+         [_ 
+          (loop #'exprs)])])))
+
+(define-syntax (module-begin stx)
+  (syntax-case stx ()
+    [(_ id exprs . body)
+     (let ([expanded 
+            (expand `(,#'module scribble-lp-tmp-name scribble/private/lp
+                                ,@(strip-context #'(id exprs . body))))])
+       (syntax-case expanded ()
+         [(module name lang (mb . stuff))
+          (begin (extract-chunks #'stuff)
+                 #'(#%module-begin (tangle id)))]))]))
diff --git a/collects/games/chat-noir/literate-reader.ss b/collects/scribble/lp/lang/reader.ss
similarity index 86%
rename from collects/games/chat-noir/literate-reader.ss
rename to collects/scribble/lp/lang/reader.ss
index 3168c0fd4b..89707ae6d5 100644
--- a/collects/games/chat-noir/literate-reader.ss
+++ b/collects/scribble/lp/lang/reader.ss
@@ -1,5 +1,5 @@
 #lang s-exp syntax/module-reader
-"literate-lang.ss"
+scribble/lp/lang/lang
 #:read read-inside
 #:read-syntax read-syntax-inside
 #:whole-body-readers? #t
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
index 1680771048..c902936141 100644
--- a/collects/scribble/manual.ss
+++ b/collects/scribble/manual.ss
@@ -14,6 +14,7 @@
 
 (provide unsyntax
          make-binding-redirect-elements
+         defidentifier
          (all-from-out "basic.ss"
                        "private/manual-style.ss"
                        "private/manual-scheme.ss"
diff --git a/collects/scribble/manual/lang.ss b/collects/scribble/manual/lang.ss
new file mode 100644
index 0000000000..f3aa8bcbf4
--- /dev/null
+++ b/collects/scribble/manual/lang.ss
@@ -0,0 +1,4 @@
+#lang scheme
+(require scribble/doclang scribble/manual)
+(provide (all-from-out scribble/doclang
+                       scribble/manual))
diff --git a/collects/scribble/manual/lang/reader.ss b/collects/scribble/manual/lang/reader.ss
new file mode 100644
index 0000000000..45fc938087
--- /dev/null
+++ b/collects/scribble/manual/lang/reader.ss
@@ -0,0 +1,10 @@
+#lang s-exp syntax/module-reader
+
+scribble/manual/lang
+
+#:read        scribble:read-inside
+#:read-syntax scribble:read-syntax-inside
+#:whole-body-readers? #t
+#:wrapper1 (lambda (t) (list* 'doc '() (t)))
+
+(require (prefix-in scribble: "../../reader.ss"))
diff --git a/collects/scribble/private/lp.ss b/collects/scribble/private/lp.ss
new file mode 100644
index 0000000000..b5b189b2a3
--- /dev/null
+++ b/collects/scribble/private/lp.ss
@@ -0,0 +1,82 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase)
+         scribble/scheme scribble/decode scribble/manual scribble/struct)
+
+(begin-for-syntax
+  ;; maps chunk identifiers to a counter, so we can distinguish multiple uses
+  ;; of the same name
+  (define chunk-numbers (make-free-identifier-mapping))
+  (define (get-chunk-number id)
+    (free-identifier-mapping-get chunk-numbers id (lambda () #f)))
+  (define (inc-chunk-number id)
+    (free-identifier-mapping-put! chunk-numbers id (+ 1 (free-identifier-mapping-get chunk-numbers id))))
+  (define (init-chunk-number id)
+    (free-identifier-mapping-put! chunk-numbers id 2)))
+
+(define-syntax (chunk stx)
+  (syntax-case stx ()
+    [(_ name expr ...) 
+     ;; no need for more error checking, using chunk for the code will do that
+     (identifier? #'name)
+     (let* ([n (get-chunk-number (syntax-local-introduce #'name))]
+            [str (symbol->string (syntax-e #'name))]
+            [tag (format "~a:~a" str (or n 1))])
+       
+       (when n
+         (inc-chunk-number (syntax-local-introduce #'name)))
+       
+       (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...)))
+       
+       (with-syntax ([tag tag]
+                     [str str]
+                     [((for-label-mod ...) ...)
+                      (map (lambda (expr)
+                             (syntax-case expr (require)
+                               [(require mod ...)
+                                (let loop ([mods (syntax->list #'(mod ...))])
+                                  (cond
+                                    [(null? mods) null]
+                                    [else 
+                                     (syntax-case (car mods) (for-syntax)
+                                       [(for-syntax x ...)
+                                        (append (loop (syntax->list #'(x ...)))
+                                                (loop (cdr mods)))]
+                                       [x
+                                        (cons #'x (loop (cdr mods)))])]))]
+                               [else null]))
+                           (syntax->list #'(expr ...)))]
+                     
+                     [(rest ...) (if n
+                                     #`((subscript #,(format "~a" n)))
+                                     #`())])
+         
+         #`(begin
+             (require (for-label for-label-mod ... ...))
+             #,@(if n
+                    #'()
+                    #'((define-syntax name (make-element-id-transformer
+                                            (lambda (stx) #'(chunkref name))))
+                       (begin-for-syntax (init-chunk-number #'name))))
+             (make-splice
+              (list (make-toc-element
+                     #f
+                     (list (elemtag '(chunk tag)
+                                    (bold (italic (scheme name)) " ::=")))
+                     (list (smaller (elemref '(chunk tag) #:underline? #f
+                                             str
+                                             rest ...))))
+                    (schemeblock expr ...))))))]))
+
+(define-syntax (chunkref stx)
+  (syntax-case stx ()
+    [(_ id)
+     (identifier? #'id)
+     (with-syntax ([tag (format "~a:1" (syntax-e #'id))]
+                   [str (format "~a" (syntax-e #'id))])
+       #'(elemref '(chunk tag) #:underline? #f str))]))
+
+
+(provide (all-from-out scheme/base
+                       scribble/manual)
+         chunk)
diff --git a/collects/scribble/private/manual-bind.ss b/collects/scribble/private/manual-bind.ss
index 331aa024b8..b136277545 100644
--- a/collects/scribble/private/manual-bind.ss
+++ b/collects/scribble/private/manual-bind.ss
@@ -26,6 +26,7 @@
          with-exporting-libraries
          id-to-target-maker
          id-to-form-target-maker
+         defidentifier
          *sig-elem
          (struct-out sig)
          ;; public:
@@ -170,6 +171,37 @@
        (lambda () (car content))
        (lambda () (car content))))))
 
+(define (defidentifier id 
+                       #:form? [form? #f]
+                       #:index? [index? #t]
+                       #:show-libs? [show-libs? #t])
+  ;; This function could have more optional argument to select
+  ;; whether to index the id, include a toc link, etc.
+  (let ([dep? #t])
+    (let ([maker (if form?
+                     (id-to-form-target-maker id dep?)
+                     (id-to-target-maker id dep?))]
+          [elem (if show-libs?
+                    (definition-site (syntax-e id) id form?)
+                    (to-element id))])
+      (if maker
+          (maker (list elem)
+                 (lambda (tag)
+                   (let ([elem
+                          (if index?
+                              (make-index-element
+                               #f (list elem) tag
+                               (list (symbol->string (syntax-e id)))
+                               (list elem)
+                               (and show-libs?
+                                    (with-exporting-libraries
+                                     (lambda (libs)
+                                       (make-exported-index-desc (syntax-e id)
+                                                                 libs)))))
+                              elem)])
+                     (make-target-element #f (list elem) tag))))
+          elem))))
+
 (define (make-binding-redirect-elements mod-path redirects)
   (let ([taglet (module-path-index->taglet 
                  (module-path-index-join mod-path #f))])
diff --git a/collects/scribble/private/manual-class.ss b/collects/scribble/private/manual-class.ss
index c76dbb224f..9d3a4968b7 100644
--- a/collects/scribble/private/manual-class.ss
+++ b/collects/scribble/private/manual-class.ss
@@ -173,11 +173,20 @@
     (make-decl-collect decl)
     (append
      ((decl-mk-head decl) #f)
-     (list
-      (make-blockquote
-       "leftindent"
-       (flow-paragraphs
-        (decode-flow (build-body decl (decl-body decl))))))))))
+     (let-values ([(pre post)
+                   (let loop ([l (decl-body decl)][accum null])
+                     (cond
+                      [(null? l) (values (reverse accum) null)]
+                      [(or (constructor? (car l)) (meth? (car l)))
+                       (values (reverse accum) l)]
+                      [else (loop (cdr l) (cons (car l) accum))]))])
+       (append
+        (flow-paragraphs (decode-flow pre))
+        (list
+         (make-blockquote
+          "leftindent"
+          (flow-paragraphs
+           (decode-flow (build-body decl post)))))))))))
 
 (define (*class-doc kind stx-id super intfs ranges whole-page? make-index-desc)
   (make-table
diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss
index 8b348a6bf3..1302b65d5a 100644
--- a/collects/scribble/private/manual-form.ss
+++ b/collects/scribble/private/manual-form.ss
@@ -153,7 +153,7 @@
                  (syntax->list #'(lit ...)))
        #'(with-togetherable-scheme-variables
           (lit ...)
-          ([form spec])
+          ([form/none spec])
           (*defforms #f
                      '(spec) (list (lambda (ignored) (schemeblock0/form spec)))
                      null null
diff --git a/collects/scribble/private/manual-proc.ss b/collects/scribble/private/manual-proc.ss
index 110aa0fc30..22130a06c4 100644
--- a/collects/scribble/private/manual-proc.ss
+++ b/collects/scribble/private/manual-proc.ss
@@ -143,16 +143,17 @@
                           #f (list (schemeparenfont "[")
                                    (schemeidfont (keyword->string (arg-kw arg)))
                                    spacer
-                                   (to-element (arg-id arg))
+                                   (to-element (make-var-id (arg-id arg)))
                                    (schemeparenfont "]")))
                          (make-element
                           #f (list (to-element (arg-kw arg))
                                    spacer
-                                   (to-element (arg-id arg)))))
-                       (to-element (arg-id arg)))]
+                                   (to-element (make-var-id (arg-id arg))))))
+                       (to-element (make-var-id (arg-id arg))))]
                     [(eq? (arg-id arg) '...+) dots1]
                     [(eq? (arg-id arg) '...) dots0]
-                    [else (to-element (arg-id arg))])]
+                    [(eq? (arg-id arg) '_...superclass-args...) (to-element (arg-id arg))]
+                    [else (to-element (make-var-id (arg-id arg)))])]
            [e (if (arg-ends-optional? arg)
                 (make-element #f (list e "]"))
                 e)]
@@ -425,7 +426,7 @@
                   [def-len (if (arg-optional? arg) (block-width arg-val) 0)]
                   [base-list
                    (list (to-flow (hspace 2))
-                         (to-flow (to-element (arg-id arg)))
+                         (to-flow (to-element (make-var-id (arg-id arg))))
                          flow-spacer
                          (to-flow ":")
                          flow-spacer
diff --git a/collects/scribble/private/manual-style.ss b/collects/scribble/private/manual-style.ss
index fe5e184d96..d4f0eba918 100644
--- a/collects/scribble/private/manual-style.ss
+++ b/collects/scribble/private/manual-style.ss
@@ -26,7 +26,7 @@
          void-const undefined-const
          math)
 
-(define PLaneT "PLaneT")
+(define PLaneT (make-element "planetName" '("PLaneT")))
 
 (define etc "etc.") ; so we can fix the latex space, one day
 
diff --git a/collects/scribble/private/manual-tech.ss b/collects/scribble/private/manual-tech.ss
index d2d386ced4..5cb7d417b2 100644
--- a/collects/scribble/private/manual-tech.ss
+++ b/collects/scribble/private/manual-tech.ss
@@ -15,8 +15,10 @@
          [s (regexp-replace* #px"[-\\s]+" s " ")])
     (make-elem style c (list 'tech (doc-prefix doc s)))))
 
-(define (deftech . s)
-  (let* ([e (apply defterm s)]
+(define (deftech #:style? [style? #t] . s)
+  (let* ([e (if style?
+                (apply defterm s)
+                (make-element #f (decode-content s)))]
          [t (*tech make-target-element #f #f (list e))])
     (make-index-element #f
                         (list t)
diff --git a/collects/scribble/private/manual-vars.ss b/collects/scribble/private/manual-vars.ss
index e5e566afc2..9d82498085 100644
--- a/collects/scribble/private/manual-vars.ss
+++ b/collects/scribble/private/manual-vars.ss
@@ -15,15 +15,23 @@
 
 (define-struct (box-splice splice) ())
 
+(begin-for-syntax (define-struct deftogether-tag () #:omit-define-syntaxes))
+
 (define-syntax (with-togetherable-scheme-variables stx)
   (syntax-case stx ()
     [(_ . rest)
-     ;; Make it transparent, so deftogether is allowed to pull it apart
-     (syntax-property
-      (syntax/loc stx
-        (with-togetherable-scheme-variables* . rest))
-      'certify-mode
-      'transparent)]))
+     (let ([result (syntax/loc stx
+                     (with-togetherable-scheme-variables* . rest))]
+           [ctx (syntax-local-context)])
+       (if (and (pair? ctx) (deftogether-tag? (car ctx)))
+           ;; Make it transparent, so deftogether is allowed to pull it apart
+           (syntax-property result
+                            'certify-mode
+                            'transparent)
+           ;; Otherwise, don't make it transparent, because that
+           ;; removes certificates that will be needed on the `letrec-syntaxes'
+           ;; that we introduce later.
+           result))]))
 
 (define-syntax-rule (with-togetherable-scheme-variables* . rest)
   (with-scheme-variables . rest))
@@ -41,6 +49,7 @@
                          (if (identifier? arg)
                              (unless (or (eq? (syntax-e arg) '...)
                                          (eq? (syntax-e arg) '...+)
+                                         (eq? (syntax-e arg) '_...superclass-args...)
                                          (memq (syntax-e arg) lits))
                                (bound-identifier-mapping-put! ht arg #t))
                              (syntax-case arg ()
@@ -51,11 +60,12 @@
                                 (identifier? #'arg)
                                 (bound-identifier-mapping-put! ht #'arg #t)])))
                        (cdr (syntax->list s-exp)))]
-                     [(form form/maybe non-term)
+                     [(form form/none form/maybe non-term)
                       (let loop ([form (case (syntax-e kind)
                                          [(form) (if (identifier? s-exp)
                                                      null
                                                      (cdr (syntax-e s-exp)))]
+                                         [(form/none) s-exp]
                                          [(form/maybe)
                                           (syntax-case s-exp ()
                                             [(#f form) #'form]
@@ -64,6 +74,9 @@
                         (if (identifier? form)
                             (unless (or (eq? (syntax-e form) '...)
                                         (eq? (syntax-e form) '...+)
+                                        (eq? (syntax-e form) 'code:line)
+                                        (eq? (syntax-e form) 'code:blank)
+                                        (eq? (syntax-e form) 'code:comment)
                                         (eq? (syntax-e form) '?)
                                         (memq (syntax-e form) lits))
                               (bound-identifier-mapping-put! ht form #t))
@@ -81,7 +94,7 @@
                  (syntax->list #'(kind ...))
                  (syntax->list #'(s-exp ...)))
        (with-syntax ([(id ...) (bound-identifier-mapping-map ht (lambda (k v) k))])
-         #'(parameterize ([current-variable-list '(id ...)])
+         #'(letrec-syntaxes ([(id) (make-variable-id 'id)] ...)
              body)))]))
 
 
@@ -112,7 +125,7 @@
                     (map (lambda (def)
                            (let ([exp-def (local-expand 
                                            def
-                                           'expression
+                                           (list (make-deftogether-tag))
                                            (cons
                                             #'with-togetherable-scheme-variables*
                                             (kernel-form-identifier-list)))])
diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss
index 58bd496125..12650f8cd1 100644
--- a/collects/scribble/run.ss
+++ b/collects/scribble/run.ss
@@ -32,6 +32,8 @@
     (make-parameter null))
   (define current-xref-input-modules
     (make-parameter null))
+  (define current-prefix-file
+    (make-parameter #f))
   (define current-style-file
     (make-parameter #f))
   (define current-style-extra-files
@@ -67,6 +69,8 @@
        (current-dest-directory dir)]
       [("--dest-name") name "write output as <name>"
        (current-dest-name name)]
+      [("--prefix") file "use given .html/.tex prefix (for doctype/documentclass)"
+       (current-prefix-file file)]
       [("--style") file "use given base .css/.tex file"
        (current-style-file file)]
       [("--redirect") url "redirect external links to tag search via <url>"
@@ -110,6 +114,7 @@
 
       (let ([renderer (new ((current-render-mixin) render%)
                            [dest-dir dir]
+                           [prefix-file (current-prefix-file)]
                            [style-file (current-style-file)]
                            [style-extra-files (reverse (current-style-extra-files))])])
         (when (current-redirect)
diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss
index 443af073be..281603a8bc 100644
--- a/collects/scribble/scheme.ss
+++ b/collects/scribble/scheme.ss
@@ -20,9 +20,14 @@
            current-variable-list
            current-meta-list
 
+           (struct-out var-id)
            (struct-out shaped-parens)
            (struct-out just-context)
-           (struct-out literal-syntax))
+           (struct-out literal-syntax)
+           (for-syntax make-variable-id
+                       variable-id?
+                       make-element-id-transformer
+                       element-id-transformer?))
 
   (define no-color "schemeplain")
   (define reader-color "schemereader")
@@ -118,57 +123,63 @@
         (make-element style content)))
 
   (define (typeset-atom c out color? quote-depth)
-    (let*-values ([(is-var?) (and (identifier? c)
-                                  (memq (syntax-e c) (current-variable-list)))]
-                  [(s it? sub?)
-                   (let ([sc (syntax-e c)])
-                     (let ([s (format "~s" (if (literal-syntax? sc)
-                                               (literal-syntax-stx sc)
-                                               sc))])
-                       (if (and (symbol? sc)
-                                ((string-length s) . > . 1)
-                                (char=? (string-ref s 0) #\_)
-                                (not (or (identifier-label-binding c)
-                                         is-var?)))
-                           (values (substring s 1) #t #f)
-                           (values s #f #f))))])
-      (if (or (element? (syntax-e c))
-              (delayed-element? (syntax-e c))
-              (part-relative-element? (syntax-e c)))
-          (out (syntax-e c) #f)
-          (out (if (and (identifier? c)
-                        color?
-                        (quote-depth . <= . 0)
-                        (not (or it? is-var?)))
-                   (if (pair? (identifier-label-binding c))
-                       (make-id-element c s)
-                       s)
-                   (literalize-spaces s))
-               (cond
-                [(positive? quote-depth) value-color]
-                [(let ([v (syntax-e c)])
-                   (or (number? v)
-                       (string? v)
-                       (bytes? v)
-                       (char? v)
-                       (regexp? v)
-                       (byte-regexp? v)
-                       (boolean? v)))
-                 value-color]
-                [(identifier? c) 
-                 (cond
-                  [is-var?
-                   variable-color]
-                  [(and (identifier? c)
-                        (memq (syntax-e c) (current-keyword-list)))
-                   keyword-color]
-                  [(and (identifier? c)
-                        (memq (syntax-e c) (current-meta-list)))
-                   meta-color]
-                  [it? variable-color]
-                  [else symbol-color])]
-                [else paren-color])
-               (string-length s)))))
+    (if (var-id? (syntax-e c))
+        (out (format "~s" (let ([v (var-id-sym (syntax-e c))])
+                            (if (syntax? v)
+                                (syntax-e v)
+                                v)))
+             variable-color)
+        (let*-values ([(is-var?) (and (identifier? c)
+                                      (memq (syntax-e c) (current-variable-list)))]
+                      [(s it? sub?)
+                       (let ([sc (syntax-e c)])
+                         (let ([s (format "~s" (if (literal-syntax? sc)
+                                                   (literal-syntax-stx sc)
+                                                   sc))])
+                           (if (and (symbol? sc)
+                                    ((string-length s) . > . 1)
+                                    (char=? (string-ref s 0) #\_)
+                                    (not (or (identifier-label-binding c)
+                                             is-var?)))
+                               (values (substring s 1) #t #f)
+                               (values s #f #f))))])
+          (if (or (element? (syntax-e c))
+                  (delayed-element? (syntax-e c))
+                  (part-relative-element? (syntax-e c)))
+              (out (syntax-e c) #f)
+              (out (if (and (identifier? c)
+                            color?
+                            (quote-depth . <= . 0)
+                            (not (or it? is-var?)))
+                       (if (pair? (identifier-label-binding c))
+                           (make-id-element c s)
+                           s)
+                       (literalize-spaces s))
+                   (cond
+                    [(positive? quote-depth) value-color]
+                    [(let ([v (syntax-e c)])
+                       (or (number? v)
+                           (string? v)
+                           (bytes? v)
+                           (char? v)
+                           (regexp? v)
+                           (byte-regexp? v)
+                           (boolean? v)))
+                     value-color]
+                    [(identifier? c) 
+                     (cond
+                      [is-var?
+                       variable-color]
+                      [(and (identifier? c)
+                            (memq (syntax-e c) (current-keyword-list)))
+                       keyword-color]
+                      [(and (identifier? c)
+                            (memq (syntax-e c) (current-meta-list)))
+                       meta-color]
+                      [it? variable-color]
+                      [else symbol-color])]
+                    [else paren-color])
+                   (string-length s))))))
 
   (define (gen-typeset c multi-line? prefix1 prefix suffix color?)
     (let* ([c (syntax-ize c 0)]
@@ -590,48 +601,65 @@
   (define ((to-paragraph/prefix pfx1 pfx sfx) c)
     (typeset c #t pfx1 pfx sfx #t))
 
+  (begin-for-syntax 
+   (define-struct variable-id (sym) #:omit-define-syntaxes)
+   (define-struct element-id-transformer (proc) #:omit-define-syntaxes))
+
   (define-syntax (define-code stx)
     (syntax-case stx ()
       [(_ code typeset-code uncode d->s stx-prop)
        (syntax/loc stx
 	 (define-syntax (code stx)
+           (define (wrap-loc v ctx e)
+             `(,#'d->s ,ctx
+                       ,e
+                       #(code
+                         ,(syntax-line v)
+                         ,(syntax-column v)
+                         ,(syntax-position v)
+                         ,(syntax-span v))))
 	   (define (stx->loc-s-expr v)
-	     (cond
-	      [(syntax? v)
-	       (let ([mk `(,#'d->s
-			   (quote-syntax ,(datum->syntax v 'defcode))
-			   ,(syntax-case v (uncode)
-			      [(uncode e) #'e]
-			      [else (stx->loc-s-expr (syntax-e v))])
-                           #(code
-                             ,(syntax-line v)
-                             ,(syntax-column v)
-                             ,(syntax-position v)
-                             ,(syntax-span v)))])
-		 (let ([prop (syntax-property v 'paren-shape)])
-		   (if prop
-		       `(,#'stx-prop ,mk 'paren-shape ,prop)
-		       mk)))]
-	      [(null? v) 'null]
-              [(list? v) `(list . ,(map stx->loc-s-expr v))]
-	      [(pair? v) `(cons ,(stx->loc-s-expr (car v))
-				,(stx->loc-s-expr (cdr v)))]
-	      [(vector? v) `(vector ,@(map
-				       stx->loc-s-expr
-				       (vector->list v)))]
-	      [(and (struct? v) (prefab-struct-key v))
-               `(make-prefab-struct (quote ,(prefab-struct-key v))
-                                    ,@(map
-				       stx->loc-s-expr
-				       (cdr (vector->list (struct->vector v)))))]
-	      [(box? v) `(box ,(stx->loc-s-expr (unbox v)))]
-	      [else `(quote ,v)]))
+             (let ([slv (and (identifier? v)
+                             (syntax-local-value v (lambda () #f)))])
+               (cond
+                [(variable-id? slv)
+                 (wrap-loc v #f `(,#'make-var-id ',(variable-id-sym slv)))]
+                [(element-id-transformer? slv)
+                 (wrap-loc v #f ((element-id-transformer-proc slv) v))]
+                [(syntax? v)
+                 (let ([mk (wrap-loc
+                            v
+                            `(quote-syntax ,(datum->syntax v 'defcode))
+                            (syntax-case v (uncode)
+                              [(uncode e) #'e]
+                              [else (stx->loc-s-expr (syntax-e v))]))])
+                   (let ([prop (syntax-property v 'paren-shape)])
+                     (if prop
+                         `(,#'stx-prop ,mk 'paren-shape ,prop)
+                         mk)))]
+                [(null? v) 'null]
+                [(list? v) `(list . ,(map stx->loc-s-expr v))]
+                [(pair? v) `(cons ,(stx->loc-s-expr (car v))
+                                  ,(stx->loc-s-expr (cdr v)))]
+                [(vector? v) `(vector ,@(map
+                                         stx->loc-s-expr
+                                         (vector->list v)))]
+                [(and (struct? v) (prefab-struct-key v))
+                 `(make-prefab-struct (quote ,(prefab-struct-key v))
+                                      ,@(map
+                                         stx->loc-s-expr
+                                         (cdr (vector->list (struct->vector v)))))]
+                [(box? v) `(box ,(stx->loc-s-expr (unbox v)))]
+                [else `(quote ,v)])))
 	   (define (cvt s)
 	     (datum->syntax #'here (stx->loc-s-expr s) #f))
-	   (syntax-case stx ()
-	     [(_ expr) #`(typeset-code #,(cvt #'expr))]
-	     [(_ expr (... ...))
-	      #`(typeset-code #,(cvt #'(code:line expr (... ...))))])))]
+           (if (eq? (syntax-local-context) 'expression)
+               (syntax-case stx ()
+                 [(_ expr) #`(typeset-code #,(cvt #'expr))]
+                 [(_ expr (... ...))
+                  #`(typeset-code #,(cvt #'(code:line expr (... ...))))])
+               (quasisyntax/loc stx
+                 (#%expression #,stx)))))]
       [(_ code typeset-code uncode d->s)
        #'(define-code code typeset-code uncode d->s syntax-property)]
       [(_ code typeset-code uncode)
@@ -666,6 +694,7 @@
                           (loop (cons (car r) r) (sub1 i)))))
            l))))
 
+  (define-struct var-id (sym))
   (define-struct shaped-parens (val shape))
   (define-struct just-context (val ctx))
   (define-struct literal-syntax (stx))
diff --git a/collects/scribble/scribble-prefix.html b/collects/scribble/scribble-prefix.html
new file mode 100644
index 0000000000..4ef584cce5
--- /dev/null
+++ b/collects/scribble/scribble-prefix.html
@@ -0,0 +1 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
diff --git a/collects/scribble/scribble-prefix.tex b/collects/scribble/scribble-prefix.tex
new file mode 100644
index 0000000000..9cfd09828e
--- /dev/null
+++ b/collects/scribble/scribble-prefix.tex
@@ -0,0 +1,11 @@
+% This is the default prefix for Scribble-generated Latex
+\documentclass{article}
+
+\parskip=10pt
+\parindent=0pt
+
+% Adjust margins to match HTML width for
+% fixed-width font
+\advance \oddsidemargin by -0.15in
+\advance \evensidemargin by -0.15in
+\advance \textwidth by 0.3in
diff --git a/collects/scribble/scribble.tex b/collects/scribble/scribble.tex
index 54d304a7a8..47e3f69168 100644
--- a/collects/scribble/scribble.tex
+++ b/collects/scribble/scribble.tex
@@ -1,20 +1,10 @@
-% This is the default prefix for Scribble-generated Latex
-
-\documentclass{article}
+% This is the default style configuration for Scribble-generated Latex
  
-\parskip=10pt
-\parindent=0pt
-
-% Adjust margins to match HTML width for
-% fixed-width font
-\advance \oddsidemargin by -0.15in
-\advance \evensidemargin by -0.15in
-\advance \textwidth by 0.3in
-
 \usepackage{graphicx}
 \usepackage{hyperref}
 \renewcommand{\rmdefault}{ptm}
 \usepackage{longtable}
+\usepackage{relsize}
 \usepackage[htt]{hyphenat}
 \usepackage[usenames,dvipsnames]{color}
 \hypersetup{bookmarks=true,bookmarksopen=true,bookmarksnumbered=true}
@@ -67,8 +57,9 @@
 \newcommand{\indexlink}[1]{#1}
 \newcommand{\noborder}[1]{#1}
 \newcommand{\imageleft}[1]{} % drop it
-\newcommand{\smaller}[1]{{\footnotesize #1}}
-\newcommand{\refpara}[1]{\marginpar{\footnotesize #1}}
+\renewcommand{\smaller}[1]{\textsmaller{#1}}
+\newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}}
+\newcommand{\planetName}[1]{PLane\hspace{-0.1ex}T}
 
 \newcommand{\titleAndEmptyVersion}[2]{\title{#1}\maketitle}
 \newcommand{\titleAndVersion}[2]{\title{#1\\{\normalsize Version #2}}\maketitle}
@@ -86,7 +77,8 @@
 \newenvironment{bibentry}[1]{\parbox[t]{0.8\linewidth}{#1}}
 
 \newenvironment{bigtabular}{\begin{longtable}}{\end{longtable}\vspace{-3ex}}
-\newcommand{\bigtabline}{\vspace{-2ex}}
+
+\newcommand{\SecRef}[2]{\S#1 ``#2''}
 
 \newcommand{\sectionhidden}[1]{\section{#1}}
 \newcommand{\subsectionhidden}[1]{\subsection{#1}}
diff --git a/collects/scribble/text-render.ss b/collects/scribble/text-render.ss
index 31835d1f3a..906d426dac 100644
--- a/collects/scribble/text-render.ss
+++ b/collects/scribble/text-render.ss
@@ -6,7 +6,8 @@
 
   (define (render-mixin %)
     (class %
-      (init [style-file #f]
+      (init [prefix-file #f]
+            [style-file #f]
             [style-extra-files ()])
       
       (define/override (get-substitutions)
diff --git a/collects/scribblings/htdp-langs/advanced.scrbl b/collects/scribblings/htdp-langs/advanced.scrbl
index 9bc2d3983b..97fef1bd5d 100644
--- a/collects/scribblings/htdp-langs/advanced.scrbl
+++ b/collects/scribblings/htdp-langs/advanced.scrbl
@@ -349,6 +349,6 @@ The same as Beginning's @|beg-check-expect|, etc.}
 
 Constants for the empty list, true, and false.}
 
-@defform[(require string)]{
+@defform[(require module-path)]{
 
 The same as Beginning's @|beg-require|.}
diff --git a/collects/scribblings/htdp-langs/beginner-abbr.scrbl b/collects/scribblings/htdp-langs/beginner-abbr.scrbl
index bba47aa84f..37962fa30d 100644
--- a/collects/scribblings/htdp-langs/beginner-abbr.scrbl
+++ b/collects/scribblings/htdp-langs/beginner-abbr.scrbl
@@ -184,6 +184,6 @@ The same as Beginning's @|beg-check-expect|, etc.}
 
 Constants for the empty list, true, and false.}
 
-@defform[(require string)]{
+@defform[(require module-path)]{
 
 The same as Beginning's @|beg-require|.}
diff --git a/collects/scribblings/htdp-langs/beginner.scrbl b/collects/scribblings/htdp-langs/beginner.scrbl
index 1147bde639..170d3febd6 100644
--- a/collects/scribblings/htdp-langs/beginner.scrbl
+++ b/collects/scribblings/htdp-langs/beginner.scrbl
@@ -318,6 +318,13 @@ lowercase), @litchar{0} through @litchar{9}, @litchar{-}, @litchar{_},
 and @litchar{.}, and the string cannot be empty or contain a leading
 or trailing @litchar{/}.}
 
+@defform/none[#:literals (require)
+              (require module-id)]{
+
+Accesses a file in an installed library. The library name is an
+identifier with the same constraints as for a relative-path string,
+with the additional constraint that it must not contain a
+@litchar{.}.}
 
 @defform/none[#:literals (require lib)
               (require (lib string string ...))]{
diff --git a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl b/collects/scribblings/htdp-langs/intermediate-lambda.scrbl
index 0ba2862bb4..f3c63795ce 100644
--- a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl
+++ b/collects/scribblings/htdp-langs/intermediate-lambda.scrbl
@@ -187,6 +187,6 @@ The same as Beginning's @|beg-check-expect|, etc.}
 
 Constants for the empty list, true, and false.}
 
-@defform[(require string)]{
+@defform[(require module-path)]{
 
 The same as Beginning's @|beg-require|.}
diff --git a/collects/scribblings/htdp-langs/intermediate.scrbl b/collects/scribblings/htdp-langs/intermediate.scrbl
index 37fbd3c0e7..3f2b96991f 100644
--- a/collects/scribblings/htdp-langs/intermediate.scrbl
+++ b/collects/scribblings/htdp-langs/intermediate.scrbl
@@ -231,6 +231,6 @@ The same as Beginning's @|beg-check-expect|, etc.}
 
 Constants for the empty list, true, and false.}
 
-@defform[(require string)]{
+@defform[(require module-path)]{
 
 The same as Beginning's @|beg-require|.}
diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl
index 8f50eacd4b..a64ce5728f 100644
--- a/collects/scribblings/reference/class.scrbl
+++ b/collects/scribblings/reference/class.scrbl
@@ -1494,7 +1494,7 @@ To customize the way that a class instance is compared to other
 instances by @scheme[equal?], implement the @scheme[equal<%>]
 interface.
 
-@definterface[equal<%> ()]{}
+@definterface[equal<%> ()]{
 
 The @scheme[equal<%>] interface includes three methods, which are
 analogous to the functions provided for a structure type with
@@ -1531,7 +1531,7 @@ classes whose most specific ancestor to explicitly implement
 
 See @scheme[prop:equal+hash] for more information on equality
 comparisons and hash codes. The @scheme[equal<%>] interface is
-implemented with @scheme[interface*] and @scheme[prop:equal+hash].
+implemented with @scheme[interface*] and @scheme[prop:equal+hash].}
 
 @; ------------------------------------------------------------------------
 
@@ -1610,11 +1610,11 @@ Like @scheme[define-serializable-class*], but with not interface
 expressions (analogous to @scheme[class]).}
 
 
-@definterface[externalizable<%> ()]{}
+@definterface[externalizable<%> ()]{
 
 The @scheme[externalizable<%>] interface includes only the
 @scheme[externalize] and @scheme[internalize] methods. See
-@scheme[define-serializable-class*] for more information.
+@scheme[define-serializable-class*] for more information.}
 
 @; ------------------------------------------------------------------------
 
diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index 0b5dfafcf6..388617e93a 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -674,10 +674,14 @@ only used in the contract for the sub-struct's maker, and the selector
 or mutators for the super-struct are not provided.}
 
 @defform/subs[
- (with-contract blame-id (wc-export ...) body ...+)
+ (with-contract blame-id (wc-export ...) free-var-list body ...+)
  ([wc-export
    id
-   (id contract-expr)])]{
+   (id contract-expr)]
+  [free-var-list
+   code:blank
+   (code:line #:freevars ([id contract-expr] ...))
+   (code:line #:freevar id contract-expr)])]{
 Generates a local contract boundary.  The @scheme[contract-expr]
 form cannot appear in expression position.  The @scheme[body] of the
 form allows definition/expression interleaving like a @scheme[module]
@@ -689,20 +693,43 @@ exported without a contract.
 The @scheme[blame-id] is used for the positive positions of
 contracts paired with exported @scheme[id]s.  Contracts broken
 within the @scheme[with-contract] @scheme[body] will use the
-@scheme[blame-id] for their negative position.}
+@scheme[blame-id] for their negative position.
 
-@defform*[[(define/contract id contract-expr init-value-expr)
- (define/contract (head args) contract-expr body ...+)]]{
+If a free-var-list is given, then any uses of the free variables
+inside the @scheme[body] will be protected with contracts that
+blame the context of the @scheme[with-contract] form for the positive
+positions and the @scheme[with-contract] form for the negative ones.}
+
+@defform*[[(define/contract id contract-expr free-var-list init-value-expr)
+ (define/contract (head args) contract-expr free-var-list body ...+)]]{
 Works like @scheme[define], except that the contract
-@scheme[contract-expr] is attached to the bound value.
+@scheme[contract-expr] is attached to the bound value.  For the
+definition of @scheme[head] and @scheme[args], see @scheme[define].
+For the definition of @scheme[free-var-list], see @scheme[with-contract].
 
-The @scheme[define/contract] form treats individual definitions as
-units of blame. The definition itself is responsible for positive
-(co-variant) positions of the contract and each reference to
-@scheme[id] (including those in the initial value expression) must
-meet the negative positions of the contract.  It is equivalent to
-wrapping a single @scheme[define] with a @scheme[with-contract] form
-that pairs the @scheme[contract-expr] with the bound identifier.}
+The @scheme[define/contract] form treats the individual definition as
+a contract region. The definition itself is responsible for positive
+(co-variant) positions of the contract and references to
+@scheme[id] outside of the definition must meet the negative
+positions of the contract. Since the contract boundary is
+between the definition and the surrounding context, references to
+@scheme[id] inside the @scheme[define/contract] form are not checked.
+
+If a free-var-list is given, then any uses of the free variables
+inside the @scheme[body] will be protected with contracts that
+blame the context of the @scheme[define/contract] form for the positive
+positions and the @scheme[define/contract] form for the negative ones.}
+
+@defform*[[(define-struct/contract struct-id ([field contract-expr] ...)
+                                   struct-option ...)]]{
+Works like @scheme[define-struct], except that the arguments to the constructor,
+accessors, and mutators are protected by contracts.  For the definitions of
+@scheme[field] and @scheme[struct-option], see @scheme[define-struct].
+
+The @scheme[define-struct/contract] form only allows a subset of the
+@scheme[struct-option] keywords: @scheme[#:mutable], @scheme[#:transparent],
+@scheme[#:auto-value], @scheme[#:omit-define-syntaxes], and
+@scheme[#:omit-define-values].}
 
 @defform*[[(contract contract-expr to-protect-expr
                      positive-blame-expr negative-blame-expr)
diff --git a/collects/scribblings/reference/include.scrbl b/collects/scribblings/reference/include.scrbl
index 78ab8233a4..2fe0004d92 100644
--- a/collects/scribblings/reference/include.scrbl
+++ b/collects/scribblings/reference/include.scrbl
@@ -7,9 +7,9 @@
 
 @defform/subs[#:literals (file lib)
               (include path-spec)
-              ([include-spec string
-                             (file string)
-                             (lib string ...+)])]{
+              ([path-spec string
+                          (file string)
+                          (lib string ...+)])]{
 
 Inlines the syntax in the file designated by @scheme[path-spec] in
 place of the @scheme[include] expression.
diff --git a/collects/scribblings/reference/module-reflect.scrbl b/collects/scribblings/reference/module-reflect.scrbl
index 40bad5d696..801383101e 100644
--- a/collects/scribblings/reference/module-reflect.scrbl
+++ b/collects/scribblings/reference/module-reflect.scrbl
@@ -258,7 +258,8 @@ Returns two association lists mapping @tech{phase level} values (where
 the corresponding phase. The first association list is for exported
 variables, and the second is for exported syntax.
 
-Each associated list more precisely matches the contract
+Each associated list, which is represented by @scheme[list?] in the
+result contracts above, more precisely matches the contract
 
 @schemeblock[
 (listof (list/c symbol?
diff --git a/collects/scribblings/reference/regexps.scrbl b/collects/scribblings/reference/regexps.scrbl
index 9201c4bc19..ba0b5b66e6 100644
--- a/collects/scribblings/reference/regexps.scrbl
+++ b/collects/scribblings/reference/regexps.scrbl
@@ -12,8 +12,6 @@
 
 @guideintro["regexp"]{regular expressions}
 
-@local-table-of-contents[]
-
 @deftech{Regular expressions} are specified as strings or byte
 strings, using the same pattern language as the Unix utility
 @exec{egrep} or Perl. A string-specified pattern produces a character
diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl
index 34eb823c43..386a62df8d 100644
--- a/collects/scribblings/reference/sandbox.scrbl
+++ b/collects/scribblings/reference/sandbox.scrbl
@@ -478,7 +478,8 @@ specifications in @scheme[sandbox-path-permissions], and it uses
 
 
 @defparam[sandbox-path-permissions perms
-          (listof (list/c (or/c 'execute 'write 'delete 'read-bytecode 'read 'exists)
+          (listof (list/c (or/c 'execute 'write 'delete 
+                                'read-bytecode 'read 'exists)
                           (or/c byte-regexp? bytes? string? path?)))]{
 
 A parameter that configures the behavior of the default sandbox
diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl
index 65da253f7c..1c45f97154 100644
--- a/collects/scribblings/reference/struct.scrbl
+++ b/collects/scribblings/reference/struct.scrbl
@@ -543,9 +543,7 @@ transformer to generate information about imported structure types, so
 that @scheme[match] and subtyping @scheme[define-struct] forms work
 within the unit.
 
-The expansion-time information for a structure type is represented
-either as a structure that encapsulates a procedure that takes no
-arguments and returns a list of six element, or it can be represented
+The expansion-time information for a structure type can be represented
 directly as a list of six elements (of the same sort that the
 encapsulated procedure must return):
 
@@ -585,10 +583,18 @@ encapsulated procedure must return):
 
 }
 
-Use @scheme[struct-info?] to recognize both forms of information, and
-use @scheme[extract-struct-info] to obtain a list from either
-representation. Use @scheme[make-struct-info] to encapsulate a
-procedure that represents structure type information.
+Instead of this direct representation, the representation can
+be a structure created by @scheme[make-struct-info] (or an instance of
+a subtype of @scheme[struct:struct-info]), which encapsulates a
+procedure that takes no arguments and returns a list of six
+elements. Finally, the representation can be an instance of a
+structure type derived from @scheme[struct:struct-info] that also
+implements @scheme[prop:procedure], and where the instance is further
+is wrapped by @scheme[make-set!-transformer].
+
+Use @scheme[struct-info?] to recognize all allowed forms of the
+information, and use @scheme[extract-struct-info] to obtain a list
+from any representation.
 
 The implementor of a syntactic form can expect users of the form to
 know what kind of information is available about a structure type. For
@@ -606,15 +612,17 @@ type.
 @defproc[(struct-info? [v any/c]) boolean?]{
 
 Returns @scheme[#t] if @scheme[v] is either a six-element list with
-the correct shape for representing structure-type information, or a
-procedure encapsulated by @scheme[make-struct-info].}
+the correct shape for representing structure-type information, a
+procedure encapsulated by @scheme[make-struct-info], or a structure
+type derived from @scheme[struct:struct-info] and wrapped with
+@scheme[make-set!-transformer].}
 
 @defproc[(checked-struct-info? [v any/c]) boolean?]{
 
 Returns @scheme[#t] if @scheme[v] is a procedure encapsulated by
 @scheme[make-struct-info] and produced by @scheme[define-struct], but
 only when no parent type is specified or the parent type is also
-specified through a transformer binding to such a value).}
+specified through a transformer binding to such a value.}
 
 @defproc[(make-struct-info [thunk (-> (and/c struct-info? list?))])
          struct-info?]{
diff --git a/collects/scribblings/reference/stx-patterns.scrbl b/collects/scribblings/reference/stx-patterns.scrbl
index 13d853b7f3..e2791a22bf 100644
--- a/collects/scribblings/reference/stx-patterns.scrbl
+++ b/collects/scribblings/reference/stx-patterns.scrbl
@@ -1,7 +1,7 @@
 #lang scribble/doc
 @(require "mz.ss")
 
-@(define ellipses (scheme ...))
+@(define lit-ellipses (scheme ...))
 
 @title[#:tag "stx-patterns"]{Pattern-Based Syntax Matching}
 
@@ -26,7 +26,7 @@
                              (stat-pattern ...+ . stat-pattern)
                              (code:line #,(tt "#")(stat-pattern ...))
                              const]
-               [ellipses #,ellipses])]{
+               [ellipses #,lit-ellipses])]{
 
 Finds the first @scheme[pattern] that matches the syntax object
 produced by @scheme[stx-expr], and for which the corresponding
@@ -205,7 +205,7 @@ the individual @scheme[stx-expr].}
                               (code:line #,(tt "#")(stat-template ...))
                               (code:line #,(tt "#s")(key-datum stat-template ...))
                               const]
-               [ellipses #,ellipses])]{
+               [ellipses #,lit-ellipses])]{
 
 Constructs a syntax object based on a @scheme[template],which can
 inlude @tech{pattern variables} bound by @scheme[syntax-case] or
diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl
index 2e12e90b4c..50e2613777 100644
--- a/collects/scribblings/reference/stx-trans.scrbl
+++ b/collects/scribblings/reference/stx-trans.scrbl
@@ -352,13 +352,14 @@ eventually expanded in an expression context.
 @transform-time[]}
 
 
-@defproc[(syntax-local-lift-require [quoted-raw-require-spec any/c][stx syntax?])
+@defproc[(syntax-local-lift-require [raw-require-spec any/c][stx syntax?])
          syntax?]{
 
 Lifts a @scheme[#%require] form corresponding to
-@scheme[quoted-raw-require-spec] to the top-level or to the top of the
-module currently being expanded, wrapping it with @scheme[for-meta] if
-the current expansion context is not @tech{phase level} 0.
+@scheme[raw-require-spec] (either as a @tech{syntax object} or datum)
+to the top-level or to the top of the module currently being expanded,
+wrapping it with @scheme[for-meta] if the current expansion context is
+not @tech{phase level} 0.
 
 The resulting syntax object is the same as @scheme[stx], except that a
 fresh @tech{syntax mark} is added. The same @tech{syntax mark} is
diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl
index a7bd70bc88..3dd7d4786b 100644
--- a/collects/scribblings/reference/syntax.scrbl
+++ b/collects/scribblings/reference/syntax.scrbl
@@ -13,6 +13,12 @@
                      scheme/package
                      scheme/splicing))
 
+@(define syntax-eval
+   (lambda ()
+     (let ([the-eval (make-base-eval)])
+       (the-eval '(require (for-syntax scheme/base)))
+       the-eval)))
+
 @(define cvt (schemefont "CVT"))
 @(define unquote-id (scheme unquote))
 @(define unquote-splicing-id (scheme unquote-splicing))
@@ -195,6 +201,14 @@ be preserved in marshaled bytecode. See also
 
 See also @secref["module-eval-model"] and @secref["mod-parse"].
 
+@defexamples[#:eval (syntax-eval)
+(module example-module scheme
+  (provide foo bar)
+  (define foo 2)
+  (define (bar x)
+    (+ x 1)))
+]
+
 @defform[(#%module-begin form ...)]{
 
 Legal only in a @tech{module begin context}, and handled by the
@@ -285,40 +299,149 @@ pre-defined forms are as follows.
   @scheme[_id] or as @scheme[_orig-id] in @scheme[[_orig-id _bind-id]]. If
   the @scheme[_id] or @scheme[_orig-id] of any @scheme[id-maybe-renamed]
   is not in the set that @scheme[require-spec] describes, a syntax
-  error is reported.}
+  error is reported.
+
+  @defexamples[#:eval (syntax-eval)
+    (require (only-in scheme/tcp
+	              tcp-listen
+                      (tcp-accept my-accept)))
+    tcp-listen
+    my-accept
+    tcp-accept
+  ]}
 
  @defsubform[(except-in require-spec id ...)]{ Like
   @scheme[require-spec], but omitting those imports for which
   @scheme[id]s are the identifiers to bind; if any @scheme[id] is not
   in the set that @scheme[require-spec] describes, a syntax error is
-  reported.}
+  reported.
+
+  @defexamples[#:eval (syntax-eval)
+    (require (except-in scheme/tcp
+	                tcp-listen))
+    tcp-accept
+    tcp-listen
+  ]}
 
  @defsubform[(prefix-in prefix-id require-spec)]{ Like
   @scheme[require-spec], but adjusting each identifier to be bound by
   prefixing it with @scheme[prefix-id]. The lexical context of the
   @scheme[prefix-id] is ignored, and instead preserved from the
-  identifiers before prefixing.}
+  identifiers before prefixing.
+
+  @defexamples[#:eval (syntax-eval)
+    (require (prefix-in tcp: scheme/tcp))
+    tcp:tcp-accept
+    tcp:tcp-listen
+  ]}
 
  @defsubform[(rename-in require-spec [orig-id bind-id] ...)]{
   Like @scheme[require-spec], but replacing the identifier to
   bind @scheme[orig-id] with @scheme[bind-id]; if any
   @scheme[orig-id] is not in the set that @scheme[require-spec]
-  describes, a syntax error is reported.}
+  describes, a syntax error is reported.
+  
+  @defexamples[#:eval (syntax-eval)
+    (require (rename-in scheme/tcp
+                        (tcp-accept accept)
+			(tcp-listen listen)))
+    accept
+    listen
+  ]}
 
  @defsubform[(combine-in require-spec ...)]{
-  The union of the @scheme[require-spec]s.}
+  The union of the @scheme[require-spec]s.
+  
+  @defexamples[#:eval (syntax-eval)
+    (require (combine-in (only-in scheme/tcp tcp-accept)
+                         (only-in scheme/tcp tcp-listen)))
+    tcp-accept
+    tcp-listen
+  ]}
 
  @defsubform[(only-meta-in phase-level require-spec ...)]{
   Like the combination of @scheme[require-spec]s, but removing any
   binding that is not for @scheme[phase-level], where @scheme[#f] for
-  @scheme[phase-level] corresponds to the @tech{label phase level}.}
+  @scheme[phase-level] corresponds to the @tech{label phase level}.
+  
+  This example only imports bindings at @tech{phase level} 1, the
+  transform phase.
+
+  @defexamples[#:eval (syntax-eval)
+  (module test scheme
+
+   (provide (for-syntax meta-1a)
+            (for-meta 1 meta-1b)
+            meta-0)
+
+   (define-for-syntax meta-1a 'a)
+   (define-for-syntax meta-1b 'b)
+   (define meta-0 2))
+
+  (require (only-meta-in 1 'test))
+
+  (define-syntax bar
+   (lambda (stx)
+    (printf "~a\n" meta-1a)
+    (printf "~a\n" meta-1b)
+    #'1))
+
+   (bar)
+   meta-0
+  ]
+
+  This example only imports bindings at @tech{phase level} 0, the
+  normal phase.
+
+  @defexamples[#:eval (syntax-eval)
+  (module test scheme
+
+   (provide (for-syntax meta-1a)
+            (for-meta 1 meta-1b)
+            meta-0)
+
+   (define-for-syntax meta-1a 'a)
+   (define-for-syntax meta-1b 'b)
+   (define meta-0 2))
+
+  (require (only-meta-in 0 'test))
+
+  (define-syntax bar
+   (lambda (stx)
+    (printf "~a\n" meta-1a)
+    (printf "~a\n" meta-1b)
+    #'1))
+
+   meta-0
+   (bar)
+  ]}
 
  @specsubform[#:literals (for-meta)
               (for-meta phase-level require-spec ...)]{Like the combination of
   @scheme[require-spec]s, but constrained each binding specified by
   each @scheme[require-spec] is shifted by @scheme[phase-level]. The
   @tech{label phase level} corresponds to @scheme[#f], and a shifting
-  combination that involves @scheme[#f] produces @scheme[#f].}
+  combination that involves @scheme[#f] produces @scheme[#f].
+  
+  @defexamples[#:eval (syntax-eval)
+  (module test scheme
+    (provide foo)
+    (define foo 2))
+  (require (for-meta 0 'test))
+  foo
+  ]}
+
+  @defexamples[#:eval (syntax-eval)
+  (module test scheme
+    (provide foo)
+    (define foo 2))
+  (require (for-meta 1 'test))
+  (define-syntax bar
+    (lambda (stx)
+      (printf "~a\n" foo)
+      #'1))
+  (bar)
+  ]}
 
  @specsubform[#:literals (for-syntax)
               (for-syntax require-spec ...)]{Same as 
@@ -348,7 +471,10 @@ corresponds to the default @tech{module name resolver}.
  @specsubform[#:literals (quote)
               (#,(scheme quote) id)]{
  Refers to a module previously declared interactively with the name
- @scheme[id].}
+ @scheme[id].
+
+ Example: Require'ing a module named test.
+ @scheme[(require 'test)]}
 
  @specsubform[rel-string]{A path relative to the containing source (as
  determined by @scheme[current-load-relative-directory] or
@@ -370,7 +496,15 @@ corresponds to the default @tech{module name resolver}.
  @margin-note{The @litchar{%} provision is intended to support a
  one-to-one encoding of arbitrary strings as path elements (after
  UTF-8 encoding). Such encodings are not decoded to arrive at a
- filename, but instead preserved in the file access.}}
+ filename, but instead preserved in the file access.}
+
+ Example: Require a module named x.ss in the same directory as this file.
+
+ @scheme[(require "x.ss")]
+ 
+ Require a module named x.ss in the parent directory.
+
+ @scheme[(require "../x.ss")]}
 
  @defsubform[(lib rel-string ...+)]{A path to a module installed into
  a @tech{collection} (see @secref["collects"]). The @scheme[rel-string]s in
@@ -386,19 +520,31 @@ corresponds to the default @tech{module name resolver}.
     @item{If a single @scheme[rel-string] is provided, and if it
     consists of a single element (i.e., no @litchar{/}) with no file
     suffix (i.e., no @litchar{.}), then @scheme[rel-string] names a
-    @tech{collection}, and @filepath{main.ss} is the library file name.}
+    @tech{collection}, and @filepath{main.ss} is the library file name.
+
+    Example: require swindle
+    @defexamples[#:eval (syntax-eval)
+      (require (lib "swindle"))]}
 
     @item{If a single @scheme[rel-string] is provided, and if it
     consists of multiple @litchar{/}-separated elements, then each
     element up to the last names a @tech{collection}, subcollection,
     etc., and the last element names a file. If the last element has
-    no file suffix, @filepath{.ss} is added.}
+    no file suffix, @filepath{.ss} is added.
+
+    Example: require a file within the swindle collection
+    @defexamples[#:eval (syntax-eval)
+      (require (lib "swindle/turbo"))]}
 
     @item{If a single @scheme[rel-string] is provided, and if it
     consists of a single element @italic{with} a file suffix (i.e,
     with a @litchar{.}), then @scheme[rel-string] names a file within
     the @filepath{mzlib} @tech{collection}. (This convention is for
-    compatibility with older version of PLT Scheme.)}
+    compatibility with older version of PLT Scheme.)
+
+    Example: require the tar module from mzlib
+    @defexamples[#:eval (syntax-eval)
+      (require (lib "tar.ss"))]}
 
     @item{Otherwise, when multiple @scheme[rel-string]s are provided,
     the first @scheme[rel-string] is effectively moved after the
@@ -406,18 +552,26 @@ corresponds to the default @tech{module name resolver}.
     separators. The resulting path names a @tech{collection}, then
     subcollection, etc., ending with a file name. No suffix is added
     automatically. (This convention is for compatibility
-    with older version of PLT Scheme.)}
+    with older version of PLT Scheme.)
 
+    Example: require the tar module from mzlib
+    @defexamples[#:eval (syntax-eval)
+      (require (lib "tar.ss" "mzlib"))]}
   }}
 
  @specsubform[id]{A shorthand for a @scheme[lib] form with a single
  @scheme[_rel-string] whose characters are the same as in the symbolic
  form of @scheme[id]. In addition to the constraints of a @scheme[lib]
- @scheme[_rel-string], @scheme[id] must not contain @litchar{.}.}
+ @scheme[_rel-string], @scheme[id] must not contain @litchar{.}.
+
+ @defexamples[#:eval (syntax-eval)
+   (require scheme/tcp)]}
 
  @defsubform[(file string)]{Similar to the plain @scheme[rel-string]
  case, but @scheme[string] is a path---possibly absolute---using the
- current platform's path conventions and @scheme[expand-user-path].}
+ current platform's path conventions and @scheme[expand-user-path].
+
+ @scheme[(require (file "~/tmp/x.ss"))]}
 
  @defsubform*[((planet id)
                (planet string)
@@ -475,7 +629,23 @@ corresponds to the default @tech{module name resolver}.
  @scheme[((unsyntax (schemeidfont "-")) _nat)] specifies a maximum
  version. The @schemeidfont{=}, @schemeidfont{+}, and @schemeidfont{-}
  identifiers in a minor-version constraint are recognized
- symbolically.}
+ symbolically.
+
+ Example: Load main.ss file package foo owned by bar.
+
+ @scheme[(require (planet bar/foo))]
+ 
+ Example: Load major version 2 of main.ss file package foo owned by bar.
+ 
+ @scheme[(require (planet bar/foo:2))]
+ 
+ Example: Load major version 2 and minor version 5 of main.ss file package foo owned by bar.
+ 
+ @scheme[(require (planet bar/foo:2:5))]
+ 
+ Example: Load major version 2 and minor version 5 of buz.ss file package foo owned by bar.
+ 
+ @scheme[(require (planet bar/foo:2:5/buz))]}
 
 No identifier can be bound multiple times in a given @tech{phase
 level} by an import, unless all of the bindings refer to the same
@@ -524,7 +694,15 @@ follows.
  @tech{phase level}. The symbolic form of @scheme[id] is used as the
  external name, and the symbolic form of the defined or imported
  identifier must match (otherwise, the external name could be
- ambiguous). }
+ ambiguous).
+
+ @defexamples[#:eval (syntax-eval)
+   (module test scheme
+      (provide foo)
+      (define foo 2))
+   (require 'test)
+   foo
+ ]}
 
  @defsubform[(all-defined-out)]{ Exports all identifiers that are
  defined at @tech{phase level} 0 or @tech{phase level} 1 within the
@@ -534,7 +712,15 @@ follows.
  accessible from the lexical context of the @scheme[(all-defined-out)]
  form are included; that is, macro-introduced imports are not
  re-exported, unless the @scheme[(all-defined-out)] form was
- introduced at the same time.}
+ introduced at the same time.
+
+ @defexamples[#:eval (syntax-eval)
+   (module test scheme
+     (provide (all-defined-out))
+     (define foo 2))
+   (require 'test)
+   foo
+ ]}
 
  @defsubform[(all-from-out module-path ...)]{ Exports all identifiers
  that are imported into the exporting module using a
@@ -545,23 +731,62 @@ follows.
  @scheme[module-path]. Only identifiers accessible from the lexical
  context of the @scheme[module-path] are included; that is,
  macro-introduced imports are not re-exported, unless the
- @scheme[module-path] was introduced at the same time.}
+ @scheme[module-path] was introduced at the same time.
+
+ @defexamples[#:eval (syntax-eval)
+   (module a scheme
+     (provide foo)
+     (define foo 2))
+   (module b scheme
+     (require 'a)
+     (provide (all-from-out 'a)))
+   (require 'b)
+   foo
+ ]}
 
  @defsubform[(rename-out [orig-id export-id] ...)]{ Exports each
  @scheme[orig-id], which must be @tech{bound} within the module at
  @tech{phase level} 0.  The symbolic name for each export is
- @scheme[export-id] instead @scheme[orig-d].}
+ @scheme[export-id] instead @scheme[orig-d].
+
+ @defexamples[#:eval (syntax-eval)
+   (module a scheme
+     (provide (rename-out (foo myfoo)))
+     (define foo 2))
+   (require 'a)
+   foo
+   myfoo
+ ]}
 
  @defsubform[(except-out provide-spec provide-spec ...)]{ Like the
  first @scheme[provide-spec], but omitting the bindings listed in each
  subsequent @scheme[provide-spec]. If one of the latter bindings is
  not included in the initial @scheme[provide-spec], a syntax error is
  reported. The symbolic export name information in the latter
- @scheme[provide-spec]s is ignored; only the bindings are used.}
+ @scheme[provide-spec]s is ignored; only the bindings are used.
+
+ @defexamples[#:eval (syntax-eval)
+   (module a scheme
+     (provide (except-out (all-defined-out)
+			  bar))
+     (define foo 2)
+     (define bar 3))
+   (require 'a)
+   foo
+   bar
+ ]}
 
  @defsubform[(prefix-out prefix-id provide-spec)]{
  Like @scheme[provide-spec], but with each symbolic export name from
- @scheme[provide-spec] prefixed with @scheme[prefix-id].}
+ @scheme[provide-spec] prefixed with @scheme[prefix-id].
+
+ @defexamples[#:eval (syntax-eval)
+   (module a scheme
+     (provide (prefix-out f: foo))
+     (define foo 2))
+   (require 'a)
+   f:foo
+ ]}
 
  @defsubform[(struct-out id)]{Exports the bindings associated with a
  structure type @scheme[id]. Typically, @scheme[id] is bound with
@@ -575,10 +800,32 @@ follows.
  includes a super-type identifier, and if the identifier has a
  @tech{transformer binding} of structure-type information, the
  accessor and mutator bindings of the super-type are @italic{not}
- included by @scheme[struct-out] for export.}
+ included by @scheme[struct-out] for export.
+
+ @defexamples[#:eval (syntax-eval)
+   (module a scheme
+     (provide (struct-out foo))
+     (define-struct foo (a b c)))
+   (require 'a)
+   make-foo
+   foo-a
+   foo-b
+   foo-c
+   foo?
+ ]}
 
  @defsubform[(combine-out provide-spec ...)]{ The union of the
- @scheme[provide-spec]s.}
+ @scheme[provide-spec]s.
+
+ @defexamples[#:eval (syntax-eval)
+   (module a scheme
+     (provide (combine-out foo bar))
+     (define foo 2)
+     (define bar 1))
+   (require 'a)
+   foo
+   bar
+ ]}
 
  @defsubform[(protect-out provide-spec ...)]{ Like the union of the
  @scheme[provide-spec]s, except that the exports are protected; see
@@ -616,8 +863,7 @@ multiple symbolic names.}
 
 
 @defform[(for-meta phase-level require-spec ...)]{See @scheme[require] and @scheme[provide].}
-@defform[(for-syntax require-spec ...)]{See @scheme[require] and @scheme[provide].}
-@defform[(for-template require-spec ...)]{See @scheme[require] and @scheme[provide].}
+@defform[(for-syntax require-spec ...)]{See @scheme[require] and @scheme[provide].} @defform[(for-template require-spec ...)]{See @scheme[require] and @scheme[provide].}
 @defform[(for-label require-spec ...)]{See @scheme[require] and @scheme[provide].}
 
 @defform/subs[(#%require raw-require-spec ...)
@@ -1602,6 +1848,21 @@ The second form is a shorthand the same as for @scheme[define]; it
 expands to a definition of the first form where the @scheme[expr] is a
 @scheme[lambda] form.}
 
+@defexamples[#:eval (syntax-eval)
+(define-syntax foo
+  (syntax-rules ()
+    ((_ a ...)
+     (printf "~a\n" (list a ...)))))
+
+(foo 1 2 3 4)
+
+(define-syntax (bar syntax-object)
+  (syntax-case syntax-object ()
+    ((_ a ...)
+     #'(printf "~a\n" (list a ...)))))
+
+(bar 1 2 3 4)
+]
 
 @defform[(define-syntaxes (id ...) expr)]{
 
@@ -1610,6 +1871,24 @@ for each @scheme[id].  The @scheme[expr] should produce as many values
 as @scheme[id]s, and each value is bound to the corresponding
 @scheme[id]. }
 
+@defexamples[#:eval (syntax-eval)
+(define-syntaxes (foo1 foo2 foo3)
+  (let ([transformer1 (lambda (syntax-object)
+			(syntax-case syntax-object ()
+			  [(_) #'1]))]
+	[transformer2 (lambda (syntax-object)
+			(syntax-case syntax-object ()
+			  [(_) #'2]))]
+	[transformer3 (lambda (syntax-object)
+			(syntax-case syntax-object ()
+			  [(_) #'3]))])
+    (values transformer1
+	    transformer2
+	    transformer3)))
+(foo1)
+(foo2)
+(foo3)
+]
 
 @defform*[[(define-for-syntax id expr)
            (define-for-syntax (head args) body ...+)]]{
@@ -1621,12 +1900,33 @@ expression for the binding is also at @tech{phase level} 1. (See
 Evaluation of @scheme[expr] side is @scheme[parameterize]d to set
 @scheme[current-namespace] as in @scheme[let-syntax].}
 
+@defexamples[#:eval (syntax-eval)
+(define-for-syntax foo 2)
+(define-syntax bar
+  (lambda (syntax-object)
+    (printf "foo is ~a\n" foo)
+    #'2))
+(bar)    
+(define-syntax (bar2 syntax-object)
+  (printf "foo is ~a\n" foo)
+  #'3)
+(bar2)  
+]
+
 @defform[(define-values-for-syntax (id ...) expr)]{
 
 Like @scheme[define-for-syntax], but @scheme[expr] must produce as
-many value as supplied @scheme[id]s, and all of the @scheme[id]s are
+many values as supplied @scheme[id]s, and all of the @scheme[id]s are
 bound (at @tech{phase level} 1).}
 
+@defexamples[#:eval (syntax-eval)
+(define-values-for-syntax (foo1 foo2) (values 1 2))
+(define-syntax (bar syntax-object)
+  (printf "foo1 is ~a foo2 is ~a\n" foo1 foo2)
+  #'2)
+(bar) 
+]
+
 @; ----------------------------------------------------------------------
 
 @subsection[#:tag "require-syntax"]{@scheme[require] Macros}
diff --git a/collects/scribblings/reference/time.scrbl b/collects/scribblings/reference/time.scrbl
index ac484daaa8..ca72c8637b 100644
--- a/collects/scribblings/reference/time.scrbl
+++ b/collects/scribblings/reference/time.scrbl
@@ -33,7 +33,7 @@ portability is needed.}
                  [hour (integer-in 0 23)]
                  [day (integer-in 1 31)]
                  [month (integer-in 1 12)]
-                 [year exact-nonnegative-integer?]
+                 [year exact-integer?]
                  [week-day (integer-in 0 6)]
                  [year-day (integer-in 0 365)]
                  [dst? boolean?]
diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl
index bbea44dcbe..d216800d16 100644
--- a/collects/scribblings/reference/units.scrbl
+++ b/collects/scribblings/reference/units.scrbl
@@ -19,6 +19,8 @@
 
 @title[#:tag "mzlib:unit" #:style 'toc]{Units}
 
+@guideintro["units"]{units}
+
 @deftech{Units} organize a program into separately compilable and
 reusable components. The imports and exports of a unit are grouped
 into a @deftech{signature}, which can include ``static'' information
@@ -576,6 +578,28 @@ each of the bindings implied by an @scheme[export]
 Like @scheme[unit/new-import-export], but binds static information to
 @scheme[unit-id] like @scheme[define-unit].}
 
+@defform[
+#:literals (import export)
+(unit/s
+  (import tagged-sig-spec ...)
+  (export tagged-sig-spec ...)
+  init-depends-decl
+  unit-id)]{
+
+Like @scheme[unit/new-import-export], but the linking clause is
+inferred, so @scheme[unit-id] must have the appropriate static
+information.}
+@defform[
+#:literals (import export)
+(define-unit/s name-id
+  (import tagged-sig-spec ...)
+  (export tagged-sig-spec ...)
+  init-depends-decl
+  unit-id)]{
+
+Like @scheme[unit/s], but binds static information to @scheme[name-id]
+like @scheme[define-unit].}
+
 @; ------------------------------------------------------------------------
 
 @section[#:tag "define-sig-form"]{Extending the Syntax of Signatures}
diff --git a/collects/scribblings/scribble/basic.scrbl b/collects/scribblings/scribble/basic.scrbl
index 2492ae3436..7d9bf57333 100644
--- a/collects/scribblings/scribble/basic.scrbl
+++ b/collects/scribblings/scribble/basic.scrbl
@@ -151,8 +151,12 @@ using @scheme[path->main-collects-relative].}
 
 @section{Text Styles}
 
-@def-elem-proc[elem]{ Wraps the @tech{decode}d @scheme[pre-content] as
-an element with style @scheme[#f].}
+@defproc[(elem [pre-content any/c] ...
+               [#:style style any/c #f])
+        element?]{
+
+Wraps the @tech{decode}d @scheme[pre-content] as an element with style
+@scheme[style].}
 
 @def-elem-proc[aux-elem]{Like @scheme[elem], but creates an
 @scheme[aux-element].}
@@ -163,7 +167,9 @@ an element with style @scheme[#f].}
 @def-style-proc[subscript]
 @def-style-proc[superscript]
 
-@def-elem-proc[smaller]{Like @scheme[elem], but with style @scheme["smaller"].}
+@def-elem-proc[smaller]{Like @scheme[elem], but with style
+@scheme["smaller"].  When uses of @scheme[smaller] are nested, text
+gets progressively smaller.}
 
 @defproc[(hspace [n exact-nonnegative-integer?]) element?]{
 
diff --git a/collects/scribblings/scribble/config.scrbl b/collects/scribblings/scribble/config.scrbl
new file mode 100644
index 0000000000..2f145316d5
--- /dev/null
+++ b/collects/scribblings/scribble/config.scrbl
@@ -0,0 +1,135 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/struct
+          scribble/decode
+          "utils.ss"
+          (for-label scheme/base))
+
+@(define (nested . str)
+   (make-blockquote #f (flow-paragraphs (decode-flow str))))
+@(define (fake-title . str) (apply bold str))
+
+@title[#:tag "config"]{Extending and Configuring Scribble Output}
+
+Sometimes, Scribble's primitives and built-in styles are insufficient
+to produce the output that you need. The cases in which you need to
+extend or configure Scribble fall into two groups:
+
+@itemize[
+
+ @item{You may need to drop into the back-end ``language'' of CSS or
+       Tex to create a specific output effect. For this kind of
+       extension, you will mostly likely attach a @scheme[`(css
+       ,_file)] or @scheme[`(tex ,_file)] style to a @scheme[section]
+       and then use a string defined in the @scheme[_file] as an
+       @scheme[element] or @tech{block} style. This kind of extension
+       is described in @secref["extra-style"].}
+
+ @item{You may need to produce a document whose page layout is
+       different from the PLT Scheme documentation style. For that
+       kind of configuration, you will most likely run the
+       @exec{scribble} command-line tool and supply flags like
+       @DFlag{prefix} or @DPFlag{style}. This kind of configuration
+       is described in @secref["config-style"].}
+
+]
+
+@; ------------------------------------------------------------
+
+@section[#:tag "extra-style" 
+         #:style `((css "inbox.css") (tex "inbox.tex"))]{Adding a Style}
+
+When a string is uses as a style in an @scheme[element],
+@scheme[styled-paragraph], or @scheme[blockquote], it corresponds to a
+CSS class for HTML output or a Tex macro (or Latex environment, in the
+case of @scheme[blockquote]) for Latex output.
+
+Scribble includes a number of predefined styles that are used by the
+exports of @scheme[scribble/manual], but they are not generally
+intended for direct use. For now, use them or redefine them at your
+own risk. 
+
+To add a mapping from your own style name to a CSS configuration, add
+a @scheme[`(css ,_file)] style (in a list of styles) to an enclosing
+@scheme[part]. To map a style name to a Tex macro (or Latex
+environment), add a @scheme[`(tex ,_file)] style to an enclosing part.
+
+To avoid collisions with future additions to Scribble, start your
+style name with an uppercase letter that is not @litchar{S}. An
+uppercase letter helps to avoid collisions with macros defined by
+Latex packages, and future styles needed by @scheme[scribble/manual]
+will start with @litchar{S}.
+
+For example, a Scribble document
+
+@verbatim[#:indent 2]|{
+ #lang scribble/doc
+ @(require manual)
+
+ @title[#:style `((css "inbox.css") (tex "inbox.tex"))]{Quantum Pet}
+
+ Do not open: @elem[#:style "InBox"]{Cat}
+}|
+
+combined with an @filepath{inbox.css} that contains
+
+@verbatim[#:indent 2]|{
+  .inbox {
+    padding: 0.2em;
+    border: 1px solid #000000;
+  }
+}|
+
+and an @filepath{inbox.tex} that contains
+
+@verbatim[#:indent 2]|{
+  \newcommand{\InBox}[1]{\fbox{#1}}
+}|
+
+generates
+
+@nested{
+ @fake-title{Quantum Pet}
+
+ Do not open: @elem[#:style "InBox"]{Cat}
+}
+
+@; ------------------------------------------------------------
+
+@section[#:tag "config-style"]{Configuring Output}
+
+Scribble's output is configured in two layers:
+
+@itemize[
+
+ @item{A prefix determines the @tt{DOCTYPE} line for HTML output or
+       the @tt{documentclass} configuration (and perhaps some addition
+       package uses or other configuration) for Latex output. The
+       default prefix is @filepath{scribble-prefix.html} or
+       @filepath{scribble-prefix.tex} in the @filepath{scribble}
+       collection.}
+
+ @item{Style definitions for all of the ``built-in'' styles used by
+        @scheme[scribble/manual] (as described in
+        @secref["extra-style"]).  The default style definitions are
+        @filepath{scribble.css} or @filepath{scribble.tex} in the
+        @filepath{scribble} collection.}
+
+]
+
+When using the @exec{scribble} command-line utility:
+
+@itemize[
+
+ @item{Replace the prefix using the @as-index{@DFlag{prefix}} flag.}
+
+ @item{Replace the style definitions using the
+       @as-index{@DFlag{style}} flag.}
+
+ @item{Add style definitions (that can override earlier ones)
+       using the @as-index{@DPFlag{style}} flag.}
+
+]
+
+For now, reading the default files is the best way to understand how
+they interact.
diff --git a/collects/scribblings/scribble/how-to.scrbl b/collects/scribblings/scribble/how-to.scrbl
index 63b6ff34ca..39c7ad4bd5 100644
--- a/collects/scribblings/scribble/how-to.scrbl
+++ b/collects/scribblings/scribble/how-to.scrbl
@@ -9,7 +9,11 @@ Although the @exec{scribble} command-line utility generates output
 from a Scribble document (run @exec{scribble -h} for more
 information), documentation of PLT Scheme libraries is normally built
 by @exec{setup-plt}. This chapter emphasizes the @exec{setup-plt}
-approach, which more automatically supports links across documents.
+approach, which more automatically supports links across
+documents.
+
+@margin-note{See @secref["config"] for information on using the
+             @exec{scribble} command-line utility.}
 
 @;----------------------------------------
 @section[#:tag "getting-started"]{Getting Started}
diff --git a/collects/scribblings/scribble/inbox.css b/collects/scribblings/scribble/inbox.css
new file mode 100644
index 0000000000..4cc3a9037f
--- /dev/null
+++ b/collects/scribblings/scribble/inbox.css
@@ -0,0 +1,4 @@
+.inbox {
+  padding: 0.2em;
+  border: 1px solid #000000;
+}
diff --git a/collects/scribblings/scribble/inbox.tex b/collects/scribblings/scribble/inbox.tex
new file mode 100644
index 0000000000..399a3ee234
--- /dev/null
+++ b/collects/scribblings/scribble/inbox.tex
@@ -0,0 +1,2 @@
+
+\newcommand{\InBox}[1]{\fbox{#1}}
diff --git a/collects/scribblings/scribble/lp-ex-doc.scrbl b/collects/scribblings/scribble/lp-ex-doc.scrbl
new file mode 100644
index 0000000000..2d3bd6ae6f
--- /dev/null
+++ b/collects/scribblings/scribble/lp-ex-doc.scrbl
@@ -0,0 +1,4 @@
+#lang scribble/doc
+@(require scribble/lp-include)
+
+@lp-include["lp-ex.ss"]
diff --git a/collects/scribblings/scribble/lp-ex.ss b/collects/scribblings/scribble/lp-ex.ss
new file mode 100644
index 0000000000..34017c90e5
--- /dev/null
+++ b/collects/scribblings/scribble/lp-ex.ss
@@ -0,0 +1,17 @@
+#lang scribble/lp
+
+Literate programs have chunks of code, like this one:
+
+@chunk[<f>
+       (define (f x)
+         <fs-body>)]
+
+and this one:
+
+@chunk[<fs-body>
+       (* x x)]
+
+that, when assembled, produce a complete program, in this case:
+
+@schemeblock[(define (f x)
+               (* x x))]
diff --git a/collects/scribblings/scribble/lp.css b/collects/scribblings/scribble/lp.css
new file mode 100644
index 0000000000..638efcd2a1
--- /dev/null
+++ b/collects/scribblings/scribble/lp.css
@@ -0,0 +1,4 @@
+.LPBoxed {
+  padding: 1ex;
+  border: 1px solid #000000;
+}
diff --git a/collects/scribblings/scribble/lp.scrbl b/collects/scribblings/scribble/lp.scrbl
new file mode 100644
index 0000000000..9bf1ffe635
--- /dev/null
+++ b/collects/scribblings/scribble/lp.scrbl
@@ -0,0 +1,73 @@
+#lang scribble/doc
+@(require scribble/manual 
+          scribble/struct 
+          scheme/runtime-path
+          (prefix-in lp-ex: "lp-ex-doc.scrbl")
+          "utils.ss"
+          (for-label scribble/lp-include scribble/lp))
+
+@title[#:tag "lp" #:style `((css "lp.css") (tex "lp.tex")) ]{Literate Programming}
+
+Programs written using @schememodname[scribble/lp] are simultaneously
+two things: a program and a document describing the program.
+
+Programs in @schememodname[scribble/lp] are viewed in two different
+ways, either by running the program directly or by including it with
+@scheme[lp-include].  When running the program, all of the
+@scheme[chunk] expressions are collected and stitched together into a
+program, and the rest of the module is discarded. When using
+@scheme[lp-include], the entire contents of the module are preserved
+and are treated like an ordinary Scribble document, where
+@scheme[chunk]s are typeset in a manner similar to @scheme[codeblock].
+
+@(define-runtime-path lp-ex "lp-ex.ss")
+
+For example, consider this program:
+
+@(call-with-input-file lp-ex
+   (lambda (port)
+     (verbatim
+      #:indent 2
+      (apply 
+       string-append
+       (let loop ()
+	 (let ([line (read-line port 'any)])
+	   (cond
+	    [(eof-object? line) '()]
+            [(equal? line "") (cons "  \n" (loop))]
+            [else 
+	       (list* line "\n" (loop))])))))))
+
+When this file is @scheme[require]d in the normal manner, it defines a
+function @scheme[f] that squares its argument, and the documentation
+is ignored. When it is included with @scheme[lp-include], it looks
+like this:
+
+@(make-blockquote
+  "LPBoxed"
+  (flow-paragraphs (part-flow lp-ex:doc)))
+
+@section{@schememodname[scribble/lp] Language}
+
+@defmodulelang[scribble/lp]{The @schememodname[scribble/lp] language
+provides core support for literate programming.}
+
+@defform[(chunk id form ...)]{
+
+  Introduces a chunk, binding @scheme[id] for use in other
+  chunks. Normally, @scheme[id] starts with @litchar{<} and ends with
+  @litchar{>}.
+
+  If @scheme[id] is @schemeidfont{<*>}, then this chunk is used as the main
+  chunk in the file. If @schemeidfont{<*>} is never used, then the first chunk
+  in the file is treated as the main chunk.
+}
+
+@section{@schememodname[scribble/lp-include] Module}
+
+@defmodule[scribble/lp-include]{}
+
+@defform[(lp-include filename)]{
+Includes the source of @scheme[filename] as the typeset version of the literate
+program.
+}
diff --git a/collects/scribblings/scribble/lp.tex b/collects/scribblings/scribble/lp.tex
new file mode 100644
index 0000000000..fcbaecac57
--- /dev/null
+++ b/collects/scribblings/scribble/lp.tex
@@ -0,0 +1,3 @@
+
+\usepackage{framed}
+\newenvironment{LPBoxed}{\begin{framed}}{\end{framed}}
diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl
index 9434c4999c..4f94f26332 100644
--- a/collects/scribblings/scribble/manual.scrbl
+++ b/collects/scribblings/scribble/manual.scrbl
@@ -4,8 +4,8 @@
           (for-syntax scheme/base)
           (for-label scribble/manual-struct))
 
-@(define ellipses (scheme ...))
-@(define ellipses+ (scheme ...+))
+@(define lit-ellipses (scheme ...))
+@(define lit-ellipses+ (scheme ...+))
 
 @title[#:tag "manual" #:style 'toc]{Manual Forms}
 
@@ -357,8 +357,8 @@ sub-sections.}
                          (keyword arg-id contract-expr-datum default-expr)
                          ellipses
                          ellipses+]
-               [ellipses #, @ellipses]
-               [ellipses+ #, @ellipses+])]{
+               [ellipses #, @lit-ellipses]
+               [ellipses+ #, @lit-ellipses+])]{
 
 Produces a sequence of flow elements (encapsulated in a
 @scheme[splice]) to document a procedure named @scheme[id]. Nesting
@@ -393,14 +393,14 @@ Each @scheme[arg-spec] must have one of the following forms:
        Like the previous case, but with a default
        value.}
 
-@specsubform[#, @ellipses]{Any number of the preceding argument.  This
+@specsubform[#, @lit-ellipses]{Any number of the preceding argument.  This
        form is normally used at the end, but keyword-based arguments
        can sensibly appear afterward. See also the documentation for
-       @scheme[append] for a use of @ellipses before the last
+       @scheme[append] for a use of @lit-ellipses before the last
        argument.}
 
-@specsubform[#, @ellipses+]{One or more of the preceding argument
-       (normally at the end, like @ellipses).}
+@specsubform[#, @lit-ellipses+]{One or more of the preceding argument
+       (normally at the end, like @lit-ellipses).}
 
 The @scheme[result-contract-expr-datum] is typeset via
 @scheme[schemeblock0], and it represents a contract on the procedure's
@@ -613,6 +613,29 @@ typeset as with @scheme[scheme].}
 Like @scheme[schemegrammar], but for typesetting multiple productions
 at once, aligned around the @litchar{=} and @litchar{|}.}
 
+@defproc[(defidentifier [id identifier?]
+                        [#:form? form? any/c #f]
+                        [#:index? index? any/c #t]
+                        [#:show-libs? show-libs? any/c #t])
+         element?]{
+
+Typesets @scheme[id] as a Scheme identifier, and also establishes the
+identifier as the definition of a binding in the same way as
+@scheme[defproc], @scheme[defform], etc. As always, the library that
+provides the identifier must be declared via @scheme[defmodule] or
+@scheme[declare-exporting] for an enclosing section.
+
+If @scheme[form?] is a true value, then the identifier is documented
+as a syntactic form, so that uses of the identifier (normally
+including @scheme[id] itself) are typeset as a syntactic form.
+
+If @scheme[index?] is a true value, then the identifier is registered
+in the index.
+
+If @scheme[show-libs?] is a true value, then the identifier's defining
+module may be exposed in the typeset form (e.g., when viewing HTML and
+the mouse hovers over the identifier).}
+
 @; ------------------------------------------------------------------------
 @section[#:tag "doc-classes"]{Documenting Classes and Interfaces}
 
@@ -906,7 +929,8 @@ The @tech{decode}d @scheme[pre-content] is hyperlinked to @scheme[t],
 which is normally defined using @scheme[elemtag].}
 
 
-@defproc[(deftech [pre-content any/c] ...) element?]{
+@defproc[(deftech [pre-content any/c] ...
+                  [#:style? style? any/c #t]) element?]{
 
 Produces an element for the @tech{decode}d @scheme[pre-content], and
 also defines a term that can be referenced elsewhere using
@@ -929,7 +953,10 @@ as follows:
 
 These normalization steps help support natural-language references
 that differ slightly from a defined form. For example, a definition of
-``bananas'' can be referenced with a use of ``banana''.}
+``bananas'' can be referenced with a use of ``banana''.
+
+If @scheme[style?] is true, then @scheme[defterm] is used on
+@scheme[pre-content].}
 
 @defproc[(tech [pre-content any/c] ...
                [#:doc module-path (or/c module-path? false/c) #f])
diff --git a/collects/scribblings/scribble/reader.scrbl b/collects/scribblings/scribble/reader.scrbl
index 0b4babd035..97ece3341e 100644
--- a/collects/scribblings/scribble/reader.scrbl
+++ b/collects/scribblings/scribble/reader.scrbl
@@ -23,13 +23,16 @@ You can use the reader via MzScheme's @schemefont{#reader} form:
       #reader scribble/reader @foo{This is free-form text!}
 }|]
 
+or use the @scheme[at-exp] meta-language as described in
+@secref["at-exp-lang"].
+
 Note that the Scribble reader reads @"@"-forms as S-expressions.  This
 means that it is up to you to give meanings for these expressions in
 the usual way: use Scheme functions, define your functions, or require
 functions.  For example, typing the above into MzScheme is likely
-going to produce a ``reference to undefined identifier'' error --- you
-can use @scheme[string-append] instead, or you can define @scheme[foo]
-as a function (with variable arity).
+going to produce a ``reference to undefined identifier'' error, unless
+@scheme[foo] is defined. You can use @scheme[string-append] instead,
+or you can define @scheme[foo] as a function (with variable arity).
 
 A common use of the Scribble @"@"-reader is when using Scribble as a
 documentation system for producing manuals.  In this case, the manual
@@ -37,7 +40,7 @@ text is likely to start with
 
 @schememod[scribble/doc]
 
-which installs the @"@" reader starting in ``text mode'', wraps the
+which installs the @"@" reader starting in ``text mode,'' wraps the
 file content afterward into a MzScheme module where many useful Scheme
 and documentation related functions are available, and parses the body
 into a document using @schememodname[scribble/decode].  See
@@ -833,6 +836,25 @@ is an example of this.
    })
 ]
 
+@;--------------------------------------------------------------------
+@section[#:tag "at-exp-lang"]{Adding @"@"-expressions to a Language}
+
+@defmodulelang[at-exp]{The @schememodname[at-exp] language installs
+@"@"-reader support in the readtable, and then chains to the reader of
+another language that is specified immediate after
+@schememodname[at-exp].}
+
+For example, @scheme[#, @hash-lang[] at-exp scheme/base] adds @"@"-reader
+support to @scheme[scheme/base], so that
+
+@schememod[
+at-exp scheme/base
+
+(define (greet who) #, @elem{@tt["@"]@scheme[string-append]@schemeparenfont["{"]@schemevalfont{Hello, }@tt["@|"]@scheme[who]@tt["|"]@schemevalfont{.}@schemeparenfont["}"]})
+(greet "friend")]
+
+reports @scheme["Hello, friend."].
+
 @;--------------------------------------------------------------------
 @section{Interface}
 
@@ -926,4 +948,5 @@ line counting for the current input-port via @scheme[port-count-lines!].}
 @; *** End reader-import section ***
 ))]))
 @with-scribble-read[]
+
  
diff --git a/collects/scribblings/scribble/scheme.scrbl b/collects/scribblings/scribble/scheme.scrbl
index df9598412e..5c7376738b 100644
--- a/collects/scribblings/scribble/scheme.scrbl
+++ b/collects/scribblings/scribble/scheme.scrbl
@@ -1,6 +1,7 @@
 #lang scribble/doc
 @(require scribble/manual
-          "utils.ss")
+          "utils.ss"
+          (for-label scribble/scheme))
 
 @title[#:tag "scheme"]{Scheme}
 
@@ -8,4 +9,144 @@
 provides utilities for typesetting Scheme code. The
 @scheme[scribble/manual] forms provide a higher-level interface.}
 
-@italic{To do:} document this library!
+@defform*[[(define-code id typeset-expr)
+           (define-code id typeset-expr uncode-id)
+           (define-code id typeset-expr uncode-id d->s-expr)
+           (define-code id typeset-expr uncode-id d->s-expr stx-prop-expr)]]{
+
+Binds @scheme[id] to a form similar to @scheme[scheme] or
+@scheme[schemeblock] for typesetting code. The form generated by
+@scheme[define-code] handles source-location information, escapes via
+@scheme[unquote], preservation of binding and property information,
+and @tech{element transformers}.
+
+The supplied @scheme[typeset-expr] expression should produce a
+procedure that performs the actual typesetting. This expression is
+normally @scheme[to-element] or @scheme[to-paragraph]. The argument
+supplied to @scheme[typeset-expr] is normally a syntax object, but
+more generally it is the result of applying @scheme[d->s-expr].
+
+The optional @scheme[uncode-id] specifies the escape from literal code
+to be recognized by @scheme[id]. The default is @scheme[unsyntax].
+
+The optional @scheme[d->s-expr] should produce a procedure that
+accepts three arguments suitable for @scheme[datum->syntax]: a syntax
+object or @scheme[#f], an arbitrary value, and a vector for a source
+location. The result should record as much or as little of the
+argument information as needed by @scheme[typeset-expr] to typeset the
+code. Normally, @scheme[d->s-expr] is @scheme[datum->syntax].
+
+The @scheme[stx-prop-expr] should produce a procedure for recording a
+@scheme['paren-shape] property when the source expression uses with
+@scheme[id] has such a property. The default is
+@scheme[syntax-property].}
+
+@defproc[(to-paragraph [v any/c]) block?]{
+
+Typesets an S-expression that is represented by a syntax object, where
+source-location information in the syntax object controls the
+generated layout.
+
+Identifiers that have @scheme[for-label] bindings are typeset and
+hyperlinked based on definitions declared elsewhere (via
+@scheme[defproc], @scheme[defform], etc.). The identifiers
+@schemeidfont{code:line}, @schemeidfont{code:comment}, and
+@schemeidfont{code:blank} are handled as in @scheme[schemeblock], as
+are identifiers that start with @litchar{_}.
+
+In addition, the given @scheme[v] can contain @scheme[var-id],
+@scheme[shaped-parens], @scheme[just-context], or
+@scheme[literal-syntax] structures to be typeset specially (see each
+structure type for details), or it can contain @scheme[element]
+structures that are used directly in the output.}
+
+
+@defproc[((to-paragraph/prefix [prefix1 any/c] [prefix any/c] [suffix any/c])
+          [v any/c]) 
+          block?]{
+
+Like @scheme[to-paragraph], but @scheme[prefix1] is prefixed onto the
+first line, @scheme[prefix] is prefix to any subsequent line, and
+@scheme[suffix] is added to the end. The @scheme[prefix1],
+@scheme[prefix], and @scheme[suffix] arguments are used as
+@tech{elements}, except that if @scheme[suffix] is a list of elements,
+it is added to the end on its own line.}
+
+
+@defproc[(to-element [v any/c]) element?]{
+
+Like @scheme[to-paragraph], except that source-location information is
+mostly ignored, since the result is meant to be inlined into a
+paragraph.}
+
+@defproc[(to-element/no-color [v any/c]) element?]{
+
+Like @scheme[to-element], but @scheme[for-syntax] bindings are
+ignored, and the generated text is uncolored. This variant is
+typically used to typeset results.}
+
+
+@defstruct[var-id ([sym (or/c symbol? identifier?)])]{
+
+When @scheme[to-paragraph] and variants encounter a @scheme[var-id]
+structure, it is typeset as @scheme[sym] in the variable font, like
+@scheme[schemevarfont].}
+
+
+@defstruct[shaped-parens ([val any/c]
+                          [shape char?])]{
+
+When @scheme[to-paragraph] and variants encounter a
+@scheme[shaped-parens] structure, it is typeset like a syntax object
+that has a @scheme['paren-shape] property with value @scheme[shape].}
+
+
+@defstruct[just-context ([val any/c]
+                         [context syntax?])]{
+
+When @scheme[to-paragraph] and variants encounter a
+@scheme[just-context] structure, it is typeset using the
+source-location information of @scheme[val] just the lexical context
+of @scheme[ctx].}
+
+
+@defstruct[literal-syntax ([stx any/c])]{
+
+When @scheme[to-paragraph] and variants encounter a
+@scheme[literal-syntax] structure, it is typeset as the string form of
+@scheme[stx]. This can be used to typeset a syntax-object value in the
+way that the default printer would represent the value.}
+
+
+@defproc[(element-id-transformer? [v any/c]) boolean?]{
+
+Provided @scheme[for-syntax]; returns @scheme[#t] if @scheme[v] is an
+@tech{element transformer} created by
+@scheme[make-element-id-transformer], @scheme[#f] otherwise.}
+
+
+@defproc[(make-element-id-transformer [proc (syntax? . -> . syntax?)])
+         element-id-transformer?]{
+
+Provided @scheme[for-syntax]; creates an @deftech{element
+transformer}.  When an identifier has a transformer binding to an
+@tech{element transformer}, then forms generated by
+@scheme[define-code] (including @scheme[scheme] and
+@scheme[schemeblock]) typeset the identifier by applying the
+@scheme[proc] to the identifier. The result must be an expression
+whose value, typically an @scheme[element], is passed on to functions
+like @scheme[to-paragraph] .}
+
+@defproc[(variable-id? [v any/c]) boolean?]{
+
+Provided @scheme[for-syntax]; returns @scheme[#t] if @scheme[v] is an
+@tech{element transformer} created by @scheme[make-variable-id],
+@scheme[#f] otherwise.}
+
+
+@defproc[(make-variable-id [sym (or/c symbol? identifier?)])
+         variable-id?]{
+
+Provided @scheme[for-syntax]; like @scheme[element-id-transformer] for
+a transformer that produces @scheme[sym] typeset as a variable (like
+@scheme[schemevarfont]).}
diff --git a/collects/scribblings/scribble/scribble.scrbl b/collects/scribblings/scribble/scribble.scrbl
index 37be0ce492..71fff8e89a 100644
--- a/collects/scribblings/scribble/scribble.scrbl
+++ b/collects/scribblings/scribble/scribble.scrbl
@@ -37,7 +37,9 @@ starting with the @filepath{scribble.scrbl} file.
 @include-section["eval.scrbl"]
 @include-section["srcdoc.scrbl"]
 @include-section["bnf.scrbl"]
+@include-section["lp.scrbl"]
 @include-section["xref.scrbl"]
 @include-section["preprocessor.scrbl"]
+@include-section["config.scrbl"]
 
 @index-section[]
diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl
index f5d6556421..f0912ac1d6 100644
--- a/collects/scribblings/scribble/struct.scrbl
+++ b/collects/scribblings/scribble/struct.scrbl
@@ -257,9 +257,9 @@ to the section.
 
 The @scheme[title-content] field holds the part's title, if any.
 
-The @scheme[style] field is normally either a symbol or a list of
-symbols.  The currently recognized style symbols (alone or in a list)
-are as follows:
+The @scheme[style] field is normally either a symbol or a list.  The
+currently recognized style symbols (alone or in a list) or other
+values (must be in a list) are as follows:
 
 @itemize{
 
@@ -288,6 +288,20 @@ are as follows:
        multi-page documents) takes on the location and color of the
        main table of contents, instead.}
 
+  @item{@scheme[`(css ,_path)] --- generated HTML refers to (a copy
+        of) @scheme[_path] as CSS.}
+
+  @item{@scheme[`(tex ,_path)] --- generated Latex includes
+        (a copy of) @scheme[_path] in the document header.}
+
+  @item{@scheme[`(body-id ,_string)] --- generated HTML uses
+        @scheme[_string] as the @tt{id} attribute of the @tt{body}
+        tag; this style can be set separately for parts that start
+        different HTML pages, otherwise it is effectively inherited by
+        sub-parts; the default is @scheme["scribble-plt-scheme.org"],
+        but @exec{setup-plt} installs @scheme["doc-plt-scheme.org"]
+        as the @tt{id} for any document that it builds.}
+
 }
 
 The @scheme[to-collect] field contains @techlink{content} that is
@@ -350,7 +364,7 @@ The @scheme[style] can be
 @itemize[
 
  @item{A string that corresponds to a CSS class for HTML output or a
-       macro for Latex output.}
+       macro for Latex output (see @secref["extra-style"]).}
 
  @item{An instance of @scheme[with-attributes], which combines a base
        style with a set of additional HTML attributes.}
@@ -386,7 +400,7 @@ The @scheme[style] can be any of the following:
 @itemize[
 
  @item{A string that corresponds to a CSS class for
-       HTML output.}
+       HTML output (see @secref["extra-style"]).}
 
  @item{@scheme['boxed] to render as a definition.}
 
@@ -404,13 +418,16 @@ The @scheme[style] can be any of the following:
 
          @item{@scheme['row-styles] to a list of association lists,
                one for each row in the table. Each of these nested
-               association lists maps @scheme['alignment] and
-               @scheme['valignment] to a list of symbols an
-               @scheme[#f]s, one for each column. The symbols in an
-               @scheme['alignment] list can be @scheme['left],
-               @scheme['right], or @scheme['center]. The symbols in a
-               @scheme['valignment] list can be @scheme['top],
-               @scheme['baseline], or @scheme['bottom].}
+               association lists can map @scheme['alignment] and
+               @scheme['valignment] to a list of symbols and
+               @scheme[#f]s (one for each column cell) and/or
+               @scheme['style] to a list of strings and @scheme[#f]s
+               (one for each column cell) for a CSS class in HTML
+               output. The symbols in an @scheme['alignment] list can
+               be @scheme['left], @scheme['right], or
+               @scheme['center]. The symbols in a @scheme['valignment]
+               list can be @scheme['top], @scheme['baseline], or
+               @scheme['bottom].}
 
          ]}
 
@@ -431,7 +448,8 @@ A @techlink{itemization} has a list of flows.
 
 A @techlink{blockquote} has a style and a list of @tech{blocks}.  The
 @scheme[style] field is normally a string that corresponds to a CSS
-class for HTML output.
+class for HTML output or Latex environment for Latex output (see
+@secref["extra-style"]).
 
 }
 
@@ -452,7 +470,7 @@ The @scheme[style] field is normally either
 @itemize{
 
  @item{a string, which corresponds to a CSS class for HTML output and
-       a macro name for Latex output;}
+       a macro name for Latex output (see @secref["extra-style"]);}
 
  @item{one of the symbols that all renderers recognize: @scheme['tt],
        @scheme['italic], @scheme['bold], @scheme['sf],
diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl
index f7c2be7001..cae5e309f1 100644
--- a/collects/scribblings/slideshow/picts.scrbl
+++ b/collects/scribblings/slideshow/picts.scrbl
@@ -285,6 +285,10 @@ argument for consistency with the other functions.}
                       [find-src (pict? pict-path? . -> . (values real? real?))]
                       [dest pict-path?]
                       [find-dest (pict? pict-path? . -> . (values real? real?))]
+                      [#:start-angle start-angle (or/c real? #f) #f]
+                      [#:end-angle end-angle (or/c real? #f) #f]
+                      [#:start-pull start-pull real? 1/4]
+                      [#:end-pull end-pull real? 1/4]
                       [#:line-width line-width (or/c #f real?) #f]
                       [#:color color (or/c #f string? (is-a/c? color%)) #f]
                       [#:under? under? any/c #f])
@@ -294,6 +298,10 @@ argument for consistency with the other functions.}
                       [find-src (pict? pict-path? . -> . (values real? real?))]
                       [dest pict-path?]
                       [find-dest (pict? pict-path? . -> . (values real? real?))]
+                      [#:start-angle start-angle (or/c real? #f) #f]
+                      [#:end-angle end-angle (or/c real? #f) #f]
+                      [#:start-pull start-pull real? 1/4]
+                      [#:end-pull end-pull real? 1/4]
                       [#:line-width line-width (or/c #f real?) #f]
                       [#:color color (or/c #f string? (is-a/c? color%)) #f]
                       [#:under? under? any/c #f]
@@ -304,6 +312,10 @@ argument for consistency with the other functions.}
                       [find-src (pict? pict-path? . -> . (values real? real?))]
                       [dest pict-path?]
                       [find-dest (pict? pict-path? . -> . (values real? real?))]
+                      [#:start-angle start-angle (or/c real? #f) #f]
+                      [#:end-angle end-angle (or/c real? #f) #f]
+                      [#:start-pull start-pull real? 1/4]
+                      [#:end-pull end-pull real? 1/4]
                       [#:line-width line-width (or/c #f real?) #f]
                       [#:color color (or/c #f string? (is-a/c? color%)) #f]
                       [#:under? under? any/c #f]
@@ -317,7 +329,25 @@ and destination of the line.
 If @scheme[under?] is true, then the line and arrows are added under
 the existing @scheme[pict] drawing, instead of on top. If
 @scheme[solid?] is false, then the arrowheads are hollow instead of
-filled.}
+filled.
+
+The @scheme[start-angle], @scheme[end-angle], @scheme[start-pull], and
+@scheme[end-pull] arguments control the curve of the line:
+
+@itemize[
+
+ @item{The @scheme[start-angle] and @scheme[end-angle] arguments
+       specify the direction of curve at its start and end positions;
+       if either is @scheme[#f], it defaults to the angle of a
+       straight line from the start position to end position.}
+
+ @item{The @scheme[start-pull] and @scheme[end-pull] arguments specify
+       a kind of momentum for the starting and ending angles; larger
+       values preserve the angle longer.}
+
+]
+
+The defaults produce a straight line.}
 
 @defthing[text-style/c contract?]{
 
diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss
index deb88f66f2..20caa3162f 100644
--- a/collects/setup/scribble.ss
+++ b/collects/setup/scribble.ss
@@ -310,12 +310,19 @@
     (let ([tag-prefix p]
           [tags (if (member '(part "top") (part-tags v))
                   (part-tags v)
-                  (cons '(part "top") (part-tags v)))])
+                  (cons '(part "top") (part-tags v)))]
+          [style (if (list? (part-style v))
+                     (part-style v)
+                     (list (part-style v)))])
       (make-versioned-part
        tag-prefix
        tags
        (part-title-content v)
-       (part-style v)
+       (if (ormap (lambda (s)
+                    (and (pair? s) (eq? (car s) 'body-id)))
+                  style)
+           style
+           (cons '(body-id "doc-plt-scheme-org") style))
        (part-to-collect v)
        (part-flow v)
        (part-parts v)
diff --git a/collects/slideshow/core.ss b/collects/slideshow/core.ss
index 614b20ddcb..dd8e7bc755 100644
--- a/collects/slideshow/core.ss
+++ b/collects/slideshow/core.ss
@@ -561,6 +561,11 @@
 	(define ah (arrowhead gap-size 0))
 	(define current-item (colorize (hc-append (- (/ gap-size 2)) ah ah) blue))
 	(define other-item (rc-superimpose (ghost current-item) (colorize ah "light gray")))
+        (define (to-next l)
+          (let ([l (cdddr l)])
+            (if (and (pair? l) (number? (car l)))
+                (cdr l)
+                l)))
 	(lambda (which)
 	  (slide/name
 	   (format "--~a--"
@@ -569,7 +574,7 @@
 		      [(null? l) "<unknown>"]
 		      [(eq? (car l) which)
 		       (cadr l)]
-		      [else (loop (cdddr l))])))
+		      [else (loop (to-next l))])))
 	   (blank (+ title-h gap-size))
 	   (lc-superimpose
 	    (blank (current-para-width) 0)
@@ -581,7 +586,7 @@
 				    (and (list? (car l))
 					 (memq which (car l))))])
 		  (vc-append
-		   gap-size
+                   gap-size
 		   (page-para
 		    (hbl-append
 		     (quotient gap-size 2)
@@ -592,8 +597,12 @@
 		       (if (pict? p)
 			   p
 			   (bt p)))))
-		   (let ([rest (loop (cdddr l))]
-			 [sub-items (caddr l)])
+		   (let* ([rest (let ([p (loop (to-next l))]
+                                      [l (cdddr l)])
+                                  (if (and (pair? l) (number? (car l)))
+                                      (inset p 0 (car l) 0 0)
+                                      p))]
+                          [sub-items (caddr l)])
 		     (if (and current?
 			      sub-items
 			      (not (null? sub-items)))
diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss
index 3a8e3c7250..adc304e0d8 100644
--- a/collects/slideshow/pict.ss
+++ b/collects/slideshow/pict.ss
@@ -6,7 +6,9 @@
            (rename-in texpict/utils
                       [pin-line t:pin-line]
                       [pin-arrow-line t:pin-arrow-line]
-                      [pin-arrows-line t:pin-arrows-line]))
+                      [pin-arrows-line t:pin-arrows-line])
+           (only-in scheme/gui/base dc-path%)
+           (only-in scheme/class new send))
 
   (define (hline w h #:segment [seg #f])
     (if seg
@@ -40,36 +42,123 @@
              (list? p)
              (andmap pict? p))))
 
-  (define (pin-line p src find-src dest find-dest
-                    #:line-width [lw #f]
+  (define (pin-line sz p 
+                    src src-find
+                    dest dest-find
+                    #:start-angle [sa #f] #:end-angle [ea #f]
+                    #:start-pull [sp #f] #:end-pull [ep #f]
                     #:color [col #f]
-                    #:under? [under? #f])
-    (finish-pin (launder (t:pin-line (ghost p)
-                                     src find-src 
-                                     dest find-dest))
-                p lw col under?))
+                    #:line-width [lw #f]
+                    #:under? [under? #f]
+                    #:solid? [solid? #t])
+    (if (not (or sa ea))
+        (finish-pin (launder (t:pin-line (ghost p)
+                                         src src-find 
+                                         dest dest-find))
+                    p lw col under?)
+        (pin-curve* #f #f p src src-find dest dest-find
+                    sa ea sp ep sz col lw under? #t)))
 
-  (define (pin-arrow-line sz p src find-src dest find-dest
-                          #:line-width [lw #f]
-                          #:color [col #f]
-                          #:under? [under? #f]
-                          #:solid? [solid? #t])
-    (finish-pin (launder (t:pin-arrow-line sz (ghost p)
-                                           src find-src 
-                                           dest find-dest
-                                           #f #f #f solid?))
-                p lw col under?))
+    (define (pin-arrow-line sz p 
+                            src src-find
+                            dest dest-find
+                            #:start-angle [sa #f] #:end-angle [ea #f]
+                            #:start-pull [sp #f] #:end-pull [ep #f]
+                            #:color [col #f]
+                            #:line-width [lw #f]
+                            #:under? [under? #f]
+                            #:solid? [solid? #t])
+      (if (not (or sa ea))
+          (finish-pin (launder (t:pin-arrow-line sz (ghost p)
+                                                 src src-find 
+                                                 dest dest-find
+                                                 #f #f #f solid?))
+                      p lw col under?)
+          (pin-curve* #f #t p src src-find dest dest-find
+                      sa ea sp ep sz col lw under? solid?)))
+
+    (define (pin-arrows-line sz p 
+                             src src-find
+                             dest dest-find
+                             #:start-angle [sa #f] #:end-angle [ea #f]
+                             #:start-pull [sp #f] #:end-pull [ep #f]
+                             #:color [col #f]
+                             #:line-width [lw #f]
+                             #:under? [under? #f]
+                             #:solid? [solid? #t])
+      (if (not sa ea)
+          (finish-pin (launder (t:pin-arrows-line sz (ghost p)
+                                                  src src-find 
+                                                  dest dest-find
+                                                  #f #f #f solid?))
+                      p lw col under?)
+          (pin-curve* #t #t p src src-find dest dest-find
+                      sa ea sp ep sz col lw under? solid?)))
+    
+  (define (pin-curve* start-arrow? end-arrow? p 
+                      src src-find
+                      dest dest-find
+                      sa ea sp ep
+                      sz col lw
+                      under? solid?)
+    (let-values ([(sx0 sy0) (src-find p src)]
+                 [(dx0 dy0) (dest-find p dest)])
+      (let* ([sa (or sa
+                     (atan (- sy0 dy0) (- dx0 sx0)))]
+             [ea (or ea
+                     (atan (- sy0 dy0) (- dx0 sx0)))]
+             [d (sqrt (+ (* (- dy0 sy0) (- dy0 sy0)) (* (- dx0 sx0) (- dx0 sx0))))]
+             [sp (* (or sp 1/4) d)]
+             [ep (* (or ep 1/4) d)])
+        (let ([dx (if end-arrow? (- dx0 (* sz (cos ea))) dx0)]
+              [dy (if end-arrow? (+ dy0 (* sz (sin ea))) dy0)]
+              [sx (if start-arrow? (+ sx0 (* sz (cos sa))) sx0)]
+              [sy (if start-arrow? (- sy0 (* sz (sin sa))) sy0)]
+              [path (new dc-path%)]
+              [maybe-pin-line
+               (lambda (arrow? p sx sy dx dy)
+                 (if arrow?
+                     (pin-arrow-line 
+                      sz
+                      p
+                      p (lambda (a b) (values sx sy))
+                      p (lambda (a b) (values dx dy))
+                      #:line-width lw
+                      #:color col
+                      #:under? under?
+                      #:solid? solid?)
+                     p))])
+          (send path move-to sx sy)
+          (send path curve-to
+                (+ sx (* sp (cos sa)))
+                (- sy (* sp (sin sa)))
+                (- dx (* ep (cos ea)))
+                (+ dy (* ep (sin ea)))
+                dx
+                dy)
+          (maybe-pin-line 
+           start-arrow?
+           (maybe-pin-line 
+            end-arrow?
+            ((if under? pin-under pin-over)
+             p
+             0 0
+             (let* ([p (dc (lambda (dc x y)
+                             (let ([b (send dc get-brush)])
+                               (send dc set-brush "white" 'transparent)
+                               (send dc draw-path path x y)
+                               (send dc set-brush b)))
+                           0 0)]
+                    [p (if col
+                           (colorize p col)
+                           p)]
+                    [p (if lw
+                           (linewidth lw p)
+                           p)])
+               p))
+            dx dy dx0 dy0)
+           sx sy sx0 sy0)))))
 
-  (define (pin-arrows-line sz p src find-src dest find-dest
-                           #:line-width [lw #f]
-                           #:color [col #f]
-                           #:under? [under? #f]
-                           #:solid? [solid? #t])
-    (finish-pin (launder (t:pin-arrows-line sz (ghost p)
-                                            src find-src 
-                                            dest find-dest
-                                            #f #f #f solid?))
-                p lw col under?))
 
   (define (finish-pin l p lw col under?)
     (let* ([l (if lw
diff --git a/collects/slideshow/play.ss b/collects/slideshow/play.ss
index caa81f8c0f..873cdc8888 100644
--- a/collects/slideshow/play.ss
+++ b/collects/slideshow/play.ss
@@ -18,12 +18,12 @@
 ;; Create a slide sequence where `mid' takes a number from 0.0 to 1.0.
 ;; The 0.0 slide will wit until you advance, but the remaining ones will
 ;; time out automatically to create the animation.
-(define (play #:title [title #f] mid)
-  (slide #:title title (mid 0))
+(define (play #:title [title #f] #:layout [layout 'auto] mid)
+  (slide #:title title #:layout layout (mid 0))
   (if condense?
       (skip-slides 10)
       (map (lambda (n)
-             (slide #:title title #:timeout 0.05 (mid n)))
+             (slide #:title title #:layout layout #:timeout 0.05 (mid n)))
            (let ([cnt 10])
              (let loop ([n cnt])
                (if (zero? n)
@@ -36,14 +36,15 @@
 ;; arguments will be 0.0. The first argument goes from 0.0 to 1.0
 ;; for the first `play' sequence, and then it stays at 1.0 while
 ;; the second goes from 0.0 to 1.0 for the second sequence, etc.
-(define (play-n #:title [title #f] mid)
+(define (play-n #:title [title #f] #:layout [layout 'auto] mid)
   (let ([n (procedure-arity mid)])
     (let loop ([post (vector->list (make-vector n))]
                [pre null])
       (if (null? post)
-          (slide #:title title (apply mid pre))
+          (slide #:title title #:layout layout (apply mid pre))
           (begin
             (play #:title title
+                  #:layout layout 
                   (lambda (n)
                     (apply mid (append pre (list n) (cdr post)))))
             (loop (cdr post) (cons 1.0 pre)))))))
diff --git a/collects/srfi/39.ss b/collects/srfi/39.ss
index 98c180b56b..818336bb56 100644
--- a/collects/srfi/39.ss
+++ b/collects/srfi/39.ss
@@ -1,3 +1,18 @@
-;; Supported by core PLT:
+;; Supported by core PLT, with a slight difference in how a guard is used:
 #lang scheme/base
-(provide make-parameter parameterize)
+
+(define make-parameter*
+  (let ([make-parameter
+         (case-lambda
+          [(v) (make-parameter v)]
+          [(v guard) (make-parameter (if (and (procedure? guard)
+                                              (procedure-arity-includes? guard 1))
+                                         ;; apply guard to initial value:
+                                         (guard v)
+                                         ;; let `make-parameter' complain:
+                                         v)
+                                     guard)])])
+    make-parameter))
+
+(provide (rename-out [make-parameter* make-parameter])
+         parameterize)
diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss
index 86f0485563..e173f76b85 100644
--- a/collects/string-constants/english-string-constants.ss
+++ b/collects/string-constants/english-string-constants.ss
@@ -1045,7 +1045,8 @@ please adhere to these guidelines:
   (no-language-chosen "No language chosen")
  
  (module-language-one-line-summary "Run creates a REPL in the context of the module, including the module's declared language")
-  
+  (module-language-auto-text "Automatic #lang line") ;; shows up in the details section of the module language
+   
   ;;; from the `not a language language' used initially in drscheme.
   (must-choose-language "DrScheme cannot process programs until you choose a programming language.")
   
diff --git a/collects/stxclass/main.ss b/collects/stxclass/main.ss
index ad37c75457..f55c6ba21a 100644
--- a/collects/stxclass/main.ss
+++ b/collects/stxclass/main.ss
@@ -8,11 +8,16 @@
          define-basic-syntax-class*
          pattern
          basic-syntax-class
+         ~and
+         ~or
+         ...*
 
          syntax-parse
          syntax-parser
          with-patterns
-         ...*
+         attribute
+
+         this-syntax
 
          current-expression
          current-macro-name
diff --git a/collects/stxclass/private/codegen-data.ss b/collects/stxclass/private/codegen-data.ss
index 8579caf711..77938937f4 100644
--- a/collects/stxclass/private/codegen-data.ss
+++ b/collects/stxclass/private/codegen-data.ss
@@ -10,19 +10,27 @@
 ;;   - 'fail' stxparameterized to (non-escaping!) failure procedure
 (define-struct pk (ps k) #:transparent)
 
-;; An ExtPK is one of
+;; A Group (G) is one of
 ;;   - PK
-;;   - (make-idpks stxclass (listof stx) (listof PK))
-;;   - (make-cpks (listof PK) (listof DatumPKS) (listof LiteralPKS))
-;;       the first field has only pair patterns
-(define-struct idpks (stxclass args idpks))
-(define-struct cpks (pairpks datumpks literalpks))
+;;   - (make-idG stxclass (listof stx) (listof PK))
+;;     where each PK starts with an id pattern of given stxclass/args
+;;   - (make-descrimG (listof DatumSG) (listof LiteralSG) (listof CompountSGs))
+;;     where each DatumSG/LiteralSG/CompoundSG has a different datum/lit/kind
+(define-struct idG (stxclass args idpks) #:transparent)
+(define-struct descrimG (datumSGs literalSGs kindSGs) #:transparent)
 
-;; A DatumPKS is (make-datumpks datum (listof PK))
-(define-struct datumpks (datum pks))
+;; A DatumSG is (make-datumSG datum (listof PK))
+;; where each PK starts with a datum pattern equal to datum
+(define-struct datumSG (datum pks))
+
+;; A LiteralSG is (make-literalSG id (listof PK))
+;; where each PK starts with a literal pattern equal to literal
+(define-struct literalSG (literal pks))
+
+;; A CompoundSG is (make-compoundSG Kind (listof PK))
+;; where each PK starts with a compound pattern of given kind
+(define-struct compoundSG (kind pks))
 
-;; A LiteralPKS is (make-literalpks identifier (listof PK))
-(define-struct literalpks (literal pks))
 
 ;; A FrontierContextExpr (FCE) is one of
 ;;  - (make-fce Id FrontierIndexExpr)
@@ -55,6 +63,11 @@
             (cons (fi:add-index (car (fce-indexes fc)) expr)
                   (cdr (fce-indexes fc)))))
 
+(define (frontier:add-unvector fc)
+  (frontier:add-car fc (fce-stx fc)))
+(define (frontier:add-unbox fc)
+  (frontier:add-car fc (fce-stx fc)))
+
 (define (join-frontiers base ext)
   (make-joined-frontier base ext))
 
@@ -80,6 +93,7 @@
        stx]
       [(struct joined-frontier (base ext))
        #`(let ([inner-failure #,ext])
-           (or (and (failed? inner-failure) (failed-frontier-stx inner-failure))
+           (or (and (failed? inner-failure)
+                    (failed-frontier-stx inner-failure))
                #,(loop base)))]))
   (loop fc))
diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss
index ba26d8c07d..81727b614f 100644
--- a/collects/stxclass/private/codegen.ss
+++ b/collects/stxclass/private/codegen.ss
@@ -14,7 +14,10 @@
          "../util.ss")
 (provide/contract
  [parse:rhs (rhs? (listof sattr?) (listof identifier?) . -> . syntax?)]
- [parse:clauses (syntax? identifier? identifier? . -> . syntax?)])
+ [parse:clauses (syntax? identifier? identifier? . -> . syntax?)]
+ [announce-failures? parameter?])
+
+(define announce-failures? (make-parameter #f))
 
 ;; parse:rhs : RHS (listof SAttr) (listof identifier) -> stx
 ;; Takes a list of the relevant attrs; order is significant!
@@ -27,19 +30,21 @@
                  #,(if (rhs-transparent? rhs)
                        #`(make-failed x expected frontier frontier-stx)
                        #'#f))
-               #,(let ([pks (rhs->pks rhs relsattrs #'x)])
-                   (unless (pair? pks)
-                     (wrong-syntax (rhs-orig-stx rhs)
-                                   "syntax class has no variants"))
-                   (parse:pks (list #'x)
-                              (list (empty-frontier #'x))
-                              pks
-                              #'fail-rhs))))]
+               (syntax-parameterize ((this-syntax (make-rename-transformer #'x)))
+                 #,(let ([pks (rhs->pks rhs relsattrs #'x)])
+                     (unless (pair? pks)
+                       (wrong-syntax (rhs-orig-stx rhs)
+                                     "syntax class has no variants"))
+                     (parse:pks (list #'x)
+                                (list (empty-frontier #'x))
+                                #'fail-rhs
+                                (list #f)
+                                pks)))))]
         [(rhs:basic? rhs)
          (rhs:basic-parser rhs)]))
 
 ;; parse:clauses : stx identifier identifier -> stx
-(define (parse:clauses stx var failid)
+(define (parse:clauses stx var phi)
   (define clauses-kw-table
     (list (list '#:literals check-literals-list)))
   (define-values (chunks clauses-stx)
@@ -70,8 +75,9 @@
       (wrong-syntax stx "no variants"))
     (parse:pks (list var)
                (list (empty-frontier var))
-               pks
-               failid)))
+               phi
+               (list #f)
+               pks)))
 
 ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)
 (define (rhs->pks rhs relsattrs main-var)
@@ -116,8 +122,9 @@
                  [fail-k enclosing-fail])
              #,(parse:pks (list #'x)
                           (list (done-frontier #'x))
-                          (list (make-pk (list p) inner))
-                          #'fail-k))))]))
+                          #'fail-k
+                          (list #f)
+                          (list (make-pk (list p) inner))))))]))
 
 ;; success-expr : (listof IAttr) (listof SAttr) RemapEnv stx -> stx
 (define (success-expr iattrs relsattrs remap main-var)
@@ -137,51 +144,78 @@
                 [fstx-expr (frontier->fstx-expr fce)])
     #`(let ([failcontext fc-expr]
             [failcontext-syntax fstx-expr])
+        #,(when (announce-failures?)
+            #`(printf "failing on ~s\n  reason: ~s\n" x p))
         (k x p failcontext failcontext-syntax))))
 
 ;; Parsing
 
-;; parse:pks : (listof identifier) (listof FCE) (listof PK) identifier -> stx
+#|
+
+The parsing algorithm is based on the classic backtracking
+algorithm (see Optimizing Pattern Matching for an overview). A PK
+corresponds to a row in the pattern matrix. The failure argument
+corresponds to the static catch continuation.
+
+The FCs (frontier contexts, one per column) are an addition for error
+reporting. They track the matcher's progress into the term. The
+matcher compares failures on backtracking, and reports the "furthest
+along" failure, based on the frontiers.
+
+Conventions:
+  <ParseConfig> =
+    vars : listof identifiers, variables, one per column
+    fcs : listof FCEs, failure contexts, one per column
+    phi : id, failure continuation
+    ds : listof (string/#f), description string
+
+|#
+
+
+;; parse:pks : <ParseConfig> (listof PK) -> stx
 ;; Each PK has a list of |vars| patterns.
 ;; The list of PKs must not be empty.
-(define (parse:pks vars fcs pks failid)
+(define (parse:pks vars fcs phi ds pks)
   (cond [(null? pks)
          (error 'parse:pks "internal error: empty list of rows")]
         [(null? vars)
          ;; Success!
-         (let* ([failvar (car (generate-temporaries #'(fail-k)))]
+         (let* ([failvar (generate-temporary 'fail-k)]
                 [exprs
                  (for/list ([pk pks])
                    #`(with-enclosing-fail #,failvar #,(pk-k pk)))])
            (with-syntax ([failvar failvar]
                          [(expr ...) exprs])
-             #`(try failvar [expr ...] #,failid)))]
+             #`(try failvar [expr ...] #,phi)))]
         [else
-         (let-values ([(vars extpks) (split-pks vars pks)])
-           (let* ([failvar (car (generate-temporaries #'(fail-k)))]
+         (let-values ([(vars groups) (split-pks vars pks)])
+           (let* ([failvar (generate-temporary 'fail-k)]
                   [exprs
-                   (for/list ([extpk extpks])
-                     (parse:extpk vars fcs extpk failvar))])
+                   (for/list ([group groups])
+                     (parse:group vars fcs failvar ds group))])
              (with-syntax ([failvar failvar]
                            [(expr ...) exprs])
-               #`(try failvar [expr ...] #,failid))))]))
+               #`(try failvar [expr ...] #,phi))))]))
 
 
-;; parse:extpk : (listof identifier) (listof FCE) ExtPK identifier -> stx
+;; parse:group : <ParseConfig> Group -> stx
 ;; Pre: vars is not empty
-(define (parse:extpk vars fcs extpk failid)
-  (match extpk
-    [(struct idpks (stxclass args pks))
+(define (parse:group vars fcs phi ds group)
+  (match group
+    [(struct idG (stxclass args pks))
      (if stxclass
-         (parse:pk:id/stxclass vars fcs failid stxclass args pks)
-         (parse:pk:id/any  vars fcs failid args pks))]
-    [(struct cpks (pairpks datumpkss literalpkss))
-     (parse:pk:c vars fcs failid pairpks datumpkss literalpkss)]
+         (parse:group:id/stxclass vars fcs phi ds stxclass args pks)
+         (parse:group:id/any vars fcs phi ds args pks))]
+    [(struct descrimG (datumSGs literalSGs kindSGs))
+     (parse:group:descrim vars fcs phi ds datumSGs literalSGs kindSGs)]
+    [(struct pk ((cons (? pat:and? and-pattern) rest-patterns) k))
+     (parse:group:and vars fcs phi ds and-pattern rest-patterns k)]
     [(struct pk ((cons (? pat:gseq? gseq-pattern) rest-patterns) k))
-     (parse:pk:gseq vars fcs failid gseq-pattern rest-patterns k)]))
+     (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k)]))
 
-;; parse:pk:id/stxclass : (listof id) (listof FCE) id SC stx (listof pk) -> stx
-(define (parse:pk:id/stxclass vars fcs failid stxclass args pks)
+;; parse:group:id/stxclass : <ParseConfig> SC stx (listof pk)
+;;                        -> stx
+(define (parse:group:id/stxclass vars fcs phi ds stxclass args pks)
   (with-syntax ([var0 (car vars)]
                 [(arg ...) args]
                 [(arg-var ...) (generate-temporaries args)]
@@ -190,77 +224,108 @@
     #`(let ([arg-var arg] ...)
         (let ([result (parser var0 arg-var ...)])
           (if (ok? result)
-              #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid)
-              #,(fail failid (car vars)
+              #,(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:id pks #'result))
+              #,(fail phi (car vars)
                       #:pattern (expectation-of-stxclass stxclass #'(arg-var ...) #'result)
                       #:fce (join-frontiers (car fcs) #'result)))))))
 
-;; parse:pk:id/any : (listof id) (listof FCE) id stx (listof pk) -> stx
-(define (parse:pk:id/any vars fcs failid args pks)
+;; parse:group:id/any : <ParseConfig> stx (listof pk) -> stx
+(define (parse:group:id/any vars fcs phi ds args pks)
   (with-syntax ([var0 (car vars)]
                 [(arg ...) args]
                 [(arg-var ...) (generate-temporaries args)]
                 [result (generate-temporary 'result)])
     #`(let ([arg-var arg] ...)
         (let ([result (list var0)])
-          #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid)))))
+          #,(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:id pks #'result))))))
 
-;; parse:pk:c : (listof id) (listof FCE) id ??? ... -> stx
-(define (parse:pk:c vars fcs failid pairpks datumpkss literalpkss)
+;; parse:group:descrim : <ParseConfig>
+;;                       (listof DatumSG) (listof LiteralSG) (listof CompoundSG)
+;;                    -> stx
+(define (parse:group:descrim vars fcs phi ds datumSGs literalSGs compoundSGs)
   (define var (car vars))
   (define datum-var (generate-temporary 'datum))
-  (define (datumpks-test datumpks)
-    (let ([datum (datumpks-datum datumpks)])
+  (define (datumSG-test datumSG)
+    (let ([datum (datumSG-datum datumSG)])
       #`(equal? #,datum-var (quote #,datum))))
-  (define (datumpks-rhs datumpks)
-    (let ([pks (datumpks-pks datumpks)])
-      (parse:pks (cdr vars) (cdr fcs) (shift-pks:datum pks) failid)))
-  (define (literalpks-test literalpks)
-    (let ([literal (literalpks-literal literalpks)])
+  (define (datumSG-rhs datumSG)
+    (let ([pks (datumSG-pks datumSG)])
+      (parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:datum pks))))
+  (define (literalSG-test literalSG)
+    (let ([literal (literalSG-literal literalSG)])
       #`(and (identifier? #,var)
              (free-identifier=? #,var (quote-syntax #,literal)))))
-  (define (literalpks-rhs literalpks)
-    (let ([pks (literalpks-pks literalpks)])
-      (parse:pks (cdr vars) (cdr fcs) (shift-pks:literal pks) failid)))
+  (define (literalSG-rhs literalSG)
+    (let ([pks (literalSG-pks literalSG)])
+      (parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:literal pks))))
+  (define (compoundSG-test compoundSG)
+    (let ([kind (compoundSG-kind compoundSG)])
+      #`(#,(kind-predicate kind) #,datum-var)))
+  (define (compoundSG-rhs compoundSG)
+    (let* ([pks (compoundSG-pks compoundSG)]
+           [kind (compoundSG-kind compoundSG)]
+           [selectors (kind-selectors kind)]
+           [frontier-procs (kind-frontier-procs kind)]
+           [part-vars (for/list ([selector selectors]) (generate-temporary 'part))]
+           [part-frontiers
+            (for/list ([fproc frontier-procs] [part-var part-vars])
+              (fproc (car fcs) part-var))]
+           [part-ds (for/list ([selector selectors]) (car ds))])
+      (with-syntax ([(part-var ...) part-vars]
+                    [(part-expr ...)
+                     (for/list ([selector selectors]) (selector var datum-var))])
+        #`(let ([part-var part-expr] ...)
+            #,(parse:pks (append part-vars (cdr vars))
+                         (append part-frontiers (cdr fcs))
+                         phi
+                         (append part-ds (cdr ds))
+                         (shift-pks:compound pks))))))
   (define-pattern-variable var0 var)
   (define-pattern-variable dvar0 datum-var)
   (define-pattern-variable head-var (generate-temporary 'head))
   (define-pattern-variable tail-var (generate-temporary 'tail))
   (with-syntax ([(datum-clause ...)
-                 (for/list ([datumpks datumpkss])
-                   #`[#,(datumpks-test datumpks) #,(datumpks-rhs datumpks)])]
+                 (for/list ([datumSG datumSGs])
+                   #`[#,(datumSG-test datumSG) #,(datumSG-rhs datumSG)])]
                 [(lit-clause ...)
-                 (for/list ([literalpks literalpkss])
-                   #`[#,(literalpks-test literalpks) #,(literalpks-rhs literalpks)])])
+                 (for/list ([literalSG literalSGs])
+                   #`[#,(literalSG-test literalSG) #,(literalSG-rhs literalSG)])]
+                [(compound-clause ...)
+                 (for/list ([compoundSG compoundSGs])
+                   #`[#,(compoundSG-test compoundSG) #,(compoundSG-rhs compoundSG)])])
     #`(let ([dvar0 (if (syntax? var0) (syntax-e var0) var0)])
-        (cond #,@(if (pair? pairpks)
-                     #`([(pair? dvar0)
-                         (let ([head-var (car dvar0)]
-                               [tail-var (datum->syntax var0 (cdr dvar0) var0)])
-                           #,(parse:pks (list* #'head-var #'tail-var (cdr vars))
-                                        (list* (frontier:add-car (car fcs) #'head-var)
-                                               (frontier:add-cdr (car fcs))
-                                               (cdr fcs))
-                                        (shift-pks:pair pairpks)
-                                        failid))])
-                     #`())
+        (cond compound-clause ...
               lit-clause ...
               datum-clause ...
               [else
-               #,(fail failid (car vars)
+               #,(fail phi (car vars)
                        #:pattern (expectation-of-constants
-                                  (pair? pairpks)
-                                  (for/list ([d datumpkss])
-                                    (datumpks-datum d))
-                                  (for/list ([l literalpkss])
-                                    (literalpks-literal l)))
+                                  (pair? compoundSGs)
+                                  (for/list ([d datumSGs])
+                                    (datumSG-datum d))
+                                  (for/list ([l literalSGs])
+                                    (literalSG-literal l))
+                                  (car ds))
                        #:fce (car fcs))]))))
 
-;; parse:pk:gseq : (listof id) (listof FCE) id
-;;                 pat:gseq (listof Pattern)
-;;                 ???
-;;              -> stx
-(define (parse:pk:gseq vars fcs failid gseq-pattern rest-patterns k)
+;; parse:gseq:and : <ParseConfig> pat:and (listof Pattern) stx
+;;               -> stx
+(define (parse:group:and vars fcs phi ds and-pattern rest-patterns k)
+  (match-define (struct pat:and (orig-stx attrs depth description patterns))
+                and-pattern)
+  ;; FIXME: handle description
+  (let ([var0-copies (for/list ([p patterns]) (car vars))]
+        [fc0-copies (for/list ([p patterns]) (car fcs))]
+        [ds-copies (for/list ([p patterns]) (or description (car ds)))])
+    (parse:pks (append var0-copies (cdr vars))
+               (append fc0-copies (cdr fcs))
+               phi
+               (append ds-copies (cdr ds))
+               (list (make pk (append patterns rest-patterns) k)))))
+
+;; parse:compound:gseq : <ParseConfig> pat:gseq (listof Pattern) stx
+;;                    -> stx
+(define (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k)
   (match-define (struct pat:gseq (orig-stx attrs depth heads tail)) gseq-pattern)
   (define xvar (generate-temporary 'x))
   (define head-lengths (for/list ([head heads]) (length (head-ps head))))
@@ -268,9 +333,7 @@
   (define hid-initss
     (for/list ([head heads] [head-attrs head-attrss])
       (for/list ([head-attr head-attrs])
-        (cond [(head-default head)
-               => (lambda (x) #`(quote-syntax #,x))]
-              [(head-as-list? head) #'null]
+        (cond [(head-as-list? head) #'null]
               [else #'#f]))))
   (define combinerss
     (for/list ([head heads] [head-attrs head-attrss])
@@ -308,9 +371,6 @@
                    (if maxrep
                        #`(< #,repvar #,maxrep)
                        #`#t))]
-                [(occurs-binding ...)
-                 (for/list ([head heads] [rep reps] #:when (head-occurs head))
-                   #`[#,(head-occurs head) (positive? #,rep)])]
                 [(parse-loop failkv fail-tail)
                  (generate-temporaries #'(parse-loop failkv fail-tail))])
 
@@ -343,12 +403,12 @@
         #`(cond minrep-clause ...
                 [else
                  (let ([hid (finalize hid-arg)] ... ...
-                       occurs-binding ...
                        [fail-tail enclosing-fail])
                    #,(parse:pks (cdr vars)
                                 (cdr fcs)
-                                (list (make-pk rest-patterns k))
-                                #'fail-tail))])))
+                                #'fail-tail
+                                (cdr ds)
+                                (list (make-pk rest-patterns k))))])))
 
     (with-syntax ([tail-rhs tail-rhs-expr]
                   [(rhs ...)
@@ -365,31 +425,33 @@
             #,(parse:pks (list #'x)
                          (list (frontier:add-index (car fcs)
                                                    #'(calculate-index rep ...)))
+                         #'failkv
+                         (list (car ds))
                          (append
                           (map make-pk
                                (map list completed-heads)
                                (syntax->list #'(rhs ...)))
-                          (list (make-pk (list tail) #`tail-rhs)))
-                         #'failkv))
+                          (list (make-pk (list tail) #`tail-rhs)))))
           (let ([hid hid-init] ... ...
                 [rep 0] ...)
-            (parse-loop var0 hid ... ... rep ... #,failid))))))
-
+            (parse-loop var0 hid ... ... rep ... #,phi))))))
 
 ;; complete-heads-patterns : Head identifier number stx -> Pattern
 (define (complete-heads-pattern head rest-var depth seq-orig-stx)
   (define (loop ps pat)
     (if (pair? ps)
-        (make-pat:pair (cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat))
-                       (append (pattern-attrs (car ps)) (pattern-attrs pat))
-                       depth
-                       (car ps)
-                       (loop (cdr ps) pat))
+        (make pat:compound
+              (cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat))
+              (append (pattern-attrs (car ps)) (pattern-attrs pat))
+              depth
+              pairK
+              (list (car ps) (loop (cdr ps) pat)))
         pat))
   (define base 
-    (make-pat:id seq-orig-stx
-                 (list (make-attr rest-var depth null))
-                 depth rest-var #f null))
+    (make pat:id
+          seq-orig-stx
+          (list (make-attr rest-var depth null))
+          depth rest-var #f null))
   (loop (head-ps head) base))
 
 ;; split-pks : (listof identifier) (listof PK)
@@ -405,7 +467,7 @@
 (define (split-pks/first-column pks)
   (define (get-pat x) (car (pk-ps x)))
   (define (constructor-pat? p)
-    (or (pat:pair? p) (pat:datum? p) (pat:literal? p)))
+    (or (pat:compound? p) (pat:datum? p) (pat:literal? p)))
   (define (constructor-pk? pk)
     (constructor-pat? (get-pat pk)))
   (define (id-pk? pk)
@@ -452,13 +514,17 @@
         (pat:id? p2)
         (and (pat:datum? p1) (pat:datum? p2)
              (equal? (pat:datum-datum p1) (pat:datum-datum p2)))
-        (and (pat:pair? p1) (pat:pair? p2)
-             (pattern-intersects? (pat:pair-head p1) (pat:pair-head p2))
-             (pattern-intersects? (pat:pair-tail p1) (pat:pair-tail p2)))
+        (and (pat:compound? p1) (pat:compound? p2)
+             (eq? (pat:compound-kind p1) (pat:compound-kind p2))
+             (andmap pattern-intersects?
+                     (pat:compound-patterns p1)
+                     (pat:compound-patterns p2)))
         ;; FIXME: conservative
         (and (pat:literal? p1) (pat:literal? p2))
         (pat:gseq? p1)
-        (pat:gseq? p2)))
+        (pat:gseq? p2)
+        (pat:and? p1)
+        (pat:and? p2)))
 
   (define (major-loop pks epks)
     (match pks
@@ -480,18 +546,17 @@
                                tail
                                (list head)
                                null)])
-           (let ([id-epk (make idpks this-stxclass this-args (reverse r-id-pks))])
+           (let ([id-epk (make idG this-stxclass this-args (reverse r-id-pks))])
              (major-loop tail (cons id-epk epks)))))]
+      ;; Leave gseq- and and-patterns by themselves (at least for now)
       [(cons head tail)
        (major-loop tail (cons head epks))]))
 
   ;; gather : (PK -> boolean) (listof PK) (listof PK) (listof PK)
   ;;       -> (listof PK) (listof PK)
   (define (gather pred pks taken prefix)
-    #;(printf "called gather (~s pks, ~s prefix)\n" (length pks) (length prefix))
     (match pks
       ['()
-       #;(printf "took ~s, left ~s\n" (length taken) (length prefix))
        (values taken (reverse prefix))]
       [(cons pk tail)
        ;; We can have it if it can move past everything in the prefix.
@@ -503,16 +568,18 @@
 
   ;; group-constructor-pks : (listof PK) -> ExtPK
   (define (group-constructor-pks reversed-pks)
-    (define pairpks null)
-    (define ht (make-hash))
+    (define compound-ht (make-hasheq))
+    (define datum-ht (make-hash))
     (define lit-ht (make-bound-identifier-mapping))
     (for ([pk reversed-pks])
       (let ([p (get-pat pk)])
-        (cond [(pat:pair? p)
-               (set! pairpks (cons pk pairpks))]
+        (cond [(pat:compound? p)
+               (let ([kind (pat:compound-kind p)])
+                 (hash-set! compound-ht
+                            kind (cons pk (hash-ref compound-ht kind null))))]
               [(pat:datum? p)
                (let ([d (pat:datum-datum p)])
-                 (hash-set! ht d (cons pk (hash-ref ht d null))))]
+                 (hash-set! datum-ht d (cons pk (hash-ref datum-ht d null))))]
               [(pat:literal? p)
                (let ([lit (pat:literal-literal p)])
                  (bound-identifier-mapping-put!
@@ -521,9 +588,10 @@
                   (cons pk
                         (bound-identifier-mapping-get lit-ht lit
                                                       (lambda () null)))))])))
-    (let ([datumpkss (hash-map ht make-datumpks)]
-          [litpkss (bound-identifier-mapping-map lit-ht make-literalpks)])
-      (make cpks pairpks datumpkss litpkss)))
+    (let ([datumSGs (hash-map datum-ht make-datumSG)]
+          [literalSGs (bound-identifier-mapping-map lit-ht make-literalSG)]
+          [compoundSGs (hash-map compound-ht make-compoundSG)])
+      (make descrimG datumSGs literalSGs compoundSGs)))
 
   (major-loop pks null))
 
@@ -564,13 +632,14 @@
     (make-pk (cdr (pk-ps pk)) (pk-k pk)))
   (map shift-pk pks))
 
-;; shift-pks:pair : (listof PK) -> (listof PK)
-(define (shift-pks:pair pks)
+;; shift-pks:compound : (listof PK) -> (listof PK)
+(define (shift-pks:compound pks)
   (define (shift-pk pk0)
     (match pk0
-      [(struct pk ((cons (struct pat:pair (orig-stx attrs depth head tail)) rest-ps)
+      [(struct pk ((cons (struct pat:compound (orig-stx attrs depth kind patterns))
+                         rest-ps)
                    k))
-       (make-pk (list* head tail rest-ps) k)]))
+       (make-pk (append patterns rest-ps) k)]))
   (map shift-pk pks))
 
 ;; wrap-pvars : (listof IAttr) stx -> stx
diff --git a/collects/stxclass/private/debug.ss b/collects/stxclass/private/debug.ss
new file mode 100644
index 0000000000..670ba1eb8f
--- /dev/null
+++ b/collects/stxclass/private/debug.ss
@@ -0,0 +1,15 @@
+
+#lang scheme/base
+(require (for-syntax scheme/base)
+         (for-syntax "codegen.ss"))
+
+(provide announce-parse-failures)
+
+(define-syntax (announce-parse-failures stx)
+  (syntax-case stx ()
+    [(_ b)
+     (begin (announce-failures? (and (syntax-e #'b) #t))
+            #'(void))]
+    [(_)
+     #'(announce-failures #t)]))
+
diff --git a/collects/stxclass/private/lib.ss b/collects/stxclass/private/lib.ss
index 6497a307e4..5f2906f1f7 100644
--- a/collects/stxclass/private/lib.ss
+++ b/collects/stxclass/private/lib.ss
@@ -13,13 +13,10 @@
 (provide (all-defined-out))
 
 (define-syntax-rule (define-pred-stxclass name pred)
-  (define-basic-syntax-class name
-    ([datum 0])
-    (lambda (x)
-      (let ([d (if (syntax? x) (syntax-e x) x)])
-        (if (pred d)
-            (list d)
-            #f)))))
+  (define-syntax-class name #:attributes ([datum 0])
+    (pattern x
+             #:with datum (if (syntax? #'x) (syntax-e #'x) #'x)
+             #:when (pred (attribute datum)))))
 
 (define-pred-stxclass identifier symbol?)
 (define-pred-stxclass boolean boolean?)
@@ -33,160 +30,105 @@
 (define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?)
 (define-pred-stxclass exact-positive-integer exact-positive-integer?)
 
-(define-syntax-rule (define-kw-stxclass name kw)
-  (define-basic-syntax-class name
-    ()
-    (lambda (x)
-      (if (and (identifier? x) (free-identifier=? x (quote-syntax kw)))
-          null
-          #f))))
-
-(define-kw-stxclass lambda-kw #%lambda)
-(define-kw-stxclass define-values-kw define-values)
-(define-kw-stxclass define-syntaxes-kw define-syntaxes)
-
-(define-syntax-class define-values-form
-  (pattern (kw:define-values-kw (var:identifier ...) rhs)))
-(define-syntax-class define-syntaxes-form
-  (pattern (kw:define-syntaxes-kw (var:identifier ...) rhs)))
-(define-syntax-class definition-form
-  (pattern :define-values-form)
-  (pattern :define-syntaxes-form))
-
 (define-syntax-class (static-of name pred)
-  #:description name
-  #:attributes ([value 0])
-  (basic-syntax-class
-   (lambda (x name pred)
-     (let/ec escape
-       (define (bad) (escape #f))
-       (if (identifier? x)
-           (let ([value (syntax-local-value x bad)])
-             (unless (pred value) (bad))
-             (list value))
-           (bad))))))
-
-(define-syntax-class static
   #:attributes (value)
+  (pattern x:id
+           #:with value-list (syntax-local-value* #'x)
+           #:when (pair? (attribute value-list))
+           #:with value (car (attribute value-list))
+           #:when (pred (attribute value))))
+
+(define (syntax-local-value* id)
+  (let/ec escape
+    (list (syntax-local-value id (lambda () (escape null))))))
+
+(define-syntax-class static #:attributes (value)
   (pattern x
            #:declare x (static-of "static" (lambda _ #t))
            #:with value #'x.value))
 
-(define-basic-syntax-class struct-name
-  ([descriptor 0]
-   [constructor 0]
-   [predicate 0]
-   [accessor 1]
-   [super 0]
-   [complete? 0])
-  (lambda (x)
-    (if (identifier? x)
-        (let/ec escape
-          (define (bad) (escape #f))
-          (let ([value (syntax-local-value x bad)])
-            (unless (struct-info? value) (bad))
-            (let ([lst (extract-struct-info value)])
-              (let ([descriptor (list-ref lst 0)]
-                    [constructor (list-ref lst 1)]
-                    [predicate (list-ref lst 2)]
-                    [accessors (list-ref lst 3)]
-                    [super (list-ref lst 5)])
-                (let ([r-accessors (reverse accessors)])
-                  (list descriptor
-                        constructor
-                        predicate
-                        (if (and (pair? r-accessors)
-                                 (eq? #f (car r-accessors)))
-                            (cdr r-accessors)
-                            r-accessors)
-                        super
-                        (or (null? r-accessors)
-                            (not (eq? #f (car r-accessors))))))))))
-        #f)))
+(define-syntax-class struct-name
+  #:description "struct name"
+  #:attributes (descriptor
+                constructor
+                predicate
+                [accessor 1]
+                super
+                complete?)
+  (pattern s
+           #:declare s (static-of "struct name" struct-info?)
+           #:with info (extract-struct-info (attribute s.value))
+           #:with descriptor (list-ref (attribute info) 0)
+           #:with constructor (list-ref (attribute info) 1)
+           #:with predicate (list-ref (attribute info) 2)
+           #:with r-accessors (reverse (list-ref (attribute info) 3))
+           #:with (accessor ...)
+                  (datum->syntax #f (let ([r-accessors (attribute r-accessors)])
+                                      (if (and (pair? r-accessors) (eq? #f (car r-accessors)))
+                                          (cdr r-accessors)
+                                          r-accessors)))
+           #:with super (list-ref (attribute info) 5)
+           #:with complete? (or (null? (attribute r-accessors))
+                                (and (pair? (attribute r-accessors))
+                                     (not (eq? #f (car (attribute r-accessors))))))))
 
-(define-basic-syntax-class expr/local-expand
-  ([expanded 0])
-  (lambda (x)
-    (list (local-expand x 'expression null))))
+(define-syntax-class expr/local-expand
+  #:attributes (expanded)
+  (pattern x
+           #:with expanded (local-expand #'x 'expression null)))
 
-(define-basic-syntax-class expr/head-local-expand
-  ([expanded 0])
-  (lambda (x)
-    (list (local-expand x 'expression (kernel-form-identifier-list)))))
+(define-syntax-class expr/head-local-expand
+  #:attributes (expanded)
+  (pattern x
+           #:with expanded (local-expand #'x 'expression (kernel-form-identifier-list))))
 
-(define-basic-syntax-class block/head-local-expand
-  ([expanded-block 0]
-   [expanded 1]
-   [def 1]
-   [vdef 1]
-   [sdef 1]
-   [expr 1])
-  (lambda (x)
-    (let-values ([(ex1 ex2 defs vdefs sdefs exprs)
-                  (head-local-expand-and-categorize-syntaxes x #f #; #t)])
-      (list ex1 ex2 defs vdefs sdefs exprs))))
+(define-syntax-class block/head-local-expand
+  #:attributes (expanded-block
+                [expanded 1]
+                [def 1]
+                [vdef 1]
+                [sdef 1]
+                [expr 1])
+  (pattern x
+           #:with (expanded-block (expanded ...) (def ...) (vdef ...) (sdef ...) (expr ...))
+                  (datum->syntax #f
+                                 (let-values ([(ex1 ex2 defs vdefs sdefs exprs)
+                                               (head-local-expand-and-categorize-syntaxes
+                                                #'x #f #| #t |#)])
+                                   (list ex1 ex2 defs vdefs sdefs exprs)))))
 
-(define-basic-syntax-class internal-definitions
-  ([expanded-block 0]
-   [expanded 1]
-   [def 1]
-   [vdef 1]
-   [sdef 1]
-   [expr 1])
-  (lambda (x)
-    (let-values ([(ex1 ex2 defs vdefs sdefs exprs)
-                  (head-local-expand-and-categorize-syntaxes x #t #; #f)])
-      (list ex1 ex2 defs vdefs sdefs exprs))))
+(define-syntax-class internal-definitions
+  #:attributes (expanded-block
+                [expanded 1]
+                [def 1]
+                [vdef 1]
+                [sdef 1]
+                [expr 1])
+  (pattern x
+           #:with (expanded-block (expanded ...) (def ...) (vdef ...) (sdef ...) (expr ...))
+                  (datum->syntax #f
+                                 (let-values ([(ex1 ex2 defs vdefs sdefs exprs)
+                                               (head-local-expand-and-categorize-syntaxes
+                                                #'x #t #| #f |#)])
+                                   (list ex1 ex2 defs vdefs sdefs exprs)))))
 
-(define-syntax-rule (define-contract-stxclass name c)
-  (define-basic-syntax-class* (name)
-    ([orig-stx 0])
-    (lambda (x)
-      (list #`(contract c
-                        #,x
-                        (quote #,(string->symbol (or (build-src-loc-string x) "")))
-                        (quote #,(or (current-macro-name) '<this-macro>))
-                        (quote-syntax #,(syntax/loc x (<there>))))
-            x))))
+(define-syntax-class expr
+  #:attributes ()
+  (pattern x
+           #:when (and (syntax? #'x) (not (keyword? (syntax-e #'x))))))
 
-(define-contract-stxclass expr/num number?)
-(define-contract-stxclass expr/num->num (-> number? number?))
-
-(define-basic-syntax-class* (expr)
-  ()
-  (lambda (x)
-    (if (not (keyword? (syntax-e x)))
-        (list x)
-        #f)))
 
 ;; FIXME: hack
 (define expr/c-use-contracts? (make-parameter #t))
 
-(define-basic-syntax-class* (expr/c contract)
-  ([orig-stx 0])
-  (lambda (x c)
-    (if (not (keyword? (syntax-e x)))
-        (if (expr/c-use-contracts?)
-            (list #`(contract #,c
-                              #,x
-                              (quote #,(string->symbol
-                                        (or (build-src-loc-string x) "")))
-                              (quote #,(or (current-macro-name) '<this-macro>))
-                              (quote-syntax #,(syntax/loc x (<there>))))
-                  x)
-            (list x x))
-        #f)))
-
-(define-basic-syntax-class (term parser)
-  ()
-  (lambda (x p) (p x)))
-
-(define-basic-syntax-class (term/pred pred)
-  ()
-  (lambda (x p)
-    (if (p x)
-        null
-        #f)))
+(define-syntax-class (expr/c ctc)
+  #:attributes (c)
+  (pattern x:expr
+           #:with c #`(contract #,ctc
+                                x
+                                (quote #,(string->symbol (or (build-src-loc-string #'x) "")))
+                                (quote #,(or (current-macro-name) '<this-macro>))
+                                (quote-syntax #,(syntax/loc #'x (<there>))))))
 
 ;; Aliases
 
diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss
index 9464f7bb23..6de85b445f 100644
--- a/collects/stxclass/private/rep-data.ss
+++ b/collects/stxclass/private/rep-data.ss
@@ -14,8 +14,11 @@
          (struct-out pat:id)
          (struct-out pat:datum)
          (struct-out pat:literal)
-         (struct-out pat:pair)
+         (struct-out pat:compound)
          (struct-out pat:gseq)
+         (struct-out pat:and)
+         (struct-out pat:orseq)
+         (struct-out kind)
          (struct-out head)
          (struct-out clause:when)
          (struct-out clause:with))
@@ -53,18 +56,24 @@
 ;;   (make-pat:pair <Pattern> Pattern Pattern)
 ;;   (make-pat:seq <Pattern> Pattern Pattern)
 ;;   (make-pat:gseq <Pattern> (listof Head) Pattern)
+;;   (make-pat:and <Pattern> string/#f (listof Pattern))
+;;   (make-pat:compound <Pattern> Kind (listof Pattern))
 ;; when <Pattern> = stx (listof IAttr) number
 (define-struct pattern (orig-stx attrs depth) #:transparent)
 (define-struct (pat:id pattern) (name stxclass args) #:transparent)
 (define-struct (pat:datum pattern) (datum) #:transparent)
 (define-struct (pat:literal pattern) (literal) #:transparent)
-(define-struct (pat:pair pattern) (head tail) #:transparent)
 (define-struct (pat:gseq pattern) (heads tail) #:transparent)
+(define-struct (pat:and pattern) (description subpatterns) #:transparent)
+(define-struct (pat:orseq pattern) (heads) #:transparent)
+(define-struct (pat:compound pattern) (kind patterns) #:transparent)
+
+;; A Kind is (make-kind id (listof (id id -> stx)) (listof (FCE id -> FCE)))
+(define-struct kind (predicate selectors frontier-procs) #:transparent)
 
 ;; A Head is
 ;;   (make-head stx (listof IAttr) nat (listof Pattern) nat/f nat/f boolean id/#f stx/#f)
-(define-struct head (orig-stx attrs depth ps min max as-list? occurs default)
-  #:transparent)
+(define-struct head (orig-stx attrs depth ps min max as-list?) #:transparent)
 
 ;; A SideClause is one of
 ;;   (make-clause:with pattern stx)
@@ -84,7 +93,6 @@
   (and (attr? a) (symbol? (attr-name a))))
 
 
-
 ;; Environments
 
 ;; DeclEnv maps [id => DeclEntry]
diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss
index 00bdf50365..dd96ade8d5 100644
--- a/collects/stxclass/private/rep.ss
+++ b/collects/stxclass/private/rep.ss
@@ -6,7 +6,8 @@
          syntax/boundmap
          syntax/stx
          "../util.ss"
-         "rep-data.ss")
+         "rep-data.ss"
+         "codegen-data.ss")
 
 (provide/contract
  [parse-whole-pattern 
@@ -21,7 +22,10 @@
       rhs?)]
  [check-literals-list
   (-> syntax?
-      (listof (list/c identifier? identifier?)))])
+      (listof (list/c identifier? identifier?)))]
+ [pairK kind?]
+ [vectorK kind?]
+ [boxK kind?])
 
 (define (atomic-datum? stx)
   (let ([datum (syntax-e stx)])
@@ -47,6 +51,40 @@
   (and (identifier? stx)
        (free-identifier=? stx (quote-syntax ...*))))
 
+(define (and-kw? stx)
+  (and (identifier? stx)
+       (free-identifier=? stx (quote-syntax ~and))))
+
+(define (orseq-kw? stx)
+  (and (identifier? stx)
+       (free-identifier=? stx (quote-syntax ~or))))
+
+(define (reserved? stx)
+  (or (dots? stx)
+      (gdots? stx)
+      (and-kw? stx)
+      (orseq-kw? stx)))
+
+;; ---- Kinds ----
+
+(define pairK
+  (make-kind #'pair?
+             (list (lambda (s d) #`(car #,d))
+                   (lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s)))
+             (list (lambda (fc x) (frontier:add-car fc x))
+                   (lambda (fc x) (frontier:add-cdr fc)))))
+
+(define vectorK
+  (make-kind #'vector?
+             (list (lambda (s d)
+                     #`(datum->syntax #,s (vector->list #,d) #,s)))
+             (list (lambda (fc x) (frontier:add-unvector fc)))))
+
+(define boxK
+  (make-kind #'box?
+             (list (lambda (s d) #`(unbox #,d)))
+             (list (lambda (fc x) (frontier:add-unbox fc)))))
+
 ;; ---
 
 ;; parse-rhs : stx(SyntaxClassRHS) boolean stx -> RHS
@@ -146,12 +184,15 @@
   pattern)
 
 ;; parse-pattern : stx(Pattern) DeclEnv number -> Pattern
-(define (parse-pattern stx decls depth)
-  (syntax-case stx ()
-    [dots
-     (or (dots? #'dots)
-         (gdots? #'dots))
-     (wrong-syntax stx "ellipses not allowed here")]
+(define (parse-pattern stx decls depth
+                       #:allow-orseq-pattern? [allow-orseq-pattern? #f])
+  (syntax-case stx (~and ~or)
+    [gdots
+     (gdots? #'gdots)
+     (wrong-syntax stx "obsolete (...*) sequence syntax")]
+    [reserved
+     (reserved? #'reserved)
+     (wrong-syntax #'reserved "not allowed here")]
     [id
      (identifier? #'id)
      (match (declenv-lookup decls #'id)
@@ -169,25 +210,46 @@
     [datum
      (atomic-datum? #'datum)
      (make pat:datum stx null depth (syntax->datum #'datum))]
-    [(heads gdots . tail)
-     (gdots? #'gdots)
-     (let* ([heads (parse-heads #'heads decls depth)]
-            [tail (parse-pattern #'tail decls depth)]
-            [hattrs (append-attrs (for/list ([head heads]) (head-attrs head)))]
-            [tattrs (pattern-attrs tail)])
-       (make pat:gseq stx (append-attrs (list hattrs tattrs)) depth heads tail))]
+    [(~and . rest)
+     (begin (unless (stx-list? #'rest)
+              (wrong-syntax stx "expected list of patterns"))
+            (parse-and-pattern stx decls depth))]
+    [(~or . heads)
+     (begin (unless (stx-list? #'heads)
+              (wrong-syntax stx "expected list of pattern sequences"))
+            (unless allow-orseq-pattern?
+              (wrong-syntax stx "or/sequence pattern not allowed here"))
+            (let* ([heads (parse-heads #'heads decls depth)]
+                   [attrs
+                    (append-attrs
+                     (for/list ([head heads]) (head-attrs head)))])
+              (make pat:orseq stx attrs depth heads)))]
     [(head dots . tail)
      (dots? #'dots)
-     (let* ([headp (parse-pattern #'head decls (add1 depth))]
+     (let* ([headp (parse-pattern #'head decls (add1 depth)
+                                  #:allow-orseq-pattern? #t)]
+            [heads
+             (if (pat:orseq? headp)
+                 (pat:orseq-heads headp)
+                 (list (pattern->head headp)))]
             [tail (parse-pattern #'tail decls depth)]
-            [head (pattern->head headp)]
-            [attrs (append-attrs (list (head-attrs head) (pattern-attrs tail)))])
-       (make pat:gseq stx attrs depth (list head) tail))]
+            [hattrs (pattern-attrs headp)]
+            [tattrs (pattern-attrs tail)])
+       (make pat:gseq stx (append-attrs (list hattrs tattrs))
+             depth heads tail))]
     [(a . b)
      (let ([pa (parse-pattern #'a decls depth)]
            [pb (parse-pattern #'b decls depth)])
-       (let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)))])
-         (make pat:pair stx attrs depth pa pb)))]))
+       (define attrs
+         (append-attrs (list (pattern-attrs pa) (pattern-attrs pb))))
+       (make pat:compound stx attrs depth pairK (list pa pb))
+       #| (make pat:pair stx attrs depth pa pb) |#)]
+    [#(a ...)
+     (let ([lp (parse-pattern (syntax/loc stx (a ...)) decls depth)])
+       (make pat:compound stx (pattern-attrs lp) depth vectorK (list lp)))]
+    [#&x
+     (let ([bp (parse-pattern #'x decls depth)])
+       (make pat:compound stx (pattern-attrs bp) depth boxK (list bp)))]))
 
 (define (id-pattern-attrs name sc depth)
   (cond [(wildcard? name) null]
@@ -201,18 +263,23 @@
         [else
          (list (make attr name depth null))]))
 
+;; parse-and-patttern : stxlist DeclEnv nat -> Pattern
+(define (parse-and-pattern stx decls depth)
+  (define-values (chunks rest)
+    (chunk-kw-seq/no-dups (stx-cdr stx) and-pattern-directive-table))
+  (define description
+    (cond [(assq '#:description chunks) => caddr]
+          [else #f]))
+  (define patterns
+    (for/list ([x (stx->list rest)])
+      (parse-pattern x decls depth)))
+  (define attrs (append-attrs (map pattern-attrs patterns)))
+  (make pat:and stx attrs depth description patterns))
+
 (define (pattern->head p)
   (match p
     [(struct pattern (orig-stx iattrs depth))
-     (make head orig-stx iattrs depth (list p) #f #f #t #f #f)]))
-
-(define head-directive-table
-  (list (list '#:min check-nat/f)
-        (list '#:max check-nat/f)
-        (list '#:occurs check-id)
-        (list '#:default values)
-        (list '#:opt)
-        (list '#:mand)))
+     (make head orig-stx iattrs depth (list p) #f #f #t)]))
 
 (define (parse-heads stx decls enclosing-depth)
   (syntax-case stx ()
@@ -220,10 +287,14 @@
      (wrong-syntax (stx-car stx)
                    "empty head sequence not allowed")]
     [({p ...} . more)
-     (let-values ([(chunks rest) (chunk-kw-seq/no-dups #'more head-directive-table)])
-       (reject-duplicate-chunks chunks) ;; FIXME: needed?
+     (let()
+       (define-values (chunks rest)
+         (chunk-kw-seq/no-dups #'more head-directive-table))
+       (define-values (chunks2 rest2)
+         (chunk-kw-seq rest head-directive-table2))
+       ;; FIXME FIXME: handle chunks2 !!!!
        (cons (parse-head/chunks (stx-car stx) decls enclosing-depth chunks)
-             (parse-heads rest decls enclosing-depth)))]
+             (parse-heads rest2 decls enclosing-depth)))]
     [()
      null]
     [_
@@ -232,11 +303,9 @@
                          [else #f])
                    "expected sequence of patterns or sequence directive")]))
 
-(define (parse-head/chunks pstx decls enclosing-depth chunks)
+(define (parse-head/chunks pstx decls depth chunks)
   (let* ([min-row (assq '#:min chunks)]
          [max-row (assq '#:max chunks)]
-         [occurs-row (assq '#:occurs chunks)]
-         [default-row (assq '#:default chunks)]
          [opt-row (assq '#:opt chunks)]
          [mand-row (assq '#:mand chunks)]
          [min-stx (and min-row (caddr min-row))]
@@ -252,44 +321,25 @@
     (when (and (or min-row max-row) (or opt-row mand-row))
       (wrong-syntax (or min-stx max-stx)
                     "min/max-constraints are incompatible with opt/mand directives"))
-    (when default-row
-      (unless opt-row
-        (wrong-syntax (cadr default-row)
-                      "default only allowed for optional patterns")))
     (parse-head/options pstx
                         decls
-                        enclosing-depth
+                        depth
                         (cond [opt-row 0] [mand-row 1] [else min])
                         (cond [opt-row 1] [mand-row 1] [else max])
-                        (not (or opt-row mand-row))
-                        (and occurs-row (caddr occurs-row))
-                        default-row)))
+                        (not (or opt-row mand-row)))))
 
-(define (parse-head/options pstx decls enclosing-depth 
-                            min max as-list? occurs-pvar default-row)
-  (let* ([depth (if as-list? (add1 enclosing-depth) enclosing-depth)]
+(define (parse-head/options pstx decls depth min max as-list?)
+  (let* ([effective-depth (if as-list? depth (sub1 depth))]
          [heads
-          (for/list ([p (syntax->list pstx)])
-            (parse-pattern p decls depth))]
+          (for/list ([p (stx->list pstx)])
+            (parse-pattern p decls effective-depth))]
          [heads-attrs
           (append-attrs (map pattern-attrs heads))])
-    (when default-row
-      (unless (and (= (length heads-attrs) 1)
-                   (= enclosing-depth (attr-depth (car heads-attrs)))
-                   (null? (attr-inner (car heads-attrs))))
-        (wrong-syntax (cadr default-row)
-                      "default only allowed for patterns with single simple pattern variable")))
-    (let ([occurs-attrs
-           (if occurs-pvar
-               (list (make-attr occurs-pvar depth null))
-               null)])
-      (make head pstx
-            (append-attrs (list occurs-attrs heads-attrs))
-            depth
-            heads
-            min max as-list?
-            occurs-pvar
-            (and default-row (caddr default-row))))))
+    (make head pstx
+          heads-attrs
+          depth
+          heads
+          min max as-list?)))
 
 ;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id+id)
 ;;                         -> stx DeclEnv RemapEnv (listof SideClause)
@@ -358,6 +408,13 @@
      '()]))
 
 
+;; check-lit-string : stx -> string
+(define (check-lit-string stx)
+  (let ([x (syntax-e stx)])
+    (unless (string? x)
+      (wrong-syntax stx "expected string literal"))
+    x))
+
 ;; check-attr-arity-list : stx -> (listof SAttr)
 (define (check-attr-arity-list stx)
   (unless (stx-list? stx)
@@ -421,3 +478,17 @@
         (list '#:rename check-id check-id)
         (list '#:with values values)
         (list '#:when values)))
+
+;; and-pattern-directive-table
+(define and-pattern-directive-table
+  (list (list '#:description check-lit-string)))
+
+(define head-directive-table
+  (list (list '#:min check-nat/f)
+        (list '#:max check-nat/f)
+        (list '#:opt)
+        (list '#:mand)))
+
+(define head-directive-table2
+  (list (list '#:with values values)
+        (list '#:declare check-id values)))
diff --git a/collects/stxclass/private/runtime.ss b/collects/stxclass/private/runtime.ss
index aea51fb425..22a3bdaaad 100644
--- a/collects/stxclass/private/runtime.ss
+++ b/collects/stxclass/private/runtime.ss
@@ -9,6 +9,8 @@
          (for-syntax "../util/error.ss"))
 (provide pattern
          basic-syntax-class
+         ~and
+         ~or
          ...*
 
          with-enclosing-fail
@@ -20,6 +22,8 @@
          current-expression
          current-macro-name
 
+         this-syntax
+
          (for-syntax expectation-of-stxclass
                      expectation-of-constants
                      expectation-of/message)
@@ -41,8 +45,9 @@
 
 (define-keyword pattern)
 (define-keyword basic-syntax-class)
+(define-keyword ~and)
+(define-keyword ~or)
 (define-keyword ...*)
-(define-keyword ...**)
 
 ;; Parameters & Syntax Parameters
 
@@ -59,6 +64,12 @@
   (lambda (stx)
     (wrong-syntax stx "used out of context: not parsing pattern")))
 
+;; this-syntax
+;; Bound to syntax being matched inside of syntax class
+(define-syntax-parameter this-syntax
+  (lambda (stx)
+    (wrong-syntax stx "used out of context: not within a syntax class")))
+
 (define current-expression (make-parameter #f))
 
 (define (current-macro-name)
@@ -106,8 +117,8 @@
 ;; Runtime: parsing failures/expectations
 
 ;; An Expectation is
-;;   (make-expc (listof scdyn) (listof expc) (listof atom) (listof id))
-(define-struct expc (stxclasses pairs? data literals)
+;;   (make-expc (listof scdyn) (listof string/#t) (listof atom) (listof id))
+(define-struct expc (stxclasses compound data literals)
   #:transparent)
 
 (define-struct scdyn (name desc failure)
@@ -116,7 +127,7 @@
 (define expectation/c (or/c expc?))
 
 (define (make-stxclass-expc scdyn)
-  (make-expc (list scdyn) #f null null))
+  (make-expc (list scdyn) null null null))
 
 (begin-for-syntax
   (define certify (syntax-local-certifier))
@@ -131,18 +142,22 @@
                     (make-scdyn 'name (desc-var arg ...)
                                 (if (failed? #,result-var) #,result-var #f)))))))
 
-  (define (expectation-of-constants pairs? data literals)
+  (define (expectation-of-constants pairs? data literals description)
     (with-syntax ([(datum ...) data]
                   [(literal ...) literals]
-                  [pairs? pairs?])
+                  [pairs? pairs?]
+                  [description
+                   (if pairs?
+                       (list (or description #t))
+                       null)])
       (certify
-       #'(make-expc null 'pairs? (list 'datum ...)
+       #'(make-expc null 'description (list 'datum ...)
                     (list (quote-syntax literal) ...)))))
 
   (define (expectation-of/message msg)
     (with-syntax ([msg msg])
       (certify
-       #'(make-expc '() #f '((msg)) '())))))
+       #'(make-expc '() '() '((msg)) '())))))
 
 (define-syntax (try stx)
   (syntax-case stx ()
@@ -174,7 +189,7 @@
 
 (define (merge-expectations e1 e2)
   (make-expc (union (expc-stxclasses e1) (expc-stxclasses e2))
-             (or (expc-pairs? e1) (expc-pairs? e2))
+             (union (expc-compound e1) (expc-compound e2))
              (union (expc-data e1) (expc-data e2))
              (union (expc-literals e1) (expc-literals e2))))
 
@@ -183,9 +198,9 @@
 
 (define (expectation-of-null? e)
   (match e
-    [(struct expc (scs pairs? data literals))
+    [(struct expc (scs compound data literals))
      (and (null? scs)
-          (not pairs?)
+          (null? compound)
           (null? literals)
           (and (pair? data) (null? (cdr data)))
           (equal? (car data) '()))]
@@ -193,16 +208,18 @@
 
 (define (expectation->string e)
   (match e
-    [(struct expc (_ #t _ _))
-     #f]
-    [(struct expc (stxclasses pairs? data literals))
-     (let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))]
-           [s2 (and (pair? data) (string-of-data data))]
-           [s3 (and (pair? literals) (string-of-literals literals))]
-           [s4 (and pairs? string-of-pairs?)])
-       (join-sep (filter string? (list s1 s2 s3 s4))
-                 ";"
-                 "or"))]))
+    [(struct expc (stxclasses compound data literals))
+     (cond [(null? compound)
+            (let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))]
+                  [s2 (and (pair? data) (string-of-data data))]
+                  [s3 (and (pair? literals) (string-of-literals literals))])
+              (join-sep (filter string? (list s1 s2 s3))
+                        ";"
+                        "or"))]
+           [(andmap string? compound)
+            (join-sep compound ";" "or")]
+           [else
+            #f])]))
 
 (define (string-of-stxclasses scdyns)
   (comma-list (map string-of-stxclass scdyns)))
diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss
index a74c93fce4..1f9e10b039 100644
--- a/collects/stxclass/private/sc.ss
+++ b/collects/stxclass/private/sc.ss
@@ -1,4 +1,3 @@
-
 #lang scheme/base
 (require (for-syntax scheme/base
                      scheme/match
@@ -24,12 +23,16 @@
 
          pattern
          basic-syntax-class
+         ~and
+         ~or
          ...*
 
          attribute
 
          (struct-out failed)
 
+         this-syntax
+
          current-expression
          current-macro-name)
 
diff --git a/collects/stxclass/scribblings/parsing-syntax.scrbl b/collects/stxclass/scribblings/parsing-syntax.scrbl
index 8e9ae9b039..93d253320a 100644
--- a/collects/stxclass/scribblings/parsing-syntax.scrbl
+++ b/collects/stxclass/scribblings/parsing-syntax.scrbl
@@ -55,15 +55,21 @@ procedure accepts a single argument, which should be a syntax object.
 The grammar of patterns accepted by @scheme[syntax-parse] and
 @scheme[syntax-parser] follows:
 
-@schemegrammar*[#:literals (_ ...*)
+@schemegrammar*[#:literals (_ ~or ~and)
                 [syntax-pattern
                  pvar-id
                  pvar-id:syntax-class-id
                  literal-id
                  atomic-datum
                  (syntax-pattern . syntax-pattern)
-                 (syntax-pattern #,ellipses . syntax-pattern)
-                 ((head ...+) ...* . syntax-pattern)]
+                 (ellipsis-head-pattern #,ellipses . syntax-pattern)
+                 (~and maybe-description syntax-pattern ...)]
+                [ellipsis-head-pattern
+                 (~or head ...+)
+                 syntax-pattern]
+                [maybe-description
+                 (code:line)
+                 (code:line #:description string)]
                 [pvar-id
                  _
                  id]]
@@ -116,17 +122,8 @@ Matches a syntax pair whose head matches the first pattern and whose
 tail matches the second.
 
 }
-@;{
-@specsubform[(syntax-splice-pattern . syntax-pattern)]{
 
-Matches a syntax object which consists of any sequence of syntax
-objects matching the splice pattern followed by a tail matching the
-given tail pattern.
-
-}
-}
-
-@specsubform[(syntax-pattern #,ellipses . syntax-pattern)]{
+@specsubform[(ellipsis-head-pattern #,ellipses . syntax-pattern)]{
 
 Matches a sequence of the first pattern ending in a tail matching the
 second pattern.
@@ -135,23 +132,21 @@ That is, the sequence pattern matches either the second pattern (which
 need not be a list) or a pair whose head matches the first pattern and
 whose tail recursively matches the whole sequence pattern.
 
-}
-@specsubform/subs[#:literals (...*)
-                  ((head ...+) ...* . syntax-pattern)
+The head pattern can be either an ordinary pattern or an
+or/sequence-pattern:
+
+@specsubform/subs[#:literals (~or)
+                  (~or head ...+)
                   ([head
                     (code:line (syntax-pattern ...+) head-directive ...)]
                    [head-directive
                     (code:line #:min min-reps)
                     (code:line #:max max-reps)
-                    (code:line #:mand)
-                    #| (code:line #:opt)
-                       (code:line #:occurs occurs-pvar-id)
-                       (code:line #:default default-form)
-                    |#])]{
+                    (code:line #:mand)])]{
 
-Matches a sequence of any combination of the heads ending in a tail
-matching the final pattern. The match is subject to constraints
-specified on the heads.
+If the head is an or/sequence-pattern (introduced by @scheme[~or]),
+then the whole sequence pattern matches any combination of the head
+sequences followed by a tail matching the final pattern.
 
 @specsubform[(code:line #:min min-reps)]{
 
@@ -175,27 +170,16 @@ in the preceding head are not bound at a higher ellipsis nesting
 depth.
 
 }
-@;{
-@specsubform[#:opt]{
-
-(Probably a bad idea.)
-
 }
 }
-}
-@;{
-The variants of @scheme[_syntax-splice-pattern] follow:
+@specsubform/subs[#:literals (~and)
+                  (~and maybe-description syntax-pattern ...)
+                  ([maybe-description
+                    (code:line)
+                    (code:line #:description string)])]{
 
-@specsubform[pvar-id:syntax-splice-class-id]{
+Matches any syntax that matches all of the included patterns.
 
-Matches a sequence of syntax objects described by
-@scheme[_syntax-splice-class-id].
-
-The name @scheme[_pvar-id] is bound, but not allowed within
-expressions or @scheme[syntax] templates (since it does not refer to a
-particular syntax object). Only the prefixed attributes of the splice
-class are usable.
-}
 }
 
 Both @scheme[syntax-parse] and @scheme[syntax-parser] support
@@ -241,10 +225,19 @@ backtracks as described above; otherwise, it continues.
 
 }
 
-@defidform[...*]{
+
+@defidform[~and]{
 
 Keyword recognized by @scheme[syntax-parse] etc as notation for
-generalized sequences. It may not be used as an expression.
+and-patterns.
+
+}
+
+@defidform[~or]{
+
+Keyword recognized by @scheme[syntax-parse] etc as notation for
+or/sequence-patterns (within sequences). It may not be used as an
+expression.
 
 }
 
diff --git a/collects/stxclass/util/misc.ss b/collects/stxclass/util/misc.ss
index 13aba13abc..17fb4f9f08 100644
--- a/collects/stxclass/util/misc.ss
+++ b/collects/stxclass/util/misc.ss
@@ -14,6 +14,7 @@
          with-catching-disappeared-uses
          with-disappeared-uses
          syntax-local-value/catch
+         record-disappeared-uses
 
          format-symbol
 
@@ -51,10 +52,13 @@
 (define (syntax-local-value/catch id pred)
   (let ([value (syntax-local-value id (lambda () #f))])
     (and (pred value)
-         (begin (let ([uses (current-caught-disappeared-uses)])
-                  (when uses (current-caught-disappeared-uses (cons id uses))))
+         (begin (record-disappeared-uses (list id))
                 value))))
 
+(define (record-disappeared-uses ids)
+  (let ([uses (current-caught-disappeared-uses)])
+    (when uses
+      (current-caught-disappeared-uses (append ids uses)))))
 
 ;; Generating temporaries
 
diff --git a/collects/syntax/scribblings/strip-context.scrbl b/collects/syntax/scribblings/strip-context.scrbl
new file mode 100644
index 0000000000..0953ef514c
--- /dev/null
+++ b/collects/syntax/scribblings/strip-context.scrbl
@@ -0,0 +1,12 @@
+#lang scribble/doc
+@(require "common.ss"
+          (for-label syntax/strip-context))
+
+@title[#:tag "strip-context"]{Stripping Lexical Context}
+
+@defmodule[syntax/strip-context]
+
+@defproc[(strip-context [stx syntax?]) syntax?]{
+
+Removes all lexical context from @scheme[stx], preserving
+source-location information and properties.}
diff --git a/collects/syntax/scribblings/syntax-object-helpers.scrbl b/collects/syntax/scribblings/syntax-object-helpers.scrbl
index ea9c505da2..bff81ea78d 100644
--- a/collects/syntax/scribblings/syntax-object-helpers.scrbl
+++ b/collects/syntax/scribblings/syntax-object-helpers.scrbl
@@ -8,5 +8,6 @@
 @include-section["boundmap.scrbl"]
 @include-section["to-string.scrbl"]
 @include-section["free-vars.scrbl"]
+@include-section["strip-context.scrbl"]
 @include-section["zodiac.scrbl"]
 
diff --git a/collects/syntax/strip-context.ss b/collects/syntax/strip-context.ss
new file mode 100644
index 0000000000..81a3bafc6e
--- /dev/null
+++ b/collects/syntax/strip-context.ss
@@ -0,0 +1,22 @@
+#lang scheme/base
+
+(provide strip-context)
+
+(define (strip-context e)
+  (cond
+   [(syntax? e)
+    (datum->syntax #f
+                   (strip-context (syntax-e e))
+                   e
+                   e)]
+   [(pair? e) (cons (strip-context (car e))
+                    (strip-context (cdr e)))]
+   [(vector? e) (list->vector
+                 (map strip-context
+                      (vector->list e)))]
+   [(box? e) (box (strip-context (unbox e)))]
+   [(prefab-struct-key e)
+    => (lambda (k)
+         (apply make-prefab-struct
+                (strip-context (cdr (vector->list (struct->vector e))))))]
+   [else e]))
diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl
index a64bcff87f..5dc66e3309 100644
--- a/collects/teachpack/2htdp/scribblings/universe.scrbl
+++ b/collects/teachpack/2htdp/scribblings/universe.scrbl
@@ -25,6 +25,8 @@
 
 @author{Matthias Felleisen}
 
+@defmodule[2htdp/universe #:use-sources (teachpack/htdp/image)]
+
 @;{FIXME: the following paragraph uses `defterm' instead of `deftech',
    because the words "world" and "universe" are used as datatypes, and
    datatypes are currently linked as technical terms --- which is a hack.
@@ -52,8 +54,6 @@ The purpose of this documentation is to give experienced Schemers and HtDP
  have a series of projects available as a small booklet on
  @link["http://world.cs.brown.edu/"]{How to Design Worlds}.
 
-@declare-exporting[teachpack/2htdp/universe #:use-sources (teachpack/htdp/image)]
-
 @; -----------------------------------------------------------------------------
 
 @section[#:tag "basics"]{Basics}
@@ -158,7 +158,7 @@ The design of a world program demands that you come up with a data
 @defform/subs[#:id big-bang
               #:literals 
 	      (on-tick on-draw on-key on-mouse on-receive 
-	        stop-when register record?)
+	        stop-when register record? name)
               (big-bang state-expr clause ...)
               ([clause
 		 (on-tick tick-expr)
@@ -171,7 +171,7 @@ The design of a world program demands that you come up with a data
 		 (record? boolean-expr)
 		 (on-receive rec-expr)
 		 (register IP-expr)
-		 (register IP-expr name-expr)
+		 (name name-expr)
 		 ])]{
 
  starts a @tech{world} program in the initial state specified with
@@ -798,11 +798,11 @@ following shapes:
 }
 
 @item{
-@defform/none[(register ip-expr name-expr)
-              #:contracts
-              ([ip-expr string?]
-               [name-expr (or/c symbol? string?)])]{
- connect this world to a universe server @emph{under a specific} @scheme[name-expr].}
+@defform[(name name-expr)
+         #:contracts
+         ([name-expr (or/c symbol? string?)])]{
+ provide a name (@scheme[namer-expr]) to this world, which is used as the
+ title of the canvas and the name sent to the server.}
 }
 
 ]
@@ -1636,12 +1636,13 @@ Finally, here is the third function, which renders the state as a scene:
 
 ; String -> WorldState 
 ; create and hook up a world with the @scheme[LOCALHOST] server
-(define (create-world name)
+(define (create-world n)
   (big-bang WORLD0
            (on-receive receive)
-	   (on-draw (draw name))
+	   (on-draw (draw n))
 	   (on-tick move)
-	   (register LOCALHOST name)))
+           (name n)
+	   (register LOCALHOST)))
 ))
 
  Now you can use @scheme[(create-world 'carl)] and @scheme[(create-world 'same)],
diff --git a/collects/tests/drscheme/syncheck-test.ss b/collects/tests/drscheme/syncheck-test.ss
index 875ee2c736..4c13e3f2d2 100644
--- a/collects/tests/drscheme/syncheck-test.ss
+++ b/collects/tests/drscheme/syncheck-test.ss
@@ -34,6 +34,7 @@ trigger runtime errors in check syntax.
   ;; tests : (listof test)
   (define tests
     (list 
+     
      (build-test "12345"
                 '(("12345" constant)))
      (build-test "'abcdef"
@@ -829,7 +830,25 @@ trigger runtime errors in check syntax.
                       (" "             default-color)
                       ("foldl"         imported-variable)
                       (")"             default-color))
-                    #f)))
+                    #f)
+     
+     (build-test "#lang scheme/base\n(require scheme)\n(define-syntax m (lambda (x) #'1))"
+                 '(("#lang "        default-color)
+                   ("scheme/base"   error)
+                   ("\n("           default-color)
+                   ("require"       imported)
+                   (" scheme)\n("   default-color)
+                   ("define-syntax" imported)
+                   (" "             default-color)
+                   ("m"             lexically-bound)
+                   (" ("            default-color)
+                   ("lambda"        imported)
+                   (" ("            default-color)
+                   ("x"             lexically-bound)
+                   (") "            default-color)
+                   ("#'"            imported)
+                   ("1))"           default-color))
+                 (list '((27 33) (19 26) (36 49) (53 59) (64 66))))))
   
   (define (run-test)
     (check-language-level #rx"Pretty")
diff --git a/collects/tests/honu/basic.honu b/collects/tests/honu/basic.honu
index 42f3d46819..b05716e989 100644
--- a/collects/tests/honu/basic.honu
+++ b/collects/tests/honu/basic.honu
@@ -14,4 +14,6 @@ obj test(t, a, b){
 }
 
 var x = 3;
+const y = 2;
 test("x = 3", x, 3);
+test("y = 2", y, 2);
diff --git a/collects/tests/html/test.ss b/collects/tests/html/test.ss
new file mode 100644
index 0000000000..2b53719672
--- /dev/null
+++ b/collects/tests/html/test.ss
@@ -0,0 +1,45 @@
+#lang scheme
+(require (planet schematics/schemeunit:3)
+         (planet schematics/schemeunit:3/text-ui)
+         (prefix-in h: html)
+         (prefix-in x: xml))
+
+(define html-tests
+  (test-suite
+   "HTML"
+   
+   (test-case
+    "Example"
+    (local
+      [(define an-html
+         (h:read-xhtml
+          (open-input-string
+           (string-append
+            "<html><head><title>My title</title></head><body>"
+            "<p>Hello world</p><p><b>Testing</b>!</p>"
+            "</body></html>"))))
+       
+       ; extract-pcdata: html-content -> (listof string)
+       ; Pulls out the pcdata strings from some-content.
+       (define (extract-pcdata some-content)
+         (cond [(x:pcdata? some-content)
+                (list (x:pcdata-string some-content))]
+               [(x:entity? some-content)
+                (list)]
+               [else
+                (extract-pcdata-from-element some-content)]))
+       
+       ; extract-pcdata-from-element: html-element -> (listof string)
+       ; Pulls out the pcdata strings from an-html-element.
+       (define (extract-pcdata-from-element an-html-element)
+         (match an-html-element
+           [(struct h:html-full (attributes content))
+            (apply append (map extract-pcdata content))]
+           
+           [(struct h:html-element (attributes))
+            '()]))]
+      
+      (check-equal? (extract-pcdata an-html)
+                    ' ("My title" "Hello world" "Testing" "!"))))))
+
+(run-tests html-tests)
\ No newline at end of file
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index 2e4c85d6f9..917e07c2ae 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -2401,7 +2401,192 @@
       (eval '(require 'foo-dc18)))
    "(unit U@)")
   
+  (test/spec-failed
+   'define/contract19
+   '(let ()
+      (define y 3)
+      (define/contract (f n)
+        (-> number? number?)
+        #:freevar y (-> number? boolean?)
+        3)
+      1)
+   "top-level")
+  
+  (test/spec-passed
+   'define/contract20
+   '(let ()
+      (define y (lambda (n) 4))
+      (define/contract (f n)
+        (-> number? number?)
+        #:freevar y (-> number? boolean?)
+        3)
+      1))
+  
+  (test/spec-passed
+   'define/contract21
+   '(let ()
+      (define y (lambda (n) 4))
+      (define/contract (f n)
+        (-> number? number?)
+        #:freevar y (-> number? boolean?)
+        (if (y n) 3 1))
+      1))
+  
+  (test/spec-failed
+   'define/contract22
+   '(let ()
+      (define y 4)
+      (define/contract (f n)
+        (-> number? number?)
+        #:freevar y (-> number? boolean?)
+        3)
+      1)
+   "top-level")
 
+  (test/spec-failed
+   'define/contract23
+   '(let ()
+      (define y (lambda (n) #t))
+      (define/contract (f n)
+        (-> number? number?)
+        #:freevar y (-> number? number?)
+        (y n))
+      (f 5))
+   "top-level")
+  
+  (test/spec-failed
+   'define/contract24
+   '(let ()
+      (define y (lambda (n) 4))
+      (define/contract (f n)
+        (-> number? number?)
+        #:freevar y (-> number? boolean?)
+        (if (y #t) 3 1))
+      (f 5))
+   "(function f)")
+  
+  (test/spec-failed
+   'define/contract25
+   '(let ()
+      (define y #t)
+      (define z 3)
+      (define/contract f
+        number?
+        #:freevars ([y number?] [z number?])
+        (+ y z))
+      1)
+   "top-level")
+  
+
+
+;                                                                                                                                  
+;                                                                                                                                  
+;                                                                                                                                  
+;        ;          ;;;;                                                         ;                                                 
+;       ;;         ;   ;                                                         ;                                                 
+;        ;         ;                                ;                      ;    ;                        ;                      ;  
+;        ;         ;                                ;                      ;    ;                        ;                      ;  
+;     ;; ;   ;;;  ;;;; ;  ; ;;    ;;;          ;;; ;;;; ; ;;;;  ;;   ;;;  ;;;;  ;   ;;;     ;;    ; ;;  ;;;; ; ;;  ;;;    ;;;  ;;;;
+;    ;  ;;  ;   ;  ;  ;; ;;;  ;  ;   ;        ;  ;  ;  ;;;   ;   ;  ;   ;  ;   ;   ;   ;   ;  ;  ;;;  ;  ;  ;;;   ;   ;  ;   ;  ;  
+;   ;    ;  ;;;;;  ;   ;  ;   ;  ;;;;;        ;     ;   ;    ;   ;  ;      ;   ;   ;      ;    ;  ;   ;  ;   ;       ;;  ;      ;  
+;   ;    ;  ;      ;   ;  ;   ;  ;      ;;;;   ;;   ;   ;    ;   ;  ;      ;   ;   ;      ;    ;  ;   ;  ;   ;     ;; ;  ;      ;  
+;   ;    ;  ;      ;   ;  ;   ;  ;               ;  ;   ;    ;   ;  ;      ;   ;   ;      ;    ;  ;   ;  ;   ;    ;   ;  ;      ;  
+;    ;  ;;; ;   ;  ;   ;  ;   ;  ;   ;        ;  ;  ; ; ;    ;  ;;; ;   ;  ; ;;    ;   ;   ;  ;   ;   ;  ; ; ;    ;  ;;  ;   ;  ; ;
+;     ;; ;   ;;;  ;;;;;;;;;; ;;;  ;;;         ;;;   ;; ;;;    ;; ;   ;;;   ;; ;     ;;;     ;;   ;;; ;;; ;; ;;;    ;; ;;  ;;;   ;; 
+;                                                                                                                                  
+;                                                                                                                                  
+;                                                                                                                                  
+
+  (test/spec-passed
+   'define-struct/contract1
+   '(let ()
+      (define-struct/contract foo ([x number?] [y number?]))
+      1))
+
+  (test/spec-passed
+   'define-struct/contract2
+   '(let ()
+      (define-struct/contract foo ([x number?] [y number?]))
+      (make-foo 1 2)))
+  
+  (test/spec-failed
+   'define-struct/contract3
+   '(let ()
+      (define-struct/contract foo ([x number?] [y number?]))
+      (make-foo 1 #t))
+   "top-level")
+  
+  (test/spec-passed
+   'define-struct/contract4
+   '(let ()
+      (define-struct/contract foo ([x number?] [y number?]))
+      (foo-y (make-foo 2 3))))
+  
+  (test/spec-failed
+   'define-struct/contract5
+   '(let ()
+      (define-struct/contract foo ([x number?] [y number?]))
+      (foo-y 1))
+   "top-level")
+  
+  (test/spec-passed
+   'define-struct/contract6
+   '(let ()
+      (define-struct/contract foo ([x number?] [y number?]) #:mutable)
+      (set-foo-y! (make-foo 1 2) 3)
+      (set-foo-x! (make-foo 1 2) 3)))
+  
+  (test/spec-failed
+   'define-struct/contract7
+   '(let ()
+      (define-struct/contract foo ([x number?] [y number?]) #:mutable)
+      (set-foo-y! (make-foo 1 2) #f))
+   "top-level")
+  
+  (test/spec-passed
+   'define-struct/contract8
+   '(let ()
+      (define-struct/contract foo ([(x #:mutable) number?] [y number?]))
+      (set-foo-x! (make-foo 1 2) 4)))
+  
+  (test/spec-failed
+   'define-struct/contract9
+   '(let ()
+      (define-struct/contract foo ([(x #:mutable) number?] [y number?]))
+      (set-foo-x! (make-foo 1 2) #f))
+   "top-level")
+  
+  (test/spec-failed
+   'define-struct/contract10
+   '(let ()
+      (define-struct/contract foo ([x number?] [(y #:auto) number?]))
+      (make-foo 1))
+   "(struct foo)")
+  
+  (test/spec-passed
+   'define-struct/contract11
+   '(let ()
+      (define-struct/contract foo ([x number?] [(y #:auto) number?]) #:auto-value 3)
+      (make-foo 1)))
+  
+  (test/spec-passed
+   'define-struct/contract12
+   '(let ()
+      (define-struct/contract foo ([x number?] [(y #:auto #:mutable) number?]) #:auto-value 3)
+      (set-foo-y! (make-foo 1) 3)))
+  
+  (test/spec-failed
+   'define-struct/contract13
+   '(let ()
+      (define-struct/contract foo ([x number?] [(y #:auto #:mutable) number?]) #:auto-value 3)
+      (set-foo-y! (make-foo 1) #t))
+   "top-level")
+  
+  (test/spec-passed
+   'define-struct/contract14
+   '(let ()
+      (define-struct/contract foo ([x number?] [y number?]) #:transparent)
+      1))
 ;                                                                                  
 ;                                                                                  
 ;                                                                                  
@@ -2523,6 +2708,14 @@
         (define (x n) (if (y n) 4 0)))
       (x 4))
    "(region region2)")
+  
+  ;; make sure uncontracted exports make it out
+  (test/spec-passed
+   'with-contract9
+   '(let ()
+      (with-contract region1 (f)
+        (define f 3))
+      f))
 
 ;                                                                                                                         
 ;                                                                                                                         
diff --git a/collects/tests/mzscheme/htdp-image.ss b/collects/tests/mzscheme/htdp-image.ss
index 2a0bd8db84..40a9e72886 100644
--- a/collects/tests/mzscheme/htdp-image.ss
+++ b/collects/tests/mzscheme/htdp-image.ss
@@ -1058,6 +1058,19 @@
       (image->color-list (add-line (rectangle 10 10 'solid 'blue)
                                    0.1 #e.2 2.1 2.2 'red)))
 
+(test #t
+      'flooring/rounding-is-consistent
+      (image=? (overlay (rectangle 10 10 'solid 'black)
+                        (move-pinhole
+                         (rectangle 5 5 'solid 'red)
+                         (- (+ 5 1/10))
+                         (- (+ 5 1/10))))
+               (overlay/xy (rectangle 10 10 'solid 'black)
+                           (+ 5 1/10)
+                           (+ 5 1/10)
+                           (rectangle 5 5 'solid 'red))))
+      
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; The tests beginning with "bs-" ensure
diff --git a/collects/tests/stxclass/stxclass.ss b/collects/tests/stxclass/stxclass.ss
index d11e383b08..1ebeb878c2 100644
--- a/collects/tests/stxclass/stxclass.ss
+++ b/collects/tests/stxclass/stxclass.ss
@@ -118,37 +118,37 @@
         (check-equal? (syntax->datum #'(t.a ...)) '(1 4 6)))
       (test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8))
         (check-equal? (syntax->datum #'(t.b ...)) '(2 5 7)))
-      (test-patterns ({{x:id v:nat} {s:str}} ...*) #'(x 1 y 2 "whee" x 3)
+      (test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3)
         (check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3)))
         (check-equal? (stx->datum #'(s ...)) '("whee")))
-      (test-patterns ({{x:id v:nat} {s:str}} ...*) #'(x 1 y 2 "whee" x 3)
+      (test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3)
         (check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3)))
         (check-equal? (stx->datum #'(s ...)) '("whee")))
-      (test-patterns ({{1} #:min 1 #:max 1
-                       {2} #:min 1 #:max 1
-                       {3} #:min 1 #:max 1} ...*)
+      (test-patterns ({~or {1} #:min 1 #:max 1
+                           {2} #:min 1 #:max 1
+                           {3} #:min 1 #:max 1} ...)
                      #'(1 2 3)
         'ok)
-      (test-patterns ({{a:id} {b:nat} {c:str}} ...*) #'("one" 2 three)
+      (test-patterns ({~or {a:id} {b:nat} {c:str}} ...) #'("one" 2 three)
         (check-equal? (stx->datum #'(a ...)) '(three))
         (check-equal? (stx->datum #'(b ...)) '(2))
         (check-equal? (stx->datum #'(c ...)) '("one")))
-      (test-patterns ({{1} #:min 1 #:max 1
-                       {2} #:min 1 #:max 1
-                       {3} #:min 1 #:max 1
-                       {x} #:min 1 #:max 1
-                       {y} #:min 1 #:max 1
-                       {w} #:min 1 #:max 1} ...*)
+      (test-patterns ({~or {1} #:min 1 #:max 1
+                           {2} #:min 1 #:max 1
+                           {3} #:min 1 #:max 1
+                           {x} #:min 1 #:max 1
+                           {y} #:min 1 #:max 1
+                           {w} #:min 1 #:max 1} ...)
                      #'(1 2 3 x y z)
         (for ([s (syntax->list #'(x ... y ... w ...))]) (check-pred identifier? s))
         (check-equal? (sort 
                        (map symbol->string (stx->datum #'(x ... y ... w ...)))
                        string<?)
                       '("x" "y" "z")))
-      (test-patterns ({{x}
-                       {1} #:min 1 #:max 1
-                       {2} #:min 1 #:max 1
-                       {3} #:min 1 #:max 1} ...*)
+      (test-patterns ({~or {x}
+                           {1} #:min 1 #:max 1
+                           {2} #:min 1 #:max 1
+                           {3} #:min 1 #:max 1} ...)
                      #'(1 2 3 x y z)
         (check-equal? (stx->datum #'(x ...)) '(x y z)))
       )))
diff --git a/collects/tests/web-server/all-web-server-tests.ss b/collects/tests/web-server/all-web-server-tests.ss
index 73a0cf1bf8..ea44c8a081 100644
--- a/collects/tests/web-server/all-web-server-tests.ss
+++ b/collects/tests/web-server/all-web-server-tests.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          "configuration/all-configuration-tests.ss"
          "dispatchers/all-dispatchers-tests.ss"           
          "lang/all-lang-tests.ss"
diff --git a/collects/tests/web-server/configuration/all-configuration-tests.ss b/collects/tests/web-server/configuration/all-configuration-tests.ss
index 5282587ae5..3de7a213ba 100644
--- a/collects/tests/web-server/configuration/all-configuration-tests.ss
+++ b/collects/tests/web-server/configuration/all-configuration-tests.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          "configuration-table-test.ss")
 (provide all-configuration-tests)
 
diff --git a/collects/tests/web-server/configuration/configuration-table-test.ss b/collects/tests/web-server/configuration/configuration-table-test.ss
index fb48463129..6018612f07 100644
--- a/collects/tests/web-server/configuration/configuration-table-test.ss
+++ b/collects/tests/web-server/configuration/configuration-table-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          (only-in mzlib/file
                   make-temporary-file)
          web-server/configuration/configuration-table)
diff --git a/collects/tests/web-server/dispatchers/all-dispatchers-tests.ss b/collects/tests/web-server/dispatchers/all-dispatchers-tests.ss
index 79d213922e..6d3e761478 100644
--- a/collects/tests/web-server/dispatchers/all-dispatchers-tests.ss
+++ b/collects/tests/web-server/dispatchers/all-dispatchers-tests.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          "dispatch-passwords-test.ss"
          "dispatch-files-test.ss"        
          "dispatch-servlets-test.ss"
diff --git a/collects/tests/web-server/dispatchers/dispatch-files-test.ss b/collects/tests/web-server/dispatchers/dispatch-files-test.ss
index 35b481cbba..e4080c4e37 100644
--- a/collects/tests/web-server/dispatchers/dispatch-files-test.ss
+++ b/collects/tests/web-server/dispatchers/dispatch-files-test.ss
@@ -1,5 +1,5 @@
-#lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+#lang scheme
+(require (planet schematics/schemeunit:3)
          (only-in mzlib/file
                   file-name-from-path
                   make-temporary-file)
@@ -45,10 +45,14 @@
    (test-case
     "read-range-header: missing and badly formed headers"
     (check-false (files:read-range-header (list (make-header #"Ranges" #"bytes=1-10"))) "check 1")
-    (check-false (files:read-range-header (list (make-header #"Range" #"completely wrong"))) "check 2")
-    (check-false (files:read-range-header (list (make-header #"Range" #"byte=1-10"))) "check 3")
-    (check-false (files:read-range-header (list (make-header #"Range" #"bytes=a-10"))) "check 4")
-    (check-false (files:read-range-header (list (make-header #"Range" #"bytes=1-1.0"))) "check 5"))
+    (check-false (parameterize ([current-error-port (open-output-nowhere)])
+                   (files:read-range-header (list (make-header #"Range" #"completely wrong")))) "check 2")
+    (check-false (parameterize ([current-error-port (open-output-nowhere)])
+                   (files:read-range-header (list (make-header #"Range" #"byte=1-10")))) "check 3")
+    (check-false (parameterize ([current-error-port (open-output-nowhere)])
+                   (files:read-range-header (list (make-header #"Range" #"bytes=a-10")))) "check 4")
+    (check-false (parameterize ([current-error-port (open-output-nowhere)])
+                   (files:read-range-header (list (make-header #"Range" #"bytes=1-1.0")))) "check 5"))
    
    (test-case
     "read-range-header: single range"
diff --git a/collects/tests/web-server/dispatchers/dispatch-host-test.ss b/collects/tests/web-server/dispatchers/dispatch-host-test.ss
index b04c459cec..1ec05a0d04 100644
--- a/collects/tests/web-server/dispatchers/dispatch-host-test.ss
+++ b/collects/tests/web-server/dispatchers/dispatch-host-test.ss
@@ -1,6 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
-         (planet "util.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          (only-in mzlib/file
                   make-temporary-file)
          net/url
diff --git a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss
index b15b37623f..f80795a9cc 100644
--- a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss
+++ b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))
          mzlib/etc
          mzlib/list
diff --git a/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss b/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss
index 19be134a59..5f0325ee08 100644
--- a/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss
+++ b/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss
@@ -1,6 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
-         (planet "util.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          (only-in mzlib/file
                   make-temporary-file)
          net/url
diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss
index dbfb5b1322..cb96d59275 100644
--- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss
+++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))
          mzlib/etc
          mzlib/list
diff --git a/collects/tests/web-server/dispatchers/filesystem-map-test.ss b/collects/tests/web-server/dispatchers/filesystem-map-test.ss
index 2597c326ae..9059091c6b 100644
--- a/collects/tests/web-server/dispatchers/filesystem-map-test.ss
+++ b/collects/tests/web-server/dispatchers/filesystem-map-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          net/url
          web-server/private/util
          web-server/dispatchers/filesystem-map)
diff --git a/collects/tests/web-server/dispatchers/servlet-test-util.ss b/collects/tests/web-server/dispatchers/servlet-test-util.ss
index 37db1dfbcf..225e95310b 100644
--- a/collects/tests/web-server/dispatchers/servlet-test-util.ss
+++ b/collects/tests/web-server/dispatchers/servlet-test-util.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))         
          mzlib/list
          web-server/http
diff --git a/collects/tests/web-server/formlets-test.ss b/collects/tests/web-server/formlets-test.ss
index 9f12129485..c466f4a7ab 100644
--- a/collects/tests/web-server/formlets-test.ss
+++ b/collects/tests/web-server/formlets-test.ss
@@ -1,5 +1,5 @@
 #lang scheme
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          net/url
          web-server/http
          web-server/formlets
diff --git a/collects/tests/web-server/http/all-http-tests.ss b/collects/tests/web-server/http/all-http-tests.ss
index 3ca82a429c..d4b0a037b8 100644
--- a/collects/tests/web-server/http/all-http-tests.ss
+++ b/collects/tests/web-server/http/all-http-tests.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          "cookies-test.ss"
          "digest-auth-test.ss")
 (provide all-http-tests)
diff --git a/collects/tests/web-server/http/cookies-test.ss b/collects/tests/web-server/http/cookies-test.ss
index fa25ae829f..10d3831fb4 100644
--- a/collects/tests/web-server/http/cookies-test.ss
+++ b/collects/tests/web-server/http/cookies-test.ss
@@ -1,5 +1,5 @@
 #lang scheme
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          net/url
          web-server/http/request-structs
          web-server/http/response-structs
@@ -57,11 +57,11 @@
      "xexpr-response/cookies"
      (test-equal? "Simple"
                   (response/full-body (xexpr-response/cookies empty `(html)))
-                  (list #"<html></html>"))
+                  (list #"<html />"))
      
      (test-equal? "One (body)"
                   (response/full-body (xexpr-response/cookies (list (make-cookie "name" "value")) `(html)))
-                  (list #"<html></html>"))
+                  (list #"<html />"))
      
      (test-equal? "One (headers)"
                   (map (lambda (h) (cons (header-field h) (header-value h)))
diff --git a/collects/tests/web-server/http/digest-auth-test.ss b/collects/tests/web-server/http/digest-auth-test.ss
index 6e545c2aea..1da759b525 100644
--- a/collects/tests/web-server/http/digest-auth-test.ss
+++ b/collects/tests/web-server/http/digest-auth-test.ss
@@ -1,5 +1,5 @@
 #lang scheme
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/http
          net/url)
 (provide digest-auth-tests)
diff --git a/collects/tests/web-server/lang-test.ss b/collects/tests/web-server/lang-test.ss
index 1cc0be72dd..a53a562217 100644
--- a/collects/tests/web-server/lang-test.ss
+++ b/collects/tests/web-server/lang-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          "util.ss")
 (provide lang-tests)
 
@@ -240,7 +240,7 @@
        (let* ([first-key (table-01-eval '(dispatch-start start 'foo))]
               [second-key (table-01-eval `(dispatch lookup-k '(,first-key 1)))]
               [third-key (table-01-eval `(dispatch lookup-k '(,first-key -7)))])
-         (printf "~S~n" (list first-key second-key third-key))
+         #;(printf "~S~n" (list first-key second-key third-key))
          (check = 3 (table-01-eval `(dispatch lookup-k '(,second-key 2))))
          (check = 4 (table-01-eval `(dispatch lookup-k '(,second-key 3))))
          (check-true (zero? (table-01-eval `(dispatch lookup-k '(,second-key -1)))))
diff --git a/collects/tests/web-server/lang/abort-resume-test.ss b/collects/tests/web-server/lang/abort-resume-test.ss
index b30891e6e7..c9d1c320ec 100644
--- a/collects/tests/web-server/lang/abort-resume-test.ss
+++ b/collects/tests/web-server/lang/abort-resume-test.ss
@@ -1,6 +1,5 @@
 #lang scheme
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
-         (planet "util.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/lang/abort-resume)
 (require/expose web-server/lang/abort-resume (web-prompt))
 (provide abort-resume-tests)
diff --git a/collects/tests/web-server/lang/all-lang-tests.ss b/collects/tests/web-server/lang/all-lang-tests.ss
index f75fc2afc9..2f7af74d49 100644
--- a/collects/tests/web-server/lang/all-lang-tests.ss
+++ b/collects/tests/web-server/lang/all-lang-tests.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          "abort-resume-test.ss"
          "anormal-test.ss"
          "defun-test.ss"
diff --git a/collects/tests/web-server/lang/anormal-test.ss b/collects/tests/web-server/lang/anormal-test.ss
index 56202f7cf7..8651ffe3b6 100644
--- a/collects/tests/web-server/lang/anormal-test.ss
+++ b/collects/tests/web-server/lang/anormal-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/lang/anormal
          web-server/lang/util)
 (provide anormal-tests)
diff --git a/collects/tests/web-server/lang/defun-test.ss b/collects/tests/web-server/lang/defun-test.ss
index be3b2b9259..7b1e17b954 100644
--- a/collects/tests/web-server/lang/defun-test.ss
+++ b/collects/tests/web-server/lang/defun-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/lang/defun
          web-server/lang/util)
 (provide defun-tests)
diff --git a/collects/tests/web-server/lang/file-box-test.ss b/collects/tests/web-server/lang/file-box-test.ss
index 2cb4fef533..fefb26b73c 100644
--- a/collects/tests/web-server/lang/file-box-test.ss
+++ b/collects/tests/web-server/lang/file-box-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/lang/file-box
          (only-in mzlib/file make-temporary-file))
 (provide file-box-tests)
diff --git a/collects/tests/web-server/lang/labels-test.ss b/collects/tests/web-server/lang/labels-test.ss
index cf8ee4db2f..f261c55ef8 100644
--- a/collects/tests/web-server/lang/labels-test.ss
+++ b/collects/tests/web-server/lang/labels-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/lang/labels)
 (provide labels-tests)
 
diff --git a/collects/tests/web-server/lang/stuff-url-test.ss b/collects/tests/web-server/lang/stuff-url-test.ss
index 0f936bd836..70521c87d9 100644
--- a/collects/tests/web-server/lang/stuff-url-test.ss
+++ b/collects/tests/web-server/lang/stuff-url-test.ss
@@ -1,7 +1,7 @@
 #lang scheme/base
 (require web-server/lang/stuff-url
          web-server/stuffers
-         (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+         (planet schematics/schemeunit:3)
          net/url
          mzlib/serialize
          "../util.ss")
diff --git a/collects/tests/web-server/lang/web-param-test.ss b/collects/tests/web-server/lang/web-param-test.ss
index a31cedd9ab..072efce82d 100644
--- a/collects/tests/web-server/lang/web-param-test.ss
+++ b/collects/tests/web-server/lang/web-param-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          "../util.ss")
 (provide web-param-tests)
 
diff --git a/collects/tests/web-server/managers/all-managers-tests.ss b/collects/tests/web-server/managers/all-managers-tests.ss
index c7d44bba43..b2b0b2542c 100644
--- a/collects/tests/web-server/managers/all-managers-tests.ss
+++ b/collects/tests/web-server/managers/all-managers-tests.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
+(require (planet schematics/schemeunit:3))
 (provide all-managers-tests)
 
 (define all-managers-tests
diff --git a/collects/tests/web-server/private/all-private-tests.ss b/collects/tests/web-server/private/all-private-tests.ss
index 4dcc5803aa..6646557df1 100644
--- a/collects/tests/web-server/private/all-private-tests.ss
+++ b/collects/tests/web-server/private/all-private-tests.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          "request-test.ss"
          "cache-table-test.ss"
          "response-test.ss"
diff --git a/collects/tests/web-server/private/cache-table-test.ss b/collects/tests/web-server/private/cache-table-test.ss
index 071d55a33e..de88a4ec96 100644
--- a/collects/tests/web-server/private/cache-table-test.ss
+++ b/collects/tests/web-server/private/cache-table-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/private/cache-table)
 (provide cache-table-tests)
 
diff --git a/collects/tests/web-server/private/connection-manager-test.ss b/collects/tests/web-server/private/connection-manager-test.ss
index 75dc98384e..5e6a458dfa 100644
--- a/collects/tests/web-server/private/connection-manager-test.ss
+++ b/collects/tests/web-server/private/connection-manager-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/private/connection-manager)
 (provide connection-manager-tests)
 
diff --git a/collects/tests/web-server/private/define-closure-test.ss b/collects/tests/web-server/private/define-closure-test.ss
index 75b602edfd..5bb26814f1 100644
--- a/collects/tests/web-server/private/define-closure-test.ss
+++ b/collects/tests/web-server/private/define-closure-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          mzlib/serialize
          mzlib/match
          web-server/private/define-closure)
diff --git a/collects/tests/web-server/private/gzip-test.ss b/collects/tests/web-server/private/gzip-test.ss
index f020089a4d..c1969af515 100644
--- a/collects/tests/web-server/private/gzip-test.ss
+++ b/collects/tests/web-server/private/gzip-test.ss
@@ -1,5 +1,5 @@
 #lang scheme
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/private/gzip)
 (provide gzip-tests)
 
diff --git a/collects/tests/web-server/private/mime-types-test.ss b/collects/tests/web-server/private/mime-types-test.ss
index 56ba00cbbe..85c6c64cc3 100644
--- a/collects/tests/web-server/private/mime-types-test.ss
+++ b/collects/tests/web-server/private/mime-types-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          (only-in mzlib/file make-temporary-file)
          web-server/http
          web-server/private/mime-types)
diff --git a/collects/tests/web-server/private/mod-map-test.ss b/collects/tests/web-server/private/mod-map-test.ss
index ecb1328465..d4c45dc127 100644
--- a/collects/tests/web-server/private/mod-map-test.ss
+++ b/collects/tests/web-server/private/mod-map-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/private/mod-map
          mzlib/serialize
          "../util.ss")
diff --git a/collects/tests/web-server/private/request-test.ss b/collects/tests/web-server/private/request-test.ss
index 6dfced3bfd..2998634914 100644
--- a/collects/tests/web-server/private/request-test.ss
+++ b/collects/tests/web-server/private/request-test.ss
@@ -1,6 +1,5 @@
 #lang scheme
-(require (planet "util.ss" ("schematics" "schemeunit.plt" 2))
-         (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/private/connection-manager
          web-server/private/timer
          web-server/http)
diff --git a/collects/tests/web-server/private/response-test.ss b/collects/tests/web-server/private/response-test.ss
index a2575c32e0..b5305ca7a5 100644
--- a/collects/tests/web-server/private/response-test.ss
+++ b/collects/tests/web-server/private/response-test.ss
@@ -1,6 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
-         (planet "util.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          xml/xml
          (only-in mzlib/file
                   make-temporary-file)
diff --git a/collects/tests/web-server/private/session-test.ss b/collects/tests/web-server/private/session-test.ss
index b2597ef20a..2d8882d494 100644
--- a/collects/tests/web-server/private/session-test.ss
+++ b/collects/tests/web-server/private/session-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          mzlib/list
          net/url
          web-server/private/session)
diff --git a/collects/tests/web-server/private/url-param-test.ss b/collects/tests/web-server/private/url-param-test.ss
index a7a1f6f8eb..3c134259f0 100644
--- a/collects/tests/web-server/private/url-param-test.ss
+++ b/collects/tests/web-server/private/url-param-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          net/url
          web-server/private/url-param)
 (provide url-param-tests)
diff --git a/collects/tests/web-server/private/util-test.ss b/collects/tests/web-server/private/util-test.ss
index c8d1feccf5..bd28d4a886 100644
--- a/collects/tests/web-server/private/util-test.ss
+++ b/collects/tests/web-server/private/util-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          net/url
          xml/xml
          mzlib/contract
diff --git a/collects/tests/web-server/run-all-tests.ss b/collects/tests/web-server/run-all-tests.ss
index 290f2b7fbf..9aa2ce4abf 100644
--- a/collects/tests/web-server/run-all-tests.ss
+++ b/collects/tests/web-server/run-all-tests.ss
@@ -1,6 +1,5 @@
 #lang scheme/base
-(require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2))
-         (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3/text-ui)
          "all-web-server-tests.ss")
 
-(test/graphical-ui all-web-server-tests)
+(run-tests all-web-server-tests)
diff --git a/collects/tests/web-server/servlet-env-test.ss b/collects/tests/web-server/servlet-env-test.ss
index f450d730c8..cd3766f31a 100644
--- a/collects/tests/web-server/servlet-env-test.ss
+++ b/collects/tests/web-server/servlet-env-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          #;(only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3))
                  ssax:xml->sxml)
          #;(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4))
diff --git a/collects/tests/web-server/servlet/all-servlet-tests.ss b/collects/tests/web-server/servlet/all-servlet-tests.ss
index a8097822aa..898aa16ad8 100644
--- a/collects/tests/web-server/servlet/all-servlet-tests.ss
+++ b/collects/tests/web-server/servlet/all-servlet-tests.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          "bindings-test.ss"
          "basic-auth-test.ss"
          "helpers-test.ss"
diff --git a/collects/tests/web-server/servlet/basic-auth-test.ss b/collects/tests/web-server/servlet/basic-auth-test.ss
index 74525a02d6..33f3eedf68 100644
--- a/collects/tests/web-server/servlet/basic-auth-test.ss
+++ b/collects/tests/web-server/servlet/basic-auth-test.ss
@@ -1,5 +1,5 @@
 #lang scheme
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/http
          net/url)
 (provide basic-auth-tests)
diff --git a/collects/tests/web-server/servlet/bindings-test.ss b/collects/tests/web-server/servlet/bindings-test.ss
index 26f61926da..343e6f10f1 100644
--- a/collects/tests/web-server/servlet/bindings-test.ss
+++ b/collects/tests/web-server/servlet/bindings-test.ss
@@ -1,5 +1,5 @@
 #lang scheme
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          mzlib/list
          net/url
          web-server/http
diff --git a/collects/tests/web-server/servlet/helpers-test.ss b/collects/tests/web-server/servlet/helpers-test.ss
index f345d23e9c..17c105462d 100644
--- a/collects/tests/web-server/servlet/helpers-test.ss
+++ b/collects/tests/web-server/servlet/helpers-test.ss
@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/servlet)
 (provide helpers-tests)
 
diff --git a/collects/tests/web-server/servlet/web-test.ss b/collects/tests/web-server/servlet/web-test.ss
index 1dac07efac..8caee36c94 100644
--- a/collects/tests/web-server/servlet/web-test.ss
+++ b/collects/tests/web-server/servlet/web-test.ss
@@ -1,6 +1,5 @@
 #lang scheme/base
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
-         (planet "util.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          net/url
          web-server/servlet/web)
 (require/expose web-server/servlet/web
diff --git a/collects/tests/web-server/stuffers-test.ss b/collects/tests/web-server/stuffers-test.ss
index 5036b080bc..7198a58e25 100644
--- a/collects/tests/web-server/stuffers-test.ss
+++ b/collects/tests/web-server/stuffers-test.ss
@@ -1,5 +1,5 @@
 #lang scheme
-(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+(require (planet schematics/schemeunit:3)
          web-server/stuffers
          web-server/private/servlet
          web-server/http
diff --git a/collects/tests/web-server/util.ss b/collects/tests/web-server/util.ss
index 007be21461..22b4ebbcfd 100644
--- a/collects/tests/web-server/util.ss
+++ b/collects/tests/web-server/util.ss
@@ -23,7 +23,7 @@
   (match (regexp-match #"^.+\r\n\r\n(.+)$" bs)
     [(list _ s)
      (define sx (ssax:xml->sxml (open-input-bytes s) empty))
-     (pretty-print sx)
+     #;(pretty-print sx)
      sx]
     [_
      (error 'html "Given ~S~n" bs)]))
@@ -107,7 +107,8 @@
            (eval '(require 'm-id)))
          
          (lambda (s-expr)
-           (parameterize ([current-namespace ns])
+           (parameterize ([current-namespace ns]
+                          [current-output-port (open-output-nowhere)])
              (eval s-expr))))]
     [else
      (raise-syntax-error #f "make-module-evel: dropped through" m-expr)]))
@@ -121,5 +122,6 @@
       (namespace-require 'mzlib/serialize)
       (namespace-require pth))
     (lambda (expr)
-      (parameterize ([current-namespace ns])
+      (parameterize ([current-namespace ns]
+                     [current-output-port (open-output-nowhere)])
         (eval expr)))))
diff --git a/collects/tests/xml/clark-tests/canonxml.html b/collects/tests/xml/clark-tests/canonxml.html
new file mode 100644
index 0000000000..2ba0edf6c6
--- /dev/null
+++ b/collects/tests/xml/clark-tests/canonxml.html
@@ -0,0 +1,44 @@
+<HTML>
+<TITLE>Canonical XML</TITLE>
+<BODY>
+<H1>Canonical XML</H1>
+<P>
+This document defines a subset of XML called canonical XML.
+The intended use of canonical XML is in testing XML processors,
+as a representation of the result of parsing an XML document.
+<P>
+Every well-formed XML document has a unique structurally equivalent
+canonical XML document.  Two structurally equivalent XML
+documents have a byte-for-byte identical canonical XML document.
+Canonicalizing an XML document requires only information that an XML
+processor is required to make available to an application.
+<P>
+A canonical XML document conforms to the following grammar:
+<PRE>
+CanonXML    ::= Pi* element Pi*
+element     ::= Stag (Datachar | Pi | element)* Etag
+Stag        ::= '&lt;'  Name Atts '&gt;'
+Etag        ::= '&lt;/' Name '&gt;'
+Pi          ::= '&lt;?' Name ' ' (((Char - S) Char*)? - (Char* '?&gt;' Char*)) '?&gt;'
+Atts        ::= (' ' Name '=' '"' Datachar* '"')*
+Datachar    ::= '&amp;amp;' | '&amp;lt;' | '&amp;gt;' | '&amp;quot;'
+                 | '&amp;#9;'| '&amp;#10;'| '&amp;#13;'
+                 | (Char - ('&amp;' | '&lt;' | '&gt;' | '"' | #x9 | #xA | #xD))
+Name        ::= (see XML spec)
+Char        ::= (see XML spec)
+S           ::= (see XML spec)
+</PRE>
+<P>
+Attributes are in lexicographical order (in Unicode bit order).
+<P>
+A canonical XML document is encoded in UTF-8.
+<P>
+Ignorable white space is considered significant and is treated equivalently
+to data.
+<P>
+<ADDRESS>
+<A HREF="mailto:jjc@jclark.com">James Clark</A>
+</ADDRESS>
+
+</BODY>
+</HTML>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/invalid/001.ent b/collects/tests/xml/clark-tests/invalid/001.ent
new file mode 100644
index 0000000000..f70eaea9c4
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/001.ent
@@ -0,0 +1,3 @@
+<!ELEMENT doc EMPTY>
+<!ENTITY % e "<!--">
+%e; -->
diff --git a/collects/tests/xml/clark-tests/invalid/001.xml b/collects/tests/xml/clark-tests/invalid/001.xml
new file mode 100644
index 0000000000..36188451ae
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/001.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "001.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/invalid/002.ent b/collects/tests/xml/clark-tests/invalid/002.ent
new file mode 100644
index 0000000000..4cb848b438
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/002.ent
@@ -0,0 +1,2 @@
+<!ENTITY % e "(#PCDATA">
+<!ELEMENT doc %e;)>
diff --git a/collects/tests/xml/clark-tests/invalid/002.xml b/collects/tests/xml/clark-tests/invalid/002.xml
new file mode 100644
index 0000000000..5a3a96d1ab
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/002.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "002.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/invalid/003.ent b/collects/tests/xml/clark-tests/invalid/003.ent
new file mode 100644
index 0000000000..54f3c821b8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/003.ent
@@ -0,0 +1,2 @@
+<!ENTITY % e "<!ELEMENT ">
+%e; doc (#PCDATA)>
diff --git a/collects/tests/xml/clark-tests/invalid/003.xml b/collects/tests/xml/clark-tests/invalid/003.xml
new file mode 100644
index 0000000000..dd01f41126
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/003.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "003.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/invalid/004.ent b/collects/tests/xml/clark-tests/invalid/004.ent
new file mode 100644
index 0000000000..aae4cc2929
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/004.ent
@@ -0,0 +1,3 @@
+<!ENTITY % e1 "<!ELEMENT ">
+<!ENTITY % e2 ">">
+%e1; doc (#PCDATA) %e2;
diff --git a/collects/tests/xml/clark-tests/invalid/004.xml b/collects/tests/xml/clark-tests/invalid/004.xml
new file mode 100644
index 0000000000..20cdf6d0e5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/004.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "004.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/invalid/005.ent b/collects/tests/xml/clark-tests/invalid/005.ent
new file mode 100644
index 0000000000..85e16474a6
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/005.ent
@@ -0,0 +1,2 @@
+<!ENTITY % e ">">
+<!ELEMENT doc (#PCDATA) %e;
diff --git a/collects/tests/xml/clark-tests/invalid/005.xml b/collects/tests/xml/clark-tests/invalid/005.xml
new file mode 100644
index 0000000000..383553d24f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/005.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "005.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/invalid/006.ent b/collects/tests/xml/clark-tests/invalid/006.ent
new file mode 100644
index 0000000000..116ca79657
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/006.ent
@@ -0,0 +1,2 @@
+<!ENTITY % e "(#PCDATA)>">
+<!ELEMENT doc %e;
diff --git a/collects/tests/xml/clark-tests/invalid/006.xml b/collects/tests/xml/clark-tests/invalid/006.xml
new file mode 100644
index 0000000000..2f14e839e2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/invalid/006.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "006.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/001.ent b/collects/tests/xml/clark-tests/not-wf/ext-sa/001.ent
new file mode 100644
index 0000000000..378a2074b7
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/001.ent
@@ -0,0 +1 @@
+&e;
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/001.xml b/collects/tests/xml/clark-tests/not-wf/ext-sa/001.xml
new file mode 100644
index 0000000000..aa624cbe71
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/001.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e SYSTEM "001.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/002.ent b/collects/tests/xml/clark-tests/not-wf/ext-sa/002.ent
new file mode 100644
index 0000000000..2cd184a213
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/002.ent
@@ -0,0 +1,3 @@
+<?xml version="1.0" standalone="yes"?>
+data
+
diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/002.xml b/collects/tests/xml/clark-tests/not-wf/ext-sa/002.xml
new file mode 100644
index 0000000000..9eaf91724f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/002.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e SYSTEM "002.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/003.ent b/collects/tests/xml/clark-tests/not-wf/ext-sa/003.ent
new file mode 100644
index 0000000000..35cf4892f2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/003.ent
@@ -0,0 +1,2 @@
+<?xml version="1.0"?><?xml version="1.0"?>
+data
diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/003.xml b/collects/tests/xml/clark-tests/not-wf/ext-sa/003.xml
new file mode 100644
index 0000000000..bb60b663ef
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/003.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e SYSTEM "003.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/001.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/001.ent
new file mode 100644
index 0000000000..00096e572e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/001.ent
@@ -0,0 +1,3 @@
+<![ INCLUDE [
+<!ELEMENT doc (#PCDATA)>
+]>
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/001.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/001.xml
new file mode 100644
index 0000000000..36188451ae
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/001.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "001.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/002.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/002.xml
new file mode 100644
index 0000000000..dd73174135
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/002.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e "<?xml version='1.0' encoding='UTF-8'?>">
+%e;
+]>
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/003.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/003.ent
new file mode 100644
index 0000000000..abf1b1a35e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/003.ent
@@ -0,0 +1,2 @@
+<!ELEMENT doc (#PCDATA)>
+<![ IGNORE [
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/003.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/003.xml
new file mode 100644
index 0000000000..dd01f41126
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/003.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "003.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/004.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/004.ent
new file mode 100644
index 0000000000..552e4f520a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/004.ent
@@ -0,0 +1,2 @@
+<!ELEMENT doc (#PCDATA)>
+<![ INCLUDE [
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/004.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/004.xml
new file mode 100644
index 0000000000..20cdf6d0e5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/004.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "004.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/005.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/005.ent
new file mode 100644
index 0000000000..9a369cef12
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/005.ent
@@ -0,0 +1,2 @@
+<!ELEMENT doc (#PCDATA)>
+%e;
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/005.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/005.xml
new file mode 100644
index 0000000000..383553d24f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/005.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "005.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/006.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/006.ent
new file mode 100644
index 0000000000..771daf1915
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/006.ent
@@ -0,0 +1,3 @@
+<![INCLUDE
+<!ELEMENT doc (#PCDATA)>
+]]>
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/006.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/006.xml
new file mode 100644
index 0000000000..2f14e839e2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/006.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "006.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/007.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/007.ent
new file mode 100644
index 0000000000..9e9866d2ad
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/007.ent
@@ -0,0 +1,3 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/007.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/007.xml
new file mode 100644
index 0000000000..38897e34ea
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/007.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "007.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/008.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/008.ent
new file mode 100644
index 0000000000..f8b1cd3dad
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/008.ent
@@ -0,0 +1,2 @@
+<!ELEMENT doc ANY>
+<!ENTITY e "100%">
diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/008.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/008.xml
new file mode 100644
index 0000000000..54351009cd
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/not-sa/008.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "008.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/001.xml b/collects/tests/xml/clark-tests/not-wf/sa/001.xml
new file mode 100644
index 0000000000..d33ec68dcd
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/001.xml
@@ -0,0 +1,5 @@
+<doc>
+<doc
+?
+<a</a>
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/002.xml b/collects/tests/xml/clark-tests/not-wf/sa/002.xml
new file mode 100644
index 0000000000..0a64d52428
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/002.xml
@@ -0,0 +1,4 @@
+<doc>
+<.doc></.doc>
+</doc>
+
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/003.xml b/collects/tests/xml/clark-tests/not-wf/sa/003.xml
new file mode 100644
index 0000000000..e0b8bae4a4
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/003.xml
@@ -0,0 +1 @@
+<doc><? ?></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/004.xml b/collects/tests/xml/clark-tests/not-wf/sa/004.xml
new file mode 100644
index 0000000000..e85bc96e56
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/004.xml
@@ -0,0 +1 @@
+<doc><?target some data></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/005.xml b/collects/tests/xml/clark-tests/not-wf/sa/005.xml
new file mode 100644
index 0000000000..7cd44ef10c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/005.xml
@@ -0,0 +1 @@
+<doc><?target some data?</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/006.xml b/collects/tests/xml/clark-tests/not-wf/sa/006.xml
new file mode 100644
index 0000000000..8594c35cc7
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/006.xml
@@ -0,0 +1 @@
+<doc><!-- a comment -- another --></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/007.xml b/collects/tests/xml/clark-tests/not-wf/sa/007.xml
new file mode 100644
index 0000000000..286756fdd5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/007.xml
@@ -0,0 +1 @@
+<doc>&amp no refc</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/008.xml b/collects/tests/xml/clark-tests/not-wf/sa/008.xml
new file mode 100644
index 0000000000..29ef40306b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/008.xml
@@ -0,0 +1 @@
+<doc>&.entity;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/009.xml b/collects/tests/xml/clark-tests/not-wf/sa/009.xml
new file mode 100644
index 0000000000..8e3ff7de10
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/009.xml
@@ -0,0 +1 @@
+<doc>&#RE;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/010.xml b/collects/tests/xml/clark-tests/not-wf/sa/010.xml
new file mode 100644
index 0000000000..a6790846c9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/010.xml
@@ -0,0 +1 @@
+<doc>A & B</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/011.xml b/collects/tests/xml/clark-tests/not-wf/sa/011.xml
new file mode 100644
index 0000000000..57eaf9fc48
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/011.xml
@@ -0,0 +1 @@
+<doc a1></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/012.xml b/collects/tests/xml/clark-tests/not-wf/sa/012.xml
new file mode 100644
index 0000000000..1b2539ffa6
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/012.xml
@@ -0,0 +1 @@
+<doc a1=v1></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/013.xml b/collects/tests/xml/clark-tests/not-wf/sa/013.xml
new file mode 100644
index 0000000000..3540df9143
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/013.xml
@@ -0,0 +1 @@
+<doc a1="v1'></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/014.xml b/collects/tests/xml/clark-tests/not-wf/sa/014.xml
new file mode 100644
index 0000000000..a613115609
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/014.xml
@@ -0,0 +1 @@
+<doc a1="<foo>"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/015.xml b/collects/tests/xml/clark-tests/not-wf/sa/015.xml
new file mode 100644
index 0000000000..f2baf947b5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/015.xml
@@ -0,0 +1 @@
+<doc a1=></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/016.xml b/collects/tests/xml/clark-tests/not-wf/sa/016.xml
new file mode 100644
index 0000000000..22d4b2e265
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/016.xml
@@ -0,0 +1 @@
+<doc a1="v1" "v2"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/017.xml b/collects/tests/xml/clark-tests/not-wf/sa/017.xml
new file mode 100644
index 0000000000..a76f5929e9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/017.xml
@@ -0,0 +1 @@
+<doc><![CDATA[</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/018.xml b/collects/tests/xml/clark-tests/not-wf/sa/018.xml
new file mode 100644
index 0000000000..66e204acc4
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/018.xml
@@ -0,0 +1 @@
+<doc><![CDATA [ stuff]]></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/019.xml b/collects/tests/xml/clark-tests/not-wf/sa/019.xml
new file mode 100644
index 0000000000..b835c2d752
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/019.xml
@@ -0,0 +1 @@
+<doc></>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/020.xml b/collects/tests/xml/clark-tests/not-wf/sa/020.xml
new file mode 100644
index 0000000000..b30cfcfc10
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/020.xml
@@ -0,0 +1 @@
+<doc a1="A & B"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/021.xml b/collects/tests/xml/clark-tests/not-wf/sa/021.xml
new file mode 100644
index 0000000000..1bfa84aa64
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/021.xml
@@ -0,0 +1 @@
+<doc a1="a&b"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/022.xml b/collects/tests/xml/clark-tests/not-wf/sa/022.xml
new file mode 100644
index 0000000000..44c803bf1b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/022.xml
@@ -0,0 +1 @@
+<doc a1="&#123:"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/023.xml b/collects/tests/xml/clark-tests/not-wf/sa/023.xml
new file mode 100644
index 0000000000..b877ae2a6b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/023.xml
@@ -0,0 +1 @@
+<doc 12="34"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/024.xml b/collects/tests/xml/clark-tests/not-wf/sa/024.xml
new file mode 100644
index 0000000000..cf68f2c073
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/024.xml
@@ -0,0 +1,3 @@
+<doc>
+<123></123>
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/025.xml b/collects/tests/xml/clark-tests/not-wf/sa/025.xml
new file mode 100644
index 0000000000..6cba95cd78
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/025.xml
@@ -0,0 +1 @@
+<doc>]]></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/026.xml b/collects/tests/xml/clark-tests/not-wf/sa/026.xml
new file mode 100644
index 0000000000..347984fa73
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/026.xml
@@ -0,0 +1 @@
+<doc>]]]></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/027.xml b/collects/tests/xml/clark-tests/not-wf/sa/027.xml
new file mode 100644
index 0000000000..cfafaf0d70
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/027.xml
@@ -0,0 +1,3 @@
+<doc>
+<!-- abc
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/028.xml b/collects/tests/xml/clark-tests/not-wf/sa/028.xml
new file mode 100644
index 0000000000..522714993a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/028.xml
@@ -0,0 +1,4 @@
+<doc>
+<?a pi that is not closed
+</doc>
+
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/029.xml b/collects/tests/xml/clark-tests/not-wf/sa/029.xml
new file mode 100644
index 0000000000..9a8008bc9f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/029.xml
@@ -0,0 +1 @@
+<doc>abc]]]>def</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/030.xml b/collects/tests/xml/clark-tests/not-wf/sa/030.xml
new file mode 100644
index 0000000000..25861fa19b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/030.xml
@@ -0,0 +1 @@
+<doc>A form feed () is not legal in data</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/031.xml b/collects/tests/xml/clark-tests/not-wf/sa/031.xml
new file mode 100644
index 0000000000..f946536f39
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/031.xml
@@ -0,0 +1 @@
+<doc><?pi a form feed () is not allowed in a pi?></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/032.xml b/collects/tests/xml/clark-tests/not-wf/sa/032.xml
new file mode 100644
index 0000000000..75952017ca
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/032.xml
@@ -0,0 +1 @@
+<doc><!-- a form feed () is not allowed in a comment --></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/033.xml b/collects/tests/xml/clark-tests/not-wf/sa/033.xml
new file mode 100644
index 0000000000..afd2328402
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/033.xml
@@ -0,0 +1 @@
+<doc>abcdef</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/034.xml b/collects/tests/xml/clark-tests/not-wf/sa/034.xml
new file mode 100644
index 0000000000..d74a77719b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/034.xml
@@ -0,0 +1 @@
+<doc>A form-feed is not white space or a name character</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/035.xml b/collects/tests/xml/clark-tests/not-wf/sa/035.xml
new file mode 100644
index 0000000000..e1fc920522
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/035.xml
@@ -0,0 +1 @@
+<doc>1 < 2 but not in XML</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/036.xml b/collects/tests/xml/clark-tests/not-wf/sa/036.xml
new file mode 100644
index 0000000000..b8ecb21ba1
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/036.xml
@@ -0,0 +1,2 @@
+<doc></doc>
+Illegal data
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/037.xml b/collects/tests/xml/clark-tests/not-wf/sa/037.xml
new file mode 100644
index 0000000000..2e02662926
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/037.xml
@@ -0,0 +1,2 @@
+<doc></doc>
+&#32;
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/038.xml b/collects/tests/xml/clark-tests/not-wf/sa/038.xml
new file mode 100644
index 0000000000..68b2803f82
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/038.xml
@@ -0,0 +1 @@
+<doc x="foo" y="bar" x="baz"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/039.xml b/collects/tests/xml/clark-tests/not-wf/sa/039.xml
new file mode 100644
index 0000000000..80429e3e40
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/039.xml
@@ -0,0 +1 @@
+<doc><a></aa></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/040.xml b/collects/tests/xml/clark-tests/not-wf/sa/040.xml
new file mode 100644
index 0000000000..dc8ba5a434
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/040.xml
@@ -0,0 +1,2 @@
+<doc></doc>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/041.xml b/collects/tests/xml/clark-tests/not-wf/sa/041.xml
new file mode 100644
index 0000000000..30bcdd6bfe
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/041.xml
@@ -0,0 +1,2 @@
+<doc/>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/042.xml b/collects/tests/xml/clark-tests/not-wf/sa/042.xml
new file mode 100644
index 0000000000..4ae50efc7b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/042.xml
@@ -0,0 +1 @@
+<doc/></doc/>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/043.xml b/collects/tests/xml/clark-tests/not-wf/sa/043.xml
new file mode 100644
index 0000000000..41824eee4b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/043.xml
@@ -0,0 +1,2 @@
+<doc/>
+Illegal data
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/044.xml b/collects/tests/xml/clark-tests/not-wf/sa/044.xml
new file mode 100644
index 0000000000..3fc232dc37
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/044.xml
@@ -0,0 +1 @@
+<doc/><doc/>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/045.xml b/collects/tests/xml/clark-tests/not-wf/sa/045.xml
new file mode 100644
index 0000000000..00c10f00bf
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/045.xml
@@ -0,0 +1,4 @@
+<doc>
+<a/
+</doc>
+
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/046.xml b/collects/tests/xml/clark-tests/not-wf/sa/046.xml
new file mode 100644
index 0000000000..265cb15301
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/046.xml
@@ -0,0 +1,3 @@
+<doc>
+<a/</a>
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/047.xml b/collects/tests/xml/clark-tests/not-wf/sa/047.xml
new file mode 100644
index 0000000000..d18a4a4440
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/047.xml
@@ -0,0 +1,3 @@
+<doc>
+<a / >
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/048.xml b/collects/tests/xml/clark-tests/not-wf/sa/048.xml
new file mode 100644
index 0000000000..67419c1ed5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/048.xml
@@ -0,0 +1,3 @@
+<doc>
+</doc>
+<![CDATA[]]>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/049.xml b/collects/tests/xml/clark-tests/not-wf/sa/049.xml
new file mode 100644
index 0000000000..3cf0e79422
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/049.xml
@@ -0,0 +1,4 @@
+<doc>
+<a><![CDATA[xyz]]]></a>
+<![CDATA[]]></a>
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/050.xml b/collects/tests/xml/clark-tests/not-wf/sa/050.xml
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/051.xml b/collects/tests/xml/clark-tests/not-wf/sa/051.xml
new file mode 100644
index 0000000000..b52df12cc4
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/051.xml
@@ -0,0 +1,3 @@
+<!-- a comment -->
+<![CDATA[]]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/052.xml b/collects/tests/xml/clark-tests/not-wf/sa/052.xml
new file mode 100644
index 0000000000..8283895990
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/052.xml
@@ -0,0 +1,3 @@
+<!-- a comment -->
+&#32;
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/053.xml b/collects/tests/xml/clark-tests/not-wf/sa/053.xml
new file mode 100644
index 0000000000..9d7f36920f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/053.xml
@@ -0,0 +1 @@
+<doc></DOC>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/054.xml b/collects/tests/xml/clark-tests/not-wf/sa/054.xml
new file mode 100644
index 0000000000..eda553c6d3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/054.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY foo PUBLIC "some public id">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/055.xml b/collects/tests/xml/clark-tests/not-wf/sa/055.xml
new file mode 100644
index 0000000000..cbb3683a9d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/055.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc [
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/056.xml b/collects/tests/xml/clark-tests/not-wf/sa/056.xml
new file mode 100644
index 0000000000..a681684c58
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/056.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc -- a comment -- []>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/057.xml b/collects/tests/xml/clark-tests/not-wf/sa/057.xml
new file mode 100644
index 0000000000..848d347120
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/057.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "whatever" -- a comment -->
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/058.xml b/collects/tests/xml/clark-tests/not-wf/sa/058.xml
new file mode 100644
index 0000000000..daba266af2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/058.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 (foo,bar) #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/059.xml b/collects/tests/xml/clark-tests/not-wf/sa/059.xml
new file mode 100644
index 0000000000..316083dc25
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/059.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 NMTOKEN v1>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/060.xml b/collects/tests/xml/clark-tests/not-wf/sa/060.xml
new file mode 100644
index 0000000000..9a610fd38f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/060.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 NAME #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/061.xml b/collects/tests/xml/clark-tests/not-wf/sa/061.xml
new file mode 100644
index 0000000000..59181e706f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/061.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e PUBLIC "whatever""e.ent">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/062.xml b/collects/tests/xml/clark-tests/not-wf/sa/062.xml
new file mode 100644
index 0000000000..e62e9cd370
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/062.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY foo"some text">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/063.xml b/collects/tests/xml/clark-tests/not-wf/sa/063.xml
new file mode 100644
index 0000000000..98675b9040
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/063.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<![INCLUDE[ ]]>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/064.xml b/collects/tests/xml/clark-tests/not-wf/sa/064.xml
new file mode 100644
index 0000000000..3888c46b8b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/064.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST e a1 CDATA"foo">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/065.xml b/collects/tests/xml/clark-tests/not-wf/sa/065.xml
new file mode 100644
index 0000000000..da9cafd137
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/065.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1(foo|bar) #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/066.xml b/collects/tests/xml/clark-tests/not-wf/sa/066.xml
new file mode 100644
index 0000000000..9c09eb4e5d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/066.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 (foo|bar)#IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/067.xml b/collects/tests/xml/clark-tests/not-wf/sa/067.xml
new file mode 100644
index 0000000000..7e0809bd34
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/067.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 (foo)"foo">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/068.xml b/collects/tests/xml/clark-tests/not-wf/sa/068.xml
new file mode 100644
index 0000000000..53a80a83a8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/068.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 NOTATION(foo) #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/069.xml b/collects/tests/xml/clark-tests/not-wf/sa/069.xml
new file mode 100644
index 0000000000..6f891dd5e1
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/069.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!NOTATION eps SYSTEM "eps.exe">
+<!-- missing space before NDATA -->
+<!ENTITY foo SYSTEM "foo.eps"NDATA eps>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/070.xml b/collects/tests/xml/clark-tests/not-wf/sa/070.xml
new file mode 100644
index 0000000000..faf4b0ae4c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/070.xml
@@ -0,0 +1,2 @@
+<!-- a comment ending with three dashes --->
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/071.xml b/collects/tests/xml/clark-tests/not-wf/sa/071.xml
new file mode 100644
index 0000000000..5bd3908968
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/071.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ENTITY e1 "&e2;">
+<!ENTITY e2 "&e3;">
+<!ENTITY e3 "&e1;">
+]>
+<doc>&e1;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/072.xml b/collects/tests/xml/clark-tests/not-wf/sa/072.xml
new file mode 100644
index 0000000000..743ba79429
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/072.xml
@@ -0,0 +1 @@
+<doc>&foo;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/073.xml b/collects/tests/xml/clark-tests/not-wf/sa/073.xml
new file mode 100644
index 0000000000..2578af42ec
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/073.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "whatever">
+]>
+<doc>&f;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/074.xml b/collects/tests/xml/clark-tests/not-wf/sa/074.xml
new file mode 100644
index 0000000000..f8abaeb22c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/074.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ENTITY e "</foo><foo>">
+]>
+<doc>
+<foo>&e;</foo>
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/075.xml b/collects/tests/xml/clark-tests/not-wf/sa/075.xml
new file mode 100644
index 0000000000..d3dbf50ed6
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/075.xml
@@ -0,0 +1,7 @@
+<!DOCTYPE doc [
+<!ENTITY e1 "&e2;">
+<!ENTITY e2 "&e3;">
+<!ENTITY e3 "&e1;">
+]>
+<doc a="&e1;"></doc>
+
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/076.xml b/collects/tests/xml/clark-tests/not-wf/sa/076.xml
new file mode 100644
index 0000000000..60546720e7
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/076.xml
@@ -0,0 +1 @@
+<doc a="&foo;"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/077.xml b/collects/tests/xml/clark-tests/not-wf/sa/077.xml
new file mode 100644
index 0000000000..f8ac23a5a2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/077.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY foo "&bar;">
+]>
+<doc a="&foo;"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/078.xml b/collects/tests/xml/clark-tests/not-wf/sa/078.xml
new file mode 100644
index 0000000000..446cd85ef9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/078.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA "&foo;">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/079.xml b/collects/tests/xml/clark-tests/not-wf/sa/079.xml
new file mode 100644
index 0000000000..da016fd3b2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/079.xml
@@ -0,0 +1,8 @@
+<!DOCTYPE doc [
+<!ENTITY e1 "&e2;">
+<!ENTITY e2 "&e3;">
+<!ENTITY e3 "&e1;">
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA "&e1;">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/080.xml b/collects/tests/xml/clark-tests/not-wf/sa/080.xml
new file mode 100644
index 0000000000..fa4b9e428d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/080.xml
@@ -0,0 +1,8 @@
+<!DOCTYPE doc [
+<!ENTITY e1 "&e2;">
+<!ENTITY e2 "&e3;">
+<!ENTITY e3 "&e1;">
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #FIXED "&e1;">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/081.xml b/collects/tests/xml/clark-tests/not-wf/sa/081.xml
new file mode 100644
index 0000000000..d676100e8a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/081.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e SYSTEM "nul">
+]>
+<doc a="&e;"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/082.xml b/collects/tests/xml/clark-tests/not-wf/sa/082.xml
new file mode 100644
index 0000000000..3217d6f8b4
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/082.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ENTITY e SYSTEM "nul">
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA "&e;">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/083.xml b/collects/tests/xml/clark-tests/not-wf/sa/083.xml
new file mode 100644
index 0000000000..469d43fd42
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/083.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e SYSTEM "nul" NDATA n>
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/084.xml b/collects/tests/xml/clark-tests/not-wf/sa/084.xml
new file mode 100644
index 0000000000..abbbcdea69
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/084.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ENTITY e SYSTEM "nul" NDATA n>
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA "&e;">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/085.xml b/collects/tests/xml/clark-tests/not-wf/sa/085.xml
new file mode 100644
index 0000000000..ac0aeca3e4
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/085.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc PUBLIC "[" "null.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/086.xml b/collects/tests/xml/clark-tests/not-wf/sa/086.xml
new file mode 100644
index 0000000000..df6adfd884
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/086.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY foo PUBLIC "[" "null.xml">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/087.xml b/collects/tests/xml/clark-tests/not-wf/sa/087.xml
new file mode 100644
index 0000000000..ed49492a7a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/087.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!NOTATION foo PUBLIC "[" "null.ent">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/088.xml b/collects/tests/xml/clark-tests/not-wf/sa/088.xml
new file mode 100644
index 0000000000..da0a68c401
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/088.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #IMPLIED>
+<!ENTITY e '"'>
+]>
+<doc a="&e;></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/089.xml b/collects/tests/xml/clark-tests/not-wf/sa/089.xml
new file mode 100644
index 0000000000..0c6cf404c2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/089.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY % foo SYSTEM "foo.xml" NDATA bar>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/090.xml b/collects/tests/xml/clark-tests/not-wf/sa/090.xml
new file mode 100644
index 0000000000..3fb72f3cc0
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/090.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "<foo a='&#60;'></foo>">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/091.xml b/collects/tests/xml/clark-tests/not-wf/sa/091.xml
new file mode 100644
index 0000000000..a61d0914f8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/091.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!NOTATION n SYSTEM "n">
+<!ENTITY % foo SYSTEM "foo.xml" NDATA n>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/092.xml b/collects/tests/xml/clark-tests/not-wf/sa/092.xml
new file mode 100644
index 0000000000..be5266dada
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/092.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "<foo a='&#38;'></foo>">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/093.xml b/collects/tests/xml/clark-tests/not-wf/sa/093.xml
new file mode 100644
index 0000000000..4af61bc645
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/093.xml
@@ -0,0 +1 @@
+<doc>&#X58;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/094.xml b/collects/tests/xml/clark-tests/not-wf/sa/094.xml
new file mode 100644
index 0000000000..bdec7a4660
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/094.xml
@@ -0,0 +1,2 @@
+<?xml VERSION="1.0"?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/095.xml b/collects/tests/xml/clark-tests/not-wf/sa/095.xml
new file mode 100644
index 0000000000..090b8b4eec
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/095.xml
@@ -0,0 +1,2 @@
+<?xml encoding="UTF-8" version="1.0"?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/096.xml b/collects/tests/xml/clark-tests/not-wf/sa/096.xml
new file mode 100644
index 0000000000..d806c3b952
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/096.xml
@@ -0,0 +1,2 @@
+<?xml version="1.0"encoding="UTF-8" ?>
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/097.xml b/collects/tests/xml/clark-tests/not-wf/sa/097.xml
new file mode 100644
index 0000000000..d4def544b0
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/097.xml
@@ -0,0 +1,2 @@
+<?xml version="1.0' encoding="UTF-8" ?>
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/098.xml b/collects/tests/xml/clark-tests/not-wf/sa/098.xml
new file mode 100644
index 0000000000..9798496aa3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/098.xml
@@ -0,0 +1,2 @@
+<?xml version="1.0" version="1.0"?>
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/099.xml b/collects/tests/xml/clark-tests/not-wf/sa/099.xml
new file mode 100644
index 0000000000..d5be08eff0
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/099.xml
@@ -0,0 +1,2 @@
+<?xml version="1.0" valid="no" ?>
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/100.xml b/collects/tests/xml/clark-tests/not-wf/sa/100.xml
new file mode 100644
index 0000000000..51e06231c2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/100.xml
@@ -0,0 +1,2 @@
+<?xml version="1.0" standalone="YES" ?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/101.xml b/collects/tests/xml/clark-tests/not-wf/sa/101.xml
new file mode 100644
index 0000000000..afa5a455fc
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/101.xml
@@ -0,0 +1,2 @@
+<?xml version="1.0" encoding=" UTF-8"?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/102.xml b/collects/tests/xml/clark-tests/not-wf/sa/102.xml
new file mode 100644
index 0000000000..8734adaa6e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/102.xml
@@ -0,0 +1,2 @@
+<?xml version="1.0 " ?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/103.xml b/collects/tests/xml/clark-tests/not-wf/sa/103.xml
new file mode 100644
index 0000000000..6c4716798f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/103.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "&#60;foo>">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/104.xml b/collects/tests/xml/clark-tests/not-wf/sa/104.xml
new file mode 100644
index 0000000000..dd57396239
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/104.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "<foo>">
+]>
+<doc>&e;</foo></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/105.xml b/collects/tests/xml/clark-tests/not-wf/sa/105.xml
new file mode 100644
index 0000000000..809e705870
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/105.xml
@@ -0,0 +1,4 @@
+<?pi stuff?>
+<![CDATA[]]>
+<doc>
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/106.xml b/collects/tests/xml/clark-tests/not-wf/sa/106.xml
new file mode 100644
index 0000000000..d32319ef09
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/106.xml
@@ -0,0 +1,2 @@
+<?pi data?>
+&#32;<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/107.xml b/collects/tests/xml/clark-tests/not-wf/sa/107.xml
new file mode 100644
index 0000000000..3dfd8200e2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/107.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<![CDATA[]]>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/108.xml b/collects/tests/xml/clark-tests/not-wf/sa/108.xml
new file mode 100644
index 0000000000..af5cf50d48
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/108.xml
@@ -0,0 +1,3 @@
+<doc>
+<![CDATA [  ]]>
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/109.xml b/collects/tests/xml/clark-tests/not-wf/sa/109.xml
new file mode 100644
index 0000000000..5afc03e8db
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/109.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "<doc></doc>">
+]>
+&e;
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/110.xml b/collects/tests/xml/clark-tests/not-wf/sa/110.xml
new file mode 100644
index 0000000000..cf54ebe5c0
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/110.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY e "">
+]>
+<doc></doc>
+&e;
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/111.xml b/collects/tests/xml/clark-tests/not-wf/sa/111.xml
new file mode 100644
index 0000000000..84a469f5d1
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/111.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "foo='bar'">
+]>
+<doc &e;></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/112.xml b/collects/tests/xml/clark-tests/not-wf/sa/112.xml
new file mode 100644
index 0000000000..0c5c1a4341
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/112.xml
@@ -0,0 +1,3 @@
+<doc>
+<![cdata[data]]>
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/113.xml b/collects/tests/xml/clark-tests/not-wf/sa/113.xml
new file mode 100644
index 0000000000..04fc9d2318
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/113.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY % foo "&">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/114.xml b/collects/tests/xml/clark-tests/not-wf/sa/114.xml
new file mode 100644
index 0000000000..1261ee49e1
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/114.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY foo "&">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/115.xml b/collects/tests/xml/clark-tests/not-wf/sa/115.xml
new file mode 100644
index 0000000000..f111dbe153
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/115.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "&#38;">
+]>
+<doc a="&e;"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/116.xml b/collects/tests/xml/clark-tests/not-wf/sa/116.xml
new file mode 100644
index 0000000000..84bb762fdf
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/116.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "&#38;#9">
+]>
+<doc>&e;7;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/117.xml b/collects/tests/xml/clark-tests/not-wf/sa/117.xml
new file mode 100644
index 0000000000..e4a5e572ef
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/117.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "&#38;">
+]>
+<doc>&e;#97;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/118.xml b/collects/tests/xml/clark-tests/not-wf/sa/118.xml
new file mode 100644
index 0000000000..494d53d208
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/118.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "#">
+]>
+<doc>&&e;97;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/119.xml b/collects/tests/xml/clark-tests/not-wf/sa/119.xml
new file mode 100644
index 0000000000..aefaa44a1c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/119.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ENTITY e "&#38;">
+]>
+<doc>
+&e;#38;
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/120.xml b/collects/tests/xml/clark-tests/not-wf/sa/120.xml
new file mode 100644
index 0000000000..b7d6ff9ce9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/120.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ENTITY e "&#38;">
+]>
+<doc>
+&e;
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/121.xml b/collects/tests/xml/clark-tests/not-wf/sa/121.xml
new file mode 100644
index 0000000000..2b4adcc6b4
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/121.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY #DEFAULT "default">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/122.xml b/collects/tests/xml/clark-tests/not-wf/sa/122.xml
new file mode 100644
index 0000000000..ef0b057cee
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/122.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (a, (b) | c)?>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/123.xml b/collects/tests/xml/clark-tests/not-wf/sa/123.xml
new file mode 100644
index 0000000000..06d65f045b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/123.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc ((doc?)))>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/124.xml b/collects/tests/xml/clark-tests/not-wf/sa/124.xml
new file mode 100644
index 0000000000..3bbe0f91a6
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/124.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (doc|#PCDATA)*>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/125.xml b/collects/tests/xml/clark-tests/not-wf/sa/125.xml
new file mode 100644
index 0000000000..5f9c22c0c6
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/125.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc ((#PCDATA))>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/126.xml b/collects/tests/xml/clark-tests/not-wf/sa/126.xml
new file mode 100644
index 0000000000..13e74d6d5e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/126.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)+>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/127.xml b/collects/tests/xml/clark-tests/not-wf/sa/127.xml
new file mode 100644
index 0000000000..a379b9e539
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/127.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)?>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/128.xml b/collects/tests/xml/clark-tests/not-wf/sa/128.xml
new file mode 100644
index 0000000000..dd706bb21f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/128.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc CDATA>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/129.xml b/collects/tests/xml/clark-tests/not-wf/sa/129.xml
new file mode 100644
index 0000000000..d4e4461a6d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/129.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc - - (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/130.xml b/collects/tests/xml/clark-tests/not-wf/sa/130.xml
new file mode 100644
index 0000000000..fa7be641f1
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/130.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (doc?) +(foo)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/131.xml b/collects/tests/xml/clark-tests/not-wf/sa/131.xml
new file mode 100644
index 0000000000..f34ed453b5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/131.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (doc?) -(foo)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/132.xml b/collects/tests/xml/clark-tests/not-wf/sa/132.xml
new file mode 100644
index 0000000000..ab6cc416e9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/132.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (a, (b, c), (d, (e, f) | g))?>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/133.xml b/collects/tests/xml/clark-tests/not-wf/sa/133.xml
new file mode 100644
index 0000000000..d2aa604e9f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/133.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (a *)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/134.xml b/collects/tests/xml/clark-tests/not-wf/sa/134.xml
new file mode 100644
index 0000000000..c8919c5ef8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/134.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (a) *>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/135.xml b/collects/tests/xml/clark-tests/not-wf/sa/135.xml
new file mode 100644
index 0000000000..e639e8b6ea
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/135.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (a & b)?>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/136.xml b/collects/tests/xml/clark-tests/not-wf/sa/136.xml
new file mode 100644
index 0000000000..499e68bcea
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/136.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc O O (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/137.xml b/collects/tests/xml/clark-tests/not-wf/sa/137.xml
new file mode 100644
index 0000000000..723b77f776
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/137.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc(#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/138.xml b/collects/tests/xml/clark-tests/not-wf/sa/138.xml
new file mode 100644
index 0000000000..16934cc88e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/138.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (doc*?)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/139.xml b/collects/tests/xml/clark-tests/not-wf/sa/139.xml
new file mode 100644
index 0000000000..34df52ed93
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/139.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc ()>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/140.xml b/collects/tests/xml/clark-tests/not-wf/sa/140.xml
new file mode 100644
index 0000000000..467d5ed301
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/140.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "<&#x309a;></&#x309a;>">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/141.xml b/collects/tests/xml/clark-tests/not-wf/sa/141.xml
new file mode 100644
index 0000000000..409d0a7568
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/141.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "<X&#xe5c;></X&#xe5c;>">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/142.xml b/collects/tests/xml/clark-tests/not-wf/sa/142.xml
new file mode 100644
index 0000000000..20e88f88b3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/142.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#0;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/143.xml b/collects/tests/xml/clark-tests/not-wf/sa/143.xml
new file mode 100644
index 0000000000..0ee1c614f8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/143.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#31;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/144.xml b/collects/tests/xml/clark-tests/not-wf/sa/144.xml
new file mode 100644
index 0000000000..437548c0ba
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/144.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#xFFFF;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/145.xml b/collects/tests/xml/clark-tests/not-wf/sa/145.xml
new file mode 100644
index 0000000000..71b187a933
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/145.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#xD800;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/146.xml b/collects/tests/xml/clark-tests/not-wf/sa/146.xml
new file mode 100644
index 0000000000..d0bfbca723
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/146.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#x110000;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/147.xml b/collects/tests/xml/clark-tests/not-wf/sa/147.xml
new file mode 100644
index 0000000000..3b6145615f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/147.xml
@@ -0,0 +1,3 @@
+
+<?xml version="1.0"?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/148.xml b/collects/tests/xml/clark-tests/not-wf/sa/148.xml
new file mode 100644
index 0000000000..774dce18fd
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/148.xml
@@ -0,0 +1,3 @@
+<!-- -->
+<?xml version="1.0"?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/149.xml b/collects/tests/xml/clark-tests/not-wf/sa/149.xml
new file mode 100644
index 0000000000..725eea0dec
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/149.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<?xml version="1.0"?>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/150.xml b/collects/tests/xml/clark-tests/not-wf/sa/150.xml
new file mode 100644
index 0000000000..44f6b6df92
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/150.xml
@@ -0,0 +1,3 @@
+<doc>
+<?xml version="1.0"?>
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/151.xml b/collects/tests/xml/clark-tests/not-wf/sa/151.xml
new file mode 100644
index 0000000000..fecc4f24e3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/151.xml
@@ -0,0 +1,3 @@
+<doc>
+</doc>
+<?xml version="1.0"?>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/152.xml b/collects/tests/xml/clark-tests/not-wf/sa/152.xml
new file mode 100644
index 0000000000..b5c5cb26ae
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/152.xml
@@ -0,0 +1,2 @@
+<?xml encoding="UTF-8"?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/153.xml b/collects/tests/xml/clark-tests/not-wf/sa/153.xml
new file mode 100644
index 0000000000..5e2973707e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/153.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e "<?xml encoding='UTF-8'?>">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/154.xml b/collects/tests/xml/clark-tests/not-wf/sa/154.xml
new file mode 100644
index 0000000000..96e01d63f5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/154.xml
@@ -0,0 +1,2 @@
+<?XML version="1.0"?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/155.xml b/collects/tests/xml/clark-tests/not-wf/sa/155.xml
new file mode 100644
index 0000000000..4f16d0f163
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/155.xml
@@ -0,0 +1,2 @@
+<?xmL version="1.0"?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/156.xml b/collects/tests/xml/clark-tests/not-wf/sa/156.xml
new file mode 100644
index 0000000000..c6d93fd312
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/156.xml
@@ -0,0 +1,3 @@
+<doc>
+<?xMl version="1.0"?>
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/157.xml b/collects/tests/xml/clark-tests/not-wf/sa/157.xml
new file mode 100644
index 0000000000..2f058dac3e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/157.xml
@@ -0,0 +1,3 @@
+<doc>
+<?xmL?>
+</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/158.xml b/collects/tests/xml/clark-tests/not-wf/sa/158.xml
new file mode 100644
index 0000000000..32b90b722d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/158.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!NOTATION gif PUBLIC "image/gif" "">
+<!ATTLIST #NOTATION gif a1 CDATA #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/159.xml b/collects/tests/xml/clark-tests/not-wf/sa/159.xml
new file mode 100644
index 0000000000..066244cb91
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/159.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e "<![CDATA[Tim & Michael]]>">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/160.xml b/collects/tests/xml/clark-tests/not-wf/sa/160.xml
new file mode 100644
index 0000000000..85424acb1b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/160.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e "">
+<!ENTITY foo "%e;">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/161.xml b/collects/tests/xml/clark-tests/not-wf/sa/161.xml
new file mode 100644
index 0000000000..4f8a5b7b6b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/161.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY % e "#PCDATA">
+<!ELEMENT doc (%e;)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/162.xml b/collects/tests/xml/clark-tests/not-wf/sa/162.xml
new file mode 100644
index 0000000000..efae4b190e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/162.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e1 "">
+<!ENTITY % e2 "%e1;">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/163.xml b/collects/tests/xml/clark-tests/not-wf/sa/163.xml
new file mode 100644
index 0000000000..e14fb76c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/163.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e "">
+]>
+%e;
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/164.xml b/collects/tests/xml/clark-tests/not-wf/sa/164.xml
new file mode 100644
index 0000000000..98dd267c21
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/164.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e "">
+] %e; >
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/165.xml b/collects/tests/xml/clark-tests/not-wf/sa/165.xml
new file mode 100644
index 0000000000..36c04618ef
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/165.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY% e "">
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/166.xml b/collects/tests/xml/clark-tests/not-wf/sa/166.xml
new file mode 100644
index 0000000000..ee2ce28630
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/166.xml
@@ -0,0 +1 @@
+<doc>￿</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/167.xml b/collects/tests/xml/clark-tests/not-wf/sa/167.xml
new file mode 100644
index 0000000000..9bdc6c1278
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/167.xml
@@ -0,0 +1 @@
+<doc>￾</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/168.xml b/collects/tests/xml/clark-tests/not-wf/sa/168.xml
new file mode 100644
index 0000000000..f83221a3ad
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/168.xml
@@ -0,0 +1 @@
+<doc>���</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/169.xml b/collects/tests/xml/clark-tests/not-wf/sa/169.xml
new file mode 100644
index 0000000000..310029b976
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/169.xml
@@ -0,0 +1 @@
+<doc>���</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/170.xml b/collects/tests/xml/clark-tests/not-wf/sa/170.xml
new file mode 100644
index 0000000000..cfa0aee155
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/170.xml
@@ -0,0 +1 @@
+<doc>����</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/171.xml b/collects/tests/xml/clark-tests/not-wf/sa/171.xml
new file mode 100644
index 0000000000..48b5c7d3bc
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/171.xml
@@ -0,0 +1,2 @@
+<!-- ￿ -->
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/172.xml b/collects/tests/xml/clark-tests/not-wf/sa/172.xml
new file mode 100644
index 0000000000..6651d4d299
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/172.xml
@@ -0,0 +1,2 @@
+<?pi ￿?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/173.xml b/collects/tests/xml/clark-tests/not-wf/sa/173.xml
new file mode 100644
index 0000000000..f9f9f42023
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/173.xml
@@ -0,0 +1 @@
+<doc a="￿"></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/174.xml b/collects/tests/xml/clark-tests/not-wf/sa/174.xml
new file mode 100644
index 0000000000..42bef861c6
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/174.xml
@@ -0,0 +1 @@
+<doc><![CDATA[￿]]></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/175.xml b/collects/tests/xml/clark-tests/not-wf/sa/175.xml
new file mode 100644
index 0000000000..69912f36d2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/175.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e "￿">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/176.xml b/collects/tests/xml/clark-tests/not-wf/sa/176.xml
new file mode 100644
index 0000000000..39153ad5a8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/176.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/177.xml b/collects/tests/xml/clark-tests/not-wf/sa/177.xml
new file mode 100644
index 0000000000..6bc8228879
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/177.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>A￿</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/178.xml b/collects/tests/xml/clark-tests/not-wf/sa/178.xml
new file mode 100644
index 0000000000..e8f2d18eed
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/178.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #IMPLIED>
+]>
+<doc a="&#34;></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/179.xml b/collects/tests/xml/clark-tests/not-wf/sa/179.xml
new file mode 100644
index 0000000000..e8f1f419db
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/179.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ENTITY e "&#34;>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/180.xml b/collects/tests/xml/clark-tests/not-wf/sa/180.xml
new file mode 100644
index 0000000000..569d553a8c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/180.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA "&e;">
+<!ENTITY e "v">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/181.xml b/collects/tests/xml/clark-tests/not-wf/sa/181.xml
new file mode 100644
index 0000000000..4341d99ee2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/181.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY e "&#60;![CDATA[">
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&e;]]></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/182.xml b/collects/tests/xml/clark-tests/not-wf/sa/182.xml
new file mode 100644
index 0000000000..920f431666
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/182.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY e "&#60;!--">
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&e;--></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/183.xml b/collects/tests/xml/clark-tests/not-wf/sa/183.xml
new file mode 100644
index 0000000000..7a5677de54
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/183.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA | foo*)* >
+<!ELEMENT foo EMPTY>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/184.xml b/collects/tests/xml/clark-tests/not-wf/sa/184.xml
new file mode 100644
index 0000000000..103384a06e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/184.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA | (foo))* >
+<!ELEMENT foo EMPTY>
+]>
+<doc></doc>
+
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/185.ent b/collects/tests/xml/clark-tests/not-wf/sa/185.ent
new file mode 100644
index 0000000000..e557426454
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/185.ent
@@ -0,0 +1 @@
+<!ELEMENT doc (#PCDATA)>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/185.xml b/collects/tests/xml/clark-tests/not-wf/sa/185.xml
new file mode 100644
index 0000000000..81d5ef4bcd
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/185.xml
@@ -0,0 +1,3 @@
+<?xml version="1.0" standalone="yes"?>
+<!DOCTYPE doc SYSTEM "185.ent">
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/186.xml b/collects/tests/xml/clark-tests/not-wf/sa/186.xml
new file mode 100644
index 0000000000..85b26ec0a2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/not-wf/sa/186.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE a [
+<!ELEMENT a EMPTY>
+<!ATTLIST a b CDATA #IMPLIED d CDATA #IMPLIED>
+]>
+<a b="c"d="e"/>
diff --git a/collects/tests/xml/clark-tests/not-wf/sa/null.ent b/collects/tests/xml/clark-tests/not-wf/sa/null.ent
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/collects/tests/xml/clark-tests/readme.html b/collects/tests/xml/clark-tests/readme.html
new file mode 100644
index 0000000000..fc7310c68e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/readme.html
@@ -0,0 +1,60 @@
+<HTML>
+<TITLE>XML Test Cases</TITLE>
+<BODY>
+<H1>XML Test Cases version 1998-11-18</H1>
+<P>
+Copyright (C) 1998 James Clark.  All rights reserved.  Permission is
+granted to copy and modify this collection in any way for internal use
+within a company or organization.  Permission is granted to
+redistribute the file <code>xmltest.zip</code> containing this
+collection to third parties provided that no modifications of any kind
+are made to this file.  Note that permission to distribute the
+collection in any other form is not granted.
+<P>
+The collection is structured into three directories:
+<DL>
+<DT><CODE>not-wf</CODE>
+<DD>this contains cases that are not well-formed XML documents
+<DT><CODE>valid</CODE>
+<DD>this contains cases that are valid XML documents
+<DT><CODE>invalid</CODE>
+<DD>this contains cases that are well-formed XML documents
+but are not valid XML documents
+</DL>
+<P>
+The <CODE>not-wf</CODE> and <CODE>valid</CODE> directories each have
+three subdirectories:
+<DL>
+<DT>
+<CODE>sa</CODE>
+<DD>
+this contains cases that are standalone (as defined in XML) and do not
+have references to external general entities
+<DT>
+<CODE>ext-sa</CODE>
+<DD>
+this contains case that are standalone and have references to external
+general entities
+<DT>
+<CODE>not-sa</CODE>
+<DD>
+this contains cases that are not standalone
+</DL>
+<P>
+In each directory, files with a <CODE>.xml</CODE> extension are the
+XML document test cases, and files with a <CODE>.ent</CODE> extension
+are external entities referenced by the test cases.
+<P>
+Within the <CODE>valid</CODE> directory, each of these three
+subdirectories has an <CODE>out</CODE> subdirectory which contains an
+equivalent <A HREF="canonxml.html">canonical XML</A> document for each
+of the cases.
+<P>
+<P>
+Bug reports and contributions of new test cases are welcome.
+<P>
+<ADDRESS>
+<A HREF="mailto:jjc@jclark.com">James Clark</A>
+</ADDRESS>
+</BODY>
+</HTML>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/001.ent b/collects/tests/xml/clark-tests/valid/ext-sa/001.ent
new file mode 100644
index 0000000000..1cff3fd44f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/001.ent
@@ -0,0 +1 @@
+Data
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/001.xml b/collects/tests/xml/clark-tests/valid/ext-sa/001.xml
new file mode 100644
index 0000000000..147d70d2d1
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/001.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e SYSTEM "001.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/002.ent b/collects/tests/xml/clark-tests/valid/ext-sa/002.ent
new file mode 100644
index 0000000000..45f6d8e74e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/002.ent
@@ -0,0 +1 @@
+Data
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/002.xml b/collects/tests/xml/clark-tests/valid/ext-sa/002.xml
new file mode 100644
index 0000000000..9eaf91724f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/002.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e SYSTEM "002.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/003.ent b/collects/tests/xml/clark-tests/valid/ext-sa/003.ent
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/003.xml b/collects/tests/xml/clark-tests/valid/ext-sa/003.xml
new file mode 100644
index 0000000000..bb60b663ef
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/003.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e SYSTEM "003.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/004.ent b/collects/tests/xml/clark-tests/valid/ext-sa/004.ent
new file mode 100644
index 0000000000..3436f20001
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/004.ent
@@ -0,0 +1 @@
+Data
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/004.xml b/collects/tests/xml/clark-tests/valid/ext-sa/004.xml
new file mode 100644
index 0000000000..074498ce19
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/004.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e SYSTEM "004.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/005.ent b/collects/tests/xml/clark-tests/valid/ext-sa/005.ent
new file mode 100644
index 0000000000..c6e97f821f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/005.ent
@@ -0,0 +1 @@
+<e/><e/><e/>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/005.xml b/collects/tests/xml/clark-tests/valid/ext-sa/005.xml
new file mode 100644
index 0000000000..82a6228205
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/005.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (e*)>
+<!ELEMENT e EMPTY>
+<!ENTITY e SYSTEM "005.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/006.ent b/collects/tests/xml/clark-tests/valid/ext-sa/006.ent
new file mode 100644
index 0000000000..4df2f0c2ac
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/006.ent
@@ -0,0 +1,4 @@
+Data
+<e/>
+More data
+<e/>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/006.xml b/collects/tests/xml/clark-tests/valid/ext-sa/006.xml
new file mode 100644
index 0000000000..0b326cad4c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/006.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA|e)*>
+<!ELEMENT e EMPTY>
+<!ENTITY e SYSTEM "006.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/007.ent b/collects/tests/xml/clark-tests/valid/ext-sa/007.ent
new file mode 100644
index 0000000000..ab1d696dd7
Binary files /dev/null and b/collects/tests/xml/clark-tests/valid/ext-sa/007.ent differ
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/007.xml b/collects/tests/xml/clark-tests/valid/ext-sa/007.xml
new file mode 100644
index 0000000000..825e3b286a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/007.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e SYSTEM "007.ent">
+]>
+<doc>X&e;Z</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/008.ent b/collects/tests/xml/clark-tests/valid/ext-sa/008.ent
new file mode 100644
index 0000000000..c6ca61f9c8
Binary files /dev/null and b/collects/tests/xml/clark-tests/valid/ext-sa/008.ent differ
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/008.xml b/collects/tests/xml/clark-tests/valid/ext-sa/008.xml
new file mode 100644
index 0000000000..3c001b6cb3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/008.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e SYSTEM "008.ent">
+]>
+<doc>X&e;Z</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/009.ent b/collects/tests/xml/clark-tests/valid/ext-sa/009.ent
new file mode 100644
index 0000000000..67c3297611
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/009.ent
@@ -0,0 +1 @@
+
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/009.xml b/collects/tests/xml/clark-tests/valid/ext-sa/009.xml
new file mode 100644
index 0000000000..a5866e5a77
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/009.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e SYSTEM "009.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/010.ent b/collects/tests/xml/clark-tests/valid/ext-sa/010.ent
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/010.xml b/collects/tests/xml/clark-tests/valid/ext-sa/010.xml
new file mode 100644
index 0000000000..418e9b0141
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/010.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e SYSTEM "010.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/011.ent b/collects/tests/xml/clark-tests/valid/ext-sa/011.ent
new file mode 100644
index 0000000000..b19be3a497
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/011.ent
@@ -0,0 +1 @@
+xyzzy
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/011.xml b/collects/tests/xml/clark-tests/valid/ext-sa/011.xml
new file mode 100644
index 0000000000..2ceefa1d21
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/011.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e PUBLIC "a not very interesting file" "011.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/012.ent b/collects/tests/xml/clark-tests/valid/ext-sa/012.ent
new file mode 100644
index 0000000000..8eb1fb9c41
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/012.ent
@@ -0,0 +1 @@
+&e4;
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/012.xml b/collects/tests/xml/clark-tests/valid/ext-sa/012.xml
new file mode 100644
index 0000000000..5a8f009b4a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/012.xml
@@ -0,0 +1,9 @@
+<!DOCTYPE doc [
+<!ENTITY e1 "&e2;">
+<!ENTITY e2 "&e3;">
+<!ENTITY e3 SYSTEM "012.ent">
+<!ENTITY e4 "&e5;">
+<!ENTITY e5 "(e5)">
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&e1;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/013.ent b/collects/tests/xml/clark-tests/valid/ext-sa/013.ent
new file mode 100644
index 0000000000..7f25c502dd
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/013.ent
@@ -0,0 +1 @@
+<e/>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/013.xml b/collects/tests/xml/clark-tests/valid/ext-sa/013.xml
new file mode 100644
index 0000000000..7717c97afe
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/013.xml
@@ -0,0 +1,10 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (e)>
+<!ELEMENT e (#PCDATA)>
+<!ATTLIST e
+  a1 CDATA "a1 default"
+  a2 NMTOKENS "a2 default"
+>
+<!ENTITY x SYSTEM "013.ent">
+]>
+<doc>&x;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/014.ent b/collects/tests/xml/clark-tests/valid/ext-sa/014.ent
new file mode 100644
index 0000000000..470fd6fe44
Binary files /dev/null and b/collects/tests/xml/clark-tests/valid/ext-sa/014.ent differ
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/014.xml b/collects/tests/xml/clark-tests/valid/ext-sa/014.xml
new file mode 100644
index 0000000000..816fd1e796
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/014.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e SYSTEM "014.ent">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/001.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/001.xml
new file mode 100644
index 0000000000..0a7acf8ebe
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/001.xml
@@ -0,0 +1 @@
+<doc>Data&#10;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/002.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/002.xml
new file mode 100644
index 0000000000..d4a445e555
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/002.xml
@@ -0,0 +1 @@
+<doc>Data</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/003.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/003.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/003.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/004.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/004.xml
new file mode 100644
index 0000000000..0a7acf8ebe
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/004.xml
@@ -0,0 +1 @@
+<doc>Data&#10;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/005.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/005.xml
new file mode 100644
index 0000000000..6e293aa70e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/005.xml
@@ -0,0 +1 @@
+<doc><e></e><e></e><e></e></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/006.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/006.xml
new file mode 100644
index 0000000000..04b6fc82ee
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/006.xml
@@ -0,0 +1 @@
+<doc>Data&#10;<e></e>&#10;More data&#10;<e></e>&#10;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/007.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/007.xml
new file mode 100644
index 0000000000..ab2a74c9d1
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/007.xml
@@ -0,0 +1 @@
+<doc>XYZ</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/008.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/008.xml
new file mode 100644
index 0000000000..ab2a74c9d1
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/008.xml
@@ -0,0 +1 @@
+<doc>XYZ</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/009.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/009.xml
new file mode 100644
index 0000000000..a79dff65fd
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/009.xml
@@ -0,0 +1 @@
+<doc>&#10;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/010.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/010.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/010.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/011.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/011.xml
new file mode 100644
index 0000000000..bf275adb2b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/011.xml
@@ -0,0 +1 @@
+<doc>xyzzy&#10;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/012.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/012.xml
new file mode 100644
index 0000000000..81a251cb4b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/012.xml
@@ -0,0 +1 @@
+<doc>(e5)</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/013.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/013.xml
new file mode 100644
index 0000000000..524d94ee6b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/013.xml
@@ -0,0 +1 @@
+<doc><e a1="a1 default" a2="a2 default"></e></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/014.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/014.xml
new file mode 100644
index 0000000000..71c6dc3e8e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/014.xml
@@ -0,0 +1 @@
+<doc>data</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/001.ent b/collects/tests/xml/clark-tests/valid/not-sa/001.ent
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/001.xml b/collects/tests/xml/clark-tests/valid/not-sa/001.xml
new file mode 100644
index 0000000000..2d6f41a137
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/001.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc SYSTEM "001.ent" [
+<!ELEMENT doc EMPTY>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/002.ent b/collects/tests/xml/clark-tests/valid/not-sa/002.ent
new file mode 100644
index 0000000000..67c3297611
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/002.ent
@@ -0,0 +1 @@
+
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/002.xml b/collects/tests/xml/clark-tests/valid/not-sa/002.xml
new file mode 100644
index 0000000000..023fce8499
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/002.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc SYSTEM "002.ent" [
+<!ELEMENT doc EMPTY>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/003-1.ent b/collects/tests/xml/clark-tests/valid/not-sa/003-1.ent
new file mode 100644
index 0000000000..931f3ad6d8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/003-1.ent
@@ -0,0 +1,3 @@
+<!ELEMENT doc EMPTY>
+<!ENTITY % e SYSTEM "003-2.ent">
+<!ATTLIST doc a1 CDATA %e; "v1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/003-2.ent b/collects/tests/xml/clark-tests/valid/not-sa/003-2.ent
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/003.xml b/collects/tests/xml/clark-tests/valid/not-sa/003.xml
new file mode 100644
index 0000000000..63a5e8bdfc
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/003.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "003-1.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/004-1.ent b/collects/tests/xml/clark-tests/valid/not-sa/004-1.ent
new file mode 100644
index 0000000000..40f7ff58a2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/004-1.ent
@@ -0,0 +1,4 @@
+<!ELEMENT doc EMPTY>
+<!ENTITY % e1 SYSTEM "004-2.ent">
+<!ENTITY % e2 "%e1;">
+%e1;
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/004-2.ent b/collects/tests/xml/clark-tests/valid/not-sa/004-2.ent
new file mode 100644
index 0000000000..61def75cb7
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/004-2.ent
@@ -0,0 +1 @@
+<!ATTLIST doc a1 CDATA "value">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/004.xml b/collects/tests/xml/clark-tests/valid/not-sa/004.xml
new file mode 100644
index 0000000000..adc9201496
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/004.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "004-1.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/005-1.ent b/collects/tests/xml/clark-tests/valid/not-sa/005-1.ent
new file mode 100644
index 0000000000..ade9599032
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/005-1.ent
@@ -0,0 +1,3 @@
+<!ELEMENT doc EMPTY>
+<!ENTITY % e SYSTEM "005-2.ent">
+%e;
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/005-2.ent b/collects/tests/xml/clark-tests/valid/not-sa/005-2.ent
new file mode 100644
index 0000000000..bef50b1f38
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/005-2.ent
@@ -0,0 +1 @@
+<!ATTLIST doc a1 CDATA "v1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/005.xml b/collects/tests/xml/clark-tests/valid/not-sa/005.xml
new file mode 100644
index 0000000000..6bd44cfee0
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/005.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "005-1.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/006.ent b/collects/tests/xml/clark-tests/valid/not-sa/006.ent
new file mode 100644
index 0000000000..8f305a82bd
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/006.ent
@@ -0,0 +1,2 @@
+<!ELEMENT doc EMPTY>
+<!ATTLIST doc a1 CDATA "w1" a2 CDATA "w2">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/006.xml b/collects/tests/xml/clark-tests/valid/not-sa/006.xml
new file mode 100644
index 0000000000..eb80bb7409
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/006.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc SYSTEM "006.ent" [
+<!ATTLIST doc a1 CDATA "v1">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/007.ent b/collects/tests/xml/clark-tests/valid/not-sa/007.ent
new file mode 100644
index 0000000000..fbf4ca4947
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/007.ent
@@ -0,0 +1,2 @@
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA "v1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/007.xml b/collects/tests/xml/clark-tests/valid/not-sa/007.xml
new file mode 100644
index 0000000000..38897e34ea
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/007.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "007.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/008.ent b/collects/tests/xml/clark-tests/valid/not-sa/008.ent
new file mode 100644
index 0000000000..fbf4ca4947
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/008.ent
@@ -0,0 +1,2 @@
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA "v1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/008.xml b/collects/tests/xml/clark-tests/valid/not-sa/008.xml
new file mode 100644
index 0000000000..bf777a7ff2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/008.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc PUBLIC "whatever" "008.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/009.ent b/collects/tests/xml/clark-tests/valid/not-sa/009.ent
new file mode 100644
index 0000000000..fbf4ca4947
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/009.ent
@@ -0,0 +1,2 @@
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA "v1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/009.xml b/collects/tests/xml/clark-tests/valid/not-sa/009.xml
new file mode 100644
index 0000000000..c17562fe68
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/009.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc PUBLIC "whatever" "009.ent" [
+<!ATTLIST doc a2 CDATA "v2">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/010.ent b/collects/tests/xml/clark-tests/valid/not-sa/010.ent
new file mode 100644
index 0000000000..52a28f5deb
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/010.ent
@@ -0,0 +1,2 @@
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA "v2">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/010.xml b/collects/tests/xml/clark-tests/valid/not-sa/010.xml
new file mode 100644
index 0000000000..2786b328f3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/010.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc SYSTEM "010.ent" [
+<!ATTLIST doc a1 CDATA "v1">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/011.ent b/collects/tests/xml/clark-tests/valid/not-sa/011.ent
new file mode 100644
index 0000000000..fbf4ca4947
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/011.ent
@@ -0,0 +1,2 @@
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA "v1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/011.xml b/collects/tests/xml/clark-tests/valid/not-sa/011.xml
new file mode 100644
index 0000000000..03b482bbb6
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/011.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY % e SYSTEM "011.ent">
+%e;
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/012.ent b/collects/tests/xml/clark-tests/valid/not-sa/012.ent
new file mode 100644
index 0000000000..7e372e65e9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/012.ent
@@ -0,0 +1,3 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA "v1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/012.xml b/collects/tests/xml/clark-tests/valid/not-sa/012.xml
new file mode 100644
index 0000000000..1967edbba7
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/012.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY % e SYSTEM "012.ent">
+%e;
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/013.ent b/collects/tests/xml/clark-tests/valid/not-sa/013.ent
new file mode 100644
index 0000000000..a3691d9f08
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/013.ent
@@ -0,0 +1,4 @@
+<!ELEMENT doc (#PCDATA)>
+<![ INCLUDE [
+<!ATTLIST doc a1 CDATA "v1">
+]]>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/013.xml b/collects/tests/xml/clark-tests/valid/not-sa/013.xml
new file mode 100644
index 0000000000..cf44f2600a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/013.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "013.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/014.ent b/collects/tests/xml/clark-tests/valid/not-sa/014.ent
new file mode 100644
index 0000000000..6eaf779329
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/014.ent
@@ -0,0 +1,4 @@
+<!ELEMENT doc (#PCDATA)>
+<![ %e; [
+<!ATTLIST doc a1 CDATA "v1">
+]]>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/014.xml b/collects/tests/xml/clark-tests/valid/not-sa/014.xml
new file mode 100644
index 0000000000..bd08502489
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/014.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc SYSTEM "014.ent" [
+<!ENTITY % e "INCLUDE">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/015.ent b/collects/tests/xml/clark-tests/valid/not-sa/015.ent
new file mode 100644
index 0000000000..00d2f30e1d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/015.ent
@@ -0,0 +1,5 @@
+<!ELEMENT doc (#PCDATA)>
+<![ %e; [
+<!ATTLIST doc a1 CDATA "v1">
+]]>
+<!ATTLIST doc a2 CDATA "v2">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/015.xml b/collects/tests/xml/clark-tests/valid/not-sa/015.xml
new file mode 100644
index 0000000000..e04e75ffca
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/015.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc SYSTEM "015.ent" [
+<!ENTITY % e "IGNORE">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/016.ent b/collects/tests/xml/clark-tests/valid/not-sa/016.ent
new file mode 100644
index 0000000000..bf77ef8336
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/016.ent
@@ -0,0 +1,4 @@
+<!ELEMENT doc (#PCDATA)>
+<![%e;[
+<!ATTLIST doc a1 CDATA "v1">
+]]>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/016.xml b/collects/tests/xml/clark-tests/valid/not-sa/016.xml
new file mode 100644
index 0000000000..4ccf4af350
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/016.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc SYSTEM "016.ent" [
+<!ENTITY % e "INCLUDE">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/017.ent b/collects/tests/xml/clark-tests/valid/not-sa/017.ent
new file mode 100644
index 0000000000..ffd9adde61
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/017.ent
@@ -0,0 +1,3 @@
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e "<!ATTLIST doc a1 CDATA 'v1'>">
+%e;
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/017.xml b/collects/tests/xml/clark-tests/valid/not-sa/017.xml
new file mode 100644
index 0000000000..7fe18f4c7a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/017.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "017.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/018.ent b/collects/tests/xml/clark-tests/valid/not-sa/018.ent
new file mode 100644
index 0000000000..2d46f76fc3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/018.ent
@@ -0,0 +1,3 @@
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e "'v1'">
+<!ATTLIST doc a1 CDATA %e;>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/018.xml b/collects/tests/xml/clark-tests/valid/not-sa/018.xml
new file mode 100644
index 0000000000..31e90f2405
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/018.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "018.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/019.ent b/collects/tests/xml/clark-tests/valid/not-sa/019.ent
new file mode 100644
index 0000000000..d18201a98b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/019.ent
@@ -0,0 +1,3 @@
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e "'v1'">
+<!ATTLIST doc a1 CDATA%e;>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/019.xml b/collects/tests/xml/clark-tests/valid/not-sa/019.xml
new file mode 100644
index 0000000000..b7a18faba0
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/019.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "019.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/020.ent b/collects/tests/xml/clark-tests/valid/not-sa/020.ent
new file mode 100644
index 0000000000..815291c6d2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/020.ent
@@ -0,0 +1,3 @@
+<!ENTITY % e "doc">
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST%e;a1 CDATA "v1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/020.xml b/collects/tests/xml/clark-tests/valid/not-sa/020.xml
new file mode 100644
index 0000000000..d70892f7ad
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/020.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "020.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/021.ent b/collects/tests/xml/clark-tests/valid/not-sa/021.ent
new file mode 100644
index 0000000000..9f8f2afd2b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/021.ent
@@ -0,0 +1,3 @@
+<!ENTITY % e "doc a1 CDATA">
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST %e; "v1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/021.xml b/collects/tests/xml/clark-tests/valid/not-sa/021.xml
new file mode 100644
index 0000000000..70c28730db
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/021.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "021.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/022.ent b/collects/tests/xml/clark-tests/valid/not-sa/022.ent
new file mode 100644
index 0000000000..26f2d8beb2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/022.ent
@@ -0,0 +1,3 @@
+<!ENTITY % e "INCLUDE[">
+<!ELEMENT doc (#PCDATA)>
+<![ %e; <!ATTLIST doc a1 CDATA "v1"> ]]>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/022.xml b/collects/tests/xml/clark-tests/valid/not-sa/022.xml
new file mode 100644
index 0000000000..b639f2551c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/022.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "022.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/023.ent b/collects/tests/xml/clark-tests/valid/not-sa/023.ent
new file mode 100644
index 0000000000..e3268819f7
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/023.ent
@@ -0,0 +1,5 @@
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e1 "do">
+<!ENTITY % e2 "c">
+<!ENTITY % e3 "%e1;%e2;">
+<!ATTLIST %e3; a1 CDATA "v1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/023.xml b/collects/tests/xml/clark-tests/valid/not-sa/023.xml
new file mode 100644
index 0000000000..1c2484b70b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/023.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "023.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/024.ent b/collects/tests/xml/clark-tests/valid/not-sa/024.ent
new file mode 100644
index 0000000000..aa6d0eccac
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/024.ent
@@ -0,0 +1,4 @@
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e1 "'v1'">
+<!ENTITY % e2 'a1 CDATA %e1;'>
+<!ATTLIST doc %e2;>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/024.xml b/collects/tests/xml/clark-tests/valid/not-sa/024.xml
new file mode 100644
index 0000000000..96e1ecb61b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/024.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "024.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/025.ent b/collects/tests/xml/clark-tests/valid/not-sa/025.ent
new file mode 100644
index 0000000000..389d259eb1
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/025.ent
@@ -0,0 +1,5 @@
+<!ELEMENT doc EMPTY>
+<!ENTITY % e "x">
+<!ENTITY % e "y">
+<!ENTITY % v "'%e;'">
+<!ATTLIST doc a1 CDATA %v;>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/025.xml b/collects/tests/xml/clark-tests/valid/not-sa/025.xml
new file mode 100644
index 0000000000..8fdbc14c47
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/025.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "025.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/026.ent b/collects/tests/xml/clark-tests/valid/not-sa/026.ent
new file mode 100644
index 0000000000..bdc93af639
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/026.ent
@@ -0,0 +1 @@
+<!ATTLIST doc a1 CDATA "w1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/026.xml b/collects/tests/xml/clark-tests/valid/not-sa/026.xml
new file mode 100644
index 0000000000..7b109c0913
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/026.xml
@@ -0,0 +1,7 @@
+<!DOCTYPE doc [
+<!ELEMENT doc ANY>
+<!ENTITY % e SYSTEM "026.ent">
+%e;
+<!ATTLIST doc a1 CDATA "x1" a2 CDATA "x2">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/027.ent b/collects/tests/xml/clark-tests/valid/not-sa/027.ent
new file mode 100644
index 0000000000..712cce3700
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/027.ent
@@ -0,0 +1,2 @@
+<!ENTITY % e "">
+<!ELEMENT doc (#PCDATA %e;)>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/027.xml b/collects/tests/xml/clark-tests/valid/not-sa/027.xml
new file mode 100644
index 0000000000..d0c8c7abb5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/027.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "027.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/028.ent b/collects/tests/xml/clark-tests/valid/not-sa/028.ent
new file mode 100644
index 0000000000..ac249d7b2c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/028.ent
@@ -0,0 +1,2 @@
+<!ELEMENT doc (#PCDATA)>
+<![INCLUDE[<!ATTLIST doc a1 CDATA "v1">]]>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/028.xml b/collects/tests/xml/clark-tests/valid/not-sa/028.xml
new file mode 100644
index 0000000000..50e5248cbf
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/028.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "028.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/029.ent b/collects/tests/xml/clark-tests/valid/not-sa/029.ent
new file mode 100644
index 0000000000..df94df5560
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/029.ent
@@ -0,0 +1,3 @@
+<!ELEMENT doc (#PCDATA)>
+<![IGNORE[<!ATTLIST doc a1 CDATA "v1">]]>
+<!ATTLIST doc a1 CDATA "v2">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/029.xml b/collects/tests/xml/clark-tests/valid/not-sa/029.xml
new file mode 100644
index 0000000000..07e226c1d7
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/029.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "029.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/030.ent b/collects/tests/xml/clark-tests/valid/not-sa/030.ent
new file mode 100644
index 0000000000..e3864460df
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/030.ent
@@ -0,0 +1,3 @@
+<!ELEMENT doc (#PCDATA)>
+<![IGNORE[]]>
+<![INCLUDE[]]>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/030.xml b/collects/tests/xml/clark-tests/valid/not-sa/030.xml
new file mode 100644
index 0000000000..01fc2be4ca
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/030.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "030.ent">
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/031-1.ent b/collects/tests/xml/clark-tests/valid/not-sa/031-1.ent
new file mode 100644
index 0000000000..f7f94ab152
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/031-1.ent
@@ -0,0 +1,3 @@
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e SYSTEM "031-2.ent">
+<!ENTITY e "<![CDATA[%e;]]>">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/031-2.ent b/collects/tests/xml/clark-tests/valid/not-sa/031-2.ent
new file mode 100644
index 0000000000..bef50b1f38
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/031-2.ent
@@ -0,0 +1 @@
+<!ATTLIST doc a1 CDATA "v1">
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/031.xml b/collects/tests/xml/clark-tests/valid/not-sa/031.xml
new file mode 100644
index 0000000000..c3fe5fca71
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/031.xml
@@ -0,0 +1,2 @@
+<!DOCTYPE doc SYSTEM "031-1.ent">
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/001.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/001.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/001.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/002.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/002.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/002.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/003.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/003.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/003.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/004.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/004.xml
new file mode 100644
index 0000000000..bdc39e2224
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/004.xml
@@ -0,0 +1 @@
+<doc a1="value"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/005.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/005.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/005.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/006.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/006.xml
new file mode 100644
index 0000000000..d07627d7a3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/006.xml
@@ -0,0 +1 @@
+<doc a1="v1" a2="w2"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/007.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/007.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/007.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/008.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/008.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/008.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/009.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/009.xml
new file mode 100644
index 0000000000..7293fb63dc
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/009.xml
@@ -0,0 +1 @@
+<doc a1="v1" a2="v2"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/010.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/010.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/010.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/011.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/011.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/011.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/012.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/012.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/012.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/013.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/013.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/013.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/014.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/014.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/014.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/015.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/015.xml
new file mode 100644
index 0000000000..131a32fe69
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/015.xml
@@ -0,0 +1 @@
+<doc a2="v2"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/016.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/016.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/016.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/017.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/017.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/017.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/018.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/018.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/018.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/019.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/019.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/019.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/020.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/020.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/020.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/021.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/021.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/021.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/022.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/022.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/022.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/023.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/023.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/023.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/024.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/024.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/024.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/025.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/025.xml
new file mode 100644
index 0000000000..eb3f9674e8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/025.xml
@@ -0,0 +1 @@
+<doc a1="x"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/026.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/026.xml
new file mode 100644
index 0000000000..71c02026e4
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/026.xml
@@ -0,0 +1 @@
+<doc a1="w1" a2="x2"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/027.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/027.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/027.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/028.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/028.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/028.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/029.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/029.xml
new file mode 100644
index 0000000000..7ac8b2b89d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/029.xml
@@ -0,0 +1 @@
+<doc a1="v2"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/030.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/030.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/030.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/031.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/031.xml
new file mode 100644
index 0000000000..03a6c3f9cd
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/not-sa/out/031.xml
@@ -0,0 +1 @@
+<doc>&lt;!ATTLIST doc a1 CDATA &quot;v1&quot;&gt;&#10;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/001.xml b/collects/tests/xml/clark-tests/valid/sa/001.xml
new file mode 100644
index 0000000000..7fbef49502
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/001.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/002.xml b/collects/tests/xml/clark-tests/valid/sa/002.xml
new file mode 100644
index 0000000000..2e3f1d81dd
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/002.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc ></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/003.xml b/collects/tests/xml/clark-tests/valid/sa/003.xml
new file mode 100644
index 0000000000..c841b81784
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/003.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc >
diff --git a/collects/tests/xml/clark-tests/valid/sa/004.xml b/collects/tests/xml/clark-tests/valid/sa/004.xml
new file mode 100644
index 0000000000..a9c5756933
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/004.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA #IMPLIED>
+]>
+<doc a1="v1"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/005.xml b/collects/tests/xml/clark-tests/valid/sa/005.xml
new file mode 100644
index 0000000000..b069efe727
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/005.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA #IMPLIED>
+]>
+<doc a1 = "v1"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/006.xml b/collects/tests/xml/clark-tests/valid/sa/006.xml
new file mode 100644
index 0000000000..39a346342f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/006.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA #IMPLIED>
+]>
+<doc a1='v1'></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/007.xml b/collects/tests/xml/clark-tests/valid/sa/007.xml
new file mode 100644
index 0000000000..cc3dc53166
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/007.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#32;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/008.xml b/collects/tests/xml/clark-tests/valid/sa/008.xml
new file mode 100644
index 0000000000..b3370eb1cc
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/008.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&amp;&lt;&gt;&quot;&apos;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/009.xml b/collects/tests/xml/clark-tests/valid/sa/009.xml
new file mode 100644
index 0000000000..0fa183eccf
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/009.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#x20;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/010.xml b/collects/tests/xml/clark-tests/valid/sa/010.xml
new file mode 100644
index 0000000000..eb64d18590
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/010.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA #IMPLIED>
+]>
+<doc a1="v1" ></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/011.xml b/collects/tests/xml/clark-tests/valid/sa/011.xml
new file mode 100644
index 0000000000..4cac44b4e4
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/011.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA #IMPLIED a2 CDATA #IMPLIED>
+]>
+<doc a1="v1" a2="v2"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/012.xml b/collects/tests/xml/clark-tests/valid/sa/012.xml
new file mode 100644
index 0000000000..6ce2a3eae2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/012.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc : CDATA #IMPLIED>
+]>
+<doc :="v1"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/013.xml b/collects/tests/xml/clark-tests/valid/sa/013.xml
new file mode 100644
index 0000000000..2f4aae4e28
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/013.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc _.-0123456789 CDATA #IMPLIED>
+]>
+<doc _.-0123456789="v1"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/014.xml b/collects/tests/xml/clark-tests/valid/sa/014.xml
new file mode 100644
index 0000000000..47f1f723e3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/014.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc abcdefghijklmnopqrstuvwxyz CDATA #IMPLIED>
+]>
+<doc abcdefghijklmnopqrstuvwxyz="v1"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/015.xml b/collects/tests/xml/clark-tests/valid/sa/015.xml
new file mode 100644
index 0000000000..861df8a610
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/015.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc ABCDEFGHIJKLMNOPQRSTUVWXYZ CDATA #IMPLIED>
+]>
+<doc ABCDEFGHIJKLMNOPQRSTUVWXYZ="v1"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/016.xml b/collects/tests/xml/clark-tests/valid/sa/016.xml
new file mode 100644
index 0000000000..66b1973c5d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/016.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc><?pi?></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/017.xml b/collects/tests/xml/clark-tests/valid/sa/017.xml
new file mode 100644
index 0000000000..827ba963bf
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/017.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc><?pi some data ? > <??></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/018.xml b/collects/tests/xml/clark-tests/valid/sa/018.xml
new file mode 100644
index 0000000000..4570903fee
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/018.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc><![CDATA[<foo>]]></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/019.xml b/collects/tests/xml/clark-tests/valid/sa/019.xml
new file mode 100644
index 0000000000..3e6b74cbf2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/019.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc><![CDATA[<&]]></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/020.xml b/collects/tests/xml/clark-tests/valid/sa/020.xml
new file mode 100644
index 0000000000..f749551a1b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/020.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc><![CDATA[<&]>]]]></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/021.xml b/collects/tests/xml/clark-tests/valid/sa/021.xml
new file mode 100644
index 0000000000..13dda8c8a5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/021.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc><!-- a comment --></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/022.xml b/collects/tests/xml/clark-tests/valid/sa/022.xml
new file mode 100644
index 0000000000..41d300e950
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/022.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc><!-- a comment ->--></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/023.xml b/collects/tests/xml/clark-tests/valid/sa/023.xml
new file mode 100644
index 0000000000..3837b831ad
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/023.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e "">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/024.xml b/collects/tests/xml/clark-tests/valid/sa/024.xml
new file mode 100644
index 0000000000..b0655c634c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/024.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (foo)>
+<!ELEMENT foo (#PCDATA)>
+<!ENTITY e "&#60;foo></foo>">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/025.xml b/collects/tests/xml/clark-tests/valid/sa/025.xml
new file mode 100644
index 0000000000..ed01f36d89
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/025.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (foo*)>
+<!ELEMENT foo (#PCDATA)>
+]>
+<doc><foo/><foo></foo></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/026.xml b/collects/tests/xml/clark-tests/valid/sa/026.xml
new file mode 100644
index 0000000000..1ba033c1a7
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/026.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (foo*)>
+<!ELEMENT foo EMPTY>
+]>
+<doc><foo/><foo></foo></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/027.xml b/collects/tests/xml/clark-tests/valid/sa/027.xml
new file mode 100644
index 0000000000..ee02439051
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/027.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (foo*)>
+<!ELEMENT foo ANY>
+]>
+<doc><foo/><foo></foo></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/028.xml b/collects/tests/xml/clark-tests/valid/sa/028.xml
new file mode 100644
index 0000000000..3d95747913
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/028.xml
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/029.xml b/collects/tests/xml/clark-tests/valid/sa/029.xml
new file mode 100644
index 0000000000..909f6ff712
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/029.xml
@@ -0,0 +1,5 @@
+<?xml version='1.0'?>
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/030.xml b/collects/tests/xml/clark-tests/valid/sa/030.xml
new file mode 100644
index 0000000000..3a7ddaa716
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/030.xml
@@ -0,0 +1,5 @@
+<?xml version = "1.0"?>
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/031.xml b/collects/tests/xml/clark-tests/valid/sa/031.xml
new file mode 100644
index 0000000000..a58e05867f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/031.xml
@@ -0,0 +1,5 @@
+<?xml version='1.0' encoding="UTF-8"?>
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/032.xml b/collects/tests/xml/clark-tests/valid/sa/032.xml
new file mode 100644
index 0000000000..be55c8d721
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/032.xml
@@ -0,0 +1,5 @@
+<?xml version='1.0' standalone='yes'?>
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/033.xml b/collects/tests/xml/clark-tests/valid/sa/033.xml
new file mode 100644
index 0000000000..a3f9053868
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/033.xml
@@ -0,0 +1,5 @@
+<?xml version='1.0' encoding="UTF-8" standalone='yes'?>
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/034.xml b/collects/tests/xml/clark-tests/valid/sa/034.xml
new file mode 100644
index 0000000000..7d52f31c0e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/034.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc/>
diff --git a/collects/tests/xml/clark-tests/valid/sa/035.xml b/collects/tests/xml/clark-tests/valid/sa/035.xml
new file mode 100644
index 0000000000..f109a8b782
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/035.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc />
diff --git a/collects/tests/xml/clark-tests/valid/sa/036.xml b/collects/tests/xml/clark-tests/valid/sa/036.xml
new file mode 100644
index 0000000000..8ab2b3fb16
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/036.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
+<?pi data?>
diff --git a/collects/tests/xml/clark-tests/valid/sa/037.xml b/collects/tests/xml/clark-tests/valid/sa/037.xml
new file mode 100644
index 0000000000..f9b2113940
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/037.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
+<!-- comment -->
+
diff --git a/collects/tests/xml/clark-tests/valid/sa/038.xml b/collects/tests/xml/clark-tests/valid/sa/038.xml
new file mode 100644
index 0000000000..d14f41bfe2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/038.xml
@@ -0,0 +1,6 @@
+<!-- comment -->
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
+
diff --git a/collects/tests/xml/clark-tests/valid/sa/039.xml b/collects/tests/xml/clark-tests/valid/sa/039.xml
new file mode 100644
index 0000000000..0897316e46
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/039.xml
@@ -0,0 +1,5 @@
+<?pi data?>
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/040.xml b/collects/tests/xml/clark-tests/valid/sa/040.xml
new file mode 100644
index 0000000000..12c419b65b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/040.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA #IMPLIED>
+]>
+<doc a1="&quot;&lt;&amp;&gt;&apos;"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/041.xml b/collects/tests/xml/clark-tests/valid/sa/041.xml
new file mode 100644
index 0000000000..a59f536277
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/041.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA #IMPLIED>
+]>
+<doc a1="&#65;"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/042.xml b/collects/tests/xml/clark-tests/valid/sa/042.xml
new file mode 100644
index 0000000000..5d7c650944
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/042.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#00000000000000000000000000000000065;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/043.xml b/collects/tests/xml/clark-tests/valid/sa/043.xml
new file mode 100644
index 0000000000..a8095dfe28
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/043.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ATTLIST doc a1 CDATA #IMPLIED>
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc a1="foo
+bar"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/044.xml b/collects/tests/xml/clark-tests/valid/sa/044.xml
new file mode 100644
index 0000000000..bee1d23e1a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/044.xml
@@ -0,0 +1,10 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (e*)>
+<!ELEMENT e EMPTY>
+<!ATTLIST e a1 CDATA "v1" a2 CDATA "v2" a3 CDATA #IMPLIED>
+]>
+<doc>
+<e a3="v3"/>
+<e a1="w1"/>
+<e a2="w2" a3="v3"/>
+</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/045.xml b/collects/tests/xml/clark-tests/valid/sa/045.xml
new file mode 100644
index 0000000000..e2567f532d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/045.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA "v1">
+<!ATTLIST doc a1 CDATA "z1">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/046.xml b/collects/tests/xml/clark-tests/valid/sa/046.xml
new file mode 100644
index 0000000000..c50a2846f9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/046.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA "v1">
+<!ATTLIST doc a2 CDATA "v2">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/047.xml b/collects/tests/xml/clark-tests/valid/sa/047.xml
new file mode 100644
index 0000000000..a4c688cf1a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/047.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>X
+Y</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/048.xml b/collects/tests/xml/clark-tests/valid/sa/048.xml
new file mode 100644
index 0000000000..c6b2dedbba
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/048.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>]</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/049.xml b/collects/tests/xml/clark-tests/valid/sa/049.xml
new file mode 100644
index 0000000000..c3cc797b59
Binary files /dev/null and b/collects/tests/xml/clark-tests/valid/sa/049.xml differ
diff --git a/collects/tests/xml/clark-tests/valid/sa/050.xml b/collects/tests/xml/clark-tests/valid/sa/050.xml
new file mode 100644
index 0000000000..12303b1af2
Binary files /dev/null and b/collects/tests/xml/clark-tests/valid/sa/050.xml differ
diff --git a/collects/tests/xml/clark-tests/valid/sa/051.xml b/collects/tests/xml/clark-tests/valid/sa/051.xml
new file mode 100644
index 0000000000..7ae8f6c73a
Binary files /dev/null and b/collects/tests/xml/clark-tests/valid/sa/051.xml differ
diff --git a/collects/tests/xml/clark-tests/valid/sa/052.xml b/collects/tests/xml/clark-tests/valid/sa/052.xml
new file mode 100644
index 0000000000..3f33a4c760
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/052.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>𐀀􏿽</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/053.xml b/collects/tests/xml/clark-tests/valid/sa/053.xml
new file mode 100644
index 0000000000..0d88f28718
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/053.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ENTITY e "<e/>">
+<!ELEMENT doc (e)>
+<!ELEMENT e EMPTY>
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/054.xml b/collects/tests/xml/clark-tests/valid/sa/054.xml
new file mode 100644
index 0000000000..5d1c88b946
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/054.xml
@@ -0,0 +1,10 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+
+
+<doc
+></doc
+>
+
+
diff --git a/collects/tests/xml/clark-tests/valid/sa/055.xml b/collects/tests/xml/clark-tests/valid/sa/055.xml
new file mode 100644
index 0000000000..da0292c5bc
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/055.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<?pi  data?>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/056.xml b/collects/tests/xml/clark-tests/valid/sa/056.xml
new file mode 100644
index 0000000000..144871b2a3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/056.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#x0000000000000000000000000000000000000041;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/057.xml b/collects/tests/xml/clark-tests/valid/sa/057.xml
new file mode 100644
index 0000000000..c1ac849ed1
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/057.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (a*)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/058.xml b/collects/tests/xml/clark-tests/valid/sa/058.xml
new file mode 100644
index 0000000000..2ff23b233f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/058.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ATTLIST doc a1 NMTOKENS #IMPLIED>
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc a1=" 1  	2 	"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/059.xml b/collects/tests/xml/clark-tests/valid/sa/059.xml
new file mode 100644
index 0000000000..2171480ecf
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/059.xml
@@ -0,0 +1,10 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (e*)>
+<!ELEMENT e EMPTY>
+<!ATTLIST e a1 CDATA #IMPLIED a2 CDATA #IMPLIED a3 CDATA #IMPLIED>
+]>
+<doc>
+<e a1="v1" a2="v2" a3="v3"/>
+<e a1="w1" a2="v2"/>
+<e a1="v1" a2="w2" a3="v3"/>
+</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/060.xml b/collects/tests/xml/clark-tests/valid/sa/060.xml
new file mode 100644
index 0000000000..6cd6b4386b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/060.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>X&#10;Y</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/061.xml b/collects/tests/xml/clark-tests/valid/sa/061.xml
new file mode 100644
index 0000000000..bbdc152492
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/061.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#163;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/062.xml b/collects/tests/xml/clark-tests/valid/sa/062.xml
new file mode 100644
index 0000000000..f4ba53090a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/062.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#xe40;&#xe08;&#xe21;ส์</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/063.xml b/collects/tests/xml/clark-tests/valid/sa/063.xml
new file mode 100644
index 0000000000..9668f2da73
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/063.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE เจมส์ [
+<!ELEMENT เจมส์ (#PCDATA)>
+]>
+<เจมส์></เจมส์>
diff --git a/collects/tests/xml/clark-tests/valid/sa/064.xml b/collects/tests/xml/clark-tests/valid/sa/064.xml
new file mode 100644
index 0000000000..74a97aa431
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/064.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#x10000;&#x10FFFD;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/065.xml b/collects/tests/xml/clark-tests/valid/sa/065.xml
new file mode 100644
index 0000000000..f708f2bc17
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/065.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY e "&#60;">
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/066.xml b/collects/tests/xml/clark-tests/valid/sa/066.xml
new file mode 100644
index 0000000000..a27340b9a7
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/066.xml
@@ -0,0 +1,7 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA #IMPLIED>
+<!-- 34 is double quote -->
+<!ENTITY e1 "&#34;">
+]>
+<doc a1="&e1;"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/067.xml b/collects/tests/xml/clark-tests/valid/sa/067.xml
new file mode 100644
index 0000000000..a0ccf772a5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/067.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#13;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/068.xml b/collects/tests/xml/clark-tests/valid/sa/068.xml
new file mode 100644
index 0000000000..8ed806b9a3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/068.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e "&#13;">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/069.xml b/collects/tests/xml/clark-tests/valid/sa/069.xml
new file mode 100644
index 0000000000..2437f60530
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/069.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!NOTATION n PUBLIC "whatever">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/070.xml b/collects/tests/xml/clark-tests/valid/sa/070.xml
new file mode 100644
index 0000000000..eef097df76
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/070.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY % e "<!ELEMENT doc (#PCDATA)>">
+%e;
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/071.xml b/collects/tests/xml/clark-tests/valid/sa/071.xml
new file mode 100644
index 0000000000..ebfba230a4
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/071.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a ID #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/072.xml b/collects/tests/xml/clark-tests/valid/sa/072.xml
new file mode 100644
index 0000000000..6ef39dc49e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/072.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a IDREF #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/073.xml b/collects/tests/xml/clark-tests/valid/sa/073.xml
new file mode 100644
index 0000000000..217476d9a9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/073.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a IDREFS #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/074.xml b/collects/tests/xml/clark-tests/valid/sa/074.xml
new file mode 100644
index 0000000000..8b2354ff73
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/074.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a ENTITY #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/075.xml b/collects/tests/xml/clark-tests/valid/sa/075.xml
new file mode 100644
index 0000000000..33c012441a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/075.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a ENTITIES #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/076.xml b/collects/tests/xml/clark-tests/valid/sa/076.xml
new file mode 100644
index 0000000000..65b731cf6d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/076.xml
@@ -0,0 +1,7 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a NOTATION (n1|n2) #IMPLIED>
+<!NOTATION n1 SYSTEM "http://www.w3.org/">
+<!NOTATION n2 SYSTEM "http://www.w3.org/">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/077.xml b/collects/tests/xml/clark-tests/valid/sa/077.xml
new file mode 100644
index 0000000000..e5f301eac8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/077.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a (1|2) #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/078.xml b/collects/tests/xml/clark-tests/valid/sa/078.xml
new file mode 100644
index 0000000000..b31f40f94e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/078.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #REQUIRED>
+]>
+<doc a="v"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/079.xml b/collects/tests/xml/clark-tests/valid/sa/079.xml
new file mode 100644
index 0000000000..a3290d6cbb
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/079.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #FIXED "v">
+]>
+<doc a="v"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/080.xml b/collects/tests/xml/clark-tests/valid/sa/080.xml
new file mode 100644
index 0000000000..3208fa9aa5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/080.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #FIXED "v">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/081.xml b/collects/tests/xml/clark-tests/valid/sa/081.xml
new file mode 100644
index 0000000000..51ee1a375c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/081.xml
@@ -0,0 +1,7 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (a, b, c)>
+<!ELEMENT a (a?)>
+<!ELEMENT b (b*)>
+<!ELEMENT c (a | b)+>
+]>
+<doc><a/><b/><c><a/></c></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/082.xml b/collects/tests/xml/clark-tests/valid/sa/082.xml
new file mode 100644
index 0000000000..d5245ac51a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/082.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY % e SYSTEM "e.dtd">
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/083.xml b/collects/tests/xml/clark-tests/valid/sa/083.xml
new file mode 100644
index 0000000000..937cfc0bdd
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/083.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY % e PUBLIC 'whatever' "e.dtd">
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/084.xml b/collects/tests/xml/clark-tests/valid/sa/084.xml
new file mode 100644
index 0000000000..82760767aa
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/084.xml
@@ -0,0 +1 @@
+<!DOCTYPE doc [<!ELEMENT doc (#PCDATA)>]><doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/085.xml b/collects/tests/xml/clark-tests/valid/sa/085.xml
new file mode 100644
index 0000000000..cf5834f2a5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/085.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e "<foo>">
+<!ENTITY e "">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/086.xml b/collects/tests/xml/clark-tests/valid/sa/086.xml
new file mode 100644
index 0000000000..bbc3080db6
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/086.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e "">
+<!ENTITY e "<foo>">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/087.xml b/collects/tests/xml/clark-tests/valid/sa/087.xml
new file mode 100644
index 0000000000..34797a67d7
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/087.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ENTITY e "<foo/&#62;">
+<!ELEMENT doc (foo)>
+<!ELEMENT foo EMPTY>
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/088.xml b/collects/tests/xml/clark-tests/valid/sa/088.xml
new file mode 100644
index 0000000000..f97d96848d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/088.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e "&lt;foo>">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/089.xml b/collects/tests/xml/clark-tests/valid/sa/089.xml
new file mode 100644
index 0000000000..2d80c8f3fb
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/089.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY e "&#x10000;&#x10FFFD;&#x10FFFF;">
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/090.xml b/collects/tests/xml/clark-tests/valid/sa/090.xml
new file mode 100644
index 0000000000..c392c96084
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/090.xml
@@ -0,0 +1,7 @@
+<!DOCTYPE doc [
+<!ATTLIST e a NOTATION (n) #IMPLIED>
+<!ELEMENT doc (e)*>
+<!ELEMENT e (#PCDATA)>
+<!NOTATION n PUBLIC "whatever">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/091.xml b/collects/tests/xml/clark-tests/valid/sa/091.xml
new file mode 100644
index 0000000000..7343d0f795
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/091.xml
@@ -0,0 +1,7 @@
+<!DOCTYPE doc [
+<!NOTATION n SYSTEM "http://www.w3.org/">
+<!ENTITY e SYSTEM "http://www.w3.org/" NDATA n>
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a ENTITY "e">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/092.xml b/collects/tests/xml/clark-tests/valid/sa/092.xml
new file mode 100644
index 0000000000..627b74ecdf
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/092.xml
@@ -0,0 +1,10 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (a)*>
+<!ELEMENT a EMPTY>
+]>
+<doc>
+<a/>
+    <a/>	<a/>
+
+
+</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/093.xml b/collects/tests/xml/clark-tests/valid/sa/093.xml
new file mode 100644
index 0000000000..968acb628f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/093.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>
+

</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/094.xml b/collects/tests/xml/clark-tests/valid/sa/094.xml
new file mode 100644
index 0000000000..5726e7db6f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/094.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ENTITY % e "foo">
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a1 CDATA "%e;">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/095.xml b/collects/tests/xml/clark-tests/valid/sa/095.xml
new file mode 100644
index 0000000000..1fe69596da
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/095.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ATTLIST doc a1 CDATA #IMPLIED>
+<!ATTLIST doc a1 NMTOKENS #IMPLIED>
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc a1="1  2"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/096.xml b/collects/tests/xml/clark-tests/valid/sa/096.xml
new file mode 100644
index 0000000000..a6f8f43620
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/096.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ATTLIST doc a1 NMTOKENS " 1  	2 	">
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/097.ent b/collects/tests/xml/clark-tests/valid/sa/097.ent
new file mode 100644
index 0000000000..e06554ace2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/097.ent
@@ -0,0 +1 @@
+<!ATTLIST doc a2 CDATA #IMPLIED>
diff --git a/collects/tests/xml/clark-tests/valid/sa/097.xml b/collects/tests/xml/clark-tests/valid/sa/097.xml
new file mode 100644
index 0000000000..c606afa97f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/097.xml
@@ -0,0 +1,8 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY % e SYSTEM "097.ent">
+<!ATTLIST doc a1 CDATA "v1">
+%e;
+<!ATTLIST doc a2 CDATA "v2">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/098.xml b/collects/tests/xml/clark-tests/valid/sa/098.xml
new file mode 100644
index 0000000000..33a64ce5ae
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/098.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc><?pi x
+y?></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/099.xml b/collects/tests/xml/clark-tests/valid/sa/099.xml
new file mode 100644
index 0000000000..1b7214a137
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/099.xml
@@ -0,0 +1,5 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/100.xml b/collects/tests/xml/clark-tests/valid/sa/100.xml
new file mode 100644
index 0000000000..5b839e76bc
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/100.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ENTITY e PUBLIC ";!*#@$_%" "100.xml">
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/101.xml b/collects/tests/xml/clark-tests/valid/sa/101.xml
new file mode 100644
index 0000000000..f464484bf5
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/101.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e "&#34;">
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/102.xml b/collects/tests/xml/clark-tests/valid/sa/102.xml
new file mode 100644
index 0000000000..f239ff5fee
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/102.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #IMPLIED>
+]>
+<doc a="&#34;"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/103.xml b/collects/tests/xml/clark-tests/valid/sa/103.xml
new file mode 100644
index 0000000000..1dbbd5bb7c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/103.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc>&#60;doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/104.xml b/collects/tests/xml/clark-tests/valid/sa/104.xml
new file mode 100644
index 0000000000..666f43de0f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/104.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #IMPLIED>
+]>
+<doc a="x	y"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/105.xml b/collects/tests/xml/clark-tests/valid/sa/105.xml
new file mode 100644
index 0000000000..6b3af2b847
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/105.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #IMPLIED>
+]>
+<doc a="x&#9;y"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/106.xml b/collects/tests/xml/clark-tests/valid/sa/106.xml
new file mode 100644
index 0000000000..8757c0a5ae
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/106.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #IMPLIED>
+]>
+<doc a="x&#10;y"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/107.xml b/collects/tests/xml/clark-tests/valid/sa/107.xml
new file mode 100644
index 0000000000..3d2c2566a7
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/107.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #IMPLIED>
+]>
+<doc a="x&#13;y"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/108.xml b/collects/tests/xml/clark-tests/valid/sa/108.xml
new file mode 100644
index 0000000000..e919bf229a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/108.xml
@@ -0,0 +1,7 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e "
+">
+<!ATTLIST doc a CDATA #IMPLIED>
+]>
+<doc a="x&e;y"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/109.xml b/collects/tests/xml/clark-tests/valid/sa/109.xml
new file mode 100644
index 0000000000..33fa38e13b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/109.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a CDATA #IMPLIED>
+]>
+<doc a=""></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/110.xml b/collects/tests/xml/clark-tests/valid/sa/110.xml
new file mode 100644
index 0000000000..0c61c65119
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/110.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e "&#13;&#10;">
+<!ATTLIST doc a CDATA #IMPLIED>
+]>
+<doc a="x&e;y"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/111.xml b/collects/tests/xml/clark-tests/valid/sa/111.xml
new file mode 100644
index 0000000000..cb56f264b0
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/111.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST doc a NMTOKENS #IMPLIED>
+]>
+<doc a="&#32;x&#32;&#32;y&#32;"></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/112.xml b/collects/tests/xml/clark-tests/valid/sa/112.xml
new file mode 100644
index 0000000000..27b6a4c793
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/112.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (a | b)>
+<!ELEMENT a (#PCDATA)>
+]>
+<doc><a></a></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/113.xml b/collects/tests/xml/clark-tests/valid/sa/113.xml
new file mode 100644
index 0000000000..d2edd0f01d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/113.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ATTLIST e a CDATA #IMPLIED>
+]>
+<doc></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/114.xml b/collects/tests/xml/clark-tests/valid/sa/114.xml
new file mode 100644
index 0000000000..52e207096d
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/114.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e "<![CDATA[&foo;]]>">
+]>
+<doc>&e;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/115.xml b/collects/tests/xml/clark-tests/valid/sa/115.xml
new file mode 100644
index 0000000000..d939a67010
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/115.xml
@@ -0,0 +1,6 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY e1 "&e2;">
+<!ENTITY e2 "v">
+]>
+<doc>&e1;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/116.xml b/collects/tests/xml/clark-tests/valid/sa/116.xml
new file mode 100644
index 0000000000..55ab49620b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/116.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+]>
+<doc><![CDATA[
+]]></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/117.xml b/collects/tests/xml/clark-tests/valid/sa/117.xml
new file mode 100644
index 0000000000..e4f02b14c8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/117.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY rsqb "]">
+]>
+<doc>&rsqb;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/118.xml b/collects/tests/xml/clark-tests/valid/sa/118.xml
new file mode 100644
index 0000000000..fba6c44668
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/118.xml
@@ -0,0 +1,5 @@
+<!DOCTYPE doc [
+<!ELEMENT doc (#PCDATA)>
+<!ENTITY rsqb "]]">
+]>
+<doc>&rsqb;</doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/119.xml b/collects/tests/xml/clark-tests/valid/sa/119.xml
new file mode 100644
index 0000000000..876e74730c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/119.xml
@@ -0,0 +1,4 @@
+<!DOCTYPE doc [
+<!ELEMENT doc ANY>
+]>
+<doc><!-- -á --></doc>
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/001.xml b/collects/tests/xml/clark-tests/valid/sa/out/001.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/001.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/002.xml b/collects/tests/xml/clark-tests/valid/sa/out/002.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/002.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/003.xml b/collects/tests/xml/clark-tests/valid/sa/out/003.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/003.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/004.xml b/collects/tests/xml/clark-tests/valid/sa/out/004.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/004.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/005.xml b/collects/tests/xml/clark-tests/valid/sa/out/005.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/005.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/006.xml b/collects/tests/xml/clark-tests/valid/sa/out/006.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/006.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/007.xml b/collects/tests/xml/clark-tests/valid/sa/out/007.xml
new file mode 100644
index 0000000000..97cf3e3b86
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/007.xml
@@ -0,0 +1 @@
+<doc> </doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/008.xml b/collects/tests/xml/clark-tests/valid/sa/out/008.xml
new file mode 100644
index 0000000000..3ea232c21a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/008.xml
@@ -0,0 +1 @@
+<doc>&amp;&lt;&gt;&quot;'</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/009.xml b/collects/tests/xml/clark-tests/valid/sa/out/009.xml
new file mode 100644
index 0000000000..97cf3e3b86
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/009.xml
@@ -0,0 +1 @@
+<doc> </doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/010.xml b/collects/tests/xml/clark-tests/valid/sa/out/010.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/010.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/011.xml b/collects/tests/xml/clark-tests/valid/sa/out/011.xml
new file mode 100644
index 0000000000..7293fb63dc
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/011.xml
@@ -0,0 +1 @@
+<doc a1="v1" a2="v2"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/012.xml b/collects/tests/xml/clark-tests/valid/sa/out/012.xml
new file mode 100644
index 0000000000..5a0c9831ae
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/012.xml
@@ -0,0 +1 @@
+<doc :="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/013.xml b/collects/tests/xml/clark-tests/valid/sa/out/013.xml
new file mode 100644
index 0000000000..c9c7ec5da8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/013.xml
@@ -0,0 +1 @@
+<doc _.-0123456789="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/014.xml b/collects/tests/xml/clark-tests/valid/sa/out/014.xml
new file mode 100644
index 0000000000..ac6b28f97a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/014.xml
@@ -0,0 +1 @@
+<doc abcdefghijklmnopqrstuvwxyz="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/015.xml b/collects/tests/xml/clark-tests/valid/sa/out/015.xml
new file mode 100644
index 0000000000..8e216eb99b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/015.xml
@@ -0,0 +1 @@
+<doc ABCDEFGHIJKLMNOPQRSTUVWXYZ="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/016.xml b/collects/tests/xml/clark-tests/valid/sa/out/016.xml
new file mode 100644
index 0000000000..4fc76928b2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/016.xml
@@ -0,0 +1 @@
+<doc><?pi ?></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/017.xml b/collects/tests/xml/clark-tests/valid/sa/out/017.xml
new file mode 100644
index 0000000000..3b9a2f8d4e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/017.xml
@@ -0,0 +1 @@
+<doc><?pi some data ? > <??></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/018.xml b/collects/tests/xml/clark-tests/valid/sa/out/018.xml
new file mode 100644
index 0000000000..a5471011df
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/018.xml
@@ -0,0 +1 @@
+<doc>&lt;foo&gt;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/019.xml b/collects/tests/xml/clark-tests/valid/sa/out/019.xml
new file mode 100644
index 0000000000..05d4e2fcf9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/019.xml
@@ -0,0 +1 @@
+<doc>&lt;&amp;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/020.xml b/collects/tests/xml/clark-tests/valid/sa/out/020.xml
new file mode 100644
index 0000000000..95ae08a12e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/020.xml
@@ -0,0 +1 @@
+<doc>&lt;&amp;]&gt;]</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/021.xml b/collects/tests/xml/clark-tests/valid/sa/out/021.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/021.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/022.xml b/collects/tests/xml/clark-tests/valid/sa/out/022.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/022.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/023.xml b/collects/tests/xml/clark-tests/valid/sa/out/023.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/023.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/024.xml b/collects/tests/xml/clark-tests/valid/sa/out/024.xml
new file mode 100644
index 0000000000..a9aa2074ff
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/024.xml
@@ -0,0 +1 @@
+<doc><foo></foo></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/025.xml b/collects/tests/xml/clark-tests/valid/sa/out/025.xml
new file mode 100644
index 0000000000..de0f566020
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/025.xml
@@ -0,0 +1 @@
+<doc><foo></foo><foo></foo></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/026.xml b/collects/tests/xml/clark-tests/valid/sa/out/026.xml
new file mode 100644
index 0000000000..de0f566020
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/026.xml
@@ -0,0 +1 @@
+<doc><foo></foo><foo></foo></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/027.xml b/collects/tests/xml/clark-tests/valid/sa/out/027.xml
new file mode 100644
index 0000000000..de0f566020
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/027.xml
@@ -0,0 +1 @@
+<doc><foo></foo><foo></foo></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/028.xml b/collects/tests/xml/clark-tests/valid/sa/out/028.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/028.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/029.xml b/collects/tests/xml/clark-tests/valid/sa/out/029.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/029.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/030.xml b/collects/tests/xml/clark-tests/valid/sa/out/030.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/030.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/031.xml b/collects/tests/xml/clark-tests/valid/sa/out/031.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/031.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/032.xml b/collects/tests/xml/clark-tests/valid/sa/out/032.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/032.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/033.xml b/collects/tests/xml/clark-tests/valid/sa/out/033.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/033.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/034.xml b/collects/tests/xml/clark-tests/valid/sa/out/034.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/034.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/035.xml b/collects/tests/xml/clark-tests/valid/sa/out/035.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/035.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/036.xml b/collects/tests/xml/clark-tests/valid/sa/out/036.xml
new file mode 100644
index 0000000000..2bcfb06cf1
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/036.xml
@@ -0,0 +1 @@
+<doc></doc><?pi data?>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/037.xml b/collects/tests/xml/clark-tests/valid/sa/out/037.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/037.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/038.xml b/collects/tests/xml/clark-tests/valid/sa/out/038.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/038.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/039.xml b/collects/tests/xml/clark-tests/valid/sa/out/039.xml
new file mode 100644
index 0000000000..82d117d492
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/039.xml
@@ -0,0 +1 @@
+<?pi data?><doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/040.xml b/collects/tests/xml/clark-tests/valid/sa/out/040.xml
new file mode 100644
index 0000000000..d79cfe1493
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/040.xml
@@ -0,0 +1 @@
+<doc a1="&quot;&lt;&amp;&gt;'"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/041.xml b/collects/tests/xml/clark-tests/valid/sa/out/041.xml
new file mode 100644
index 0000000000..6f2cd5832e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/041.xml
@@ -0,0 +1 @@
+<doc a1="A"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/042.xml b/collects/tests/xml/clark-tests/valid/sa/out/042.xml
new file mode 100644
index 0000000000..f683039a80
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/042.xml
@@ -0,0 +1 @@
+<doc>A</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/043.xml b/collects/tests/xml/clark-tests/valid/sa/out/043.xml
new file mode 100644
index 0000000000..e162b76504
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/043.xml
@@ -0,0 +1 @@
+<doc a1="foo bar"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/044.xml b/collects/tests/xml/clark-tests/valid/sa/out/044.xml
new file mode 100644
index 0000000000..78028b704b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/044.xml
@@ -0,0 +1 @@
+<doc>&#10;<e a1="v1" a2="v2" a3="v3"></e>&#10;<e a1="w1" a2="v2"></e>&#10;<e a1="v1" a2="w2" a3="v3"></e>&#10;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/045.xml b/collects/tests/xml/clark-tests/valid/sa/out/045.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/045.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/046.xml b/collects/tests/xml/clark-tests/valid/sa/out/046.xml
new file mode 100644
index 0000000000..7293fb63dc
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/046.xml
@@ -0,0 +1 @@
+<doc a1="v1" a2="v2"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/047.xml b/collects/tests/xml/clark-tests/valid/sa/out/047.xml
new file mode 100644
index 0000000000..b327ebd67f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/047.xml
@@ -0,0 +1 @@
+<doc>X&#10;Y</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/048.xml b/collects/tests/xml/clark-tests/valid/sa/out/048.xml
new file mode 100644
index 0000000000..ced7d02719
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/048.xml
@@ -0,0 +1 @@
+<doc>]</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/049.xml b/collects/tests/xml/clark-tests/valid/sa/out/049.xml
new file mode 100644
index 0000000000..7cc53f9ea0
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/049.xml
@@ -0,0 +1 @@
+<doc>£</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/050.xml b/collects/tests/xml/clark-tests/valid/sa/out/050.xml
new file mode 100644
index 0000000000..33703c7925
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/050.xml
@@ -0,0 +1 @@
+<doc>เจมส์</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/051.xml b/collects/tests/xml/clark-tests/valid/sa/out/051.xml
new file mode 100644
index 0000000000..cfeb5a5366
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/051.xml
@@ -0,0 +1 @@
+<เจมส์></เจมส์>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/052.xml b/collects/tests/xml/clark-tests/valid/sa/out/052.xml
new file mode 100644
index 0000000000..f5a0484791
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/052.xml
@@ -0,0 +1 @@
+<doc>𐀀􏿽</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/053.xml b/collects/tests/xml/clark-tests/valid/sa/out/053.xml
new file mode 100644
index 0000000000..c4083843d9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/053.xml
@@ -0,0 +1 @@
+<doc><e></e></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/054.xml b/collects/tests/xml/clark-tests/valid/sa/out/054.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/054.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/055.xml b/collects/tests/xml/clark-tests/valid/sa/out/055.xml
new file mode 100644
index 0000000000..82d117d492
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/055.xml
@@ -0,0 +1 @@
+<?pi data?><doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/056.xml b/collects/tests/xml/clark-tests/valid/sa/out/056.xml
new file mode 100644
index 0000000000..f683039a80
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/056.xml
@@ -0,0 +1 @@
+<doc>A</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/057.xml b/collects/tests/xml/clark-tests/valid/sa/out/057.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/057.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/058.xml b/collects/tests/xml/clark-tests/valid/sa/out/058.xml
new file mode 100644
index 0000000000..f898cc8c98
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/058.xml
@@ -0,0 +1 @@
+<doc a1="1 2"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/059.xml b/collects/tests/xml/clark-tests/valid/sa/out/059.xml
new file mode 100644
index 0000000000..78028b704b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/059.xml
@@ -0,0 +1 @@
+<doc>&#10;<e a1="v1" a2="v2" a3="v3"></e>&#10;<e a1="w1" a2="v2"></e>&#10;<e a1="v1" a2="w2" a3="v3"></e>&#10;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/060.xml b/collects/tests/xml/clark-tests/valid/sa/out/060.xml
new file mode 100644
index 0000000000..b327ebd67f
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/060.xml
@@ -0,0 +1 @@
+<doc>X&#10;Y</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/061.xml b/collects/tests/xml/clark-tests/valid/sa/out/061.xml
new file mode 100644
index 0000000000..7cc53f9ea0
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/061.xml
@@ -0,0 +1 @@
+<doc>£</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/062.xml b/collects/tests/xml/clark-tests/valid/sa/out/062.xml
new file mode 100644
index 0000000000..33703c7925
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/062.xml
@@ -0,0 +1 @@
+<doc>เจมส์</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/063.xml b/collects/tests/xml/clark-tests/valid/sa/out/063.xml
new file mode 100644
index 0000000000..cfeb5a5366
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/063.xml
@@ -0,0 +1 @@
+<เจมส์></เจมส์>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/064.xml b/collects/tests/xml/clark-tests/valid/sa/out/064.xml
new file mode 100644
index 0000000000..f5a0484791
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/064.xml
@@ -0,0 +1 @@
+<doc>𐀀􏿽</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/065.xml b/collects/tests/xml/clark-tests/valid/sa/out/065.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/065.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/066.xml b/collects/tests/xml/clark-tests/valid/sa/out/066.xml
new file mode 100644
index 0000000000..7597d31bf9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/066.xml
@@ -0,0 +1 @@
+<doc a1="&quot;"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/067.xml b/collects/tests/xml/clark-tests/valid/sa/out/067.xml
new file mode 100644
index 0000000000..4bbdad45ed
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/067.xml
@@ -0,0 +1 @@
+<doc>&#13;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/068.xml b/collects/tests/xml/clark-tests/valid/sa/out/068.xml
new file mode 100644
index 0000000000..4bbdad45ed
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/068.xml
@@ -0,0 +1 @@
+<doc>&#13;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/069.xml b/collects/tests/xml/clark-tests/valid/sa/out/069.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/069.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/070.xml b/collects/tests/xml/clark-tests/valid/sa/out/070.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/070.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/071.xml b/collects/tests/xml/clark-tests/valid/sa/out/071.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/071.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/072.xml b/collects/tests/xml/clark-tests/valid/sa/out/072.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/072.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/073.xml b/collects/tests/xml/clark-tests/valid/sa/out/073.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/073.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/074.xml b/collects/tests/xml/clark-tests/valid/sa/out/074.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/074.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/075.xml b/collects/tests/xml/clark-tests/valid/sa/out/075.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/075.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/076.xml b/collects/tests/xml/clark-tests/valid/sa/out/076.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/076.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/077.xml b/collects/tests/xml/clark-tests/valid/sa/out/077.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/077.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/078.xml b/collects/tests/xml/clark-tests/valid/sa/out/078.xml
new file mode 100644
index 0000000000..fcab0cd7ff
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/078.xml
@@ -0,0 +1 @@
+<doc a="v"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/079.xml b/collects/tests/xml/clark-tests/valid/sa/out/079.xml
new file mode 100644
index 0000000000..fcab0cd7ff
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/079.xml
@@ -0,0 +1 @@
+<doc a="v"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/080.xml b/collects/tests/xml/clark-tests/valid/sa/out/080.xml
new file mode 100644
index 0000000000..fcab0cd7ff
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/080.xml
@@ -0,0 +1 @@
+<doc a="v"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/081.xml b/collects/tests/xml/clark-tests/valid/sa/out/081.xml
new file mode 100644
index 0000000000..e356e7e4db
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/081.xml
@@ -0,0 +1 @@
+<doc><a></a><b></b><c><a></a></c></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/082.xml b/collects/tests/xml/clark-tests/valid/sa/out/082.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/082.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/083.xml b/collects/tests/xml/clark-tests/valid/sa/out/083.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/083.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/084.xml b/collects/tests/xml/clark-tests/valid/sa/out/084.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/084.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/085.xml b/collects/tests/xml/clark-tests/valid/sa/out/085.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/085.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/086.xml b/collects/tests/xml/clark-tests/valid/sa/out/086.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/086.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/087.xml b/collects/tests/xml/clark-tests/valid/sa/out/087.xml
new file mode 100644
index 0000000000..a9aa2074ff
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/087.xml
@@ -0,0 +1 @@
+<doc><foo></foo></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/088.xml b/collects/tests/xml/clark-tests/valid/sa/out/088.xml
new file mode 100644
index 0000000000..a5471011df
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/088.xml
@@ -0,0 +1 @@
+<doc>&lt;foo&gt;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/089.xml b/collects/tests/xml/clark-tests/valid/sa/out/089.xml
new file mode 100644
index 0000000000..e01d86e8d3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/089.xml
@@ -0,0 +1 @@
+<doc>𐀀􏿽􏿿</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/090.xml b/collects/tests/xml/clark-tests/valid/sa/out/090.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/090.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/091.xml b/collects/tests/xml/clark-tests/valid/sa/out/091.xml
new file mode 100644
index 0000000000..dd3bbedf74
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/091.xml
@@ -0,0 +1 @@
+<doc a="e"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/092.xml b/collects/tests/xml/clark-tests/valid/sa/out/092.xml
new file mode 100644
index 0000000000..87269f79d9
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/092.xml
@@ -0,0 +1 @@
+<doc>&#10;<a></a>&#10;    <a></a>&#9;<a></a>&#10;&#10;&#10;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/093.xml b/collects/tests/xml/clark-tests/valid/sa/out/093.xml
new file mode 100644
index 0000000000..631bfde91e
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/093.xml
@@ -0,0 +1 @@
+<doc>&#10;&#10;&#10;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/094.xml b/collects/tests/xml/clark-tests/valid/sa/out/094.xml
new file mode 100644
index 0000000000..636ab4729a
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/094.xml
@@ -0,0 +1 @@
+<doc a1="%e;"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/095.xml b/collects/tests/xml/clark-tests/valid/sa/out/095.xml
new file mode 100644
index 0000000000..a20706ee01
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/095.xml
@@ -0,0 +1 @@
+<doc a1="1  2"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/096.xml b/collects/tests/xml/clark-tests/valid/sa/out/096.xml
new file mode 100644
index 0000000000..f898cc8c98
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/096.xml
@@ -0,0 +1 @@
+<doc a1="1 2"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/097.xml b/collects/tests/xml/clark-tests/valid/sa/out/097.xml
new file mode 100644
index 0000000000..e05cfe6c31
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/097.xml
@@ -0,0 +1 @@
+<doc a1="v1"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/098.xml b/collects/tests/xml/clark-tests/valid/sa/out/098.xml
new file mode 100644
index 0000000000..f6408de9b8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/098.xml
@@ -0,0 +1,2 @@
+<doc><?pi x
+y?></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/099.xml b/collects/tests/xml/clark-tests/valid/sa/out/099.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/099.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/100.xml b/collects/tests/xml/clark-tests/valid/sa/out/100.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/100.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/101.xml b/collects/tests/xml/clark-tests/valid/sa/out/101.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/101.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/102.xml b/collects/tests/xml/clark-tests/valid/sa/out/102.xml
new file mode 100644
index 0000000000..6e66b8da21
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/102.xml
@@ -0,0 +1 @@
+<doc a="&quot;"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/103.xml b/collects/tests/xml/clark-tests/valid/sa/out/103.xml
new file mode 100644
index 0000000000..96495d45c3
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/103.xml
@@ -0,0 +1 @@
+<doc>&lt;doc&gt;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/104.xml b/collects/tests/xml/clark-tests/valid/sa/out/104.xml
new file mode 100644
index 0000000000..cc3def3336
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/104.xml
@@ -0,0 +1 @@
+<doc a="x y"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/105.xml b/collects/tests/xml/clark-tests/valid/sa/out/105.xml
new file mode 100644
index 0000000000..5aed3d613b
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/105.xml
@@ -0,0 +1 @@
+<doc a="x&#9;y"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/106.xml b/collects/tests/xml/clark-tests/valid/sa/out/106.xml
new file mode 100644
index 0000000000..1197d2ff9c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/106.xml
@@ -0,0 +1 @@
+<doc a="x&#10;y"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/107.xml b/collects/tests/xml/clark-tests/valid/sa/out/107.xml
new file mode 100644
index 0000000000..288f23cdf2
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/107.xml
@@ -0,0 +1 @@
+<doc a="x&#13;y"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/108.xml b/collects/tests/xml/clark-tests/valid/sa/out/108.xml
new file mode 100644
index 0000000000..cc3def3336
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/108.xml
@@ -0,0 +1 @@
+<doc a="x y"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/109.xml b/collects/tests/xml/clark-tests/valid/sa/out/109.xml
new file mode 100644
index 0000000000..c43bdf9b9c
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/109.xml
@@ -0,0 +1 @@
+<doc a=""></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/110.xml b/collects/tests/xml/clark-tests/valid/sa/out/110.xml
new file mode 100644
index 0000000000..a92237b4ec
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/110.xml
@@ -0,0 +1 @@
+<doc a="x  y"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/111.xml b/collects/tests/xml/clark-tests/valid/sa/out/111.xml
new file mode 100644
index 0000000000..cc3def3336
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/111.xml
@@ -0,0 +1 @@
+<doc a="x y"></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/112.xml b/collects/tests/xml/clark-tests/valid/sa/out/112.xml
new file mode 100644
index 0000000000..c82f47bca8
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/112.xml
@@ -0,0 +1 @@
+<doc><a></a></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/113.xml b/collects/tests/xml/clark-tests/valid/sa/out/113.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/113.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/114.xml b/collects/tests/xml/clark-tests/valid/sa/out/114.xml
new file mode 100644
index 0000000000..8e0722abad
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/114.xml
@@ -0,0 +1 @@
+<doc>&amp;foo;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/115.xml b/collects/tests/xml/clark-tests/valid/sa/out/115.xml
new file mode 100644
index 0000000000..682b8140ec
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/115.xml
@@ -0,0 +1 @@
+<doc>v</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/116.xml b/collects/tests/xml/clark-tests/valid/sa/out/116.xml
new file mode 100644
index 0000000000..a79dff65fd
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/116.xml
@@ -0,0 +1 @@
+<doc>&#10;</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/117.xml b/collects/tests/xml/clark-tests/valid/sa/out/117.xml
new file mode 100644
index 0000000000..ced7d02719
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/117.xml
@@ -0,0 +1 @@
+<doc>]</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/118.xml b/collects/tests/xml/clark-tests/valid/sa/out/118.xml
new file mode 100644
index 0000000000..31e37a9398
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/118.xml
@@ -0,0 +1 @@
+<doc>]]</doc>
\ No newline at end of file
diff --git a/collects/tests/xml/clark-tests/valid/sa/out/119.xml b/collects/tests/xml/clark-tests/valid/sa/out/119.xml
new file mode 100644
index 0000000000..7e8f183484
--- /dev/null
+++ b/collects/tests/xml/clark-tests/valid/sa/out/119.xml
@@ -0,0 +1 @@
+<doc></doc>
\ No newline at end of file
diff --git a/collects/tests/xml/info.ss b/collects/tests/xml/info.ss
new file mode 100644
index 0000000000..a073420a94
--- /dev/null
+++ b/collects/tests/xml/info.ss
@@ -0,0 +1,3 @@
+#lang setup/infotab
+
+(define compile-omit-paths 'all)
diff --git a/collects/tests/xml/test-clark.ss b/collects/tests/xml/test-clark.ss
new file mode 100644
index 0000000000..eeffd6ab2a
--- /dev/null
+++ b/collects/tests/xml/test-clark.ss
@@ -0,0 +1,90 @@
+#lang scheme
+(require (planet schematics/schemeunit:3)
+         (planet schematics/schemeunit:3/base)
+         (planet schematics/schemeunit:3/test-case)
+         (planet schematics/schemeunit:3/check)
+         (planet schematics/schemeunit:3/test-suite)
+         (planet schematics/schemeunit:3/text-ui)
+         xml
+         scheme/runtime-path)
+
+(define (validate-xml? xml)
+  (error 'validate-xml? "Not implemented"))
+(define (well-formed-xml? xml)
+  (error 'well-formed-xml? "Not implemented"))
+
+(define (read-xml/file f)
+  (with-input-from-file f
+    (lambda () (read-xml))))
+(define (dir->test-suite d name path->test-case)
+  (make-schemeunit-test-suite
+   name
+   (parameterize
+       ([current-test-case-around test-suite-test-case-around]
+        [current-check-around test-suite-check-around])     
+     (map (lambda (p)
+            (path->test-case (build-path d p)))
+          (filter (lambda (p)
+                    (define ext (filename-extension p))
+                    (and ext (bytes=? #"xml" ext)))
+                  (directory-list d))))
+   void
+   void))
+
+(define (not-wf-dir->test-suite d)
+  (define (path->test-case f)
+    (test-not-false
+     (path->string f)
+     (with-handlers ([exn:xml? (lambda _ #t)])
+       (not (well-formed-xml? (read-xml/file f))))))
+  (test-suite
+   "Not Well-Formed"
+   (dir->test-suite 
+    (build-path d "sa") "Stand-alone"
+    path->test-case)
+   (dir->test-suite 
+    (build-path d "ext-sa") "External Stand-alone"
+    path->test-case)
+   (dir->test-suite 
+    (build-path d "not-sa") "Not Stand-alone"
+    path->test-case)))
+(define (invalid-dir->test-suite d)
+  (dir->test-suite 
+   d "Invalid"
+   (lambda (f)
+     (test-false (path->string f)
+                 (validate-xml? (read-xml/file f))))))
+; XXX also check canonical xml
+(define (valid-dir->test-suite d)
+  (define (path->test-case f)
+    (test-not-false (path->string f)
+                      (validate-xml? (read-xml/file f))))
+  (test-suite
+   "Valid"
+   (dir->test-suite 
+    (build-path d "sa") "Stand-alone"
+    path->test-case)
+   (dir->test-suite 
+    (build-path d "ext-sa") "External Stand-alone"
+    path->test-case)
+   (dir->test-suite 
+    (build-path d "not-sa") "Not Stand-alone"
+    path->test-case)))
+
+(define (directory->test-suite d)
+  (test-suite
+   "James Clark's XML Test Cases"
+   
+   (not-wf-dir->test-suite (build-path d "not-wf"))
+   (invalid-dir->test-suite (build-path d "invalid"))
+   (valid-dir->test-suite (build-path d "valid"))))
+
+(define-runtime-path
+  clark-tests-dir
+  (list 'lib "xml/clark-tests" "tests"))
+
+(define clark-tests
+  (directory->test-suite 
+   clark-tests-dir))
+
+(run-tests clark-tests)
\ No newline at end of file
diff --git a/collects/tests/xml/test.ss b/collects/tests/xml/test.ss
new file mode 100644
index 0000000000..6fd84aadf1
--- /dev/null
+++ b/collects/tests/xml/test.ss
@@ -0,0 +1,703 @@
+#lang scheme
+(require (planet schematics/schemeunit:3)
+         (planet schematics/schemeunit:3/text-ui)
+         xml
+         xml/plist
+         mzlib/etc
+         "to-list.ss")
+
+;; test-bad-read-input : format-str str -> void
+;; First argument is the input, second is the error message
+(define ((mk-test-read-xml/exn read-xml) format-str err-string)
+  (define str (format format-str))
+  (test-exn
+   str
+   (lambda (x)
+     (regexp-match (regexp-quote err-string) (exn-message x)))
+   (lambda ()
+     (read-xml (open-input-string str)))))
+
+(define test-read-xml/exn (mk-test-read-xml/exn read-xml))
+(define (test-read-xml str xml)
+  (test-equal? str (document->list (read-xml (open-input-string str))) xml))
+
+(define test-syntax:read-xml/exn (mk-test-read-xml/exn syntax:read-xml))
+(define (test-syntax:read-xml str xml)
+  (test-equal? str (syntax->datum (syntax:read-xml (open-input-string str))) xml))
+
+(define test-read-xml/element/exn (mk-test-read-xml/exn read-xml/element))
+(define (test-read-xml/element str xml)
+  (test-equal? str (element->list (read-xml/element (open-input-string str))) xml))
+
+(define test-syntax:read-xml/element/exn (mk-test-read-xml/exn syntax:read-xml/element))
+(define (test-syntax:read-xml/element str xml)
+  (test-equal? str (syntax->datum (syntax:read-xml/element (open-input-string str))) xml))
+
+(define (test-write-xml str)
+  (test-equal? str (with-output-to-string (lambda () (write-xml (read-xml (open-input-string str))))) str))
+(define (test-write-xml/content str)
+  (test-equal? str (with-output-to-string (lambda () (write-xml/content (document-element (read-xml (open-input-string str)))))) str))
+
+(define (test-display-xml str res)
+  (test-equal? str (with-output-to-string (lambda () (display-xml (read-xml (open-input-string str))))) res))
+(define (test-display-xml/content str res)
+  (test-equal? str (with-output-to-string (lambda () (display-xml/content (document-element (read-xml (open-input-string str)))))) res))
+
+(define (test-xexpr? xe)
+  (test-not-false (format "~S" xe) (xexpr? xe)))
+(define (test-not-xexpr? xe)
+  (test-false (format "~S" xe) (xexpr? xe)))
+
+(define xml-tests
+  (test-suite
+   "XML"
+   
+   (test-suite
+    "Legacy tests"   
+    
+    (test-suite 
+     "DOCTYPE"
+     
+     (let ()
+       (define source-string #<<END
+<!DOCTYPE html PUBLIC
+ "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"> </html>
+END
+         )
+       
+       (define source-document
+         (read-xml (open-input-string source-string)))
+       (define result-string
+         (with-output-to-string (lambda () (write-xml source-document))))
+       (define expected-string #<<END
+<html xmlns="http://www.w3.org/1999/xhtml"> </html>
+END
+         )
+       (test-equal?
+        "DOCTYPE dropping" result-string expected-string)))
+    
+    (local 
+      [(define a-pi (make-p-i #f #f "foo" "bar"))
+       (define a-p (make-prolog empty #f empty))
+       (define a-p/pi (make-prolog (list a-pi) #f (list)))
+       (define a-d0
+         (make-document a-p (make-element #f #f 'html empty empty)
+                        empty))
+       (define a-d1
+         (make-document a-p (make-element #f #f 'html empty empty)
+                        (list a-pi)))
+       (define a-d2
+         (make-document a-p/pi (make-element #f #f 'html empty empty)
+                        (list a-pi)))]
+      (test-suite 
+       "PIs"
+       (test-equal? "Display XML w/o pis"
+                    (with-output-to-string (lambda () (display-xml a-d0)))
+                    "\n<html />")
+       (test-equal? "Display XML w/ pi in doc-misc"
+                    (with-output-to-string (lambda () (display-xml a-d1)))
+                    "\n<html /><?foo bar?>\n")
+       (test-equal? "Display XML w/ pi in doc-misc and prolog"
+                    (with-output-to-string (lambda () (display-xml a-d2)))
+                    "<?foo bar?>\n\n<html /><?foo bar?>\n"))))
+   
+   (test-suite
+    "Datatypes"
+    (test-suite 
+     "xexpr"
+     (test-xexpr? "string")
+     (test-xexpr? (list 'a (list (list 'href "#")) "content"))
+     (test-xexpr? (list 'p "one" "two" "three"))
+     (test-xexpr? 'nbsp)
+     (test-xexpr? 10)
+     (test-xexpr? (make-cdata #f #f "unquoted <b>"))
+     (test-xexpr? (make-comment "Comment!"))
+     (test-xexpr? (make-pcdata #f #f "quoted <b>"))
+     
+     (test-not-xexpr? +)
+     (test-not-xexpr? #f))
+    
+    (test-not-false "xexpr/c" (contract? xexpr/c))
+    
+    (test-not-false "document" (document? (make-document (make-prolog empty #f empty) (make-element #f #f 'br empty empty) empty)))
+    
+    (test-not-false "prolog" (prolog? (make-prolog empty #f empty)))
+    (let ([c1 (make-comment "c1")]
+          [c2 (make-comment "c2")])
+      (test-equal? "prolog" (prolog-misc2 (make-prolog empty #f (list c1 c2)))
+                   (list c1 c2)))
+    
+    (test-not-false "document-type" (document-type? (make-document-type 'name (make-external-dtd "string") #f)))
+    
+    (test-not-false "external-dtd" (external-dtd? (make-external-dtd "string")))
+    (test-not-false "external-dtd/public" (external-dtd/public? (make-external-dtd/public "string" "public")))
+    (test-not-false "external-dtd/system" (external-dtd/system? (make-external-dtd/system "string")))
+    
+    (test-not-false "element" (element? (make-element #f #f 'br empty empty)))
+    
+    (test-not-false "content? pcdata" (content? (make-pcdata #f #f "pcdata")))
+    (test-not-false "content? element" (content? (make-element #f #f 'br empty empty)))
+    (test-not-false "content? entity" (content? (make-entity #f #f 'nbsp)))
+    (test-not-false "content? comment" (content? (make-comment "string")))
+    (test-not-false "content? cdata" (content? (make-cdata #f #f "cdata")))
+    
+    (test-not-false "attribute" (attribute? (make-attribute #f #f 'name "value")))
+    
+    (test-not-false "entity symbol" (entity? (make-entity #f #f 'nbsp)))
+    (test-not-false "entity number" (entity? (make-entity #f #f 10)))
+    
+    (test-not-false "pcdata" (pcdata? (make-pcdata #f #f "string")))
+    
+    (test-not-false "cdata" (cdata? (make-cdata #f #f "string")))
+    
+    (test-not-false "p-i" (p-i? (make-p-i #f #f "target" "instruction")))
+    
+    (test-not-false "comment" (comment? (make-comment "text")))
+    
+    (test-not-false "source" (source? (make-source 'start 'stop)))
+    (test-not-false "source" (source? (make-source (make-location 1 2 3) 'stop)))
+    (test-not-false "source" (source? (make-source 'start (make-location 1 2 3))))
+    (test-not-false "source" (source? (make-source (make-location 1 2 3) (make-location 4 5 6))))
+    
+    (test-not-false "exn:invalid-xexpr" (exn:invalid-xexpr? (make-exn:invalid-xexpr "string" (current-continuation-marks) 'nbsp))))
+   
+   (test-suite
+    "Reading and Writing XML"
+    
+    (test-suite
+     "read-xml"
+     (test-read-xml/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
+     (test-read-xml/exn "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
+     (test-read-xml/exn
+      "<a></b>"
+      "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
+     (test-read-xml/exn
+      "<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
+     
+     (test-read-xml/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
+     (test-read-xml/exn "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
+     (test-read-xml/exn
+      "~n<a></b>"
+      "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
+     (test-read-xml/exn
+      "~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
+     
+     (test-read-xml/exn "" "read-xml: parse-error: expected root element - received #<eof>")
+     (test-read-xml/exn "<br /><br />" "read-xml: parse-error: extra stuff at end of document #<element>")
+     
+     (test-read-xml 
+      "<doc><bold>hi</bold> there!</doc>"
+      '(make-document
+        (make-prolog (list) #f (list))
+        (make-element
+         (make-source (make-location 1 0 1) (make-location 1 33 34))
+         'doc
+         (list)
+         (list
+          (make-element
+           (make-source (make-location 1 5 6) (make-location 1 20 21))
+           'bold
+           (list)
+           (list (make-pcdata (make-source (make-location 1 11 12) (make-location 1 13 14)) "hi")))
+          (make-pcdata (make-source (make-location 1 20 21) (make-location 1 27 28)) " there!")))
+        (list)))
+     
+     (test-read-xml
+      "<a href=\"#\">inner</a>"
+      '(make-document
+        (make-prolog (list) #f (list))
+        (make-element
+         (make-source (make-location 1 0 1) (make-location 1 21 22))
+         'a
+         (list (make-attribute (make-source (make-location 1 3 4) (make-location 1 11 12)) href "#"))
+         (list (make-pcdata (make-source (make-location 1 12 13) (make-location 1 17 18)) "inner")))
+        (list)))
+     
+     (test-read-xml
+      "<root>&nbsp;</root>"
+      '(make-document
+        (make-prolog (list) #f (list))
+        (make-element
+         (make-source (make-location 1 0 1) (make-location 1 19 20))
+         'root
+         (list)
+         (list (make-entity (make-source (make-location 1 6 7) (make-location 1 12 13)) 'nbsp)))
+        (list)))
+     
+     (test-read-xml
+      "<root>&#40;</root>"
+      '(make-document
+        (make-prolog (list) #f (list))
+        (make-element
+         (make-source (make-location 1 0 1) (make-location 1 18 19))
+         'root
+         (list)
+         (list (make-entity (make-source (make-location 1 6 7) (make-location 1 11 12)) '40)))
+        (list)))
+     
+     (test-read-xml
+      "<!-- comment --><br />"
+      '(make-document
+        (make-prolog (list) #f (list))
+        (make-element (make-source (make-location 1 16 17) (make-location 1 22 23)) 'br (list) (list))
+        (list)))
+     
+     ; XXX need more read-xml tests
+     
+     )
+    
+    (test-suite
+     "read-xml/element"
+     (test-read-xml/element/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
+     (test-read-xml/element/exn "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
+     (test-read-xml/element/exn
+      "<a></b>"
+      "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
+     (test-read-xml/element/exn
+      "<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
+     
+     (test-read-xml/element/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
+     (test-read-xml/element/exn "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
+     (test-read-xml/element/exn
+      "~n<a></b>"
+      "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
+     (test-read-xml/element/exn
+      "~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
+     
+     (test-read-xml/element/exn "" "read-xml: parse-error: expected root element - received #<eof>")
+     
+     (test-read-xml/element
+      "<br /><br />"
+      '(make-element (make-source (make-location 1 0 1) (make-location 1 6 7)) 'br (list) (list)))
+     
+     (test-read-xml/element 
+      "<doc><bold>hi</bold> there!</doc>"
+      '(make-element
+        (make-source (make-location 1 0 1) (make-location 1 33 34))
+        'doc
+        (list)
+        (list
+         (make-element
+          (make-source (make-location 1 5 6) (make-location 1 20 21))
+          'bold
+          (list)
+          (list (make-pcdata (make-source (make-location 1 11 12) (make-location 1 13 14)) "hi")))
+         (make-pcdata (make-source (make-location 1 20 21) (make-location 1 27 28)) " there!"))))
+     
+     (test-read-xml/element
+      "<a href=\"#\">inner</a>"
+      '(make-element
+        (make-source (make-location 1 0 1) (make-location 1 21 22))
+        'a
+        (list (make-attribute (make-source (make-location 1 3 4) (make-location 1 11 12)) href "#"))
+        (list (make-pcdata (make-source (make-location 1 12 13) (make-location 1 17 18)) "inner"))))
+     
+     (test-read-xml/element
+      "<root>&nbsp;</root>"
+      '(make-element
+        (make-source (make-location 1 0 1) (make-location 1 19 20))
+        'root
+        (list)
+        (list (make-entity (make-source (make-location 1 6 7) (make-location 1 12 13)) 'nbsp))))
+     
+     (test-read-xml/element
+      "<root>&#40;</root>"
+      '(make-element
+        (make-source (make-location 1 0 1) (make-location 1 18 19))
+        'root
+        (list)
+        (list (make-entity (make-source (make-location 1 6 7) (make-location 1 11 12)) '40))))
+     
+     (test-read-xml/element/exn
+      "<!-- comment --><br />"
+      "read-xml: parse-error: expected root element - received #<comment>")
+     
+     ; XXX need more read-xml/element tests
+     
+     )
+    
+    (test-suite
+     "syntax:read-xml"
+     (test-syntax:read-xml/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
+     (test-syntax:read-xml/exn "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
+     (test-syntax:read-xml/exn
+      "<a></b>"
+      "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
+     (test-syntax:read-xml/exn
+      "<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
+     
+     (test-syntax:read-xml/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
+     (test-syntax:read-xml/exn "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
+     (test-syntax:read-xml/exn
+      "~n<a></b>"
+      "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
+     (test-syntax:read-xml/exn
+      "~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
+     
+     (test-syntax:read-xml/exn "" "read-xml: parse-error: expected root element - received #<eof>")
+     (test-syntax:read-xml/exn "<br /><br />" "read-xml: parse-error: extra stuff at end of document #<element>")
+     
+     (test-syntax:read-xml 
+      "<doc><bold>hi</bold> there!</doc>"
+      '(doc () (bold () "hi") " there!"))
+     
+     (test-syntax:read-xml
+      "<a href=\"#\">inner</a>"
+      '(a ([href "#"]) "inner"))
+     
+     (test-syntax:read-xml
+      "<root>&nbsp;</root>"
+      '(root () nbsp))
+     
+     (test-syntax:read-xml
+      "<root>&#40;</root>"
+      '(root () 40))
+     
+     (test-syntax:read-xml
+      "<!-- comment --><br />"
+      '(br ()))
+     
+     ; XXX need more syntax:read-xml tests
+     
+     )
+    
+    (test-suite
+     "syntax:read-xml/element"
+     (test-syntax:read-xml/element/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
+     (test-syntax:read-xml/element/exn "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
+     (test-syntax:read-xml/element/exn
+      "<a></b>"
+      "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
+     (test-syntax:read-xml/element/exn
+      "<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
+     
+     (test-syntax:read-xml/element/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
+     (test-syntax:read-xml/element/exn "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
+     (test-syntax:read-xml/element/exn
+      "~n<a></b>"
+      "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
+     (test-syntax:read-xml/element/exn
+      "~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
+     
+     (test-syntax:read-xml/element/exn "" "read-xml: parse-error: expected root element - received #<eof>")
+     (test-syntax:read-xml/element 
+      "<br /><br />"
+      '(br ()))
+     
+     (test-syntax:read-xml/element 
+      "<doc><bold>hi</bold> there!</doc>"
+      '(doc () (bold () "hi") " there!"))
+     
+     (test-syntax:read-xml/element
+      "<a href=\"#\">inner</a>"
+      '(a ([href "#"]) "inner"))
+     
+     (test-syntax:read-xml/element
+      "<root>&nbsp;</root>"
+      '(root () nbsp))
+     
+     (test-syntax:read-xml/element
+      "<root>&#40;</root>"
+      '(root () 40))
+     
+     (test-syntax:read-xml/element/exn
+      "<!-- comment --><br />"
+      "read-xml: parse-error: expected root element - received #<comment>")
+     
+     ; XXX need more syntax:read-xml/element tests
+     
+     )
+    
+    (test-suite
+     "write-xml"
+     (test-write-xml "<doc><bold>hi</bold> there!</doc>")
+     (test-write-xml "<a href=\"#\">inner</a>")
+     (test-write-xml "<root>&nbsp;</root>")
+     (test-write-xml "<root>&#40;</root>")
+     (test-write-xml "<br />")
+     ; XXX need more write-xml tests
+     )
+    
+    (test-suite
+     "write-xml/content"
+     (test-write-xml/content "<doc><bold>hi</bold> there!</doc>")
+     (test-write-xml/content "<a href=\"#\">inner</a>")
+     (test-write-xml/content "<root>&nbsp;</root>")
+     (test-write-xml/content "<root>&#40;</root>")
+     (test-write-xml/content "<br />")
+     ; XXX need more write-xml/content tests
+     )
+    
+    (test-suite
+     "display-xml"
+     (test-display-xml "<doc><bold>hi</bold> there!</doc>" "\n<doc>\n  <bold>\n    hi\n  </bold>\n   there!\n</doc>")
+     (test-display-xml "<a href=\"#\">inner</a>" "\n<a href=\"#\">\n  inner\n</a>")
+     (test-display-xml "<root>&nbsp;</root>" "\n<root>&nbsp;\n</root>")
+     (test-display-xml "<root>&#40;</root>" "\n<root>&#40;\n</root>")
+     (test-display-xml "<br />" "\n<br />")
+     ; XXX need more display-xml tests
+     )
+    
+    (test-suite
+     "display-xml/content"
+     (test-display-xml/content "<doc><bold>hi</bold> there!</doc>" "\n<doc>\n  <bold>\n    hi\n  </bold>\n   there!\n</doc>")
+     (test-display-xml/content "<a href=\"#\">inner</a>" "\n<a href=\"#\">\n  inner\n</a>")
+     (test-display-xml/content "<root>&nbsp;</root>" "\n<root>&nbsp;\n</root>")
+     (test-display-xml/content "<root>&#40;</root>" "\n<root>&#40;\n</root>")
+     (test-display-xml/content "<br />" "\n<br />")
+     ; XXX need more display-xml/content tests
+     )
+    )
+   
+   (local
+     [(define (test-xml->xexpr str xe)
+        (test-equal? str (xml->xexpr (document-element (read-xml (open-input-string str)))) xe))
+      (define (test-xexpr->string xe str)
+        (test-equal? (format "~S" xe) (xexpr->string xe) str))]
+     (test-suite 
+      "XML and X-expression Conversions"
+      
+      (test-suite
+       "xml->xexpr"
+       (test-xml->xexpr    
+        "<doc><bold>hi</bold> there!</doc>"
+        '(doc () (bold () "hi") " there!"))
+       
+       (test-xml->xexpr
+        "<a href=\"#\">inner</a>"
+        '(a ([href "#"]) "inner"))
+       
+       (test-xml->xexpr
+        "<root>&nbsp;</root>"
+        '(root () nbsp))
+       
+       (test-xml->xexpr
+        "<root>&#40;</root>"
+        '(root () 40))
+       
+       ; XXX more xml->xexpr tests
+       )
+      
+      (test-suite
+       "xexpr->string"
+       (test-xexpr->string '(doc () (bold () "hi") " there!")
+                           "<doc><bold>hi</bold> there!</doc>")
+       (test-xexpr->string '(a ([href "#"]) "inner")
+                           "<a href=\"#\">inner</a>")
+       (test-xexpr->string '(root () nbsp)
+                           "<root>&nbsp;</root>")      
+       (test-xexpr->string '(root () 40)
+                           "<root>&#40;</root>")
+       ; XXX more xexpr->string tests
+       )
+      
+      (local
+        [(define (test-eliminate-whitespace tags choose str res)
+           (test-equal? (format "~S" (list tags choose str))
+                        (with-output-to-string 
+                         (lambda () 
+                           (write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str))))))
+                        res))
+         (define (test-eliminate-whitespace/exn tags choose str msg)
+           (test-exn (format "~S" (list tags choose str))
+                     (lambda (x)
+                       (and (exn? x)
+                            (regexp-match (regexp-quote msg) (exn-message x))))
+                     (lambda ()
+                       (with-output-to-string 
+                        (lambda () 
+                          (write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str)))))))))
+         (define (truer x) #t)]
+        (test-suite             
+         "eliminate-whitespace"
+         
+         (test-eliminate-whitespace empty identity "<html>\n<p>Hey</p></html>" "<html>\n<p>Hey</p></html>")
+         (test-eliminate-whitespace/exn empty not "<html>\n<p>Hey</p></html>" "not allowed to contain text")
+         (test-eliminate-whitespace/exn empty truer "<html>\n<p>Hey</p></html>" "not allowed to contain text")
+         
+         (test-eliminate-whitespace '(html) identity "<html>\n<p>Hey</p></html>" "<html><p>Hey</p></html>")
+         (test-eliminate-whitespace/exn '(html) not "<html>\n<p>Hey</p></html>" "not allowed to contain text")
+         (test-eliminate-whitespace/exn '(html) truer "<html>\n<p>Hey</p></html>" "not allowed to contain text")
+         
+         (test-eliminate-whitespace '(html) identity "<html>\n<p>\n</p></html>" "<html><p>\n</p></html>")
+         (test-eliminate-whitespace '(html) not "<html>\n<p>\n</p></html>" "<html>\n<p /></html>")
+         (test-eliminate-whitespace '(html) truer "<html>\n<p>\n</p></html>" "<html><p /></html>")))
+      
+      (local
+        [(define (test-validate-xexpr xe)
+           (test-not-false (format "~S" xe) (validate-xexpr xe)))
+         (define (test-validate-xexpr/exn xe v)
+           (test-exn (format "~S" xe)
+                     (lambda (x)
+                       (and (exn:invalid-xexpr? x)
+                            (equal? (exn:invalid-xexpr-code x) v)))
+                     (lambda ()
+                       (validate-xexpr xe))))]
+        (test-suite
+         "validate-xexpr"
+         (test-validate-xexpr 4)
+         (test-validate-xexpr 'nbsp)
+         (test-validate-xexpr "string")
+         (test-validate-xexpr (make-pcdata #f #f "pcdata"))
+         (test-validate-xexpr (make-cdata #f #f "cdata"))
+         (test-validate-xexpr (make-comment "comment"))
+         (test-validate-xexpr (make-p-i #f #f "s1" "s2"))
+         (test-validate-xexpr '(br))
+         (test-validate-xexpr '(br ()))
+         (test-validate-xexpr '(a ([href "#"]) "string"))
+         
+         (test-validate-xexpr/exn #f #f)
+         (test-validate-xexpr/exn + +)
+         (test-validate-xexpr/exn '(a ([href foo]) bar) 'foo)
+         (test-validate-xexpr/exn '("foo" bar) '("foo" bar))))
+      
+      ; XXX correct-xexpr?
+      
+      (test-suite
+       "permissive?"
+       (test-exn
+        "Non-permissive"
+        (lambda (exn)
+          (and (exn? exn)
+               (regexp-match #rx"Expected content," (exn-message exn))))
+        (lambda ()
+          (xml->xexpr #f)))
+       
+       (test-false
+        "Permissive"
+        (parameterize ([permissive? #t])
+          (xml->xexpr #f))))))
+   
+   (local
+     [(define ((mk-test-param param) v istr ostr)
+        (test-equal? (format "~S" (list v istr))
+                     (parameterize ([param v])
+                       (with-output-to-string
+                        (lambda ()
+                          (write-xml (read-xml (open-input-string istr))))))
+                     ostr))
+      (define test-empty-tag-shorthand (mk-test-param empty-tag-shorthand))
+      (define test-collapse-whitespace (mk-test-param collapse-whitespace))
+      (define test-read-comments (mk-test-param read-comments))]
+     (test-suite
+      "Parameters"
+      
+      (test-suite
+       "empty-tag-shorthand"
+       (test-empty-tag-shorthand 'always "<html></html>" "<html />")
+       (test-empty-tag-shorthand 'always "<html>Hey</html>" "<html>Hey</html>")
+       (test-empty-tag-shorthand 'never "<html></html>" "<html></html>")
+       (test-empty-tag-shorthand 'never "<html>Hey</html>" "<html>Hey</html>")
+       (test-empty-tag-shorthand empty "<html></html>" "<html></html>")
+       (test-empty-tag-shorthand empty "<html>Hey</html>" "<html>Hey</html>")
+       (test-empty-tag-shorthand '(html) "<html></html>" "<html />")
+       (test-empty-tag-shorthand '(html) "<html>Hey</html>" "<html>Hey</html>")
+       (test-empty-tag-shorthand '(p) "<html></html>" "<html></html>")
+       (test-empty-tag-shorthand '(p) "<html>Hey</html>" "<html>Hey</html>"))
+
+      (test-equal? "html-empty-tags"
+                   html-empty-tags
+                   '(param meta link isindex input img hr frame col br basefont base area))
+      
+      (test-suite
+       "collapse-whitespace"
+       (test-collapse-whitespace #t "<html>\n</html>" "<html> </html>")
+       (test-collapse-whitespace #t "<html>\t</html>" "<html> </html>")
+       (test-collapse-whitespace #t "<html>    </html>" "<html> </html>")
+       (test-collapse-whitespace #t "<html><![CDATA[   ]]></html>" "<html><![CDATA[   ]]></html>")
+       (test-collapse-whitespace #t "<html><![CDATA[\n]]></html>" "<html><![CDATA[\n]]></html>")
+       (test-collapse-whitespace #t "<html><![CDATA[\t]]></html>" "<html><![CDATA[\t]]></html>")
+       (test-collapse-whitespace #f "<html>\n</html>" "<html>\n</html>"))
+      
+      (test-suite
+       "read-comments"
+       (test-read-comments #f "<html><!-- Foo --></html>" "<html />")
+       (test-read-comments #t "<html><!-- Foo --></html>" "<html><!-- Foo --></html>"))
+
+      (local
+        [(define (test-xexpr-drop-empty-attributes v istr xe)
+           (test-equal? (format "~S" (list v istr))
+                        (parameterize ([xexpr-drop-empty-attributes v])
+                          (xml->xexpr (document-element (read-xml (open-input-string istr)))))
+                        xe))]
+        (test-suite
+         "xexpr-drop-empty-attributes"
+         
+         (test-xexpr-drop-empty-attributes #f "<html />" '(html ()))
+         (test-xexpr-drop-empty-attributes #t "<html />" '(html))
+         (test-xexpr-drop-empty-attributes #f "<html>Hey</html>" '(html () "Hey"))
+         (test-xexpr-drop-empty-attributes #t "<html>Hey</html>" '(html "Hey"))
+         (test-xexpr-drop-empty-attributes #f "<a href=\"#\">Hey</a>" '(a ([href "#"]) "Hey"))
+         (test-xexpr-drop-empty-attributes #t "<a href=\"#\">Hey</a>" '(a ([href "#"]) "Hey"))))))
+   
+   (local 
+     [(define example
+        `(dict (assoc-pair "first-key"
+                           "just a string with some  whitespace in it")
+               (assoc-pair "second-key"
+                           (false))
+               (assoc-pair "third-key"
+                           (dict ))
+               (assoc-pair "fourth-key"
+                           (dict (assoc-pair "inner-key"
+                                             (real 3.432))))
+               (assoc-pair "fifth-key"
+                           (array (integer 14)
+                                  "another string"
+                                  (true)))
+               (assoc-pair "sixth-key"
+                           (array))))
+      (define example-str #<<END
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist SYSTEM "file://localhost/System/Library/DTDs/PropertyList.dtd">
+<plist version="0.9"><dict><key>first-key</key><string>just a string with some  whitespace in it</string><key>second-key</key><false /><key>third-key</key><dict /><key>fourth-key</key><dict><key>inner-key</key><real>3.432</real></dict><key>fifth-key</key><array><integer>14</integer><string>another string</string><true /></array><key>sixth-key</key><array /></dict></plist>
+END
+        )]
+     (test-suite
+      "PList Library"
+      
+      (test-not-false 
+       "plist-dict?"
+       (plist-dict? 
+        example))
+      (test-false
+       "plist-dict?"
+       (plist-dict?
+        `(p "Hey")))
+      (test-false
+       "plist-dict?"
+       (plist-dict?
+        `(dict (p "Hey"))))
+      (test-false
+       "plist-dict?"
+       (plist-dict?
+        `(dict (assoc-pair "key" 2 3))))
+      (test-false
+       "plist-dict?"
+       (plist-dict?
+        `(dict (assoc-pair 1 2))))
+      (test-false
+       "plist-dict?"
+       (plist-dict?
+        `(dict (assoc-pair "key" #f))))
+      
+      (test-equal? "read-plist"
+                   (read-plist (open-input-string example-str))
+                   example)
+      
+      (test-equal? "write-plist"
+                   (with-output-to-string
+                    (lambda ()
+                      (write-plist example (current-output-port))))
+                   example-str)
+      
+      (local [(define (test-plist-round-trip plist)
+                (define-values (in out) (make-pipe))
+                (write-plist plist out)
+                (close-output-port out)
+                (test-equal? (format "~S" plist) (read-plist in) plist))]
+        (test-plist-round-trip example))))))
+
+(run-tests xml-tests)
\ No newline at end of file
diff --git a/collects/tests/xml/to-list.ss b/collects/tests/xml/to-list.ss
new file mode 100644
index 0000000000..1c954c9489
--- /dev/null
+++ b/collects/tests/xml/to-list.ss
@@ -0,0 +1,84 @@
+#lang scheme
+(require xml)
+(provide (all-defined-out))
+
+(define (document->list xml)
+  (list 'make-document
+        (prolog->list (document-prolog xml))
+        (element->list (document-element xml))
+        (list* 'list (map misc->list (document-misc xml)))))
+(define (prolog->list p)
+  (list 'make-prolog
+         (list* 'list (map misc->list (prolog-misc p)))
+         (dtd->list (prolog-dtd p))
+         (list* 'list (map misc->list (prolog-misc2 p)))))
+(define (dtd->list d)
+  (if d
+      (list 'make-document-type
+            (document-type-name d)
+            (external-dtd->list (document-type-external d))
+            (document-type-inlined d))
+      #f))
+(define (external-dtd->list d)
+  (cond
+    [(external-dtd/system? d)
+     (list 'make-external-dtd/system (external-dtd-system d))]
+    [(external-dtd/public? d)
+     (list 'make-external-dtd/public (external-dtd-system d) (external-dtd/public-public d))]
+    [(external-dtd? d)
+     (list 'make-external-dtd (external-dtd-system d))]))
+(define (element->list e)
+  (list 'make-element
+        (source->list e)
+        (list 'quote (element-name e))
+        (list* 'list (map attribute->list (element-attributes e)))
+        (list* 'list (map content->list (element-content e)))))
+(define (misc->list e)
+  (cond
+    [(comment? e)
+     (comment->list e)]
+    [(p-i? e)
+     (p-i->list e)]))
+(define (content->list e)
+  (cond
+    [(pcdata? e) (pcdata->list e)]
+    [(element? e) (element->list e)]
+    [(entity? e) (entity->list e)]
+    [(comment? e) (comment->list e)]
+    [(cdata? e) (cdata->list e)]))
+(define (attribute->list e)
+  (list 'make-attribute
+        (source->list e)
+        (attribute-name e)
+        (attribute-value e)))
+(define (entity->list e)
+  (list 'make-entity
+        (source->list e)
+        (list 'quote (entity-text e))))
+(define (pcdata->list e)
+  (list 'make-pcdata
+        (source->list e)
+        (pcdata-string e)))
+(define (cdata->list e)
+  (list 'make-cdata
+        (source->list e)
+        (cdata-string e)))
+(define (p-i->list e)
+  (list 'make-p-i
+        (source->list e)
+        (p-i-target-name e)
+        (p-i-instruction e)))
+(define (comment->list e)
+  (list 'make-comment
+        (comment-text e)))
+(define (source->list e)
+  (list 'make-source
+        (location->list (source-start e))
+        (location->list (source-stop e))))
+(define (location->list e)
+  (if (symbol? e)
+      e
+      (list 'make-location
+            (location-line e)
+            (location-char e)
+            (location-offset e))))
\ No newline at end of file
diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index f845addcb1..eedf52c58b 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -395,10 +395,10 @@
 [lcm  (null -Integer . ->* . -Integer)]
 
 [arithmetic-shift (-Integer -Integer . -> . -Integer)]
-[bitwise-and (null N . ->* . N)]
-[bitwise-ior (null N . ->* . N)]
-[bitwise-not (null N . ->* . N)]
-[bitwise-xor (null N . ->* . N)]
+[bitwise-and (null -Integer . ->* . -Integer)]
+[bitwise-ior (null -Integer . ->* . -Integer)]
+[bitwise-not (null -Integer . ->* . -Integer)]
+[bitwise-xor (null -Integer . ->* . -Integer)]
 
 [vector (-poly (a) (->* (list) a (-vec a)))]
 [make-string (cl-> [(-Integer) -String] [(-Integer -Char) -String])]
diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss
index 6099ad5021..632e16f282 100644
--- a/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss
+++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss
@@ -3,6 +3,7 @@
 (provide start interface-version)
 
 (define msg (make-parameter "unknown"))
+(define printf void)
 
 (define (gn)
   (printf "gn ~a~n" (msg))
diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss
index 8bcc653a5d..f416ee5866 100644
--- a/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss
+++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss
@@ -3,6 +3,7 @@
 (provide start interface-version)
 
 (define msg (make-web-parameter "unknown"))
+(define printf void)
 
 (define (gn)
   (printf "gn ~a~n" (msg))
diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss
index eae0530e17..b6b1352909 100644
--- a/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss
+++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss
@@ -2,6 +2,8 @@
 (define interface-version 'stateless)
 (provide start interface-version)
 
+(define printf void)
+
 ;; get-number-from-user: string -> number
 ;; ask the user for a number
 (define (get-number msg)
diff --git a/collects/web-server/http/request.ss b/collects/web-server/http/request.ss
index 8917ec1757..6a89746f4e 100644
--- a/collects/web-server/http/request.ss
+++ b/collects/web-server/http/request.ss
@@ -1,6 +1,5 @@
 #lang scheme
-(require mzlib/contract
-         mzlib/plt-match
+(require mzlib/plt-match
          net/url
          mzlib/list
          net/uri-codec
@@ -10,7 +9,11 @@
 
 (provide/contract
  [rename ext:read-request read-request
-         ((connection? number? ((input-port?) . ->* . (string? string?))) . ->* . (request? boolean?))])
+         (connection? 
+          port-number?
+          (input-port? . -> . (values string? string?))
+          . -> .
+          (values request? boolean?))])
 
 (define (ext:read-request conn host-port port-addresses)
   (with-handlers ([exn? (lambda (exn)
diff --git a/collects/web-server/lang.ss b/collects/web-server/lang.ss
index 6fd66ca732..1ba70de28f 100644
--- a/collects/web-server/lang.ss
+++ b/collects/web-server/lang.ss
@@ -13,15 +13,15 @@
 (provide (rename-out [lang-module-begin #%module-begin])
          (all-from-out "lang/lang-api.ss"))
 
+(define-for-syntax anormalize (make-anormal-term elim-letrec-term))
+
 (define-syntax lang-module-begin 
   (make-lang-module-begin 
    make-labeling
    (make-module-case/new-defs
     (make-define-case/new-defs
-     (compose #;(lambda (stx) (values stx empty))
-              defun
-              elim-callcc
-              (make-anormal-term elim-letrec-term)
-              #;(make-anormal-term (lambda (x) x))
-              #;elim-letrec-term
-              )))))
+     (lambda (stx)
+       (define anf-stx (anormalize stx))
+       (define no-callcc-stx (elim-callcc anf-stx))
+       (define-values (defun-stx new-defs) (defun no-callcc-stx))
+       (values defun-stx new-defs))))))
diff --git a/collects/web-server/lang/util.ss b/collects/web-server/lang/util.ss
index 1894034ce7..af3afa7803 100644
--- a/collects/web-server/lang/util.ss
+++ b/collects/web-server/lang/util.ss
@@ -1,9 +1,21 @@
 #lang scheme/base
 (require (for-template scheme/base)
-         syntax/kerncase
-         mzlib/pretty
-         mzlib/list)
-(provide (all-defined-out))
+         scheme/pretty
+         scheme/list
+         scheme/contract
+         syntax/kerncase)
+(provide/contract
+ [transformer? (parameter/c boolean?)]
+ [recertify (syntax? syntax? . -> . syntax?)]
+ [recertify* (syntax? (listof syntax?) . -> . (listof syntax?))]
+ [recertify/new-defs (syntax? (-> (values syntax? (listof syntax?))) . -> . (values syntax? (listof syntax?)))]
+ [current-code-labeling (parameter/c (syntax? . -> . syntax?))]
+ [generate-formal ((symbol?) ((or/c false/c syntax?)) . ->* . (values syntax? syntax?))]
+ [formals-list (syntax? . -> . (listof syntax?))]
+ [make-define-case/new-defs ((syntax? . -> . (values syntax? (listof syntax?))) . -> . (syntax? . -> . (listof syntax?)))]
+ [make-module-case/new-defs ((syntax? . -> . (listof syntax?)) . -> . (syntax? . -> . (listof syntax?)))]
+ [make-lang-module-begin ((bytes? . -> . (-> symbol?)) (syntax? . -> . (listof syntax?)) . -> . (syntax? . -> . syntax?))]
+ [bound-identifier-member? (syntax? (listof syntax?) . -> . boolean?)])
 
 (define transformer? (make-parameter #f))
 
diff --git a/collects/web-server/private/dispatch-server-sig.ss b/collects/web-server/private/dispatch-server-sig.ss
index d2487f49bd..67346d6e3f 100644
--- a/collects/web-server/private/dispatch-server-sig.ss
+++ b/collects/web-server/private/dispatch-server-sig.ss
@@ -1,13 +1,26 @@
-#lang scheme/base
-(require mzlib/unit)
+#lang scheme
+(require web-server/private/util
+         web-server/private/connection-manager)
 
 (define-signature dispatch-server^
-  (serve
-   serve-ports))
+  ((contracted
+    [serve (-> (-> void))]
+    [serve-ports (input-port? output-port? . -> . (-> void))])))
 
 (define-signature dispatch-server-config^
-  (port listen-ip max-waiting initial-connection-timeout
-        read-request dispatch))
+  ((contracted
+    [port port-number?]
+    [listen-ip (or/c string? false/c)]
+    [max-waiting integer?]
+    [initial-connection-timeout integer?]
+    [read-request
+     (connection? 
+      port-number?
+      (input-port? . -> . (values string? string?))
+      . -> .
+      (values any/c boolean?))]
+    [dispatch 
+     (-> connection? any/c void)])))
 
 (provide
  dispatch-server^ dispatch-server-config^)
diff --git a/collects/web-server/scribblings/private.scrbl b/collects/web-server/scribblings/private.scrbl
index 44f3ec298a..6df3c4b026 100644
--- a/collects/web-server/scribblings/private.scrbl
+++ b/collects/web-server/scribblings/private.scrbl
@@ -147,21 +147,19 @@ The @scheme[dispatch-server^] signature is an alias for
 
 @defsignature[dispatch-server-config^ ()]{
 
- @defthing[port port?]{Specifies the port to serve on.}
- @defthing[listen-ip string?]{Passed to @scheme[tcp-accept].}
+ @defthing[port port-number?]{Specifies the port to serve on.}
+ @defthing[listen-ip (or/c string? false/c)]{Passed to @scheme[tcp-listen].}
  @defthing[max-waiting integer?]{Passed to @scheme[tcp-accept].}
  @defthing[initial-connection-timeout integer?]{Specifies the initial timeout given to a connection.}
  @defproc[(read-request [c connection?]
-                        [p port?]
-                        [port-addresses (-> port? boolean?
-                                            (or/c (values string? string?)
-                                                  (values string? (integer-in 1 65535)
-                                                          string? (integer-in 1 65535))))])
-          any/c]{
+                        [p port-number?]
+                        [port-addresses 
+                         (input-port? . -> . (values string? string?))])
+          (values any/c boolean?)]{
   Defines the way the server reads requests off connections to be passed
   to @scheme[dispatch].
  }
- @defthing[dispatch dispatcher/c]{How to handle requests.}
+ @defthing[dispatch (-> connection? any/c void)]{How to handle requests.}
 }
 
 }
@@ -173,8 +171,8 @@ The @scheme[dispatch-server^] signature is an alias for
 The @schememodname[web-server/private/dispatch-server-unit] module
 provides the unit that actually implements a dispatching server.
 
-@defthing[dispatch-server@ (unit/c (tcp^ dispatch-server-config^) 
-                                   (dispatch-server^))]{
+@defthing[dispatch-server@ (unit/c (import tcp^ dispatch-server-config^) 
+                                   (export dispatch-server^))]{
  Runs the dispatching server config in a very basic way, except that it uses
  @secref["connection-manager.ss"] to manage connections.
 }
diff --git a/collects/web-server/scribblings/running.scrbl b/collects/web-server/scribblings/running.scrbl
index b749364283..a1de7b68e0 100644
--- a/collects/web-server/scribblings/running.scrbl
+++ b/collects/web-server/scribblings/running.scrbl
@@ -99,7 +99,7 @@ of the @web-server in other applications, or loading a custom
 dispatcher. 
 
 @defproc[(serve [#:dispatch dispatch dispatcher/c]
-                [#:tcp@ tcp@ tcp-unit^ raw:tcp@]
+                [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]
                 [#:port port integer? 80]
                 [#:listen-ip listen-ip (or/c string? false/c) #f]
                 [#:max-waiting max-waiting integer? 40]
@@ -127,7 +127,7 @@ from a given path:
 ]
 
 @defproc[(serve/ports [#:dispatch dispatch dispatcher/c]
-                      [#:tcp@ tcp@ tcp-unit^ raw:tcp@]
+                      [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]
                       [#:ports ports (listof integer?) (list 80)]
                       [#:listen-ip listen-ip (or/c string? false/c) #f]
                       [#:max-waiting max-waiting integer? 40]
@@ -138,7 +138,7 @@ from a given path:
 }
 
 @defproc[(serve/ips+ports [#:dispatch dispatch dispatcher/c]
-                          [#:tcp@ tcp@ tcp-unit^ raw:tcp@]
+                          [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]
                           [#:ips+ports ips+ports (listof (cons/c (or/c string? false/c) (listof integer?))) (list (cons #f (list 80)))]
                           [#:max-waiting max-waiting integer? 40]
                           [#:initial-connection-timeout initial-connection-timeout integer? 60])
@@ -147,8 +147,8 @@ from a given path:
  a function that shuts down all of the server instances.
 }
                   
-@defproc[(serve/web-config@ [config@ web-config^]
-                            [#:tcp@ tcp@ tcp-unit^ raw:tcp@])
+@defproc[(serve/web-config@ [config@ (unit/c (import) (export web-config^))]
+                            [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@])
          (-> void)]{
  Starts the @web-server with the settings defined by the given @scheme[web-config^] unit.
         
diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl
index 24eedf89c4..1c6cbba862 100644
--- a/collects/web-server/scribblings/tutorial/continue.scrbl
+++ b/collects/web-server/scribblings/tutorial/continue.scrbl
@@ -948,12 +948,11 @@ So, in the next section, we'll talk about how to use an SQL database to store ou
                                   web-server/scribblings/tutorial/examples/dummy-3
                                   web-server/scribblings/tutorial/dummy-sqlite)]
 @(require (for-label web-server/scribblings/tutorial/dummy-sqlite))
-@;@(require (prefix-in sqlite: (for-label (planet jaymccarthy/sqlite:3/sqlite))))
 
-Our next task is to employ an SQL database for the blog model. We'll be using SQLite with the @schememodname[(planet jaymccarthy/sqlite:3/sqlite)] PLaneT package. We add the following to the top of our model:
+Our next task is to employ an SQL database for the blog model. We'll be using SQLite with the @schememodname[(planet jaymccarthy/sqlite:4)] PLaneT package. We add the following to the top of our model:
 
 @schemeblock[
-(require (prefix-in sqlite: (planet jaymccarthy/sqlite:3/sqlite)))
+(require (prefix-in sqlite: (planet jaymccarthy/sqlite:4)))
 ]
 
 We now have the following bindings:
@@ -961,7 +960,7 @@ We now have the following bindings:
 @defthing[sqlite:db? (any/c . -> . boolean?)]
 @defthing[sqlite:open (path? . -> . sqlite:db?)]
 @defthing[sqlite:exec/ignore (sqlite:db? string? . -> . void)]
-@defthing[sqlite:select (sqlite:db? string? . -> . (listof vector?))]
+@defthing[sqlite:select (sqlite:db? string? . -> . (listof (vectorof (or/c integer? number? string? bytes? false/c))))]
 @defthing[sqlite:insert (sqlite:db? string? . -> . integer?)]
 
 
@@ -1068,8 +1067,7 @@ The only function that creates posts is @scheme[blog-posts]:
   (local [(define (row->post a-row)
             (make-post 
              a-blog
-             (string->number
-              (vector-ref a-row 0))))
+             (vector-ref a-row 0)))
           (define rows (sqlite:select
                         (blog-db a-blog)
                         "SELECT id FROM posts"))]
diff --git a/collects/web-server/scribblings/tutorial/examples/model-3.ss b/collects/web-server/scribblings/tutorial/examples/model-3.ss
index 4a740fc977..3e6a28ce56 100644
--- a/collects/web-server/scribblings/tutorial/examples/model-3.ss
+++ b/collects/web-server/scribblings/tutorial/examples/model-3.ss
@@ -1,5 +1,5 @@
 #lang scheme
-(require (prefix-in sqlite: (planet jaymccarthy/sqlite:3/sqlite)))
+(require (prefix-in sqlite: (planet jaymccarthy/sqlite:4)))
 
 ;; A blog is a (make-blog db)
 ;; where db is an sqlite database handle
@@ -37,8 +37,7 @@
   (local [(define (row->post a-row)
             (make-post 
              a-blog
-             (string->number
-              (vector-ref a-row 0))))
+             (vector-ref a-row 0)))
           (define rows (sqlite:select
                         (blog-db a-blog)
                         "SELECT id FROM posts"))]
diff --git a/collects/web-server/scribblings/web-config-unit.scrbl b/collects/web-server/scribblings/web-config-unit.scrbl
index 76d050c98d..ea6ac8d626 100644
--- a/collects/web-server/scribblings/web-config-unit.scrbl
+++ b/collects/web-server/scribblings/web-config-unit.scrbl
@@ -31,7 +31,7 @@ Provides contains the following identifiers.
  Passed to @scheme[tcp-accept].
 }
 
-@defthing[virtual-hosts (listof (cons/c string? host-table?))]{
+@defthing[virtual-hosts (string? . -> . host?)]{
  Contains the configuration of individual virtual hosts.
 }
 
@@ -43,8 +43,8 @@ Provides contains the following identifiers.
  Specifies the port to serve HTTP on.
 }
 
-@defthing[listen-ip string?]{
- Passed to @scheme[tcp-accept].
+@defthing[listen-ip (or/c false/c string?)]{
+ Passed to @scheme[tcp-listen].
 }
 
 @defthing[make-servlet-namespace make-servlet-namespace/c]{
@@ -62,7 +62,7 @@ Provides contains the following identifiers.
                                            [#:port port (or/c false/c port-number?) #f]
                                            [#:listen-ip listen-ip (or/c false/c string?) #f]
                                            [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)])
-         (unit? web-config^)]{
+         (unit/c (import) (export web-config^))]{
  Reads the S-expression at @scheme[path] and calls
  @scheme[configuration-table-sexpr->web-config@] appropriately.
 }
@@ -74,7 +74,7 @@ Provides contains the following identifiers.
                                                  [#:listen-ip listen-ip (or/c false/c string?) #f]
                                                  [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c
                                                                            (make-make-servlet-namespace)])
-         (unit? web-config^)]{
+         (unit/c (import) (export web-config^))]{
  Parses @scheme[sexpr] as a configuration-table and constructs a @scheme[web-config^] unit.
 }
 
diff --git a/collects/web-server/web-config-sig.ss b/collects/web-server/web-config-sig.ss
index 6ba8ea286f..497cd1e3a3 100644
--- a/collects/web-server/web-config-sig.ss
+++ b/collects/web-server/web-config-sig.ss
@@ -1,8 +1,17 @@
-#lang scheme/signature
+#lang scheme
+(require web-server/private/util
+         web-server/configuration/namespace
+         web-server/configuration/configuration-table-structs)
 
-max-waiting 
-virtual-hosts
-initial-connection-timeout
-port
-listen-ip
-make-servlet-namespace
+(provide
+ web-config^)
+
+(define-signature
+  web-config^
+  ((contracted
+    [max-waiting integer?]
+    [virtual-hosts (string? . -> . host?)]
+    [initial-connection-timeout integer?]
+    [port port-number?]
+    [listen-ip (or/c false/c string?)]
+    [make-servlet-namespace make-servlet-namespace/c])))
\ No newline at end of file
diff --git a/collects/web-server/web-config-unit.ss b/collects/web-server/web-config-unit.ss
index f8c11d31cf..2b068fdd24 100644
--- a/collects/web-server/web-config-unit.ss
+++ b/collects/web-server/web-config-unit.ss
@@ -14,14 +14,14 @@
        (#:port (or/c false/c number?)
                #:listen-ip (or/c false/c string?)
                #:make-servlet-namespace make-servlet-namespace/c)
-       unit?)]
+       (unit/c (import) (export web-config^)))]
  [configuration-table-sexpr->web-config@
   (->* (configuration-table-sexpr?)
        (#:web-server-root path-string?
                           #:port (or/c false/c number?)
                           #:listen-ip (or/c false/c string?)
                           #:make-servlet-namespace make-servlet-namespace/c)
-       unit?)])
+       (unit/c (import) (export web-config^)))])
 
 ; configuration-table->web-config@ : path -> configuration
 (define (configuration-table->web-config@ 
diff --git a/collects/web-server/web-server.ss b/collects/web-server/web-server.ss
index 1491095d57..a12a43af6d 100644
--- a/collects/web-server/web-server.ss
+++ b/collects/web-server/web-server.ss
@@ -14,7 +14,7 @@
 (provide/contract
  [serve
   (->* (#:dispatch dispatcher/c)
-       (#:tcp@ unit?
+       (#:tcp@ (unit/c (import) (export tcp^))
         #:port number?
         #:listen-ip (or/c false/c string?)
         #:max-waiting number?
@@ -22,7 +22,7 @@
        (-> void))]
  [serve/ports
   (->* (#:dispatch dispatcher/c)
-       (#:tcp@ unit?
+       (#:tcp@ (unit/c (import) (export tcp^))
         #:ports (listof number?)
         #:listen-ip (or/c false/c string?)
         #:max-waiting number?
@@ -30,13 +30,13 @@
        (-> void))]
  [serve/ips+ports
   (->* (#:dispatch dispatcher/c)
-       (#:tcp@ unit?
+       (#:tcp@ (unit/c (import) (export tcp^))
         #:ips+ports (listof (cons/c (or/c false/c string?) (listof number?)))
         #:max-waiting number?
         #:initial-connection-timeout number?)
        (-> void))]
  [do-not-return (-> void)]
- [serve/web-config@ ((unit?) (#:tcp@ unit?) . ->* . (-> void?))])
+ [serve/web-config@ (((unit/c (import) (export web-config^))) (#:tcp@ (unit/c (import) (export tcp^))) . ->* . (-> void?))])
 
 (define (do-not-return)
   (semaphore-wait (make-semaphore 0)))
diff --git a/collects/xml/plist.ss b/collects/xml/plist.ss
index d7b7d27b20..80cf581b29 100644
--- a/collects/xml/plist.ss
+++ b/collects/xml/plist.ss
@@ -1,218 +1,185 @@
-(module plist mzscheme
+#lang scheme
+(require xml)
 
-  (require "xml.ss"
-           mzlib/contract)
+; a dict is (list 'dict assoc-pair ...)
+; an assoc-pair is (list 'assoc-pair key value)
+; a key is a string
+; a value is either: 
+;  a string,
+;  a boolean, 
+;  an integer : (list 'integer number)
+;  a real : (list 'real number)
+;  a dict, or
+;  an array : (list 'array value ...)
+; (we're ignoring data & date)
 
-   ; a dict is (list 'dict assoc-pair ...)
-   ; an assoc-pair is (list 'assoc-pair key value)
-   ; a key is a string
-   ; a value is either: 
-   ;  a string,
-   ;  a boolean, 
-   ;  an integer : (list 'integer number)
-   ;  a real : (list 'real number)
-   ;  a dict, or
-   ;  an array : (list 'array value ...)
-   ; (we're ignoring data & date)
-
-   (define (plist-dict? v)
-     (and (list? v)
-          (pair? v)
-          (eq? (car v) 'dict)
-          (andmap (lambda (v)
-                    (and (list? v)
-                         (= 3 (length v))
-                         (eq? (car v) 'assoc-pair)
-                         (string? (cadr v))
-                         (let pl-value? ([v (caddr v)])
-                           (or (string? v)
-                               (and (pair? v)
-                                    (case (car v)
-                                      [(true) (null? (cdr v))]
-                                      [(false) (null? (cdr v))]
-                                      [(integer) (and (= (length v) 2)
-                                                      (exact-integer? (cadr v)))]
-                                      [(real) (and (= (length v) 2)
-                                                   (real? (cadr v)))]
-                                      [(array) (andmap pl-value? (cdr v))]
-                                      [else (plist-dict? v)]))))))
-                  (cdr v))))
+(define (plist-dict? v)
+  (and (list? v)
+       (pair? v)
+       (eq? (car v) 'dict)
+       (andmap (lambda (v)
+                 (and (list? v)
+                      (= 3 (length v))
+                      (eq? (car v) 'assoc-pair)
+                      (string? (cadr v))
+                      (let pl-value? ([v (caddr v)])
+                        (or (string? v)
+                            (and (pair? v)
+                                 (case (car v)
+                                   [(true) (null? (cdr v))]
+                                   [(false) (null? (cdr v))]
+                                   [(integer) (and (= (length v) 2)
+                                                   (exact-integer? (cadr v)))]
+                                   [(real) (and (= (length v) 2)
+                                                (real? (cadr v)))]
+                                   [(array) (andmap pl-value? (cdr v))]
+                                   [else (plist-dict? v)]))))))
+               (cdr v))))
 
 
-   ; raise-plist-exn : string mark-set xexpr symbol -> ???
-   (define (raise-plist-exn tag mark-set xexpr type)
-     (raise (make-exn:fail:contract (string-append "badly formed '" tag "'")
-				    mark-set)))
+; raise-plist-exn : string mark-set xexpr symbol -> ???
+(define (raise-plist-exn tag mark-set xexpr type)
+  (raise (make-exn:fail:contract (string-append "badly formed '" tag "'")
+                                 mark-set)))
 
-   ; expand-dict : xexpr -> xexpr
-   (define (expand-dict x)
-     (cond [(and (eq? (car x) 'dict)
-		 (map expand-assoc-pair (cdr x)))
-	    =>
-	    (lambda (x) `(dict ,@(apply append x)))]
-	   [else
-	    (raise-plist-exn "dict" (current-continuation-marks) x 'plist:dict)]))
+; expand-dict : xexpr -> xexpr
+(define (expand-dict x)
+  (cond [(and (eq? (car x) 'dict)
+              (map expand-assoc-pair (cdr x)))
+         =>
+         (lambda (x) `(dict ,@(apply append x)))]
+        [else
+         (raise-plist-exn "dict" (current-continuation-marks) x 'plist:dict)]))
 
-   ; expand-assoc-pair : xexpr -> (list xexpr xexpr)
-   (define (expand-assoc-pair x)
-     (cond [(and (eq? (car x) 'assoc-pair)
-		 (string? (cadr x))
-		 (expand-value (caddr x)))
-	    =>
-	    (lambda (z) `((key ,(cadr x))
-			  ,z))]
-	   [else
-	    (raise-plist-exn "assoc-pair" (current-continuation-marks) x 'plist:assoc-pair)]))
+; expand-assoc-pair : xexpr -> (list xexpr xexpr)
+(define (expand-assoc-pair x)
+  (cond [(and (eq? (car x) 'assoc-pair)
+              (string? (cadr x))
+              (expand-value (caddr x)))
+         =>
+         (lambda (z) `((key ,(cadr x))
+                       ,z))]
+        [else
+         (raise-plist-exn "assoc-pair" (current-continuation-marks) x 'plist:assoc-pair)]))
 
-   ; expand-value : xexpr -> xexpr
-   (define (expand-value x)
-     (cond [(string? x)
-	    `(string ,x)]
-	   [(or (equal? x '(true))
-		(equal? x '(false)))
-	    x]
-	   [(and (eq? (car x) 'integer)
-		 (expand-integer x))
-	    => 
-	    (lambda (x) x)]
-	   [(and (eq? (car x) 'real)
-		 (expand-real x))
-	    =>
-	    (lambda (x) x)]
-	   [(and (eq? (car x) 'dict)
-		 (expand-dict x))
-	    =>
-	    (lambda (x) x)]
-	   [(and (eq? (car x) 'array)
-		 (expand-array x))
-	    =>
-	    (lambda (x) x)]
-	   [else
-	    (raise-plist-exn "value" (current-continuation-marks) x 'plist:value)]))
+; expand-value : xexpr -> xexpr
+(define (expand-value x)
+  (cond [(string? x)
+         `(string ,x)]
+        [(or (equal? x '(true))
+             (equal? x '(false)))
+         x]
+        [(and (eq? (car x) 'integer)
+              (expand-integer x))
+         => 
+         (lambda (x) x)]
+        [(and (eq? (car x) 'real)
+              (expand-real x))
+         =>
+         (lambda (x) x)]
+        [(and (eq? (car x) 'dict)
+              (expand-dict x))
+         =>
+         (lambda (x) x)]
+        [(and (eq? (car x) 'array)
+              (expand-array x))
+         =>
+         (lambda (x) x)]
+        [else
+         (raise-plist-exn "value" (current-continuation-marks) x 'plist:value)]))
 
-   ; expand-real : xexpr -> xexpr
-   (define (expand-real x)
-     (cond [(and (eq? (car x) 'real)
-		 (real? (cadr x)))
-	    `(real ,(number->string (cadr x)))]
-	   [else
-	    (raise-plist-exn "real" (current-continuation-marks) x 'plist:real)]))
+; expand-real : xexpr -> xexpr
+(define (expand-real x)
+  (cond [(and (eq? (car x) 'real)
+              (real? (cadr x)))
+         `(real ,(number->string (cadr x)))]
+        [else
+         (raise-plist-exn "real" (current-continuation-marks) x 'plist:real)]))
 
-   ; expand-integer : xexpr -> xexpr
-   (define (expand-integer x)
-     (cond [(and (eq? (car x) 'integer)
-		 (integer? (cadr x)))
-	    `(integer ,(number->string (cadr x)))]
-	   [else
-	    (raise-plist-exn "integer" (current-continuation-marks) x 'plist:integer)]))
+; expand-integer : xexpr -> xexpr
+(define (expand-integer x)
+  (cond [(and (eq? (car x) 'integer)
+              (integer? (cadr x)))
+         `(integer ,(number->string (cadr x)))]
+        [else
+         (raise-plist-exn "integer" (current-continuation-marks) x 'plist:integer)]))
 
-   ; expand-array : xexpr -> xexpr
-   (define (expand-array x)
-     (cond [(and (eq? (car x) 'array)
-		 (map expand-value (cdr x)))
-	    =>
-	    (lambda (x)
-	      `(array ,@x))]
-	   [else
-	    (raise-plist-exn "array" (current-continuation-marks) x 'plist:array)]))
+; expand-array : xexpr -> xexpr
+(define (expand-array x)
+  (cond [(and (eq? (car x) 'array)
+              (map expand-value (cdr x)))
+         =>
+         (lambda (x)
+           `(array ,@x))]
+        [else
+         (raise-plist-exn "array" (current-continuation-marks) x 'plist:array)]))
 
-   ; dict? tst -> boolean
-   (define (dict? x)
-     (with-handlers [(exn:fail:contract? (lambda (exn) #f))]
-       (expand-dict x)
-       #t))
+; dict? tst -> boolean
+(define (dict? x)
+  (with-handlers [(exn:fail:contract? (lambda (exn) #f))]
+    (expand-dict x)
+    #t))
 
-   ; write-plist : xexpr port -> (void)
-   (define (write-plist xexpr port)
-     (let ([plist-xexpr `(plist ,(expand-dict xexpr))])
-       (write-xml 
-	(make-document (make-prolog (list (make-pi #f #f 'xml "version=\"1.0\" encoding=\"UTF-8\"")) 
-				    (make-document-type 'plist
-							(if (eq? (system-type) 'macosx)
-							    (make-external-dtd/system 
-							     "file://localhost/System/Library/DTDs/PropertyList.dtd")
-							    #f)
-							#f))
-		       (xexpr->xml `(plist ((version "0.9"))
-					   ,(expand-dict xexpr)))
-		       null)
-	port)))
+; write-plist : xexpr port -> (void)
+(define (write-plist xexpr port)
+  (let ([plist-xexpr `(plist ,(expand-dict xexpr))])
+    (write-xml 
+     (make-document (make-prolog (list (make-p-i #f #f 'xml "version=\"1.0\" encoding=\"UTF-8\"")) 
+                                 (make-document-type 'plist
+                                                     (if (eq? (system-type) 'macosx)
+                                                         (make-external-dtd/system 
+                                                          "file://localhost/System/Library/DTDs/PropertyList.dtd")
+                                                         #f)
+                                                     #f)
+                                 empty)
+                    (xexpr->xml `(plist ((version "0.9"))
+                                        ,(expand-dict xexpr)))
+                    null)
+     port)))
 
 
-   ; collapse-dict : xexpr -> dict
-   (define (collapse-dict x)
-     `(dict ,@(collapse-assoc-pairs (cdr x))))
+; collapse-dict : xexpr -> dict
+(define (collapse-dict x)
+  `(dict ,@(collapse-assoc-pairs (cdr x))))
 
-   ; collapse-assoc-pairs : (listof xexpr) -> (listof assoc-pairs)
-   (define (collapse-assoc-pairs args)
-     (if (null? args)
-	 null
-	 (let ([key (car args)]
-	       [value (cadr args)]
-	       [rest (cddr args)])
-	   (cons `(assoc-pair ,(cadr key) ,(collapse-value value))
-		 (collapse-assoc-pairs rest)))))
+; collapse-assoc-pairs : (listof xexpr) -> (listof assoc-pairs)
+(define (collapse-assoc-pairs args)
+  (if (null? args)
+      null
+      (let ([key (car args)]
+            [value (cadr args)]
+            [rest (cddr args)])
+        (cons `(assoc-pair ,(cadr key) ,(collapse-value value))
+              (collapse-assoc-pairs rest)))))
 
-   ; collapse-value : xexpr -> value
-   (define (collapse-value value)
-     (case (car value)
-       [(string) (cadr value)]
-       [(true false) value]
-       [(integer real) (list (car value) (string->number (cadr value)))]
-       [(dict) (collapse-dict value)]
-       [(array) (collapse-array value)]))
+; collapse-value : xexpr -> value
+(define (collapse-value value)
+  (case (car value)
+    [(string) (cadr value)]
+    [(true false) value]
+    [(integer real) (list (car value) (string->number (cadr value)))]
+    [(dict) (collapse-dict value)]
+    [(array) (collapse-array value)]))
 
-   ; collapse-array : xexpr -> array
-   (define (collapse-array xexpr)
-     `(array ,@(map collapse-value (cdr xexpr))))
+; collapse-array : xexpr -> array
+(define (collapse-array xexpr)
+  `(array ,@(map collapse-value (cdr xexpr))))
 
-   (define tags-without-whitespace
-     '(plist dict array))
+(define tags-without-whitespace
+  '(plist dict array))
 
-   ; read-plist : port -> dict
-   (define (read-plist port)
-     (let* ([xml-doc (read-xml port)]
-	    [content (parameterize ([xexpr-drop-empty-attributes #t])
-		       (xml->xexpr
-			((eliminate-whitespace tags-without-whitespace (lambda (x) x))
-			 (document-element xml-doc))))])
-       (unless (eq? (car content) 'plist)
-	       (error 'read-plist "xml expression is not a plist: ~a" content))
-       (collapse-dict (caddr content))))
+; read-plist : port -> dict
+(define (read-plist port)
+  (let* ([xml-doc (read-xml port)]
+         [content (parameterize ([xexpr-drop-empty-attributes #t])
+                    (xml->xexpr
+                     ((eliminate-whitespace tags-without-whitespace (lambda (x) x))
+                      (document-element xml-doc))))])
+    (unless (eq? (car content) 'plist)
+      (error 'read-plist "xml expression is not a plist: ~a" content))
+    (collapse-dict (caddr content))))
 
-   ;; TEST
-
-   '(define my-dict
-     `(dict (assoc-pair "first-key"
-			"just a string
-                         with some whitespace in it")
-	    (assoc-pair "second-key"
-			(false))
-	    (assoc-pair "third-key"
-			(dict ))
-	    (assoc-pair "fourth-key"
-			(dict (assoc-pair "inner-key"
-					  (real 3.432))))
-	    (assoc-pair "fifth-key"
-			(array (integer 14)
-			       "another string"
-			       (true)))
-	    (assoc-pair "sixth-key"
-			(array))))
-
-   '(call-with-output-file "/Users/clements/tmp.plist"
-     (lambda (port)
-       (write-plist my-dict port))
-     'truncate)
-
-   '(define new-dict
-     (call-with-input-file "/Users/clements/tmp.plist"
-       (lambda (port)
-	 (read-plist port))))
-
-   '(equal? new-dict my-dict)
-
-   ;; END OF TEST
-
-  (provide plist-dict? read-plist)
-  (provide/contract [write-plist (plist-dict? output-port? . -> . void?)]))
+(provide/contract 
+ [plist-dict? (any/c . -> . boolean?)]
+ [read-plist (input-port? . -> . plist-dict?)]
+ [write-plist (plist-dict? output-port? . -> . void?)])
\ No newline at end of file
diff --git a/collects/xml/private/reader.ss b/collects/xml/private/reader.ss
index 0c0d940242..5eb020581b 100644
--- a/collects/xml/private/reader.ss
+++ b/collects/xml/private/reader.ss
@@ -1,466 +1,462 @@
-(module reader mzscheme
-  (require mzlib/unitsig
-           mzlib/list
-           mzlib/etc)
+#lang scheme
+(require "sig.ss")
+
+(provide reader@)
+
+(define-unit reader@
+  (import xml-structs^)
+  (export reader^)
   
-  (require "sig.ss")
+  ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
+  (define-struct (start-tag source) (name attrs))
   
-  (provide reader@)
+  ;; End-tag ::= (make-end-tag Location Location Symbol)
+  (define-struct (end-tag source) (name))
   
-  (define reader@
-    (unit/sig reader^
-      (import xml-structs^)
-      
-      ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
-      (define-struct (start-tag source) (name attrs))
-      
-      ;; End-tag ::= (make-end-tag Location Location Symbol)
-      (define-struct (end-tag source) (name))
-      
-      ;; Token ::= Contents | Start-tag | End-tag | Eof
-      
-      (define read-comments (make-parameter #f))
-      (define collapse-whitespace (make-parameter #f))
-      
-      ;; read-xml : [Input-port] -> Document
-      (define read-xml
-        (opt-lambda ([in (current-input-port)])
-          (let*-values ([(in pos) (positionify in)]
-                        [(misc0 start) (read-misc in pos)])
-            (make-document (make-prolog misc0 #f)
-                           (read-xml-element-helper pos in start)
-                           (let ([loc-before (pos)])
-                             (let-values ([(misc1 end-of-file) (read-misc in pos)])
-                               (unless (eof-object? end-of-file)
-                                 (let ([loc-after (pos)])
-                                   (parse-error (list
-                                                 (make-srcloc
-                                                  (object-name in)
-                                                  #f
-                                                  #f
-                                                  (location-offset loc-before)
-                                                  (- (location-offset loc-after)
-                                                     (location-offset loc-before))))
-                                                "extra stuff at end of document ~e"
-                                                end-of-file)))
-                               misc1))))))
-      
-      ;; read-xml/element : [Input-port] -> Element
-      (define read-xml/element
-        (opt-lambda ([in (current-input-port)])
-          (let-values ([(in pos) (positionify in)])
-            (skip-space in)
-            (read-xml-element-helper pos in (lex in pos)))))
-      
-      ;; read-xml-element-helper : Nat Iport Token -> Element
-      (define (read-xml-element-helper pos in start)
+  ;; Token ::= Contents | Start-tag | End-tag | Eof
+  
+  (define read-comments (make-parameter #f))
+  (define collapse-whitespace (make-parameter #f))
+  
+  ;; read-xml : [Input-port] -> Document
+  (define read-xml
+    (lambda ([in (current-input-port)])
+      (let*-values ([(in pos) (positionify in)]
+                    [(misc0 start) (read-misc in pos)])
+        (make-document (make-prolog misc0 #f empty)
+                       (read-xml-element-helper pos in start)
+                       (let ([loc-before (pos)])
+                         (let-values ([(misc1 end-of-file) (read-misc in pos)])
+                           (unless (eof-object? end-of-file)
+                             (let ([loc-after (pos)])
+                               (parse-error (list
+                                             (make-srcloc
+                                              (object-name in)
+                                              #f
+                                              #f
+                                              (location-offset loc-before)
+                                              (- (location-offset loc-after)
+                                                 (location-offset loc-before))))
+                                            "extra stuff at end of document ~e"
+                                            end-of-file)))
+                           misc1))))))
+  
+  ;; read-xml/element : [Input-port] -> Element
+  (define read-xml/element
+    (lambda ([in (current-input-port)])
+      (let-values ([(in pos) (positionify in)])
+        (skip-space in)
+        (read-xml-element-helper pos in (lex in pos)))))
+  
+  ;; read-xml-element-helper : Nat Iport Token -> Element
+  (define (read-xml-element-helper pos in start)
+    (cond
+      [(start-tag? start) (read-element start in pos)]
+      [(element? start) start]
+      [else (parse-error (list
+                          (make-srcloc
+                           (object-name in)
+                           #f
+                           #f
+                           1
+                           (- (location-offset (pos)) 1)))
+                         "expected root element - received ~e"
+                         (if (pcdata? start) (pcdata-string start) start))]))
+  
+  ;; read-misc : Input-port (-> Location) -> (listof Misc) Token
+  (define (read-misc in pos)
+    (let read-more ()
+      (let ([x (lex in pos)])
         (cond
-          [(start-tag? start) (read-element start in pos)]
-          [(element? start) start]
-          [else (parse-error (list
-                              (make-srcloc
-                               (object-name in)
-                               #f
-                               #f
-                               1
-                               (- (location-offset (pos)) 1)))
-                             "expected root element - received ~e"
-                             (if (pcdata? start) (pcdata-string start) start))]))
-      
-      ;; read-misc : Input-port (-> Location) -> (listof Misc) Token
-      (define (read-misc in pos)
-        (let read-more ()
-          (let ([x (lex in pos)])
-            (cond
-              [(pi? x)
-               (let-values ([(lst next) (read-more)])
-                 (values (cons x lst) next))]
-              [(comment? x)
-               (let-values ([(lst next) (read-more)])
-                 (if (read-comments)
-                     (values (cons x lst) next)
-                     (values lst next)))]
-              [(and (pcdata? x) (andmap char-whitespace? (string->list (pcdata-string x))))
-               (read-more)]
-              [else (values null x)]))))
-      
-      ;; read-element : Start-tag Input-port (-> Location) -> Element
-      (define (read-element start in pos)
-        (let ([name (start-tag-name start)]
-              [a (source-start start)]
-              [b (source-stop start)])
-          (let read-content ([k (lambda (body end-loc)
-                                  (make-element
-                                   a end-loc name (start-tag-attrs start)
-                                   body))])
-            (let ([x (lex in pos)])
+          [(pi? x)
+           (let-values ([(lst next) (read-more)])
+             (values (cons x lst) next))]
+          [(comment? x)
+           (let-values ([(lst next) (read-more)])
+             (if (read-comments)
+                 (values (cons x lst) next)
+                 (values lst next)))]
+          [(and (pcdata? x) (andmap char-whitespace? (string->list (pcdata-string x))))
+           (read-more)]
+          [else (values null x)]))))
+  
+  ;; read-element : Start-tag Input-port (-> Location) -> Element
+  (define (read-element start in pos)
+    (let ([name (start-tag-name start)]
+          [a (source-start start)]
+          [b (source-stop start)])
+      (let read-content ([k (lambda (body end-loc)
+                              (make-element
+                               a end-loc name (start-tag-attrs start)
+                               body))])
+        (let ([x (lex in pos)])
+          (cond
+            [(eof-object? x)
+             (parse-error (list
+                           (make-srcloc
+                            (object-name in)
+                            #f
+                            #f
+                            (location-offset (source-start start))
+                            (- (location-offset (source-stop start))
+                               (location-offset (source-start start)))))
+                          "unclosed `~a' tag at [~a ~a]"
+                          name
+                          (format-source a)
+                          (format-source b))]
+            [(start-tag? x)
+             (let ([next-el (read-element x in pos)])
+               (read-content (lambda (body end-loc)
+                               (k (cons next-el body)
+                                  end-loc))))]
+            [(end-tag? x)
+             (let ([end-loc (source-stop x)])
+               (unless (eq? name (end-tag-name x))
+                 (parse-error
+                  (list
+                   (make-srcloc (object-name in)
+                                #f
+                                #f
+                                (location-offset a)
+                                (- (location-offset b) (location-offset a)))
+                   (make-srcloc (object-name in)
+                                #f
+                                #f
+                                (location-offset (source-start x))
+                                (- (location-offset end-loc) (location-offset (source-start x)))))
+                  "start tag `~a' at [~a ~a] doesn't match end tag `~a' at [~a ~a]"
+                  name
+                  (format-source a)
+                  (format-source b)
+                  (end-tag-name x)
+                  (format-source (source-start x))
+                  (format-source end-loc)))
+               (k null end-loc))]
+            [(entity? x) (read-content (lambda (body end-loc)
+                                         (k (cons (expand-entity x) body)
+                                            end-loc)))]
+            [(comment? x) (if (read-comments)
+                              (read-content (lambda (body end-loc) (k (cons x body) end-loc)))
+                              (read-content k))]
+            [else (read-content (lambda (body end-loc) (k (cons x body) end-loc)))])))))
+  
+  ;; expand-entity : Entity -> (U Entity Pcdata)
+  ;; more here - allow expansion of user defined entities
+  (define (expand-entity x)
+    (let ([expanded (default-entity-table (entity-text x))])
+      (if expanded
+          (make-pcdata (source-start x) (source-stop x) expanded)
+          x)))
+  
+  ;; default-entity-table : Symbol -> (U #f String)
+  (define (default-entity-table name)
+    (case name
+      [(amp) "&"]
+      [(lt) "<"]
+      [(gt) ">"]
+      [(quot) "\""]
+      [(apos) "'"]
+      [else #f]))
+  
+  ;; lex : Input-port (-> Location) -> (U Token special)
+  (define (lex in pos)
+    (let ([c (peek-char-or-special in)])
+      (cond
+        [(eof-object? c) c]
+        [(eq? c #\&) (lex-entity in pos)]
+        [(eq? c #\<) (lex-tag-cdata-pi-comment in pos)]
+        [(not (char? c)) (read-char-or-special in)]
+        [else (lex-pcdata in pos)])))
+  
+  ; lex-entity : Input-port (-> Location) -> Entity
+  ; pre: the first char is a #\&
+  (define (lex-entity in pos)
+    (let ([start (pos)])
+      (read-char in)
+      (let ([data (case (peek-char in)
+                    [(#\#)
+                     (read-char in)
+                     (let ([n (case (peek-char in)
+                                [(#\x) (read-char in)
+                                       (string->number (read-until #\; in pos) 16)]
+                                [else (string->number (read-until #\; in pos))])])
+                       (unless (number? n)
+                         (lex-error in pos "malformed numeric entity"))
+                       n)]
+                    [else
+                     (begin0
+                       (lex-name in pos)
+                       (unless (eq? (read-char in) #\;)
+                         (lex-error in pos "expected ; at the end of an entity")))])])
+        (make-entity start (pos) data))))
+  
+  ; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Cdata | Pi | Comment
+  ; pre: the first char is a #\<
+  (define (lex-tag-cdata-pi-comment in pos)
+    (let ([start (pos)])
+      (read-char in)
+      (case (non-eof peek-char-or-special in pos)
+        [(#\!)
+         (read-char in)
+         (case (non-eof peek-char in pos)
+           [(#\-) (read-char in)
+                  (unless (eq? (read-char-or-special in) #\-)
+                    (lex-error in pos "expected second - after <!-"))
+                  (let ([data (lex-comment-contents in pos)])
+                    (unless (eq? (read-char in) #\>)
+                      (lex-error in pos "expected > to end comment (\"--\" can't appear in comments)"))
+                    ;(make-comment start (pos) data)
+                    (make-comment data))]
+           [(#\[) (read-char in)
+                  (unless (string=? (read-string 6 in) "CDATA[")
+                    (lex-error in pos "expected CDATA following <["))
+                  (let ([data (lex-cdata-contents in pos)])
+                    (make-cdata start (pos) (format "<![CDATA[~a]]>" data)))]
+           [else (skip-dtd in pos)
+                 (skip-space in)
+                 (unless (eq? (peek-char-or-special in) #\<)
+                   (lex-error in pos "expected pi, comment, or element after doctype"))
+                 (lex-tag-cdata-pi-comment in pos)])]
+        [(#\?) (read-char in)
+               (let ([name (lex-name in pos)])
+                 (skip-space in)
+                 (let ([data (lex-pi-data in pos)])
+                   (make-pi start (pos) name data)))]
+        [(#\/) (read-char in)
+               (let ([name (lex-name in pos)])
+                 (skip-space in)
+                 (unless (eq? (read-char-or-special in) #\>)
+                   (lex-error in pos "expected > to close ~a's end tag" name))
+                 (make-end-tag start (pos) name))]
+        [else ; includes 'special, but lex-name will fail in that case
+         (let ([name (lex-name in pos)]
+               [attrs (lex-attributes in pos)])
+           (skip-space in)
+           (case (read-char-or-special in)
+             [(#\/)
+              (unless (eq? (read-char in) #\>)
+                (lex-error in pos "expected > to close empty element ~a" name))
+              (make-element start (pos) name attrs null)]
+             [(#\>) (make-start-tag start (pos) name attrs)]
+             [else (lex-error in pos "expected / or > to close tag `~a'" name)]))])))
+  
+  ;; lex-attributes : Input-port (-> Location) -> (listof Attribute)
+  (define (lex-attributes in pos)
+    (sort (let loop ()
+            (skip-space in)
+            (cond [(name-start? (peek-char-or-special in))
+                   (cons (lex-attribute in pos) (loop))]
+                  [else null]))
+          (lambda (a b)
+            (let ([na (attribute-name a)]
+                  [nb (attribute-name b)])
               (cond
-                [(eof-object? x)
-                 (parse-error (list
-                               (make-srcloc
-                                (object-name in)
-                                #f
-                                #f
-                                (location-offset (source-start start))
-                                (- (location-offset (source-stop start))
-                                   (location-offset (source-start start)))))
-                              "unclosed `~a' tag at [~a ~a]"
-                              name
-                              (format-source a)
-                              (format-source b))]
-                [(start-tag? x)
-                 (let ([next-el (read-element x in pos)])
-                   (read-content (lambda (body end-loc)
-                                   (k (cons next-el body)
-                                      end-loc))))]
-                [(end-tag? x)
-                 (let ([end-loc (source-stop x)])
-                   (unless (eq? name (end-tag-name x))
-                     (parse-error
-                      (list
-                       (make-srcloc (object-name in)
-                                    #f
-                                    #f
-                                    (location-offset a)
-                                    (- (location-offset b) (location-offset a)))
-                       (make-srcloc (object-name in)
-                                    #f
-                                    #f
-                                    (location-offset (source-start x))
-                                    (- (location-offset end-loc) (location-offset (source-start x)))))
-                      "start tag `~a' at [~a ~a] doesn't match end tag `~a' at [~a ~a]"
-                      name
-                      (format-source a)
-                      (format-source b)
-                      (end-tag-name x)
-                      (format-source (source-start x))
-                      (format-source end-loc)))
-                   (k null end-loc))]
-                [(entity? x) (read-content (lambda (body end-loc)
-                                             (k (cons (expand-entity x) body)
-                                                end-loc)))]
-                [(comment? x) (if (read-comments)
-                                  (read-content (lambda (body end-loc) (k (cons x body) end-loc)))
-                                  (read-content k))]
-                [else (read-content (lambda (body end-loc) (k (cons x body) end-loc)))])))))
-      
-      ;; expand-entity : Entity -> (U Entity Pcdata)
-      ;; more here - allow expansion of user defined entities
-      (define (expand-entity x)
-        (let ([expanded (default-entity-table (entity-text x))])
-          (if expanded
-              (make-pcdata (source-start x) (source-stop x) expanded)
-              x)))
-      
-      ;; default-entity-table : Symbol -> (U #f String)
-      (define (default-entity-table name)
-        (case name
-          [(amp) "&"]
-          [(lt) "<"]
-          [(gt) ">"]
-          [(quot) "\""]
-          [(apos) "'"]
-          [else #f]))
-      
-      ;; lex : Input-port (-> Location) -> (U Token special)
-      (define (lex in pos)
-        (let ([c (peek-char-or-special in)])
-          (cond
-            [(eof-object? c) c]
-            [(eq? c #\&) (lex-entity in pos)]
-            [(eq? c #\<) (lex-tag-cdata-pi-comment in pos)]
-            [(not (char? c)) (read-char-or-special in)]
-            [else (lex-pcdata in pos)])))
-      
-      ; lex-entity : Input-port (-> Location) -> Entity
-      ; pre: the first char is a #\&
-      (define (lex-entity in pos)
-        (let ([start (pos)])
+                [(eq? na nb) (lex-error in pos "duplicated attribute name ~a" na)]
+                [else (string<? (symbol->string na) (symbol->string nb))])))))
+  
+  ;; lex-attribute : Input-port (-> Location) -> Attribute
+  (define (lex-attribute in pos)
+    (let ([start (pos)]
+          [name (lex-name in pos)])
+      (skip-space in)
+      (unless (eq? (read-char in) #\=)
+        (lex-error in pos "expected = in attribute ~a" name))
+      (skip-space in)
+      ;; more here - handle entites and disallow "<"
+      (let* ([delimiter (read-char-or-special in)]
+             [value (case delimiter
+                      [(#\' #\")
+                       (list->string
+                        (let read-more ()
+                          (let ([c (non-eof peek-char-or-special in pos)])
+                            (cond
+                              [(eq? c 'special)
+                               (lex-error in pos "attribute values cannot contain non-text values")]
+                              [(eq? c delimiter) (read-char in) null]
+                              [(eq? c #\&)
+                               (let ([entity (expand-entity (lex-entity in pos))])
+                                 (if (pcdata? entity)
+                                     (append (string->list (pcdata-string entity)) (read-more))
+                                     ;; more here - do something with user defined entites
+                                     (read-more)))]
+                              [else (read-char in) (cons c (read-more))]))))]
+                      [else (if (char? delimiter)
+                                (lex-error in pos "attribute values must be in ''s or in \"\"s")
+                                delimiter)])])
+        (make-attribute start (pos) name value))))
+  
+  ;; skip-space : Input-port -> Void
+  ;; deviation - should sometimes insist on at least one space
+  (define (skip-space in)
+    (let loop ()
+      (let ([c (peek-char-or-special in)])
+        (when (and (char? c)
+                   (char-whitespace? c))
           (read-char in)
-          (let ([data (case (peek-char in)
-                        [(#\#)
-                         (read-char in)
-                         (let ([n (case (peek-char in)
-                                    [(#\x) (read-char in)
-                                     (string->number (read-until #\; in pos) 16)]
-                                    [else (string->number (read-until #\; in pos))])])
-                           (unless (number? n)
-                             (lex-error in pos "malformed numeric entity"))
-                           n)]
-                        [else
-                         (begin0
-                           (lex-name in pos)
-                           (unless (eq? (read-char in) #\;)
-                             (lex-error in pos "expected ; at the end of an entity")))])])
-            (make-entity start (pos) data))))
-      
-      ; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Cdata | Pi | Comment
-      ; pre: the first char is a #\<
-      (define (lex-tag-cdata-pi-comment in pos)
-        (let ([start (pos)])
-          (read-char in)
-          (case (non-eof peek-char-or-special in pos)
-            [(#\!)
-             (read-char in)
-             (case (non-eof peek-char in pos)
-               [(#\-) (read-char in)
-                (unless (eq? (read-char-or-special in) #\-)
-                  (lex-error in pos "expected second - after <!-"))
-                (let ([data (lex-comment-contents in pos)])
-                  (unless (eq? (read-char in) #\>)
-                    (lex-error in pos "expected > to end comment (\"--\" can't appear in comments)"))
-                  ;(make-comment start (pos) data)
-                  (make-comment data))]
-               [(#\[) (read-char in)
-                (unless (string=? (read-string 6 in) "CDATA[")
-                  (lex-error in pos "expected CDATA following <["))
-                (let ([data (lex-cdata-contents in pos)])
-                  (make-cdata start (pos) (format "<![CDATA[~a]]>" data)))]
-               [else (skip-dtd in pos)
-                     (skip-space in)
-                     (unless (eq? (peek-char-or-special in) #\<)
-                       (lex-error in pos "expected pi, comment, or element after doctype"))
-                     (lex-tag-cdata-pi-comment in pos)])]
-            [(#\?) (read-char in)
-             (let ([name (lex-name in pos)])
-               (skip-space in)
-               (let ([data (lex-pi-data in pos)])
-                 (make-pi start (pos) name data)))]
-            [(#\/) (read-char in)
-             (let ([name (lex-name in pos)])
-               (skip-space in)
-               (unless (eq? (read-char-or-special in) #\>)
-                 (lex-error in pos "expected > to close ~a's end tag" name))
-               (make-end-tag start (pos) name))]
-            [else ; includes 'special, but lex-name will fail in that case
-             (let ([name (lex-name in pos)]
-                   [attrs (lex-attributes in pos)])
-               (skip-space in)
-               (case (read-char-or-special in)
-                 [(#\/)
-                  (unless (eq? (read-char in) #\>)
-                    (lex-error in pos "expected > to close empty element ~a" name))
-                  (make-element start (pos) name attrs null)]
-                 [(#\>) (make-start-tag start (pos) name attrs)]
-                 [else (lex-error in pos "expected / or > to close tag `~a'" name)]))])))
-      
-      ;; lex-attributes : Input-port (-> Location) -> (listof Attribute)
-      (define (lex-attributes in pos)
-        (sort (let loop ()
-                (skip-space in)
-                (cond [(name-start? (peek-char-or-special in))
-                       (cons (lex-attribute in pos) (loop))]
-                      [else null]))
-              (lambda (a b)
-                (let ([na (attribute-name a)]
-                      [nb (attribute-name b)])
-                  (cond
-                   [(eq? na nb) (lex-error in pos "duplicated attribute name ~a" na)]
-                   [else (string<? (symbol->string na) (symbol->string nb))])))))
-
-      ;; lex-attribute : Input-port (-> Location) -> Attribute
-      (define (lex-attribute in pos)
-        (let ([start (pos)]
-              [name (lex-name in pos)])
-          (skip-space in)
-          (unless (eq? (read-char in) #\=)
-            (lex-error in pos "expected = in attribute ~a" name))
-          (skip-space in)
-          ;; more here - handle entites and disallow "<"
-          (let* ([delimiter (read-char-or-special in)]
-                 [value (case delimiter
-                          [(#\' #\")
-                           (list->string
-                            (let read-more ()
-                              (let ([c (non-eof peek-char-or-special in pos)])
-                                (cond
-                                  [(eq? c 'special)
-                                   (lex-error in pos "attribute values cannot contain non-text values")]
-                                  [(eq? c delimiter) (read-char in) null]
-                                  [(eq? c #\&)
-                                   (let ([entity (expand-entity (lex-entity in pos))])
-                                     (if (pcdata? entity)
-                                         (append (string->list (pcdata-string entity)) (read-more))
-                                         ;; more here - do something with user defined entites
-                                         (read-more)))]
-                                  [else (read-char in) (cons c (read-more))]))))]
-                          [else (if (char? delimiter)
-                                    (lex-error in pos "attribute values must be in ''s or in \"\"s")
-                                    delimiter)])])
-            (make-attribute start (pos) name value))))
-      
-      ;; skip-space : Input-port -> Void
-      ;; deviation - should sometimes insist on at least one space
-      (define (skip-space in)
-        (let loop ()
-          (let ([c (peek-char-or-special in)])
-            (when (and (char? c)
-                       (char-whitespace? c))
-              (read-char in)
-              (loop)))))
-      
-      ;; lex-pcdata : Input-port (-> Location) -> Pcdata
-      ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec 
-      (define (lex-pcdata in pos)
-        (let ([start (pos)]
-              [data (let loop ()
-                      (let ([next (peek-char-or-special in)])
-                        (cond
-                          [(or (eof-object? next)
-			       (not (char? next))
-			       (eq? next #\&)
-			       (eq? next #\<))
-                           null]
-                          [(and (char-whitespace? next) (collapse-whitespace))
-                           (skip-space in)
-                           (cons #\space (loop))]
-                          [else (cons (read-char in) (loop))])))])
-          (make-pcdata start
-                       (pos)
-                       (list->string data))))
-      
-      ;; lex-name : Input-port (-> Location) -> Symbol
-      (define (lex-name in pos)
-        (let ([c (non-eof read-char-or-special in pos)])
-          (unless (name-start? c)
-            (lex-error in pos "expected name, received ~e" c))
-          (string->symbol
-           (list->string
-            (cons c (let lex-rest ()
-                      (let ([c (non-eof peek-char-or-special in pos)])
-                        (cond
-                         [(eq? c 'special)
-                          (lex-error in pos "names cannot contain non-text values")]
-                         [(name-char? c)
-                          (cons (read-char in) (lex-rest))]
-                         [else null]))))))))
-      
-      ;; skip-dtd : Input-port (-> Location) -> Void
-      (define (skip-dtd in pos)
-        (let skip ()
-          (case (non-eof read-char in pos)
-            [(#\') (read-until #\' in pos) (skip)]
-            [(#\") (read-until #\" in pos) (skip)]
-            [(#\<)
-             (case (non-eof read-char in pos)
-               [(#\!) (case (non-eof read-char in pos)
-                        [(#\-) (read-char in) (lex-comment-contents in pos) (read-char in) (skip)]
-                        [else (skip) (skip)])]
-               [(#\?) (lex-pi-data in pos) (skip)]
-               [else (skip) (skip)])]
-            [(#\>) (void)]
-            [else (skip)])))
-      
-      ;; name-start? : Char -> Bool
-      (define (name-start? ch)
-        (and (char? ch)
-             (or (char-alphabetic? ch)
-                 (eq? ch #\_)
-                 (eq? ch #\:))))
-      
-      ;; name-char? : Char -> Bool
-      (define (name-char? ch)
-        (and (char? ch)
-             (or (name-start? ch)
-                 (char-numeric? ch)
-                 (eq? ch #\.)
-                 (eq? ch #\-))))
-      
-      ;; read-until : Char Input-port (-> Location) -> String
-      ;; discards the stop character, too
-      (define (read-until char in pos)
+          (loop)))))
+  
+  ;; lex-pcdata : Input-port (-> Location) -> Pcdata
+  ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec 
+  (define (lex-pcdata in pos)
+    (let ([start (pos)]
+          [data (let loop ()
+                  (let ([next (peek-char-or-special in)])
+                    (cond
+                      [(or (eof-object? next)
+                           (not (char? next))
+                           (eq? next #\&)
+                           (eq? next #\<))
+                       null]
+                      [(and (char-whitespace? next) (collapse-whitespace))
+                       (skip-space in)
+                       (cons #\space (loop))]
+                      [else (cons (read-char in) (loop))])))])
+      (make-pcdata start
+                   (pos)
+                   (list->string data))))
+  
+  ;; lex-name : Input-port (-> Location) -> Symbol
+  (define (lex-name in pos)
+    (let ([c (non-eof read-char-or-special in pos)])
+      (unless (name-start? c)
+        (lex-error in pos "expected name, received ~e" c))
+      (string->symbol
+       (list->string
+        (cons c (let lex-rest ()
+                  (let ([c (non-eof peek-char-or-special in pos)])
+                    (cond
+                      [(eq? c 'special)
+                       (lex-error in pos "names cannot contain non-text values")]
+                      [(name-char? c)
+                       (cons (read-char in) (lex-rest))]
+                      [else null]))))))))
+  
+  ;; skip-dtd : Input-port (-> Location) -> Void
+  (define (skip-dtd in pos)
+    (let skip ()
+      (case (non-eof read-char in pos)
+        [(#\') (read-until #\' in pos) (skip)]
+        [(#\") (read-until #\" in pos) (skip)]
+        [(#\<)
+         (case (non-eof read-char in pos)
+           [(#\!) (case (non-eof read-char in pos)
+                    [(#\-) (read-char in) (lex-comment-contents in pos) (read-char in) (skip)]
+                    [else (skip) (skip)])]
+           [(#\?) (lex-pi-data in pos) (skip)]
+           [else (skip) (skip)])]
+        [(#\>) (void)]
+        [else (skip)])))
+  
+  ;; name-start? : Char -> Bool
+  (define (name-start? ch)
+    (and (char? ch)
+         (or (char-alphabetic? ch)
+             (eq? ch #\_)
+             (eq? ch #\:))))
+  
+  ;; name-char? : Char -> Bool
+  (define (name-char? ch)
+    (and (char? ch)
+         (or (name-start? ch)
+             (char-numeric? ch)
+             (eq? ch #\.)
+             (eq? ch #\-))))
+  
+  ;; read-until : Char Input-port (-> Location) -> String
+  ;; discards the stop character, too
+  (define (read-until char in pos)
+    (list->string
+     (let read-more ()
+       (let ([c (non-eof read-char in pos)])
+         (cond
+           [(eq? c char) null]
+           [else (cons c (read-more))])))))
+  
+  ;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Location) -> Char
+  (define (non-eof f in pos)
+    (let ([c (f in)])
+      (cond
+        [(eof-object? c) (lex-error in pos "unexpected eof")]
+        [else c])))
+  
+  ;; gen-read-until-string : String -> Input-port (-> Location) -> String
+  ;; uses Knuth-Morris-Pratt from
+  ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
+  ;; discards stop from input
+  (define (gen-read-until-string stop)
+    (let* ([len (string-length stop)]
+           [prefix (make-vector len 0)]
+           [fall-back
+            (lambda (k c)
+              (let ([k (let loop ([k k])
+                         (cond
+                           [(and (> k 0) (not (eq? (string-ref stop k) c)))
+                            (loop (vector-ref prefix (sub1 k)))]
+                           [else k]))])
+                (if (eq? (string-ref stop k) c)
+                    (add1 k)
+                    k)))])
+      (let init ([k 0] [q 1])
+        (when (< q len)
+          (let ([k (fall-back k (string-ref stop q))])
+            (vector-set! prefix q k)
+            (init k (add1 q)))))
+      ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
+      (lambda (in pos)
         (list->string
-         (let read-more ()
-           (let ([c (non-eof read-char in pos)])
-             (cond
-               [(eq? c char) null]
-               [else (cons c (read-more))])))))
-      
-      ;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Location) -> Char
-      (define (non-eof f in pos)
-        (let ([c (f in)])
-          (cond
-            [(eof-object? c) (lex-error in pos "unexpected eof")]
-            [else c])))
-      
-      ;; gen-read-until-string : String -> Input-port (-> Location) -> String
-      ;; uses Knuth-Morris-Pratt from
-      ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
-      ;; discards stop from input
-      (define (gen-read-until-string stop)
-        (let* ([len (string-length stop)]
-               [prefix (make-vector len 0)]
-               [fall-back
-                (lambda (k c)
-                  (let ([k (let loop ([k k])
-                             (cond
-                               [(and (> k 0) (not (eq? (string-ref stop k) c)))
-                                (loop (vector-ref prefix (sub1 k)))]
-                               [else k]))])
-                    (if (eq? (string-ref stop k) c)
-                        (add1 k)
-                        k)))])
-          (let init ([k 0] [q 1])
-            (when (< q len)
-              (let ([k (fall-back k (string-ref stop q))])
-                (vector-set! prefix q k)
-                (init k (add1 q)))))
-          ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
-          (lambda (in pos)
-            (list->string
-             (let/ec out
-               (let loop ([matched 0] [out out])
-                 (let* ([c (non-eof read-char in pos)]
-                        [matched (fall-back matched c)])
-                   (cond
-                     [(= matched len) (out null)]
-                     [(zero? matched) (cons c (let/ec out (loop matched out)))]
-                     [else (cons c (loop matched out))]))))))))
-      
-      ;; "-->" makes more sense, but "--" follows the spec.
-      (define lex-comment-contents (gen-read-until-string "--"))
-      (define lex-pi-data (gen-read-until-string "?>"))
-      (define lex-cdata-contents (gen-read-until-string "]]>"))
-      
-      ;; positionify : Input-port -> Input-port (-> Location)
-      ; This function predates port-count-lines! and port-next-location.
-      ; Otherwise I would have used those directly at the call sites.
-      (define (positionify in)
-        (port-count-lines! in)
-        (values
-         in
-         (lambda ()
-           (let-values ([(line column offset) (port-next-location in)])
-             (make-location line column offset)))))
-      
-      ;; locs : (listof (list number number))
-      (define-struct (exn:xml exn:fail:read) ())
-      
-      ;; lex-error : Input-port String (-> Location) TST* -> alpha
-      ;; raises a lexer error, using exn:xml
-      (define (lex-error in pos str . rest)
-        (let* ([the-pos (pos)]
-               [offset (location-offset the-pos)])
-          (raise
-           (make-exn:xml
-            (format "read-xml: lex-error: at position ~a: ~a"
-                    (format-source the-pos)
-                    (apply format str rest))
-            (current-continuation-marks)
-            (list
-             (make-srcloc (object-name in) #f #f offset 1))))))
-
-      ;; parse-error : (listof srcloc) (listof TST) *-> alpha
-      ;; raises a parsing error, using exn:xml
-      (define (parse-error src fmt . args)
-        (raise (make-exn:xml (string-append "read-xml: parse-error: "
-                                            (apply format fmt args))
-                             (current-continuation-marks)
-                             src)))
-
-      ;; format-source : Location -> string
-      ;; to format the source location for an error message
-      (define (format-source loc)
-        (if (location? loc)
-            (format "~a.~a/~a" (location-line loc) (location-char loc) (location-offset loc))
-            (format "~a" loc))))))
+         (let/ec out
+           (let loop ([matched 0] [out out])
+             (let* ([c (non-eof read-char in pos)]
+                    [matched (fall-back matched c)])
+               (cond
+                 [(= matched len) (out null)]
+                 [(zero? matched) (cons c (let/ec out (loop matched out)))]
+                 [else (cons c (loop matched out))]))))))))
+  
+  ;; "-->" makes more sense, but "--" follows the spec.
+  (define lex-comment-contents (gen-read-until-string "--"))
+  (define lex-pi-data (gen-read-until-string "?>"))
+  (define lex-cdata-contents (gen-read-until-string "]]>"))
+  
+  ;; positionify : Input-port -> Input-port (-> Location)
+  ; This function predates port-count-lines! and port-next-location.
+  ; Otherwise I would have used those directly at the call sites.
+  (define (positionify in)
+    (port-count-lines! in)
+    (values
+     in
+     (lambda ()
+       (let-values ([(line column offset) (port-next-location in)])
+         (make-location line column offset)))))
+  
+  ;; locs : (listof (list number number))
+  (define-struct (exn:xml exn:fail:read) ())
+  
+  ;; lex-error : Input-port String (-> Location) TST* -> alpha
+  ;; raises a lexer error, using exn:xml
+  (define (lex-error in pos str . rest)
+    (let* ([the-pos (pos)]
+           [offset (location-offset the-pos)])
+      (raise
+       (make-exn:xml
+        (format "read-xml: lex-error: at position ~a: ~a"
+                (format-source the-pos)
+                (apply format str rest))
+        (current-continuation-marks)
+        (list
+         (make-srcloc (object-name in) #f #f offset 1))))))
+  
+  ;; parse-error : (listof srcloc) (listof TST) *-> alpha
+  ;; raises a parsing error, using exn:xml
+  (define (parse-error src fmt . args)
+    (raise (make-exn:xml (string-append "read-xml: parse-error: "
+                                        (apply format fmt args))
+                         (current-continuation-marks)
+                         src)))
+  
+  ;; format-source : Location -> string
+  ;; to format the source location for an error message
+  (define (format-source loc)
+    (if (location? loc)
+        (format "~a.~a/~a" (location-line loc) (location-char loc) (location-offset loc))
+        (format "~a" loc))))
diff --git a/collects/xml/private/sig.ss b/collects/xml/private/sig.ss
index 69da82bb3d..17498e8355 100644
--- a/collects/xml/private/sig.ss
+++ b/collects/xml/private/sig.ss
@@ -1,62 +1,89 @@
+#lang scheme
 
-(module sig mzscheme
-  (require mzlib/unitsig)
+(define-signature xml-structs^
+  ((struct/ctc location ([line exact-nonnegative-integer?]
+                         [char exact-nonnegative-integer?]
+                         [offset exact-nonnegative-integer?]))
+   (struct/ctc source ([start (or/c location? symbol?)]
+                       [stop (or/c location? symbol?)]))
+   (struct/ctc comment ([text string?]))
+   (struct pcdata (string)) ; XXX needs parent
+   (struct cdata (string)) ; XXX needs parent
+   (struct/ctc document-type ([name symbol?]
+                              #;[external external-dtd?]
+                              ; XXX results in this error
+                              ;     ->: expected contract or a value that can be coerced into one, got #<undefined>
+                              ;     I presume that there is a letrec somewhere
+                              [external any/c]
+                              [inlined false/c]))
+   (struct/ctc document (#;[prolog prolog?] ; XXX same as above
+                         [prolog any/c]
+                         #;[element element?]
+                         [element any/c]
+                         #;[misc (listof (or/c comment? pi?))]
+                         [misc (listof any/c)]))
+   (struct/ctc prolog (#;[misc (listof (or/c comment? pi?))] ; XXX same as above
+                       [misc (listof any/c)]
+                       #;[dtd document-type?]
+                       [dtd any/c]
+                       #;[misc2 (listof (or/c comment? pi?))]
+                       [misc2 (listof any/c)]))
+   (struct/ctc external-dtd ([system string?]))
+   (struct external-dtd/public (public)) ; XXX needs parent
+   (struct external-dtd/system ()) ; XXX needs parent
+   (struct element (name attributes content)) ; XXX needs parent
+   (struct attribute (name value)) ; XXX needs parent
+   (struct pi (target-name instruction)) ; XXX needs parent
+   (struct entity (text)) ; XXX needs parent
+   (contracted
+    [content? (any/c . -> . boolean?)])))
 
-  (define-signature xml-structs^
-    ((struct location (line char offset))
-     (struct document (prolog element misc))
-     (struct comment (text))
-     (struct prolog (misc dtd misc2))
-     (struct document-type (name external inlined))
-     (struct external-dtd (system))
-     (struct external-dtd/public (public))
-     (struct external-dtd/system ())
-     (struct element (name attributes content))
-     (struct attribute (name value))
-     (struct pi (target-name instruction))
-     (struct source (start stop))
-     (struct pcdata (string))
-     (struct cdata (string))
-     (struct entity (text))
-     content?))
+(define-signature writer^
+  ((contracted
+    [write-xml ((any/c) (output-port?) . ->* . void?)]
+    [display-xml ((any/c) (output-port?) . ->* . void?)]
+    [write-xml/content ((any/c) (output-port?) . ->* . void?)]
+    [display-xml/content ((any/c) (output-port?) . ->* . void?)])
+   ; XXX I can't contract the above (well), because they refer to structs from xml-structs^
+   (contracted
+    [empty-tag-shorthand (parameter/c (or/c (symbols 'always 'never) (listof symbol?)))]
+    [html-empty-tags (listof symbol?)])))
 
-  (define-signature writer^
-    (write-xml
-      display-xml
-      write-xml/content
-      display-xml/content
-      empty-tag-shorthand
-      html-empty-tags))
+(define-signature reader^ 
+  ((contracted
+    [read-xml (() (input-port?) . ->* . any/c)]
+    [read-xml/element (() (input-port?) . ->* . any/c)]
+    [read-comments (parameter/c boolean?)]
+    [collapse-whitespace (parameter/c boolean?)])
+   ; XXX can't contract the above (well) because they refer to structs
+   ; XXX can't contract exn:xml beacuse of parent
+   (struct exn:xml ())))
 
-  (define-signature reader^ 
-    (read-xml
-     read-xml/element
-     read-comments
-     collapse-whitespace
-     (struct exn:xml ())))
+(define-signature xexpr^
+  ((struct exn:invalid-xexpr (code)) ; XXX needs parent
+   (contracted
+    [xexpr/c contract?]
+    [xexpr? (any/c . -> . boolean?)]
+    [xexpr->string (xexpr/c . -> . string?)]
+    [xml->xexpr (any/c . -> . xexpr/c)] ; XXX bad because of struct
+    [xexpr->xml (xexpr/c . -> . any/c)] ; XXX bad because of struct
+    [xexpr-drop-empty-attributes (parameter/c boolean?)]
+    [permissive? (parameter/c boolean?)]
+    [validate-xexpr (any/c . -> . (one-of/c #t))]
+    [correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)]
+    [xexpr-attribute? (any/c . -> . boolean?)]
+    [listof? ((any/c . -> . boolean?) any/c . -> . boolean?)]
+    [attribute->srep (any/c . -> . xexpr-attribute?)] ; XXX bad because of struct
+    [bcompose ((any/c any/c . -> . any/c) (any/c . -> . any/c) . -> . (any/c any/c . -> . any/c))]
+    [assoc-sort ((listof (list/c symbol? string?)) . -> . (listof (list/c symbol? string?)))])))
 
-  (define-signature xexpr^
-    (xml->xexpr
-      xexpr->xml
-      xexpr->string
-      xexpr-drop-empty-attributes
-      xexpr/c
-      xexpr?
-      permissive?
-      correct-xexpr?
-      validate-xexpr
-      (struct exn:invalid-xexpr (code))
-      xexpr-attribute?
-      listof?))
+(define-signature space^ 
+  ((contracted
+    ; XXX bad because of struct
+    [eliminate-whitespace ((listof symbol?) (boolean? . -> . boolean?) . -> . (any/c . -> . any/c))])))
 
-  (define-signature extra-xexpr^
-    ((open xexpr^) assoc-sort bcompose attribute->srep))
-
-  (define-signature space^ (eliminate-whitespace))
-
-  (provide xml-structs^
-	  writer^
-	  reader^
-	  xexpr^
-	  extra-xexpr^
-	  space^))
+(provide xml-structs^
+         writer^
+         reader^
+         xexpr^
+         space^)
diff --git a/collects/xml/private/space.ss b/collects/xml/private/space.ss
index dc7444623a..24e24b2891 100644
--- a/collects/xml/private/space.ss
+++ b/collects/xml/private/space.ss
@@ -1,39 +1,34 @@
+#lang scheme
+(require "sig.ss")
 
-(module space mzscheme
-  (require mzlib/unitsig
-	  mzlib/list)
-
-  (require "sig.ss")
-
-  (provide space@)
-
-  (define space@
-    (unit/sig space^
-      (import xml-structs^)
-      
-      ;; eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element
-      (define (eliminate-whitespace special eliminate-special?)
-	(letrec ([blank-it
-		  (lambda (el)
-		    (let ([name (element-name el)]
-			  [content (map (lambda (x)
-					  (if (element? x) (blank-it x) x))
-					(element-content el))])
-		      (make-element
-		       (source-start el)
-		       (source-stop el)
-		       name
-		       (element-attributes el)
-		       (cond
-			[(eliminate-special? (memq (element-name el) special))
-			 (filter (lambda (s)
-				   (not (and (pcdata? s)
-					     (or (all-blank (pcdata-string s))
-						 (error 'eliminate-blanks "Element <~a> is not allowed to contain text ~e" name (pcdata-string s))))))
-				 content)]
-			[else content]))))])
-	  blank-it))
-      
-      ;; all-blank : String -> Bool
-      (define (all-blank s) (andmap char-whitespace? (string->list s))))))
+(provide space@)
 
+(define-unit space@
+  (import xml-structs^)
+  (export space^)
+  
+  ;; eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element
+  (define (eliminate-whitespace special eliminate-special?)
+    (letrec ([blank-it
+              (lambda (el)
+                (let ([name (element-name el)]
+                      [content (map (lambda (x)
+                                      (if (element? x) (blank-it x) x))
+                                    (element-content el))])
+                  (make-element
+                   (source-start el)
+                   (source-stop el)
+                   name
+                   (element-attributes el)
+                   (cond
+                     [(eliminate-special? (and (memq (element-name el) special) #t))
+                      (filter (lambda (s)
+                                (not (and (pcdata? s)
+                                          (or (all-blank (pcdata-string s))
+                                              (error 'eliminate-blanks "Element <~a> is not allowed to contain text ~e" name (pcdata-string s))))))
+                              content)]
+                     [else content]))))])
+      blank-it))
+  
+  ;; all-blank : String -> Bool
+  (define (all-blank s) (andmap char-whitespace? (string->list s))))
diff --git a/collects/xml/private/structures.ss b/collects/xml/private/structures.ss
index e2bb74bd55..c939b0cf68 100644
--- a/collects/xml/private/structures.ss
+++ b/collects/xml/private/structures.ss
@@ -1,86 +1,71 @@
+#lang scheme
+(require "sig.ss")
 
-(module structures mzscheme
-  (require mzlib/unitsig)
+(provide xml-structs@)
 
-  (require "sig.ss")
-
-  (provide xml-structs@)
-
-  (define xml-structs@
-    (unit/sig xml-structs^
-      (import)
-      
-      ; Location = (make-location Nat Nat Nat) | Symbol
-      (define-struct location (line char offset))
-
-      ; Source = (make-source Location Location)
-      (define-struct source (start stop))
-      
-      ; Document = (make-document Prolog Element (listof Misc))
-      (define-struct document (prolog element misc))
-      
-      ; Prolog = (make-prolog (listof Misc) Document-type [Misc ...])
-      ; The Misc items after the Document-type are optional arguments to maintain
-      ; backward compatability with older versions of the XML library.
-      ;(define-struct prolog (misc dtd misc2))
-
-      (define-values (struct:prolog real-make-prolog prolog? access-prolog set-prolog!)
-        (make-struct-type 'prolog #f 3 0))
-      
-      (define (make-prolog misc dtd . misc2)
-        (real-make-prolog misc dtd misc2))
-      
-      (define prolog-misc (make-struct-field-accessor access-prolog 0 'misc))
-      (define set-prolog-misc! (make-struct-field-mutator set-prolog! 0 'misc))
-      
-      (define prolog-dtd (make-struct-field-accessor access-prolog 1 'dtd))
-      (define set-prolog-dtd! (make-struct-field-mutator set-prolog! 1 'dtd))
-      
-      (define prolog-misc2 (make-struct-field-accessor access-prolog 2 'misc2))
-      (define set-prolog-misc2! (make-struct-field-mutator set-prolog! 2 'misc2))
-      
-      ; Document-type = (make-document-type sym External-dtd #f)
-      ;               | #f
-      (define-struct document-type (name external inlined))
-      
-      ; External-dtd = (make-external-dtd/public str str)
-      ;              | (make-external-dtd/system str)
-      ;              | #f
-      (define-struct external-dtd (system))
-      (define-struct (external-dtd/public external-dtd) (public))
-      (define-struct (external-dtd/system external-dtd) ())
-      
-      ; Element = (make-element Location Location Symbol (listof Attribute) (listof Content))
-      (define-struct (element source) (name attributes content))
-      
-      ; Attribute = (make-attribute Location Location Symbol String)
-      (define-struct (attribute source) (name value))
-      
-      ; Pcdata = (make-pcdata Location Location String)
-      (define-struct (pcdata source) (string))
-      
-      ; Cdata = (make-cdata Location Location String)
-      (define-struct (cdata source) (string))
-      
-      ; Content = Pcdata  
-      ;         |  Element
-      ;         |  Entity
-      ;         |  Misc
-      ;         |  Cdata
-      
-      ; Misc = Comment
-      ;      |  Processing-instruction
-      
-      ; Entity = (make-entity Location Location (U Nat Symbol))
-      (define-struct (entity source) (text))
-      
-      ; Processing-instruction = (make-pi Location Location String String)
-      ; also represents XMLDecl
-      (define-struct (pi source) (target-name instruction))
-      
-      ; Comment = (make-comment String)
-      (define-struct comment (text))
-      
-      ; content? : TST -> Bool
-      (define (content? x)
-	(or (pcdata? x) (element? x) (entity? x) (comment? x) (pi? x))))))
+(define-unit xml-structs@
+  (import)
+  (export xml-structs^)
+  
+  ; Location = (make-location Nat Nat Nat) | Symbol
+  (define-struct location (line char offset))
+  
+  ; Source = (make-source Location Location)
+  (define-struct source (start stop))
+  
+  ; Document = (make-document Prolog Element (listof Misc))
+  (define-struct document (prolog element misc))
+  
+  ; Prolog = (make-prolog (listof Misc) Document-type (listof Misc))
+  (define-struct prolog (misc dtd misc2))
+  
+  ; Document-type = (make-document-type sym External-dtd #f)
+  ;               | #f
+  (define-struct document-type (name external inlined))
+  
+  ; External-dtd = (make-external-dtd/public str str)
+  ;              | (make-external-dtd/system str)
+  ;              | #f
+  (define-struct external-dtd (system))
+  (define-struct (external-dtd/public external-dtd) (public))
+  (define-struct (external-dtd/system external-dtd) ())
+  
+  ; Element = (make-element Location Location Symbol (listof Attribute) (listof Content))
+  (define-struct (element source) (name attributes content))
+  
+  ; Attribute = (make-attribute Location Location Symbol String)
+  (define-struct (attribute source) (name value))
+  
+  ; Pcdata = (make-pcdata Location Location String)
+  (define-struct (pcdata source) (string))
+  
+  ; Cdata = (make-cdata Location Location String)
+  (define-struct (cdata source) (string))
+  
+  ; Content = Pcdata  
+  ;         |  Element
+  ;         |  Entity
+  ;         |  Misc
+  ;         |  Cdata
+  
+  ; Misc = Comment
+  ;      |  Processing-instruction
+  
+  ; Entity = (make-entity Location Location (U Nat Symbol))
+  (define-struct (entity source) (text))
+  
+  ; Processing-instruction = (make-pi Location Location String String)
+  ; also represents XMLDecl
+  (define-struct (pi source) (target-name instruction))
+  
+  ; Comment = (make-comment String)
+  (define-struct comment (text))
+  
+  ; content? : TST -> Bool
+  (define (content? x)
+    (or (pcdata? x) 
+        (element? x)
+        (entity? x)
+        (comment? x)
+        (cdata? x)
+        (pi? x))))
diff --git a/collects/xml/private/syntax.ss b/collects/xml/private/syntax.ss
index 222833f99f..6b03e9e91f 100644
--- a/collects/xml/private/syntax.ss
+++ b/collects/xml/private/syntax.ss
@@ -1,213 +1,212 @@
-(module syntax mzscheme
-  (provide syntax-structs@)
-  (require mzlib/unitsig
-           "sig.ss")
+#lang scheme
+(require "sig.ss")
+
+; to make error-raising functions named like structure mutators
+(define-syntax (struct! stx)
+  (syntax-case stx ()
+    [(struct-src name (field ...))
+     (with-syntax ([struct:name (datum->syntax
+                                 (syntax name)
+                                 (string->symbol (string-append "struct:" (symbol->string (syntax->datum (syntax name))))))]
+                   [(setter-name ...)
+                    (let ([struct-name
+                           (symbol->string (syntax->datum (syntax name)))])
+                      (map (lambda (field-name)
+                             (datum->syntax
+                              field-name
+                              (string->symbol
+                               (string-append
+                                "set-"
+                                struct-name
+                                "-"
+                                (symbol->string (syntax->datum field-name))
+                                "!"))))
+                           (syntax->list (syntax (field ...)))))])
+       (syntax
+        (begin
+          (define struct:name void)
+          (define (setter-name s v)
+            (error (quote setter-name) "cannot mutate XML syntax"))
+          ...)))]))
+
+(provide syntax-structs@)
+(define-unit syntax-structs@
+  (import)
+  (export xml-structs^)
   
-  ; to make error-raising functions named like structure mutators
-  (define-syntax (struct! stx)
-    (syntax-case stx ()
-      [(struct-src name (field ...))
-       (with-syntax ([struct:name (datum->syntax-object
-                                   (syntax name)
-                                   (string->symbol (string-append "struct:" (symbol->string (syntax-object->datum (syntax name))))))]
-                     [(setter-name ...)
-                      (let ([struct-name
-                             (symbol->string (syntax-object->datum (syntax name)))])
-                        (map (lambda (field-name)
-                               (datum->syntax-object
-                                field-name
-                                (string->symbol
-                                 (string-append
-                                  "set-"
-                                  struct-name
-                                  "-"
-                                  (symbol->string (syntax-object->datum field-name))
-                                  "!"))))
-                             (syntax->list (syntax (field ...)))))])
-         (syntax
-          (begin
-            (define struct:name void)
-            (define (setter-name s v)
-              (error (quote setter-name) "cannot mutate XML syntax"))
-            ...)))]))
+  ; The locations from the two sets of structures shouldn't mingle, so I'm
+  ; re-defining the location structure.  Maybe this is not a good idea, but I
+  ; think it's okay.
+  (define-struct location (line char offset))
+  (define-struct source (start stop))
   
-  (define syntax-structs@
-    (unit/sig xml-structs^
-      (import)
-      
-      ; The locations from the two sets of structures shouldn't mingle, so I'm
-      ; re-defining the location structure.  Maybe this is not a good idea, but I
-      ; think it's okay.
-      (define-struct location (line char offset))
-      (define-struct source (start stop))
-      
-      ; make-document : prolog element ? -> document
-      (define (make-document p e ?) e)
-      
-      ; make-prolog : ? #f -> prolog
-      (define (make-prolog ? ??) #f)
-      
-      ; make-element : src src sym (listof attribute) (listof content) -> element
-      (define (make-element from to name attrs content)
-        (wrap (list* name attrs content) from to))
-      
-      ; make-pcdata : src src str -> pcdata
-      (define (make-pcdata from to x)
-        (wrap x from to))
-      
-      ; make-cdata : src src str -> cdata
-      (define (make-cdata from to x)
-        (wrap x from to))
-      
-      ; make-entity : src src (U sym num) -> entity
-      (define (make-entity from to entity)
-        (wrap entity from to))
-      
-      ; make-comment : str -> comment
-      ; There is no syntax object representation for comments
-      (define (make-comment x) #f)
-      
-      ; make-pi : src src sym str -> pi
-      ; There's not really a syntax object representation for pi's either
-      (define (make-pi from to name val) #f)
-      
-      ; make-attribute : src src sym str -> attribute
-      (define (make-attribute from to name val)
-        (wrap (list name val) from to))
-      
-      (define (make-document-type . x) #f)
-      (define (make-external-dtd . x) #f)
-      (define (make-external-dtd/public . x) #f)
-      (define (make-external-dtd/system . x) #f)
-      
-      ; wrap : tst src src -> syntax
-      (define (wrap x from to)
-        (datum->syntax-object #f x (position from to)))
-      
-      ; position : src src -> (list #f nat nat nat nat)
-      (define (position from to)
-        (let ([start-offset (location-offset from)])
-          (list #f (location-line from) (location-char from) start-offset
-                (- (location-offset to) start-offset))))
-      
-      ; : syntax -> syntax
-      (define (attribute-name a) (car (syntax->list a)))
-      (define (attribute-value a) (cadr (syntax->list a)))
-      
-      ; : syntax -> syntax
-      (define (element-name e) (car (syntax->list e)))
-      (define (element-attributes e) (cadr (syntax->list e)))
-      (define (element-content e) (cddr (syntax->list e)))
-      
-      (define (entity-text e) (syntax-e e))
-      
-      (define (pcdata-string x) (syntax-e x))
-      (define (cdata-string x) (syntax-e x))
-      
-      (define (comment-text c)
-        (error 'comment-text "expected a syntax representation of an XML comment, received ~e" c))
-      ; conflate documents with their root elements
-      (define (document-element d) d)
-      ; more here - spoof document pieces better?
-      (define (document-misc d) null)
-      (define (document-prolog d) null)
-      
-      (define (document-type-external dtd)
-        (error 'document-type-external "expected a dtd, given ~e" dtd))
-      
-      (define (document-type-inlined dtd)
-        (error 'document-type-inlined "expected a dtd, given ~e" dtd))
-      
-      (define (document-type-name dtd)
-        (error 'document-type-name "expected a dtd, given ~e" dtd))
-      
-      (define (external-dtd-system x)
-        (error 'external-dtd-system "expected an external dtd, given ~e" x))
-      
-      (define (external-dtd/public-public x)
-        (error 'external-dtd/public-public "expected an external dtd, given ~e" x))
-      
-      (define (pi-instruction x)
-        (error 'pi-instruction "expected a pi, given ~e" x))
-      
-      (define (pi-target-name x)
-        (error 'pi-target-name "expected a pi, given ~e" x))
-      
-      (define (prolog-dtd x)
-        (error 'prolog-dtd "expected a prolog, given ~e" x))
-      
-      (define (prolog-misc x)
-        (error 'prolog-misc "expected a prolog, given ~e" x))
-      
-      (define (prolog-misc2 x)
-        (error 'prolog-misc2 "expected a prolog, given ~e" x))
-      
-      ; : tst -> bool
-      (define (attribute? a)
-        (and (syntax? a)
-             (let ([x (syntax-object->datum a)])
-               (and (pair? x) (symbol? (car x))
-                    (pair? (cdr x)) (string? (cadr x))
-                    (null? (cddr x))))))
-      
-      
-      ; : tst -> bool
-      (define (comment? x) #f)
-      
-      ; : tst -> bool
-      (define (content? x)
-        (and (syntax? x)
-             (or (string? (syntax-object->datum x))
-                 (element? x))))
-      
-      ; : tst -> bool
-      (define (element? x)
-        (and (syntax? x)
-             (let ([e (syntax-e x)])
-               (and (pair? e) (symbol? (car e))
-                    (pair? (cdr e)) (list? (cadr e))
-                    (andmap attribute? (cadr e))
-                    (list? (cddr e))
-                    (andmap content? (cddr e))))))
-      
-      ; : tst -> bool
-      (define document? element?)
-      
-      ; : tst -> bool
-      (define (document-type? x) #f)
-      
-      ; : tst -> bool
-      (define (external-dtd/public? x) #f)
-      (define (external-dtd/system? x) #f)
-      (define (external-dtd? x) #f)
-      
-      (define (prolog? x) #f)
-      (define (pi? x) #f)
-      
-      ; : tst -> bool
-      (define (pcdata? x)
-        (and (syntax? x) (string (syntax-e x))))
-      (define (cdata? x)
-        (and (syntax? x) (string (syntax-e x))))
-      
-      ; : tst -> bool
-      (define (entity? x)
-        (and (syntax? x) (let ([r (syntax-e x)]) (or (symbol? r) (number? r)))))
-      
-      ;(struct! location (line char offset))
-      (struct! document (prolog element misc))
-      (struct! comment (text))
-      (struct! prolog (misc dtd misc2))
-      (struct! document-type (name external inlined))
-      (struct! external-dtd (system))
-      (struct! external-dtd/public (public))
-      (struct! external-dtd/system ())
-      (struct! element (name attributes content))
-      (struct! attribute (name value))
-      (struct! pi (target-name instruction))
-      ;(struct! source (start stop))
-      (struct! pcdata (string))
-      (struct! cdata (string))
-      (struct! entity (text))
-      
-      )))
+  ; make-document : prolog element ? -> document
+  (define (make-document p e ?) e)
+  
+  ; make-prolog : (listof Misc) Document-type (listof Misc) -> prolog
+  (define (make-prolog misc dtd misc2) #f)
+  
+  ; make-element : src src sym (listof attribute) (listof content) -> element
+  (define (make-element from to name attrs content)
+    (wrap (list* name attrs content) from to))
+  
+  ; make-pcdata : src src str -> pcdata
+  (define (make-pcdata from to x)
+    (wrap x from to))
+  
+  ; make-cdata : src src str -> cdata
+  (define (make-cdata from to x)
+    (wrap x from to))
+  
+  ; make-entity : src src (U sym num) -> entity
+  (define (make-entity from to entity)
+    (wrap entity from to))
+  
+  ; make-comment : str -> comment
+  ; There is no syntax object representation for comments
+  (define (make-comment x) #f)
+  
+  ; make-pi : src src sym str -> pi
+  ; There's not really a syntax object representation for pi's either
+  (define (make-pi from to name val) #f)
+  
+  ; make-attribute : src src sym str -> attribute
+  (define (make-attribute from to name val)
+    (wrap (list name val) from to))
+  
+  (define (make-document-type . x) #f)
+  (define (make-external-dtd . x) #f)
+  (define (make-external-dtd/public . x) #f)
+  (define (make-external-dtd/system . x) #f)
+  
+  ; wrap : tst src src -> syntax
+  (define (wrap x from to)
+    (datum->syntax #f x (position from to)))
+  
+  ; position : src src -> (list #f nat nat nat nat)
+  (define (position from to)
+    (let ([start-offset (location-offset from)])
+      (list #f (location-line from) (location-char from) start-offset
+            (- (location-offset to) start-offset))))
+  
+  ; : syntax -> syntax
+  (define (attribute-name a) (car (syntax->list a)))
+  (define (attribute-value a) (cadr (syntax->list a)))
+  
+  ; : syntax -> syntax
+  (define (element-name e) (car (syntax->list e)))
+  (define (element-attributes e) (cadr (syntax->list e)))
+  (define (element-content e) (cddr (syntax->list e)))
+  
+  (define (entity-text e) (syntax-e e))
+  
+  (define (pcdata-string x) (syntax-e x))
+  (define (cdata-string x) (syntax-e x))
+  
+  (define (comment-text c)
+    (error 'comment-text "expected a syntax representation of an XML comment, received ~e" c))
+  ; conflate documents with their root elements
+  (define (document-element d) d)
+  ; more here - spoof document pieces better?
+  (define (document-misc d) null)
+  (define (document-prolog d) null)
+  
+  (define (document-type-external dtd)
+    (error 'document-type-external "expected a dtd, given ~e" dtd))
+  
+  (define (document-type-inlined dtd)
+    (error 'document-type-inlined "expected a dtd, given ~e" dtd))
+  
+  (define (document-type-name dtd)
+    (error 'document-type-name "expected a dtd, given ~e" dtd))
+  
+  (define (external-dtd-system x)
+    (error 'external-dtd-system "expected an external dtd, given ~e" x))
+  
+  (define (external-dtd/public-public x)
+    (error 'external-dtd/public-public "expected an external dtd, given ~e" x))
+  
+  (define (pi-instruction x)
+    (error 'pi-instruction "expected a pi, given ~e" x))
+  
+  (define (pi-target-name x)
+    (error 'pi-target-name "expected a pi, given ~e" x))
+  
+  (define (prolog-dtd x)
+    (error 'prolog-dtd "expected a prolog, given ~e" x))
+  
+  (define (prolog-misc x)
+    (error 'prolog-misc "expected a prolog, given ~e" x))
+  
+  (define (prolog-misc2 x)
+    (error 'prolog-misc2 "expected a prolog, given ~e" x))
+  
+  ; : tst -> bool
+  (define (attribute? a)
+    (and (syntax? a)
+         (let ([x (syntax->datum a)])
+           (and (pair? x) (symbol? (car x))
+                (pair? (cdr x)) (string? (cadr x))
+                (null? (cddr x))))))
+  
+  
+  ; : tst -> bool
+  (define (comment? x) #f)
+  
+  ; : tst -> bool
+  (define (content? x)
+    (and (syntax? x)
+         (or (string? (syntax->datum x))
+             (element? x))))
+  
+  ; : tst -> bool
+  (define (element? x)
+    (and (syntax? x)
+         (let ([e (syntax-e x)])
+           (and (pair? e) (symbol? (car e))
+                (pair? (cdr e)) (list? (cadr e))
+                (andmap attribute? (cadr e))
+                (list? (cddr e))
+                (andmap content? (cddr e))))))
+  
+  ; : tst -> bool
+  (define document? element?)
+  
+  ; : tst -> bool
+  (define (document-type? x) #f)
+  
+  ; : tst -> bool
+  (define (external-dtd/public? x) #f)
+  (define (external-dtd/system? x) #f)
+  (define (external-dtd? x) #f)
+  
+  (define (prolog? x) #f)
+  (define (pi? x) #f)
+  
+  ; : tst -> bool
+  (define (pcdata? x)
+    (and (syntax? x) (string (syntax-e x))))
+  (define (cdata? x)
+    (and (syntax? x) (string (syntax-e x))))
+  
+  ; : tst -> bool
+  (define (entity? x)
+    (and (syntax? x) (let ([r (syntax-e x)]) (or (symbol? r) (number? r)))))
+    
+  ;(struct! location (line char offset))
+  (struct! document (prolog element misc))
+  (struct! comment (text))
+  (struct! prolog (misc dtd misc2))
+  (struct! document-type (name external inlined))
+  (struct! external-dtd (system))
+  (struct! external-dtd/public (public))
+  (struct! external-dtd/system ())
+  (struct! element (name attributes content))
+  (struct! attribute (name value))
+  (struct! pi (target-name instruction))
+  ;(struct! source (start stop))
+  (struct! pcdata (string))
+  (struct! cdata (string))
+  (struct! entity (text))
+  
+  )
diff --git a/collects/xml/private/writer.ss b/collects/xml/private/writer.ss
index c04aa39da6..f9e364f7c7 100644
--- a/collects/xml/private/writer.ss
+++ b/collects/xml/private/writer.ss
@@ -1,174 +1,167 @@
+#lang scheme
+(require "sig.ss")
 
-(module writer mzscheme
-  (require mzlib/unitsig
-           mzlib/list
-	   mzlib/string
-           mzlib/etc
-           (only scheme/base for for/fold in-list log-error))
+(provide writer@)
+
+(define-unit writer@
+  (import xml-structs^)
+  (export writer^)
   
-  (require "sig.ss")
+  ;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol))
+  (define empty-tag-shorthand
+    (make-parameter 'always
+                    (lambda (x)
+                      (if (or (eq? x 'always) (eq? x 'never) (and (list? x) (andmap symbol? x)))
+                          x
+                          (error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~e" x)))))
   
-  (provide writer@)
+  (define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area))
   
-  (define writer@
-    (unit/sig writer^
-      (import xml-structs^)
-      
-      ;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol))
-      (define empty-tag-shorthand
-	(make-parameter 'always
-			(lambda (x)
-			  (if (or (eq? x 'always) (eq? x 'never) (and (list? x) (andmap symbol? x)))
-			      x
-			      (error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~e" x)))))
-      
-      (define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area))
-      
-      ;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void
-      (define (gen-write/display-xml/content dent)
-	(opt-lambda (c [out (current-output-port)]) (write-xml-content c 0 dent out)))
-      
-      ;; indent : Nat Output-port -> Void
-      (define (indent n out)
-	(newline out)
-	(let loop ([n n])
-	  (unless (zero? n)
-	    (display #\space out)
-	    (loop (sub1 n)))))
-      
-      ;; write-xml/content : Content [Output-port] -> Void
-      (define write-xml/content (gen-write/display-xml/content void))
-      
-      ;; display-xml/content : Content [Output-port] -> Void
-      (define display-xml/content (gen-write/display-xml/content indent))
-      
-      ;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void
-      (define (gen-write/display-xml output-content)
-	(opt-lambda (doc [out (current-output-port)])
-          (let ([prolog (document-prolog doc)])
-            (display-outside-misc (prolog-misc prolog) out)
-            (display-dtd (prolog-dtd prolog) out)
-            (display-outside-misc (prolog-misc2 prolog) out))
-          (output-content (document-element doc) out)
-          (display-outside-misc (document-misc doc) out)))
-      
-      ; display-dtd : document-type oport -> void
-      (define (display-dtd dtd out)
-        (when dtd
-          (fprintf out "<!DOCTYPE ~a" (document-type-name dtd))
-          (let ([external (document-type-external dtd)])
-            (cond
-              [(external-dtd/public? external)
-               (fprintf out " PUBLIC \"~a\" \"~a\""
-                        (external-dtd/public-public external)
-                        (external-dtd-system external))]
-              [(external-dtd/system? external)
-               (fprintf out " SYSTEM \"~a\"" (external-dtd-system external))]
-              [(not external) (void)]))
-          (display ">" out)
-          (newline out)))
-      
-      ;; write-xml : Document [Output-port] -> Void
-      (define write-xml (gen-write/display-xml write-xml/content))
-      
-      ;; display-xml : Document [Output-port] -> Void
-      (define display-xml (gen-write/display-xml display-xml/content))
-      
-      ;; display-outside-misc : (listof Misc) Output-port -> Void
-      (define (display-outside-misc misc out)
-	(for-each (lambda (x)
-		    ((cond
-                       [(comment? x) write-xml-comment]
-                       [(pi? x) write-xml-pi]) x 0 void out)
-		    (newline out))
-		  misc))
-      
-      ;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void
-      (define (write-xml-content el over dent out)
-	((cond
-           [(element? el) write-xml-element]
-           [(pcdata? el) write-xml-pcdata]
-           [(cdata? el) write-xml-cdata]
-           [(entity? el) write-xml-entity]
-           [(comment? el) write-xml-comment]
-           [(pi? el) write-xml-pi]
-           [else (error 'write-xml-content "received ~e" el)])
-	 el over dent out))
-      
-      ;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void
-      (define (write-xml-element el over dent out)
-	(let* ([name (element-name el)]
-	       [start (lambda (str) 
-                        (write-xml-base str over dent out)
-                        (display name out))]
-	       [content (element-content el)])
-	  (start "<")
-          (for ([att (in-list (element-attributes el))])
-            (fprintf out " ~a=\"~a\"" (attribute-name att)
-                     (escape (attribute-value att) escape-attribute-table)))
-	  (if (and (null? content)
-		   (let ([short (empty-tag-shorthand)])
-		     (case short
-		       [(always) #t]
-		       [(never) #f]
-		       [else (memq (lowercase-symbol name) short)])))
-	      (display " />" out)
-	      (begin
-		(display ">" out)
-                (for ([c (in-list content)])
-                  (write-xml-content c (incr over) dent out))
-		(start "</")
-		(display ">" out)))))
-
-      ; : sym -> sym
-      (define lowercases (make-hash-table 'weak))
-      (define (lowercase-symbol x)
-        (or (hash-table-get lowercases x #f)
-            (let ([s (symbol->string x)])
-              (let ([s (string->symbol (string-downcase s))])
-                (hash-table-put! lowercases x s)
-                s))))
-      
-      ;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void
-      (define (write-xml-base el over dent out)
-	(dent over out)
-	(display el out))
-      
-      ;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
-      (define (write-xml-pcdata str over dent out)
-	(write-xml-base (escape (pcdata-string str) escape-table) over dent out))
-
-      ;; write-xml-cdata : Cdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
-      (define (write-xml-cdata cdata over dent out)
-        ;; XXX: Different kind of quote is needed, for assume the user includes the <![CDATA[...]]> with proper quoting
-        (write-xml-base (format "~a" (cdata-string cdata)) over dent out))
-      
-      ;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void
-      (define (write-xml-pi pi over dent out)
-	(write-xml-base (format "<?~a ~a?>" (pi-target-name pi) (pi-instruction pi)) over dent out))
-      
-      ;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void
-      (define (write-xml-comment comment over dent out)
-	(write-xml-base (format "<!--~a-->" (comment-text comment)) over dent out))
-      
-      ;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void
-      (define (write-xml-entity entity over dent out)
-	(let ([n (entity-text entity)])
-	  (fprintf out (if (number? n) "&#~a;" "&~a;") n)))
-      
-      (define escape-table #rx"[<>&]")
-      (define escape-attribute-table #rx"[<>&\"]")
-
-      (define (replace-escaped s)
-        (case (string-ref s 0)
-          [(#\<) "&lt;"]
-          [(#\>) "&gt;"]
-          [(#\&) "&amp;"]
-          [(#\") "&quot;"]))
-      
-      ;; escape : String -> String
-      (define (escape x table)
-        (regexp-replace* table x replace-escaped))
-      
-      ;; incr : Nat -> Nat
-      (define (incr n) (+ n 2)))))
+  ;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void
+  (define (gen-write/display-xml/content dent)
+    (lambda (c [out (current-output-port)]) (write-xml-content c 0 dent out)))
+  
+  ;; indent : Nat Output-port -> Void
+  (define (indent n out)
+    (newline out)
+    (let loop ([n n])
+      (unless (zero? n)
+        (display #\space out)
+        (loop (sub1 n)))))
+  
+  ;; write-xml/content : Content [Output-port] -> Void
+  (define write-xml/content (gen-write/display-xml/content void))
+  
+  ;; display-xml/content : Content [Output-port] -> Void
+  (define display-xml/content (gen-write/display-xml/content indent))
+  
+  ;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void
+  (define (gen-write/display-xml output-content)
+    (lambda (doc [out (current-output-port)])
+      (let ([prolog (document-prolog doc)])
+        (display-outside-misc (prolog-misc prolog) out)
+        (display-dtd (prolog-dtd prolog) out)
+        (display-outside-misc (prolog-misc2 prolog) out))
+      (output-content (document-element doc) out)
+      (display-outside-misc (document-misc doc) out)))
+  
+  ; display-dtd : document-type oport -> void
+  (define (display-dtd dtd out)
+    (when dtd
+      (fprintf out "<!DOCTYPE ~a" (document-type-name dtd))
+      (let ([external (document-type-external dtd)])
+        (cond
+          [(external-dtd/public? external)
+           (fprintf out " PUBLIC \"~a\" \"~a\""
+                    (external-dtd/public-public external)
+                    (external-dtd-system external))]
+          [(external-dtd/system? external)
+           (fprintf out " SYSTEM \"~a\"" (external-dtd-system external))]
+          [(not external) (void)]))
+      (display ">" out)
+      (newline out)))
+  
+  ;; write-xml : Document [Output-port] -> Void
+  (define write-xml (gen-write/display-xml write-xml/content))
+  
+  ;; display-xml : Document [Output-port] -> Void
+  (define display-xml (gen-write/display-xml display-xml/content))
+  
+  ;; display-outside-misc : (listof Misc) Output-port -> Void
+  (define (display-outside-misc misc out)
+    (for-each (lambda (x)
+                ((cond
+                   [(comment? x) write-xml-comment]
+                   [(pi? x) write-xml-pi]) x 0 void out)
+                (newline out))
+              misc))
+  
+  ;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+  (define (write-xml-content el over dent out)
+    ((cond
+       [(element? el) write-xml-element]
+       [(pcdata? el) write-xml-pcdata]
+       [(cdata? el) write-xml-cdata]
+       [(entity? el) write-xml-entity]
+       [(comment? el) write-xml-comment]
+       [(pi? el) write-xml-pi]
+       [else (error 'write-xml-content "received ~e" el)])
+     el over dent out))
+  
+  ;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+  (define (write-xml-element el over dent out)
+    (let* ([name (element-name el)]
+           [start (lambda (str) 
+                    (write-xml-base str over dent out)
+                    (display name out))]
+           [content (element-content el)])
+      (start "<")
+      (for ([att (in-list (element-attributes el))])
+        (fprintf out " ~a=\"~a\"" (attribute-name att)
+                 (escape (attribute-value att) escape-attribute-table)))
+      (if (and (null? content)
+               (let ([short (empty-tag-shorthand)])
+                 (case short
+                   [(always) #t]
+                   [(never) #f]
+                   [else (memq (lowercase-symbol name) short)])))
+          (display " />" out)
+          (begin
+            (display ">" out)
+            (for ([c (in-list content)])
+              (write-xml-content c (incr over) dent out))
+            (start "</")
+            (display ">" out)))))
+  
+  ; : sym -> sym
+  (define lowercases (make-weak-hash))
+  (define (lowercase-symbol x)
+    (or (hash-ref lowercases x #f)
+        (let ([s (symbol->string x)])
+          (let ([s (string->symbol (string-downcase s))])
+            (hash-set! lowercases x s)
+            s))))
+  
+  ;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+  (define (write-xml-base el over dent out)
+    (dent over out)
+    (display el out))
+  
+  ;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+  (define (write-xml-pcdata str over dent out)
+    (write-xml-base (escape (pcdata-string str) escape-table) over dent out))
+  
+  ;; write-xml-cdata : Cdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+  (define (write-xml-cdata cdata over dent out)
+    ;; XXX: Different kind of quote is needed, for assume the user includes the <![CDATA[...]]> with proper quoting
+    (write-xml-base (format "~a" (cdata-string cdata)) over dent out))
+  
+  ;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+  (define (write-xml-pi pi over dent out)
+    (write-xml-base (format "<?~a ~a?>" (pi-target-name pi) (pi-instruction pi)) over dent out))
+  
+  ;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+  (define (write-xml-comment comment over dent out)
+    (write-xml-base (format "<!--~a-->" (comment-text comment)) over dent out))
+  
+  ;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void
+  (define (write-xml-entity entity over dent out)
+    (let ([n (entity-text entity)])
+      (fprintf out (if (number? n) "&#~a;" "&~a;") n)))
+  
+  (define escape-table #rx"[<>&]")
+  (define escape-attribute-table #rx"[<>&\"]")
+  
+  (define (replace-escaped s)
+    (case (string-ref s 0)
+      [(#\<) "&lt;"]
+      [(#\>) "&gt;"]
+      [(#\&) "&amp;"]
+      [(#\") "&quot;"]))
+  
+  ;; escape : String -> String
+  (define (escape x table)
+    (regexp-replace* table x replace-escaped))
+  
+  ;; incr : Nat -> Nat
+  (define (incr n) (+ n 2)))
diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss
index 05ec921117..c2c6954365 100644
--- a/collects/xml/private/xexpr.ss
+++ b/collects/xml/private/xexpr.ss
@@ -1,231 +1,228 @@
-(module xexpr mzscheme
-  (require mzlib/unitsig
-           mzlib/list
-           scheme/contract
-           scheme/pretty
-           mzlib/etc)
+#lang scheme
+(require scheme/pretty)
+(require "sig.ss")
+
+(provide xexpr@)
+
+(define-unit xexpr@
+  (import xml-structs^ writer^)
+  (export xexpr^)
+  ;; Xexpr ::= String
+  ;;        |  (list* Symbol (listof Attribute-srep) (listof Xexpr))
+  ;;        |  (cons Symbol (listof Xexpr))
+  ;;        |  Symbol
+  ;;        |  Nat
+  ;;        |  Comment
+  ;;        |  Processing-instruction
+  ;;        |  Cdata
+  ;; Attribute-srep ::= (list Symbol String)
   
-  (require "sig.ss")
+  ;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts.
   
-  (provide xexpr@)
+  ;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a))
+  (define (assoc-sort to-sort)
+    (sort to-sort (bcompose string<? (compose symbol->string car))))
   
-  (define xexpr@
-    (unit/sig extra-xexpr^
-      (import xml-structs^ writer^)
-      ;; Xexpr ::= String
-      ;;        |  (list* Symbol (listof Attribute-srep) (listof Xexpr))
-      ;;        |  (cons Symbol (listof Xexpr))
-      ;;        |  Symbol
-      ;;        |  Nat
-      ;;        |  Comment
-      ;;        |  Processing-instruction
-      ;;        |  Cdata
-      ;; Attribute-srep ::= (list Symbol String)
-      
-      ;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts.
-      
-      ;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a))
-      (define (assoc-sort to-sort)
-        (sort to-sort (bcompose string<? (compose symbol->string car))))
-      
-      (define xexpr-drop-empty-attributes (make-parameter #f))
-      
-      (define xexpr/c 
-        (make-proj-contract
-         'xexpr?
-         (lambda (pos neg src-info name)
-           (lambda (val)
-             (with-handlers ([exn:invalid-xexpr?
-                              (lambda (exn)
-                                (raise-contract-error
-                                 val
-                                 src-info
-                                 pos
-                                 name
-                                 "Not an Xexpr. ~a~n~nContext:~n~a"
-                                 (exn-message exn)
-                                 (pretty-format val)))])
-               (validate-xexpr val)
-               val)))
-         (lambda (v) #t)))
-      
-      (define (xexpr? x)
-        (correct-xexpr? x (lambda () #t) (lambda (exn) #f)))
-      
-      
-      (define (validate-xexpr x)
-        (correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn))))
-      
-      ;; ;; ;; ;; ;; ;; ;
-      ;; ; xexpr? helpers
-      
-      (define-struct (exn:invalid-xexpr exn:fail) (code))
-      
-      ;; correct-xexpr? : any (-> a) (exn -> a) -> a
-      (define (correct-xexpr? x true false)
-        (cond
-          ((string? x) (true))
-          ((symbol? x) (true))
-          ((exact-nonnegative-integer? x) (true))
-          ((comment? x) (true))
-          ((pi? x) (true))
-          ((cdata? x) (true))
-          ((list? x)
-           (or (null? x)
-               (if (symbol? (car x))
-                   (if (has-attribute? x)
-                       (and (attribute-pairs? (cadr x) true false)
-                            (andmap (lambda (part)
-                                      (correct-xexpr? part true false))
-                                    (cddr x))
-                            (true))
-                       (andmap (lambda (part)
-                                 (correct-xexpr? part true false))
-                               (cdr x)))
-                   (false (make-exn:invalid-xexpr
-                           (format
-                            "Expected a symbol as the element name, given ~s"
-                            (car x))
-                           (current-continuation-marks)
-                           x)))))
-          (else (false
-                 (make-exn:invalid-xexpr
-                  (format (string-append
-                           "Expected a string, symbol, number, comment, "
-                           "processing instruction, or list, given ~s")
-                          x)
-                  (current-continuation-marks)
-                  x)))))
-      
-      ;; has-attribute? : List -> Boolean
-      ;; True if the Xexpr provided has an attribute list.
-      (define (has-attribute? x)
-        (and (> (length x) 1)
-             (list? (cadr x))
-             (andmap (lambda (attr)
-                       (pair? attr))
-                     (cadr x))))
-      
-      ;; attribute-pairs? : List (-> a) (exn -> a) -> a
-      ;; True if the list is a list of pairs.
-      (define (attribute-pairs? attrs true false)
-        (if (null? attrs)
+  (define xexpr-drop-empty-attributes (make-parameter #f))
+  
+  (define xexpr/c 
+    (make-proj-contract
+     'xexpr?
+     (lambda (pos neg src-info name)
+       (lambda (val)
+         (with-handlers ([exn:invalid-xexpr?
+                          (lambda (exn)
+                            (raise-contract-error
+                             val
+                             src-info
+                             pos
+                             name
+                             "Not an Xexpr. ~a~n~nContext:~n~a"
+                             (exn-message exn)
+                             (pretty-format val)))])
+           (validate-xexpr val)
+           val)))
+     (lambda (v) #t)))
+  
+  (define (xexpr? x)
+    (correct-xexpr? x (lambda () #t) (lambda (exn) #f)))
+  
+  
+  (define (validate-xexpr x)
+    (correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn))))
+  
+  ;; ;; ;; ;; ;; ;; ;
+  ;; ; xexpr? helpers
+  
+  (define-struct (exn:invalid-xexpr exn:fail) (code))
+  
+  ;; correct-xexpr? : any (-> a) (exn -> a) -> a
+  (define (correct-xexpr? x true false)
+    (cond
+      ((string? x) (true))
+      ((symbol? x) (true))
+      ((exact-nonnegative-integer? x) (true))
+      ((comment? x) (true))
+      ((pi? x) (true))
+      ((cdata? x) (true))
+      ((pcdata? x) (true))
+      ((list? x)
+       (or (null? x)
+           (if (symbol? (car x))
+               (if (has-attribute? x)
+                   (and (attribute-pairs? (cadr x) true false)
+                        (andmap (lambda (part)
+                                  (correct-xexpr? part true false))
+                                (cddr x))
+                        (true))
+                   (andmap (lambda (part)
+                             (correct-xexpr? part true false))
+                           (cdr x)))
+               (false (make-exn:invalid-xexpr
+                       (format
+                        "Expected a symbol as the element name, given ~s"
+                        (car x))
+                       (current-continuation-marks)
+                       x)))))
+      [(permissive?) (true)]
+      (else (false
+             (make-exn:invalid-xexpr
+              (format (string-append
+                       "Expected a string, symbol, number, comment, "
+                       "processing instruction, or list, given ~s")
+                      x)
+              (current-continuation-marks)
+              x)))))
+  
+  ;; has-attribute? : List -> Boolean
+  ;; True if the Xexpr provided has an attribute list.
+  (define (has-attribute? x)
+    (and (> (length x) 1)
+         (list? (cadr x))
+         (andmap (lambda (attr)
+                   (pair? attr))
+                 (cadr x))))
+  
+  ;; attribute-pairs? : List (-> a) (exn -> a) -> a
+  ;; True if the list is a list of pairs.
+  (define (attribute-pairs? attrs true false)
+    (if (null? attrs)
+        (true)
+        (let ((attr (car attrs)))
+          (if (pair? attr)
+              (and (attribute-symbol-string? attr true false)
+                   (attribute-pairs? (cdr attrs) true false )
+                   (true))
+              (false
+               (make-exn:invalid-xexpr
+                (format "Expected a pair, given ~a" attr)
+                (current-continuation-marks)
+                attr))))))
+  
+  ;; attribute-symbol-string? : List (-> a) (exn -> a) -> a
+  ;; True if the list is a list of String,Symbol pairs.
+  (define (attribute-symbol-string? attr true false)
+    (if (symbol? (car attr))
+        (if (string? (cadr attr))
             (true)
-            (let ((attr (car attrs)))
-              (if (pair? attr)
-                  (and (attribute-symbol-string? attr true false)
-                       (attribute-pairs? (cdr attrs) true false )
-                       (true))
-                  (false
-                   (make-exn:invalid-xexpr
-                    (format "Expected a pair, given ~a" attr)
-                    (current-continuation-marks)
-                    attr))))))
-      
-      ;; attribute-symbol-string? : List (-> a) (exn -> a) -> a
-      ;; True if the list is a list of String,Symbol pairs.
-      (define (attribute-symbol-string? attr true false)
-        (if (symbol? (car attr))
-            (if (string? (cadr attr))
-                (true)
-                (false (make-exn:invalid-xexpr
-                        (format "Expected a string, given ~a" (cadr attr))
-                        (current-continuation-marks)
-                        (cadr attr))))
             (false (make-exn:invalid-xexpr
-                    (format "Expected a symbol, given ~a" (car attr))
+                    (format "Expected a string, given ~a" (cadr attr))
                     (current-continuation-marks)
-                    (cadr attr)))))
-      
-      ;; ; end xexpr? helpers
-      ;; ;; ;; ;; ;; ;; ;; ;;
-      
-      
-      ; : (a -> bool) tst -> bool
-      ; To check if l is a (listof p?)
-      ; Don't use (and (list? l) (andmap p? l)) because l may be improper.
-      (define (listof? p? l)
-        (let listof-p? ([l l])
-          (or (null? l)
-              (and (cons? l) (p? (car l)) (listof-p? (cdr l))))))
-      
-      ; : tst -> bool
-      (define (xexpr-attribute? b)
-        (and (pair? b)
-             (symbol? (car b))
-             (pair? (cdr b))
-             (string? (cadr b))
-             (null? (cddr b))))
-      
-      ; permissive? : parameter bool
-      (define permissive? (make-parameter #f))
-      
-      ;; xml->xexpr : Content -> Xexpr
-      (define (xml->xexpr x)
-        (let* ([non-dropping-combine
-                (lambda (atts body)
-                  (cons (assoc-sort (map attribute->srep atts))
-                        body))]
-               [combine (if (xexpr-drop-empty-attributes)
-                            (lambda (atts body)
-                              (if (null? atts)
-                                  body
-                                  (non-dropping-combine atts body)))
-                            non-dropping-combine)])
-          (let loop ([x x])
-            (cond
-              [(element? x)
-               (let ([body (map loop (element-content x))]
-                     [atts (element-attributes x)])
-                 (cons (element-name x) (combine atts body)))]
-              [(pcdata? x) (pcdata-string x)]
-              [(entity? x) (entity-text x)]
-              [(or (comment? x) (pi? x) (cdata? x)) x]
-              [(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)]
-              [(permissive?) x]
-              [else (error 'xml->xexpr "Expected content, given ~e" x)]))))
-      
-      ;; attribute->srep : Attribute -> Attribute-srep
-      (define (attribute->srep a)
-        (list (attribute-name a) (attribute-value a)))
-      
-      ;; srep->attribute : Attribute-srep -> Attribute
-      (define (srep->attribute a)
-        (unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a)))
-          (error 'srep->attribute "expected (list Symbol String) given ~e" a))
-        (make-attribute 'scheme 'scheme (car a) (cadr a)))
-      
-      ;; xexpr->xml : Xexpr -> Content
-      ;; The contract is enforced.
-      (define (xexpr->xml x)
+                    (cadr attr))))
+        (false (make-exn:invalid-xexpr
+                (format "Expected a symbol, given ~a" (car attr))
+                (current-continuation-marks)
+                (cadr attr)))))
+  
+  ;; ; end xexpr? helpers
+  ;; ;; ;; ;; ;; ;; ;; ;;
+  
+  
+  ; : (a -> bool) tst -> bool
+  ; To check if l is a (listof p?)
+  ; Don't use (and (list? l) (andmap p? l)) because l may be improper.
+  (define (listof? p? l)
+    (let listof-p? ([l l])
+      (or (null? l)
+          (and (cons? l) (p? (car l)) (listof-p? (cdr l))))))
+  
+  ; : tst -> bool
+  (define (xexpr-attribute? b)
+    (and (pair? b)
+         (symbol? (car b))
+         (pair? (cdr b))
+         (string? (cadr b))
+         (null? (cddr b))))
+  
+  ; permissive? : parameter bool
+  (define permissive? (make-parameter #f))
+  
+  ;; xml->xexpr : Content -> Xexpr
+  (define (xml->xexpr x)
+    (let* ([non-dropping-combine
+            (lambda (atts body)
+              (cons (assoc-sort (map attribute->srep atts))
+                    body))]
+           [combine (if (xexpr-drop-empty-attributes)
+                        (lambda (atts body)
+                          (if (null? atts)
+                              body
+                              (non-dropping-combine atts body)))
+                        non-dropping-combine)])
+      (let loop ([x x])
         (cond
-          [(pair? x)
-           (let ([f (lambda (atts body)
-                      (unless (list? body)
-                        (error 'xexpr->xml
-                               "expected a list of xexprs for the body in ~e"
-                               x))
-                      (make-element 'scheme 'scheme (car x)
-                                    atts
-                                    (map xexpr->xml body)))])
-             (if (and (pair? (cdr x))
-                      (or (null? (cadr x))
-                          (and (pair? (cadr x)) (pair? (caadr x)))))
-                 (f (map srep->attribute (cadr x)) (cddr x))
-                 (f null (cdr x))))]
-          [(string? x) (make-pcdata 'scheme 'scheme x)]
-          [(or (symbol? x) (exact-nonnegative-integer? x))
-           (make-entity 'scheme 'scheme x)]
+          [(element? x)
+           (let ([body (map loop (element-content x))]
+                 [atts (element-attributes x)])
+             (cons (element-name x) (combine atts body)))]
+          [(pcdata? x) (pcdata-string x)]
+          [(entity? x) (entity-text x)]
           [(or (comment? x) (pi? x) (cdata? x)) x]
-          [else ;(error 'xexpr->xml "malformed xexpr ~e" x)
-           x]))
-      
-      ;; xexpr->string : Xexpression -> String
-      (define (xexpr->string xexpr)
-        (let ([port (open-output-string)])
-          (write-xml/content (xexpr->xml xexpr) port)
-          (get-output-string port)))
-      
-      ;; bcompose : (a a -> c) (b -> a) -> (b b -> c)
-      (define (bcompose f g)
-        (lambda (x y) (f (g x) (g y)))))))
+          [(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)]
+          [(permissive?) x]
+          [else (error 'xml->xexpr "Expected content, given ~e" x)]))))
+  
+  ;; attribute->srep : Attribute -> Attribute-srep
+  (define (attribute->srep a)
+    (list (attribute-name a) (attribute-value a)))
+  
+  ;; srep->attribute : Attribute-srep -> Attribute
+  (define (srep->attribute a)
+    (unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a)))
+      (error 'srep->attribute "expected (list Symbol String) given ~e" a))
+    (make-attribute 'scheme 'scheme (car a) (cadr a)))
+  
+  ;; xexpr->xml : Xexpr -> Content
+  ;; The contract is enforced.
+  (define (xexpr->xml x)
+    (cond
+      [(pair? x)
+       (let ([f (lambda (atts body)
+                  (unless (list? body)
+                    (error 'xexpr->xml
+                           "expected a list of xexprs for the body in ~e"
+                           x))
+                  (make-element 'scheme 'scheme (car x)
+                                atts
+                                (map xexpr->xml body)))])
+         (if (and (pair? (cdr x))
+                  (or (null? (cadr x))
+                      (and (pair? (cadr x)) (pair? (caadr x)))))
+             (f (map srep->attribute (cadr x)) (cddr x))
+             (f null (cdr x))))]
+      [(string? x) (make-pcdata 'scheme 'scheme x)]
+      [(or (symbol? x) (exact-nonnegative-integer? x))
+       (make-entity 'scheme 'scheme x)]
+      [(or (comment? x) (pi? x) (cdata? x) (pcdata? x)) x]
+      [else ;(error 'xexpr->xml "malformed xexpr ~e" x)
+       x]))
+  
+  ;; xexpr->string : Xexpression -> String
+  (define (xexpr->string xexpr)
+    (let ([port (open-output-string)])
+      (write-xml/content (xexpr->xml xexpr) port)
+      (get-output-string port)))
+  
+  ;; bcompose : (a a -> c) (b -> a) -> (b b -> c)
+  (define (bcompose f g)
+    (lambda (x y) (f (g x) (g y)))))
diff --git a/collects/xml/test.ss b/collects/xml/test.ss
deleted file mode 100644
index e0f0fc43fa..0000000000
--- a/collects/xml/test.ss
+++ /dev/null
@@ -1,108 +0,0 @@
-;; run these tests with:
-;;  % mzscheme --require test.ss
-
-(module test mzscheme
-  (require xml/xml
-           scheme/port)
-  
-  
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  ;;
-  ;; utils
-  ;;
-  
-  ;; test-bad-read-input : format-str str -> void
-  ;; First argument is the input, second is the error message
-  (define (test-bad-read-input format-str err-string)
-    (let ([str (format format-str)])
-      (with-handlers ([exn:xml?
-                       (lambda (x)
-                         (unless (equal? (exn-message x) err-string)
-                           (report-err format-str (exn-message x) err-string)))])
-        (read-xml (open-input-string str))
-        (report-err str "no error" err-string))))
-  
-  ;; tests-failed : number
-  ;; incremened for each test that fails
-  (define tests-failed 0)
-  
-  ;; report-err : string string string -> void
-  ;; reports an error in the test suite
-  ;; increments tests-failed.
-  (define (report-err test got expected)
-    (set! tests-failed (+ tests-failed 1))
-    (printf "FAILED     test: ~a~n            got: ~a~n       expected: ~a~n"
-            test got expected))
-  
-  ;; done : -> void
-  ;; prints out a message saying the tests are done.
-  ;; if any tests failed, prints a message saying how many
-  (define (done)
-    (if (= tests-failed 0)
-        (printf "All tests passed~n")
-        (printf "~a tests failed~n" tests-failed)))
-  
-  
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  ;;
-  ;; reader error tests
-  ;;
-  
-  (test-bad-read-input "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
-  (test-bad-read-input "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
-  (test-bad-read-input
-   "<a></b>"
-   "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
-  (test-bad-read-input
-   "<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
-  
-  (test-bad-read-input "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
-  (test-bad-read-input "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
-  (test-bad-read-input
-   "~n<a></b>"
-   "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
-  (test-bad-read-input
-   "~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
-  
-  ;; permissive?
-  (with-handlers ([exn?
-                   (lambda (exn)
-                     (regexp-match #rx"Expected content," (exn-message exn)))])
-    (report-err "Non-permissive" (xml->xexpr #f) "Exception"))
-  
-  (with-handlers ([exn?
-                   (lambda (exn)
-                     (report-err "Permissive" "Exception" "#f"))])
-    (parameterize ([permissive? #t])
-      (let ([tmp (xml->xexpr #f)])
-        (when tmp
-          (report-err "Permissive" tmp "#f")))))
-  
-  ;; doctype
-  (let ()
-    (define source-string #<<END
-<!DOCTYPE html PUBLIC
- "-//W3C//DTD XHTML 1.0 Transitional//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml"> </html>
-END
-      )
-    
-    (define source-document
-      (read-xml (open-input-string source-string)))
-    (define result-string
-      (with-output-to-string (lambda () (write-xml source-document))))
-    (define expected-string #<<END
-<html xmlns="http://www.w3.org/1999/xhtml"> </html>
-END
-      )
-    (unless (string=? expected-string result-string)
-      (report-err "DOCTYPE dropping"
-                  result-string
-                  expected-string)))
-  
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  ;;
-  ;; done
-  ;;
-  (done))
diff --git a/collects/xml/xml-sig.ss b/collects/xml/xml-sig.ss
index 8f6bb02f96..1db8fea971 100644
--- a/collects/xml/xml-sig.ss
+++ b/collects/xml/xml-sig.ss
@@ -1,14 +1,19 @@
+#lang scheme
+(require "private/sig.ss")
 
-(module xml-sig mzscheme
-  (require mzlib/unitsig)
-  
-  (require "private/sig.ss")
-
-  (define-signature xml^
-    ((open xml-structs^) (open reader^) (open writer^) (open xexpr^) (open space^)
-     syntax:read-xml syntax:read-xml/element))
-
-  (provide xml^))
-
+(define-signature xml-syntax^
+  ((contracted
+    ; XXX these should both actually return syntax? that is also xexpr/c
+    [syntax:read-xml (() (input-port?) . ->* . syntax?)]
+    [syntax:read-xml/element (() (input-port?) . ->* . syntax?)])))
 
+(define-signature xml^
+  ((open xml-structs^)
+   (open reader^)
+   (open writer^)
+   (open xexpr^)
+   (open space^)
+   (open xml-syntax^)))
 
+(provide xml^
+         xml-syntax^)
diff --git a/collects/xml/xml-unit.ss b/collects/xml/xml-unit.ss
index d378e2d1cc..2ea7450497 100644
--- a/collects/xml/xml-unit.ss
+++ b/collects/xml/xml-unit.ss
@@ -1,28 +1,74 @@
+#lang scheme
+(require "xml-sig.ss" 
+         "private/sig.ss"
+         "private/structures.ss"
+         "private/reader.ss"
+         "private/writer.ss"
+         "private/xexpr.ss"
+         "private/space.ss"
+         "private/syntax.ss")
 
-(module xml-unit mzscheme
-  (require mzlib/unitsig)
+(provide xml@)
 
-  (require "xml-sig.ss" "private/sig.ss"
-	  "private/structures.ss"
-	  "private/reader.ss"
-	  "private/writer.ss"
-	  "private/xexpr.ss"
-	  "private/space.ss"
-          "private/syntax.ss")
+(define-unit reader->xml-syntax@
+  (import reader^)
+  (export xml-syntax^)
+  (define syntax:read-xml read-xml)
+  (define syntax:read-xml/element read-xml/element))
 
-  (provide xml@)
+(define-compound-unit/infer xml-syntax@
+  (import)
+  (export xml-syntax^)
+  (link syntax-structs@ reader@ reader->xml-syntax@))
 
-  (define xml@
-    (compound-unit/sig
-     (import)
-     (link
-      [S : xml-structs^ (xml-structs@)]
-      [SS : xml-structs^ (syntax-structs@)]
-      [R : reader^ (reader@ S)]
-      [R2 : reader^ (reader@ SS)]
-      (U : writer^ (writer@ S))
-      (T : xexpr^ (xexpr@ S U))
-      (W : space^ (space@ S)))
-     (export (open S) (open R) (var (R2 read-xml) syntax:read-xml)
-             (var (R2 read-xml/element) syntax:read-xml/element)
-             (open U) (open T) (open W)))))
+(define-unit native-xml-syntax@
+  (import xml-structs^ reader^ xexpr^)
+  (export xml-syntax^)
+  
+  (define (syntax:read-xml [in (current-input-port)])
+    (define the-xml (read-xml in))
+    (define the-xml-element (document-element the-xml))
+    (element->xexpr-syntax the-xml-element))
+  
+  (define (syntax:read-xml/element [in (current-input-port)])
+    (define the-xml-element (read-xml/element in))
+    (element->xexpr-syntax the-xml-element))
+  
+  (define (position from to)
+    (let ([start-offset (location-offset from)])
+      (list #f (location-line from) (location-char from) start-offset
+            (- (location-offset to) start-offset))))
+  
+  (define (wrap s e)
+    (datum->syntax #f e (position (source-start s) (source-stop s))))  
+  
+  (define (attribute->syntax a)
+    (wrap a (list (attribute-name a) (attribute-value a))))
+  
+  (define (non-dropping-combine atts body)
+    (list* (map attribute->syntax atts) body))
+  
+  (define (combine atts body)
+    (if (xexpr-drop-empty-attributes)
+        (if (empty? atts)
+            body
+            (non-dropping-combine atts body))
+        (non-dropping-combine atts body)))
+  
+  (define (element->xexpr-syntax e)
+    (wrap e
+          (list* (element-name e)
+                 (combine (element-attributes e)
+                          (map content->xexpr-syntax (element-content e))))))
+  
+  (define (content->xexpr-syntax x)
+    (cond
+      [(element? x) (element->xexpr-syntax x)]
+      [(pcdata? x) (wrap x (pcdata-string x))]
+      [(entity? x) (wrap x (entity-text x))]
+      [else (wrap x x)])))
+
+(define-compound-unit/infer xml@
+  (import)
+  (export xml-structs^ reader^ xml-syntax^ writer^ xexpr^ space^)
+  (link   xml-structs@ reader@ native-xml-syntax@ writer@ xexpr@ space@))
diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl
index cb7a123ff0..155c8d3c9c 100644
--- a/collects/xml/xml.scrbl
+++ b/collects/xml/xml.scrbl
@@ -4,12 +4,14 @@
           scribble/eval
           (for-label scheme/base
                      scheme/contract
+                     scheme/list
                      xml
                      xml/plist))
 
 @(define xml-eval (make-base-eval))
 @(define plist-eval (make-base-eval))
 @interaction-eval[#:eval xml-eval (require xml)]
+@interaction-eval[#:eval xml-eval (require scheme/list)]
 @interaction-eval[#:eval plist-eval (require xml/plist)]
 
 @title{@bold{XML}: Parsing and Writing}
@@ -71,17 +73,16 @@ and a @scheme[_misc] is an instance of the @scheme[comment] or
 
 @defstruct[document ([prolog prolog?]
                      [element element?]
-                     [misc (or/c comment? pcdata?)])]{
+                     [misc (listof (or/c comment? p-i?))])]{
 
 Represents a document.}
 
-@defstruct[prolog ([misc (listof (or/c comment? pcdata?))]
+@defstruct[prolog ([misc (listof (or/c comment? p-i?))]
                    [dtd (or/c document-type false/c)]
-                   [misc2 (listof (or/c comment? pcdata?))])]{
+                   [misc2 (listof (or/c comment? p-i?))])]{
 
-Represents a document prolog. The @scheme[make-prolog] binding is
-unusual: it accepts two or more arguments, and all arguments after the
-first two are collected into the @scheme[misc2] field.}
+Represents a document prolog. 
+}
 
 @defstruct[document-type ([name symbol?]
                           [external external-dtd?]
@@ -259,7 +260,7 @@ Converts an @tech{X-expression} into XML content.}
 Converts an @tech{X-expression} into a string containing XML.}
 
 @defproc[((eliminate-whitespace [tags (listof symbol?)]
-                                [choose (boolean? . -> . any/c)])
+                                [choose (boolean? . -> . boolean?)])
           [elem element?])
          element?]{
 
@@ -270,7 +271,7 @@ tag names as @scheme[tag]s and the identity function as
 that filters out PCDATA consisting solely of whitespace from those
 elements, and it raises an error if any non-whitespace text appears.
 Passing in @scheme[not] as @scheme[choose] filters all elements which
-are not named in the @scheme[tags] list.  Using @scheme[void] as
+are not named in the @scheme[tags] list.  Using @scheme[(lambda (x) #t)] as
 @scheme[choose] filters all elements regardless of the @scheme[tags]
 list.}
 
diff --git a/collects/xml/xml.ss b/collects/xml/xml.ss
index 5fb75ccfd0..f4103edb9d 100644
--- a/collects/xml/xml.ss
+++ b/collects/xml/xml.ss
@@ -1,10 +1,7 @@
+#lang scheme
+(require "xml-sig.ss"
+         "xml-unit.ss")
 
-(module xml mzscheme
-  (require mzlib/unitsig)
+(define-values/invoke-unit/infer xml@)
 
-  (require "xml-sig.ss"
-	   "xml-unit.ss")
-  
-  (define-values/invoke-unit/sig xml^ xml@)
-
-  (provide-signature-elements xml^))
+(provide-signature-elements xml^)
\ No newline at end of file
diff --git a/src/mred/mredmac.cxx b/src/mred/mredmac.cxx
index aea2890f82..d585074b68 100644
--- a/src/mred/mredmac.cxx
+++ b/src/mred/mredmac.cxx
@@ -285,9 +285,6 @@ static int waiting_for_next_event;
 static int wne_handlersInstalled;
 static int pending_self_ae;
 
-static int ae_target_ready = 0;
-static AEAddressDesc ae_target;
-
 static void EnsureWNEReturn()
 {
   /* Generate an event that WaitNextEvent() will return, but that we can
@@ -301,18 +298,17 @@ static void EnsureWNEReturn()
      dummy AppleEvent and defeat the purpose. */
   if (!pending_self_ae) {
     ProcessSerialNumber psn;
-    AppleEvent ae;
+    AppleEvent ae, ae_target;
 
     pending_self_ae = 1;
 
     GetCurrentProcess(&psn);
-    if (!ae_target_ready) {
-      AECreateDesc(typeProcessSerialNumber, &psn, sizeof(psn), &ae_target);
-      ae_target_ready = 1;
-    }
+    AECreateDesc(typeProcessSerialNumber, &psn, sizeof(psn), &ae_target);
     AECreateAppleEvent('MrEd', 'Smug', &ae_target, kAutoGenerateReturnID, kAnyTransactionID, &ae);
     AESend(&ae, NULL, kAENoReply, kAENormalPriority, kNoTimeOut, NULL, NULL);
-    AEDisposeDesc(&ae);
+    /* Not supposed to dispose? */
+    /* AEDisposeDesc(&ae); */
+    /* AEDisposeDesc(&ae_target); */
   }
 }
 
diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c
index 9617d026e6..33d2512a6e 100644
--- a/src/mzscheme/src/env.c
+++ b/src/mzscheme/src/env.c
@@ -3990,6 +3990,10 @@ namespace_undefine_variable(int argc, Scheme_Object *argv[])
 
   if (scheme_lookup_global(argv[0], env)) {
     bucket = scheme_global_bucket(argv[0], env);
+    scheme_set_global_bucket("namespace-undefine-variable!", 
+                             bucket,
+                             NULL,
+                             0);
     bucket->val = NULL;
   } else {
     scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, argv[0],
diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c
index 4d586e26d9..c8b49b92b3 100644
--- a/src/mzscheme/src/eval.c
+++ b/src/mzscheme/src/eval.c
@@ -6442,7 +6442,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 	  if (!SCHEME_STX_SYMBOLP(var))
 	    scheme_wrong_syntax(NULL, var, first, 
 				"name must be an identifier");
-	  // scheme_dup_symbol_check(&r, "internal definition", var, "binding", first);
+	  /* scheme_dup_symbol_check(&r, "internal definition", var, "binding", first); */
 	  vars = SCHEME_STX_CDR(vars);
 	  cnt++;
 	}
diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c
index 1f0472e9a7..8c0c3d0753 100644
--- a/src/mzscheme/src/struct.c
+++ b/src/mzscheme/src/struct.c
@@ -3694,9 +3694,8 @@ static Scheme_Object *check_date_fields(int argc, Scheme_Object **argv)
   if (!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 1) || (SCHEME_INT_VAL(a) > 12))
     scheme_wrong_field_type(argv[10], "integer in [1, 12]", a);
   a = argv[5];
-  if ((!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 0))
-      && (!SCHEME_BIGNUMP(a) || !SCHEME_BIGPOS(a)))
-    scheme_wrong_field_type(argv[10], "nonnegative exact integer", a);
+  if (!SCHEME_INTP(a) && !SCHEME_BIGNUMP(a))
+    scheme_wrong_field_type(argv[10], "exact integer", a);
   a = argv[6];
   if (!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 0) || (SCHEME_INT_VAL(a) > 6))
     scheme_wrong_field_type(argv[10], "integer in [0, 6]", a);