From 7a55275a26f4052af6ec87f2737f367721abc4ec Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 15 Oct 2008 22:23:56 +0000
Subject: [PATCH] unit bug fixes related to new scoping of signature elements;
 change scribble/manual to compute ids typeset as variables at compile time,
 in preparation for moving from a parameter to syntax bindings; fix docs
 typos; extend decompiler's support for unmarshaling syntax objects

svn: r12046
---
 collects/compiler/decompile.ss                |   1 +
 collects/compiler/main.ss                     |   3 +-
 collects/compiler/zo-parse.ss                 | 124 +++++-
 collects/mzlib/private/unit-compiletime.ss    |   2 +-
 collects/scribble/manual.ss                   | 397 +++++++++++-------
 collects/scribblings/guide/for.scrbl          |   2 +-
 .../scribblings/guide/pattern-macros.scrbl    |   6 +-
 .../scribblings/reference/contracts.scrbl     |   4 +-
 8 files changed, 376 insertions(+), 163 deletions(-)

diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss
index 4c009cdcd1..aa851a4052 100644
--- a/collects/compiler/decompile.ss
+++ b/collects/compiler/decompile.ss
@@ -266,6 +266,7 @@
 
 (define (decompile-lam expr globs stack)
   (match expr
+    [(struct closure (lam gen-id)) (decompile-lam lam globs stack)]
     [(struct lam (name flags num-params rest? closure-map max-let-depth body))
      (let ([vars (for/list ([i (in-range num-params)]) 
                    (gensym (format "arg~a-" i)))]
diff --git a/collects/compiler/main.ss b/collects/compiler/main.ss
index 369b942990..456823c1f4 100644
--- a/collects/compiler/main.ss
+++ b/collects/compiler/main.ss
@@ -453,7 +453,8 @@
      (for ([zo-file source-files])
        (let ([zo-file (path->complete-path zo-file)])
          (let-values ([(base name dir?) (split-path zo-file)])
-           (parameterize ([current-load-relative-directory base])
+           (parameterize ([current-load-relative-directory base]
+                          [print-graph #t])
              (pretty-print
               (decompile
                (call-with-input-file*
diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss
index cc44ec16fe..f73b98d2ce 100644
--- a/collects/compiler/zo-parse.ss
+++ b/collects/compiler/zo-parse.ss
@@ -306,7 +306,7 @@
   ;; not sure if it's really unsigned
   (integer-bytes->integer (read-bytes 4 p) #f #f))
 
-(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets))
+(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns))
 
 (define (cp-getc cp)
   (begin-with-definitions
@@ -426,6 +426,124 @@
 
 (define-struct not-ready ())
 
+;; ----------------------------------------
+;; Synatx unmarshaling
+
+(define-form-struct wrapped (datum wraps certs))
+
+(define (decode-stx cp v)
+  (if (integer? v)
+      (let-values ([(v2 decoded?) (unmarshal-stx-get cp v)])
+        (if decoded?
+            v2
+            (let ([v2 (decode-stx cp v2)])
+              (unmarshal-stx-set! cp v v2)
+              v2)))
+      (let loop ([v v])
+        (let-values ([(cert-marks v encoded-wraps)
+                      (match v
+                        [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)]
+                        [`(,datum . ,wraps) (values #f datum wraps)]
+                        [else (error 'decode-wraps "bad datum+wrap: ~e" v)])])
+          (let* ([wraps (decode-wraps cp encoded-wraps)]
+                 [add-wrap (lambda (v) (make-wrapped v wraps cert-marks))])
+            (cond
+             [(pair? v)
+              (if (eq? #t (car v))
+                  ;; Share decoded wraps with all nested parts.
+                  (let loop ([v (cdr v)])
+                    (cond
+                     [(pair? v) 
+                      (let ploop ([v v])
+                        (cond
+                         [(null? v) null]
+                         [(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))]
+                         [else (loop v)]))]
+                     [(box? v) (add-wrap (box (loop (unbox v))))]
+                     [(vector? v)
+                      (add-wrap (list->vector (map loop (vector->list v))))]
+                     [(prefab-struct-key v)
+                      => (lambda (k)
+                           (add-wrap
+                            (apply
+                             make-prefab-struct 
+                             k
+                             (map loop (cdr (vector->list (struct->vector v)))))))]
+                     [else (add-wrap v)]))
+                  ;; Decode sub-elements that have their own wraps:
+                  (let-values ([(v counter) (if (exact-integer? (car v))
+                                                (values (cdr v) (car v))
+                                                (values v -1))])
+                    (add-wrap
+                     (let ploop ([v v][counter counter])
+                       (cond
+                        [(null? v) null]
+                        [(or (not (pair? v)) (zero? counter)) (loop v)]
+                        [(pair? v) (cons (loop (car v))
+                                         (ploop (cdr v) (sub1 counter)))])))))]
+             [(box? v) (add-wrap (box (loop (unbox v))))]
+             [(vector? v)
+              (add-wrap (list->vector (map loop (vector->list v))))]
+             [(prefab-struct-key v)
+              => (lambda (k)
+                   (add-wrap
+                    (apply
+                     make-prefab-struct 
+                     k
+                     (map loop (cdr (vector->list (struct->vector v)))))))]
+             [else (add-wrap v)]))))))
+
+(define (decode-wraps cp w)
+  (if (integer? w)
+      (let-values ([(w2 decoded?) (unmarshal-stx-get cp w)])
+        (if decoded?
+            w2
+            (let ([w2 (decode-wraps cp w2)])
+              (unmarshal-stx-set! cp w w2)
+              w2)))
+      (map (lambda (a)
+             (let aloop ([a a])
+               (cond
+                [(integer? a) 
+                 (let-values ([(a2 decoded?) (unmarshal-stx-get cp a)])
+                   (if decoded?
+                       a2
+                       (let ([a2 (aloop a2)])
+                         (unmarshal-stx-set! cp a a2)
+                         a2)))]
+                [(and (pair? a) (null? (cdr a)) (number? (car a)))
+                 ;; a mark
+                 (string->symbol (format "mark~a" (car a)))]
+                [(vector? a)
+                 `(#%decode-lexical-rename ,a)]
+                [(pair? a)
+                 `(#%decode-module-rename ,a)]
+                [(boolean? a)
+                 `(#%top-level-rename ,a)]
+                [(symbol? a)
+                 '(#%mark-barrier)]
+                [(box? a)
+                 `(#%phase-shift ,(unbox a))]
+                [else (error 'decode-wraps "bad wrap element: ~e" a)])))
+           w)))
+
+(define (unmarshal-stx-get cp pos)
+  (if (pos . >= . (vector-length (cport-symtab cp)))
+      (values `(#%bad-index ,pos) #t)
+      (let ([v (vector-ref (cport-symtab cp) pos)])
+        (if (not-ready? v)
+            (let ([save-pos (cport-pos cp)])
+              (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos)))
+              (let ([v (read-compact cp)])
+                (vector-set! (cport-symtab cp) pos v)
+                (set-cport-pos! cp save-pos)
+                (values v #f)))
+            (values v (vector-ref (cport-decoded cp) pos))))))
+
+(define (unmarshal-stx-set! cp pos v)
+  (vector-set! (cport-symtab cp) pos v)
+  (vector-set! (cport-decoded cp) pos #t))
+
 ;; ----------------------------------------
 ;; Main parsing loop
 
@@ -535,7 +653,7 @@
           [(marshalled) (read-marshalled (read-compact-number cp) cp)]
           [(stx)
            (let ([v (make-reader-graph (read-compact cp))])
-             (make-stx v))]
+             (make-stx (decode-stx cp v)))]
           [(local local-unbox)
            (let ([c (read-compact-number cp)]
                  [unbox? (eq? cpt-tag 'local-unbox)])
@@ -666,7 +784,7 @@
 
    (define symtab (make-vector symtabsize (make-not-ready)))
 
-   (define cp (make-cport 0 port size* rst symtab so*))
+   (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash)))
    (for/list ([i (in-range 1 symtabsize)])
      (when (not-ready? (vector-ref symtab i))
        (set-cport-pos! cp (vector-ref so* (sub1 i)))
diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss
index af6b14daef..1cbb60ca16 100644
--- a/collects/mzlib/private/unit-compiletime.ss
+++ b/collects/mzlib/private/unit-compiletime.ss
@@ -355,7 +355,7 @@
   (define (process-tagged-import spec)
     (process-tagged-import/export spec #t #t))
   (define (process-tagged-export spec)
-    (process-tagged-import/export spec #f #f))
+    (process-tagged-import/export spec #f #t))
   
   ;; process-spec : syntax-object -> sig
   (define (process-spec spec)
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
index a926c89fd6..b248d5dfb4 100644
--- a/collects/scribble/manual.ss
+++ b/collects/scribble/manual.ss
@@ -12,7 +12,9 @@
          scheme/stxparam
          scheme/serialize
          setup/main-collects
-         (for-syntax scheme/base)
+         (for-syntax scheme/base
+                     syntax/boundmap
+                     syntax/kerncase)
          (for-label scheme/base
                     scheme/class))
 
@@ -739,13 +741,16 @@
     [(_ [[proto result] ...] desc ...)
      (defproc* #:mode procedure #:within #f [[proto result] ...] desc ...)]
     [(_ #:mode m #:within cl [[proto result] ...] desc ...)
-     (*defproc 'm (quote-syntax/loc cl)
-               (list (extract-proc-id proto) ...)
-               '[proto ...]
-               (list (arg-contracts proto) ...)
-               (list (arg-defaults proto) ...)
-               (list (lambda () (result-contract result)) ...)
-               (lambda () (list desc ...)))]))
+     (with-togetherable-scheme-variables
+      ()
+      ([proc proto] ...)
+      (*defproc 'm (quote-syntax/loc cl)
+                (list (extract-proc-id proto) ...)
+                '[proto ...]
+                (list (arg-contracts proto) ...)
+                (list (arg-defaults proto) ...)
+                (list (lambda () (result-contract result)) ...)
+                (lambda () (list desc ...))))]))
 (define-syntax defstruct
   (syntax-rules ()
     [(_ name fields #:mutable #:inspector #f desc ...)
@@ -762,10 +767,13 @@
      (**defstruct name fields #t #f desc ...)]))
 (define-syntax-rule (**defstruct name ([field field-contract] ...) immutable?
                                  transparent? desc ...)
-  (*defstruct (quote-syntax/loc name) 'name
-              '([field field-contract] ...)
-              (list (lambda () (schemeblock0 field-contract)) ...)
-              immutable? transparent? (lambda () (list desc ...))))
+  (with-togetherable-scheme-variables
+   ()
+   ()
+   (*defstruct (quote-syntax/loc name) 'name
+               '([field field-contract] ...)
+               (list (lambda () (schemeblock0 field-contract)) ...)
+               immutable? transparent? (lambda () (list desc ...)))))
 (define-syntax (defform*/subs stx)
   (syntax-case stx ()
     [(_ #:id defined-id #:literals (lit ...) [spec spec1 ...]
@@ -783,16 +791,20 @@
                                           spec
                                           spec)]
                           [_ spec])))])
-       #'(*defforms (quote-syntax/loc defined-id) '(lit ...)
-                    '(spec spec1 ...)
-                    (list (lambda (x) (schemeblock0/form new-spec))
-                          (lambda (ignored) (schemeblock0/form spec1)) ...)
-                    '((non-term-id non-term-form ...) ...)
-                    (list (list (lambda () (scheme non-term-id))
-                                (lambda () (schemeblock0/form non-term-form))
-                                ...)
-                          ...)
-                    (lambda () (list desc ...))))]
+       #'(with-togetherable-scheme-variables
+          (lit ...)
+          ([form spec] [form spec1] ... 
+           [non-term (non-term-id non-term-form ...)] ...)
+          (*defforms (quote-syntax/loc defined-id)
+                     '(spec spec1 ...)
+                     (list (lambda (x) (schemeblock0/form new-spec))
+                           (lambda (ignored) (schemeblock0/form spec1)) ...)
+                     '((non-term-id non-term-form ...) ...)
+                     (list (list (lambda () (scheme non-term-id))
+                                 (lambda () (schemeblock0/form non-term-form))
+                                 ...)
+                           ...)
+                     (lambda () (list desc ...)))))]
     [(fm #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...)
          desc ...)
      #'(fm #:id id #:literals () [spec spec1 ...]
@@ -839,46 +851,60 @@
 (define-syntax (defform/none stx)
   (syntax-case stx ()
     [(_ #:literals (lit ...) spec desc ...)
-     #'(*defforms #f '(lit ...)
-                  '(spec) (list (lambda (ignored) (schemeblock0/form spec)))
-                  null null
-                  (lambda () (list desc ...)))]
+     #'(with-togetherable-scheme-variables
+        (lit ...)
+        ([form spec])
+        (*defforms #f
+                   '(spec) (list (lambda (ignored) (schemeblock0/form spec)))
+                   null null
+                   (lambda () (list desc ...))))]
     [(_ spec desc ...)
      #'(defform/none #:literals () spec desc ...)]))
 (define-syntax (defidform stx)
   (syntax-case stx ()
     [(_ spec-id desc ...)
-     #'(*defforms (quote-syntax/loc spec-id) null
-                  '(spec-id)
-                  (list (lambda (x) (make-omitable-paragraph (list x))))
-                  null
-                  null
-                  (lambda () (list desc ...)))]))
+     #'(with-togetherable-scheme-variables
+        ()
+        ()
+        (*defforms (quote-syntax/loc spec-id)
+                   '(spec-id)
+                   (list (lambda (x) (make-omitable-paragraph (list x))))
+                   null
+                   null
+                   (lambda () (list desc ...))))]))
 (define-syntax (defsubform stx)
   (syntax-case stx ()
     [(_ . rest) #'(into-blockquote (defform . rest))]))
 (define-syntax (defsubform* stx)
   (syntax-case stx ()
     [(_ . rest) #'(into-blockquote (defform* . rest))]))
+(define-syntax spec?form/subs
+  (syntax-rules ()
+    [(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
+        desc ...)
+     (with-scheme-variables
+      (lit ...)
+      ([form/maybe (has-kw? spec)]
+       [non-term (non-term-id non-term-form ...)] ...)
+      (*specsubform 'spec '(lit ...) (lambda () (schemeblock0/form spec))
+                    '((non-term-id non-term-form ...) ...)
+                    (list (list (lambda () (scheme non-term-id))
+                                (lambda () (schemeblock0/form non-term-form))
+                                ...)
+                          ...)
+                    (lambda () (list desc ...))))]))
 (define-syntax specsubform
   (syntax-rules ()
     [(_ #:literals (lit ...) spec desc ...)
-     (*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec))
-                   null null (lambda () (list desc ...)))]
+     (spec?form/subs #f #:literals (lit ...) spec () desc ...)]
     [(_ spec desc ...)
-     (*specsubform 'spec #f null (lambda () (schemeblock0/form spec))
-                   null null (lambda () (list desc ...)))]))
+     (specsubform #:literals () spec desc ...)]))
 (define-syntax specsubform/subs
   (syntax-rules ()
     [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
         desc ...)
-     (*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec))
-                   '((non-term-id non-term-form ...) ...)
-                   (list (list (lambda () (scheme non-term-id))
-                               (lambda () (schemeblock0/form non-term-form))
-                               ...)
-                         ...)
-                   (lambda () (list desc ...)))]
+     (spec?form/subs #f #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
+                     desc ...)]
     [(_ spec subs desc ...)
      (specsubform/subs #:literals () spec subs desc ...)]))
 (define-syntax-rule (specspecsubform spec desc ...)
@@ -888,37 +914,37 @@
 (define-syntax specform
   (syntax-rules ()
     [(_ #:literals (lit ...) spec desc ...)
-     (*specsubform 'spec #t '(lit ...) (lambda () (schemeblock0/form spec))
-                   null null (lambda () (list desc ...)))]
+     (spec?form/subs #t #:literals (lit ...) spec () desc ...)]
     [(_ spec desc ...)
-     (*specsubform 'spec #t null (lambda () (schemeblock0/form spec))
-                   null null (lambda () (list desc ...)))]))
+     (specform #:literals () spec desc ...)]))
 (define-syntax specform/subs
   (syntax-rules ()
     [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
         desc ...)
-     (*specsubform 'spec #t
-                   '(lit ...)
-                   (lambda () (schemeblock0/form spec))
-                   '((non-term-id non-term-form ...) ...)
-                   (list (list (lambda () (scheme non-term-id))
-                               (lambda () (schemeblock0/form non-term-form))
-                               ...)
-                         ...)
-                   (lambda () (list desc ...)))]
+     (spec?form/subs #t #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
+                     desc ...)]
     [(_ spec ([non-term-id non-term-form ...] ...) desc ...)
      (specform/subs #:literals () spec ([non-term-id non-term-form ...] ...)
                     desc ...)]))
 (define-syntax-rule (specsubform/inline spec desc ...)
-  (*specsubform 'spec #f null #f null null (lambda () (list desc ...))))
+  (with-scheme-variables
+   ()
+   ([form/maybe (#f spec)])
+   (*specsubform 'spec null #f null null (lambda () (list desc ...)))))
 (define-syntax-rule (defthing id result desc ...)
-  (*defthing (list (quote-syntax/loc id)) (list 'id) #f
-             (list (schemeblock0 result))
-             (lambda () (list desc ...))))
+  (with-togetherable-scheme-variables
+   ()
+   ()
+   (*defthing (list (quote-syntax/loc id)) (list 'id) #f
+              (list (schemeblock0 result))
+              (lambda () (list desc ...)))))
 (define-syntax-rule (defthing* ([id result] ...) desc ...)
-  (*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f
-             (list (schemeblock0 result) ...)
-             (lambda () (list desc ...))))
+  (with-togetherable-scheme-variables
+   ()
+   ()
+   (*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f
+              (list (schemeblock0 result) ...)
+              (lambda () (list desc ...)))))
 (define-syntax-rule (defparam id arg contract desc ...)
   (defproc* ([(id) contract] [(id [arg contract]) void?]) desc ...))
 (define-syntax-rule (defparam* id arg in-contract out-contract desc ...)
@@ -928,20 +954,26 @@
 (define-syntax schemegrammar
   (syntax-rules ()
     [(_ #:literals (lit ...) id clause ...)
-     (*schemegrammar '(lit ...)
-                     '(id clause ...)
-                     (lambda ()
-                       (list (list (scheme id)
-                                   (schemeblock0/form clause) ...))))]
+     (with-scheme-variables
+      (lit ...)
+      ([non-term (id clause ...)])
+      (*schemegrammar '(lit ...)
+                      '(id clause ...)
+                      (lambda ()
+                        (list (list (scheme id)
+                                    (schemeblock0/form clause) ...)))))]
     [(_ id clause ...) (schemegrammar #:literals () id clause ...)]))
 (define-syntax schemegrammar*
   (syntax-rules ()
     [(_ #:literals (lit ...) [id clause ...] ...)
-     (*schemegrammar '(lit ...)
-                     '(id ... clause ... ...)
-                     (lambda ()
-                       (list (list (scheme id) (schemeblock0/form clause) ...)
-                             ...)))]
+     (with-scheme-variables
+      (lit ...)
+      ([non-term (id clause ...)] ...)
+      (*schemegrammar '(lit ...)
+                      '(id ... clause ... ...)
+                      (lambda ()
+                        (list (list (scheme id) (schemeblock0/form clause) ...)
+                              ...))))]
     [(_ [id clause ...] ...)
      (schemegrammar* #:literals () [id clause ...] ...)]))
 (define-syntax-rule (var id)
@@ -949,6 +981,75 @@
 (define-syntax-rule (svar id)
   (*var 'id))
 
+(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)]))
+
+(define-syntax-rule (with-togetherable-scheme-variables* . rest)
+  (with-scheme-variables . rest))
+
+(define-syntax (with-scheme-variables stx)
+  (syntax-case stx ()
+    [(_ lits ([kind s-exp] ...) body)
+     (let ([ht (make-bound-identifier-mapping)]
+           [lits (syntax->datum #'lits)])
+       (for-each (lambda (kind s-exp)
+                   (case (syntax-e kind)
+                     [(proc)
+                      (for-each
+                       (lambda (arg)
+                         (if (identifier? arg)
+                             (unless (or (eq? (syntax-e arg) '...)
+                                         (eq? (syntax-e arg) '...+)
+                                         (memq (syntax-e arg) lits))
+                               (bound-identifier-mapping-put! ht arg #t))
+                             (syntax-case arg ()
+                               [(kw arg . rest)
+                                (keyword? (syntax-e #'kw))
+                                (bound-identifier-mapping-put! ht #'arg #t)]
+                               [(arg . rest)
+                                (identifier? #'arg)
+                                (bound-identifier-mapping-put! ht #'arg #t)])))
+                       (cdr (syntax->list s-exp)))]
+                     [(form form/maybe non-term)
+                      (let loop ([form (case (syntax-e kind)
+                                         [(form) (if (identifier? s-exp)
+                                                     null
+                                                     (cdr (syntax-e s-exp)))]
+                                         [(form/maybe)
+                                          (syntax-case s-exp ()
+                                            [(#f form) #'form]
+                                            [(#t (id . form)) #'form])]
+                                         [(non-term) s-exp])])
+                        (if (identifier? form)
+                            (unless (or (eq? (syntax-e form) '...)
+                                        (eq? (syntax-e form) '...+)
+                                        (eq? (syntax-e form) '?)
+                                        (memq (syntax-e form) lits))
+                              (bound-identifier-mapping-put! ht form #t))
+                            (syntax-case form (unsyntax)
+                              [(unsyntax _) (void)]
+                              [(a . b) (loop #'a) (loop #'b)]
+                              [#(a ...) (loop #'(a ...))]
+                              [_ (void)])))]
+                     [else
+                      (raise-syntax-error
+                       #f
+                       "unknown variable mode"
+                       stx
+                       kind)]))
+                 (syntax->list #'(kind ...))
+                 (syntax->list #'(s-exp ...)))
+       (with-syntax ([(id ...) (bound-identifier-mapping-map ht (lambda (k v) k))])
+         #'(parameterize ([current-variable-list '(id ...)])
+             body)))]))
+
 (define (defthing/proc id contract descs)
   (*defthing (list id) (list (syntax-e id)) #f (list contract)
              (lambda () descs)))
@@ -1009,7 +1110,7 @@
    (lambda (render part ri)
      (proc (or (get-exporting-libraries render part ri) null)))))
 
-(define-struct (box-splice splice) (var-list))
+(define-struct (box-splice splice) ())
 
 (define (*deftogether boxes body-thunk)
   (make-splice
@@ -1029,12 +1130,33 @@
                                 "together"
                                 (table-flowss (car (splice-run box))))))))
       boxes))
-    (parameterize ([current-variable-list
-                    (append-map box-splice-var-list boxes)])
-      (body-thunk)))))
+    (body-thunk))))
 
-(define-syntax-rule (deftogether (box ...) . body)
-  (*deftogether (list box ...) (lambda () (list . body))))
+(define-syntax (deftogether stx)
+  (syntax-case stx ()
+    [(_ (def ...) . body)
+     (with-syntax ([((_ (lit ...) (var ...) decl) ...)
+                    (map (lambda (def)
+                           (let ([exp-def (local-expand 
+                                           def
+                                           'expression
+                                           (cons
+                                            #'with-togetherable-scheme-variables*
+                                            (kernel-form-identifier-list)))])
+                             (syntax-case exp-def (with-togetherable-scheme-variables*)
+                               [(with-togetherable-scheme-variables* lits vars decl)
+                                exp-def]
+                               [_
+                                (raise-syntax-error
+                                 #f
+                                 "sub-form is not a documentation form that can be combined"
+                                 stx
+                                 def)])))
+                         (syntax->list #'(def ...)))])
+       #'(with-togetherable-scheme-variables
+          (lit ... ...)
+          (var ... ...)
+          (*deftogether (list decl ...) (lambda () (list . body)))))]))
 
 (define-struct arg
   (special? kw id optional? starts-optional? ends-optional? num-closers))
@@ -1365,22 +1487,20 @@
   (define var-list
     (filter-map (lambda (a) (and (not (arg-special? a)) (arg-id a)))
                 (append* all-args)))
-  (parameterize ([current-variable-list var-list])
-    (make-box-splice
-     (cons
-      (make-table
-       'boxed
-       (append-map
-        do-one
-        stx-ids prototypes all-args arg-contractss arg-valss result-contracts
-        (let loop ([ps prototypes] [accum null])
-          (cond [(null? ps) null]
-                [(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum)
-                 (cons #f (loop (cdr ps) accum))]
-                [else (cons #t (loop (cdr ps)
-                                     (cons (extract-id (car ps)) accum)))]))))
-      (content-thunk))
-     var-list)))
+  (make-box-splice
+   (cons
+    (make-table
+     'boxed
+     (append-map
+      do-one
+      stx-ids prototypes all-args arg-contractss arg-valss result-contracts
+      (let loop ([ps prototypes] [accum null])
+        (cond [(null? ps) null]
+              [(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum)
+               (cons #f (loop (cdr ps) accum))]
+              [else (cons #t (loop (cdr ps)
+                                   (cons (extract-id (car ps)) accum)))]))))
+    (content-thunk))))
 
 (define (make-target-element* inner-make-target-element stx-id content wrappers)
   (if (null? wrappers)
@@ -1577,8 +1697,7 @@
                                (make-flow (list (field-contract))))))))]
                [else null]))
            fields field-contracts)))
-    (content-thunk))
-   null))
+    (content-thunk))))
 
 (define (*defthing stx-ids names form? result-contracts content-thunk)
   (make-box-splice
@@ -1623,24 +1742,12 @@
                                 result-contract
                                 (make-omitable-paragraph (list result-contract)))))))))))
       stx-ids names result-contracts))
-    (content-thunk))
-   null))
+    (content-thunk))))
 
 (define (meta-symbol? s) (memq s '(... ...+ ?)))
 
-(define (*defforms kw-id lits forms form-procs subs sub-procs content-thunk)
-  (define var-list
-    (let loop ([form (cons forms subs)])
-      (cond [(symbol? form)
-             (if (or (meta-symbol? form)
-                     (and kw-id (eq? form (syntax-e kw-id)))
-                     (memq form lits))
-               null
-               (list form))]
-            [(pair? form) (append (loop (car form)) (loop (cdr form)))]
-            [else null])))
-  (parameterize ([current-variable-list var-list]
-                 [current-meta-list '(... ...+)])
+(define (*defforms kw-id forms form-procs subs sub-procs content-thunk)
+  (parameterize ([current-meta-list '(... ...+)])
     (make-box-splice
      (cons
       (make-table
@@ -1689,23 +1796,10 @@
                                (*schemerawgrammars "specgrammar"
                                                    (map car l)
                                                    (map cdr l))))))))))
-      (content-thunk))
-     var-list)))
+      (content-thunk)))))
 
-(define (*specsubform form has-kw? lits form-thunk subs sub-procs content-thunk)
-  (parameterize ([current-variable-list
-                  (append (let loop ([form (cons (if has-kw? (cdr form) form)
-                                                 subs)])
-                            (cond
-                              [(symbol? form) (if (or (meta-symbol? form)
-                                                      (memq form lits))
-                                                null
-                                                (list form))]
-                              [(pair? form) (append (loop (car form))
-                                                    (loop (cdr form)))]
-                              [else null]))
-                          (current-variable-list))]
-                 [current-meta-list '(... ...+)])
+(define (*specsubform form lits form-thunk subs sub-procs content-thunk)
+  (parameterize ([current-meta-list '(... ...+)])
     (make-blockquote
      "leftindent"
      (cons
@@ -1754,23 +1848,14 @@
   (*schemerawgrammars style (list nonterm) (list (cons clause1 clauses))))
 
 (define (*schemegrammar lits s-expr clauseses-thunk)
-  (parameterize ([current-variable-list
-                  (let loop ([form s-expr])
-                    (cond
-                      [(symbol? form) (if (memq form lits)
-                                        null
-                                        (list form))]
-                      [(pair? form) (append (loop (car form))
-                                            (loop (cdr form)))]
-                      [else null]))])
-    (let ([l (clauseses-thunk)])
-      (*schemerawgrammars #f
-                          (map (lambda (x)
-                                 (make-element #f
-                                               (list (hspace 2)
-                                                     (car x))))
-                               l)
-                          (map cdr l)))))
+  (let ([l (clauseses-thunk)])
+    (*schemerawgrammars #f
+                        (map (lambda (x)
+                               (make-element #f
+                                             (list (hspace 2)
+                                                   (car x))))
+                             l)
+                        (map cdr l))))
 
 (define (*var id)
   (to-element (*var-sym id)))
@@ -2425,16 +2510,22 @@
          signature-desc)
 
 (define-syntax-rule (defsignature name (super ...) body ...)
-  (*defsignature (quote-syntax name)
-                 (list (quote-syntax super) ...)
-                 (lambda () (list body ...))
-                 #t))
+  (with-togetherable-scheme-variables
+   ()
+   ()
+   (*defsignature (quote-syntax name)
+                  (list (quote-syntax super) ...)
+                  (lambda () (list body ...))
+                  #t)))
 
 (define-syntax-rule (defsignature/splice name (super ...) body ...)
-  (*defsignature (quote-syntax name)
-                 (list (quote-syntax super) ...)
-                 (lambda () (list body ...))
-                 #f))
+  (with-togetherable-scheme-variables
+   ()
+   ()
+   (*defsignature (quote-syntax name)
+                  (list (quote-syntax super) ...)
+                  (lambda () (list body ...))
+                  #f)))
 
 (define-struct sig-desc (in))
 (define (signature-desc . l)
diff --git a/collects/scribblings/guide/for.scrbl b/collects/scribblings/guide/for.scrbl
index 2d5cdce9d6..29fe2b9349 100644
--- a/collects/scribblings/guide/for.scrbl
+++ b/collects/scribblings/guide/for.scrbl
@@ -391,7 +391,7 @@ fast-clause [id fast-seq]
 ]
 
 @schemegrammar[
-#:literals [in-range in-naturals in-list in-vector in-string in-bytes stop-before stop-after]
+#:literals [in-range in-naturals in-list in-vector in-string in-bytes in-value stop-before stop-after]
 fast-seq (in-range expr expr)
          (in-range expr expr expr)
          (in-naturals)
diff --git a/collects/scribblings/guide/pattern-macros.scrbl b/collects/scribblings/guide/pattern-macros.scrbl
index 3b41fe35b7..ae3f087a9e 100644
--- a/collects/scribblings/guide/pattern-macros.scrbl
+++ b/collects/scribblings/guide/pattern-macros.scrbl
@@ -144,7 +144,8 @@ such macros, the programmer much use the more general
 @scheme[define-syntax] form along with the @scheme[syntax-rules]
 transformer form:
 
-@specform[(define-syntax id
+@specform[#:literals (syntax-rules)
+          (define-syntax id
             (syntax-rules (literal-id ...)
               [pattern template]
               ...))]
@@ -260,7 +261,8 @@ clock 3)] expands to @scheme[(put-clock! 3)].
 The @scheme[syntax-id-rules] form is like @scheme[syntax-rules], but
 it creates a transformer that acts as an identifier macro:
 
-@specform[(define-syntax id
+@specform[#:literals (syntax-id-rules)
+          (define-syntax id
             (syntax-id-rules (literal-id ...)
               [pattern template]
               ...))]
diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index be450d7817..76eb3302a4 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -310,7 +310,7 @@ checking will not terminate.}
 
 @defform[(flat-murec-contract ([id flat-contract-expr ...] ...) body ...+)]{
 
-A generalization of @scheme[flat-rec-contracts] for defining several
+A generalization of @scheme[flat-rec-contract] for defining several
 mutually recursive flat contracts simultaneously. Each @scheme[id] is
 visible in the entire @scheme[flat-murec-contract] form, and the
 result of the final @scheme[body] is the result of the entire form.}
@@ -988,7 +988,7 @@ raised by the contract system.}
 
 @defproc[(contract? [v any/c]) boolean?]{
 
-Returns @scheme[#t] if its argument is a contract (ie, constructed
+Returns @scheme[#t] if its argument is a contract (i.e., constructed
 with one of the combinators described in this section or a value that
 can be used as a contract) and @scheme[#f] otherwise.}