From 746184ef5ab97050ba0200347ec543d5a744f2cf Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Thu, 20 Nov 2008 20:41:59 +0000
Subject: [PATCH 01/17] Changing docs to have better explanation

svn: r12544
---
 .../web-server/scribblings/servlet-env.scrbl     | 16 +++++-----------
 1 file changed, 5 insertions(+), 11 deletions(-)

diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl
index f4eda42536..375ca2196a 100644
--- a/collects/web-server/scribblings/servlet-env.scrbl
+++ b/collects/web-server/scribblings/servlet-env.scrbl
@@ -110,15 +110,7 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
                                                       "conf"
                                                       "not-found.html"))]
                         [#:mime-types-path mime-types-path path?
-                                           (let ([p (build-path
-                                                     server-root-path
-                                                     "mime.types")])
-                                             (if (file-exists? p)
-                                                 p
-                                                 (build-path
-                                                  (directory-part 
-                                                   default-configuration-table-path)
-                                                  "mime.types")))]
+                                           ...]
                         [#:log-file log-file path? #f]
                         [#:log-format log-format symbol? 'apache-default])
                        void]{
@@ -157,8 +149,10 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
  If @scheme[banner?] is true, then an informative banner is printed. You may want to use this when
  running from the command line, in which case the @scheme[command-line?] option controls similar options.
  
- MIME types are looked up at @scheme[mime-types-path].
- 
+ MIME types are looked up at @scheme[mime-types-path]. By default the @filepath{mime.types} file in the
+ @scheme[server-root-path] is used, but if that file does not exist, then the file that ships with the
+ Web Server is used instead. Of course, if a path is given, then it overrides this behavior.
+
  If @scheme[log-file] is given, then it used to log requests using @scheme[log-format] as the format. Allowable formats
  are those allowed by @scheme[log-format->format].
 }

From accd20a8ed18f23a34552b42d283845f0fd22990 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 20 Nov 2008 20:45:02 +0000
Subject: [PATCH 02/17] remove debugging code

svn: r12545
---
 src/mzscheme/src/read.c | 8 --------
 1 file changed, 8 deletions(-)

diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c
index 473c2b1f15..f80452e61e 100644
--- a/src/mzscheme/src/read.c
+++ b/src/mzscheme/src/read.c
@@ -4371,8 +4371,6 @@ static Scheme_Object *read_compact_k(void)
   return read_compact(port, p->ku.k.i1);
 }
 
-int dump_info = 0;
-
 static Scheme_Object *read_compact(CPort *port, int use_stack)
 {
 #define BLK_BUF_SIZE 32
@@ -4398,9 +4396,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
     ZO_CHECK(port->pos < port->size);
     ch = CP_GETC(port);
 
-    if (dump_info)
-      printf("%d %d %d\n", ch, port->pos, need_car); 
-
     switch(cpt_branch[ch]) {
     case CPT_ESCAPE:
       {
@@ -4456,8 +4451,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
     case CPT_SYMREF:
       l = read_compact_number(port);
       RANGE_CHECK(l, < port->symtab_size);
-      if (dump_info)
-        printf("%d\n", l);
       v = port->symtab[l];
       if (!v) {
         long save_pos = port->pos;
@@ -5268,7 +5261,6 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
     len = symtabsize;
     for (j = 1; j < len; j++) {
       if (!symtab[j]) {
-        if (dump_info) printf("at %ld %ld\n", j, rp->pos); 
         v = read_compact(rp, 0);
         symtab[j] = v;
       } else {

From f0b72082eb41971b65d08d1fed316fb05214a12a Mon Sep 17 00:00:00 2001
From: Carl Eastlund <cce@racket-lang.org>
Date: Thu, 20 Nov 2008 21:15:21 +0000
Subject: [PATCH 03/17] Fixed typos in Plugin docs: Many contracts had
 redundant @scheme[...] around them, which rendered as (scheme ...) in the
 final product.

svn: r12546
---
 collects/scribblings/tools/frame.scrbl    |  6 +++---
 collects/scribblings/tools/language.scrbl |  2 +-
 collects/scribblings/tools/rep.scrbl      |  6 +++---
 collects/scribblings/tools/unit.scrbl     | 22 +++++++++++-----------
 4 files changed, 18 insertions(+), 18 deletions(-)

diff --git a/collects/scribblings/tools/frame.scrbl b/collects/scribblings/tools/frame.scrbl
index d35029a89a..38e59531e4 100644
--- a/collects/scribblings/tools/frame.scrbl
+++ b/collects/scribblings/tools/frame.scrbl
@@ -60,7 +60,7 @@ if the
 }
 
 @defmethod[#:mode override 
-           (file-menu:between-open-and-revert [file-menu (is-a?/c @scheme[menu%])])
+           (file-menu:between-open-and-revert [file-menu (is-a?/c menu%)])
            void?]{
 
 Adds an ``Install .plt File...'' menu item, which
@@ -72,7 +72,7 @@ method.
 }
 
 @defmethod[#:mode override 
-           (file-menu:between-print-and-close [file-menu (is-a?/c @scheme[menu%])])
+           (file-menu:between-print-and-close [file-menu (is-a?/c menu%)])
            void?]{
 
 Calls the super method. Then, creates a menu item for
@@ -187,7 +187,7 @@ This interface is the result of the @scheme[drscheme:frame:basics-mixin]
 
 
 
-@defmethod[(add-show-menu-items [show-menu (is-a?/c @scheme[menu%])])
+@defmethod[(add-show-menu-items [show-menu (is-a?/c menu%)])
            void?]{
 @methspec{
 
diff --git a/collects/scribblings/tools/language.scrbl b/collects/scribblings/tools/language.scrbl
index f866ef30ed..57970c2498 100644
--- a/collects/scribblings/tools/language.scrbl
+++ b/collects/scribblings/tools/language.scrbl
@@ -415,7 +415,7 @@ for this language.
 }
 
 @defmethod[(get-transformer-module)
-           (or/c quoted-module-path @scheme[#f])]{
+           (or/c quoted-module-path #f)]{
 This method specifies the module that defines the
 transformation language. It is used to initialize
 the transformer portion of the user's namespace.
diff --git a/collects/scribblings/tools/rep.scrbl b/collects/scribblings/tools/rep.scrbl
index 357e1a9f3e..a5a53991ca 100644
--- a/collects/scribblings/tools/rep.scrbl
+++ b/collects/scribblings/tools/rep.scrbl
@@ -15,7 +15,7 @@ class affect the implementation that uses it.
 
 
 
-@defconstructor/make[([context (implements @scheme[drscheme:rep:context<%>])])]{
+@defconstructor/make[([context (implements drscheme:rep:context<%>)])]{
 }
 
 @defmethod[#:mode override 
@@ -155,7 +155,7 @@ for more information about parameters.
 
 }
 
-@defmethod[(highlight-errors [locs (listof (list (instance (implements @scheme[text:basic<%>])) small-integer small-integer))])
+@defmethod[(highlight-errors [locs (listof (list (instance (implements text:basic<%>)) small-integer small-integer))])
            void?]{
 Call this method to highlight errors associated with this repl.
 See also
@@ -382,7 +382,7 @@ See also
 
 }
 
-@defmethod[(ensure-rep-shown [rep (is-a?/c @scheme[drscheme:rep:text<%>])])
+@defmethod[(ensure-rep-shown [rep (is-a?/c drscheme:rep:text<%>)])
            void?]{
 
 This method is called to force the rep window to be visible when, for
diff --git a/collects/scribblings/tools/unit.scrbl b/collects/scribblings/tools/unit.scrbl
index d0b0bd5bbf..7188b0f139 100644
--- a/collects/scribblings/tools/unit.scrbl
+++ b/collects/scribblings/tools/unit.scrbl
@@ -43,7 +43,7 @@ Enables the Run button, and the Run menu item and unlocks
            (values (or/c thread? false/c) (or/c custodian? false/c))]{}
 
 @defmethod[(get-defs)
-           (is-a?/c @scheme[drscheme:unit:definitions-text<%>])]{
+           (is-a?/c drscheme:unit:definitions-text<%>)]{
 This text is initially the top half of the drscheme window and
 contains the users program.
 
@@ -73,13 +73,13 @@ is already running (in another thread).
 }
 
 @defmethod[(get-frame)
-           (is-a?/c @scheme[drscheme:unit:frame%])]{
+           (is-a?/c drscheme:unit:frame%)]{
 Returns the frame that this tab is inside.
 
 }
 
 @defmethod[(get-ints)
-           (is-a?/c @scheme[drscheme:rep:text%])]{
+           (is-a?/c drscheme:rep:text%)]{
 This text is initially the bottom half of the drscheme window and
 contains the users interactions with the REPL.
 
@@ -216,7 +216,7 @@ Passes all arguments to @scheme[super-init].
 }
 
 @defmethod[#:mode override 
-           (add-show-menu-items [show-menu (is-a?/c @scheme[menu%])])
+           (add-show-menu-items [show-menu (is-a?/c menu%)])
            void?]{
 
 Adds the ``Show Definitions'', ``Show Interactions'' and
@@ -570,7 +570,7 @@ Shows the interactions window
 }
 
 @defmethod[(get-current-tab)
-           (is-a?/c @scheme[drscheme:unit:tab<%>])]{
+           (is-a?/c drscheme:unit:tab<%>)]{
 Returns the currently active tab.
 
 }
@@ -607,7 +607,7 @@ Returns the Insert menu.
 }}
 
 @defmethod[(get-interactions-canvas)
-           (instanceof (derivedfrom @scheme[drscheme:unit:interactions-canvas%]))]{
+           (instanceof (derivedfrom drscheme:unit:interactions-canvas%))]{
 
 This canvas is the canvas containing the 
 @method[drscheme:unit:frame<%> get-interactions-text]. It is initially the bottom half of the drscheme window.
@@ -621,7 +621,7 @@ it will use the extended class to create the canvas.
 }
 
 @defmethod[(get-interactions-text)
-           (instanceof (derivedfrom @scheme[drscheme:rep:text%]))]{
+           (instanceof (derivedfrom drscheme:rep:text%))]{
 
 Calls result of
 @method[drscheme:unit:frame<%> get-current-tab]'s 
@@ -631,7 +631,7 @@ Calls result of
 }
 
 @defmethod[(get-tabs)
-           (listof @scheme[drscheme:unit:tab<%>])]{
+           (listof drscheme:unit:tab<%>)]{
 Returns the list of tabs in this frame.
 
 }
@@ -656,7 +656,7 @@ The @scheme[from-tab] argument is the previously selected tab, and the
 }}
 
 @defmethod[(register-capability-menu-item [key symbol]
-                                          [menu (is-a? @scheme[menu%])])
+                                          [menu (is-a? menu%)])
            void?]{
 Registers the menu item that was most recently added as
 being controlled by the capability @scheme[key]. This means
@@ -773,7 +773,7 @@ the editor should be used.)
 }
 
 @defmethod[(get-tab)
-           (instanceof @scheme[drscheme:unit:tab%])]{
+           (instanceof drscheme:unit:tab%)]{
 Returns the editor's enclosing tab.
 
 }
@@ -807,7 +807,7 @@ an interaction (unless the Runs first).
 }}
 
 @defmethod[(set-next-settings [language-settings language-settings]
-                              [update-prefs? any/c @scheme[#t]])
+                              [update-prefs? any/c #t])
            void?]{
 
 Changes the language settings for this window. If

From 2382712f3fe64b49485bf2de9af40216e4a48eae Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 20 Nov 2008 22:03:43 +0000
Subject: [PATCH 04/17] fixed exponential slowdown bug

svn: r12547
---
 collects/slideshow/pict.ss | 22 +++++++++++-----------
 1 file changed, 11 insertions(+), 11 deletions(-)

diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss
index 9e2f3210a6..3a8e3c7250 100644
--- a/collects/slideshow/pict.ss
+++ b/collects/slideshow/pict.ss
@@ -44,9 +44,9 @@
                     #:line-width [lw #f]
                     #:color [col #f]
                     #:under? [under? #f])
-    (finish-pin (t:pin-line (ghost p)
-                            src find-src 
-                            dest find-dest)
+    (finish-pin (launder (t:pin-line (ghost p)
+                                     src find-src 
+                                     dest find-dest))
                 p lw col under?))
 
   (define (pin-arrow-line sz p src find-src dest find-dest
@@ -54,10 +54,10 @@
                           #:color [col #f]
                           #:under? [under? #f]
                           #:solid? [solid? #t])
-    (finish-pin (t:pin-arrow-line sz (ghost p)
-                                  src find-src 
-                                  dest find-dest
-                                  #f #f #f solid?)
+    (finish-pin (launder (t:pin-arrow-line sz (ghost p)
+                                           src find-src 
+                                           dest find-dest
+                                           #f #f #f solid?))
                 p lw col under?))
 
   (define (pin-arrows-line sz p src find-src dest find-dest
@@ -65,10 +65,10 @@
                            #:color [col #f]
                            #:under? [under? #f]
                            #:solid? [solid? #t])
-    (finish-pin (t:pin-arrows-line sz (ghost p)
-                                   src find-src 
-                                   dest find-dest
-                                  #f #f #f solid?)
+    (finish-pin (launder (t:pin-arrows-line sz (ghost p)
+                                            src find-src 
+                                            dest find-dest
+                                            #f #f #f solid?))
                 p lw col under?))
 
   (define (finish-pin l p lw col under?)

From e27ae4d4577ee78df53fb6afee0152007112e244 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Thu, 20 Nov 2008 22:30:29 +0000
Subject: [PATCH 05/17] bindings for the rest of scheme/bool

svn: r12548
---
 collects/typed-scheme/private/base-env.ss | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index 641376322e..a71c975708 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -3,6 +3,7 @@
 (require
  scheme/list
  scheme/tcp
+ scheme
  (only-in rnrs/lists-6 fold-left)
  '#%paramz
  (only-in '#%kernel [apply kernel:apply])
@@ -493,4 +494,9 @@
 [tcp-close (-TCP-Listener . -> . -Void )]
 [tcp-connect (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))]
 [tcp-connect/enable-break (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))]
-[tcp-listen (N . -> . -TCP-Listener)]
\ No newline at end of file
+[tcp-listen (N . -> . -TCP-Listener)]
+
+;; scheme/bool
+[boolean=? (B B . -> . B)]
+[symbol=? (Sym Sym . -> . B)]
+[false? (make-pred-ty (-val #f))]
\ No newline at end of file

From bea22974216d0b8f26b3b79f6596ee3aaafd6329 Mon Sep 17 00:00:00 2001
From: Kevin Tew <tewk@racket-lang.org>
Date: Thu, 20 Nov 2008 23:36:54 +0000
Subject: [PATCH 06/17] Make GC callbacks members of NewGC

svn: r12549
---
 src/mred/wxs/wxscheme.cxx    |  6 ++---
 src/mzscheme/gc/alloc.c      | 16 ++++++++++++--
 src/mzscheme/gc/include/gc.h |  6 +++--
 src/mzscheme/gc2/gc2.h       | 16 +++++++++-----
 src/mzscheme/gc2/newgc.c     | 43 +++++++++++++++++++++++++++---------
 src/mzscheme/gc2/newgc.h     |  6 +++++
 src/mzscheme/sgc/sgc.c       | 19 ++++++++++++++--
 src/mzscheme/src/port.c      |  7 ++----
 src/mzscheme/src/salloc.c    |  2 +-
 src/mzscheme/src/thread.c    | 16 +++++---------
 10 files changed, 94 insertions(+), 43 deletions(-)

diff --git a/src/mred/wxs/wxscheme.cxx b/src/mred/wxs/wxscheme.cxx
index 4b5372865a..4168f8f063 100644
--- a/src/mred/wxs/wxscheme.cxx
+++ b/src/mred/wxs/wxscheme.cxx
@@ -162,10 +162,8 @@ void wxsScheme_setup(Scheme_Env *env)
   get_ps_setup_from_user = scheme_false;
   message_box = scheme_false;
 
-  orig_collect_start_callback = GC_collect_start_callback;
-  GC_collect_start_callback = (GC_START_END_PTR)collect_start_callback;
-  orig_collect_end_callback = GC_collect_end_callback;
-  GC_collect_end_callback = (GC_START_END_PTR)collect_end_callback;
+  orig_collect_start_callback = GC_set_collect_start_callback(collect_start_callback);
+  orig_collect_end_callback = GC_set_collect_end_callback(collect_end_callback);
 }
 
 extern "C" {
diff --git a/src/mzscheme/gc/alloc.c b/src/mzscheme/gc/alloc.c
index 75db270553..1ef473e1ff 100644
--- a/src/mzscheme/gc/alloc.c
+++ b/src/mzscheme/gc/alloc.c
@@ -320,8 +320,20 @@ void GC_maybe_gc()
 }
 
 /* PLTSCHEME: notification callback for starting/ending a GC */
-void (*GC_collect_start_callback)(void) = NULL;
-void (*GC_collect_end_callback)(void) = NULL;
+GC_collect_start_callback_Proc GC_collect_start_callback = NULL;
+GC_collect_end_callback_Proc GC_collect_end_callback = NULL;
+GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc func) {
+  GC_collect_start_callback_Proc old;
+  old = GC_collect_start_callback;
+  GC_collect_start_callback = func;
+  return old;
+}
+GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc func) {
+  GC_collect_end_callback_Proc old;
+  old = GC_collect_end_callback;
+  GC_collect_end_callback = func;
+  return old;
+}
 
 /*
  * Stop the world garbage collection.  Assumes lock held, signals disabled.
diff --git a/src/mzscheme/gc/include/gc.h b/src/mzscheme/gc/include/gc.h
index dc61c1434a..3c482034a3 100644
--- a/src/mzscheme/gc/include/gc.h
+++ b/src/mzscheme/gc/include/gc.h
@@ -1017,13 +1017,15 @@ extern void GC_thr_init GC_PROTO((void));/* Needed for Solaris/X86	*/
 #if defined(GC_REDIRECT_TO_LOCAL) && !defined(GC_LOCAL_ALLOC_H)
 #  include  "gc_local_alloc.h"
 #endif
+typedef void (*GC_collect_start_callback_Proc)(void);
+typedef void (*GC_collect_end_callback_Proc)(void);
 
 /* PLTSCHEME: */
 GC_API void (*GC_custom_finalize)(void);
 GC_API void (*GC_push_last_roots)(void);
 GC_API void (*GC_push_last_roots_again)(void);
-GC_API void (*GC_collect_start_callback)(void);
-GC_API void (*GC_collect_end_callback)(void);
+GC_API GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc);
+GC_API GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc);
 GC_API void (*GC_out_of_memory)(void);
 GC_API int GC_did_mark_stack_overflow(void);
 GC_API void GC_mark_from_mark_stack(void);
diff --git a/src/mzscheme/gc2/gc2.h b/src/mzscheme/gc2/gc2.h
index 807e869778..01d6503c46 100644
--- a/src/mzscheme/gc2/gc2.h
+++ b/src/mzscheme/gc2/gc2.h
@@ -21,6 +21,10 @@
 typedef int (*Size_Proc)(void *obj);
 typedef int (*Mark_Proc)(void *obj);
 typedef int (*Fixup_Proc)(void *obj);
+typedef void (*GC_collect_start_callback_Proc)(void);
+typedef void (*GC_collect_end_callback_Proc)(void);
+typedef void (*GC_collect_inform_callback_Proc)(int major_gc, long pre_used, long post_used);
+typedef unsigned long (*GC_get_thread_stack_base_Proc)(void);
 /* 
    Types of the traversal procs (supplied by MzScheme); see overview in README
    for information about traversals. The return value is the size of
@@ -56,9 +60,9 @@ extern "C" {
 /* Administration                                                          */
 /***************************************************************************/
 
-GC2_EXTERN unsigned long (*GC_get_thread_stack_base)(void);
+GC2_EXTERN void GC_set_get_thread_stack_base(unsigned long (*)(void));
 /* 
-   Called by GC to get the base for stack traversal in the current
+   Sets callback called by GC to get the base for stack traversal in the current
    thread (see README). The returned address must not be in the middle
    of a variable-stack record. */
 
@@ -96,11 +100,11 @@ GC2_EXTERN void GC_register_thread(void *, void *);
 /*
    Indicates that a a thread record is owned by a particular custodian. */
 
-GC2_EXTERN void (*GC_collect_start_callback)(void);
-GC2_EXTERN void (*GC_collect_end_callback)(void);
-GC2_EXTERN void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used);
+GC2_EXTERN GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc);
+GC2_EXTERN GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc);
+GC2_EXTERN void GC_set_collect_inform_callback(GC_collect_inform_callback_Proc);
 /*
-   Called by GC before/after performing a collection. Used by MzScheme
+   Sets callbacks called by GC before/after performing a collection.  Used by MzScheme
    to zero out some data and record collection times. The end
    procedure should be called before finalizations are performed. */
 
diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c
index 3d26e0214c..4b0ad4cb1d 100644
--- a/src/mzscheme/gc2/newgc.c
+++ b/src/mzscheme/gc2/newgc.c
@@ -130,15 +130,31 @@ static THREAD_LOCAL NewGC *GC;
 #define GENERATIONS 1
 
 /* the externals */
-void (*GC_collect_start_callback)(void);
-void (*GC_collect_end_callback)(void);
-void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used);
 void (*GC_out_of_memory)(void);
 void (*GC_report_out_of_memory)(void);
-unsigned long (*GC_get_thread_stack_base)(void);
 void (*GC_mark_xtagged)(void *obj);
 void (*GC_fixup_xtagged)(void *obj);
 
+GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc func) {
+  NewGC *gc = GC_get_GC();
+  GC_collect_start_callback_Proc old;
+  old = gc->GC_collect_start_callback;
+  gc->GC_collect_start_callback = func;
+  return old;
+}
+GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc func) {
+  NewGC *gc = GC_get_GC();
+  GC_collect_end_callback_Proc old;
+  old = gc->GC_collect_end_callback;
+  gc->GC_collect_end_callback = func;
+  return old;
+}
+void GC_set_collect_inform_callback(void (*func)(int major_gc, long pre_used, long post_used)) {
+  NewGC *gc = GC_get_GC();
+  gc->GC_collect_inform_callback = func;
+}
+
+
 #include "my_qsort.c"
 
 /*****************************************************************************/
@@ -982,8 +998,13 @@ unsigned long GC_get_stack_base()
   return gc->stack_base;
 }
 
+void GC_set_get_thread_stack_base(unsigned long (*func)(void)) {
+  NewGC *gc = GC_get_GC();
+  gc->GC_get_thread_stack_base = func;
+}
+
 static inline void *get_stack_base(NewGC *gc) {
-  if (GC_get_thread_stack_base) return (void*) GC_get_thread_stack_base();
+  if (gc->GC_get_thread_stack_base) return (void*) gc->GC_get_thread_stack_base();
   return (void*) gc->stack_base;
 }
 
@@ -2409,8 +2430,8 @@ static void garbage_collect(NewGC *gc, int force_full)
   TIME_INIT();
 
   /* inform the system (if it wants us to) that we're starting collection */
-  if(GC_collect_start_callback)
-    GC_collect_start_callback();
+  if(gc->GC_collect_start_callback)
+    gc->GC_collect_start_callback();
 
   TIME_STEP("started");
 
@@ -2530,10 +2551,10 @@ static void garbage_collect(NewGC *gc, int force_full)
     gc->last_full_mem_use = gc->memory_in_use;
 
   /* inform the system (if it wants us to) that we're done with collection */
-  if (GC_collect_start_callback)
-    GC_collect_end_callback();
-  if (GC_collect_inform_callback)
-    GC_collect_inform_callback(gc->gc_full, old_mem_use + old_gen0, gc->memory_in_use);
+  if (gc->GC_collect_start_callback)
+    gc->GC_collect_end_callback();
+  if (gc->GC_collect_inform_callback)
+    gc->GC_collect_inform_callback(gc->gc_full, old_mem_use + old_gen0, gc->memory_in_use);
 
   TIME_STEP("ended");
 
diff --git a/src/mzscheme/gc2/newgc.h b/src/mzscheme/gc2/newgc.h
index c5f05eeacc..2b6e087f5c 100644
--- a/src/mzscheme/gc2/newgc.h
+++ b/src/mzscheme/gc2/newgc.h
@@ -151,6 +151,12 @@ typedef struct NewGC {
   unsigned long num_minor_collects;
   unsigned long num_major_collects;
 
+  /* Callbacks */
+  void (*GC_collect_start_callback)(void);
+  void (*GC_collect_end_callback)(void);
+  void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used);
+  unsigned long (*GC_get_thread_stack_base)(void);
+
   GC_Immobile_Box *immobile_boxes;
 
   /* Common with CompactGC */
diff --git a/src/mzscheme/sgc/sgc.c b/src/mzscheme/sgc/sgc.c
index fbc280d7db..31330e255c 100644
--- a/src/mzscheme/sgc/sgc.c
+++ b/src/mzscheme/sgc/sgc.c
@@ -776,10 +776,25 @@ static long mem_traced;
 static long num_chunks;
 static long num_blocks;
 
-void (*GC_collect_start_callback)(void);
-void (*GC_collect_end_callback)(void);
+typedef void (*GC_collect_start_callback_Proc)(void);
+typedef void (*GC_collect_end_callback_Proc)(void);
+GC_collect_start_callback_Proc GC_collect_start_callback;
+GC_collect_end_callback_Proc GC_collect_end_callback;
 void (*GC_custom_finalize)(void);
 
+GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc) {
+  GC_collect_start_callback_Proc old;
+  old = GC_collect_start_callback;
+  GC_collect_start_callback = func;
+  return old
+}
+GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc) {
+  GC_collect_end_callback_Proc old
+  old = GC_collect_end_callback;
+  GC_collect_end_callback = func;
+  return old
+}
+
 static long roots_count;
 static long roots_size;
 static unsigned long *roots;
diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c
index 6eaba89dff..2d1fd56220 100644
--- a/src/mzscheme/src/port.c
+++ b/src/mzscheme/src/port.c
@@ -892,9 +892,6 @@ typedef struct Scheme_Thread_Memory {
 
 Scheme_Thread_Memory *tm_start, *tm_next;
 
-extern MZ_DLLIMPORT void (*GC_collect_start_callback)(void);
-extern MZ_DLLIMPORT void (*GC_collect_end_callback)(void);
-
 void scheme_init_thread_memory()
 {
 #ifndef MZ_PRECISE_GC
@@ -915,8 +912,8 @@ void scheme_init_thread_memory()
 #endif
 
   /* scheme_init_thread() will replace these: */
-  GC_collect_start_callback = scheme_suspend_remembered_threads;
-  GC_collect_end_callback = scheme_resume_remembered_threads;
+  GC_set_collect_start_callback(scheme_suspend_remembered_threads);
+  GC_set_collect_end_callback(scheme_resume_remembered_threads);
 }
 
 Scheme_Thread_Memory *scheme_remember_thread(void *t, int autoclose)
diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c
index 175f0748fc..db5e8a50a8 100644
--- a/src/mzscheme/src/salloc.c
+++ b/src/mzscheme/src/salloc.c
@@ -2053,7 +2053,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
         scheme_console_printf(" swapped in\n");
         var_stack = GC_variable_stack;
         delta = 0;
-        limit = (void *)GC_get_thread_stack_base();
+        limit = (void *)scheme_get_current_thread_stack_start();
       } else {
         scheme_console_printf(" swapped out\n");
         var_stack = (void **)t->jmpup_buf.gc_var_stack;
diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c
index ea2669aa44..adbc13f86d 100644
--- a/src/mzscheme/src/thread.c
+++ b/src/mzscheme/src/thread.c
@@ -200,10 +200,6 @@ Scheme_Object *scheme_break_enabled_key;
 
 long scheme_total_gc_time;
 static long start_this_gc_time, end_this_gc_time;
-#ifndef MZ_PRECISE_GC
-extern MZ_DLLIMPORT void (*GC_collect_start_callback)(void);
-extern MZ_DLLIMPORT void (*GC_collect_end_callback)(void);
-#endif
 static void get_ready_for_GC(void);
 static void done_with_GC(void);
 #ifdef MZ_PRECISE_GC
@@ -437,7 +433,7 @@ extern BOOL WINAPI DllMain(HINSTANCE inst, ULONG reason, LPVOID reserved);
 #endif
 
 #ifdef MZ_PRECISE_GC
-static unsigned long get_current_stack_start(void);
+unsigned long scheme_get_current_thread_stack_start(void);
 #endif
 
 /*========================================================================*/
@@ -2106,10 +2102,10 @@ static Scheme_Thread *make_thread(Scheme_Config *config,
     thread_swap_callbacks = scheme_null;
     thread_swap_out_callbacks = scheme_null;
 
-    GC_collect_start_callback = get_ready_for_GC;
-    GC_collect_end_callback = done_with_GC;
+    GC_set_collect_start_callback(get_ready_for_GC);
+    GC_set_collect_end_callback(done_with_GC);
 #ifdef MZ_PRECISE_GC
-    GC_collect_inform_callback = inform_GC;
+    GC_set_collect_inform_callback(inform_GC);
 #endif
 
 #ifdef LINK_EXTENSIONS_BY_TABLE
@@ -2118,7 +2114,7 @@ static Scheme_Thread *make_thread(Scheme_Config *config,
 #endif
     
 #if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC)
-    GC_get_thread_stack_base = get_current_stack_start;
+    GC_set_get_thread_stack_base(scheme_get_current_thread_stack_start);
 #endif
     process->stack_start = stack_base;
 
@@ -7448,7 +7444,7 @@ Scheme_Jumpup_Buf_Holder *scheme_new_jmpupbuf_holder(void)
 }
 
 #ifdef MZ_PRECISE_GC
-static unsigned long get_current_stack_start(void)
+unsigned long scheme_get_current_thread_stack_start(void)
 {
   Scheme_Thread *p;
   p = scheme_current_thread;

From daff0abe158ddf4b8ae1516ef1e08ae3c62a00c6 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Thu, 20 Nov 2008 23:57:32 +0000
Subject: [PATCH 07/17] Extended example

svn: r12550
---
 .../template/examples/blog-posted.html        |   4 +
 .../template/examples/blog-posts.html         |  16 +
 .../template/examples/blog-xexpr.ss           |  93 ++++++
 .../web-server/template/examples/blog.html    |  32 ++
 .../web-server/template/examples/blog.ss      |  46 +++
 .../web-server/scribblings/templates.scrbl    | 296 +++++++++++++++++-
 6 files changed, 475 insertions(+), 12 deletions(-)
 create mode 100644 collects/tests/web-server/template/examples/blog-posted.html
 create mode 100644 collects/tests/web-server/template/examples/blog-posts.html
 create mode 100644 collects/tests/web-server/template/examples/blog-xexpr.ss
 create mode 100644 collects/tests/web-server/template/examples/blog.html
 create mode 100644 collects/tests/web-server/template/examples/blog.ss

diff --git a/collects/tests/web-server/template/examples/blog-posted.html b/collects/tests/web-server/template/examples/blog-posted.html
new file mode 100644
index 0000000000..b3284cdd9e
--- /dev/null
+++ b/collects/tests/web-server/template/examples/blog-posted.html
@@ -0,0 +1,4 @@
+<h2>@|title|</h2>
+<p>@|body|</p>
+
+<h1><a href="@|k-url|">Continue</a></h1>
\ No newline at end of file
diff --git a/collects/tests/web-server/template/examples/blog-posts.html b/collects/tests/web-server/template/examples/blog-posts.html
new file mode 100644
index 0000000000..669399ac7c
--- /dev/null
+++ b/collects/tests/web-server/template/examples/blog-posts.html
@@ -0,0 +1,16 @@
+@in[p posts]{
+ <h2>@(post-title p)</h2>
+ <p>@(post-body p)</p>
+ <ul>
+  @in[c (post-comments p)]{
+   <li>@|c|</li>
+  }
+ </ul>
+}
+
+<h1>New Post</h1>
+<form action="@|k-url|">
+ <input name="title" />
+ <input name="body" />
+ <input type="submit" />
+</form>
diff --git a/collects/tests/web-server/template/examples/blog-xexpr.ss b/collects/tests/web-server/template/examples/blog-xexpr.ss
new file mode 100644
index 0000000000..807b7c4a62
--- /dev/null
+++ b/collects/tests/web-server/template/examples/blog-xexpr.ss
@@ -0,0 +1,93 @@
+#lang scheme
+(require web-server/servlet
+         xml
+         web-server/servlet-env)
+
+(define-struct post (title body comments))
+
+(define posts
+  (list 
+   (make-post
+    "(Y Y) Works: The Why of Y"
+    "..."
+    (list 
+     "First post! - A.T."
+     "Didn't I write this? - Matthias"))
+   (make-post
+    "Church and the States"
+    "As you may know, I grew up in DC, not technically a state..."
+    (list
+     "Finally, A Diet That Really Works! As Seen On TV"))))
+
+(define (template section body)
+  `(html
+    (head (title "Alonzo's Church: " ,section)
+          (style ([type "text/css"])
+                 ,(make-cdata #f #f "
+   body {
+    margin: 0px;
+    padding: 10px;
+   }
+
+   #main {
+    background: #dddddd;
+   }")))
+    (body
+     (script ([type "text/javascript"])
+             ,(make-cdata #f #f "
+   var gaJsHost = ((\"https:\" == document.location.protocol) ?
+     \"https://ssl.\" : \"http://www.\");
+   document.write(unescape(\"%3Cscript src='\" + gaJsHost +
+     \"google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E\"));
+"))
+     (script ([type "text/javascript"])
+             ,(make-cdata #f #f "
+   var pageTracker = _gat._getTracker(\"UA-YYYYYYY-Y\");
+   pageTracker._trackPageview();
+"))
+     
+     (h1 "Alonzo's Church: " ,section)
+     (div ([id "main"])
+          ,@body))))
+
+(define (blog-posted title body k-url)
+  `((h2 ,title)
+    (p ,body)
+    (h1 (a ([href ,k-url]) "Continue"))))
+
+(define (extract-post req)
+  (define title (extract-binding/single 'title (request-bindings req)))
+  (define body (extract-binding/single 'body (request-bindings req)))
+  (set! posts
+        (list* (make-post title body empty)
+               posts))
+  (send/suspend
+   (lambda (k-url)
+     (template "Posted" (blog-posted title body k-url))))
+  (display-posts))
+
+(define (blog-posts k-url)
+  (append
+   (apply append 
+          (for/list ([p posts])
+            `((h2 ,(post-title p))
+              (p ,(post-body p))
+              (ul
+               ,@(for/list ([c (post-comments p)])
+                   `(li ,c))))))
+   `((h1 "New Post")
+     (form ([action ,k-url])
+           (input ([name "title"]))
+           (input ([name "body"]))
+           (input ([type "submit"]))))))
+
+(define (display-posts)
+  (extract-post
+   (send/suspend
+    (lambda (k-url)
+      (template "Posts" (blog-posts k-url))))))
+
+(define (start req)
+  (display-posts))
+
+(serve/servlet start)
diff --git a/collects/tests/web-server/template/examples/blog.html b/collects/tests/web-server/template/examples/blog.html
new file mode 100644
index 0000000000..c5dc3f41bd
--- /dev/null
+++ b/collects/tests/web-server/template/examples/blog.html
@@ -0,0 +1,32 @@
+<html>
+ <head>
+  <title>Alonzo's Church: @|section|</title>
+  <style type="text/css">
+   body {
+    margin: 0px;
+    padding: 10px;
+   }
+
+   #main {
+    background: #dddddd;
+   }
+  </style>
+ </head>
+ <body>
+  <script type="text/javascript">
+   var gaJsHost = (("https:" == document.location.protocol) ?
+     "https://ssl." : "http://www.");
+   document.write(unescape("%3Cscript src='" + gaJsHost +
+     "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));
+  </script>
+  <script type="text/javascript">
+   var pageTracker = _gat._getTracker("UA-YYYYYYY-Y");
+   pageTracker._trackPageview();
+  </script>
+
+  <h1>Alonzo's Church: @|section|</h1>
+  <div id="main">
+    @body
+  </div>
+ </body>
+</html>
diff --git a/collects/tests/web-server/template/examples/blog.ss b/collects/tests/web-server/template/examples/blog.ss
new file mode 100644
index 0000000000..34e0c12a82
--- /dev/null
+++ b/collects/tests/web-server/template/examples/blog.ss
@@ -0,0 +1,46 @@
+#lang scheme
+(require web-server/templates
+         web-server/servlet
+         web-server/servlet-env)
+
+(define-struct post (title body comments))
+
+(define posts
+  (list 
+   (make-post
+    "(Y Y) Works: The Why of Y"
+    "..."
+    (list 
+     "First post! - A.T."
+     "Didn't I write this? - Matthias"))
+   (make-post
+    "Church and the States"
+    "As you may know, I grew up in DC, not technically a state..."
+    (list
+     "Finally, A Diet That Really Works! As Seen On TV"))))
+
+(define (template section body)
+  (list TEXT/HTML-MIME-TYPE
+        (include-template "blog.html")))
+
+(define (extract-post req)
+  (define title (extract-binding/single 'title (request-bindings req)))
+  (define body (extract-binding/single 'body (request-bindings req)))
+  (set! posts
+        (list* (make-post title body empty)
+               posts))
+  (send/suspend
+   (lambda (k-url)
+     (template "Posted" (include-template "blog-posted.html"))))
+  (display-posts))
+
+(define (display-posts)
+  (extract-post
+   (send/suspend
+    (lambda (k-url)
+      (template "Posts" (include-template "blog-posts.html"))))))
+
+(define (start req)
+  (display-posts))
+
+(serve/servlet start)
diff --git a/collects/web-server/scribblings/templates.scrbl b/collects/web-server/scribblings/templates.scrbl
index a42b233b04..f202eee7ad 100644
--- a/collects/web-server/scribblings/templates.scrbl
+++ b/collects/web-server/scribblings/templates.scrbl
@@ -2,11 +2,13 @@
 @(require "web-server.ss")
 @(require (for-label web-server/servlet
                      web-server/templates
+                     scheme/promise
                      scheme/list
                      xml))
 
 @(define xexpr @tech[#:doc '(lib "xml/xml.scrbl")]{X-expression})
 @(define at-reader-ref @secref[#:doc '(lib "scribblings/scribble/scribble.scrbl")]{reader})
+@(define text-ref @secref[#:doc '(lib "scribblings/scribble/scribble.scrbl")]{preprocessor})
 
 @title[#:tag "templates"]{Templates}
 
@@ -15,6 +17,9 @@
 The @web-server provides a powerful Web template system for separating the presentation logic of a Web application
 and enabling non-programmers to contribute to PLT-based Web applications.
 
+@margin-note{Although all the examples here generate HTML, the template language and the @text-ref it is based on can
+             be used to generate any text-based format: C, SQL, form emails, reports, etc.} 
+
 @local-table-of-contents[]
 
 @section{Static}
@@ -62,8 +67,8 @@ Then
 ]
 evaluates to the same content as the static example.
 
-There is no constraints on the values, the way they are used, or the way they are defined, that are made accessible to the template.
-For example,
+There are no constraints on how the lexical context of the template is populated. For instance, you can built template abstractions
+by wrapping the inclusion of a template in a function:
 @schemeblock[
  (define (fast-template thing)
    (include-template "simple.html"))
@@ -94,18 +99,71 @@ and
  </html>
 }|
 
+Furthermore, there are no constraints on the Scheme used by templates: they can use macros, structs, continuation marks, threads, etc.
+However, Scheme values that are ultimately returned must be printable by the @text-ref@"."
+For example, consider the following outputs of the 
+title line of different calls to @scheme[fast-template]:
+
+@itemize{
+
+@item{
+@schemeblock[
+ (fast-template 'Templates)
+] 
+@verbatim[#:indent 2]|{
+  <head><title>Fastest Templates in the West!</title></head>
+}|
+}
+
+@item{
+@schemeblock[
+ (fast-template 42)
+] 
+@verbatim[#:indent 2]|{
+  <head><title>Fastest 42 in the West!</title></head>
+}|
+}
+
+@item{
+@schemeblock[
+ (fast-template (list "Noo" "dles"))
+] 
+@verbatim[#:indent 2]|{
+  <head><title>Fastest Noodles in the West!</title></head>
+}|
+}
+
+@item{
+@schemeblock[
+ (fast-template (lambda () "Thunks"))
+] 
+@verbatim[#:indent 2]|{
+  <head><title>Fastest Thunks in the West!</title></head>
+}|
+}
+
+@item{
+@schemeblock[
+ (fast-template (delay "Laziness"))
+] 
+@verbatim[#:indent 2]|{
+  <head><title>Fastest Laziness in the West!</title></head>
+}|
+}
+}
+
 @section{Gotchas}
 
-One of the most important things to remember about the @at-reader-ref syntax is that the @"@" symbol must be escaped in content:
+To obtain an @"@" symbol in template output, you must escape the @"@" symbol, because it is the escape character of the @at-reader-ref syntax.
+For example, to obtain:
 @verbatim[#:indent 2]|{
- <html>
-  <head><title>Fastest @"@"s in the West!</title></head>
-  <body>
-   <h1>Bang!</h1>
-   <h2>Bang!</h2>
-  </body>
- </html>
+  <head><title>Fastest @s in the West!</title></head>
 }|
+You must write:
+@verbatim[#:indent 2]|{
+  <head><title>Fastest @"@"s in the West!</title></head>
+}|
+as your template: literal @"@"s must be replaced with @"@\"@\"".
 
 The other gotcha is that since the template is compiled into a Scheme program, only its results will be printed. For example, suppose 
 we have the template:
@@ -117,7 +175,7 @@ we have the template:
  </table>
 }|
 
-If this is included in a lexical context with @scheme[clients] bound to @scheme[(list (cons "Young" "Brigham") (cons "Smith" "Joseph"))],
+If this is included in a lexical context with @scheme[clients] bound to @schemeblock[(list (cons "Young" "Brigham") (cons "Smith" "Joseph"))]
 then the template will be printed as:
 @verbatim[#:indent 2]|{
  <table>
@@ -225,4 +283,218 @@ the template to be unescaped, then create a @scheme[cdata] structure:
   (in c clients "<tr><td>" (car c) ", " (cdr c) "</td></tr>")
  ]
 }
-         
\ No newline at end of file
+         
+@section{Conversion Example}
+
+Alonzo Church has been maintaining a blog with PLT Scheme for some years and would like to convert to @schememodname[web-server/templates].
+
+Here's the code he starts off with:
+@schememod[
+ scheme
+(require xml
+         web-server/servlet 
+         web-server/servlet-env)
+
+(code:comment "He actually Church-encodes them, but we'll use structs.")
+(define-struct post (title body comments))
+
+(define posts
+  (list 
+   (make-post
+    "(Y Y) Works: The Why of Y"
+    "..."
+    (list 
+     "First post! - A.T."
+     "Didn't I write this? - Matthias"))
+   (make-post
+    "Church and the States"
+    "As you may know, I grew up in DC, not technically a state..."
+    (list
+     "Finally, A Diet That Really Works! As Seen On TV"))))
+
+(code:comment "A function that is the generic template for the site")
+(define (template section body)
+  `(html
+    (head (title "Alonzo's Church: " ,section)
+          (style ([type "text/css"])
+                 (code:comment "CDATA objects were useful for returning raw data")
+                 ,(make-cdata #f #f "\n   body {\n    margin: 0px;\n    padding: 10px;\n   }\n\n   #main {\n    background: #dddddd;\n   }")))
+    (body
+     (script ([type "text/javascript"])
+             (code:comment "Which is particularly useful for JavaScript")
+             ,(make-cdata #f #f "\n   var gaJsHost = ((\"https:\" == document.location.protocol) ?\n     \"https://ssl.\" : \"http://www.\");\n   document.write(unescape(\"%3Cscript src='\" + gaJsHost +\n     \"google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E\"));\n"))
+     (script ([type "text/javascript"])
+             ,(make-cdata #f #f "\n   var pageTracker = _gat._getTracker(\"UA-YYYYYYY-Y\");\n   pageTracker._trackPageview();\n"))
+     
+     (h1 "Alonzo's Church: " ,section)
+     (div ([id "main"])
+          (code:comment "He had to be careful to use splicing here")
+          ,@body))))
+
+(define (blog-posted title body k-url)
+  `((h2 ,title)
+    (p ,body)
+    (h1 (a ([href ,k-url]) "Continue"))))
+
+(define (extract-post req)
+  (define binds
+    (request-bindings req))
+  (define title 
+    (extract-binding/single 'title binds))
+  (define body
+    (extract-binding/single 'body binds))
+  (set! posts
+        (list* (make-post title body empty)
+               posts))
+  (send/suspend
+   (lambda (k-url)
+     (template "Posted" (blog-posted title body k-url))))
+  (display-posts))
+
+(define (blog-posts k-url)
+  (code:comment "append or splicing is needed")
+  (append
+   (code:comment "Each element of the list is another list")
+   (apply append 
+          (for/list ([p posts])
+            `((h2 ,(post-title p))
+              (p ,(post-body p))
+              (ul
+               ,@(for/list ([c (post-comments p)])
+                   `(li ,c))))))
+   `((h1 "New Post")
+     (form ([action ,k-url])
+           (input ([name "title"]))
+           (input ([name "body"]))
+           (input ([type "submit"]))))))
+
+(define (display-posts)
+  (extract-post
+   (send/suspend
+    (lambda (k-url)
+      (template "Posts" (blog-posts k-url))))))
+
+(define (start req)
+  (display-posts))
+
+(serve/servlet start)
+]
+
+Luckily, Alonzo has great software engineering skills, so he's already separated the presentation logic into the functions
+@scheme[blog-posted], @scheme[blog-posts], and @scheme[template]. Each one of these will turn into a different
+template.
+
+@filepath{blog.html}:
+@verbatim[#:indent 2]|{
+<html>
+ <head>
+  <title>Alonzo's Church: @|section|</title>
+  <style type="text/css">
+   body {
+    margin: 0px;
+    padding: 10px;
+   }
+
+   #main {
+    background: #dddddd;
+   }
+  </style>
+ </head>
+ <body>
+  <script type="text/javascript">
+   var gaJsHost = (("https:" == document.location.protocol) ?
+     "https://ssl." : "http://www.");
+   document.write(unescape("%3Cscript src='" + gaJsHost +
+     "google-analytics.com/ga.js' 
+      type='text/javascript'%3E%3C/script%3E"));
+  </script>
+  <script type="text/javascript">
+   var pageTracker = _gat._getTracker("UA-YYYYYYY-Y");
+   pageTracker._trackPageview();
+  </script>
+
+  <h1>Alonzo's Church: @|section|</h1>
+  <div id="main">
+    @body
+  </div>
+ </body>
+</html>
+}|
+
+Notice that this part of the presentation is much simpler, because the CSS and JavaScript
+can be included verbatim, without resorting to any special escape-escaping patterns.
+Similarly, since the @scheme[body] is represented as a string, there is no need to
+remember if splicing is necessary.
+
+@filepath{blog-posts.html}:
+@verbatim[#:indent 2]|{
+@in[p posts]{
+ <h2>@(post-title p)</h2>
+ <p>@(post-body p)</p>
+ <ul>
+  @in[c (post-comments p)]{
+   <li>@|c|</li>
+  }
+ </ul>
+}
+
+<h1>New Post</h1>
+<form action="@|k-url|">
+ <input name="title" />
+ <input name="body" />
+ <input type="submit" />
+</form>
+}|
+
+This template is even simpler, because there is no list management whatsoever. The defaults "just work".
+For completeness, we show the final template:
+
+@filepath{blog-posted.html}:
+@verbatim[#:indent 2]|{
+<h2>@|title|</h2>
+<p>@|body|</p>
+
+<h1><a href="@|k-url|">Continue</a></h1>
+}|
+
+The code associated with these templates is very simple as well:
+@schememod[
+ scheme
+(require web-server/templates
+         web-server/servlet
+         web-server/servlet-env)
+
+(define-struct post (title body comments))
+
+(define posts ...)
+
+(define (template section body)
+  (list TEXT/HTML-MIME-TYPE
+        (include-template "blog.html")))
+
+(define (extract-post req)
+  (define binds
+    (request-bindings req))
+  (define title
+    (extract-binding/single 'title binds))
+  (define body 
+    (extract-binding/single 'body binds))
+  (set! posts
+        (list* (make-post title body empty)
+               posts))
+  (send/suspend
+   (lambda (k-url)
+     (template "Posted" (include-template "blog-posted.html"))))
+  (display-posts))
+
+(define (display-posts)
+  (extract-post
+   (send/suspend
+    (lambda (k-url)
+      (template "Posts" (include-template "blog-posts.html"))))))
+
+(define (start req)
+  (display-posts))
+
+(serve/servlet start)
+] 
\ No newline at end of file

From 429e229ff7a3e02336fc49ae759e45c78429f376 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 21 Nov 2008 00:59:40 +0000
Subject: [PATCH 08/17] fixed a redrawing bug in the search bar

svn: r12554
---
 collects/framework/private/frame.ss | 4 ++--
 collects/framework/private/text.ss  | 8 +++++++-
 2 files changed, 9 insertions(+), 3 deletions(-)

diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss
index da655a13c2..0990485cdc 100644
--- a/collects/framework/private/frame.ss
+++ b/collects/framework/private/frame.ss
@@ -1952,7 +1952,6 @@
         (set! red? r?)
         (refresh)))
     (define/override (on-paint)
-      (super on-paint)
       (when red?
         (let ([dc (get-dc)])
           (let-values ([(cw ch) (get-client-size)])
@@ -1962,7 +1961,8 @@
               (send dc set-brush "pink" 'solid)
               (send dc draw-rectangle 0 0 cw ch)
               (send dc set-pen pen)
-              (send dc set-brush brush))))))
+              (send dc set-brush brush)))))
+      (super on-paint))
     (super-new)))
 
 (define-local-member-name 
diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss
index cce4a88ec9..e955212d88 100644
--- a/collects/framework/private/text.ss
+++ b/collects/framework/private/text.ss
@@ -857,7 +857,13 @@ WARNING: printf is rebound in the body of the unit to always
              normalize?))]
         [else
          (preferences:get 'framework:do-paste-normalization)]))
-    (define/public (string-normalize s) (string-normalize-nfkc s))
+    (define/public (string-normalize s) 
+      
+      (let ([ns (string-normalize-nfkc s)])
+        (unless (equal? s ns)
+          (printf "normalized: ~s => ~s\n" s ns)))
+      
+      (string-normalize-nfkc s))
 
     
     

From d539020c42421a1b0f931079e8bbcd77f67978f5 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 21 Nov 2008 01:00:36 +0000
Subject: [PATCH 09/17] oops, undoing mistake

svn: r12555
---
 collects/framework/private/text.ss | 8 +-------
 1 file changed, 1 insertion(+), 7 deletions(-)

diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss
index e955212d88..cce4a88ec9 100644
--- a/collects/framework/private/text.ss
+++ b/collects/framework/private/text.ss
@@ -857,13 +857,7 @@ WARNING: printf is rebound in the body of the unit to always
              normalize?))]
         [else
          (preferences:get 'framework:do-paste-normalization)]))
-    (define/public (string-normalize s) 
-      
-      (let ([ns (string-normalize-nfkc s)])
-        (unless (equal? s ns)
-          (printf "normalized: ~s => ~s\n" s ns)))
-      
-      (string-normalize-nfkc s))
+    (define/public (string-normalize s) (string-normalize-nfkc s))
 
     
     

From cea8e15d2e855173f878551f08282bf77b48c1bd Mon Sep 17 00:00:00 2001
From: Greg Cooper <greg@cs.brown.edu>
Date: Fri, 21 Nov 2008 01:33:23 +0000
Subject: [PATCH 10/17] try to make the debug-button properly centered

svn: r12556
---
 collects/gui-debugger/debug-tool.ss | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/collects/gui-debugger/debug-tool.ss b/collects/gui-debugger/debug-tool.ss
index 47a920e6b0..3efc59a2b9 100644
--- a/collects/gui-debugger/debug-tool.ss
+++ b/collects/gui-debugger/debug-tool.ss
@@ -1278,7 +1278,9 @@
             (new switchable-button%
                  (label (string-constant debug-tool-button-name))
                  (bitmap debug-bitmap)
-                 (parent (make-object vertical-pane% (get-button-panel)))
+                 (parent (new vertical-pane%
+			      [parent (get-button-panel)]
+			      [alignment '(center center)]))
                  (callback (λ (button) (debug-callback)))))
           (inherit register-toolbar-button)
           (register-toolbar-button debug-button)

From cacdcc55ac6054bebc8e616a61ad628f0e69eb73 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 21 Nov 2008 03:22:24 +0000
Subject: [PATCH 11/17] macro-debugger: fixed button alignment (PR 9932)

svn: r12557
---
 collects/macro-debugger/tool.ss | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss
index bd8ee29529..53cf67f2e9 100644
--- a/collects/macro-debugger/tool.ss
+++ b/collects/macro-debugger/tool.ss
@@ -99,7 +99,10 @@
                  get-definitions-text)
 
         (define macro-debug-panel
-          (new vertical-pane% (parent (get-button-panel))))
+          (new horizontal-pane%
+               (parent (get-button-panel))
+               (stretchable-height #f)
+               (stretchable-width #f)))
         (define macro-debug-button
           (new switchable-button%
                (label "Macro Stepper")

From 370ec9b8e9fff394970c6c6bce681b7e07daa519 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Fri, 21 Nov 2008 08:27:14 +0000
Subject: [PATCH 12/17] show the client's ip in the apache-style log

svn: r12558
---
 collects/web-server/dispatchers/dispatch-log.ss | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/web-server/dispatchers/dispatch-log.ss b/collects/web-server/dispatchers/dispatch-log.ss
index adcd1ca585..6b32b72721 100644
--- a/collects/web-server/dispatchers/dispatch-log.ss
+++ b/collects/web-server/dispatchers/dispatch-log.ss
@@ -45,7 +45,7 @@
 (define (apache-default-format req)
   (define request-time (srfi-date:current-date))
   (format "~a - - [~a] \"~a\" ~a ~a~n"
-          (request-host-ip req)
+          (request-client-ip req)
           (srfi-date:date->string request-time "~d/~b/~Y:~T ~z")
           (request-line-raw req)
           200

From 9bdd4603cf742b9b6ef860e39be75055b92bf013 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Fri, 21 Nov 2008 08:50:26 +0000
Subject: [PATCH 13/17] Welcome to a new PLT day.

svn: r12559
---
 collects/repos-time-stamp/stamp.ss | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss
index 925fa0040c..e3af7fca9e 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "20nov2008")
+#lang scheme/base (provide stamp) (define stamp "21nov2008")

From 344ef566045d6e7ef2ff00e0f893f42de474f3e6 Mon Sep 17 00:00:00 2001
From: Kathy Gray <kathryn.gray@cl.cam.ac.uk>
Date: Fri, 21 Nov 2008 13:21:26 +0000
Subject: [PATCH 14/17] Changing coverage default

svn: r12562
---
 collects/profj/tool.ss | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss
index 88f34c72b3..0f436edd9c 100644
--- a/collects/profj/tool.ss
+++ b/collects/profj/tool.ss
@@ -506,7 +506,7 @@
           ;default-settings: -> profj-settings
           (define/public (default-settings) 
             (if (memq level `(beginner intermediate intermediate+access advanced))
-                (make-profj-settings 'field #f #t #f #t #t null)
+                (make-profj-settings 'field #f #t #f #t #f null)
                 (make-profj-settings 'type #f #t #t #f #f null)))
           ;default-settings? any -> bool
           (define/public (default-settings? s) (equal? s (default-settings)))

From 937fd18b2a6b11ccb1b10ce6d47b7e3e87c225e4 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 21 Nov 2008 13:49:10 +0000
Subject: [PATCH 15/17] change internal definition expansion, simplifying,
 fixing douplicate-id checking, and fixing binding resolution through
 extensible ribs

svn: r12563
---
 src/mzscheme/src/env.c     |  25 +++++++-
 src/mzscheme/src/error.c   |   2 +-
 src/mzscheme/src/eval.c    |  26 ++++++--
 src/mzscheme/src/module.c  |   3 +
 src/mzscheme/src/schpriv.h |   2 +
 src/mzscheme/src/stxobj.c  |  45 ++++++-------
 src/mzscheme/src/syntax.c  | 126 +++++++++++++++++++++++--------------
 7 files changed, 152 insertions(+), 77 deletions(-)

diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c
index 0e52f7223f..7c64c50239 100644
--- a/src/mzscheme/src/env.c
+++ b/src/mzscheme/src/env.c
@@ -2123,7 +2123,8 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
   }
 
   while (env != upto) {
-    if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED))) {
+    if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME 
+                        | SCHEME_CAPTURE_LIFTED | SCHEME_INTDEF_SHADOW))) {
       int i, count;
       
       /* How many slots filled in the frame so far?  This can change
@@ -2311,6 +2312,26 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
 	    stx = scheme_add_rename(stx, l);
 	}
       }
+    } else if (env->flags & SCHEME_INTDEF_SHADOW) {
+      /* Just extract existing uids from identifiers, and don't need to
+         add renames to syntax objects. */
+      if (!env->uids) {
+        Scheme_Object **uids, *uid;
+        int i;
+        
+        uids = MALLOC_N(Scheme_Object *, env->num_bindings);
+        env->uids = uids;
+        
+        for (i = env->num_bindings; i--; ) {
+          uid = scheme_stx_moduleless_env(env->values[i]);
+          if (SCHEME_FALSEP(uid))
+            scheme_signal_error("intdef shadow binding is #f for %d/%s",
+                                SCHEME_TYPE(env->values[i]),
+                                scheme_write_to_string(SCHEME_STX_VAL(env->values[i]), 
+                                                       NULL));
+          env->uids[i] = uid;
+        }
+      }
     }
 
     env = env->next;
@@ -2446,7 +2467,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
 	if (frame->values[i]) {
 	  if (frame->uids) 
 	    uid = frame->uids[i];
-	  if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i]))
+          if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i]))
 	      && (scheme_stx_env_bound_eq(find_id, frame->values[i], uid, scheme_make_integer(phase))
 		  || ((frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)
 		      && scheme_stx_module_eq2(find_id, frame->values[i], scheme_make_integer(phase), find_id_sym))
diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c
index 0fb36e3f88..bb4b052258 100644
--- a/src/mzscheme/src/error.c
+++ b/src/mzscheme/src/error.c
@@ -778,7 +778,7 @@ scheme_signal_error (const char *msg, ...)
   if (scheme_current_thread->current_local_env) {
     char *s2 = " [during expansion]";
     strcpy(buffer + len, s2);
-    len = strlen(s2);
+    len += strlen(s2);
   }
 
   buffer[len] = 0;
diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c
index 1aff3b6e8a..ad1973066c 100644
--- a/src/mzscheme/src/eval.c
+++ b/src/mzscheme/src/eval.c
@@ -4563,6 +4563,7 @@ void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec,
     /* should be always NULL */
     dest[i].observer = src[drec].observer;
     dest[i].pre_unwrapped = 0;
+    dest[i].env_already = 0;
   }
 }
 
@@ -4581,6 +4582,7 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec,
     dest[i].certs = src[drec].certs;
     dest[i].observer = src[drec].observer;
     dest[i].pre_unwrapped = 0;
+    dest[i].env_already = 0;
   }
 }
 
@@ -4603,6 +4605,7 @@ void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec,
   lam[dlrec].certs = src[drec].certs;
   lam[dlrec].observer = src[drec].observer;
   lam[dlrec].pre_unwrapped = 0;
+  lam[dlrec].env_already = 0;
 }
 
 void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec,
@@ -4850,6 +4853,7 @@ static void *compile_k(void)
     rec.certs = NULL;
     rec.observer = NULL;
     rec.pre_unwrapped = 0;
+    rec.env_already = 0;
 
     cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME);
 
@@ -6289,7 +6293,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 	  if (!SCHEME_STX_SYMBOLP(var))
 	    scheme_wrong_syntax(NULL, var, first, 
 				"name must be an identifier");
-	  scheme_dup_symbol_check(&r, "internal definition", var, "binding", first);
+	  // scheme_dup_symbol_check(&r, "internal definition", var, "binding", first);
 	  vars = SCHEME_STX_CDR(vars);
 	  cnt++;
 	}
@@ -6359,6 +6363,16 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 	    scheme_set_local_syntax(cnt++, a, scheme_false, new_env);
 	  }
 
+	  /* Extend shared rib with renamings */
+	  scheme_add_env_renames(rib, new_env, env);
+
+          /* Check for duplicates after extending the rib with renamings,
+             since the renamings properly track marks. */
+          for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
+	    a = SCHEME_STX_CAR(l);
+            scheme_dup_symbol_check(&r, "internal definition", a, "binding", first);
+          }
+
 	  if (!is_val) {
 	    /* Evaluate and bind syntaxes */
 	    scheme_prepare_exp_env(new_env->genv);
@@ -6371,9 +6385,6 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 				 &pos);
 	  }
 
-	  /* Extend shared rib with renamings */
-	  scheme_add_env_renames(rib, new_env, env);
-	  
 	  /* Remember extended environment */
 	  SCHEME_PTR1_VAL(ctx) = new_env;
 	  env = new_env;
@@ -6441,6 +6452,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
     }
 
     if (!more) {
+      /* We've converted to a letrec or letrec-values+syntaxes */
+      rec[drec].env_already = 1;
+
       if (rec[drec].comp) {
 	result = scheme_compile_expr(result, env, rec, drec);
         return scheme_make_pair(result, scheme_null);
@@ -8720,6 +8734,7 @@ static void *expand_k(void)
     erec1.certs = certs;
     erec1.observer = observer;
     erec1.pre_unwrapped = 0;
+    erec1.env_already = 0;
 
     if (catch_lifts_key)
       scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, catch_lifts_key);
@@ -9201,7 +9216,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
     l = scheme_add_rename(l, renaming);
 
   if (for_expr) {
-    /* Package up expanded expr with the enviornment. */
+    /* Package up expanded expr with the environment. */
     while (1) {
       if (orig_env->flags & SCHEME_FOR_STOPS)
         orig_env = orig_env->next;
@@ -9552,6 +9567,7 @@ local_eval(int argc, Scheme_Object **argv)
     rec.certs = certs;
     rec.observer = observer;
     rec.pre_unwrapped = 0;
+    rec.env_already = 0;
     
     /* Evaluate and bind syntaxes */
     expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark);
diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c
index 360e0fa16c..77d3f168c4 100644
--- a/src/mzscheme/src/module.c
+++ b/src/mzscheme/src/module.c
@@ -5773,6 +5773,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	erec1.certs = rec[drec].certs;
         erec1.observer = rec[drec].observer;
         erec1.pre_unwrapped = 0;
+        erec1.env_already = 0;
 	e = scheme_expand_expr(e, xenv, &erec1, 0);	
       }
 
@@ -5975,6 +5976,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	  mrec.certs = rec[drec].certs;
           mrec.observer = NULL;
           mrec.pre_unwrapped = 0;
+          mrec.env_already = 0;
 
 	  if (!rec[drec].comp) {
 	    Scheme_Expand_Info erec1;
@@ -5984,6 +5986,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	    erec1.certs = rec[drec].certs;
             erec1.observer = rec[drec].observer;
             erec1.pre_unwrapped = 0;
+            erec1.env_already = 0;
 	    SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
 	    code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0);
 	  }
diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h
index 9ea3f36d3a..8cff95e5c6 100644
--- a/src/mzscheme/src/schpriv.h
+++ b/src/mzscheme/src/schpriv.h
@@ -1837,6 +1837,7 @@ typedef struct Scheme_Compile_Expand_Info
   char resolve_module_ids;
   char pre_unwrapped;
   int depth;
+  int env_already;
 } Scheme_Compile_Expand_Info;
 
 typedef Scheme_Compile_Expand_Info Scheme_Compile_Info;
@@ -2301,6 +2302,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
 #define SCHEME_FOR_STOPS 128
 #define SCHEME_FOR_INTDEF 256
 #define SCHEME_CAPTURE_LIFTED 512
+#define SCHEME_INTDEF_SHADOW 1024
 
 /* Flags used with scheme_static_distance */
 #define SCHEME_ELIM_CONST 1
diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c
index a31ef7c2e1..e24d1a87dd 100644
--- a/src/mzscheme/src/stxobj.c
+++ b/src/mzscheme/src/stxobj.c
@@ -2982,12 +2982,14 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx)
   return scheme_false;
 }
 
-XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
-				     Scheme_Object *barrier_env, Scheme_Object *ignore_rib)
+XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env)
 /* Compares the marks in two wraps lists. A result of 2 means that the
-   result depended on a barrier env. Use #f for barrier_env
-   to treat no rib envs as barriers; we check for barrier_env only in ribs
-   because simpliciation eliminates the need for these checks(?). */
+   result depended on a barrier env. For a rib-based renaming, we need
+   to check only up to the rib, and the barrier effect important for
+   when a rib-based renaming is layered with another renaming (such as
+   when an internal-definition-base local-expand is used to form a new
+   set of bindings, as in the unit form); simplification cleans up the
+   layers, so that we only need to check in ribs. */
 {
   WRAP_POS awl;
   WRAP_POS bwl;
@@ -3015,9 +3017,7 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
 	  WRAP_POS_INC(awl);
 	}
       } else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) {
-	if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(awl))) {
-	  WRAP_POS_INC(awl);
-	} else if (SCHEME_FALSEP(barrier_env)) {
+	if (SCHEME_FALSEP(barrier_env)) {
 	  WRAP_POS_INC(awl);
 	} else {
 	  /* See if the barrier environment is in this rib. */
@@ -3054,9 +3054,7 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
 	  WRAP_POS_INC(bwl);
 	}
       } else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) {
-	if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(bwl))) {
-	  WRAP_POS_INC(bwl);
-	} else if (SCHEME_FALSEP(barrier_env)) {
+	if (SCHEME_FALSEP(barrier_env)) {
 	  WRAP_POS_INC(bwl);
 	} else {
 	  /* See if the barrier environment is in this rib. */
@@ -3665,15 +3663,16 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
 		       && !no_lexical)) {
       /* Lexical rename: */
       Scheme_Object *rename, *renamed;
-      int ri, c, istart, iend, is_rib;
+      int ri, c, istart, iend;
+      Scheme_Lexical_Rib *is_rib;
 
       if (rib) {
 	rename = rib->rename;
+	is_rib = rib;
 	rib = rib->next;
-	is_rib = 1;
       } else {
 	rename = WRAP_POS_FIRST(wraps);
-	is_rib = 0;
+	is_rib = NULL;
       }
 
       c = SCHEME_RENAME_LEN(rename);
@@ -3735,7 +3734,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
 	      {
 		WRAP_POS w2;
 		WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps);
-		same = same_marks(&w2, &wraps, other_env, WRAP_POS_FIRST(wraps));
+		same = same_marks(&w2, &wraps, other_env);
                 if (!same)
                   EXPLAIN(printf("Different marks\n"));
 	      }
@@ -3755,7 +3754,11 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
 		o_rename_stack = CONS(CONS(other_env, envname),
 				      o_rename_stack);
 	      }
-	      rib = NULL; /* skip rest of rib (if any) */
+              if (is_rib) {
+                /* skip rest of rib (if any) and future instances of the same rib */
+                rib = NULL;
+                skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs);
+              }
 	    }
 
 	    break;
@@ -4092,7 +4095,7 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
     WRAP_POS bw;
     WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
     WRAP_POS_INIT(bw, ((Scheme_Stx *)b)->wraps);
-    if (!same_marks(&aw, &bw, ae, NULL))
+    if (!same_marks(&aw, &bw, ae))
       return 0;
   }
 
@@ -4277,7 +4280,7 @@ Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *re
   WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
   WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps);
 
-  if (!same_marks(&aw, &bw, NULL, NULL)) {
+  if (!same_marks(&aw, &bw, scheme_false)) {
     Scheme_Object *wraps = ((Scheme_Stx *)relative_to)->wraps;
     if (uid) {
       /* Add a rename record: */
@@ -4647,7 +4650,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
 
               /* Check marks (now that we have the correct barriers). */
 	      WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
-	      if (!same_marks(&w2, &w, other_env, (Scheme_Object *)init_rib)) {
+	      if (!same_marks(&w2, &w, other_env)) {
 		other_env = NULL;
 	      }
 
@@ -4699,7 +4702,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
               }
 	    } else {
 	      WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
-	      if (same_marks(&w2, &w, scheme_false, (Scheme_Object *)init_rib))
+	      if (same_marks(&w2, &w, scheme_false))
                 ok = SCHEME_VEC_ELS(v)[0];
 	      else
 		ok = NULL;
@@ -6759,7 +6762,7 @@ static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv)
   WRAP_POS_INIT(awl, stx->wraps);
   WRAP_POS_INIT_END(ewl);
 
-  if (same_marks(&awl, &ewl, scheme_false, NULL))
+  if (same_marks(&awl, &ewl, scheme_false))
     return scheme_true;
   else
     return scheme_false;
diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c
index f3819089de..4a1e6a4546 100644
--- a/src/mzscheme/src/syntax.c
+++ b/src/mzscheme/src/syntax.c
@@ -4092,6 +4092,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
   Scheme_Object *first = NULL;
   Scheme_Compiled_Let_Value *last = NULL, *lv;
   DupCheckRecord r;
+  int rec_env_already = rec[drec].env_already;
 
   i = scheme_stx_proper_list_length(form);
   if (i < 3)
@@ -4160,8 +4161,14 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
   names = MALLOC_N(Scheme_Object *, num_bindings);
   if (frame_already)
     frame = frame_already;
-  else
-    frame = scheme_new_compilation_frame(num_bindings, 0, origenv, rec[drec].certs);
+  else {
+    frame = scheme_new_compilation_frame(num_bindings, 
+                                         (rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
+                                         origenv, 
+                                         rec[drec].certs);
+    if (rec_env_already)
+      frame_already = frame;
+  }
   env = frame;
 
   recs = MALLOC_N_RT(Scheme_Compile_Info, (num_clauses + 1));
@@ -4172,7 +4179,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
 
   defname = scheme_check_name_property(form, defname);
   
-  if (!star) {
+  if (!star && !frame_already) {
     scheme_begin_dup_symbol_check(&r, env);
   }
 
@@ -4216,7 +4223,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
       names[k++] = name;
     }
     
-    if (!star) {
+    if (!star && !frame_already) {
       for (m = pre_k; m < k; m++) {
 	scheme_dup_symbol_check(&r, NULL, names[m], "binding", form);
       }
@@ -4319,6 +4326,7 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
   Scheme_Comp_Env *use_env, *env;
   Scheme_Expand_Info erec1;
   DupCheckRecord r;
+  int rec_env_already = erec[drec].env_already;
 
   vars = SCHEME_STX_CDR(form);
 
@@ -4385,8 +4393,8 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
   }
   
   /* Note: no more letstar handling needed after this point */
-
-  scheme_begin_dup_symbol_check(&r, origenv);
+  if (!env_already && !rec_env_already)
+    scheme_begin_dup_symbol_check(&r, origenv);
 
   vlist = scheme_null;
   vs = vars;
@@ -4405,15 +4413,18 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
     {
       DupCheckRecord r2;
       Scheme_Object *names = name;
-      scheme_begin_dup_symbol_check(&r2, origenv);
+      if (!env_already && !rec_env_already)
+        scheme_begin_dup_symbol_check(&r2, origenv);
       while (SCHEME_STX_PAIRP(names)) {
 	name = SCHEME_STX_CAR(names);
 
 	scheme_check_identifier(NULL, name, NULL, origenv, form);
 	vlist = cons(name, vlist);
 
-	scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form);
-	scheme_dup_symbol_check(&r, NULL, name, "binding", form);
+        if (!env_already && !rec_env_already) {
+          scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form);
+          scheme_dup_symbol_check(&r, NULL, name, "binding", form);
+        }
 	
 	names = SCHEME_STX_CDR(names);
       }
@@ -4430,7 +4441,10 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
   if (env_already)
     env = env_already;
   else
-    env = scheme_add_compilation_frame(vlist, origenv, 0, erec[drec].certs);
+    env = scheme_add_compilation_frame(vlist, 
+                                       origenv, 
+                                       (rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
+                                       erec[drec].certs);
 
   if (letrec)
     use_env = env;
@@ -5526,6 +5540,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
   rec1.certs = rec[drec].certs;
   rec1.observer = NULL;
   rec1.pre_unwrapped = 0;
+  rec1.env_already = 0;
 
   if (for_stx) {
     names = defn_targets_syntax(names, exp_env, &rec1, 0);
@@ -5717,6 +5732,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
   mrec.certs = certs;
   mrec.observer = NULL;
   mrec.pre_unwrapped = 0;
+  mrec.env_already = 0;
 
   a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0);
 
@@ -5805,9 +5821,11 @@ do_letrec_syntaxes(const char *where,
   Scheme_Object *form, *bindings, *var_bindings, *body, *v;
   Scheme_Object *names_to_disappear;
   Scheme_Comp_Env *stx_env, *var_env, *rhs_env;
-  int cnt, stx_cnt, var_cnt, i, j, depth, saw_var;
+  int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already;
   DupCheckRecord r;
 
+  env_already = rec[drec].env_already;
+
   form = SCHEME_STX_CDR(forms);
   if (!SCHEME_STX_PAIRP(form))
     scheme_wrong_syntax(NULL, NULL, forms, NULL);
@@ -5823,7 +5841,10 @@ do_letrec_syntaxes(const char *where,
 
   scheme_rec_add_certs(rec, drec, forms);
 
-  stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs);
+  if (env_already)
+    stx_env = origenv;
+  else
+    stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs);
 
   rhs_env = stx_env;
 
@@ -5846,8 +5867,8 @@ do_letrec_syntaxes(const char *where,
   else
     names_to_disappear = NULL;
 
-
-  scheme_begin_dup_symbol_check(&r, stx_env);
+  if (!env_already)
+    scheme_begin_dup_symbol_check(&r, stx_env);
 
   /* Pass 1: Check and Rename */
 
@@ -5881,8 +5902,10 @@ do_letrec_syntaxes(const char *where,
 
       for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
 	a = SCHEME_STX_CAR(l);
-	scheme_check_identifier(where, a, NULL, stx_env, forms);
-	scheme_dup_symbol_check(&r, where, a, "binding", forms);
+        if (!env_already) {
+          scheme_check_identifier(where, a, NULL, stx_env, forms);
+          scheme_dup_symbol_check(&r, where, a, "binding", forms);
+        }
 	cnt++;
       }
       if (i)
@@ -5895,30 +5918,35 @@ do_letrec_syntaxes(const char *where,
       var_cnt = cnt - stx_cnt;
   }
 
-  scheme_add_local_syntax(stx_cnt, stx_env);
-  if (saw_var)
-    var_env = scheme_new_compilation_frame(var_cnt, 0, stx_env, rec[drec].certs);
-  else
+  if (!env_already)
+    scheme_add_local_syntax(stx_cnt, stx_env);
+  
+  if (saw_var) {
+    var_env = scheme_new_compilation_frame(var_cnt, 
+                                           (env_already ? SCHEME_INTDEF_SHADOW : 0), 
+                                           stx_env, 
+                                           rec[drec].certs);
+  } else
     var_env = NULL;
 
-  for (i = 0; i < (var_env ? 2 : 1) ; i++) {
+  for (i = (env_already ? 1 : 0); i < (var_env ? 2 : 1) ; i++) {
     cnt = (i ? var_cnt : stx_cnt);
     if (cnt > 0) {
-      /* Add new syntax names to the environment: */
+      /* Add new syntax/variable names to the environment: */
       j = 0;
       for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
-	Scheme_Object *a, *l;
+        Scheme_Object *a, *l;
 	
-	a = SCHEME_STX_CAR(v);
-	for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
-	  a = SCHEME_STX_CAR(l);
-	  if (i) {
-	    /* In compile mode, this will get re-written by the letrec compiler.
-	       But that's ok. We need it now for env_renames. */
-	    scheme_add_compilation_binding(j++, a, var_env);
-	  } else
-	    scheme_set_local_syntax(j++, a, NULL, stx_env);
-	}
+        a = SCHEME_STX_CAR(v);
+        for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
+          a = SCHEME_STX_CAR(l);
+          if (i) {
+            /* In compile mode, this will get re-written by the letrec compiler.
+               But that's ok. We need it now for env_renames. */
+            scheme_add_compilation_binding(j++, a, var_env);
+          } else
+            scheme_set_local_syntax(j++, a, NULL, stx_env);
+        }
       }
     }
   }
@@ -5949,29 +5977,31 @@ do_letrec_syntaxes(const char *where,
   
   scheme_prepare_exp_env(stx_env->genv);
 
-  i = 0;
+  if (!env_already) {
+    i = 0;
 
-  for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
-    Scheme_Object *a, *names;
+    for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
+      Scheme_Object *a, *names;
 
-    SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
+      SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
 
-    a = SCHEME_STX_CAR(v);
-    names = SCHEME_STX_CAR(a);
-    a = SCHEME_STX_CDR(a);
-    a = SCHEME_STX_CAR(a);
+      a = SCHEME_STX_CAR(v);
+      names = SCHEME_STX_CAR(a);
+      a = SCHEME_STX_CDR(a);
+      a = SCHEME_STX_CAR(a);
 
-    scheme_bind_syntaxes(where, names, a,
-                         stx_env->genv->exp_env,
-                         stx_env->insp,
-                         rec, drec,
-                         stx_env, rhs_env, 
-                         &i);
+      scheme_bind_syntaxes(where, names, a,
+                           stx_env->genv->exp_env,
+                           stx_env->insp,
+                           rec, drec,
+                           stx_env, rhs_env, 
+                           &i);
+    }
   }
 
   SCHEME_EXPAND_OBSERVE_NEXT_GROUP(rec[drec].observer);
 
-  if (names_to_disappear) {
+  if (!env_already && names_to_disappear) {
     /* Need to add renaming for disappeared bindings. If they
        originated for internal definitions, then we need both
        pre-renamed and renamed, since some might have been

From 58f9e0251375bfb25a6d89d01d33248d096ad627 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 21 Nov 2008 13:52:20 +0000
Subject: [PATCH 16/17] fix (mostly) expand tests suite

svn: r12564
---
 collects/tests/mzscheme/expand.ss | 53 +++++++++++++++----------------
 collects/tests/mzscheme/module.ss |  4 +++
 collects/tests/mzscheme/syntax.ss |  2 ++
 3 files changed, 31 insertions(+), 28 deletions(-)

diff --git a/collects/tests/mzscheme/expand.ss b/collects/tests/mzscheme/expand.ss
index ef00b03c8e..2ccfd4ab7f 100644
--- a/collects/tests/mzscheme/expand.ss
+++ b/collects/tests/mzscheme/expand.ss
@@ -55,8 +55,8 @@
   ;; really idempotent, on the structure. Assume that
   ;; the test case is broken, not expand.
   (define (ensure-good-test-case o1 o2)
-    (let ([d1 (syntax-object->datum o1)]
-          [d2 (syntax-object->datum o2)])
+    (let ([d1 (syntax->datum o1)]
+          [d2 (syntax->datum o2)])
       (unless (equal? d1 d2)
         (error 'compare-objs "bad test case: ~e ~e" d1 d2))))
   
@@ -64,19 +64,16 @@
   (define (both? p? o1 o2) (and (p? o1) (p? o2)))
   
   (compare-expansion #''())
-  (compare-expansion #'(#%datum . 1))
-  (compare-expansion #'(#%datum . #t))
   (compare-expansion #'(quote 1))
   (compare-expansion #'(#%top . x))
   (compare-expansion #'(if (#%top . a) (#%top . b) (#%top . c)))
-  (compare-expansion #'(if (#%top . a) (#%top . b)))
-  (compare-expansion #'(lambda () (#%top . x)))
-  (compare-expansion #'(lambda (x) x))
-  (compare-expansion #'(lambda (x y z) x))
-  (compare-expansion #'(lambda (x) x x x))
+  (compare-expansion #'(#%plain-lambda () (#%top . x)))
+  (compare-expansion #'(#%plain-lambda (x) x))
+  (compare-expansion #'(#%plain-lambda (x y z) x))
+  (compare-expansion #'(#%plain-lambda (x) x x x))
   (compare-expansion #'(case-lambda))
-  (compare-expansion #'(case-lambda [() (#%datum . 1)]))
-  (compare-expansion #'(case-lambda [() (#%datum . 1)] [(x) x]))
+  (compare-expansion #'(case-lambda [() (quote 1)]))
+  (compare-expansion #'(case-lambda [() (quote 1)] [(x) x]))
   (compare-expansion #'(case-lambda [(x y) x]))
   (compare-expansion #'(define-values () (#%top . x)))
   (compare-expansion #'(define-values (x) (#%top . x)))
@@ -84,37 +81,37 @@
   (compare-expansion #'(define-syntaxes () (#%top . x)))
   (compare-expansion #'(define-syntaxes (s) (#%top . x)))
   (compare-expansion #'(define-syntaxes (s x y) (#%top . x)))
-  (compare-expansion #'(require mzscheme))
-  (compare-expansion #'(require (lib "list.ss")))
-  (compare-expansion #'(require (lib "list.ss") mzscheme))
-  (compare-expansion #'(require-for-syntax mzscheme))
-  (compare-expansion #'(require-for-syntax (lib "list.ss")))
-  (compare-expansion #'(require-for-syntax (lib "list.ss") mzscheme))
+  (compare-expansion #'(#%require mzscheme))
+  (compare-expansion #'(#%require (lib "list.ss")))
+  (compare-expansion #'(#%require (lib "list.ss") mzscheme))
+  (compare-expansion #'(#%require (for-syntax mzscheme)))
+  (compare-expansion #'(#%require (for-syntax (lib "list.ss"))))
+  (compare-expansion #'(#%require (for-syntax (lib "list.ss") mzscheme)))
   (compare-expansion #'(begin))
   (compare-expansion #'(begin (#%top . x)))
-  (compare-expansion #'(begin (#%top . x) (#%datum . 2)))
+  (compare-expansion #'(begin (#%top . x) (quote 2)))
   (compare-expansion #'(begin0 (#%top . x)))
-  (compare-expansion #'(begin0 (#%top . x) (#%datum . 2)))
-  (compare-expansion #'(begin0 (#%top . x) (#%datum . 2) (#%datum . 2)))
+  (compare-expansion #'(begin0 (#%top . x) (quote 2)))
+  (compare-expansion #'(begin0 (#%top . x) (quote 2) (quote 2)))
   (compare-expansion #'(let-values () (#%top . q)))
   (compare-expansion #'(let-values (((x y) (#%top . p))) (#%top . q)))
-  (compare-expansion #'(let-values (((x y) (#%top . p)) ((z) (#%datum . 12))) (#%top . q)))
+  (compare-expansion #'(let-values (((x y) (#%top . p)) ((z) (quote 12))) (#%top . q)))
   (compare-expansion #'(let-values (((x y) (#%top . p))) (#%top . q) (#%top . p)))
   (compare-expansion #'(letrec-values () (#%top . q)))
   (compare-expansion #'(letrec-values (((x y) (#%top . p))) (#%top . q)))
-  (compare-expansion #'(letrec-values (((x y) (#%top . p)) ((z) (#%datum . 12))) (#%top . q)))
+  (compare-expansion #'(letrec-values (((x y) (#%top . p)) ((z) (quote 12))) (#%top . q)))
   (compare-expansion #'(letrec-values (((x y) (#%top . p))) (#%top . q) (#%top . p)))
   (compare-expansion #'(set! x (#%top . y)))
   (compare-expansion #'(quote-syntax x))
   (compare-expansion #'(with-continuation-mark (#%top . x) (#%top . x) (#%top . x)))
-  (compare-expansion #'(#%app (#%top . f)))
-  (compare-expansion #'(#%app (#%top . f) (#%datum . 1))))
+  (compare-expansion #'(#%plain-app (#%top . f)))
+  (compare-expansion #'(#%plain-app (#%top . f) (quote 1))))
 
 (define expand-test-use-toplevel? #f)
 
-(define datum->top-level-syntax-object
+(define datum->top-level-syntax
   (lambda (v)
-    (namespace-syntax-introduce (datum->syntax-object #f v))))
+    (namespace-syntax-introduce (datum->syntax #f v))))
 
 (define now-expanding (make-parameter #f))
 
@@ -139,13 +136,13 @@
 	      (let ([x (if (or (compiled-expression? x)
 			       (and (syntax? x) (compiled-expression? (syntax-e x))))
 			   x
-			   (parameterize ([current-module-name-prefix #f]
+			   (parameterize ([current-module-declare-name #f]
 					  [now-expanding expand-test-use-toplevel?])
 			     (expand-syntax
 			      ((if expand-test-use-toplevel?
 				   expand-top-level-with-compile-time-evals
 				   expand-syntax)
-			       ((if (syntax? x) values datum->top-level-syntax-object) x)))))])
+			       ((if (syntax? x) values datum->top-level-syntax) x)))))])
 		(set! mz-test-syntax-errors-allowed? #f)
 		(orig x)))))))
    (lambda ()
diff --git a/collects/tests/mzscheme/module.ss b/collects/tests/mzscheme/module.ss
index 3cd2d93fa2..e3550e034e 100644
--- a/collects/tests/mzscheme/module.ss
+++ b/collects/tests/mzscheme/module.ss
@@ -239,6 +239,8 @@
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Test proper bindings for `#%module-begin'
 
+(define expand-test-use-toplevel? #t)
+
 (test (void) eval
       '(begin
 	 (module mod_beg2 mzscheme
@@ -282,6 +284,8 @@
 	 (module m 'mod_beg2
 		 3)))
 
+(define expand-test-use-toplevel? #f)
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (let ([f1 "tmp1.ss"]
diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss
index b3cf53c677..219256cefe 100644
--- a/collects/tests/mzscheme/syntax.ss
+++ b/collects/tests/mzscheme/syntax.ss
@@ -1156,9 +1156,11 @@
                                                                  [(_) (+ 2 (abcdefg 9))]
                                                                  [(_ ?) 77])])
                                                      (abcdefg))))
+(define expand-test-use-toplevel? #t)
 (splicing-let-syntax ([abcdefg (syntax-rules ()
                                  [(_) 8])])
                      (define hijklmn (abcdefg)))
+(define expand-test-use-toplevel? #f)
 (test 8 'hijklmn hijklmn)
 (test 30 'local-hijklmn (let ()
                           (splicing-let-syntax ([abcdefg (syntax-rules ()

From 2480a1c4e8e94e623267ea0b332bb58a922ecd37 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 21 Nov 2008 14:01:32 +0000
Subject: [PATCH 17/17] extra int-def tests

svn: r12565
---
 collects/tests/mzscheme/macro.ss  | 61 +++++++++++++++++++++++++++++++
 collects/tests/units/test-unit.ss | 12 ++++++
 2 files changed, 73 insertions(+)

diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss
index c035e1ee6c..4080b105b7 100644
--- a/collects/tests/mzscheme/macro.ss
+++ b/collects/tests/mzscheme/macro.ss
@@ -339,4 +339,65 @@
 
 ;; ----------------------------------------
 
+(require (only-in mzlib/etc begin-with-definitions))
+
+(define-syntax (def stx)
+  (syntax-case stx ()
+    [(_ id)
+     (with-syntax ([x:id (datum->syntax #'id 'x)])
+       #'(begin
+           (define x:id 50)
+           (define-syntax id #'x:id)))]))
+(define-syntax (look stx)
+  (syntax-case stx ()
+    [(_ id) (syntax-local-value #'id)]))
+
+(test 50 'look
+      (let ()
+        (def foo)
+        (look foo)))
+
+(test 50 'look
+      (begin-with-definitions
+       (def foo)
+       (look foo)))
+
+(test #t 'bwd-struct
+      (let ()
+        (begin-with-definitions
+         (define-struct a (x y))
+         (define-struct (b a) (z))
+         (b? (make-b 1 2 3)))))
+
+(test 5 'intdef
+      (let ()
+        (define-syntax foo
+          (syntax-rules ()
+            [(_ id) (begin
+                      (define x 5)
+                      (define id x))]))
+        (foo x)
+        x))
+
+(test 6 'intdef-values
+      (let ()
+        (define-syntax foo
+          (syntax-rules ()
+            [(_ id) (define-values (x id) 
+                      (values 6 (lambda () x)))]))
+        (foo x)
+        (x)))
+
+(test 75 'bwd
+      (begin-with-definitions
+       (define-syntax foo
+         (syntax-rules ()
+           [(_ id) (begin
+                     (define x 75)
+                     (define id x))]))
+       (foo x)
+       x))
+
+;; ----------------------------------------
+
 (report-errs)
diff --git a/collects/tests/units/test-unit.ss b/collects/tests/units/test-unit.ss
index 061e142937..e7cb92bc2c 100644
--- a/collects/tests/units/test-unit.ss
+++ b/collects/tests/units/test-unit.ss
@@ -1677,3 +1677,15 @@
   (use-unit-badly1 u-a))
 (test-runtime-error exn:fail:contract:variable? "context mismatch; no u-a"
   (use-unit-badly2 sig^))
+
+(test 12
+      (let ()
+        (define-signature s^ (x))
+        (define-unit u@
+          (import)
+          (export s^)
+          (define x 12))
+        (define-values/invoke-unit u@ (import) (export s^))
+        x))
+
+