From 3f93fd0f25d3b7e604cde5294796a10041c8a6f2 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Fri, 18 Jan 2008 22:44:54 +0000
Subject: [PATCH] Use an extra let binding to make Typed Scheme happy.

svn: r8366
---
 collects/mzlib/private/match/ddk-handlers.ss  | 51 ++++++++++---------
 .../mzlib/private/match/render-helpers.ss     | 24 ++++-----
 .../private/match/render-test-list-impl.ss    | 37 +++++++-------
 3 files changed, 58 insertions(+), 54 deletions(-)

diff --git a/collects/mzlib/private/match/ddk-handlers.ss b/collects/mzlib/private/match/ddk-handlers.ss
index bafa793af2..8966285026 100644
--- a/collects/mzlib/private/match/ddk-handlers.ss
+++ b/collects/mzlib/private/match/ddk-handlers.ss
@@ -8,7 +8,8 @@
            "render-helpers.ss"
            "render-sigs.ss"
            (lib "stx.ss" "syntax")
-           (lib "unit.ss"))
+           (lib "unit.ss")
+           (lib "trace.ss"))
   
   (require-for-template mzscheme
 			"test-no-order.ss")
@@ -90,28 +91,32 @@
                                                   (lambda (x) #`(reverse #,x))
                                                   binding-list-names))
                                             bv))
-                           #,(next-outer #'the-pat
-                                         #`(car #,exp-name)
-                                         sf
-                                         bv  ;; we always start
-                                         ;; over with the old
-                                         ;; bindings
-                                         let-bound
-                                         kf
-                                         (lambda (sf bv)
-                                           #`(#,loop-name
-                                                (cdr #,exp-name)
-                                                #,@(map
-                                                    (lambda
-                                                        (b-var
-                                                         bindings-var)
-                                                      #`(cons
-                                                         #,(get-bind-val
-                                                            b-var
-                                                            bv)
-                                                         #,bindings-var))
-                                                    bound binding-list-names)))
-                                         cert))))]))))
+                           #,(let ([new-var (gensym 'exp)])
+                               #`(let ([#,new-var (car #,exp-name)])
+                                   #,(next-outer #'the-pat
+                                                 #`#,new-var
+                                                 sf
+                                                 ;(append (map cons bound new-vars) bv)  
+                                                 bv
+                                                 ;; we always start
+                                                 ;; over with the old
+                                                 ;; bindings
+                                                 let-bound
+                                                 kf
+                                                 (lambda (sf bv)                                                   
+                                                   #`(#,loop-name
+                                                      (cdr #,exp-name)
+                                                      #,@(map
+                                                          (lambda
+                                                              (b-var
+                                                               bindings-var)
+                                                            #`(cons
+                                                               #,(get-bind-val
+                                                                  b-var
+                                                                  bv)
+                                                               #,bindings-var))
+                                                          bound binding-list-names)))
+                                                 cert))))))]))))
       (define (new-emit f) (emit f ae let-bound sf bv kf ksucc))
       (case k
         ((0) (ksucc sf bv))
diff --git a/collects/mzlib/private/match/render-helpers.ss b/collects/mzlib/private/match/render-helpers.ss
index 740d2ed800..d55a44071a 100644
--- a/collects/mzlib/private/match/render-helpers.ss
+++ b/collects/mzlib/private/match/render-helpers.ss
@@ -8,7 +8,8 @@
 	   "getter-setter.scm"
 	   "parse-quasi.scm"
            "test-structure.scm"
-           (lib "etc.ss"))
+           (lib "etc.ss")
+           (lib "trace.ss"))
 
   (require-for-template mzscheme
 			(lib "list.ss")
@@ -32,18 +33,15 @@
       [p #'p]))
 
   (define (get-bind-val b-var bv-list)
-    (let ((res (assq
-                b-var
-                bv-list)))
-      (if res (cdr res)
-          (let ((res 
-                 (assq
-                    (syntax-object->datum b-var)
-                    (map (lambda (x)
-                           (cons 
-                            (syntax-object->datum (car x)) (cdr x))) 
-                         bv-list))))
-            (if res (cdr res) (error 'var-not-found))))))
+    (cond [(assq b-var bv-list) => cdr]
+          [(assq
+            (syntax-object->datum b-var)
+            (map (lambda (x)
+                   (cons 
+                    (syntax-object->datum (car x)) (cdr x))) 
+                 bv-list))
+           => cdr]
+          [else (error 'var-not-found)]))
   
   
     ;;!(function proper-hash-table-pattern?
diff --git a/collects/mzlib/private/match/render-test-list-impl.ss b/collects/mzlib/private/match/render-test-list-impl.ss
index deeb5bec1b..4d4aef049f 100644
--- a/collects/mzlib/private/match/render-test-list-impl.ss
+++ b/collects/mzlib/private/match/render-test-list-impl.ss
@@ -419,27 +419,28 @@
                              '(unquote unquote-splicing ... ___))
                        (stx-dot-dot-k? (syntax pat))))
               (stx-dot-dot-k? (syntax dot-dot-k)))
-         (list
-          (shape-test
-           `(list? ,ae-datum)
-           ae (lambda (exp) #`(list? #,exp)))
-          (make-act
-           'list-ddk-pat
-           ae
-           (lambda (ks kf let-bound)
-             (if (stx-null? (syntax (pat-rest ...)))
-                 (handle-end-ddk-list ae kf ks
-                                      (syntax pat)
-                                      (syntax dot-dot-k)
-                                      let-bound
-                                      cert)
-                 (handle-inner-ddk-list ae kf ks
+         (begin
+           (list
+            (shape-test
+             `(list? ,ae-datum)
+             ae (lambda (exp) #`(list? #,exp)))
+            (make-act
+             'list-ddk-pat
+             ae
+             (lambda (ks kf let-bound)
+               (if (stx-null? (syntax (pat-rest ...)))
+                   (handle-end-ddk-list ae kf ks
                                         (syntax pat)
                                         (syntax dot-dot-k)
-                                        (append-if-necc 'list
-                                                        (syntax (pat-rest ...)))
                                         let-bound
-                                        cert))))))
+                                        cert)
+                   (handle-inner-ddk-list ae kf ks
+                                          (syntax pat)
+                                          (syntax dot-dot-k)
+                                          (append-if-necc 'list
+                                                          (syntax (pat-rest ...)))
+                                          let-bound
+                                          cert)))))))
         
         ;; list-rest pattern with a ooo or ook pattern
         ((list-rest pat dot-dot-k pat-rest ...)