From c7fb7b5ec58f21a7124cfb8ed792f610ed6fce63 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 5 Jul 2005 18:38:24 +0000
Subject: [PATCH] Separated out the cruft for syntax into a separate value
 until it gets into the tool, where we combine it, and then drop it
 appropriately.

svn: r348
---
 collects/honu/compile.ss                    |  6 +++---
 collects/honu/private/compiler/translate.ss | 10 +++++-----
 collects/honu/tool.ss                       | 10 ++++++----
 3 files changed, 14 insertions(+), 12 deletions(-)

diff --git a/collects/honu/compile.ss b/collects/honu/compile.ss
index 0ebe7955bc..a41d2c529f 100644
--- a/collects/honu/compile.ss
+++ b/collects/honu/compile.ss
@@ -17,9 +17,9 @@
            "private/typechecker/typecheck-expression.ss")
   
   (provide/contract [compile/defns
-                     (tenv? tenv? (listof honu:defn?)
-                      . -> . 
-                      (cons/c any/c (listof (syntax/c any/c))))]
+                     ((tenv? tenv? (listof honu:defn?))
+                      . ->* . 
+                      (any/c (listof (syntax/c any/c))))]
                     [compile/interaction
                      ((tenv? 
                        tenv?
diff --git a/collects/honu/private/compiler/translate.ss b/collects/honu/private/compiler/translate.ss
index 1c785838f8..63ced40111 100644
--- a/collects/honu/private/compiler/translate.ss
+++ b/collects/honu/private/compiler/translate.ss
@@ -13,9 +13,9 @@
            "translate-unwanted-types.ss"
            "translate-utils.ss")
   
-  (provide/contract [translate ((listof honu:defn?)
-                                . -> .
-                                (cons/c any/c (listof (syntax/c any/c))))]
+  (provide/contract [translate (((listof honu:defn?))
+                                . ->* .
+                                (any/c (listof (syntax/c any/c))))]
                     [translate-defn (honu:defn?
                                      . -> .
                                      (syntax/c any/c))])
@@ -24,8 +24,8 @@
                [syntaxes    '()])
       (cond
         [(null? defns-to-go)
-         (cons (build-unwanted-type-syntax defns)
-               (reverse syntaxes))]
+         (values (build-unwanted-type-syntax defns)
+               (	reverse syntaxes))]
         [(honu:subclass? (car defns-to-go))
          (let ([mixin (find (lambda (d)
                               (and (honu:mixin? d) 
diff --git a/collects/honu/tool.ss b/collects/honu/tool.ss
index 5c7852d661..1fa391e8c6 100644
--- a/collects/honu/tool.ss
+++ b/collects/honu/tool.ss
@@ -86,11 +86,13 @@
                 (if (eof-object? (peek-char-or-special port))
                     eof
                     (let* ([parsed (level-parser port name)])
-                      (let ([compiled-defns (compile/defns tenv lenv parsed)])
+                      (let-values ([(cruft-for-stx compiled-defns) (compile/defns tenv lenv parsed)])
                         ;; if we wrap this in something special for the syntax-case below, then
                         ;; Check Syntax breaks (unsurprisingly), so we'll just do special
                         ;; wrappers for the interaction stuff.
-                        (datum->syntax-object #f (cons 'begin compiled-defns) #f)))))))
+                        (datum->syntax-object #f (list 'begin cruft-for-stx 
+                                                       (datum->syntax-object #f (cons 'begin compiled-defns) #f))
+                                              #f)))))))
           (define/public (front-end/interaction port settings teachpack-cache)
             (let ([name (object-name port)])
               (lambda ()
@@ -140,8 +142,8 @@
                         ;; window, so just eval it.
                         ;;
                         ;; well, remove the cruft I added to get Check Syntax to work first.
-                        [(_ type-cruft stx ...)
-                         (old-current-eval (syntax-as-top #'(begin stx ...)))]))))
+                        [(_ type-cruft real-stx)
+                         (old-current-eval (syntax-as-top #'real-stx))]))))
                  (namespace-attach-module n path)
                  (namespace-require path)))))
           (define/public (render-value value settings port)