From bf5dddbd13fa45fd1950289624bbd05e9ec92135 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Mon, 8 Dec 2008 17:06:53 +0000
Subject: [PATCH 01/29] Adding current unit contract work over here.

svn: r12743
---
 collects/mzlib/private/unit-compiletime.ss | 23 +++++++++--
 collects/mzlib/unit.ss                     | 44 +++++++++++++++++-----
 2 files changed, 53 insertions(+), 14 deletions(-)

diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss
index f05c7f8691..079764d012 100644
--- a/collects/mzlib/private/unit-compiletime.ss
+++ b/collects/mzlib/private/unit-compiletime.ss
@@ -57,8 +57,10 @@
   ;; - (cons identifier identifier)
   ;; A def is
   ;; - (listof (cons (listof int/ext) syntax-object))
+  ;; A ctc-pair is
+  ;; - (cons int/ext syntax-object)
   ;; A sig is
-  ;; - (list (listof int/ext) (listof def) (listof def))
+  ;; - (list (listof int/ext) (listof def) (listof def) (listof ctc-pair))
   ;; A tagged-sig is 
   ;; - (listof (cons #f siginfo) (cons #f identifier) sig)
   ;; - (listof (cons symbol siginfo) (cons symbol identifier) sig)
@@ -95,8 +97,9 @@
   ;;                 (listof identifier)
   ;;                 (listof (cons (listof identifier) syntax-object))
   ;;                 (listof (cons (listof identifier) syntax-object))
+  ;;                 (listof (cons identifier syntax-object))
   ;;                 identifier)
-  (define-struct/proc signature (siginfo vars val-defs stx-defs orig-binder)
+  (define-struct/proc signature (siginfo vars val-defs stx-defs ctc-pairs orig-binder)
     (lambda (_ stx)
       (parameterize ((error-syntax stx))
         (raise-stx-err "illegal use of signature name"))))
@@ -219,6 +222,7 @@
            (vars (signature-vars sig))
            (vals (signature-val-defs sig))
            (stxs (signature-stx-defs sig))
+           (cps  (signature-ctc-pairs sig))
            (delta-introduce (if bind?
                                 (let ([f (syntax-local-make-delta-introducer
                                           spec)])
@@ -243,7 +247,12 @@
                         (cons (map (λ (id) (cons id id))
                                    (car stx))
                               (cdr stx)))
-                      stxs)))))
+                      stxs)
+                     (map
+                      (λ (cp)
+                        (cons (cons (car cp) (car cp))
+                              (cdr cp)))
+                      cps)))))
   
   (define (sig-names sig)
     (append (car sig)
@@ -264,12 +273,18 @@
                (car def))
           (g (cdr def))))
   
+  ;; map-ctc-pair : (identifier -> identifier) (syntax-object -> syntax-object) ctc-pair -> ctc-pair
+  (define (map-ctc-pair f g cp)
+    (cons (cons (f (caar cp)) (g (cdar cp)))
+          (g (cdr cp))))
+  
   ;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object)  sig -> sig
   ;; applies f to the internal parts, and g to the external parts.
   (define (map-sig f g sig)
     (list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig))
           (map (lambda (x) (map-def f g x)) (cadr sig))
-          (map (lambda (x) (map-def f g x)) (caddr sig))))
+          (map (lambda (x) (map-def f g x)) (caddr sig))
+          (map (lambda (x) (map-ctc-pair f g x)) (cadddr sig))))
   
   ;; An import-spec is one of
   ;; - signature-name
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 593155f322..48ba22921b 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -123,7 +123,8 @@
   (define-for-syntax (build-val+macro-defs sig)
     (with-syntax ([(((int-ivar . ext-ivar) ...)
                     ((((int-vid . ext-vid) ...) . vbody) ...)
-                    ((((int-sid . ext-sid) ...) . sbody) ...))
+                    ((((int-sid . ext-sid) ...) . sbody) ...)
+                    (((int-cid . ext-cid) . cbody) ...))
                    (map-sig (lambda (x) x)
                             (make-syntax-introducer)
                             sig)])
@@ -164,13 +165,17 @@
     (cons (map syntax-local-introduce (car d))
           (syntax-local-introduce (cdr d))))
   
+  (define-for-syntax (introduce-ctc-pair cp)
+    (cons (syntax-local-introduce (car cp))
+          (syntax-local-introduce (cdr cp))))
+  
   ;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object
   (define-for-syntax (build-define-signature sigid super-sigid sig-exprs)
     (unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs))
       (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs))
     (let ([ses (checked-syntax->list sig-exprs)])
       (define-values (super-names super-ctimes super-rtimes super-bindings
-                                  super-val-defs super-stx-defs)
+                                  super-val-defs super-stx-defs super-ctc-pairs)
         (if super-sigid
             (let* ([super-sig (lookup-signature super-sigid)]
                    [super-siginfo (signature-siginfo super-sig)])
@@ -180,17 +185,20 @@
                            (siginfo-rtime-ids super-siginfo))
                       (map syntax-local-introduce (signature-vars super-sig))
                       (map introduce-def (signature-val-defs super-sig))
-                      (map introduce-def (signature-stx-defs super-sig))))
-            (values '() '() '() '() '() '())))
+                      (map introduce-def (signature-stx-defs super-sig))
+                      (map introduce-ctc-pair (signature-ctc-pairs super-sig))))
+            (values '() '() '() '() '() '() '())))
       (let loop ((sig-exprs ses)
                  (bindings null)
                  (val-defs null)
-                 (stx-defs null))
+                 (stx-defs null)
+                 (ctc-pairs null))
         (cond
           ((null? sig-exprs)
            (let* ([all-bindings (append super-bindings (reverse bindings))]
                   [all-val-defs (append super-val-defs (reverse val-defs))]
                   [all-stx-defs (append super-stx-defs (reverse stx-defs))]
+                  [all-ctc-pairs (append super-ctc-pairs (reverse ctc-pairs))]
                   [dup
                    (check-duplicate-identifier
                     (append all-bindings
@@ -202,7 +210,8 @@
                            ((super-name ...) super-names)
                            ((var ...) all-bindings)
                            ((((vid ...) . vbody) ...) all-val-defs)
-                           ((((sid ...) . sbody) ...) all-stx-defs))
+                           ((((sid ...) . sbody) ...) all-stx-defs)
+                           (((cid . cbody) ...) all-ctc-pairs))
                #`(begin
                    (define signature-tag (gensym))
                    (define-syntax #,sigid
@@ -221,12 +230,25 @@
                                    ((syntax-local-certifier)
                                     (quote-syntax sbody)))
                              ...)
+                       (list (cons (quote-syntax cid)
+                                   ((syntax-local-certifier)
+                                    (quote-syntax cbody)))
+                             ...)
                        (quote-syntax #,sigid))))))))
           (else
-           (syntax-case (car sig-exprs) (define-values define-syntaxes)
+           (syntax-case (car sig-exprs) (define-values define-syntaxes contracted)
              (x
               (identifier? #'x)
-              (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs))
+              (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs ctc-pairs))
+             ((x y z)
+              (and (identifier? #'x)
+                   (module-identifier=? #'x #'contracted)
+                   (identifier? #'y))
+              (loop (cdr sig-exprs)
+                    (cons #'y bindings)
+                    val-defs
+                    stx-defs
+                    (cons (cons #'y #'z) ctc-pairs)))
              ((x . y)
               (and (identifier? #'x)
                    (or (module-identifier=? #'x #'define-values)
@@ -248,7 +270,8 @@
                              (if (module-identifier=? #'x #'define-syntaxes)
                                  (cons (cons (syntax->list #'(name ...)) b)
                                        stx-defs)
-                                 stx-defs))))))))
+                                 stx-defs)
+                             ctc-pairs)))))))
              ((x . y)
               (let ((trans 
                      (set!-trans-extract
@@ -266,7 +289,8 @@
                   (loop (append results (cdr sig-exprs))
                         bindings
                         val-defs
-                        stx-defs))))
+                        stx-defs
+                        ctc-pairs))))
              (x (raise-stx-err 
                  "expected either an identifier or signature form"
                  #'x))))))))

From a9be78545d95d72e5076d14369afae8b5774dbad Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 9 Dec 2008 22:14:11 +0000
Subject: [PATCH 02/29] Add contracts to unit imports and values imported via
 define-values/invoke-unit.  We still need contracts on unit exports, and we
 might want to do the stuff here in a cleaner fashion (particularly for
 define-values/invoke-unit).

svn: r12759
---
 collects/mzlib/private/unit-compiletime.ss | 30 ++++-----
 collects/mzlib/unit.ss                     | 76 +++++++++++++---------
 2 files changed, 61 insertions(+), 45 deletions(-)

diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss
index 079764d012..db2b8ea90b 100644
--- a/collects/mzlib/private/unit-compiletime.ss
+++ b/collects/mzlib/private/unit-compiletime.ss
@@ -57,10 +57,11 @@
   ;; - (cons identifier identifier)
   ;; A def is
   ;; - (listof (cons (listof int/ext) syntax-object))
-  ;; A ctc-pair is
-  ;; - (cons int/ext syntax-object)
+  ;; A ctc is
+  ;; - syntax-object
+  ;; - #f
   ;; A sig is
-  ;; - (list (listof int/ext) (listof def) (listof def) (listof ctc-pair))
+  ;; - (list (listof int/ext) (listof def) (listof def) (listof ctc))
   ;; A tagged-sig is 
   ;; - (listof (cons #f siginfo) (cons #f identifier) sig)
   ;; - (listof (cons symbol siginfo) (cons symbol identifier) sig)
@@ -97,9 +98,9 @@
   ;;                 (listof identifier)
   ;;                 (listof (cons (listof identifier) syntax-object))
   ;;                 (listof (cons (listof identifier) syntax-object))
-  ;;                 (listof (cons identifier syntax-object))
+  ;;                 (listof syntax-object)
   ;;                 identifier)
-  (define-struct/proc signature (siginfo vars val-defs stx-defs ctc-pairs orig-binder)
+  (define-struct/proc signature (siginfo vars val-defs stx-defs ctcs orig-binder)
     (lambda (_ stx)
       (parameterize ((error-syntax stx))
         (raise-stx-err "illegal use of signature name"))))
@@ -222,7 +223,7 @@
            (vars (signature-vars sig))
            (vals (signature-val-defs sig))
            (stxs (signature-stx-defs sig))
-           (cps  (signature-ctc-pairs sig))
+           (ctcs  (signature-ctcs sig))
            (delta-introduce (if bind?
                                 (let ([f (syntax-local-make-delta-introducer
                                           spec)])
@@ -248,11 +249,7 @@
                                    (car stx))
                               (cdr stx)))
                       stxs)
-                     (map
-                      (λ (cp)
-                        (cons (cons (car cp) (car cp))
-                              (cdr cp)))
-                      cps)))))
+                     ctcs))))
   
   (define (sig-names sig)
     (append (car sig)
@@ -273,10 +270,11 @@
                (car def))
           (g (cdr def))))
   
-  ;; map-ctc-pair : (identifier -> identifier) (syntax-object -> syntax-object) ctc-pair -> ctc-pair
-  (define (map-ctc-pair f g cp)
-    (cons (cons (f (caar cp)) (g (cdar cp)))
-          (g (cdr cp))))
+  ;; map-ctc : (identifier -> identifier) (syntax-object -> syntax-object) ctc -> ctc
+  (define (map-ctc f g ctc)
+    (if ctc
+        (g ctc)
+        ctc))
   
   ;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object)  sig -> sig
   ;; applies f to the internal parts, and g to the external parts.
@@ -284,7 +282,7 @@
     (list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig))
           (map (lambda (x) (map-def f g x)) (cadr sig))
           (map (lambda (x) (map-def f g x)) (caddr sig))
-          (map (lambda (x) (map-ctc-pair f g x)) (cadddr sig))))
+          (map (lambda (x) (map-ctc f g x)) (cadddr sig))))
   
   ;; An import-spec is one of
   ;; - signature-name
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 48ba22921b..17370eac95 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -9,7 +9,8 @@
                       "private/unit-compiletime.ss"
                       "private/unit-syntax.ss")
   
-  (require mzlib/etc
+  (require mzlib/contract
+           mzlib/etc
            "private/unit-keywords.ss"
            "private/unit-runtime.ss")
   
@@ -124,7 +125,7 @@
     (with-syntax ([(((int-ivar . ext-ivar) ...)
                     ((((int-vid . ext-vid) ...) . vbody) ...)
                     ((((int-sid . ext-sid) ...) . sbody) ...)
-                    (((int-cid . ext-cid) . cbody) ...))
+                    (cbody ...))
                    (map-sig (lambda (x) x)
                             (make-syntax-introducer)
                             sig)])
@@ -165,17 +166,13 @@
     (cons (map syntax-local-introduce (car d))
           (syntax-local-introduce (cdr d))))
   
-  (define-for-syntax (introduce-ctc-pair cp)
-    (cons (syntax-local-introduce (car cp))
-          (syntax-local-introduce (cdr cp))))
-  
   ;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object
   (define-for-syntax (build-define-signature sigid super-sigid sig-exprs)
     (unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs))
       (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs))
     (let ([ses (checked-syntax->list sig-exprs)])
       (define-values (super-names super-ctimes super-rtimes super-bindings
-                                  super-val-defs super-stx-defs super-ctc-pairs)
+                                  super-val-defs super-stx-defs super-ctcs)
         (if super-sigid
             (let* ([super-sig (lookup-signature super-sigid)]
                    [super-siginfo (signature-siginfo super-sig)])
@@ -186,19 +183,23 @@
                       (map syntax-local-introduce (signature-vars super-sig))
                       (map introduce-def (signature-val-defs super-sig))
                       (map introduce-def (signature-stx-defs super-sig))
-                      (map introduce-ctc-pair (signature-ctc-pairs super-sig))))
+                      (map (lambda (ctc)
+                             (if ctc
+                                 (syntax-local-introduce ctc)
+                                 ctc))
+                           (signature-ctcs super-sig))))
             (values '() '() '() '() '() '() '())))
       (let loop ((sig-exprs ses)
                  (bindings null)
                  (val-defs null)
                  (stx-defs null)
-                 (ctc-pairs null))
+                 (ctcs null))
         (cond
           ((null? sig-exprs)
            (let* ([all-bindings (append super-bindings (reverse bindings))]
                   [all-val-defs (append super-val-defs (reverse val-defs))]
                   [all-stx-defs (append super-stx-defs (reverse stx-defs))]
-                  [all-ctc-pairs (append super-ctc-pairs (reverse ctc-pairs))]
+                  [all-ctcs (append super-ctcs (reverse ctcs))]
                   [dup
                    (check-duplicate-identifier
                     (append all-bindings
@@ -210,8 +211,7 @@
                            ((super-name ...) super-names)
                            ((var ...) all-bindings)
                            ((((vid ...) . vbody) ...) all-val-defs)
-                           ((((sid ...) . sbody) ...) all-stx-defs)
-                           (((cid . cbody) ...) all-ctc-pairs))
+                           ((((sid ...) . sbody) ...) all-stx-defs))
                #`(begin
                    (define signature-tag (gensym))
                    (define-syntax #,sigid
@@ -230,16 +230,18 @@
                                    ((syntax-local-certifier)
                                     (quote-syntax sbody)))
                              ...)
-                       (list (cons (quote-syntax cid)
-                                   ((syntax-local-certifier)
-                                    (quote-syntax cbody)))
-                             ...)
+                       (list #,@(map (lambda (c) 
+                                       (if c
+                                           #`((syntax-local-certifier)
+                                              (quote-syntax #,c))
+                                           #'#f))
+                                     all-ctcs))
                        (quote-syntax #,sigid))))))))
           (else
            (syntax-case (car sig-exprs) (define-values define-syntaxes contracted)
              (x
               (identifier? #'x)
-              (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs ctc-pairs))
+              (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs)))
              ((x y z)
               (and (identifier? #'x)
                    (module-identifier=? #'x #'contracted)
@@ -248,7 +250,7 @@
                     (cons #'y bindings)
                     val-defs
                     stx-defs
-                    (cons (cons #'y #'z) ctc-pairs)))
+                    (cons #'z ctcs)))
              ((x . y)
               (and (identifier? #'x)
                    (or (module-identifier=? #'x #'define-values)
@@ -271,7 +273,7 @@
                                  (cons (cons (syntax->list #'(name ...)) b)
                                        stx-defs)
                                  stx-defs)
-                             ctc-pairs)))))))
+                             ctcs)))))))
              ((x . y)
               (let ((trans 
                      (set!-trans-extract
@@ -290,7 +292,7 @@
                         bindings
                         val-defs
                         stx-defs
-                        ctc-pairs))))
+                        ctcs))))
              (x (raise-stx-err 
                  "expected either an identifier or signature form"
                  #'x))))))))
@@ -449,6 +451,13 @@
   (define-for-syntax process-unit-export
     (process-unit-import/export process-tagged-export))
   
+  (define-for-syntax (make-import-unboxing loc ctc name)
+    (if ctc
+        (quasisyntax/loc (error-syntax)
+          (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name)))
+        (quasisyntax/loc (error-syntax)
+          (quote-syntax (unbox #,loc)))))
+  
   ;; build-unit : syntax-object -> 
   ;;             (values syntax-object (listof identifier) (listof identifier))
   ;; constructs the code for a unit expression.  stx must be
@@ -525,11 +534,17 @@
                       (let-values ([(iloc ...)
                                     (vector->values (hash-table-get import-table import-key) 0 icount)]
                                    ...)
-                        (letrec-syntaxes ([(int-ivar ...)
-                                           (make-id-mappers
-                                            (quote-syntax (unbox iloc))
-                                            ...)]
-                                          ...
+                        (letrec-syntaxes (#,@(map (lambda (ivs ils ics)
+                                                    (quasisyntax/loc (error-syntax)
+                                                      [#,ivs
+                                                       (make-id-mappers
+                                                        #,@(map (lambda (l c)
+                                                                  (make-import-unboxing l c #'name))
+                                                                (syntax->list ils)
+                                                                ics))]))
+                                                  (syntax->list #'((int-ivar ...) ...))
+                                                  (syntax->list #'((iloc ...) ...))
+                                                  (map cadddr import-sigs))
                                           [(int-evar ...)
                                            (make-id-mappers
                                             (quote-syntax (unbox eloc))
@@ -1205,9 +1220,12 @@
                         (map 
                          (lambda (os ov)
                            (map 
-                            (lambda (i)
-                              #`(vector-ref #,ov #,i))
-                            (iota (length (car os)))))
+                            (lambda (i c)
+                              (if c
+                                  #`(contract #,c (unbox (vector-ref #,ov #,i)) 'cant-happen (#%variable-reference))
+                                  #`(unbox (vector-ref #,ov #,i))))
+                            (iota (length (car os)))
+                            (cadddr os)))
                          out-sigs
                          out-vec)))
            (quasisyntax/loc stx
@@ -1225,7 +1243,7 @@
                                      ((unit-go unit-tmp))))
                          (let ([out-vec (hash-table-get export-table key1)] ...)
                            (unit-fn #f)
-                           (values (unbox out-code) ... ...))))))
+                           (values out-code ... ...))))))
                (define-syntaxes . renames) ...
                (define-syntaxes (mac-name ...) mac-body) ... ...
                (define-values (val-name ...) val-body) ... ...)))))

From 90ad3f9221a9b5c31a673dcc820304e7b6c86872 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 9 Dec 2008 23:16:48 +0000
Subject: [PATCH 03/29] Do the let so that (hopefully) the contract errors will
 get reported on the identifier.  With a small change in scheme/contract, it
 does, but even with this, it doesn't seem to.  How odd.

svn: r12760
---
 collects/mzlib/unit.ss | 16 ++++++++++------
 1 file changed, 10 insertions(+), 6 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 17370eac95..90e6b594a1 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -451,10 +451,11 @@
   (define-for-syntax process-unit-export
     (process-unit-import/export process-tagged-export))
   
-  (define-for-syntax (make-import-unboxing loc ctc name)
+  (define-for-syntax (make-import-unboxing var loc ctc name)
     (if ctc
         (quasisyntax/loc (error-syntax)
-          (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name)))
+          (quote-syntax (let ([#,var (unbox #,loc)])
+                          (contract #,ctc #,var 'cant-happen '#,name))))
         (quasisyntax/loc (error-syntax)
           (quote-syntax (unbox #,loc)))))
   
@@ -538,8 +539,9 @@
                                                     (quasisyntax/loc (error-syntax)
                                                       [#,ivs
                                                        (make-id-mappers
-                                                        #,@(map (lambda (l c)
-                                                                  (make-import-unboxing l c #'name))
+                                                        #,@(map (lambda (v l c)
+                                                                  (make-import-unboxing v l c #'name))
+                                                                (syntax->list ivs)
                                                                 (syntax->list ils)
                                                                 ics))]))
                                                   (syntax->list #'((int-ivar ...) ...))
@@ -1220,11 +1222,13 @@
                         (map 
                          (lambda (os ov)
                            (map 
-                            (lambda (i c)
+                            (lambda (i iv c)
                               (if c
-                                  #`(contract #,c (unbox (vector-ref #,ov #,i)) 'cant-happen (#%variable-reference))
+                                  #`(let ([#,iv (unbox (vector-ref #,ov #,i))])
+                                      (contract #,c #,iv 'cant-happen (#%variable-reference)))
                                   #`(unbox (vector-ref #,ov #,i))))
                             (iota (length (car os)))
+                            (map car (car os))
                             (cadddr os)))
                          out-sigs
                          out-vec)))

From 56854a84bd2958f23eae2d04a185ed29eafbc077 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Wed, 10 Dec 2008 17:19:39 +0000
Subject: [PATCH 04/29] I'd like a better way of handling export contracts
 (some of the work that should be doable at compile time is being done at run
 time), but at least this works for now and gives us a chance to play around
 with it.

svn: r12763
---
 collects/mzlib/private/unit-compiletime.ss |  2 +-
 collects/mzlib/unit.ss                     | 37 +++++++++++++++-------
 2 files changed, 27 insertions(+), 12 deletions(-)

diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss
index db2b8ea90b..0e910972de 100644
--- a/collects/mzlib/private/unit-compiletime.ss
+++ b/collects/mzlib/private/unit-compiletime.ss
@@ -46,7 +46,7 @@
                  
         
   ;; (make-var-info bool bool identifier)
-  (define-struct var-info (syntax? [exported? #:mutable] id))
+  (define-struct var-info (syntax? [exported? #:mutable] id [ctc #:mutable]))
   
   (define-syntax define-struct/proc
     (syntax-rules ()
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 90e6b594a1..e49627e4d1 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -454,8 +454,8 @@
   (define-for-syntax (make-import-unboxing var loc ctc name)
     (if ctc
         (quasisyntax/loc (error-syntax)
-          (quote-syntax (let ([#,var (unbox #,loc)])
-                          (contract #,ctc #,var 'cant-happen '#,name))))
+          (quote-syntax (let ([#,var (contract #,ctc (unbox #,loc) 'cant-happen '#,name)])
+                          #,var)))
         (quasisyntax/loc (error-syntax)
           (quote-syntax (unbox #,loc)))))
   
@@ -505,6 +505,8 @@
                         (map (lambda (x) (generate-temporaries (car x))) import-sigs)]
                        [((eloc ...) ...)
                         (map (lambda (x) (generate-temporaries (car x))) export-sigs)]
+                       [((ectc ...) ...)
+                        (map cadddr export-sigs)]
                        [((import-key import-super-keys ...) ...)
                         (map tagged-info->keys import-tagged-infos)]
                        [((export-key ...) ...)
@@ -559,6 +561,7 @@
                                        (int-ivar ... ...)
                                        (int-evar ... ...)
                                        (eloc ... ...)
+                                       (ectc ... ...)
                                        . body)))))
                     (unit-export ((export-key ...) (vector-immutable eloc ...)) ...))))))
             import-tagged-sigids
@@ -574,7 +577,7 @@
   
   (define-syntax (unit-body stx)
     (syntax-case stx ()
-      ((_ err-stx ivars evars elocs body ...)
+      ((_ err-stx ivars evars elocs ectcs body ...)
        (parameterize ((error-syntax #'err-stx))
          (let* ([expand-context (generate-expand-context)]
                 [def-ctx (syntax-local-make-definition-context)]
@@ -646,7 +649,8 @@
                                    table id 
                                    (make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes))
                                                   #f
-                                                  id)))
+                                                  id
+                                                  #'#f)))
                                 (syntax->list #'(id ...)))]
                               [_ (void)])))
                          [_ (void)]))
@@ -657,7 +661,7 @@
            ;; Mark exported names and
            ;; check that all exported names are defined (as var):
            (for-each
-            (lambda (name loc)
+            (lambda (name loc ctc)
               (let ([v (bound-identifier-mapping-get defined-names-table
                                                      name
                                                      (lambda () #f))])
@@ -665,9 +669,11 @@
                   (raise-stx-err (format "undefined export ~a" (syntax-e name))))
                 (when (var-info-syntax? v)
                   (raise-stx-err "cannot export syntax from a unit" name))
-                (set-var-info-exported?! v loc)))
+                (set-var-info-exported?! v loc)
+                (set-var-info-ctc! v ctc)))
             local-evars
-            (syntax->list #'elocs))
+            (syntax->list #'elocs)
+            (syntax->list #'ectcs))
            
            ;; Check that none of the imports are defined
            (for-each
@@ -704,8 +710,15 @@
                                      (let ([ids (syntax->list #'ids)]
                                            [do-one
                                             (lambda (id tmp name)
-                                              (let ([export-loc
+                                              (let ([unit-name
+                                                     (syntax-local-infer-name (error-syntax))]
+                                                    [export-loc
                                                      (var-info-exported?
+                                                      (bound-identifier-mapping-get
+                                                       defined-names-table
+                                                       id))]
+                                                    [ctc
+                                                     (var-info-ctc
                                                       (bound-identifier-mapping-get
                                                        defined-names-table
                                                        id))])
@@ -715,7 +728,9 @@
                                                    (quasisyntax/loc defn-or-expr
                                                      (set-box! #,export-loc 
                                                                #,(if name
-                                                                     #`(let ([#,name #,tmp])
+                                                                     #`(let ([#,name (if #,ctc
+                                                                                         (contract #,ctc #,tmp '#,unit-name 'cant-happen)
+                                                                                         #,tmp)])
                                                                          #,name)
                                                                      tmp))))
                                                   (else
@@ -1224,8 +1239,8 @@
                            (map 
                             (lambda (i iv c)
                               (if c
-                                  #`(let ([#,iv (unbox (vector-ref #,ov #,i))])
-                                      (contract #,c #,iv 'cant-happen (#%variable-reference)))
+                                  #`(let ([#,iv (contract #,c (unbox (vector-ref #,ov #,i)) 'cant-happen (#%variable-reference))])
+                                      #,iv)
                                   #`(unbox (vector-ref #,ov #,i))))
                             (iota (length (car os)))
                             (map car (car os))

From 8bc883d1cbf2921c4a42b2b19441de0155b742c2 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Wed, 10 Dec 2008 18:51:40 +0000
Subject: [PATCH 05/29] Last changes, everything works up to here.

svn: r12765
---
 collects/mzlib/private/unit-compiletime.ss |  4 +-
 collects/mzlib/unit.ss                     | 47 +++++++++++++---------
 2 files changed, 30 insertions(+), 21 deletions(-)

diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss
index 0e910972de..767856da13 100644
--- a/collects/mzlib/private/unit-compiletime.ss
+++ b/collects/mzlib/private/unit-compiletime.ss
@@ -45,8 +45,8 @@
             (cons (reverse requires) l)))))))
                  
         
-  ;; (make-var-info bool bool identifier)
-  (define-struct var-info (syntax? [exported? #:mutable] id [ctc #:mutable]))
+  ;; (make-var-info bool bool identifier (or #f (syntax-object -> syntax-object)))
+  (define-struct var-info (syntax? [exported? #:mutable] id [add-ctc #:mutable]))
   
   (define-syntax define-struct/proc
     (syntax-rules ()
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index e49627e4d1..86e70628ba 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -451,11 +451,11 @@
   (define-for-syntax process-unit-export
     (process-unit-import/export process-tagged-export))
   
-  (define-for-syntax (make-import-unboxing var loc ctc name)
+  (define-for-syntax (make-import-unboxing int-var ext-var loc ctc name)
     (if ctc
         (quasisyntax/loc (error-syntax)
-          (quote-syntax (let ([#,var (contract #,ctc (unbox #,loc) 'cant-happen '#,name)])
-                          #,var)))
+          (quote-syntax (let ([#,int-var (contract #,ctc (unbox #,loc) 'cant-happen '#,name (quote-syntax #,ext-var))])
+                          #,int-var)))
         (quasisyntax/loc (error-syntax)
           (quote-syntax (unbox #,loc)))))
   
@@ -537,16 +537,18 @@
                       (let-values ([(iloc ...)
                                     (vector->values (hash-table-get import-table import-key) 0 icount)]
                                    ...)
-                        (letrec-syntaxes (#,@(map (lambda (ivs ils ics)
+                        (letrec-syntaxes (#,@(map (lambda (ivs evs ils ics)
                                                     (quasisyntax/loc (error-syntax)
                                                       [#,ivs
                                                        (make-id-mappers
-                                                        #,@(map (lambda (v l c)
-                                                                  (make-import-unboxing v l c #'name))
+                                                        #,@(map (lambda (iv ev l c)
+                                                                  (make-import-unboxing iv ev l c #'name))
                                                                 (syntax->list ivs)
+                                                                (syntax->list evs)
                                                                 (syntax->list ils)
                                                                 ics))]))
                                                   (syntax->list #'((int-ivar ...) ...))
+                                                  (syntax->list #'((ext-ivar ...) ...))
                                                   (syntax->list #'((iloc ...) ...))
                                                   (map cadddr import-sigs))
                                           [(int-evar ...)
@@ -560,6 +562,7 @@
                             (unit-body #,(error-syntax)
                                        (int-ivar ... ...)
                                        (int-evar ... ...)
+                                       (ext-evar ... ...)
                                        (eloc ... ...)
                                        (ectc ... ...)
                                        . body)))))
@@ -577,7 +580,7 @@
   
   (define-syntax (unit-body stx)
     (syntax-case stx ()
-      ((_ err-stx ivars evars elocs ectcs body ...)
+      ((_ err-stx ivars evars ext-evars elocs ectcs body ...)
        (parameterize ((error-syntax #'err-stx))
          (let* ([expand-context (generate-expand-context)]
                 [def-ctx (syntax-local-make-definition-context)]
@@ -650,7 +653,7 @@
                                    (make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes))
                                                   #f
                                                   id
-                                                  #'#f)))
+                                                  #f)))
                                 (syntax->list #'(id ...)))]
                               [_ (void)])))
                          [_ (void)]))
@@ -661,18 +664,23 @@
            ;; Mark exported names and
            ;; check that all exported names are defined (as var):
            (for-each
-            (lambda (name loc ctc)
+            (lambda (name loc var ctc)
               (let ([v (bound-identifier-mapping-get defined-names-table
                                                      name
-                                                     (lambda () #f))])
+                                                     (lambda () #f))]
+                    [unit-name (syntax-local-infer-name (error-syntax))])
                 (unless v
                   (raise-stx-err (format "undefined export ~a" (syntax-e name))))
                 (when (var-info-syntax? v)
                   (raise-stx-err "cannot export syntax from a unit" name))
                 (set-var-info-exported?! v loc)
-                (set-var-info-ctc! v ctc)))
+                (set-var-info-add-ctc! v (lambda (e)
+                                       #`(if #,ctc
+                                             (contract #,ctc #,e '#,unit-name 'cant-happen (quote-syntax #,var))
+                                             #,e)))))
             local-evars
             (syntax->list #'elocs)
+            (syntax->list #'ext-evars)
             (syntax->list #'ectcs))
            
            ;; Check that none of the imports are defined
@@ -717,8 +725,8 @@
                                                       (bound-identifier-mapping-get
                                                        defined-names-table
                                                        id))]
-                                                    [ctc
-                                                     (var-info-ctc
+                                                    [add-ctc
+                                                     (var-info-add-ctc
                                                       (bound-identifier-mapping-get
                                                        defined-names-table
                                                        id))])
@@ -728,9 +736,7 @@
                                                    (quasisyntax/loc defn-or-expr
                                                      (set-box! #,export-loc 
                                                                #,(if name
-                                                                     #`(let ([#,name (if #,ctc
-                                                                                         (contract #,ctc #,tmp '#,unit-name 'cant-happen)
-                                                                                         #,tmp)])
+                                                                     #`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)])
                                                                          #,name)
                                                                      tmp))))
                                                   (else
@@ -1239,11 +1245,13 @@
                            (map 
                             (lambda (i iv c)
                               (if c
-                                  #`(let ([#,iv (contract #,c (unbox (vector-ref #,ov #,i)) 'cant-happen (#%variable-reference))])
+                                  #`(let ([#,iv (contract #,c (unbox (vector-ref #,ov #,i))
+                                                          'cant-happen (#%variable-reference)
+                                                          (quote-syntax #,iv))])
                                       #,iv)
                                   #`(unbox (vector-ref #,ov #,i))))
                             (iota (length (car os)))
-                            (map car (car os))
+                            (map cdr (car os))
                             (cadddr os)))
                          out-sigs
                          out-vec)))
@@ -1317,7 +1325,8 @@
       ((_ name . rest)
        (begin
          (check-id #'name)
-         (let-values (((exp i e d) (build #'rest)))
+         (let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))])
+                                     (build #'rest ))))
            (with-syntax ((((itag . isig) ...) i)
                          (((etag . esig) ...) e)
                          (((deptag . depsig) ...) d))

From 138a3554e29c816f3a085085a789759513c40307 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Wed, 10 Dec 2008 18:56:13 +0000
Subject: [PATCH 06/29] Don't use the contract pretty printer when we try to
 see if we can single line the contract error.

svn: r12766
---
 collects/scheme/private/contract-guts.ss | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss
index 6627e2dee7..ff4804a9cf 100644
--- a/collects/scheme/private/contract-guts.ss
+++ b/collects/scheme/private/contract-guts.ss
@@ -180,8 +180,7 @@
         [formatted-contract-sexp
          (let ([one-line 
                 (let ([sp (open-output-string)])
-                  (parameterize ([pretty-print-print-line print-contract-liner]
-                                 [pretty-print-columns 'infinity])
+                  (parameterize ([pretty-print-columns 'infinity])
                     (pretty-print contract-sexp sp)
                     (get-output-string sp)))])
            (if (< (string-length one-line) 30)

From bc62c06e1cdd0abf4e3068dee7c1a28eb3886674 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Wed, 10 Dec 2008 19:29:21 +0000
Subject: [PATCH 07/29] These lets aren't doing anything, so remove them.

svn: r12769
---
 collects/mzlib/unit.ss | 10 ++++------
 1 file changed, 4 insertions(+), 6 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 86e70628ba..28b8c52d95 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -454,8 +454,7 @@
   (define-for-syntax (make-import-unboxing int-var ext-var loc ctc name)
     (if ctc
         (quasisyntax/loc (error-syntax)
-          (quote-syntax (let ([#,int-var (contract #,ctc (unbox #,loc) 'cant-happen '#,name (quote-syntax #,ext-var))])
-                          #,int-var)))
+          (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name (quote-syntax #,ext-var))))
         (quasisyntax/loc (error-syntax)
           (quote-syntax (unbox #,loc)))))
   
@@ -1245,10 +1244,9 @@
                            (map 
                             (lambda (i iv c)
                               (if c
-                                  #`(let ([#,iv (contract #,c (unbox (vector-ref #,ov #,i))
-                                                          'cant-happen (#%variable-reference)
-                                                          (quote-syntax #,iv))])
-                                      #,iv)
+                                  #`(contract #,c (unbox (vector-ref #,ov #,i))
+                                              'cant-happen (#%variable-reference)
+                                              (quote-syntax #,iv))
                                   #`(unbox (vector-ref #,ov #,i))))
                             (iota (length (car os)))
                             (map cdr (car os))

From 57f1dd0c4d41b044f99718b4e9a8158a0ce9ae80 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Fri, 12 Dec 2008 20:33:21 +0000
Subject: [PATCH 08/29] Lots of unit contracts, plus some bug fixing.

svn: r12820
---
 collects/typed-scheme/infer/signatures.ss     | 37 ++++++++++++------
 .../typed-scheme/private/require-contract.ss  | 16 ++++----
 .../typecheck/check-subforms-unit.ss          |  5 ++-
 collects/typed-scheme/typecheck/signatures.ss | 39 ++++++++++++++-----
 .../typed-scheme/typecheck/tc-app-unit.ss     |  4 +-
 .../typed-scheme/typecheck/tc-expr-unit.ss    |  1 -
 collects/typed-scheme/typecheck/tc-if-unit.ss |  9 -----
 .../typed-scheme/typecheck/tc-lambda-unit.ss  |  4 +-
 collects/typed-scheme/utils/unit-utils.ss     |  8 +++-
 9 files changed, 78 insertions(+), 45 deletions(-)

diff --git a/collects/typed-scheme/infer/signatures.ss b/collects/typed-scheme/infer/signatures.ss
index 6db02b38dc..a3b85665f3 100644
--- a/collects/typed-scheme/infer/signatures.ss
+++ b/collects/typed-scheme/infer/signatures.ss
@@ -1,29 +1,42 @@
 #lang scheme/base
-(require scheme/unit)
+(require scheme/unit scheme/contract "constraint-structs.ss" "../utils/utils.ss")
+(require (rep type-rep) (utils unit-utils))
 (provide (all-defined-out))
 
 (define-signature dmap^
-  (dmap-meet))
+  ([cnt dmap-meet (dmap? dmap? . -> . dmap?)]))
 
 (define-signature promote-demote^
-  (var-promote var-demote))
+  ([cnt var-promote (Type? (listof symbol?) . -> . Type?)]
+   [cnt var-demote  (Type? (listof symbol?) . -> . Type?)]))
 
 (define-signature constraints^
-  (exn:infer?
-   fail-sym
+  ([cnt exn:infer? (any/c . -> . boolean?)]
+   [cnt fail-sym symbol?]
    ;; inference failure - masked before it gets to the user program
    (define-syntaxes (fail!)
      (syntax-rules ()
        [(_ s t) (raise fail-sym)]))
-   cset-meet cset-meet*
+   [cnt cset-meet (cset? cset? . -> . cset?)]
+   [cnt cset-meet* ((listof cset?) . -> . cset?)]
    no-constraint
-   empty-cset
-   insert
-   cset-combine
-   c-meet))
+   [cnt empty-cset ((listof symbol?) . -> . cset?)]
+   [cnt insert (cset? symbol? Type? Type? . -> . cset?)]
+   [cnt cset-combine ((listof cset?) . -> . cset?)]
+   [cnt c-meet ((c? c?) (symbol?) . ->* . c?)]))
 
 (define-signature restrict^
-  (restrict))
+  ([cnt restrict (Type? Type? . -> . Type?)]))
 
 (define-signature infer^
-  (infer infer/vararg infer/dots))
+  ([cnt infer (((listof symbol?) (listof Type?) (listof Type?) Type? (listof symbol?)) ((or/c #f Type?)) . ->* . any)]
+   [cnt infer/vararg (((listof symbol?) 
+                       (listof Type?)
+                       (listof Type?)
+                       Type? Type?
+                       (listof symbol?))
+                      ((or/c #f Type?)) . ->* . any)]
+   [cnt infer/dots (((listof symbol?) 
+                     symbol?
+                     (listof Type?) (listof Type?) Type? Type? (listof symbol?))
+                    (#:expected (or/c #f Type?)) . ->* . any)]))
diff --git a/collects/typed-scheme/private/require-contract.ss b/collects/typed-scheme/private/require-contract.ss
index c718b42fc0..bcfcc2ef0f 100644
--- a/collects/typed-scheme/private/require-contract.ss
+++ b/collects/typed-scheme/private/require-contract.ss
@@ -12,20 +12,20 @@
        (begin define-values)
        [(begin (define-values (n) e) e*)
         #`(begin (define-values (n) e)
-                 (define name #,(syntax-property #'e*
-                                                 'inferred-name
-                                                 (syntax-e #'name))))]
+                 (define name e*))]
        [(begin (begin e))
-        #`(define name #,(syntax-property #'e
-                                          'inferred-name
-                                          (syntax-e #'name)))])]))
+        #`(define name e)])]))
 
 (define-syntax (require/contract stx)
   (syntax-case stx ()
     [(require/contract nm cnt lib)
      (identifier? #'nm)
      #`(begin (require (only-in lib [nm tmp]))     
-              (define-ignored nm (contract cnt tmp '#,(syntax->datum #'nm) 'never-happen (quote-syntax nm))))]
+              (define-ignored nm (contract (let ([nm cnt]) nm) tmp 
+                                           '#,(syntax->datum #'nm)
+                                           'never-happen
+                                           (list (make-srcloc tmp #f #f #f #f) (symbol->string 'nm)))))]
     [(require/contract (orig-nm nm) cnt lib)     
      #`(begin (require (only-in lib [orig-nm tmp]))
-              (define-ignored nm (contract cnt tmp '#,(syntax->datum #'nm) 'never-happen (quote-syntax nm))))]))
+              (define-ignored nm (contract (let ([nm cnt]) nm)
+                                           tmp '#,(syntax->datum #'nm) 'never-happen (quote-syntax nm))))]))
diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.ss b/collects/typed-scheme/typecheck/check-subforms-unit.ss
index e37c6f3719..3dd9208d83 100644
--- a/collects/typed-scheme/typecheck/check-subforms-unit.ss
+++ b/collects/typed-scheme/typecheck/check-subforms-unit.ss
@@ -12,7 +12,7 @@
 (export check-subforms^)
 
 ;; find the subexpressions that need to be typechecked in an ignored form
-;; syntax -> void
+;; syntax -> any
 (define (check-subforms/with-handlers form)
   (define handler-tys '())
   (define body-ty #f)    
@@ -48,6 +48,7 @@
         [_ (void)])))
   (ret (apply Un body-ty handler-tys)))
 
+;; syntax type -> any
 (define (check-subforms/with-handlers/check form expected)
   (let loop ([form form])
     (parameterize ([current-orig-stx form])
@@ -73,7 +74,7 @@
   (ret expected))
 
 ;; typecheck the expansion of a with-handlers form
-;; syntax -> type
+;; syntax -> any
 (define (check-subforms/ignore form)
   (let loop ([form form])
     (kernel-syntax-case* form #f ()
diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss
index 572becfda2..530ad0094c 100644
--- a/collects/typed-scheme/typecheck/signatures.ss
+++ b/collects/typed-scheme/typecheck/signatures.ss
@@ -1,28 +1,49 @@
 #lang scheme/base
-(require scheme/unit)
+(require scheme/unit scheme/contract "../utils/utils.ss")
+(require (rep type-rep)
+         (utils unit-utils)
+         (private type-utils))
 (provide (all-defined-out))
 
 (define-signature typechecker^
-  (type-check tc-toplevel-form))
+  ([cnt type-check (syntax? . -> . syntax?)] 
+   [cnt tc-toplevel-form (syntax? . -> . any)]))
 
 (define-signature tc-expr^
-  (tc-expr tc-expr/check tc-expr/check/t check-below tc-literal tc-exprs tc-exprs/check tc-expr/t))
+  ([cnt tc-expr (syntax? . -> . tc-result?)]
+   [cnt tc-expr/check (syntax? Type? . -> . tc-result?)]
+   [cnt tc-expr/check/t (syntax? Type? . -> . Type?)]
+   [cnt check-below (->d ([s (or/c Type? tc-result?)] [t Type?]) () [_ (if (Type? s) Type? tc-result?)])]
+   [cnt tc-literal (any/c . -> . Type?)]
+   [cnt tc-exprs ((listof syntax?) . -> . tc-result?)]
+   [cnt tc-exprs/check ((listof syntax?) Type? . -> . tc-result?)]
+   [cnt tc-expr/t (syntax? . -> . Type?)]))
 
 (define-signature check-subforms^
-  (check-subforms/ignore check-subforms/with-handlers check-subforms/with-handlers/check))
+  ([cnt check-subforms/ignore (syntax? . -> . any)]
+   [cnt check-subforms/with-handlers (syntax? . -> . any)]
+   [cnt check-subforms/with-handlers/check (syntax? Type? . -> . any)]))
 
 (define-signature tc-if^
-  (tc/if-onearm tc/if-twoarm tc/if-onearm/check tc/if-twoarm/check))
+  ([cnt tc/if-twoarm (syntax? syntax? syntax? . -> . tc-result?)]   
+   [cnt tc/if-twoarm/check (syntax? syntax? syntax? Type? . -> . tc-result?)]))
 
 (define-signature tc-lambda^
-  (tc/lambda tc/lambda/check tc/rec-lambda/check))
+  ([cnt tc/lambda (syntax? syntax? syntax? . -> . tc-result?)]
+   [cnt tc/lambda/check (syntax? syntax? syntax? Type? . -> . tc-result?)]
+   [cnt tc/rec-lambda/check (syntax? syntax? syntax? syntax? (listof Type?) Type? . -> . Type?)]))
 
 (define-signature tc-app^
-  (tc/app tc/app/check tc/funapp))
+  ([cnt tc/app (syntax? . -> . tc-result?)] 
+   [cnt tc/app/check (syntax? Type? . -> . tc-result?)]
+   [cnt tc/funapp (syntax? syntax? tc-result? (listof tc-result?) (or/c #f Type?) . -> . tc-result?)]))
 
 (define-signature tc-let^
-  (tc/let-values tc/letrec-values tc/let-values/check tc/letrec-values/check))
+  ([cnt tc/let-values (syntax? syntax? syntax? syntax? . -> . tc-result?)]
+   [cnt tc/letrec-values (syntax? syntax? syntax? syntax? . -> . tc-result?)]
+   [cnt tc/let-values/check (syntax? syntax? syntax? syntax? Type? . -> . tc-result?)]
+   [cnt tc/letrec-values/check (syntax? syntax? syntax? syntax? Type? . -> . tc-result?)]))
 
 (define-signature tc-dots^
-  (tc/dots))
+  ([cnt tc/dots (syntax? . -> . (values Type? symbol?))]))
 
diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss
index a341e184c7..739025da29 100644
--- a/collects/typed-scheme/typecheck/tc-app-unit.ss
+++ b/collects/typed-scheme/typecheck/tc-app-unit.ss
@@ -368,8 +368,8 @@
                      (let ([substitution (infer vars ... rng)])
                        (and substitution
                             (log-result substitution)
-                            (or expected
-                                (ret (subst-all substitution rng))))))             
+                            (ret (or expected
+                                     (subst-all substitution rng))))))
              (poly-fail t argtypes #:name (and (identifier? f-stx) f-stx)))))]))
 
 (define (poly-fail t argtypes #:name [name #f])
diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss
index 9f0831ae0b..f7769e7320 100644
--- a/collects/typed-scheme/typecheck/tc-expr-unit.ss
+++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss
@@ -190,7 +190,6 @@
          (begin (tc-exprs/check (syntax->list #'es) Univ)
                 (tc-expr/check #'e expected))]          
         ;; if
-        [(if tst body) (tc/if-onearm/check #'tst #'body expected)]
         [(if tst thn els) (tc/if-twoarm/check #'tst #'thn #'els expected)]
         ;; lambda
         [(#%plain-lambda formals . body)
diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss
index bf3a4e43bb..cc87ca8b13 100644
--- a/collects/typed-scheme/typecheck/tc-if-unit.ss
+++ b/collects/typed-scheme/typecheck/tc-if-unit.ss
@@ -13,9 +13,6 @@
          mzlib/trace
          mzlib/plt-match)
 
-;; necessary for creating (#%app void) in tc-if/onearm
-(require (for-template scheme/base))
-
 ;; if typechecking   
 (import tc-expr^)
 (export tc-if^)
@@ -88,12 +85,6 @@
             ;; v cannot have type (-val #f)
             [(Var-True-Effect: v) (check-rest *remove (-val #f) v)])))))
 
-;; create a dummy else branch for typechecking
-(define (tc/if-onearm tst body) (tc/if-twoarm tst body (syntax/loc body (#%app void))))
-
-(define (tc/if-onearm/check tst body expected)
-  (tc/if-twoarm/check tst body (syntax/loc body (#%app void)) expected))
-
 ;; the main function
 (define (tc/if-twoarm tst thn els)
   #;(printf "tc-if/twoarm~n")
diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss
index 962c480e05..a4159fb63f 100644
--- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss
+++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss
@@ -199,16 +199,18 @@
                  (cons (car bodies) bodies*)
                  (cons (syntax-len (car formals)) nums-seen))]))))
 
+;; tc/lambda : syntax syntax-list syntax-list -> tc-result
 (define (tc/lambda form formals bodies)
   (tc/lambda/internal form formals bodies #f))
 
 ;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic
-;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> Type
+;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result
 (define (tc/lambda/internal form formals bodies expected)
   (if (or (syntax-property form 'typechecker:plambda) (Poly? expected) (PolyDots? expected))
       (tc/plambda form formals bodies expected)
       (ret (tc/mono-lambda formals bodies expected))))
 
+;; tc/lambda : syntax syntax-list syntax-list Type -> tc-result
 (define (tc/lambda/check form formals bodies expected)
   (tc/lambda/internal form formals bodies expected))
 
diff --git a/collects/typed-scheme/utils/unit-utils.ss b/collects/typed-scheme/utils/unit-utils.ss
index 728edcd193..e5f4eb0a37 100644
--- a/collects/typed-scheme/utils/unit-utils.ss
+++ b/collects/typed-scheme/utils/unit-utils.ss
@@ -7,7 +7,13 @@
           scheme/unit-exptime
           scheme/match))
 
-(provide define-values/link-units/infer)
+(provide define-values/link-units/infer cnt)
+
+(define-signature-form (cnt stx)
+  (syntax-case stx ()
+    [(_ nm cnt)
+     #;(list #'nm)
+     (list #'[contracted nm cnt])]))
 
 (define-syntax (define-values/link-units/infer stx)
   ;; construct something we can put in the imports/exports clause from the datum

From f7c37571ce844987fcb1bbfc8c20580b70e25864 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 16 Dec 2008 19:42:06 +0000
Subject: [PATCH 09/29] Handle this similarly to scheme/private/contract.

svn: r12869
---
 collects/mzlib/unit.ss | 16 +++++++++++++---
 1 file changed, 13 insertions(+), 3 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 28b8c52d95..33e3356c45 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -451,10 +451,20 @@
   (define-for-syntax process-unit-export
     (process-unit-import/export process-tagged-export))
   
+  ;; id->contract-src-info : identifier -> syntax
+  ;; constructs the last argument to the contract, given an identifier
+  (define-for-syntax (id->contract-src-info id)
+    #`(list (make-srcloc (quote-syntax #,id)
+                         #,(syntax-line id)
+                         #,(syntax-column id)
+                         #,(syntax-position id)
+                         #,(syntax-span id))
+            #,(format "~s" (syntax-object->datum id))))
+  
   (define-for-syntax (make-import-unboxing int-var ext-var loc ctc name)
     (if ctc
         (quasisyntax/loc (error-syntax)
-          (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name (quote-syntax #,ext-var))))
+          (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name #,(id->contract-src-info ext-var))))
         (quasisyntax/loc (error-syntax)
           (quote-syntax (unbox #,loc)))))
   
@@ -675,7 +685,7 @@
                 (set-var-info-exported?! v loc)
                 (set-var-info-add-ctc! v (lambda (e)
                                        #`(if #,ctc
-                                             (contract #,ctc #,e '#,unit-name 'cant-happen (quote-syntax #,var))
+                                             (contract #,ctc #,e '#,unit-name 'cant-happen #,(id->contract-src-info var))
                                              #,e)))))
             local-evars
             (syntax->list #'elocs)
@@ -1246,7 +1256,7 @@
                               (if c
                                   #`(contract #,c (unbox (vector-ref #,ov #,i))
                                               'cant-happen (#%variable-reference)
-                                              (quote-syntax #,iv))
+                                              #,(id->contract-src-info iv))
                                   #`(unbox (vector-ref #,ov #,i))))
                             (iota (length (car os)))
                             (map cdr (car os))

From 821a3ae90057e9e0115df51e27d1572bfa8c50cd Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 16 Dec 2008 20:35:19 +0000
Subject: [PATCH 10/29] Remove unused argument

svn: r12872
---
 collects/mzlib/unit.ss | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 33e3356c45..8912813c79 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -461,7 +461,7 @@
                          #,(syntax-span id))
             #,(format "~s" (syntax-object->datum id))))
   
-  (define-for-syntax (make-import-unboxing int-var ext-var loc ctc name)
+  (define-for-syntax (make-import-unboxing ext-var loc ctc name)
     (if ctc
         (quasisyntax/loc (error-syntax)
           (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name #,(id->contract-src-info ext-var))))
@@ -550,9 +550,8 @@
                                                     (quasisyntax/loc (error-syntax)
                                                       [#,ivs
                                                        (make-id-mappers
-                                                        #,@(map (lambda (iv ev l c)
-                                                                  (make-import-unboxing iv ev l c #'name))
-                                                                (syntax->list ivs)
+                                                        #,@(map (lambda (ev l c)
+                                                                  (make-import-unboxing ev l c #'name))
                                                                 (syntax->list evs)
                                                                 (syntax->list ils)
                                                                 ics))]))

From ed48078523c1282d0df9f2133cfca50102f8849b Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 30 Dec 2008 19:47:21 +0000
Subject: [PATCH 11/29] checkpoint

svn: r12954
---
 collects/typed-scheme/infer/infer-unit.ss          |  4 ++--
 collects/typed-scheme/private/base-env.ss          |  4 ++--
 collects/typed-scheme/private/subtype.ss           | 10 +++++-----
 .../private/type-effect-convenience.ss             | 10 +++++-----
 .../typed-scheme/private/type-effect-printer.ss    | 13 +++++++------
 collects/typed-scheme/rep/effect-rep.ss            | 14 ++++++++++----
 collects/typed-scheme/utils/unit-utils.ss          |  4 ++--
 7 files changed, 33 insertions(+), 26 deletions(-)

diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss
index bcfc0e85fb..99e7e42675 100644
--- a/collects/typed-scheme/infer/infer-unit.ss
+++ b/collects/typed-scheme/infer/infer-unit.ss
@@ -100,9 +100,9 @@
 (define (cgen/eff V X t s)
   (match* (t s)
     [(e e) (empty-cset X)]
-    [((Latent-Restrict-Effect: t) (Latent-Restrict-Effect: s))
+    [((Latent-Restrict-Effect: t k) (Latent-Restrict-Effect: s k))
      (cset-meet (cgen V X t s) (cgen V X s t))]
-    [((Latent-Remove-Effect: t) (Latent-Remove-Effect: s))
+    [((Latent-Remove-Effect: t k) (Latent-Remove-Effect: s k))
      (cset-meet (cgen V X t s) (cgen V X s t))]
     [(_ _) (fail! t s)]))
 
diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index aaad95ba84..48449b6a2b 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -107,8 +107,8 @@
 [filter (-poly (a b) (cl->*
                       ((a . -> . B
                           :
-                          (list (make-Latent-Restrict-Effect b))
-                          (list (make-Latent-Remove-Effect b)))
+                          (list (make-Latent-Restrict-Effect b 0))
+                          (list (make-Latent-Remove-Effect b 0)))
                        (-lst a)
                        . -> .
                        (-lst b))
diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss
index 7263ca8618..6373823824 100644
--- a/collects/typed-scheme/private/subtype.ss
+++ b/collects/typed-scheme/private/subtype.ss
@@ -81,15 +81,15 @@
   (ormap (lambda (e) (arr-subtype*/no-fail A e s)) ts))
 
 (define (sub-eff e1 e2)
-  (match (list e1 e2)
-    [(list e e) #t]
-    [(list (Latent-Restrict-Effect: t) (Latent-Restrict-Effect: t*))
+  (match* (e1 e2)
+    [(e e) #t]
+    [((Latent-Restrict-Effect: t k) (Latent-Restrict-Effect: t* k))
      (and (subtype t t*)
           (subtype t* t))]
-    [(list (Latent-Remove-Effect: t) (Latent-Remove-Effect: t*))
+    [((Latent-Remove-Effect: t k) (Latent-Remove-Effect: t* k))
      (and (subtype t t*)
           (subtype t* t))]
-    [else #f]))
+    [(_ _) #f]))
 
 ;(trace sub-eff)
 
diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss
index 49f21dd872..2a6752941d 100644
--- a/collects/typed-scheme/private/type-effect-convenience.ss
+++ b/collects/typed-scheme/private/type-effect-convenience.ss
@@ -38,10 +38,10 @@
 
 (define ((add-var v) eff)
   (match eff
-    [(Latent-Var-True-Effect:) (-vet v)]
-    [(Latent-Var-False-Effect:) (-vef v)]
-    [(Latent-Restrict-Effect: t) (make-Restrict-Effect t v)]
-    [(Latent-Remove-Effect: t) (make-Remove-Effect t v)]
+    [(Latent-Var-True-Effect: k) (-vet v)]
+    [(Latent-Var-False-Effect: k) (-vef v)]
+    [(Latent-Restrict-Effect: t k) (make-Restrict-Effect t v)]
+    [(Latent-Remove-Effect: t k) (make-Remove-Effect t v)]
     [(True-Effect:) eff]
     [(False-Effect:) eff]
     [_ (int-err "can't add var ~a to effect ~a" v eff)]))
@@ -208,7 +208,7 @@
 (define make-pred-ty
   (case-lambda 
     [(in out t)
-     (->* in out : (list (make-Latent-Restrict-Effect t)) (list (make-Latent-Remove-Effect t)))]
+     (->* in out : (list (make-Latent-Restrict-Effect t 0)) (list (make-Latent-Remove-Effect t 0)))]
     [(t) (make-pred-ty (list Univ) B t)]))
 
 (define -Pathlike (*Un -Path -String))
diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss
index 37f248c391..0ba7cacd5e 100644
--- a/collects/typed-scheme/private/type-effect-printer.ss
+++ b/collects/typed-scheme/private/type-effect-printer.ss
@@ -32,10 +32,10 @@
   (match c
     [(Restrict-Effect: t v) (fp "(restrict ~a ~a)" t (syntax-e v))]
     [(Remove-Effect: t v) (fp "(remove ~a ~a)" t (syntax-e v))]
-    [(Latent-Restrict-Effect: t) (fp "(restrict ~a)" t)]
-    [(Latent-Remove-Effect: t) (fp "(remove ~a)" t)]
-    [(Latent-Var-True-Effect:) (fp "(var #t)")]
-    [(Latent-Var-False-Effect:) (fp "(var #f)")]
+    [(Latent-Restrict-Effect: t k) (fp "(restrict ~a ~a)" t k)]
+    [(Latent-Remove-Effect: t k) (fp "(remove ~a ~a)" t k)]
+    [(Latent-Var-True-Effect: k) (fp "(var #t ~a)" k)]
+    [(Latent-Var-False-Effect: k) (fp "(var #f ~a)" k)]
     [(True-Effect:) (fp "T")]
     [(False-Effect:) (fp "F")]
     [(Var-True-Effect: v) (fp "(var #t ~a)" (syntax-e v))]
@@ -64,9 +64,10 @@
        (when drest
          (fp "~a ... ~a " (car drest) (cdr drest)))
        (fp "-> ~a" rng)
-       (match* (thn-eff els-eff)
+       (match* (thn-eff els-eff)         
          [((list) (list)) (void)]
-         [((list (Latent-Restrict-Effect: t)) (list (Latent-Remove-Effect: t))) (fp " : ~a" t)]
+         [((list (Latent-Restrict-Effect: t 0)) (list (Latent-Remove-Effect: t 0))) (fp " : ~a" t)]
+         [((list (Latent-Restrict-Effect: t k)) (list (Latent-Remove-Effect: t k))) (fp " : ~a_~a" t k)]
          [(_ _) (fp " : ~a ~a" thn-eff els-eff)])
        (fp ")")]))
   (define (tuple? t)
diff --git a/collects/typed-scheme/rep/effect-rep.ss b/collects/typed-scheme/rep/effect-rep.ss
index 892c889584..d7b3745521 100644
--- a/collects/typed-scheme/rep/effect-rep.ss
+++ b/collects/typed-scheme/rep/effect-rep.ss
@@ -27,13 +27,19 @@
     [#:fold-rhs (*Remove-Effect (type-rec-id t) v)])
 
 ;; t is a Type
-(de Latent-Restrict-Effect (t))
+;; k is a nat
+(de Latent-Restrict-Effect (t k) [#:frees (free-vars* t) (free-idxs* t)]
+    [#:fold-rhs (*Latent-Restrict-Effect (type-rec-id t) k)])
 
 ;; t is a Type
-(de Latent-Remove-Effect (t))
+;; k is a nat
+(de Latent-Remove-Effect (t k) [#:frees (free-vars* t) (free-idxs* t)]
+    [#:fold-rhs (*Latent-Remove-Effect (type-rec-id t) k)])
 
-(de Latent-Var-True-Effect () [#:frees #f] [#:fold-rhs #:base])
+;; k is a nat
+(de Latent-Var-True-Effect (k) [#:frees #f] [#:fold-rhs #:base])
 
-(de Latent-Var-False-Effect () [#:frees #f] [#:fold-rhs #:base])
+;; k is a nat
+(de Latent-Var-False-Effect (k) [#:frees #f] [#:fold-rhs #:base])
 
 ;; could also have latent true/false effects, but seems pointless
diff --git a/collects/typed-scheme/utils/unit-utils.ss b/collects/typed-scheme/utils/unit-utils.ss
index e5f4eb0a37..bbd8ab138d 100644
--- a/collects/typed-scheme/utils/unit-utils.ss
+++ b/collects/typed-scheme/utils/unit-utils.ss
@@ -12,8 +12,8 @@
 (define-signature-form (cnt stx)
   (syntax-case stx ()
     [(_ nm cnt)
-     #;(list #'nm)
-     (list #'[contracted nm cnt])]))
+     (list #'nm)
+     #;(list #'[contracted nm cnt])]))
 
 (define-syntax (define-values/link-units/infer stx)
   ;; construct something we can put in the imports/exports clause from the datum

From bf0d872afdcb3b511051da314cfd476c9d6e65ef Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 8 Jan 2009 20:50:33 +0000
Subject: [PATCH 12/29] Changed to be more like what Sam and I envisioned.

svn: r13039
---
 collects/mzlib/unit.ss | 131 +++++++++++++++++------------------------
 1 file changed, 54 insertions(+), 77 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 8912813c79..78439500b9 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -558,12 +558,7 @@
                                                   (syntax->list #'((int-ivar ...) ...))
                                                   (syntax->list #'((ext-ivar ...) ...))
                                                   (syntax->list #'((iloc ...) ...))
-                                                  (map cadddr import-sigs))
-                                          [(int-evar ...)
-                                           (make-id-mappers
-                                            (quote-syntax (unbox eloc))
-                                            ...)]
-                                          ...)
+                                                  (map cadddr import-sigs)))
                           (letrec-syntaxes+values (renames ...
                                                    mac ... ...)
                             (val ... ...)
@@ -703,83 +698,65 @@
                    (var-info-id defid)))))
             local-ivars)
            
-           (with-syntax ([(intname ...)
-                          (foldr
-                           (lambda (var res)
-                             (cond
-                               ((not (or (var-info-syntax? (cdr var))
-                                         (var-info-exported? (cdr var))))
-                                (cons (car var) res))
-                               (else res)))
-                           null
-                           (bound-identifier-mapping-map defined-names-table cons))]
-                         [(evar ...) #'evars]
-                         [(l-evar ...) local-evars]
-                         [(defn&expr ...) 
-                          (filter
-                           values
+           (with-syntax ([(defn&expr ...) 
+                          (apply
+                           append
                            (map (lambda (defn-or-expr)
                                   (syntax-case defn-or-expr (define-values define-syntaxes)
                                     [(define-values () expr)
-                                     (syntax/loc defn-or-expr (set!-values () expr))]
+                                     defn-or-expr]
                                     [(define-values ids expr)
-                                     (let ([ids (syntax->list #'ids)]
-                                           [do-one
-                                            (lambda (id tmp name)
-                                              (let ([unit-name
-                                                     (syntax-local-infer-name (error-syntax))]
-                                                    [export-loc
-                                                     (var-info-exported?
-                                                      (bound-identifier-mapping-get
-                                                       defined-names-table
-                                                       id))]
-                                                    [add-ctc
-                                                     (var-info-add-ctc
-                                                      (bound-identifier-mapping-get
-                                                       defined-names-table
-                                                       id))])
-                                                (cond
-                                                  (export-loc
-                                                   ;; set! exported id:
-                                                   (quasisyntax/loc defn-or-expr
-                                                     (set-box! #,export-loc 
-                                                               #,(if name
-                                                                     #`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)])
-                                                                         #,name)
-                                                                     tmp))))
-                                                  (else
-                                                   ;; not an exported id
-                                                   (quasisyntax/loc defn-or-expr
-                                                     (set! #,id #,tmp))))))])
+                                     (let* ([ids (syntax->list #'ids)]
+                                            [tmps (generate-temporaries ids)]
+                                            [new-defn (quasisyntax/loc defn-or-expr
+                                                        (define-values #,(map (lambda (id tmp)
+                                                                                (if (var-info-exported?
+                                                                                     (bound-identifier-mapping-get
+                                                                                      defined-names-table
+                                                                                      id))
+                                                                                    tmp
+                                                                                    id))
+                                                                              ids tmps) expr))]
+                                            [do-one
+                                             (lambda (id tmp name)
+                                               (let ([unit-name
+                                                      (syntax-local-infer-name (error-syntax))]
+                                                     [export-loc
+                                                      (var-info-exported?
+                                                       (bound-identifier-mapping-get
+                                                        defined-names-table
+                                                        id))]
+                                                     [add-ctc
+                                                      (var-info-add-ctc
+                                                       (bound-identifier-mapping-get
+                                                        defined-names-table
+                                                        id))])
+                                                 (cond
+                                                   (export-loc
+                                                    ;; set! exported id:
+                                                    (list 
+                                                     (quasisyntax/loc defn-or-expr
+                                                       (set-box! #,export-loc 
+                                                                 #,(if name
+                                                                       #`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)])
+                                                                           #,name)
+                                                                       tmp)))
+                                                     (quasisyntax/loc defn-or-expr
+                                                       (define-syntax #,id (make-id-mapper (quote-syntax #,tmp))))))
+                                                   (else
+                                                    ;; not an exported id
+                                                    null))))])
                                        (if (null? (cdr ids))
-                                           (do-one (car ids) (syntax expr) (car ids))
-                                           (let ([tmps (generate-temporaries ids)])
-                                             (with-syntax ([(tmp ...) tmps]
-                                                           [(set ...)
-                                                            (map (lambda (id tmp)
-                                                                   (do-one id tmp #f))
-                                                                 ids tmps)])
-                                               (syntax/loc defn-or-expr
-                                                 (let-values ([(tmp ...) expr])
-                                                   set ...))))))]
-                                    [(define-syntaxes . l) #f]
-                                    [else defn-or-expr]))
-                                expanded-body))]
-                         [(stx-defn ...) 
-                          (filter
-                           values
-                           (map (lambda (defn-or-expr)
-                                  (syntax-case defn-or-expr (define-syntaxes)
-                                    [(define-syntaxes . l) #'l]
-                                    [else #f]))
+                                           (cons new-defn (do-one (car ids) (car tmps) (car ids)))
+                                           (cons new-defn (apply append
+                                                                 (map (lambda (id tmp)
+                                                                        (do-one id tmp #f))
+                                                                      ids tmps)))))]
+                                    [else (list defn-or-expr)]))
                                 expanded-body))])
-             #'(letrec-syntaxes+values (stx-defn
-                                        ...
-                                        ((l-evar) (make-rename-transformer (quote-syntax evar)))
-                                        ...)
-                 ([(intname) undefined] ...)
-                 (void) ; in case the body would be empty
-                 defn&expr ...)))))))
+             #'(begin-with-definitions
+                 defn&expr ...
+                 (void))))))))
 
   (define-for-syntax (redirect-imports/exports import?)
     (lambda (table-stx

From e402d7ea36a8d8b85119c183458a76645776922d Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 8 Jan 2009 20:52:18 +0000
Subject: [PATCH 13/29] We do _not_ want (void) last, we want it first here.

svn: r13040
---
 collects/mzlib/unit.ss | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 78439500b9..22651667ff 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -755,8 +755,8 @@
                                     [else (list defn-or-expr)]))
                                 expanded-body))])
              #'(begin-with-definitions
-                 defn&expr ...
-                 (void))))))))
+                 (void)
+                 defn&expr ...)))))))
 
   (define-for-syntax (redirect-imports/exports import?)
     (lambda (table-stx

From a932bfc84a65d6a6d9a9cf124931ce0ca3b30117 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 9 Jan 2009 00:33:43 +0000
Subject: [PATCH 14/29] Small fixes

svn: r13043
---
 collects/mzlib/unit.ss | 10 +++-------
 1 file changed, 3 insertions(+), 7 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 22651667ff..db1b3e027e 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -587,13 +587,10 @@
        (parameterize ((error-syntax #'err-stx))
          (let* ([expand-context (generate-expand-context)]
                 [def-ctx (syntax-local-make-definition-context)]
-                [local-ivars (syntax->list (localify #'ivars def-ctx))]
-                [local-evars (syntax->list (localify #'evars def-ctx))]
                 [stop-list
                  (append
                   (kernel-form-identifier-list)
-                  (syntax->list #'ivars)
-                  (syntax->list #'evars))]
+                  (syntax->list #'ivars))]
                 [definition?
                   (lambda (id)
                     (and (identifier? id)
@@ -681,7 +678,7 @@
                                        #`(if #,ctc
                                              (contract #,ctc #,e '#,unit-name 'cant-happen #,(id->contract-src-info var))
                                              #,e)))))
-            local-evars
+            (syntax->list (localify #'evars def-ctx))
             (syntax->list #'elocs)
             (syntax->list #'ext-evars)
             (syntax->list #'ectcs))
@@ -696,7 +693,7 @@
                   (raise-stx-err
                    "definition for imported identifier"
                    (var-info-id defid)))))
-            local-ivars)
+            (syntax->list (localify #'ivars def-ctx)))
            
            (with-syntax ([(defn&expr ...) 
                           (apply
@@ -755,7 +752,6 @@
                                     [else (list defn-or-expr)]))
                                 expanded-body))])
              #'(begin-with-definitions
-                 (void)
                  defn&expr ...)))))))
 
   (define-for-syntax (redirect-imports/exports import?)

From 8d1b82bcd21e42fcc2df2827291a8264aef189d9 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 9 Jan 2009 00:59:04 +0000
Subject: [PATCH 15/29] There's no need for the special-casing define-values
 with one binding, so simplify this.

svn: r13044
---
 collects/mzlib/unit.ss | 18 ++++++------------
 1 file changed, 6 insertions(+), 12 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index db1b3e027e..671c66a6ca 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -715,7 +715,7 @@
                                                                                     id))
                                                                               ids tmps) expr))]
                                             [do-one
-                                             (lambda (id tmp name)
+                                             (lambda (id tmp)
                                                (let ([unit-name
                                                       (syntax-local-infer-name (error-syntax))]
                                                      [export-loc
@@ -734,21 +734,15 @@
                                                     (list 
                                                      (quasisyntax/loc defn-or-expr
                                                        (set-box! #,export-loc 
-                                                                 #,(if name
-                                                                       #`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)])
-                                                                           #,name)
-                                                                       tmp)))
+                                                                 (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)])
+                                                                   #,id)))
                                                      (quasisyntax/loc defn-or-expr
-                                                       (define-syntax #,id (make-id-mapper (quote-syntax #,tmp))))))
+                                                       (define-syntax #,id
+                                                         (make-id-mapper (quote-syntax #,tmp))))))
                                                    (else
                                                     ;; not an exported id
                                                     null))))])
-                                       (if (null? (cdr ids))
-                                           (cons new-defn (do-one (car ids) (car tmps) (car ids)))
-                                           (cons new-defn (apply append
-                                                                 (map (lambda (id tmp)
-                                                                        (do-one id tmp #f))
-                                                                      ids tmps)))))]
+                                       (cons new-defn (apply append (map do-one ids tmps))))]
                                     [else (list defn-or-expr)]))
                                 expanded-body))])
              #'(begin-with-definitions

From bae2c7b5e121448891289fde194ffbaaced33a24 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 9 Jan 2009 19:08:03 +0000
Subject: [PATCH 16/29] Basically write begin-with-definitions here by hand,
 which _does_ work.

So that should pretty much give us unit contracts, modulo whether we can
separate out the projections so that contracts aren't checked twice
inappropriately.

svn: r13047
---
 collects/mzlib/unit.ss | 125 ++++++++++++++++++++++++++---------------
 1 file changed, 79 insertions(+), 46 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 671c66a6ca..b5fe0fcbc8 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -10,7 +10,6 @@
                       "private/unit-syntax.ss")
   
   (require mzlib/contract
-           mzlib/etc
            "private/unit-keywords.ss"
            "private/unit-runtime.ss")
   
@@ -695,18 +694,24 @@
                    (var-info-id defid)))))
             (syntax->list (localify #'ivars def-ctx)))
            
-           (with-syntax ([(defn&expr ...) 
-                          (apply
-                           append
-                           (map (lambda (defn-or-expr)
-                                  (syntax-case defn-or-expr (define-values define-syntaxes)
-                                    [(define-values () expr)
-                                     defn-or-expr]
-                                    [(define-values ids expr)
-                                     (let* ([ids (syntax->list #'ids)]
-                                            [tmps (generate-temporaries ids)]
-                                            [new-defn (quasisyntax/loc defn-or-expr
-                                                        (define-values #,(map (lambda (id tmp)
+           (let-values ([(stx-defns val-defns exprs)
+                         (let sort-clauses ([remaining expanded-body]
+                                            [stx-clauses null]
+                                            [val-clauses null]
+                                            [exprs null])
+                           (if (null? remaining)
+                               (values (reverse stx-clauses)
+                                       (reverse val-clauses)
+                                       (if (null? exprs)
+                                           (list #'(void))
+                                           (reverse exprs)))
+                               (let ([defn-or-expr (car remaining)])
+                                 (syntax-case defn-or-expr (define-values define-syntaxes)
+                                   [(define-values (id ...) expr)
+                                    (let*-values ([(ids) (syntax->list #'(id ...))]
+                                                  [(tmps) (generate-temporaries ids)]
+                                                  [(new-val-clause) (quasisyntax/loc defn-or-expr
+                                                                      (#,(map (λ (id tmp)
                                                                                 (if (var-info-exported?
                                                                                      (bound-identifier-mapping-get
                                                                                       defined-names-table
@@ -714,39 +719,67 @@
                                                                                     tmp
                                                                                     id))
                                                                               ids tmps) expr))]
-                                            [do-one
-                                             (lambda (id tmp)
-                                               (let ([unit-name
-                                                      (syntax-local-infer-name (error-syntax))]
-                                                     [export-loc
-                                                      (var-info-exported?
-                                                       (bound-identifier-mapping-get
-                                                        defined-names-table
-                                                        id))]
-                                                     [add-ctc
-                                                      (var-info-add-ctc
-                                                       (bound-identifier-mapping-get
-                                                        defined-names-table
-                                                        id))])
-                                                 (cond
-                                                   (export-loc
-                                                    ;; set! exported id:
-                                                    (list 
-                                                     (quasisyntax/loc defn-or-expr
-                                                       (set-box! #,export-loc 
-                                                                 (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)])
-                                                                   #,id)))
-                                                     (quasisyntax/loc defn-or-expr
-                                                       (define-syntax #,id
-                                                         (make-id-mapper (quote-syntax #,tmp))))))
-                                                   (else
-                                                    ;; not an exported id
-                                                    null))))])
-                                       (cons new-defn (apply append (map do-one ids tmps))))]
-                                    [else (list defn-or-expr)]))
-                                expanded-body))])
-             #'(begin-with-definitions
-                 defn&expr ...)))))))
+                                                  [(extra-stx-clauses extra-exprs)
+                                                   (let loop ([ids ids]
+                                                              [tmps tmps]
+                                                              [stx-clauses null]
+                                                              [exprs null])
+                                                     (if (null? ids)
+                                                         (values stx-clauses exprs)
+                                                         (let* ([id (car ids)]
+                                                                [tmp (car tmps)]
+                                                                [unit-name
+                                                                 (syntax-local-infer-name (error-syntax))]
+                                                                [export-loc
+                                                                 (var-info-exported?
+                                                                  (bound-identifier-mapping-get
+                                                                   defined-names-table
+                                                                   id))]
+                                                                [add-ctc
+                                                                 (var-info-add-ctc
+                                                                  (bound-identifier-mapping-get
+                                                                   defined-names-table
+                                                                   id))])
+                                                           (cond
+                                                             [export-loc
+                                                              ;; set! exported id:
+                                                              (loop (cdr ids)
+                                                                    (cdr tmps)
+                                                                    (cons (quasisyntax/loc defn-or-expr
+                                                                            ((#,id) (make-id-mapper (quote-syntax #,tmp))))
+                                                                          stx-clauses)
+                                                                    (cons (quasisyntax/loc defn-or-expr
+                                                                            (set-box! #,export-loc 
+                                                                                      (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)])
+                                                                                        #,id)))
+                                                                          exprs))]
+                                                             [else
+                                                              ;; not an exported id
+                                                              (loop (cdr ids)
+                                                                    (cdr tmps)
+                                                                    stx-clauses
+                                                                    exprs)]))))])
+                                      (sort-clauses (cdr remaining)
+                                                    (append extra-stx-clauses stx-clauses)
+                                                    (cons new-val-clause
+                                                          (append (map (λ (s) #`(() (begin #,s (values)))) exprs)
+                                                                  val-clauses))
+                                                    extra-exprs))]
+                                   [(define-syntaxes (id ...) expr)
+                                    (sort-clauses (cdr remaining)
+                                                  (cons (cdr (syntax->list defn-or-expr))
+                                                        stx-clauses)
+                                                  val-clauses
+                                                  exprs)]
+                                   [else
+                                    (sort-clauses (cdr remaining)
+                                                  stx-clauses
+                                                  val-clauses
+                                                  (cons defn-or-expr exprs))]))))])
+             (with-syntax ([(stx-clause ...) stx-defns]
+                           [(val-clause ...) val-defns]
+                           [(expr ...) exprs])
+               #'(letrec-syntaxes+values (stx-clause ...) (val-clause ...) expr ...))))))))
 
   (define-for-syntax (redirect-imports/exports import?)
     (lambda (table-stx

From af69c0bbeccf2fab5e11b104cd8bb3a686f343f9 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 9 Jan 2009 19:50:28 +0000
Subject: [PATCH 17/29] Tag the contracts so we know what are truly contracts
 and which are just placeholder #fs.

svn: r13048
---
 collects/mzlib/unit.ss | 17 ++++++++++++-----
 1 file changed, 12 insertions(+), 5 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index b5fe0fcbc8..8509d92f9d 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -514,7 +514,12 @@
                        [((eloc ...) ...)
                         (map (lambda (x) (generate-temporaries (car x))) export-sigs)]
                        [((ectc ...) ...)
-                        (map cadddr export-sigs)]
+                        (map (λ (sig)
+                               (map (λ (ctc)
+                                      (if ctc
+                                          (cons 'contract ctc)
+                                          #f))
+                                    (cadddr sig))) export-sigs)]
                        [((import-key import-super-keys ...) ...)
                         (map tagged-info->keys import-tagged-infos)]
                        [((export-key ...) ...)
@@ -673,10 +678,12 @@
                 (when (var-info-syntax? v)
                   (raise-stx-err "cannot export syntax from a unit" name))
                 (set-var-info-exported?! v loc)
-                (set-var-info-add-ctc! v (lambda (e)
-                                       #`(if #,ctc
-                                             (contract #,ctc #,e '#,unit-name 'cant-happen #,(id->contract-src-info var))
-                                             #,e)))))
+                (when (pair? (syntax-e ctc))
+                  (set-var-info-add-ctc! 
+                   v
+                   (λ (e)
+                     #`(contract #,(cdr (syntax-e ctc)) #,e '#,unit-name 
+                                 'cant-happen #,(id->contract-src-info var)))))))
             (syntax->list (localify #'evars def-ctx))
             (syntax->list #'elocs)
             (syntax->list #'ext-evars)

From 0db2eb851a46185f0f09a130f707e1cdd748c50e Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 9 Jan 2009 22:22:24 +0000
Subject: [PATCH 18/29] Allow multiple identifier/contract pairs in the same
 contracted form.

svn: r13054
---
 collects/mzlib/unit.ss                    | 8 ++++----
 collects/typed-scheme/utils/unit-utils.ss | 2 +-
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 8509d92f9d..4b68bd6c10 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -241,15 +241,15 @@
              (x
               (identifier? #'x)
               (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs)))
-             ((x y z)
+             ((x (y z) ...)
               (and (identifier? #'x)
                    (module-identifier=? #'x #'contracted)
-                   (identifier? #'y))
+                   (andmap identifier? (syntax->list #'(y ...))))
               (loop (cdr sig-exprs)
-                    (cons #'y bindings)
+                    (append (syntax->list #'(y ...)) bindings)
                     val-defs
                     stx-defs
-                    (cons #'z ctcs)))
+                    (append (syntax->list #'(z ...)) ctcs)))
              ((x . y)
               (and (identifier? #'x)
                    (or (module-identifier=? #'x #'define-values)
diff --git a/collects/typed-scheme/utils/unit-utils.ss b/collects/typed-scheme/utils/unit-utils.ss
index bbd8ab138d..ebec947551 100644
--- a/collects/typed-scheme/utils/unit-utils.ss
+++ b/collects/typed-scheme/utils/unit-utils.ss
@@ -13,7 +13,7 @@
   (syntax-case stx ()
     [(_ nm cnt)
      (list #'nm)
-     #;(list #'[contracted nm cnt])]))
+     #;(list #'[contracted (nm cnt)])]))
 
 (define-syntax (define-values/link-units/infer stx)
   ;; construct something we can put in the imports/exports clause from the datum

From 37b2272ecf1a3e6826060560c826483ce4d64ced Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 13 Jan 2009 23:08:47 +0000
Subject: [PATCH 19/29] Move away from using the error-syntax to grab the unit
 name wherever we want it -- just use a syntax parameter.

svn: r13096
---
 collects/mzlib/unit.ss | 81 ++++++++++++++++++++++--------------------
 1 file changed, 42 insertions(+), 39 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 4b68bd6c10..2f43f73321 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -10,6 +10,7 @@
                       "private/unit-syntax.ss")
   
   (require mzlib/contract
+           mzlib/stxparam
            "private/unit-keywords.ss"
            "private/unit-runtime.ss")
   
@@ -460,10 +461,14 @@
                          #,(syntax-span id))
             #,(format "~s" (syntax-object->datum id))))
   
-  (define-for-syntax (make-import-unboxing ext-var loc ctc name)
+  (define-syntax-parameter current-unit-name-stx (lambda (stx) #'(#%variable-reference)))
+  
+  (define-for-syntax (make-import-unboxing ext-var loc ctc)
     (if ctc
         (quasisyntax/loc (error-syntax)
-          (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name #,(id->contract-src-info ext-var))))
+          (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen
+                                  (current-unit-name-stx)
+                                  #,(id->contract-src-info ext-var))))
         (quasisyntax/loc (error-syntax)
           (quote-syntax (unbox #,loc)))))
   
@@ -543,37 +548,38 @@
                (vector-immutable (cons 'export-name 
                                        (vector-immutable export-key ...)) ...)
                (list (cons 'dept depr) ...)
-               (lambda ()
-                 (let ([eloc (box undefined)] ... ...)
-                   (values 
-                    (lambda (import-table)
-                      (let-values ([(iloc ...)
-                                    (vector->values (hash-table-get import-table import-key) 0 icount)]
-                                   ...)
-                        (letrec-syntaxes (#,@(map (lambda (ivs evs ils ics)
-                                                    (quasisyntax/loc (error-syntax)
-                                                      [#,ivs
-                                                       (make-id-mappers
-                                                        #,@(map (lambda (ev l c)
-                                                                  (make-import-unboxing ev l c #'name))
-                                                                (syntax->list evs)
-                                                                (syntax->list ils)
-                                                                ics))]))
-                                                  (syntax->list #'((int-ivar ...) ...))
-                                                  (syntax->list #'((ext-ivar ...) ...))
-                                                  (syntax->list #'((iloc ...) ...))
-                                                  (map cadddr import-sigs)))
-                          (letrec-syntaxes+values (renames ...
-                                                   mac ... ...)
-                            (val ... ...)
-                            (unit-body #,(error-syntax)
-                                       (int-ivar ... ...)
-                                       (int-evar ... ...)
-                                       (ext-evar ... ...)
-                                       (eloc ... ...)
-                                       (ectc ... ...)
-                                       . body)))))
-                    (unit-export ((export-key ...) (vector-immutable eloc ...)) ...))))))
+               (syntax-parameterize ([current-unit-name-stx (lambda (stx) #'(quote name))])
+                 (lambda ()
+                   (let ([eloc (box undefined)] ... ...)
+                     (values 
+                      (lambda (import-table)
+                        (let-values ([(iloc ...)
+                                      (vector->values (hash-table-get import-table import-key) 0 icount)]
+                                     ...)
+                          (letrec-syntaxes (#,@(map (lambda (ivs evs ils ics)
+                                                      (quasisyntax/loc (error-syntax)
+                                                        [#,ivs
+                                                         (make-id-mappers
+                                                          #,@(map (lambda (ev l c)
+                                                                    (make-import-unboxing ev l c))
+                                                                  (syntax->list evs)
+                                                                  (syntax->list ils)
+                                                                  ics))]))
+                                                    (syntax->list #'((int-ivar ...) ...))
+                                                    (syntax->list #'((ext-ivar ...) ...))
+                                                    (syntax->list #'((iloc ...) ...))
+                                                    (map cadddr import-sigs)))
+                                           (letrec-syntaxes+values (renames ...
+                                                                    mac ... ...)
+                                             (val ... ...)
+                                             (unit-body #,(error-syntax)
+                                                        (int-ivar ... ...)
+                                                        (int-evar ... ...)
+                                                        (ext-evar ... ...)
+                                                        (eloc ... ...)
+                                                        (ectc ... ...)
+                                                        . body)))))
+                      (unit-export ((export-key ...) (vector-immutable eloc ...)) ...)))))))
             import-tagged-sigids
             export-tagged-sigids
             dep-tagged-sigids))))))
@@ -671,8 +677,7 @@
             (lambda (name loc var ctc)
               (let ([v (bound-identifier-mapping-get defined-names-table
                                                      name
-                                                     (lambda () #f))]
-                    [unit-name (syntax-local-infer-name (error-syntax))])
+                                                     (lambda () #f))])
                 (unless v
                   (raise-stx-err (format "undefined export ~a" (syntax-e name))))
                 (when (var-info-syntax? v)
@@ -682,7 +687,7 @@
                   (set-var-info-add-ctc! 
                    v
                    (λ (e)
-                     #`(contract #,(cdr (syntax-e ctc)) #,e '#,unit-name 
+                     #`(contract #,(cdr (syntax-e ctc)) #,e (current-unit-name-stx) 
                                  'cant-happen #,(id->contract-src-info var)))))))
             (syntax->list (localify #'evars def-ctx))
             (syntax->list #'elocs)
@@ -735,8 +740,6 @@
                                                          (values stx-clauses exprs)
                                                          (let* ([id (car ids)]
                                                                 [tmp (car tmps)]
-                                                                [unit-name
-                                                                 (syntax-local-infer-name (error-syntax))]
                                                                 [export-loc
                                                                  (var-info-exported?
                                                                   (bound-identifier-mapping-get
@@ -1261,7 +1264,7 @@
                             (lambda (i iv c)
                               (if c
                                   #`(contract #,c (unbox (vector-ref #,ov #,i))
-                                              'cant-happen (#%variable-reference)
+                                              'cant-happen (current-unit-name-stx)
                                               #,(id->contract-src-info iv))
                                   #`(unbox (vector-ref #,ov #,i))))
                             (iota (length (car os)))

From b5efb99548e940818a92f41c174bc713bfa80e6b Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Wed, 14 Jan 2009 01:12:52 +0000
Subject: [PATCH 20/29] Going to try switching this back, but need to sync from
 trunk to get Matthew's changes to see if it works.

svn: r13098
---
 collects/mzlib/unit.ss | 120 ++++++++++++-----------------------------
 1 file changed, 35 insertions(+), 85 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 2f43f73321..7caf79872d 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -9,7 +9,8 @@
                       "private/unit-compiletime.ss"
                       "private/unit-syntax.ss")
   
-  (require mzlib/contract
+  (require mzlib/etc
+           mzlib/contract
            mzlib/stxparam
            "private/unit-keywords.ss"
            "private/unit-runtime.ss")
@@ -706,90 +707,39 @@
                    (var-info-id defid)))))
             (syntax->list (localify #'ivars def-ctx)))
            
-           (let-values ([(stx-defns val-defns exprs)
-                         (let sort-clauses ([remaining expanded-body]
-                                            [stx-clauses null]
-                                            [val-clauses null]
-                                            [exprs null])
-                           (if (null? remaining)
-                               (values (reverse stx-clauses)
-                                       (reverse val-clauses)
-                                       (if (null? exprs)
-                                           (list #'(void))
-                                           (reverse exprs)))
-                               (let ([defn-or-expr (car remaining)])
-                                 (syntax-case defn-or-expr (define-values define-syntaxes)
-                                   [(define-values (id ...) expr)
-                                    (let*-values ([(ids) (syntax->list #'(id ...))]
-                                                  [(tmps) (generate-temporaries ids)]
-                                                  [(new-val-clause) (quasisyntax/loc defn-or-expr
-                                                                      (#,(map (λ (id tmp)
-                                                                                (if (var-info-exported?
-                                                                                     (bound-identifier-mapping-get
-                                                                                      defined-names-table
-                                                                                      id))
-                                                                                    tmp
-                                                                                    id))
-                                                                              ids tmps) expr))]
-                                                  [(extra-stx-clauses extra-exprs)
-                                                   (let loop ([ids ids]
-                                                              [tmps tmps]
-                                                              [stx-clauses null]
-                                                              [exprs null])
-                                                     (if (null? ids)
-                                                         (values stx-clauses exprs)
-                                                         (let* ([id (car ids)]
-                                                                [tmp (car tmps)]
-                                                                [export-loc
-                                                                 (var-info-exported?
-                                                                  (bound-identifier-mapping-get
-                                                                   defined-names-table
-                                                                   id))]
-                                                                [add-ctc
-                                                                 (var-info-add-ctc
-                                                                  (bound-identifier-mapping-get
-                                                                   defined-names-table
-                                                                   id))])
-                                                           (cond
-                                                             [export-loc
-                                                              ;; set! exported id:
-                                                              (loop (cdr ids)
-                                                                    (cdr tmps)
-                                                                    (cons (quasisyntax/loc defn-or-expr
-                                                                            ((#,id) (make-id-mapper (quote-syntax #,tmp))))
-                                                                          stx-clauses)
-                                                                    (cons (quasisyntax/loc defn-or-expr
-                                                                            (set-box! #,export-loc 
-                                                                                      (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)])
-                                                                                        #,id)))
-                                                                          exprs))]
-                                                             [else
-                                                              ;; not an exported id
-                                                              (loop (cdr ids)
-                                                                    (cdr tmps)
-                                                                    stx-clauses
-                                                                    exprs)]))))])
-                                      (sort-clauses (cdr remaining)
-                                                    (append extra-stx-clauses stx-clauses)
-                                                    (cons new-val-clause
-                                                          (append (map (λ (s) #`(() (begin #,s (values)))) exprs)
-                                                                  val-clauses))
-                                                    extra-exprs))]
-                                   [(define-syntaxes (id ...) expr)
-                                    (sort-clauses (cdr remaining)
-                                                  (cons (cdr (syntax->list defn-or-expr))
-                                                        stx-clauses)
-                                                  val-clauses
-                                                  exprs)]
-                                   [else
-                                    (sort-clauses (cdr remaining)
-                                                  stx-clauses
-                                                  val-clauses
-                                                  (cons defn-or-expr exprs))]))))])
-             (with-syntax ([(stx-clause ...) stx-defns]
-                           [(val-clause ...) val-defns]
-                           [(expr ...) exprs])
-               #'(letrec-syntaxes+values (stx-clause ...) (val-clause ...) expr ...))))))))
+           (with-syntax ([(defn-or-expr ...)
+                          (apply append
+                                 (map (λ (defn-or-expr)
+                                        (syntax-case defn-or-expr (define-values)
+                                          [(define-values (id ...) body)
+                                           (let* ([ids (syntax->list #'(id ...))]
+                                                  [tmps (generate-temporaries ids)]
+                                                  [do-one
+                                                   (λ (id tmp)
+                                                     (let ([var-info (bound-identifier-mapping-get
+                                                                      defined-names-table
+                                                                      id)])
+                                                       (cond
+                                                         [(var-info-exported? var-info)
+                                                          =>
+                                                          (λ (export-loc)
+                                                            (let ([add-ctc (var-info-add-ctc var-info)])
+                                                              (list (quasisyntax/loc defn-or-expr
+                                                                      (set-box! #,export-loc 
+                                                                                (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)])
+                                                                                  #,id)))
+                                                                    (quasisyntax/loc defn-or-expr
+                                                                      (define-syntax #,id 
+                                                                        (make-id-mapper (quote-syntax #,tmp)))))))]
+                                                         [else (list (quasisyntax/loc defn-or-expr
+                                                                       (define-syntax #,id
+                                                                         (make-rename-transformer (quote-syntax #,tmp)))))])))])
+                                             (cons (quasisyntax/loc defn-or-expr
+                                                     (define-values #,tmps body))
+                                                   (apply append (map do-one ids tmps))))]
+                                          [else (list defn-or-expr)]))
+                                      expanded-body))])
+             #'(begin-with-definitions defn-or-expr ...)))))))
 
   (define-for-syntax (redirect-imports/exports import?)
     (lambda (table-stx

From 12fc114993b4c5962791984e2ff47340d7a89a88 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Wed, 14 Jan 2009 03:14:26 +0000
Subject: [PATCH 21/29] Let's just make some differently painted identifiers so
 that some error messages won't reveal the non-similarly-named ids behind the
 curtain.

(I have my hammer, and damn if I won't use it.)

svn: r13107
---
 collects/mzlib/unit.ss | 67 +++++++++++++++++++++---------------------
 1 file changed, 34 insertions(+), 33 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 7caf79872d..ddbd135470 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -707,39 +707,40 @@
                    (var-info-id defid)))))
             (syntax->list (localify #'ivars def-ctx)))
            
-           (with-syntax ([(defn-or-expr ...)
-                          (apply append
-                                 (map (λ (defn-or-expr)
-                                        (syntax-case defn-or-expr (define-values)
-                                          [(define-values (id ...) body)
-                                           (let* ([ids (syntax->list #'(id ...))]
-                                                  [tmps (generate-temporaries ids)]
-                                                  [do-one
-                                                   (λ (id tmp)
-                                                     (let ([var-info (bound-identifier-mapping-get
-                                                                      defined-names-table
-                                                                      id)])
-                                                       (cond
-                                                         [(var-info-exported? var-info)
-                                                          =>
-                                                          (λ (export-loc)
-                                                            (let ([add-ctc (var-info-add-ctc var-info)])
-                                                              (list (quasisyntax/loc defn-or-expr
-                                                                      (set-box! #,export-loc 
-                                                                                (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)])
-                                                                                  #,id)))
-                                                                    (quasisyntax/loc defn-or-expr
-                                                                      (define-syntax #,id 
-                                                                        (make-id-mapper (quote-syntax #,tmp)))))))]
-                                                         [else (list (quasisyntax/loc defn-or-expr
-                                                                       (define-syntax #,id
-                                                                         (make-rename-transformer (quote-syntax #,tmp)))))])))])
-                                             (cons (quasisyntax/loc defn-or-expr
-                                                     (define-values #,tmps body))
-                                                   (apply append (map do-one ids tmps))))]
-                                          [else (list defn-or-expr)]))
-                                      expanded-body))])
-             #'(begin-with-definitions defn-or-expr ...)))))))
+           (let ([marker (make-syntax-introducer)])
+             (with-syntax ([(defn-or-expr ...)
+                            (apply append
+                                   (map (λ (defn-or-expr)
+                                          (syntax-case defn-or-expr (define-values)
+                                            [(define-values (id ...) body)
+                                             (let* ([ids (syntax->list #'(id ...))]
+                                                    [tmps (map marker ids)]
+                                                    [do-one
+                                                     (λ (id tmp)
+                                                       (let ([var-info (bound-identifier-mapping-get
+                                                                        defined-names-table
+                                                                        id)])
+                                                         (cond
+                                                           [(var-info-exported? var-info)
+                                                            =>
+                                                            (λ (export-loc)
+                                                              (let ([add-ctc (var-info-add-ctc var-info)])
+                                                                (list (quasisyntax/loc defn-or-expr
+                                                                        (set-box! #,export-loc 
+                                                                                  (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)])
+                                                                                    #,id)))
+                                                                      (quasisyntax/loc defn-or-expr
+                                                                        (define-syntax #,id 
+                                                                          (make-id-mapper (quote-syntax #,tmp)))))))]
+                                                           [else (list (quasisyntax/loc defn-or-expr
+                                                                         (define-syntax #,id
+                                                                           (make-rename-transformer (quote-syntax #,tmp)))))])))])
+                                               (cons (quasisyntax/loc defn-or-expr
+                                                       (define-values #,tmps body))
+                                                     (apply append (map do-one ids tmps))))]
+                                            [else (list defn-or-expr)]))
+                                        expanded-body))])
+               #'(begin-with-definitions defn-or-expr ...))))))))
 
   (define-for-syntax (redirect-imports/exports import?)
     (lambda (table-stx

From dbe366c6a0855abc117d7be2f160be058b882ec8 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 15 Jan 2009 00:42:49 +0000
Subject: [PATCH 22/29] Add error checking for contracted form, also added
 documentation in reference

svn: r13135
---
 collects/mzlib/private/unit-keywords.ss    |  4 +++-
 collects/mzlib/unit.ss                     |  9 ++++++++-
 collects/scribblings/reference/units.scrbl | 10 ++++++++++
 3 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/collects/mzlib/private/unit-keywords.ss b/collects/mzlib/private/unit-keywords.ss
index 7e02597836..8533365e9d 100644
--- a/collects/mzlib/private/unit-keywords.ss
+++ b/collects/mzlib/private/unit-keywords.ss
@@ -3,7 +3,7 @@
 
 (provide only except prefix rename tag
          import export init-depend link
-         extends)
+         extends contracted)
 
 (define-syntax-rule (define-syntax-for-error name message)
   (define-syntax name
@@ -34,3 +34,5 @@
   "misuse of compound-unit keyword")
 (define-syntax-for-error extends
   "misuse of define-signature keyword")
+(define-syntax-for-error contracted
+  "misuse of define-signature keyword")
\ No newline at end of file
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index ddbd135470..6b2af64412 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -17,7 +17,7 @@
   
   (provide define-signature-form struct open
            define-signature provide-signature-elements
-           only except rename import export prefix link tag init-depend extends
+           only except rename import export prefix link tag init-depend extends contracted
            unit?
            (rename :unit unit) define-unit 
            compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer
@@ -252,6 +252,13 @@
                     val-defs
                     stx-defs
                     (append (syntax->list #'(z ...)) ctcs)))
+             ((x . z)
+              (and (identifier? #'x)
+                   (module-identifier=? #'x #'contracted))
+              (raise-syntax-error 
+               'define-signature
+               "expected a list of [id contract] pairs after the contracted keyword"
+               (car sig-exprs)))
              ((x . y)
               (and (identifier? #'x)
                    (or (module-identifier=? #'x #'define-values)
diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl
index cb0ee2376a..a37eddce0d 100644
--- a/collects/scribblings/reference/units.scrbl
+++ b/collects/scribblings/reference/units.scrbl
@@ -160,6 +160,7 @@ the corresponding import. Each @scheme[tagged-sig-id] in an
 
  [sig-elem
   id
+  (contracted [id contract] ...)
   (define-syntaxes (id ...) expr)
   (define-values (value-id ...) expr) 
   (open sig-spec) 
@@ -175,6 +176,15 @@ of bindings for import or export:
  @scheme[id]. That is, @scheme[id] is available for use in units
  importing the signature, and @scheme[id] must be defined by units
  exporting the signature.}
+      
+ @item{Each @scheme[contracted] form in a signature declaration means
+ that a unit exporting the signature must supply a variable definition
+ for each @scheme[id] in that form.  If the signature is imported, then
+ uses of @scheme[id] inside the unit are protected by the appropriate
+ contracts using the unit as the negative blame.  If the signature is
+ exported, then the exported values are protected by the appropriate
+ contracts which use the unit as the positive blame, but internal uses
+ of the exported identifiers are not protected.}
 
  @item{Each @scheme[define-syntaxes] form in a signature declaration
  introduces a macro to that is available for use in any unit that

From 6e86da95e60f9d2aaef92c73226c9f99f374c3ae Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 15 Jan 2009 05:17:27 +0000
Subject: [PATCH 23/29] Actually make this used specifically for blame, not the
 unit name.

We might end up collapsing this and what's introduced in with-contract.

svn: r13140
---
 collects/mzlib/unit.ss | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 6b2af64412..bc40664f8d 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -469,13 +469,13 @@
                          #,(syntax-span id))
             #,(format "~s" (syntax-object->datum id))))
   
-  (define-syntax-parameter current-unit-name-stx (lambda (stx) #'(#%variable-reference)))
+  (define-syntax-parameter current-unit-blame-stx (lambda (stx) #'(#%variable-reference)))
   
   (define-for-syntax (make-import-unboxing ext-var loc ctc)
     (if ctc
         (quasisyntax/loc (error-syntax)
           (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen
-                                  (current-unit-name-stx)
+                                  (current-unit-blame-stx)
                                   #,(id->contract-src-info ext-var))))
         (quasisyntax/loc (error-syntax)
           (quote-syntax (unbox #,loc)))))
@@ -556,7 +556,7 @@
                (vector-immutable (cons 'export-name 
                                        (vector-immutable export-key ...)) ...)
                (list (cons 'dept depr) ...)
-               (syntax-parameterize ([current-unit-name-stx (lambda (stx) #'(quote name))])
+               (syntax-parameterize ([current-unit-blame-stx (lambda (stx) #'(quote (unit name)))])
                  (lambda ()
                    (let ([eloc (box undefined)] ... ...)
                      (values 
@@ -695,7 +695,7 @@
                   (set-var-info-add-ctc! 
                    v
                    (λ (e)
-                     #`(contract #,(cdr (syntax-e ctc)) #,e (current-unit-name-stx) 
+                     #`(contract #,(cdr (syntax-e ctc)) #,e (current-unit-blame-stx) 
                                  'cant-happen #,(id->contract-src-info var)))))))
             (syntax->list (localify #'evars def-ctx))
             (syntax->list #'elocs)
@@ -1222,7 +1222,7 @@
                             (lambda (i iv c)
                               (if c
                                   #`(contract #,c (unbox (vector-ref #,ov #,i))
-                                              'cant-happen (current-unit-name-stx)
+                                              'cant-happen (current-unit-blame-stx)
                                               #,(id->contract-src-info iv))
                                   #`(unbox (vector-ref #,ov #,i))))
                             (iota (length (car os)))

From bd802748e03c3434195279056f4223b94ddfc48f Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 15 Jan 2009 05:32:46 +0000
Subject: [PATCH 24/29] Okay, let's try using the "internal" names instead of
 the "external", which might make some errors more obvious.

svn: r13141
---
 collects/mzlib/unit.ss | 21 +++++++++------------
 1 file changed, 9 insertions(+), 12 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index bc40664f8d..ba185f0692 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -471,12 +471,12 @@
   
   (define-syntax-parameter current-unit-blame-stx (lambda (stx) #'(#%variable-reference)))
   
-  (define-for-syntax (make-import-unboxing ext-var loc ctc)
+  (define-for-syntax (make-import-unboxing var loc ctc)
     (if ctc
         (quasisyntax/loc (error-syntax)
           (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen
                                   (current-unit-blame-stx)
-                                  #,(id->contract-src-info ext-var))))
+                                  #,(id->contract-src-info var))))
         (quasisyntax/loc (error-syntax)
           (quote-syntax (unbox #,loc)))))
   
@@ -564,17 +564,16 @@
                         (let-values ([(iloc ...)
                                       (vector->values (hash-table-get import-table import-key) 0 icount)]
                                      ...)
-                          (letrec-syntaxes (#,@(map (lambda (ivs evs ils ics)
+                          (letrec-syntaxes (#,@(map (lambda (ivs ils ics)
                                                       (quasisyntax/loc (error-syntax)
                                                         [#,ivs
                                                          (make-id-mappers
-                                                          #,@(map (lambda (ev l c)
-                                                                    (make-import-unboxing ev l c))
-                                                                  (syntax->list evs)
+                                                          #,@(map (lambda (iv l c)
+                                                                    (make-import-unboxing iv l c))
+                                                                  (syntax->list ivs)
                                                                   (syntax->list ils)
                                                                   ics))]))
                                                     (syntax->list #'((int-ivar ...) ...))
-                                                    (syntax->list #'((ext-ivar ...) ...))
                                                     (syntax->list #'((iloc ...) ...))
                                                     (map cadddr import-sigs)))
                                            (letrec-syntaxes+values (renames ...
@@ -583,7 +582,6 @@
                                              (unit-body #,(error-syntax)
                                                         (int-ivar ... ...)
                                                         (int-evar ... ...)
-                                                        (ext-evar ... ...)
                                                         (eloc ... ...)
                                                         (ectc ... ...)
                                                         . body)))))
@@ -601,7 +599,7 @@
   
   (define-syntax (unit-body stx)
     (syntax-case stx ()
-      ((_ err-stx ivars evars ext-evars elocs ectcs body ...)
+      ((_ err-stx ivars evars elocs ectcs body ...)
        (parameterize ((error-syntax #'err-stx))
          (let* ([expand-context (generate-expand-context)]
                 [def-ctx (syntax-local-make-definition-context)]
@@ -682,7 +680,7 @@
            ;; Mark exported names and
            ;; check that all exported names are defined (as var):
            (for-each
-            (lambda (name loc var ctc)
+            (lambda (name loc ctc)
               (let ([v (bound-identifier-mapping-get defined-names-table
                                                      name
                                                      (lambda () #f))])
@@ -696,10 +694,9 @@
                    v
                    (λ (e)
                      #`(contract #,(cdr (syntax-e ctc)) #,e (current-unit-blame-stx) 
-                                 'cant-happen #,(id->contract-src-info var)))))))
+                                 'cant-happen #,(id->contract-src-info e)))))))
             (syntax->list (localify #'evars def-ctx))
             (syntax->list #'elocs)
-            (syntax->list #'ext-evars)
             (syntax->list #'ectcs))
            
            ;; Check that none of the imports are defined

From 9df50b125a7aa278e087c17450794861735429e5 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 15 Jan 2009 05:37:23 +0000
Subject: [PATCH 25/29] Missed a case.  Oops.

svn: r13142
---
 collects/mzlib/unit.ss | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index ba185f0692..c2e0fa166f 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -1216,14 +1216,14 @@
                         (map 
                          (lambda (os ov)
                            (map 
-                            (lambda (i iv c)
+                            (lambda (i v c)
                               (if c
                                   #`(contract #,c (unbox (vector-ref #,ov #,i))
                                               'cant-happen (current-unit-blame-stx)
-                                              #,(id->contract-src-info iv))
+                                              #,(id->contract-src-info v))
                                   #`(unbox (vector-ref #,ov #,i))))
                             (iota (length (car os)))
-                            (map cdr (car os))
+                            (map car (car os))
                             (cadddr os)))
                          out-sigs
                          out-vec)))

From 220380fd1b652c54790eba8201d4181071c7f07a Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Fri, 16 Jan 2009 17:09:51 +0000
Subject: [PATCH 26/29] Fixed a bug in which the "check" forms failed to
 reinitialize the "preferred productions" before each attempt.

svn: r13172
---
 collects/redex/private/rg-test.ss | 79 +++++++++++++++++++++++--------
 collects/redex/private/rg.ss      | 79 ++++++++++++++++++-------------
 2 files changed, 104 insertions(+), 54 deletions(-)

diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss
index b6f562decd..560e7d7ef8 100644
--- a/collects/redex/private/rg-test.ss
+++ b/collects/redex/private/rg-test.ss
@@ -94,16 +94,17 @@
   (define-language L
     (a 5 (x a) #:binds x a)
     (b 4))
-  (test ((pick-nt 'dontcare) 'a L '(x) 1)
+  (test (pick-nt 'a L '(x) 1 'dontcare)
         (nt-rhs (car (compiled-lang-lang L))))
-  (test ((pick-nt 'dontcare (make-random 1)) 'a L '(x) preferred-production-threshold)
+  (test (pick-nt 'a L '(x) preferred-production-threshold 'dontcare (make-random 1))
         (nt-rhs (car (compiled-lang-lang L))))
   (let ([pref (car (nt-rhs (car (compiled-lang-lang L))))])
-    (test ((pick-nt (make-immutable-hash `((a ,pref))) (make-random 0))
-           'a L '(x) preferred-production-threshold)
+    (test (pick-nt 'a L '(x) preferred-production-threshold
+                   (make-immutable-hash `((a ,pref)))
+                   (make-random 0))
           (list pref)))
-  (test ((pick-nt 'dontcare) 'sexp sexp null preferred-production-threshold)
-        (nt-rhs (car (compiled-lang-lang sexp)))))
+  (test (pick-nt 'b L null preferred-production-threshold #f)
+        (nt-rhs (cadr (compiled-lang-lang L)))))
 
 (define-syntax exn:fail-message
   (syntax-rules ()
@@ -117,7 +118,7 @@
 
 (define (patterns . selectors) 
   (map (λ (selector) 
-         (λ (name lang vars size)
+         (λ (name lang vars size pref-prods)
            (list (selector (nt-rhs (nt-by-name lang name))))))
        selectors))
 
@@ -138,22 +139,19 @@
                    #:str [str pick-string]
                    #:num [num pick-number]
                    #:any [any pick-any]
-                   #:seq [seq pick-sequence-length])
+                   #:seq [seq pick-sequence-length]
+                   #:pref [pref pick-preferred-productions])
   (define-syntax decision
     (syntax-rules ()
       [(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))]))
-  (λ (lang)
-    (unit (import) (export decisions^)
-          (define next-variable-decision (decision var))
-          (define next-non-terminal-decision
-            (if (procedure? nt) 
-                (let ([next (nt lang)])
-                  (λ () next))
-                (iterator 'nt nt)))
-          (define next-number-decision (decision num))
-          (define next-string-decision (decision str))
-          (define next-any-decision (decision any))
-          (define next-sequence-decision (decision seq)))))
+  (unit (import) (export decisions^)
+        (define next-variable-decision (decision var))
+        (define next-non-terminal-decision (decision nt))
+        (define next-number-decision (decision num))
+        (define next-string-decision (decision str))
+        (define next-any-decision (decision any))
+        (define next-sequence-decision (decision seq))
+        (define next-pref-prods-decision (decision pref))))
 
 (define-syntax generate-term/decisions
   (syntax-rules ()
@@ -495,6 +493,47 @@
                     #:var (list (λ _ 'x) (λ _ 'y))))
         (term (λ (x) (hole y)))))
 
+;; preferred productions
+(let ([make-pick-nt (λ opt (λ req (apply pick-nt (append req opt))))])
+  (define-language L
+    (e (+ e e) (* e e) 7))
+  (let ([pats (λ (L) (nt-rhs (car (compiled-lang-lang (parse-language L)))))])
+    (test 
+     (generate-term/decisions
+      L e 2 preferred-production-threshold
+      (decisions #:pref (list (λ (L) (make-immutable-hash `((e ,(car (pats L)))))))
+                 #:nt (make-pick-nt (make-random 0 0 0))))
+     '(+ (+ 7 7) (+ 7 7)))
+    (test
+     (generate-term/decisions
+      L any 2 preferred-production-threshold
+      (decisions #:nt (patterns first)
+                 #:var (list (λ _ 'x))
+                 #:any (list (λ (lang sexp) (values sexp 'sexp)))))
+     'x)
+    (test
+     (generate-term/decisions
+      L any 2 preferred-production-threshold
+      (decisions #:pref (list (λ (L) (make-immutable-hash `((e ,(car (pats L)))))))
+                 #:nt (make-pick-nt (make-random 0 0 0))
+                 #:any (list (λ (lang sexp) (values lang 'e)))))
+     '(+ (+ 7 7) (+ 7 7)))
+    (test
+     (let ([generated null])
+       (check-reduction-relation
+        (reduction-relation L (--> e e))
+        (λ (t) (set! generated (cons t generated)))
+        #:decisions (decisions #:nt (make-pick-nt (make-random)
+                                                  (λ (att rand) #t))
+                               #:pref (list (λ (_) 'dontcare)
+                                            (λ (_) 'dontcare)
+                                            (λ (_) 'dontcare)
+                                            (λ (L) (make-immutable-hash `((e ,(car (pats L))))))
+                                            (λ (L) (make-immutable-hash `((e ,(cadr (pats L))))))))
+        #:attempts 5)
+       generated)
+     '((* 7 7) (+ 7 7) 7 7 7))))
+
 ;; output : (-> (-> void) string)
 (define (output thunk)
   (let ([p (open-output-string)])
diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss
index 039ab97946..d86ffa5ef4 100644
--- a/collects/redex/private/rg.ss
+++ b/collects/redex/private/rg.ss
@@ -86,18 +86,24 @@ To do a better job of not generating programs with free variables,
 (define (pick-string lang-chars lang-lits attempt [random random])
   (random-string lang-chars lang-lits (random-natural 1/5 random) attempt random))
 
-(define ((pick-nt pref-prods [random random]) name lang bound-vars attempt)
+(define (pick-nt name lang bound-vars attempt pref-prods 
+                 [random random]
+                 [pref-prod? preferred-production?])
   (let* ([prods (nt-rhs (nt-by-name lang name))]
          [binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)]
          [do-intro-binder? (and (null? bound-vars)
                                 (not (null? binders))
                                 (try-to-introduce-binder?))])
     (cond [do-intro-binder? binders]
-          [(and (not (eq? lang sexp))
-                (preferred-production? attempt random))
+          [(and pref-prods (pref-prod? attempt random))
            (hash-ref pref-prods name)]
           [else prods])))
 
+(define (pick-preferred-productions lang)
+  (for/hash ([nt (append (compiled-lang-lang lang) 
+                         (compiled-lang-cclang lang))])
+            (values (nt-name nt) (list (pick-from-list (nt-rhs nt))))))
+
 (define (pick-from-list l [random random]) (list-ref l (random (length l))))
 
 ;; Chooses a random (exact) natural number from the "shifted" geometric distribution:
@@ -172,7 +178,8 @@ To do a better job of not generating programs with free variables,
   (define-values/invoke-unit decisions@
     (import) (export decisions^))
   
-  (define ((generate-nt lang generate base-table) name fvt-id bound-vars size attempt in-hole state)
+  (define ((generate-nt lang generate base-table pref-prods)
+           name fvt-id bound-vars size attempt in-hole state)
     (let*-values
         ([(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)]
          [(term _)
@@ -182,7 +189,7 @@ To do a better job of not generating programs with free variables,
              (let ([rhs (pick-from-list
                          (if (zero? size)
                              (min-prods (nt-by-name lang name) base-table)
-                             ((next-non-terminal-decision) name lang bound-vars attempt)))])
+                             ((next-non-terminal-decision) name lang bound-vars attempt pref-prods)))])
                (generate bound-vars (max 0 (sub1 size)) attempt 
                          (make-state (map fvt-entry (rhs-var-info rhs)) #hash())
                          in-hole (rhs-pattern rhs))))
@@ -261,12 +268,16 @@ To do a better job of not generating programs with free variables,
   (define (fvt-entry binds)
     (make-found-vars (binds-binds binds) (binds-source binds) '() #f))
   
-  (define (generate-pat lang sexp bound-vars size attempt state in-hole pat)
-    (define recur (curry generate-pat lang sexp bound-vars size attempt))
+  (define (generate-pat lang sexp pref-prods bound-vars size attempt state in-hole pat)
+    (define recur (curry generate-pat lang sexp pref-prods bound-vars size attempt))
     (define recur/pat (recur state in-hole))
     
     (define clang (rg-lang-clang lang))
-    (define gen-nt (generate-nt clang (curry generate-pat lang sexp) (rg-lang-base-table lang)))
+    (define gen-nt (generate-nt 
+                    clang 
+                    (curry generate-pat lang sexp pref-prods)
+                    (rg-lang-base-table lang)
+                    pref-prods))
     
     (match pat
       [`number (values ((next-number-decision) attempt) state)]
@@ -303,8 +314,10 @@ To do a better job of not generating programs with free variables,
          (recur state term context))]
       [`(hide-hole ,pattern) (recur state the-hole pattern)]
       [`any
-       (let*-values ([(lang nt) ((next-any-decision) lang sexp)]
-                     [(term _) (generate-pat lang sexp null size attempt new-state the-hole nt)])
+       (let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
+                     ; Don't use preferred productions for the sexp language.
+                     [(pref-prods) (if (eq? new-lang lang) pref-prods #f)]
+                     [(term _) (generate-pat new-lang sexp pref-prods null size attempt new-state the-hole nt)])
          (values term state))]
       [(? (is-nt? clang))
        (gen-nt pat pat bound-vars size attempt in-hole state)]
@@ -379,8 +392,9 @@ To do a better job of not generating programs with free variables,
                         (generate/pred 
                          pat
                          (λ ()
-                           (generate-pat rg-lang rg-sexp null size attempt 
-                                         new-state the-hole parsed))
+                           (generate-pat 
+                            rg-lang rg-sexp ((next-pref-prods-decision) (rg-lang-clang rg-lang))
+                            null size attempt new-state the-hole parsed))
                          (λ (_ env) (mismatches-satisfied? env)))])
             (values term (bindings (state-env state)))))))))
 
@@ -634,14 +648,14 @@ To do a better job of not generating programs with free variables,
   (unless (and (integer? x) (>= x 0))
     (raise-type-error name "natural number" x)))
 
-(define-for-syntax (term-generator lang pat decisions what)
+(define-for-syntax (term-generator lang pat decisions@ what)
   (with-syntax ([pattern 
                  (rewrite-side-conditions/check-errs 
                   (language-id-nts lang what)
                   what #t pat)]
                 [lang lang]
-                [decisions decisions])
-    (syntax ((generate lang (decisions lang)) `pattern))))
+                [decisions@ decisions@])
+    (syntax ((generate lang decisions@) `pattern))))
 
 (define-syntax (generate-term stx)
   (syntax-case stx ()
@@ -681,8 +695,8 @@ To do a better job of not generating programs with free variables,
            (let ([att attempts])
              (assert-nat 'redex-check att)
              (check-property 
-              (cons (list #,(term-generator #'lang #'pat #'random-decisions 'redex-check) #f)
-                    (let ([lang-gen (generate lang (random-decisions lang))])
+              (cons (list #,(term-generator #'lang #'pat #'random-decisions@ 'redex-check) #f)
+                    (let ([lang-gen (generate lang random-decisions@)])
                       #,(if (not source-stx)
                             #'null
                             #`(let-values
@@ -755,11 +769,11 @@ To do a better job of not generating programs with free variables,
        (syntax/loc stx 
         (let ([lang (metafunc-proc-lang m)]
               [dom (metafunc-proc-dom-pat m)]
-              [decisions (generation-decisions)]
+              [decisions@ (generation-decisions)]
               [att attempts])
           (assert-nat 'check-metafunction-contract att)
           (check-property 
-           (list (list ((generate lang (decisions lang)) (if dom dom '(any (... ...)))) #f))
+           (list (list ((generate lang decisions@) (if dom dom '(any (... ...)))) #f))
            #f
            #f
            (λ (t _) 
@@ -771,8 +785,8 @@ To do a better job of not generating programs with free variables,
              (pretty-print term port)))
           (void))))]))
 
-(define (check-property-many lang pats srcs prop decisions attempts)
-  (let ([lang-gen (generate lang (decisions lang))])
+(define (check-property-many lang pats srcs prop decisions@ attempts)
+  (let ([lang-gen (generate lang decisions@)])
     (for/and ([pat pats] [src srcs])
       (check-property
        (let ([gen (lang-gen pat)])
@@ -814,14 +828,14 @@ To do a better job of not generating programs with free variables,
 
 (define (check-reduction-relation 
          relation property 
-         #:decisions [decisions random-decisions]
+         #:decisions [decisions@ random-decisions@]
          #:attempts [attempts default-check-attempts])
   (check-property-many
    (reduction-relation-lang relation)
    (map rewrite-proc-lhs (reduction-relation-make-procs relation))
    (reduction-relation-srcs relation)
    property
-   decisions
+   decisions@
    attempts))
 
 (define-signature decisions^
@@ -830,23 +844,20 @@ To do a better job of not generating programs with free variables,
    next-non-terminal-decision
    next-sequence-decision
    next-any-decision
-   next-string-decision))
+   next-string-decision
+   next-pref-prods-decision))
 
-(define (random-decisions lang)
-  (define preferred-productions
-    (make-immutable-hasheq
-     (map (λ (nt) (cons (nt-name nt) (list (pick-from-list (nt-rhs nt)))))
-          (append (compiled-lang-lang lang)
-                  (compiled-lang-cclang lang)))))
+(define random-decisions@
   (unit (import) (export decisions^)
         (define (next-variable-decision) pick-var)
         (define (next-number-decision) pick-number)
-        (define (next-non-terminal-decision) (pick-nt preferred-productions))
+        (define (next-non-terminal-decision) pick-nt)
         (define (next-sequence-decision) pick-sequence-length)
         (define (next-any-decision) pick-any)
-        (define (next-string-decision) pick-string)))
+        (define (next-string-decision) pick-string)
+        (define (next-pref-prods-decision) pick-preferred-productions)))
 
-(define generation-decisions (make-parameter random-decisions))
+(define generation-decisions (make-parameter random-decisions@))
 
 (provide pick-from-list pick-var min-prods decisions^ pick-sequence-length
          is-nt? pick-char random-string pick-string redex-check nt-by-name
@@ -856,7 +867,7 @@ To do a better job of not generating programs with free variables,
          (struct-out binder) check-metafunction-contract prepare-lang
          pick-number parse-language check-reduction-relation 
          preferred-production-threshold check-metafunction check-randomness
-         generation-decisions)
+         generation-decisions pick-preferred-productions)
 
 (provide/contract
  [find-base-cases (-> compiled-lang? hash?)])

From 4fd8753c6601939eb40f5487a291dff39bf9bff0 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 16 Jan 2009 17:50:05 +0000
Subject: [PATCH 27/29] Start of a testing framework for unit contracts.

svn: r13173
---
 collects/tests/units/test-unit-contracts.ss | 31 +++++++++++++++++++++
 1 file changed, 31 insertions(+)
 create mode 100644 collects/tests/units/test-unit-contracts.ss

diff --git a/collects/tests/units/test-unit-contracts.ss b/collects/tests/units/test-unit-contracts.ss
new file mode 100644
index 0000000000..1320dab453
--- /dev/null
+++ b/collects/tests/units/test-unit-contracts.ss
@@ -0,0 +1,31 @@
+(require "test-harness.ss"
+         scheme/unit)
+
+(define-signature sig1
+  ((contracted [x number?])))
+(define-signature sig2
+  ((contracted [f (-> number? number?))))
+(define-signature sig3 extends sig2
+  ((contracted [g (-> number? boolean?))))
+(define-signature sig4
+  ((contracted [a number?] [b (-> boolean? number?)])))
+(define-signature sig5
+  ((contracted [c string?])
+   (contracted [d symbol?])))
+
+(define-unit unit1
+  (import sig1)
+  (export sig2)
+  (define (f n) x))
+
+(define-unit unit2
+  (import sig3 sig4)
+  (export)
+
+  (b (g a)))
+
+(define-unit unit3
+  (import)
+  (export sig5)
+
+  (define-values (c d) (values "foo" 'a)))

From b29b08dec0eb4654eeab6d9baf8a6da908549aff Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 16 Jan 2009 18:24:59 +0000
Subject: [PATCH 28/29] Adding tests, because we should.

svn: r13175
---
 collects/tests/units/test-unit-contracts.ss | 133 +++++++++++++++++++-
 1 file changed, 128 insertions(+), 5 deletions(-)

diff --git a/collects/tests/units/test-unit-contracts.ss b/collects/tests/units/test-unit-contracts.ss
index 1320dab453..dd5f04de6f 100644
--- a/collects/tests/units/test-unit-contracts.ss
+++ b/collects/tests/units/test-unit-contracts.ss
@@ -4,9 +4,9 @@
 (define-signature sig1
   ((contracted [x number?])))
 (define-signature sig2
-  ((contracted [f (-> number? number?))))
+  ((contracted [f (-> number? number?)])))
 (define-signature sig3 extends sig2
-  ((contracted [g (-> number? boolean?))))
+  ((contracted [g (-> number? boolean?)])))
 (define-signature sig4
   ((contracted [a number?] [b (-> boolean? number?)])))
 (define-signature sig5
@@ -14,18 +14,141 @@
    (contracted [d symbol?])))
 
 (define-unit unit1
+  (import)
+  (export sig1)
+  (define x #f))
+
+(define-unit unit2
   (import sig1)
   (export sig2)
   (define (f n) x))
 
-(define-unit unit2
+(define-unit unit3
   (import sig3 sig4)
   (export)
 
   (b (g a)))
 
-(define-unit unit3
+(define-unit unit4
+  (import sig3 sig4)
+  (export)
+
+  (g (b a)))
+
+(define-unit unit5
   (import)
   (export sig5)
 
-  (define-values (c d) (values "foo" 'a)))
+  (define-values (c d) (values "foo" 3)))
+
+(test-syntax-error "misuse of contracted"
+  contracted)
+(test-syntax-error "invalid forms after contracted in signature"
+  (define-signature x ((contracted x y))))
+(test-syntax-error "identifier not first part of pair after contracted in signature"
+  (define-signature x ((contracted [(-> number? number?) x]))))
+
+(test-syntax-error "f not defined in unit exporting sig3"
+  (unit (import) (export sig3 sig4)
+        (define a #t)
+        (define g zero?)
+        (define (b t) (if t 3 0))))
+
+(test-runtime-error exn:fail:contract? "x exported by unit1 not a number"
+  (invoke-unit unit1))
+(test-runtime-error exn:fail:contract? "x exported by unit1 not a number"
+  (invoke-unit (compound-unit (import) (export)
+                              (link (((S1 : sig1)) unit1)
+                                    (() unit2 S1)))))
+(test-runtime-error exn:fail:contract? "a provided by anonymous unit not a number"
+  (invoke-unit (compound-unit (import) (export)
+                              (link (((S3 : sig3) (S4 : sig4))
+                                     (unit (import) (export sig3 sig4)
+                                           (define a #t)
+                                           (define f add1)
+                                           (define g zero?)
+                                           (define (b t) (if t 3 0))))
+                                    (() unit3 S3 S4)))))
+
+(test-runtime-error exn:fail:contract? "g provided by anonymous unit returns the wrong value"
+  (invoke-unit (compound-unit (import) (export)
+                              (link (((S3 : sig3) (S4 : sig4))
+                                     (unit (import) (export sig3 sig4)
+                                           (define a 3)
+                                           (define f add1)
+                                           (define g values)
+                                           (define (b t) (if t 3 0))))
+                                    (() unit3 S3 S4)))))
+
+(test-runtime-error exn:fail:contract? "unit4 misuses function b"
+  (invoke-unit (compound-unit (import) (export)
+                              (link (((S3 : sig3) (S4 : sig4))
+                                     (unit (import) (export sig3 sig4)
+                                           (define a 3)
+                                           (define f add1)
+                                           (define g zero?)
+                                           (define (b t) (if t 3 0))))
+                                    (() unit4 S3 S4)))))
+
+(test-runtime-error exn:fail:contract? "unit5 provides bad value for d"
+  (invoke-unit unit5))
+
+(define-unit unit6
+  (import)
+  (export sig1)
+  (define-unit unit6-1
+    (import)
+    (export sig1)
+    (define x 3))
+  (define-values/invoke-unit unit6-1
+    (import)
+    (export sig1)))
+
+(invoke-unit unit6)
+
+(define-signature sig6
+  ((contracted [x boolean?])))
+
+(define-unit unit7
+  (import)
+  (export sig6)
+  (define-unit unit7-1
+    (import)
+    (export sig1)
+    (define x 3))
+  (define-values/invoke-unit unit7-1
+    (import)
+    (export sig1)))
+
+(test-runtime-error exn:fail:contract? "unit7 reexports x with different (wrong) contract"
+  (invoke-unit unit7))
+
+(define-unit unit8
+  (import)
+  (export)
+  (define-unit unit8-1
+    (import)
+    (export sig2)
+    (define f values))
+  (define-values/invoke-unit unit8-1
+    (import)
+    (export sig2))
+  (f #t))
+
+(test-runtime-error exn:fail:contract? "unit8 misuses f from internal unit"
+  (invoke-unit unit8))
+
+(define-unit unit9
+  (import)
+  (export)
+  (define-unit unit9-1
+    (import)
+    (export sig2)
+    (define f zero?))
+  (define-values/invoke-unit unit9-1
+    (import)
+    (export sig2))
+  (f 3))
+
+(test-runtime-error exn:fail:contract? "unit9-1 provides wrong value for function f"
+  (invoke-unit unit9))

From 2ef432d1bf2654279aaa7ec025297e8e7b96e47d Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 16 Jan 2009 18:31:03 +0000
Subject: [PATCH 29/29] benchmark tabulation option

svn: r13176
---
 .../tests/mzscheme/benchmarks/common/auto.ss  |  7 +++++
 .../mzscheme/benchmarks/common/tabulate.ss    | 31 ++++++++++++++++---
 2 files changed, 33 insertions(+), 5 deletions(-)

diff --git a/collects/tests/mzscheme/benchmarks/common/auto.ss b/collects/tests/mzscheme/benchmarks/common/auto.ss
index db84442da3..5d792874b2 100755
--- a/collects/tests/mzscheme/benchmarks/common/auto.ss
+++ b/collects/tests/mzscheme/benchmarks/common/auto.ss
@@ -225,6 +225,13 @@ exec mzscheme -qu "$0" ${1+"$@"}
                 extract-mzscheme-times
                 clean-up-nothing
                 mutable-pair-progs)
+     (make-impl 'mzschemecgc-j
+                mk-mzscheme
+                (lambda (bm)
+                  (system (format "mzschemecgc -jqu ~a.ss" bm)))
+                extract-mzscheme-times
+                clean-up-nothing
+                mutable-pair-progs)
      (make-impl 'mzschemecgc-tl
                 mk-mzscheme-tl
                 (lambda (bm)
diff --git a/collects/tests/mzscheme/benchmarks/common/tabulate.ss b/collects/tests/mzscheme/benchmarks/common/tabulate.ss
index ce4d10a963..0b2d41d103 100755
--- a/collects/tests/mzscheme/benchmarks/common/tabulate.ss
+++ b/collects/tests/mzscheme/benchmarks/common/tabulate.ss
@@ -11,6 +11,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
   (define base-link-filename (make-parameter #f))
   (define full-page-mode (make-parameter #f))
   (define include-links (make-parameter #f))
+  (define nongc (make-parameter #f))
 
   (command-line
    "tabulate"
@@ -20,6 +21,8 @@ exec mzscheme -qu "$0" ${1+"$@"}
      (include-links #f)]
     [("--multi") name "generate multiple pages for different views of data"
      (base-link-filename name)]
+    [("--nongc") "show times not including GC"
+     (nongc #t)]
     [("--index") "generate full page with an index.html link"
      (full-page-mode #t)]))
   
@@ -111,6 +114,9 @@ exec mzscheme -qu "$0" ${1+"$@"}
 
   (define forever 1000000000)
 
+  (define (ntime v)
+    (and (caadr v) (- (caadr v) (caddr (cadr v)))))
+
   (define (generate-page relative-to)
     (empty-tag-shorthand html-empty-tags)
     (write-xml/content 
@@ -141,18 +147,21 @@ exec mzscheme -qu "$0" ${1+"$@"}
                   (let ([fastest (apply min (map (lambda (run)
                                                    (or (caadr run) forever))
                                                  (cdr bm-run)))]
+                        [n-fastest (apply min (map (lambda (run)
+                                                     (or (ntime run) forever))
+                                                   (cdr bm-run)))]
                         [c-fastest (apply min (map (lambda (run)
                                                      (let ([v (caddr run)])
                                                        (or (and v (positive? v) v)
                                                            forever)))
                                                    (cdr bm-run)))])
-                    (let-values ([(base c-base)
+                    (let-values ([(base n-base c-base)
                                   (if relative-to
                                       (let ([a (assq relative-to (cdr bm-run))])
                                         (if a
-                                            (values (caadr a) (caddr a))
-                                            (values #f #f)))
-                                      (values fastest c-fastest))])
+                                            (values (caadr a) (ntime a) (caddr a))
+                                            (values #f #f #f)))
+                                      (values fastest n-fastest c-fastest))])
                       `(tr (td ,(if (include-links)
 				    `(a ((href ,(format (string-append "http://svn.plt-scheme.org/plt/trunk/collects/"
 								       "tests/mzscheme/benchmarks/common/~a.sch")
@@ -172,7 +181,8 @@ exec mzscheme -qu "$0" ${1+"$@"}
                               append
                               (map (lambda (impl)
                                      (let* ([a (assq impl (cdr bm-run))]
-                                            [n (and a (caadr a))])
+                                            [n (and a (caadr a))]
+                                            [n2 (and a (ntime a))])
                                        `(,(if (= c-fastest forever)
 					      `(td)
 					      `(td ((align "right")
@@ -192,6 +202,17 @@ exec mzscheme -qu "$0" ${1+"$@"}
                                                         `(font ((color "forestgreen")) (b ,s))
                                                         s))
                                                   "-")
+                                             ,@(if (nongc)
+                                                   `(" / " 
+                                                     ,(if (and n2 n-base)
+                                                          (let ([s (if (zero? base)
+                                                                          "*"
+                                                                          (ratio->string (/ n2 base)))])
+                                                            (if (= n2 n-fastest)
+                                                                `(font ((color "forestgreen")) (b ,s))
+                                                                s))
+                                                          "-"))
+                                                   null)
                                              nbsp))))
                                    sorted-impls))))))
                 sorted-runs)))))