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] 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