From a8d40530f4bf1bc868ea5608e7f273ea1861768b Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Tue, 24 Nov 2009 20:58:13 +0000
Subject: [PATCH 001/136] checkpoint new macro stuff

svn: r17050
---
 collects/honu/private/debug.ss |   2 +-
 collects/honu/private/honu.ss  |   1 +
 collects/honu/private/macro.ss | 211 +++++++++++++++++++++++++++++++--
 3 files changed, 206 insertions(+), 8 deletions(-)

diff --git a/collects/honu/private/debug.ss b/collects/honu/private/debug.ss
index 49f1314323..40baf40a26 100644
--- a/collects/honu/private/debug.ss
+++ b/collects/honu/private/debug.ss
@@ -4,7 +4,7 @@
 
 (provide debug)
 
-(define-for-syntax verbose? #f)
+(define-for-syntax verbose? #t)
 (define-syntax (debug stx)
   (if verbose?
     (syntax-case stx ()
diff --git a/collects/honu/private/honu.ss b/collects/honu/private/honu.ss
index dd8a1ea7a4..931bcfb78e 100644
--- a/collects/honu/private/honu.ss
+++ b/collects/honu/private/honu.ss
@@ -126,6 +126,7 @@
                  (let ([v (syntax-local-value (stx-car first) (lambda () #f))])
                    (and (honu-transformer? v) v))]
                 [else #f]))))
+     (printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
      (or (bound-transformer stx)
          (special-transformer stx)))
    
diff --git a/collects/honu/private/macro.ss b/collects/honu/private/macro.ss
index 1dd5b15182..90a0c9ee1c 100644
--- a/collects/honu/private/macro.ss
+++ b/collects/honu/private/macro.ss
@@ -1,8 +1,12 @@
 #lang scheme/base
 
 (require "honu.ss"
-         (for-syntax "debug.ss")
-         (for-syntax scheme/base))
+         (for-syntax "debug.ss"
+                     scheme/base
+                     syntax/parse
+                     syntax/stx
+                     scheme/pretty
+                     scheme/trace))
 
 (provide honu-macro)
 
@@ -21,6 +25,9 @@
        (loop out #'(rest1 rest ...))]
       [(foo) out])))
 
+(define-syntax (semicolon stx)
+  stx)
+
 (define-for-syntax (extract-patterns pattern)
   (let loop ([out '()]
              [in pattern])
@@ -36,6 +43,29 @@
                #'(rest1 rest ...)))]
       [(foo) (reverse (cons #'foo out))])))
 
+#|
+(define-for-syntax (convert stx)
+  (syntax-case stx (...)
+    [(_ x ...)
+     |#
+
+(define-for-syntax (fix-template stx) stx)
+
+#|
+(define-for-syntax (fix-template stx)
+  [(any \;
+            (... ...) rest1 rest ...)
+       (loop (cons #'(semicolon any (... ..)))
+             #'(rest1 rest ...))]
+      [((any1 any ...) rest1 rest ...)
+       (loop (loop out #'(any1 any ...))
+             #'(rest1 rest ...))]
+      |#
+
+
+;; x = 1 + y; ...
+
+#;
 (define-honu-syntax honu-macro
   (lambda (stx ctx)
     (debug "Original macro: ~a\n" (syntax->datum stx))
@@ -47,7 +77,10 @@
        (with-syntax ([(conventions ...)
                       (extract-conventions #'(pattern ...))]
                      [(raw-patterns ...)
-                      (extract-patterns #'(pattern ...))])
+                      (extract-patterns #'(pattern ...))]
+                     [(fixed-template ...)
+                      (fix-template #'(template ...))])
+         (debug "new template ~a\n" (syntax->datum #'(fixed-template ...)))
          (values
            (syntax/loc
              stx
@@ -80,7 +113,7 @@
                                [(name pattern ...)
                                 #'(honu-unparsed-block
                                     #f obj 'obj #f ctx
-                                    template ...)]))
+                                    fixed-template ...)]))
 
                    (let ([result (syntax-case stx
                                    #;
@@ -92,7 +125,7 @@
                                    [(name raw-patterns ...)
                                     #'(honu-unparsed-block
                                         #f obj 'obj #f ctx
-                                        template ...)]
+                                        fixed-template ...)]
                                    [else 'fail-boat])])
                      (debug "result was ~a\n" result))
                    (syntax-case stx (honu-literal ...)
@@ -100,7 +133,7 @@
                       (values
                         #'(honu-unparsed-block
                             #f obj 'obj #f ctx
-                            template ...)
+                            fixed-template ...)
                         #'rrest)])))
                #;
                (define-honu-syntax name
@@ -115,7 +148,171 @@
                                   (values
                                     #'(honu-unparsed-block
                                         #f obj 'obj #f ctx
-                                        template ...)
+                                        fixed-template ...)
                                     #'rrest)])))))
            #'rest))])
     ))
+
+(define-for-syntax (delimiter? x) #f)
+
+(define-syntax (my-ellipses stx) (raise-syntax-error 'my-ellipses "dont use this"))
+;; (define-syntax (wrapped stx) (raise-syntax-error 'wrapped "dont use wrap"))
+;; just a phase 0 identifier
+(define wrapped #f)
+(define unwrap #f)
+
+;; rename this to wrap
+(define-for-syntax (pull stx)
+  (define (reverse-syntax stx)
+    (with-syntax ([(x ...) (reverse (syntax->list stx))])
+      #'(x ...)))
+  (define-syntax-class ellipses-class
+                       (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
+  ;; use this if you are defining your own ellipses identifier
+  #;
+  (define-syntax-class ellipses-class
+                       #:literals (...)
+                       (pattern my-ellipses))
+  (if (not (stx-pair? stx))
+    stx
+    (let ([stx (reverse (syntax->list stx))])
+      ;; (debug-parse stx (ellipses1:ellipses-class ellipses:ellipses-class ... x ...))
+      ;; (printf "stx is ~a\n" stx)
+      ;; (printf "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx)))
+      (syntax-parse stx
+        [(ellipses1:ellipses-class ellipses:ellipses-class ... x ...)
+         (with-syntax ([(x* ...) (reverse-syntax (pull #'(x ...)))])
+           (reverse-syntax
+             (with-syntax ([wrapped #'wrapped]
+                           [original
+                            (with-syntax ([(ellipses* ...) (map (lambda (_)
+                                                            #'((... ...) (... ...)))
+                                                          (syntax->list #'(ellipses1 ellipses ...)))]
+                                          [(x-new ...) (generate-temporaries #'(x ...))])
+                              (reverse-syntax #'(ellipses* ... x-new ...)))]
+                           #;
+                           [original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))])
+               #'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))]
+        [(x ...) (with-syntax ([(x* ...) (map pull (syntax->list #'(x ...)))])
+                   (reverse-syntax #'(x* ...)))]))))
+
+(begin-for-syntax (trace pull))
+
+(define-for-syntax (unpull stx)
+  (define-syntax-class ellipses-class
+    (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
+  (syntax-parse stx
+                #:literals (wrapped unwrap)
+                [(unwrap (wrapped x ... y) ...)
+                 (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
+                   (with-syntax ([(x1* ...) (map unpull (syntax->list #'(x1 ...)))]
+                                 [(y* ...) (map unpull (syntax->list #'(y ...)))])
+                     #'(x1* ... y* ...)))]
+                [(unwrap . x) (raise-syntax-error 'unpull "unhandled unwrap ~a" stx)]
+                [(x ...) (with-syntax ([(x* ...) (map unpull (syntax->list #'(x ...)))])
+                           #'(x* ...))]
+                [else stx]))
+
+;; rename this to unwrap
+#;
+(define-syntax (unpull stx)
+  (define-syntax-class ellipses-class
+                       (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
+  (define (do-it stx)
+    (syntax-parse stx
+      #:literals (wrapped)
+      [((wrapped x ... y) ...)
+       (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
+         #'(x1 ... y ...))]
+      [((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...)
+       (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
+         #'(x* ...  ellipses1 ellipses ...))]
+      [(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
+                 #'(x* ...))]
+      [else stx]))
+  (syntax-case stx ()
+    [(_ x ...) (do-it #'(x ...))]))
+
+;; (provide unpull)
+#;
+(define-honu-syntax unpull
+  (lambda (stx ctx)
+    (define-syntax-class ellipses-class
+      (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
+    (define (do-it stx)
+      (syntax-parse stx
+                    #:literals (wrapped)
+                    [((wrapped x ... y) ...)
+                     (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
+                       #'(x1 ... y ...))]
+                    [((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...)
+                     (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
+                       #'(x* ...  ellipses1 ellipses ...))]
+                    [(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
+                               (printf "x* is ~a\n" #'(x* ...))
+                               #'(x* ...))]
+                    [else stx]))
+    (syntax-case stx ()
+      [(_ x ...) (values (do-it #'(x ...))
+                         #'())])))
+ 
+#;
+(define-syntax (test stx)
+  (syntax-case stx ()
+    [(_ x ...)
+     (begin
+       (pretty-print (syntax->datum (pull #'(x ...))))
+       (pretty-print (syntax->datum (unpull (pull #'(x ...)))))
+       #'1)]))
+
+(define-syntax (my-syntax stx)
+  (syntax-case stx ()
+    [(_ name pattern template)
+     (with-syntax ([wrap-it (pull #'template)])
+       #'(define-syntax (name stx)
+           (syntax-case stx ()
+             [pattern #'wrap-it]
+             [else (raise-syntax-error 'name (format "~a does not match pattern ~a"
+                                                     (syntax->datum stx)
+                                                     'pattern))]
+             )))]))
+
+(define-syntax (test2 stx)
+  (syntax-case stx ()
+    [(_ x ...)
+     (begin
+       (with-syntax ([pulled (pull #'(x ...))])
+         #'(unpull pulled)))]))
+
+(define-honu-syntax honu-macro
+  (lambda (stx ctx)
+    (syntax-case stx (#%parens #%braces)
+      [(_ (#%parens honu-literal ...)
+          (#%braces (#%braces name pattern ...))
+          (#%braces (#%braces template ...))
+          . rest)
+       (with-syntax ([pulled (pull #'(template ...))])
+         (values
+          #'(define-honu-syntax name
+              (lambda (stx ctx)
+                (syntax-case stx (honu-literal ...)
+                  [(name pattern ... . rrest)
+                   (with-syntax ([(out (... ...)) (unpull #'pulled)])
+                     (values
+                      #'(honu-unparsed-block
+                         #f obj 'obj #f ctx
+                         out (... ...))
+                      #'rrest))])))
+          #'rest))])))
+
+;; (my-syntax guz (_ display (#%parens x ...)) (+ x ...))
+;; (guz display (#%parens 1 2 3 4))
+
+;; (local-expand stx 'expression (list #'wrapped))
+
+#|
+(begin-for-syntax
+  (trace pull))
+(test display (#%parens x))
+(test display (#%parens x ... ...) ...)
+|#

From 71b1164034afe6265cdab53364cddf7222dba5ba Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Tue, 24 Nov 2009 21:26:05 +0000
Subject: [PATCH 002/136] propagate the argument throught the search box too

svn: r17051
---
 collects/scribble/scribble-common.js | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/collects/scribble/scribble-common.js b/collects/scribble/scribble-common.js
index 13b1dfa07a..d36d9f120f 100644
--- a/collects/scribble/scribble-common.js
+++ b/collects/scribble/scribble-common.js
@@ -90,8 +90,12 @@ function DoSearchKey(event, field, ver, top_path) {
   var val = field.value;
   if (event && event.keyCode == 13) {
     var u = GetCookie("PLT_Root."+ver, null);
+    var args = "";
     if (u == null) u = top_path; // default: go to the top path
-    location = u + "search/index.html" + "?q=" + escape(val);
+    u += "search/index.html";
+    args = SetArgInString(args, "q", val);
+    if (cur_plt_lang) args = SetArgInString(args, "lang", cur_plt_lang);
+    location = u + "?" + args;
     return false;
   }
   return true;

From 91d4240765ed77570f877045fc088ee823667960 Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Tue, 24 Nov 2009 23:14:18 +0000
Subject: [PATCH 003/136] add some examples

svn: r17052
---
 collects/scribblings/reference/exns.scrbl | 45 +++++++++++++++++++++--
 1 file changed, 41 insertions(+), 4 deletions(-)

diff --git a/collects/scribblings/reference/exns.scrbl b/collects/scribblings/reference/exns.scrbl
index 2117c1d273..9fc843868b 100644
--- a/collects/scribblings/reference/exns.scrbl
+++ b/collects/scribblings/reference/exns.scrbl
@@ -40,8 +40,20 @@ multiple returns/escapes are impossible. All exceptions raised by
 Breaks are disabled from the time the exception is raised until the
 exception handler obtains control, and the handler itself is
 @scheme[parameterize-break]ed to disable breaks initially; see
-@secref["breakhandler"] for more information on breaks.}
+@secref["breakhandler"] for more information on breaks.
 
+@examples[
+(with-handlers ([number? (lambda (n)
+                           (+ n 5))])
+  (raise 18 #t))
+(define-struct (my-exception exn:fail:user) ())
+(with-handlers ([my-exception? (lambda (e)
+                                 #f)])
+  (+ 5 (raise (make-my-exception
+                "failed"
+                (current-continuation-marks)))))
+(raise 'failed #t)
+]}
 
 @defproc*[([(error [sym symbol?]) any]
            [(error [msg string?][v any/c] ...) any]
@@ -72,7 +84,13 @@ ways:
 ]
 
 In all cases, the constructed message string is passed to
-@scheme[make-exn:fail], and the resulting exception is raised.}
+@scheme[make-exn:fail], and the resulting exception is raised.
+
+@examples[
+(error 'failed)
+(error "failed" 23 'pizza (list 1 2 3))
+(error 'failed "~a failed because ~a" 'method-a "no argument supplied")
+]}
 
 @defproc*[([(raise-user-error [sym symbol?]) any]
            [(raise-user-error [msg string?][v any/c] ...) any]
@@ -83,7 +101,13 @@ Like @scheme[error], but constructs an exception with
 default @tech{error display handler} does not show a ``stack trace'' for
 @scheme[exn:fail:user] exceptions (see @secref["contmarks"]), so
 @scheme[raise-user-error] should be used for errors that are intended
-for end users.}
+for end users.
+
+@examples[
+(raise-user-error 'failed)
+(raise-user-error "failed" 23 'pizza (list 1 2 3))
+(raise-user-error 'failed "~a failed because ~a" 'method-a "no argument supplied")
+]}
 
 
 @defproc*[([(raise-type-error [name symbol?][expected string?][v any/c]) any]
@@ -102,7 +126,20 @@ In the second form, the bad argument is indicated by an index
 arguments @scheme[v] are provided (in order). The resulting error
 message names the bad argument and also lists the other arguments. If
 @scheme[bad-pos] is not less than the number of @scheme[v]s, the
-@exnraise[exn:fail:contract].}
+@exnraise[exn:fail:contract].
+
+@examples[
+(define (feed-cow animal)
+  (if (not (eq? animal 'cow))
+    (raise-type-error 'feed-cow "cow" animal)
+    "fed the cow"))
+(feed-cow 'turkey)
+(define (feed-animals cow sheep goose cat)
+  (if (not (eq? goose 'goose))
+    (raise-type-error 'feed-animals "goose" 2 cow sheep goose cat)
+    "fed the animals"))
+(feed-animals 'cow 'sheep 'dog 'cat)
+]}
 
 @defproc[(raise-mismatch-error [name symbol?][message string?][v any/c]) any]{
 

From c5ccff770aee9eac910019fc90a0c85d10bf9def Mon Sep 17 00:00:00 2001
From: Kevin Tew <tewk@racket-lang.org>
Date: Tue, 24 Nov 2009 23:31:07 +0000
Subject: [PATCH 004/136] add scheme_init_os_thread for places mzrt threads

svn: r17053
---
 src/mzscheme/src/mzrt.c | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/mzscheme/src/mzrt.c b/src/mzscheme/src/mzrt.c
index c92b6d75ae..352d453011 100644
--- a/src/mzscheme/src/mzrt.c
+++ b/src/mzscheme/src/mzrt.c
@@ -156,6 +156,7 @@ void *mzrt_thread_stub(void *data){
   mzrt_thread_stub_data *stub_data  = (mzrt_thread_stub_data*) data;
   void * (*start_proc)(void *)        = stub_data->start_proc;
   void *start_proc_data               = stub_data->data;
+  scheme_init_os_thread();
   proc_thread_self                    = stub_data->thread;
 
   free(data);

From 096bd06dc21dc8167395b7e623eeed1fbd5d1106 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Wed, 25 Nov 2009 08:50:27 +0000
Subject: [PATCH 005/136] Welcome to a new PLT day.

svn: r17057
---
 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 05e586528c..a0c7227ffe 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "23nov2009")
+#lang scheme/base (provide stamp) (define stamp "25nov2009")

From 34925225016170e439725ffe4e4d550bc3949abb Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 25 Nov 2009 18:11:55 +0000
Subject: [PATCH 006/136] fix checking of PLTNOMZJIT

svn: r17060
---
 src/mzscheme/src/string.c | 13 ++++++-------
 1 file changed, 6 insertions(+), 7 deletions(-)

diff --git a/src/mzscheme/src/string.c b/src/mzscheme/src/string.c
index 19a0beaed5..8cd70ec7a6 100644
--- a/src/mzscheme/src/string.c
+++ b/src/mzscheme/src/string.c
@@ -2054,7 +2054,7 @@ static Scheme_Object *putenv_str_table_get(Scheme_Object *name) {
 #endif
 
 
-static Scheme_Object *sch_bool_getenv(const char* name);
+static int sch_bool_getenv(const char* name);
 
 void
 scheme_init_getenv(void)
@@ -2116,17 +2116,16 @@ static char *dos_win_getenv(const char *name) {
 }
 #endif
 
-static Scheme_Object *sch_bool_getenv(const char* name) {
-  Scheme_Object *rc;
-  rc = scheme_false;
+static int sch_bool_getenv(const char* name) {
+  int rc = 0;
 #ifdef GETENV_FUNCTION
 # ifdef DOS_FILE_SYSTEM
-  if (GetEnvironmentVariable(s, NULL, 0)) rc = scheme_true;
+  if (GetEnvironmentVariable(s, NULL, 0)) rc = 1;
 # else
-  if (getenv(name)) rc = scheme_true;
+  if (getenv(name)) rc = 1;
 # endif
 #else
-  if (putenv_str_table_get(name))  rc = scheme_true;
+  if (putenv_str_table_get(name))  rc = 1;
 #endif
   return rc;
 }

From edae542b58844a675fe4ca80378e37c103f2db9f Mon Sep 17 00:00:00 2001
From: Carl Eastlund <cce@racket-lang.org>
Date: Wed, 25 Nov 2009 20:49:29 +0000
Subject: [PATCH 007/136] unstable module for source location manipulation

svn: r17065
---
 collects/tests/unstable/srcloc.ss            | 305 ++++++++++++++++++
 collects/unstable/scribblings/srcloc.scrbl   | 123 +++++++
 collects/unstable/scribblings/unstable.scrbl |   1 +
 collects/unstable/srcloc.ss                  | 321 +++++++++++++++++++
 4 files changed, 750 insertions(+)
 create mode 100644 collects/tests/unstable/srcloc.ss
 create mode 100644 collects/unstable/scribblings/srcloc.scrbl
 create mode 100644 collects/unstable/srcloc.ss

diff --git a/collects/tests/unstable/srcloc.ss b/collects/tests/unstable/srcloc.ss
new file mode 100644
index 0000000000..299cbf07b8
--- /dev/null
+++ b/collects/tests/unstable/srcloc.ss
@@ -0,0 +1,305 @@
+
+(load-relative "../mzscheme/loadtest.ss")
+
+(Section 'srcloc)
+(require unstable/srcloc)
+(require scheme/shared)
+
+(test #t source-location? #f)
+(test #f source-location? #t)
+(test #t source-location? (list #f #f #f #f #f))
+(test #t source-location? (list 'here 1 0 1 0))
+(test #t source-location? (list #f 1 0 1 0))
+(test #f source-location? (list 'here #f 0 1 0))
+(test #f source-location? (list 'here 1 #f 1 0))
+(test #t source-location? (list 'here 1 0 #f 0))
+(test #t source-location? (list 'here 1 0 1 #f))
+(test #f source-location? (list 'here 1 -1 1 0))
+(test #f source-location? (list 'here 1 0 0 0))
+(test #f source-location? (list 'here 1 0 1 -1))
+(test #f source-location? (shared ([x (list* 'here 1 0 1 0 x)]) x))
+(test #t source-location? (vector #f #f #f #f #f))
+(test #t source-location? (vector 'here 1 0 1 0))
+(test #t source-location? (vector #f 1 0 1 0))
+(test #f source-location? (vector 'here #f 0 1 0))
+(test #f source-location? (vector 'here 1 #f 1 0))
+(test #t source-location? (vector 'here 1 0 #f 0))
+(test #t source-location? (vector 'here 1 0 1 #f))
+(test #f source-location? (vector 'here 0 0 1 0))
+(test #f source-location? (vector 'here 1 -1 1 0))
+(test #f source-location? (vector 'here 1 0 0 0))
+(test #f source-location? (vector 'here 1 0 1 -1))
+(test #t source-location? (make-srcloc #f #f #f #f #f))
+(test #t source-location? (make-srcloc 'here 1 0 1 0))
+(test #t source-location? (make-srcloc #f 1 0 1 0))
+(test #f source-location? (make-srcloc 'here #f 0 1 0))
+(test #f source-location? (make-srcloc 'here 1 #f 1 0))
+(test #t source-location? (make-srcloc 'here 1 0 #f 0))
+(test #t source-location? (make-srcloc 'here 1 0 1 #f))
+(test #t source-location? (datum->syntax #f null #f))
+(test #t source-location? (datum->syntax #f null (list 'here 1 0 1 0)))
+(test #t source-location? (datum->syntax #f null (list #f 1 0 1 0)))
+;;(test #f source-location? (datum->syntax #f null (list 'here #f 0 1 0))) ;; won't run
+;;(test #f source-location? (datum->syntax #f null (list 'here 1 #f 1 0))) ;; won't run
+(test #t source-location? (datum->syntax #f null (list 'here 1 0 #f 0)))
+(test #t source-location? (datum->syntax #f null (list 'here 1 0 1 #f)))
+
+(test #f source-location-list? #f)
+(test #t source-location-list? (list #f #f #f #f #f))
+(test #t source-location-list? (list 'here 1 0 1 0))
+(test #t source-location-list? (list #f 1 0 1 0))
+(test #f source-location-list? (list 'here #f 0 1 0))
+(test #f source-location-list? (list 'here 1 #f 1 0))
+(test #t source-location-list? (list 'here 1 0 #f 0))
+(test #t source-location-list? (list 'here 1 0 1 #f))
+(test #f source-location-list? (list 'here 0 0 1 0))
+(test #f source-location-list? (list 'here 1 -1 1 0))
+(test #f source-location-list? (list 'here 1 0 0 0))
+(test #f source-location-list? (list 'here 1 0 1 -1))
+(test #f source-location-list? (shared ([x (list* 'here 1 0 1 0 x)]) x))
+(test #f source-location-list? (vector 'here 1 0 1 0))
+(test #f source-location-list? (make-srcloc 'here 1 0 1 0))
+(test #f source-location-list? (datum->syntax #f null #f))
+(test #f source-location-list? (datum->syntax #f null (list 'here 1 0 1 0)))
+
+(test #f source-location-vector? #f)
+(test #f source-location-vector? (list 'here 1 0 1 0))
+(test #t source-location-vector? (vector #f 1 0 1 0))
+(test #f source-location-vector? (vector 'here #f 0 1 0))
+(test #f source-location-vector? (vector 'here 1 #f 1 0))
+(test #t source-location-vector? (vector 'here 1 0 #f 0))
+(test #t source-location-vector? (vector 'here 1 0 1 #f))
+(test #t source-location-vector? (vector #f #f #f #f #f))
+(test #t source-location-vector? (vector 'here 1 0 1 0))
+(test #f source-location-vector? (vector 'here 0 0 1 0))
+(test #f source-location-vector? (vector 'here 1 -1 1 0))
+(test #f source-location-vector? (vector 'here 1 0 0 0))
+(test #f source-location-vector? (vector 'here 1 0 1 -1))
+(test #f source-location-vector? (make-srcloc 'here 1 0 1 0))
+(test #f source-location-vector? (datum->syntax #f null #f))
+(test #f source-location-vector? (datum->syntax #f null (list 'here 1 0 1 0)))
+
+(test (void) check-source-location! 'test-srcloc #f)
+(err/rt-test (check-source-location! 'test-srcloc #t) exn:fail:contract?)
+(test (void) check-source-location! 'test-srcloc (list #f #f #f #f #f))
+(test (void) check-source-location! 'test-srcloc (list 'here 1 0 1 0))
+(test (void) check-source-location! 'test-srcloc (list #f 1 0 1 0))
+(err/rt-test (check-source-location! 'test-srcloc (list 'here #f 0 1 0)) exn:fail:contract?)
+(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 #f 1 0)) exn:fail:contract?)
+(test (void) check-source-location! 'test-srcloc (list 'here 1 0 #f 0))
+(test (void) check-source-location! 'test-srcloc (list 'here 1 0 1 #f))
+(err/rt-test (check-source-location! 'test-srcloc (list 'here 0 0 1 0)) exn:fail:contract?)
+(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 -1 1 0)) exn:fail:contract?)
+(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 0 0 0)) exn:fail:contract?)
+(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 0 1 -1)) exn:fail:contract?)
+(err/rt-test (check-source-location! 'test-srcloc (shared ([x (list* 'here 1 0 1 0 x)]) x)) exn:fail:contract?)
+(test (void) check-source-location! 'test-srcloc (vector #f #f #f #f #f))
+(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 1 0))
+(test (void) check-source-location! 'test-srcloc (vector #f 1 0 1 0))
+(err/rt-test (check-source-location! 'test-srcloc (vector 'here #f 0 1 0)) exn:fail:contract?)
+(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 #f 1 0)) exn:fail:contract?)
+(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 #f 0))
+(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 1 #f))
+(err/rt-test (check-source-location! 'test-srcloc (vector 'here 0 0 1 0)) exn:fail:contract?)
+(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 -1 1 0)) exn:fail:contract?)
+(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 0 0 0)) exn:fail:contract?)
+(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 0 1 -1)) exn:fail:contract?)
+(test (void) check-source-location! 'test-srcloc (make-srcloc #f #f #f #f #f))
+(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 1 0))
+(test (void) check-source-location! 'test-srcloc (make-srcloc #f 1 0 1 0))
+(err/rt-test (check-source-location! 'test-srcloc (make-srcloc 'here #f 0 1 0)) exn:fail:contract?)
+(err/rt-test (check-source-location! 'test-srcloc (make-srcloc 'here 1 #f 1 0)) exn:fail:contract?)
+(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 #f 0))
+(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 1 #f))
+(test (void) check-source-location! 'test-srcloc (datum->syntax #f null #f))
+(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 1 0)))
+(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list #f 1 0 1 0)))
+;;(err/rt-test (check-source-location! 'test-srcloc (datum->syntax #f null (list 'here #f 0 1 0))) exn:fail:contract?) ;; won't run
+;;(err/rt-test (check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 #f 1 0))) exn:fail:contract?) ;; won't run
+(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 #f 0)))
+(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 1 #f)))
+
+(test (make-srcloc #f #f #f #f #f) build-source-location)
+(test (make-srcloc #f #f #f #f #f) build-source-location #f)
+(test (make-srcloc 'here 1 0 1 0) build-source-location (make-srcloc 'here 1 0 1 0))
+(test (make-srcloc 'here 1 0 1 0) build-source-location (vector 'here 1 0 1 0))
+(test (make-srcloc 'here 1 0 1 0) build-source-location (list 'here 1 0 1 0))
+(test (make-srcloc 'here 1 0 1 0) build-source-location (datum->syntax #f null (list 'here 1 0 1 0)))
+(test (make-srcloc 'here 1 0 1 3) build-source-location (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
+(test (make-srcloc 'here 1 0 1 3) build-source-location (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
+(test (make-srcloc #f #f #f #f #f) build-source-location (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
+(err/rt-test (build-source-location (list 'bad 0 0 0 0)) exn:fail:contract?)
+
+(test (list #f #f #f #f #f) build-source-location-list)
+(test (list #f #f #f #f #f) build-source-location-list #f)
+(test (list 'here 1 0 1 0) build-source-location-list (make-srcloc 'here 1 0 1 0))
+(test (list 'here 1 0 1 0) build-source-location-list (vector 'here 1 0 1 0))
+(test (list 'here 1 0 1 0) build-source-location-list (list 'here 1 0 1 0))
+(test (list 'here 1 0 1 0) build-source-location-list (datum->syntax #f null (list 'here 1 0 1 0)))
+(test (list 'here 1 0 1 3) build-source-location-list (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
+(test (list 'here 1 0 1 3) build-source-location-list (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
+(test (list #f #f #f #f #f) build-source-location-list (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
+(err/rt-test (build-source-location-list (list 'bad 0 0 0 0)) exn:fail:contract?)
+
+(test (vector #f #f #f #f #f) build-source-location-vector)
+(test (vector #f #f #f #f #f) build-source-location-vector #f)
+(test (vector 'here 1 0 1 0) build-source-location-vector (make-srcloc 'here 1 0 1 0))
+(test (vector 'here 1 0 1 0) build-source-location-vector (vector 'here 1 0 1 0))
+(test (vector 'here 1 0 1 0) build-source-location-vector (list 'here 1 0 1 0))
+(test (vector 'here 1 0 1 0) build-source-location-vector (datum->syntax #f null (list 'here 1 0 1 0)))
+(test (vector 'here 1 0 1 3) build-source-location-vector (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
+(test (vector 'here 1 0 1 3) build-source-location-vector (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
+(test (vector #f #f #f #f #f) build-source-location-vector (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
+(err/rt-test (build-source-location-vector (list 'bad 0 0 0 0)) exn:fail:contract?)
+
+(define-syntax-rule (test-stx-srcloc (list src line col pos span) fn arg ...)
+  (begin
+    (test #t syntax? (fn arg ...))
+    (test src syntax-source (fn arg ...))
+    (test line syntax-line (fn arg ...))
+    (test col syntax-column (fn arg ...))
+    (test pos syntax-position (fn arg ...))
+    (test span syntax-span (fn arg ...))))
+
+(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax)
+(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax #f)
+(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (make-srcloc 'here 1 0 1 0))
+(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (vector 'here 1 0 1 0))
+(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (list 'here 1 0 1 0))
+(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (datum->syntax #f null (list 'here 1 0 1 0)))
+(test-stx-srcloc (list 'here 1 0 1 3) build-source-location-syntax (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
+(test-stx-srcloc (list 'here 1 0 1 3) build-source-location-syntax (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
+(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
+(err/rt-test (build-source-location-syntax (list 'bad 0 0 0 0)) exn:fail:contract?)
+
+(test #f source-location-known? #f)
+(test #t source-location-known? (list 'here 1 0 1 0))
+(test #f source-location-known? (list #f #f #f #f #f))
+(test #t source-location-known? (vector 'here 1 0 1 0))
+(test #f source-location-known? (vector #f #f #f #f #f))
+(test #t source-location-known? (make-srcloc 'here 1 0 1 0))
+(test #f source-location-known? (make-srcloc #f #f #f #f #f))
+(test #t source-location-known? (datum->syntax #f null (list 'here 1 0 1 0)))
+(test #f source-location-known? (datum->syntax #f null (list #f #f #f #f #f)))
+
+(test #f source-location-source #f)
+(test 'here source-location-source (list 'here 1 2 3 4))
+(test 'here source-location-source (vector 'here 1 2 3 4))
+(test 'here source-location-source (make-srcloc 'here 1 2 3 4))
+(test 'here source-location-source (datum->syntax #f null (list 'here 1 2 3 4)))
+
+(test #f source-location-line #f)
+(test 1 source-location-line (list 'here 1 2 3 4))
+(test 1 source-location-line (vector 'here 1 2 3 4))
+(test 1 source-location-line (make-srcloc 'here 1 2 3 4))
+(test 1 source-location-line (datum->syntax #f null (list 'here 1 2 3 4)))
+
+(test #f source-location-column #f)
+(test 2 source-location-column (list 'here 1 2 3 4))
+(test 2 source-location-column (vector 'here 1 2 3 4))
+(test 2 source-location-column (make-srcloc 'here 1 2 3 4))
+(test 2 source-location-column (datum->syntax #f null (list 'here 1 2 3 4)))
+
+(test #f source-location-position #f)
+(test 3 source-location-position (list 'here 1 2 3 4))
+(test 3 source-location-position (vector 'here 1 2 3 4))
+(test 3 source-location-position (make-srcloc 'here 1 2 3 4))
+(test 3 source-location-position (datum->syntax #f null (list 'here 1 2 3 4)))
+
+(test #f source-location-span #f)
+(test 4 source-location-span (list 'here 1 2 3 4))
+(test 4 source-location-span (vector 'here 1 2 3 4))
+(test 4 source-location-span (make-srcloc 'here 1 2 3 4))
+(test 4 source-location-span (datum->syntax #f null (list 'here 1 2 3 4)))
+
+(test #f source-location-end #f)
+(test 7 source-location-end (list 'here 1 2 3 4))
+(test #f source-location-end (list 'here 1 2 #f 4))
+(test #f source-location-end (list 'here 1 2 3 #f))
+(test 7 source-location-end (vector 'here 1 2 3 4))
+(test #f source-location-end (vector 'here 1 2 #f 4))
+(test #f source-location-end (vector 'here 1 2 3 #f))
+(test 7 source-location-end (make-srcloc 'here 1 2 3 4))
+(test #f source-location-end (make-srcloc 'here 1 2 #f 4))
+(test #f source-location-end (make-srcloc 'here 1 2 3 #f))
+(test 7 source-location-end (datum->syntax #f null (list 'here 1 2 3 4)))
+(test #f source-location-end (datum->syntax #f null (list 'here 1 2 #f 4)))
+(test #f source-location-end (datum->syntax #f null (list 'here 1 2 3 #f)))
+
+(test "" source-location->string #f)
+
+(test "" source-location->string (list #f #f #f #f #f))
+(test "here" source-location->string (list 'here #f #f #f #f))
+(test "here:1.2" source-location->string (list 'here 1 2 3 #f))
+(test "here::3" source-location->string (list 'here #f #f 3 #f))
+(test "::3-7" source-location->string (list #f #f #f 3 4))
+(test ":1.2" source-location->string (list #f 1 2 3 #f))
+(test "::3" source-location->string (list #f #f #f 3 #f))
+(test "::3-7" source-location->string (list #f #f #f 3 4))
+
+(test "" source-location->string (vector #f #f #f #f #f))
+(test "here" source-location->string (vector 'here #f #f #f #f))
+(test "here:1.2" source-location->string (vector 'here 1 2 3 #f))
+(test "here::3" source-location->string (vector 'here #f #f 3 #f))
+(test "::3-7" source-location->string (vector #f #f #f 3 4))
+(test ":1.2" source-location->string (vector #f 1 2 3 #f))
+(test "::3" source-location->string (vector #f #f #f 3 #f))
+(test "::3-7" source-location->string (vector #f #f #f 3 4))
+
+(test "" source-location->string (make-srcloc #f #f #f #f #f))
+(test "here" source-location->string (make-srcloc 'here #f #f #f #f))
+(test "here:1.2" source-location->string (make-srcloc 'here 1 2 3 #f))
+(test "here::3" source-location->string (make-srcloc 'here #f #f 3 #f))
+(test "::3-7" source-location->string (make-srcloc #f #f #f 3 4))
+(test ":1.2" source-location->string (make-srcloc #f 1 2 3 #f))
+(test "::3" source-location->string (make-srcloc #f #f #f 3 #f))
+(test "::3-7" source-location->string (make-srcloc #f #f #f 3 4))
+
+(test "" source-location->string (datum->syntax #f null (list #f #f #f #f #f)))
+(test "here" source-location->string (datum->syntax #f null (list 'here #f #f #f #f)))
+(test "here:1.2" source-location->string (datum->syntax #f null (list 'here 1 2 3 #f)))
+(test "here::3" source-location->string (datum->syntax #f null (list 'here #f #f 3 #f)))
+(test "::3-7" source-location->string (datum->syntax #f null (list #f #f #f 3 4)))
+(test ":1.2" source-location->string (datum->syntax #f null (list #f 1 2 3 #f)))
+(test "::3" source-location->string (datum->syntax #f null (list #f #f #f 3 #f)))
+(test "::3-7" source-location->string (datum->syntax #f null (list #f #f #f 3 4)))
+
+(test "" source-location->prefix #f)
+
+(test "" source-location->prefix (list #f #f #f #f #f))
+(test "here: " source-location->prefix (list 'here #f #f #f #f))
+(test "here:1.2: " source-location->prefix (list 'here 1 2 3 #f))
+(test "here::3: " source-location->prefix (list 'here #f #f 3 #f))
+(test "::3-7: " source-location->prefix (list #f #f #f 3 4))
+(test ":1.2: " source-location->prefix (list #f 1 2 3 #f))
+(test "::3: " source-location->prefix (list #f #f #f 3 #f))
+(test "::3-7: " source-location->prefix (list #f #f #f 3 4))
+
+(test "" source-location->prefix (vector #f #f #f #f #f))
+(test "here: " source-location->prefix (vector 'here #f #f #f #f))
+(test "here:1.2: " source-location->prefix (vector 'here 1 2 3 #f))
+(test "here::3: " source-location->prefix (vector 'here #f #f 3 #f))
+(test "::3-7: " source-location->prefix (vector #f #f #f 3 4))
+(test ":1.2: " source-location->prefix (vector #f 1 2 3 #f))
+(test "::3: " source-location->prefix (vector #f #f #f 3 #f))
+(test "::3-7: " source-location->prefix (vector #f #f #f 3 4))
+
+(test "" source-location->prefix (make-srcloc #f #f #f #f #f))
+(test "here: " source-location->prefix (make-srcloc 'here #f #f #f #f))
+(test "here:1.2: " source-location->prefix (make-srcloc 'here 1 2 3 #f))
+(test "here::3: " source-location->prefix (make-srcloc 'here #f #f 3 #f))
+(test "::3-7: " source-location->prefix (make-srcloc #f #f #f 3 4))
+(test ":1.2: " source-location->prefix (make-srcloc #f 1 2 3 #f))
+(test "::3: " source-location->prefix (make-srcloc #f #f #f 3 #f))
+(test "::3-7: " source-location->prefix (make-srcloc #f #f #f 3 4))
+
+(test "" source-location->prefix (datum->syntax #f null (list #f #f #f #f #f)))
+(test "here: " source-location->prefix (datum->syntax #f null (list 'here #f #f #f #f)))
+(test "here:1.2: " source-location->prefix (datum->syntax #f null (list 'here 1 2 3 #f)))
+(test "here::3: " source-location->prefix (datum->syntax #f null (list 'here #f #f 3 #f)))
+(test "::3-7: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 4)))
+(test ":1.2: " source-location->prefix (datum->syntax #f null (list #f 1 2 3 #f)))
+(test "::3: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 #f)))
+(test "::3-7: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 4)))
+
+(report-errs)
diff --git a/collects/unstable/scribblings/srcloc.scrbl b/collects/unstable/scribblings/srcloc.scrbl
new file mode 100644
index 0000000000..f4e69e78c2
--- /dev/null
+++ b/collects/unstable/scribblings/srcloc.scrbl
@@ -0,0 +1,123 @@
+#lang scribble/manual
+@(require scribble/eval "utils.ss" (for-label scheme/base unstable/srcloc))
+
+@(define evaluator (make-base-eval))
+@(evaluator '(require unstable/srcloc))
+
+@title[#:tag "srcloc"]{Source Locations}
+
+@defmodule[unstable/srcloc]
+
+@unstable[@author+email["Carl Eastlund" "cce@ccs.neu.edu"]]
+
+This module defines utilities for manipulating representations of source
+locations, including both @scheme[srcloc] structures and all the values accepted
+by @scheme[datum->syntax]'s third argument: syntax objects, lists, vectors, and
+@scheme[#f].
+
+@deftogether[(
+@defproc[(source-location? [x any/c]) boolean?]{}
+@defproc[(source-location-list? [x any/c]) boolean?]{}
+@defproc[(source-location-vector? [x any/c]) boolean?]{}
+)]{
+
+These functions recognize valid source location representations.  The first,
+@scheme[source-location?], recognizes @scheme[srcloc] structures, syntax
+objects, lists, and vectors with appropriate structure, as well as @scheme[#f].
+The latter predicates recognize only valid lists and vectors, respectively.
+
+@examples[#:eval evaluator
+(source-location? #f)
+(source-location? #'here)
+(source-location? (make-srcloc 'here 1 0 1 0))
+(source-location? (make-srcloc 'bad 1 #f 1 0))
+(source-location? (list 'here 1 0 1 0))
+(source-location? (list* 'bad 1 0 1 0 'tail))
+(source-location? (vector 'here 1 0 1 0))
+(source-location? (vector 'bad 0 0 0 0))
+]
+
+}
+
+@defproc[(check-source-location! [name symbol?] [x any/c]) void?]{
+
+This procedure checks that its input is a valid source location.  If it is, the
+procedure returns @scheme[(void)].  If it is not,
+@scheme[check-source-location!] raises a detailed error message in terms of
+@scheme[name] and the problem with @scheme[x].
+
+@examples[#:eval evaluator
+(check-source-location! 'this-example #f)
+(check-source-location! 'this-example #'here)
+(check-source-location! 'this-example (make-srcloc 'here 1 0 1 0))
+(check-source-location! 'this-example (make-srcloc 'bad 1 #f 1 0))
+(check-source-location! 'this-example (list 'here 1 0 1 0))
+(check-source-location! 'this-example (list* 'bad 1 0 1 0 'tail))
+(check-source-location! 'this-example (vector 'here 1 0 1 0))
+(check-source-location! 'this-example (vector 'bad 0 0 0 0))
+]
+
+}
+
+@deftogether[(
+@defproc[(build-source-location [loc source-location?] ...) srcloc?]{}
+@defproc[(build-source-location-list [loc source-location?] ...) source-location-list?]{}
+@defproc[(build-source-location-vector [loc source-location?] ...) source-location-vector?]{}
+@defproc[(build-source-location-syntax [loc source-location?] ...) syntax?]{}
+)]{
+
+These procedures combine multiple (zero or more) source locations, merging
+locations within the same source and reporting @scheme[#f] for locations that
+span sources.  They also convert the result to the desired representation:
+@scheme[srcloc], list, vector, or syntax object, respectively.
+
+@examples[#:eval evaluator
+(build-source-location)
+(build-source-location-list)
+(build-source-location-vector)
+(build-source-location-syntax)
+(build-source-location #f)
+(build-source-location-list #f)
+(build-source-location-vector #f)
+(build-source-location-syntax #f)
+(build-source-location (list 'here 1 2 3 4))
+(build-source-location-list (make-srcloc 'here 1 2 3 4))
+(build-source-location-vector (make-srcloc 'here 1 2 3 4))
+(build-source-location-syntax (make-srcloc 'here 1 2 3 4))
+(build-source-location (list 'here 1 2 3 4) (vector 'here 5 6 7 8))
+(build-source-location-list (make-srcloc 'here 1 2 3 4) (vector 'here 5 6 7 8))
+(build-source-location-vector (make-srcloc 'here 1 2 3 4) (vector 'here 5 6 7 8))
+(build-source-location-syntax (make-srcloc 'here 1 2 3 4) (vector 'here 5 6 7 8))
+(build-source-location (list 'here 1 2 3 4) (vector 'there 5 6 7 8))
+(build-source-location-list (make-srcloc 'here 1 2 3 4) (vector 'there 5 6 7 8))
+(build-source-location-vector (make-srcloc 'here 1 2 3 4) (vector 'there 5 6 7 8))
+(build-source-location-syntax (make-srcloc 'here 1 2 3 4) (vector 'there 5 6 7 8))
+]
+
+}
+
+@deftogether[(
+@defproc[(source-location->string [loc source-location?]) string?]{}
+@defproc[(source-location->prefix [loc source-location?]) string?]{}
+)]{
+
+These procedures convert source locations to strings for use in error messages.
+The first produces a string describing the source location; the second appends
+@scheme[": "] to the string if it is non-empty.
+
+@examples[#:eval evaluator
+(source-location->string (make-srcloc 'here 1 2 3 4))
+(source-location->string (make-srcloc 'here #f #f 3 4))
+(source-location->string (make-srcloc 'here #f #f #f #f))
+(source-location->string (make-srcloc #f 1 2 3 4))
+(source-location->string (make-srcloc #f #f #f 3 4))
+(source-location->string (make-srcloc #f #f #f #f #f))
+(source-location->prefix (make-srcloc 'here 1 2 3 4))
+(source-location->prefix (make-srcloc 'here #f #f 3 4))
+(source-location->prefix (make-srcloc 'here #f #f #f #f))
+(source-location->prefix (make-srcloc #f 1 2 3 4))
+(source-location->prefix (make-srcloc #f #f #f 3 4))
+(source-location->prefix (make-srcloc #f #f #f #f #f))
+]
+
+}
diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl
index 907a540732..b5eff58733 100644
--- a/collects/unstable/scribblings/unstable.scrbl
+++ b/collects/unstable/scribblings/unstable.scrbl
@@ -77,6 +77,7 @@ Keep documentation and tests up to date.
 @include-section["list.scrbl"]
 @include-section["net.scrbl"]
 @include-section["path.scrbl"]
+@include-section["srcloc.scrbl"]
 @include-section["string.scrbl"]
 @include-section["struct.scrbl"]
 @include-section["syntax.scrbl"]
diff --git a/collects/unstable/srcloc.ss b/collects/unstable/srcloc.ss
new file mode 100644
index 0000000000..89251f6318
--- /dev/null
+++ b/collects/unstable/srcloc.ss
@@ -0,0 +1,321 @@
+#lang scheme/base
+
+;; Unstable library by: Carl Eastlund <cce@ccs.neu.edu>
+;; intended for use in scheme/contract, so don't try to add contracts!
+
+(provide
+
+ ;; type predicates
+ source-location?
+ source-location-list?
+ source-location-vector?
+
+ ;; error checks
+ check-source-location!
+
+ ;; conversion and combination
+ build-source-location
+ build-source-location-list
+ build-source-location-vector
+ build-source-location-syntax
+
+ ;; accessors
+ source-location-known?
+ source-location-source
+ source-location-line
+ source-location-column
+ source-location-position
+ source-location-span
+ source-location-end
+
+ ;; rendering
+ source-location->string
+ source-location->prefix
+
+ )
+
+(define (source-location? x)
+  (process-source-location x good? bad? 'source-location?))
+
+(define (source-location-list? x)
+  (process-list x good? bad? 'source-location-list?))
+
+(define (source-location-vector? x)
+  (process-vector x good? bad? 'source-location-vector?))
+
+(define (check-source-location! name x)
+  (process-source-location x good! bad! name))
+
+(define (source-location-known? x)
+  (process-source-location x good-known? bad! 'source-location-known?))
+
+(define (source-location-source x)
+  (process-source-location x good-source bad! 'source-location-source))
+
+(define (source-location-line x)
+  (process-source-location x good-line bad! 'source-location-line))
+
+(define (source-location-position x)
+  (process-source-location x good-position bad! 'source-location-position))
+
+(define (source-location-column x)
+  (process-source-location x good-column bad! 'source-location-column))
+
+(define (source-location-span x)
+  (process-source-location x good-span bad! 'source-location-span))
+
+(define (source-location-end x)
+  (process-source-location x good-end bad! 'source-location-end))
+
+(define (source-location->string x)
+  (process-source-location x good-string bad! 'source-location->string))
+
+(define (source-location->prefix x)
+  (process-source-location x good-prefix bad! 'source-location->prefix))
+
+(define (build-source-location . locs)
+  (combine-source-locations locs good-srcloc bad!
+                            'build-source-location))
+
+(define (build-source-location-list . locs)
+  (combine-source-locations locs good-list bad!
+                            'build-source-location-list))
+
+(define (build-source-location-vector . locs)
+  (combine-source-locations locs good-vector bad!
+                            'build-source-location-vector))
+
+(define (build-source-location-syntax . locs)
+  (combine-source-locations locs good-syntax bad!
+                            'build-source-location-syntax))
+
+(define (good? x src line col pos span) #t)
+(define (bad? fmt . args) #f)
+
+(define (good! x src line col pos span) (void))
+(define (bad! fmt . args)
+  (raise
+   (make-exn:fail:contract
+    (apply format fmt args)
+    (current-continuation-marks))))
+
+(define (good-known? x src line col pos span)
+  (and (or src line col pos span) #t))
+
+(define (good-source x src line col pos span) src)
+(define (good-line x src line col pos span) line)
+(define (good-column x src line col pos span) col)
+(define (good-position x src line col pos span) pos)
+(define (good-span x src line col pos span) span)
+(define (good-end x src line col pos span) (and pos span (+ pos span)))
+
+(define (good-srcloc x src line col pos span)
+  (if (srcloc? x) x (make-srcloc src line col pos span)))
+
+(define (good-list x src line col pos span)
+  (if (list? x) x (list src line col pos span)))
+
+(define (good-vector x src line col pos span)
+  (if (vector? x) x (vector src line col pos span)))
+
+(define (good-syntax x src line col pos span)
+  (cond
+   [(syntax? x) x]
+   [(or (list? x) (vector? x)) (datum->syntax #f null x)]
+   [else (datum->syntax #f null (vector src line col pos span))]))
+
+(define (good-string x src line col pos span)
+  (format "~a~a"
+          (or src "")
+          (if line
+            (if col
+              (format ":~a.~a" line col)
+              (format ":~a" line))
+            (if pos
+              (if span
+                (format "::~a-~a" pos (+ pos span))
+                (format "::~a" pos))
+              ""))))
+
+(define (good-prefix x src line col pos span)
+  (let ([str (good-string x src line col pos span)])
+    (if (string=? str "") "" (string-append str ": "))))
+
+(define (combine-source-locations locs good bad name)
+
+  (define (loop loc1 src1 line1 col1 pos1 span1 locs)
+    (if (null? locs)
+      (good loc1 src1 line1 col1 pos1 span1)
+      (process-source-location
+       (car locs)
+       (lambda (loc2 src2 line2 col2 pos2 span2)
+         (combine-two
+          src1 line1 col1 pos1 span1
+          src2 line2 col2 pos2 span2
+          (lambda (loc src line col pos span)
+            (loop loc src line col pos span (cdr locs)))))
+       bad
+       name)))
+
+  (if (null? locs)
+    (process-source-location #f good bad name)
+    (process-source-location
+     (car locs)
+     (lambda (loc src line col pos span)
+       (loop loc src line col pos span (cdr locs)))
+     bad
+     name)))
+
+(define (combine-two src1 line1 col1 pos1 span1
+                     src2 line2 col2 pos2 span2
+                     good)
+  (if (and src1 src2 (equal? src1 src2))
+    (let-values
+        ([(src) src1]
+         [(line col)
+          (cond
+           [(and line1 line2)
+            (cond
+             [(< line1 line2) (values line1 col1)]
+             [(> line1 line2) (values line2 col2)]
+             [else (values line1
+                           (if (and col1 col2)
+                             (min col1 col2)
+                             (or col1 col2)))])]
+           [line1 (values line1 col1)]
+           [line2 (values line2 col2)]
+           [else (values #f #f)])]
+         [(pos span)
+          (cond
+           [(and pos1 pos2)
+            (let ([pos (min pos1 pos2)])
+              (cond
+               [(and span1 span2)
+                (let ([end (max (+ pos1 span1) (+ pos2 span2))])
+                  (values pos (- end pos)))]
+               [span1 (values pos (- (+ pos1 span1) pos))]
+               [span2 (values pos (- (+ pos2 span2) pos))]
+               [else (values pos #f)]))])])
+      (good #f src line col pos span))
+    (good #f #f #f #f #f #f)))
+
+(define (process-source-location x good bad name)
+  (cond
+   ;; #f
+   [(not x) (process-false x good bad name)]
+   ;; srcloc
+   [(srcloc? x) (process-srcloc x good bad name)]
+   ;; list
+   [(or (null? x) (pair? x)) (process-list x good bad name)]
+   ;; vector
+   [(vector? x) (process-vector x good bad name)]
+   ;; syntax
+   [(syntax? x) (process-syntax x good bad name)]
+   ;; other
+   [else
+    (bad
+     "~a: expected a source location (srcloc struct, syntax object, list, vector, or #f); got: ~e"
+     name
+     x)]))
+
+(define (process-false x good bad name)
+  (process-elements #f good bad name #f #f #f #f #f))
+
+(define (process-srcloc x good bad name)
+  (process-elements x good bad name
+                    (srcloc-source x)
+                    (srcloc-line x)
+                    (srcloc-column x)
+                    (srcloc-position x)
+                    (srcloc-span x)))
+
+(define (process-syntax x good bad name)
+  (process-elements x good bad name
+                    (syntax-source x)
+                    (syntax-line x)
+                    (syntax-column x)
+                    (syntax-position x)
+                    (syntax-span x)))
+
+(define (process-list x good bad name)
+  (cond
+   [(null? x)
+    (bad
+     "~a: expected a source location (a list of 5 elements); got an empty list: ~e"
+     name
+     x)]
+   [(list? x)
+    (let ([n (length x)])
+      (if (= n 5)
+        (apply process-elements x good bad name x)
+        (bad
+         "~a: expected a source location (a list of 5 elements); got a list of ~a elements: ~e"
+         name
+         n
+         x)))]
+   [(pair? x)
+    (bad
+     "~a: expected a source location (a list of 5 elements); got an improper list: ~e"
+     name
+     x)]
+   [else
+    (bad
+     "~a: expected a source location list; got: ~e"
+     name
+     x)]))
+
+(define (process-vector x good bad name)
+  (if (vector? x)
+    (let ([n (vector-length x)])
+      (if (= n 5)
+        (process-elements x good bad name
+                          (vector-ref x 0)
+                          (vector-ref x 1)
+                          (vector-ref x 2)
+                          (vector-ref x 3)
+                          (vector-ref x 4))
+        (bad
+         "~a: expected a source location (a vector of 5 elements); got a vector of ~a elements: ~e"
+         name
+         n
+         x)))
+    (bad
+     "~a: expected a source location vector; got: ~e"
+     name
+     x)))
+
+(define (process-elements x good bad name src line col pos span)
+  (cond
+   [(and line (not (exact-positive-integer? line)))
+    (bad
+     "~a: expected a source location with a positive line number or #f (second element); got line number ~e: ~e"
+     name
+     line
+     x)]
+   [(and col (not (exact-nonnegative-integer? col)))
+    (bad
+     "~a: expected a source location with a non-negative column number or #f (third element); got column number ~e: ~e"
+     name
+     col
+     x)]
+   [(or (and col (not line)) (and (not col) line))
+    (bad
+     "~a: expected a source location with line number and column number both numeric or both #f; got ~a and ~a respectively: ~e"
+     name
+     line
+     col
+     x)]
+   [(and pos (not (exact-positive-integer? pos)))
+    (bad
+     "~a: expected a source location with a positive position or #f (fourth element); got line number ~e: ~e"
+     name
+     pos
+     x)]
+   [(and span (not (exact-nonnegative-integer? span)))
+    (bad
+     "~a: expected a source location with a non-negative span or #f (fifth element); got column number ~e: ~e"
+     name
+     span
+     x)]
+   [else (good x src line col pos span)]))
+

From 04ae026b1b29b4064a982c0c0a82d67430550c2f Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Wed, 25 Nov 2009 23:57:42 +0000
Subject: [PATCH 008/136] typo in result of search

svn: r17066
---
 collects/scribble/scribble-common.js | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/scribble/scribble-common.js b/collects/scribble/scribble-common.js
index d36d9f120f..b56fa3df76 100644
--- a/collects/scribble/scribble-common.js
+++ b/collects/scribble/scribble-common.js
@@ -61,7 +61,7 @@ function SetArgInString(str, name, val) {
 }
 
 function GetArgFromURL(url, name) {
-  if (!url.href.search(/\?([^#]*)(?:#|$)/)) return false;
+  if (url.href.search(/\?([^#]*)(?:#|$)/) < 0) return false;
   return GetArgFromString(RegExp.$1, name);
 }
 

From faaa6c46a8faa55d03914f2592fcc75e8a40abe1 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Thu, 26 Nov 2009 08:50:37 +0000
Subject: [PATCH 009/136] Welcome to a new PLT day.

svn: r17067
---
 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 a0c7227ffe..9aab326df9 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "25nov2009")
+#lang scheme/base (provide stamp) (define stamp "26nov2009")

From 61dd4ca0b9a66e1982856cb7b8447fac9efdf23b Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 26 Nov 2009 15:07:16 +0000
Subject: [PATCH 010/136] add unsafe-f64vector-{ref,set!} and improve JIT to
 inline arithmetic ops with more than 2 arguments

svn: r17068
---
 collects/compiler/decompile.ss                |    8 +-
 collects/scribblings/guide/performance.scrbl  |    6 +-
 collects/scribblings/reference/unsafe.scrbl   |   15 +-
 .../benchmarks/shootout/mandelbrot.ss         |    2 +-
 .../mzscheme/benchmarks/shootout/nbody.ss     |   11 +-
 collects/tests/mzscheme/optimize.ss           |   62 +-
 collects/tests/mzscheme/unsafe.ss             |   16 +-
 doc/release-notes/mzscheme/HISTORY.txt        |    4 +
 src/mzscheme/src/cstartup.inc                 |   82 +-
 src/mzscheme/src/jit.c                        | 1068 ++++++++++++-----
 src/mzscheme/src/lightning/i386/fp.h          |    5 +-
 src/mzscheme/src/numarith.c                   |   12 +-
 src/mzscheme/src/number.c                     |   40 +-
 src/mzscheme/src/numcomp.c                    |   21 +-
 src/mzscheme/src/schminc.h                    |    2 +-
 src/mzscheme/src/schvers.h                    |    4 +-
 16 files changed, 958 insertions(+), 400 deletions(-)

diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss
index 8729a983b1..0ebc8b28a6 100644
--- a/collects/compiler/decompile.ss
+++ b/collects/compiler/decompile.ss
@@ -321,13 +321,15 @@
                                       list list* vector vector-immutable box))]
              [(3) (memq (car a) '(eq? = <= < >= >
                                       bitwise-bit-set? char=?
-                                      + - * / quotient remainder min max bitwise-and bitwise-ior
+                                      + - * / quotient remainder min max bitwise-and bitwise-ior bitwise-xor
                                       arithmetic-shift vector-ref string-ref bytes-ref
                                       set-mcar! set-mcdr! cons mcons
                                       list list* vector vector-immutable))]
              [(4) (memq (car a) '(vector-set! string-set! bytes-set!
-                                              list list* vector vector-immutable))]
-             [else (memq (car a) '(list list* vector vector-immutable))]))
+                                              list list* vector vector-immutable
+                                              + - * / min max bitwise-and bitwise-ior bitwise-xor))]
+             [else (memq (car a) '(list list* vector vector-immutable
+                                        + - * / min max bitwise-and bitwise-ior bitwise-xor))]))
       (cons '#%in a)
       a))
 
diff --git a/collects/scribblings/guide/performance.scrbl b/collects/scribblings/guide/performance.scrbl
index dd78b8d3a4..0a0fc5e165 100644
--- a/collects/scribblings/guide/performance.scrbl
+++ b/collects/scribblings/guide/performance.scrbl
@@ -253,9 +253,9 @@ machine's instruction to add the numbers (and check for overflow). If
 the two numbers are not fixnums, then the next check whether whether
 both are flonums; in that case, the machine's floating-point
 operations are used directly. For functions that take any number of
-arguments, such as @scheme[+], inlining is applied only for the
-two-argument case (except for @scheme[-], whose one-argument case is
-also inlined).
+arguments, such as @scheme[+], inlining works for two or more
+arguments (except for @scheme[-], whose one-argument case is also
+inlined) when the arguments are either all fixnums or all flonums.
 
 Flonums are @defterm{boxed}, which means that memory is allocated to
 hold every result of a flonum computation. Fortunately, the
diff --git a/collects/scribblings/reference/unsafe.scrbl b/collects/scribblings/reference/unsafe.scrbl
index f01ba82236..35202bb503 100644
--- a/collects/scribblings/reference/unsafe.scrbl
+++ b/collects/scribblings/reference/unsafe.scrbl
@@ -1,6 +1,10 @@
 #lang scribble/doc
 @(require "mz.ss"
-          (for-label scheme/unsafe/ops))
+          (for-label scheme/unsafe/ops
+                     (only-in scheme/foreign
+                              f64vector?
+                              f64vector-ref
+                              f64vector-set!)))
 
 @title[#:tag "unsafe"]{Unsafe Operations}
 
@@ -165,6 +169,15 @@ Unsafe versions of @scheme[bytes-length], @scheme[bytes-ref], and
 fixnum).}
 
 
+@deftogether[(
+@defproc[(unsafe-f64vector-ref [vec f64vector?][k fixnum?]) inexact-real?]
+@defproc[(unsafe-f64vector-set! [vec f64vector?][k fixnum?][n inexact-real?]) void?]
+)]{
+
+Unsafe versions of @scheme[f64vector-ref] and
+@scheme[f64vector-set!].}
+
+
 @deftogether[(
 @defproc[(unsafe-struct-ref [v any/c][k fixnum?]) any/c]
 @defproc[(unsafe-struct-set! [v any/c][k fixnum?][val any/c]) void?]
diff --git a/collects/tests/mzscheme/benchmarks/shootout/mandelbrot.ss b/collects/tests/mzscheme/benchmarks/shootout/mandelbrot.ss
index 3e8306c7b8..37b3526660 100644
--- a/collects/tests/mzscheme/benchmarks/shootout/mandelbrot.ss
+++ b/collects/tests/mzscheme/benchmarks/shootout/mandelbrot.ss
@@ -36,7 +36,7 @@
              ((> (+ zrq ziq) +limit-sqr+) 0)
              (else (loop (add1 i) 
                          (+ (- zrq ziq) cr) 
-                         (+ (* 2.0 (* zr zi)) ci)))))))))
+                         (+ (* 2.0 zr zi) ci)))))))))
 
 ;; -------------------------------
 
diff --git a/collects/tests/mzscheme/benchmarks/shootout/nbody.ss b/collects/tests/mzscheme/benchmarks/shootout/nbody.ss
index f3c3199ddd..3311cc344e 100644
--- a/collects/tests/mzscheme/benchmarks/shootout/nbody.ss
+++ b/collects/tests/mzscheme/benchmarks/shootout/nbody.ss
@@ -93,9 +93,10 @@ Correct output N = 1000 is
     (if (null? o)
       e
       (let* ([o1 (car o)]
-             [e (+ e (* (* 0.5 (body-mass o1))
-                        (+ (+ (* (body-vx o1) (body-vx o1))
-                              (* (body-vy o1) (body-vy o1)))
+             [e (+ e (* 0.5 
+                        (body-mass o1)
+                        (+ (* (body-vx o1) (body-vx o1))
+                           (* (body-vy o1) (body-vy o1))
                            (* (body-vz o1) (body-vz o1)))))])
         (let loop-i ([i (cdr o)] [e e])
           (if (null? i)
@@ -104,7 +105,7 @@ Correct output N = 1000 is
                    [dx   (- (body-x o1) (body-x i1))]
                    [dy   (- (body-y o1) (body-y i1))]
                    [dz   (- (body-z o1) (body-z i1))]
-                   [dist (sqrt (+ (+ (* dx dx) (* dy dy)) (* dz dz)))]
+                   [dist (sqrt (+ (* dx dx) (* dy dy) (* dz dz)))]
                    [e    (- e (/ (* (body-mass o1) (body-mass i1)) dist))])
               (loop-i (cdr i) e))))))))
 
@@ -126,7 +127,7 @@ Correct output N = 1000 is
                    [dx    (- o1x (body-x i1))]
                    [dy    (- o1y (body-y i1))]
                    [dz    (- o1z (body-z i1))]
-                   [dist2 (+ (+ (* dx dx) (* dy dy)) (* dz dz))]
+                   [dist2 (+ (* dx dx) (* dy dy) (* dz dz))]
                    [mag   (/ +dt+ (* dist2 (sqrt dist2)))]
                    [dxmag (* dx mag)]
                    [dymag (* dy mag)]
diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss
index f221dca2d6..19c32bfd45 100644
--- a/collects/tests/mzscheme/optimize.ss
+++ b/collects/tests/mzscheme/optimize.ss
@@ -89,17 +89,38 @@
                   (bin0 iv op +nan.0 (exact->inexact arg2))
                   (unless (eq? op 'eq?)
                     (bin0 iv op +nan.0 +nan.0))))]
-	 [tri0 (lambda (v op get-arg1 arg2 arg3 check-effect)
+	 [tri0 (lambda (v op get-arg1 arg2 arg3 check-effect #:wrap [wrap values])
 		 ;; (printf "Trying ~a ~a ~a\n" op (get-arg1) arg2 arg3);
-		 (let ([name `(,op ,get-arg1 ,arg2, arg3)])
-		   (test v name ((eval `(lambda (x) (,op x ,arg2 ,arg3))) (get-arg1)))
+		 (let ([name `(,op ,get-arg1 ,arg2, arg3)]
+                       [get-arg2 (lambda () arg2)]
+                       [get-arg3 (lambda () arg3)])
+		   (test v name ((eval `(lambda (x) ,(wrap `(,op x ,arg2 ,arg3)))) (get-arg1)))
 		   (check-effect)
-		   (test v name ((eval `(lambda (x) (,op (,get-arg1) x ,arg3))) arg2))
+		   (test v name ((eval `(lambda (x) ,(wrap `(,op (,get-arg1) x ,arg3)))) arg2))
 		   (check-effect)
-		   (test v name ((eval `(lambda (x) (,op (,get-arg1) ,arg2 x))) arg3))
+		   (test v name ((eval `(lambda (x) ,(wrap `(,op x (,get-arg2) ,arg3)))) (get-arg1)))
 		   (check-effect)
-		   (test v name ((eval `(lambda (x y z) (,op x y z))) (get-arg1) arg2 arg3))
+		   (test v name ((eval `(lambda (x) ,(wrap `(,op (,get-arg1) (,get-arg2) x)))) arg3))
+		   (check-effect)
+		   (test v name ((eval `(lambda () ,(wrap `(,op (,get-arg1) (,get-arg2) (,get-arg3)))))))
+		   (check-effect)
+		   (test v name ((eval `(lambda (x) ,(wrap `(,op (,get-arg1) ,arg2 x)))) arg3))
+		   (check-effect)
+		   (test v name ((eval `(lambda (x y) ,(wrap `(,op (,get-arg1) x y)))) arg2 arg3))
+		   (check-effect)
+		   (test v name ((eval `(lambda (x y z) ,(wrap `(,op x y z)))) (get-arg1) arg2 arg3))
 		   (check-effect)))]
+         [tri (lambda (v op get-arg1 arg2 arg3 check-effect #:wrap [wrap values])
+                (define (e->i n) (if (number? n) (exact->inexact n) n))
+                (tri0 v op get-arg1 arg2 arg3 check-effect #:wrap wrap)
+                (tri0 (e->i v) op (lambda () (exact->inexact (get-arg1))) (exact->inexact arg2) (exact->inexact arg3) check-effect
+                       #:wrap wrap)
+                (tri0 (e->i v) op get-arg1 (exact->inexact arg2) arg3 check-effect
+                       #:wrap wrap))]
+         [tri-if (lambda (v op get-arg1 arg2 arg3 check-effect)
+                   (tri v op get-arg1 arg2 arg3 check-effect)
+                   (tri (if v 'true 'false) op get-arg1 arg2 arg3 check-effect
+                        #:wrap (lambda (e) `(if ,e 'true 'false))))]
 	 [tri-exact (lambda (v op get-arg1 arg2 arg3 check-effect 3rd-all-ok?)
                       (check-error-message op (eval `(lambda (x) (,op x ,arg2 ,arg3))))
                       (check-error-message op (eval `(lambda (x) (,op (,get-arg1) x ,arg3))))
@@ -188,12 +209,18 @@
     (bin #t '< -200 100)
     (bin #f '< 100 -200)
     (bin #t '< 1 (expt 2 30))
+    (tri-if #t '< (lambda () 1) 2 3 void)
+    (tri-if #f '< (lambda () 1) 3 3 void)
+    (tri-if #f '< (lambda () 1) -1 3 void)
 
     (bin #t '<= 100 200)
     (bin #f '<= 200 100)
     (bin #t '<= 100 100)
     (bin #t '<= -200 100)
     (bin #f '<= 100 -200)
+    (tri-if #t '<= (lambda () 1) 2 3 void)
+    (tri-if #t '<= (lambda () 1) 3 3 void)
+    (tri-if #f '<= (lambda () 1) -1 3 void)
 
     (bin #f '> 100 200)
     (bin #t '> 200 100)
@@ -201,18 +228,28 @@
     (bin #f '> -200 100)
     (bin #t '> 100 -200)
     (bin #f '> 1 (expt 2 30))
+    (tri-if #t '> (lambda () 3) 2 1 void)
+    (tri-if #f '> (lambda () 3) 3 1 void)
+    (tri-if #f '> (lambda () 3) -1 1 void)
 
     (bin #f '>= 100 200)
     (bin #t '>= 200 100)
     (bin #t '>= 100 100)
     (bin #f '>= -200 100)
     (bin #t '>= 100 -200)
+    (tri-if #t '>= (lambda () 3) 2 1 void)
+    (tri-if #t '>= (lambda () 3) 3 1 void)
+    (tri-if #f '>= (lambda () 3) -1 1 void)
 
     (bin #f '= 100 200)
     (bin #f '= 200 100)
     (bin #t '= 100 100)
     (bin #f '= -200 100)
     (bin #f '= +nan.0 +nan.0)
+    (tri-if #t '= (lambda () 3) 3 3 void)
+    (tri-if #f '= (lambda () 3) 3 1 void)
+    (tri-if #f '= (lambda () 3) 1 3 void)
+    (tri-if #f '= (lambda () 1) 3 3 void)
 
     (un 3 'add1 2)
     (un -3 'add1 -4)
@@ -247,6 +284,7 @@
     (bin -3 '+ 4 -7)
     (bin (expt 2 30) '+ (expt 2 29) (expt 2 29))
     (bin (- (expt 2 31) 2) '+ (sub1 (expt 2 30)) (sub1 (expt 2 30)))
+    (tri 6 '+ (lambda () 1) 2 3 void)
 
     (bin 3 '- 7 4)
     (bin 11 '- 7 -4)
@@ -254,6 +292,7 @@
     (bin (expt 2 30) '- (expt 2 29) (- (expt 2 29)))
     (bin (- (expt 2 30)) '- (- (expt 2 29)) (expt 2 29))
     (bin (- 2 (expt 2 31)) '- (- 1 (expt 2 30)) (sub1 (expt 2 30)))
+    (tri 6 '- (lambda () 10) 3 1 void)
 
     (bin 4 '* 1 4)
     (bin 0 '* 0 4)
@@ -265,6 +304,7 @@
     (bin (expt 2 30) '* 2 (expt 2 29))
     (bin (expt 2 31) '* 2 (expt 2 30))
     (bin (- (expt 2 30)) '* 2 (- (expt 2 29)))
+    (tri 30 '* (lambda () 2) 3 5 void)
 
     (bin 0 '/ 0 4)
     (bin 1/4 '/ 1 4)
@@ -273,6 +313,7 @@
     (bin -4 '/ -16 4)
     (bin -4 '/ 16 -4)
     (bin 4 '/ -16 -4)
+    (tri 3 '/ (lambda () 30) 5 2 void)
 
     (bin-int 3 'quotient 10 3)
     (bin-int -3 'quotient 10 -3)
@@ -289,10 +330,16 @@
     (bin 3 'min 3 300)
     (bin -300 'min 3 -300)
     (bin -400 'min -400 -300)
+    (tri 5 'min (lambda () 10) 5 20 void)
+    (tri 5 'min (lambda () 5) 10 20 void)
+    (tri 5 'min (lambda () 20) 10 5 void)
 
     (bin 300 'max 3 300)
     (bin 3 'max 3 -300)
     (bin -3 'max -3 -300)
+    (tri 50 'max (lambda () 10) 50 20 void)
+    (tri 50 'max (lambda () 50) 10 20 void)
+    (tri 50 'max (lambda () 20) 10 50 void)
 
     (bin-exact 11 'bitwise-and 11 43)
     (bin-exact 0 'bitwise-and 11 32)
@@ -301,18 +348,21 @@
     (bin-exact 11 'bitwise-and 11 -1)
     (bin-exact -11 'bitwise-and -11 -1)
     (bin-exact (expt 2 50) 'bitwise-and (expt 2 50) (expt 2 50))
+    (tri-exact #x10101 'bitwise-and (lambda () #x11111) #x10111 #x110101 void #f)
 
     (bin-exact 11 'bitwise-ior 8 3)
     (bin-exact 11 'bitwise-ior 11 3)
     (bin-exact -1 'bitwise-ior 11 -1)
     (bin-exact (sub1 (expt 2 51)) 'bitwise-ior (sub1 (expt 2 50)) (expt 2 50))
     (bin-exact (add1 (expt 2 50)) 'bitwise-ior 1 (expt 2 50))
+    (tri-exact #x10101 'bitwise-ior (lambda () #x1) #x100 #x10000 void #f)
 
     (bin-exact 11 'bitwise-xor 8 3)
     (bin-exact 8 'bitwise-xor 11 3)
     (bin-exact -2 'bitwise-xor 1 -1)
     (bin-exact (sub1 (expt 2 51)) 'bitwise-xor (sub1 (expt 2 50)) (expt 2 50))
     (bin-exact (add1 (expt 2 50)) 'bitwise-xor 1 (expt 2 50))
+    (tri-exact #x10101 'bitwise-xor (lambda () #x1) #x110 #x10010 void #f)
 
     (bin-exact 4 'arithmetic-shift 2 1)
     (bin-exact 1 'arithmetic-shift 2 -1)
diff --git a/collects/tests/mzscheme/unsafe.ss b/collects/tests/mzscheme/unsafe.ss
index 71f7aac5ae..fdfd47803c 100644
--- a/collects/tests/mzscheme/unsafe.ss
+++ b/collects/tests/mzscheme/unsafe.ss
@@ -3,7 +3,8 @@
 
 (Section 'unsafe)
 
-(require '#%unsafe)
+(require scheme/unsafe/ops
+         scheme/foreign)
 
 (let ()
   (define (test-tri result proc x y z 
@@ -186,6 +187,13 @@
               #:post (lambda (x) (list x (string-ref v 2)))
               #:literal-ok? #f))
 
+  (test-bin 9.5 'unsafe-f64vector-ref (f64vector 1.0 9.5 18.7) 1)
+  (let ([v (f64vector 1.0 9.5 18.7)])
+    (test-tri (list (void) 27.4) 'unsafe-f64vector-set! v 2 27.4
+              #:pre (lambda () (f64vector-set! v 2 0.0)) 
+              #:post (lambda (x) (list x (f64vector-ref v 2)))
+              #:literal-ok? #f))
+
   (let ()
     (define-struct posn (x [y #:mutable] z))
     (test-bin 'a unsafe-struct-ref (make-posn 'a 'b 'c) 0 #:literal-ok? #f)
@@ -195,6 +203,12 @@
                 #:pre (lambda () (set-posn-y! p 0)) 
                 #:post (lambda (x) (posn-y p))
                 #:literal-ok? #f)))
+  ;; test unboxing:
+  (test-tri 5.4 '(lambda (x y z) (unsafe-fl+ x (unsafe-f64vector-ref y z))) 1.2 (f64vector 1.0 4.2 6.7) 1)
+  (test-tri 3.2 '(lambda (x y z) 
+                   (unsafe-f64vector-set! y 1 (unsafe-fl+ x z))
+                   (unsafe-f64vector-ref y 1))
+            1.2 (f64vector 1.0 4.2 6.7) 2.0)
 
   (void))
 
diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt
index 1c35a4436d..fa874ddc03 100644
--- a/doc/release-notes/mzscheme/HISTORY.txt
+++ b/doc/release-notes/mzscheme/HISTORY.txt
@@ -1,3 +1,7 @@
+Version 4.2.3.3
+Added unsafe-f64vector-ref and unsafe-f64vector-set!
+Changed JIT to inline numeric ops with more than 2 arguments
+
 Version 4.2.3, November 2009
 Changed _pointer (in scheme/foreign) to mean a pointer that does not
  refer to GCable memory; added _gcpointer
diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc
index 51a29c08c7..2173ba0593 100644
--- a/src/mzscheme/src/cstartup.inc
+++ b/src/mzscheme/src/cstartup.inc
@@ -1,43 +1,43 @@
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,50,50,0,0,0,1,0,0,3,0,12,0,
-17,0,20,0,27,0,40,0,47,0,51,0,58,0,63,0,68,0,72,0,78,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,51,50,0,0,0,1,0,0,3,0,12,0,
+25,0,29,0,34,0,41,0,44,0,49,0,56,0,63,0,67,0,72,0,78,
 0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
 177,0,179,0,193,0,4,1,33,1,44,1,55,1,65,1,101,1,134,1,167,
 1,226,1,36,2,114,2,180,2,185,2,205,2,96,3,116,3,167,3,233,3,
 118,4,4,5,56,5,79,5,158,5,0,0,105,7,0,0,29,11,11,68,104,
-101,114,101,45,115,116,120,64,99,111,110,100,62,111,114,66,108,101,116,114,101,
-99,72,112,97,114,97,109,101,116,101,114,105,122,101,66,117,110,108,101,115,115,
-63,108,101,116,66,100,101,102,105,110,101,64,119,104,101,110,64,108,101,116,42,
-63,97,110,100,65,113,117,111,116,101,29,94,2,13,68,35,37,107,101,114,110,
+101,114,101,45,115,116,120,72,112,97,114,97,109,101,116,101,114,105,122,101,63,
+97,110,100,64,108,101,116,42,66,100,101,102,105,110,101,62,111,114,64,99,111,
+110,100,66,108,101,116,114,101,99,66,117,110,108,101,115,115,63,108,101,116,64,
+119,104,101,110,65,113,117,111,116,101,29,94,2,13,68,35,37,107,101,114,110,
 101,108,11,29,94,2,13,68,35,37,112,97,114,97,109,122,11,62,105,102,65,
 98,101,103,105,110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101,
 115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109,
 98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,
 45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97,
-35,11,8,240,168,70,0,0,95,159,2,15,35,35,159,2,14,35,35,159,2,
-14,35,35,16,20,2,3,2,1,2,5,2,1,2,6,2,1,2,7,2,1,
-2,8,2,1,2,9,2,1,2,10,2,1,2,4,2,1,2,11,2,1,2,
-12,2,1,97,36,11,8,240,168,70,0,0,93,159,2,14,35,36,16,2,2,
-2,161,2,1,36,2,2,2,1,2,2,96,11,11,8,240,168,70,0,0,16,
-0,96,37,11,8,240,168,70,0,0,16,0,13,16,4,35,29,11,11,2,1,
+35,11,8,240,35,79,0,0,95,159,2,15,35,35,159,2,14,35,35,159,2,
+14,35,35,16,20,2,3,2,1,2,7,2,1,2,4,2,1,2,5,2,1,
+2,6,2,1,2,9,2,1,2,8,2,1,2,10,2,1,2,11,2,1,2,
+12,2,1,97,36,11,8,240,35,79,0,0,93,159,2,14,35,36,16,2,2,
+2,161,2,1,36,2,2,2,1,2,2,96,11,11,8,240,35,79,0,0,16,
+0,96,37,11,8,240,35,79,0,0,16,0,13,16,4,35,29,11,11,2,1,
 11,18,16,2,99,64,104,101,114,101,8,31,8,30,8,29,8,28,8,27,93,
-8,224,175,70,0,0,95,9,8,224,175,70,0,0,2,1,27,248,22,137,4,
+8,224,42,79,0,0,95,9,8,224,42,79,0,0,2,1,27,248,22,137,4,
 195,249,22,130,4,80,158,38,35,251,22,77,2,16,248,22,92,199,12,249,22,
 67,2,17,248,22,94,201,27,248,22,137,4,195,249,22,130,4,80,158,38,35,
 251,22,77,2,16,248,22,92,199,249,22,67,2,17,248,22,94,201,12,27,248,
 22,69,248,22,137,4,196,28,248,22,75,193,20,15,159,36,35,36,28,248,22,
 75,248,22,69,194,248,22,68,193,249,22,130,4,80,158,38,35,251,22,77,2,
-16,248,22,68,199,249,22,67,2,12,248,22,69,201,11,18,16,2,101,10,8,
+16,248,22,68,199,249,22,67,2,4,248,22,69,201,11,18,16,2,101,10,8,
 31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,3,1,8,101,110,118,
-49,49,51,56,56,16,4,11,11,2,19,3,1,8,101,110,118,49,49,51,56,
-57,93,8,224,176,70,0,0,95,9,8,224,176,70,0,0,2,1,27,248,22,
+49,50,57,54,48,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,54,
+49,93,8,224,43,79,0,0,95,9,8,224,43,79,0,0,2,1,27,248,22,
 69,248,22,137,4,196,28,248,22,75,193,20,15,159,36,35,36,28,248,22,75,
 248,22,69,194,248,22,68,193,249,22,130,4,80,158,38,35,250,22,77,2,20,
 248,22,77,249,22,77,248,22,77,2,21,248,22,68,201,251,22,77,2,16,2,
-21,2,21,249,22,67,2,4,248,22,69,204,18,16,2,101,11,8,31,8,30,
-8,29,8,28,8,27,16,4,11,11,2,18,3,1,8,101,110,118,49,49,51,
-57,49,16,4,11,11,2,19,3,1,8,101,110,118,49,49,51,57,50,93,8,
-224,177,70,0,0,95,9,8,224,177,70,0,0,2,1,248,22,137,4,193,27,
+21,2,21,249,22,67,2,7,248,22,69,204,18,16,2,101,11,8,31,8,30,
+8,29,8,28,8,27,16,4,11,11,2,18,3,1,8,101,110,118,49,50,57,
+54,51,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,54,52,93,8,
+224,44,79,0,0,95,9,8,224,44,79,0,0,2,1,248,22,137,4,193,27,
 248,22,137,4,194,249,22,67,248,22,77,248,22,68,196,248,22,69,195,27,248,
 22,69,248,22,137,4,23,197,1,249,22,130,4,80,158,38,35,28,248,22,53,
 248,22,131,4,248,22,68,23,198,2,27,249,22,2,32,0,89,162,8,44,36,
@@ -51,8 +51,8 @@
 249,22,2,32,0,89,162,8,44,36,46,9,222,33,42,248,22,137,4,248,22,
 68,201,248,22,69,198,27,248,22,69,248,22,137,4,196,27,248,22,137,4,248,
 22,68,195,249,22,130,4,80,158,39,35,28,248,22,75,195,250,22,78,2,20,
-9,248,22,69,199,250,22,77,2,8,248,22,77,248,22,68,199,250,22,78,2,
-11,248,22,69,201,248,22,69,202,27,248,22,69,248,22,137,4,23,197,1,27,
+9,248,22,69,199,250,22,77,2,11,248,22,77,248,22,68,199,250,22,78,2,
+5,248,22,69,201,248,22,69,202,27,248,22,69,248,22,137,4,23,197,1,27,
 249,22,1,22,81,249,22,2,22,137,4,248,22,137,4,248,22,68,199,249,22,
 130,4,80,158,39,35,251,22,77,1,22,119,105,116,104,45,99,111,110,116,105,
 110,117,97,116,105,111,110,45,109,97,114,107,2,24,250,22,78,1,23,101,120,
@@ -62,14 +62,14 @@
 22,69,203,27,248,22,69,248,22,137,4,196,28,248,22,75,193,20,15,159,36,
 35,36,249,22,130,4,80,158,38,35,27,248,22,137,4,248,22,68,197,28,249,
 22,167,8,62,61,62,248,22,131,4,248,22,92,196,250,22,77,2,20,248,22,
-77,249,22,77,21,93,2,25,248,22,68,199,250,22,78,2,3,249,22,77,2,
+77,249,22,77,21,93,2,25,248,22,68,199,250,22,78,2,8,249,22,77,2,
 25,249,22,77,248,22,101,203,2,25,248,22,69,202,251,22,77,2,16,28,249,
 22,167,8,248,22,131,4,248,22,68,200,64,101,108,115,101,10,248,22,68,197,
-250,22,78,2,20,9,248,22,69,200,249,22,67,2,3,248,22,69,202,100,8,
+250,22,78,2,20,9,248,22,69,200,249,22,67,2,8,248,22,69,202,100,8,
 31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,3,1,8,101,110,118,
-49,49,52,49,52,16,4,11,11,2,19,3,1,8,101,110,118,49,49,52,49,
-53,93,8,224,178,70,0,0,18,16,2,158,94,10,64,118,111,105,100,8,47,
-95,9,8,224,178,70,0,0,2,1,27,248,22,69,248,22,137,4,196,249,22,
+49,50,57,56,54,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,56,
+55,93,8,224,45,79,0,0,18,16,2,158,94,10,64,118,111,105,100,8,47,
+95,9,8,224,45,79,0,0,2,1,27,248,22,69,248,22,137,4,196,249,22,
 130,4,80,158,38,35,28,248,22,53,248,22,131,4,248,22,68,197,250,22,77,
 2,26,248,22,77,248,22,68,199,248,22,92,198,27,248,22,131,4,248,22,68,
 197,250,22,77,2,26,248,22,77,248,22,68,197,250,22,78,2,23,248,22,69,
@@ -81,25 +81,25 @@
 2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,35,
 45,36,11,11,11,16,0,16,0,16,0,35,35,11,11,11,11,16,0,16,0,
 16,0,35,35,16,11,16,5,2,2,20,15,159,35,35,35,35,20,102,159,35,
-16,0,16,1,33,32,10,16,5,2,7,89,162,8,44,36,52,9,223,0,33,
-33,35,20,102,159,35,16,1,2,2,16,0,11,16,5,2,10,89,162,8,44,
+16,0,16,1,33,32,10,16,5,2,10,89,162,8,44,36,52,9,223,0,33,
+33,35,20,102,159,35,16,1,2,2,16,0,11,16,5,2,12,89,162,8,44,
 36,52,9,223,0,33,34,35,20,102,159,35,16,1,2,2,16,0,11,16,5,
-2,12,89,162,8,44,36,52,9,223,0,33,35,35,20,102,159,35,16,1,2,
-2,16,1,33,36,11,16,5,2,4,89,162,8,44,36,55,9,223,0,33,37,
-35,20,102,159,35,16,1,2,2,16,1,33,38,11,16,5,2,8,89,162,8,
+2,4,89,162,8,44,36,52,9,223,0,33,35,35,20,102,159,35,16,1,2,
+2,16,1,33,36,11,16,5,2,7,89,162,8,44,36,55,9,223,0,33,37,
+35,20,102,159,35,16,1,2,2,16,1,33,38,11,16,5,2,11,89,162,8,
 44,36,57,9,223,0,33,41,35,20,102,159,35,16,1,2,2,16,0,11,16,
-5,2,5,89,162,8,44,36,52,9,223,0,33,43,35,20,102,159,35,16,1,
-2,2,16,0,11,16,5,2,11,89,162,8,44,36,53,9,223,0,33,44,35,
-20,102,159,35,16,1,2,2,16,0,11,16,5,2,6,89,162,8,44,36,54,
-9,223,0,33,45,35,20,102,159,35,16,1,2,2,16,0,11,16,5,2,3,
+5,2,9,89,162,8,44,36,52,9,223,0,33,43,35,20,102,159,35,16,1,
+2,2,16,0,11,16,5,2,5,89,162,8,44,36,53,9,223,0,33,44,35,
+20,102,159,35,16,1,2,2,16,0,11,16,5,2,3,89,162,8,44,36,54,
+9,223,0,33,45,35,20,102,159,35,16,1,2,2,16,0,11,16,5,2,8,
 89,162,8,44,36,57,9,223,0,33,46,35,20,102,159,35,16,1,2,2,16,
-1,33,48,11,16,5,2,9,89,162,8,44,36,53,9,223,0,33,49,35,20,
+1,33,48,11,16,5,2,6,89,162,8,44,36,53,9,223,0,33,49,35,20,
 102,159,35,16,1,2,2,16,0,11,16,0,94,2,14,2,15,93,2,14,9,
 9,35,0};
     EVAL_ONE_SIZED_STR((char *)expr, 2018);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,50,59,0,0,0,1,0,0,13,0,18,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,51,59,0,0,0,1,0,0,13,0,18,0,
 35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226,
 0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1,
 199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100,
@@ -341,12 +341,12 @@
     EVAL_ONE_SIZED_STR((char *)expr, 5006);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,50,8,0,0,0,1,0,0,6,0,19,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,51,8,0,0,0,1,0,0,6,0,19,0,
 34,0,48,0,62,0,76,0,118,0,0,0,38,1,0,0,65,113,117,111,116,
 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35,
-37,107,101,114,110,101,108,11,97,35,11,8,240,46,71,0,0,98,159,2,2,
+37,107,101,114,110,101,108,11,97,35,11,8,240,169,79,0,0,98,159,2,2,
 35,35,159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,
 35,159,2,6,35,35,16,0,159,35,20,102,159,35,16,1,11,16,0,83,158,
 41,20,100,144,69,35,37,98,117,105,108,116,105,110,29,11,11,11,11,11,18,
@@ -360,7 +360,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 331);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,50,56,0,0,0,1,0,0,11,0,38,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,51,56,0,0,0,1,0,0,11,0,38,0,
 44,0,57,0,66,0,73,0,95,0,117,0,143,0,155,0,173,0,193,0,205,
 0,221,0,244,0,0,1,31,1,38,1,43,1,48,1,53,1,58,1,67,1,
 72,1,76,1,84,1,93,1,101,1,204,1,249,1,13,2,42,2,73,2,129,
diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c
index 95859ffeb2..577b27be65 100644
--- a/src/mzscheme/src/jit.c
+++ b/src/mzscheme/src/jit.c
@@ -134,6 +134,7 @@ static void *call_original_binary_rev_arith_code;
 static void *call_original_unary_arith_for_branch_code;
 static void *call_original_binary_arith_for_branch_code;
 static void *call_original_binary_rev_arith_for_branch_code;
+static void *call_original_nary_arith_code;
 static void *bad_car_code, *bad_cdr_code;
 static void *bad_caar_code, *bad_cdar_code, *bad_cadr_code, *bad_cddr_code;
 static void *bad_mcar_code, *bad_mcdr_code;
@@ -1047,7 +1048,7 @@ static int mz_remap_it(mz_jit_state *jitter, int i)
   while (p && (j >= 0)) {
     c = jitter->mappings[p];
     if (c & 0x1) {
-      /* native push */
+      /* native push or skip */
       c >>= 1;
       i += c;
       if (c < 0)
@@ -2097,6 +2098,19 @@ static int is_constant_and_avoids_r1(Scheme_Object *obj)
     return (t >= _scheme_compiled_values_types_);
 }
 
+static int avoids_r1(Scheme_Object *obj)
+{
+  Scheme_Type t = SCHEME_TYPE(obj);
+
+  if (SAME_TYPE(t, scheme_toplevel_type)) {
+    return 1;
+  } else if (SAME_TYPE(t, scheme_local_type)
+             || SAME_TYPE(t, scheme_local_unbox_type)) {
+    return 1;
+  } else
+    return is_constant_and_avoids_r1(obj);
+}
+
 /*========================================================================*/
 /*                         application codegen                            */
 /*========================================================================*/
@@ -3063,7 +3077,7 @@ static void register_helper_func(mz_jit_state *jitter, void *code)
 #endif  
 }
 
-int do_generate_shared_call(mz_jit_state *jitter, void *_data)
+static int do_generate_shared_call(mz_jit_state *jitter, void *_data)
 {
   Generate_Call_Data *data = (Generate_Call_Data *)_data;
   
@@ -3351,7 +3365,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
   }
 
   if (num_rands) {
-    if (!direct_prim || (num_rands > 1)) {
+    if (!direct_prim || (num_rands > 1) || (no_call == 2)) {
       mz_rs_dec(num_rands);
       need_safety = num_rands;
       CHECK_RUNSTACK_OVERFLOW();
@@ -3425,7 +3439,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
       /* Move rator back to register: */
       mz_rs_ldxi(JIT_V1, i + offset);
     }
-    if ((!direct_prim || (num_rands > 1))
+    if ((!direct_prim || (num_rands > 1) || (no_call == 2))
 	&& (!direct_self || !is_tail || no_call || (i + 1 < num_rands))) {
       mz_rs_stxi(i + offset, JIT_R0);
     }
@@ -3571,6 +3585,7 @@ static int is_unboxable_op(Scheme_Object *obj, int flag)
   if (IS_NAMED_PRIM(obj, "unsafe-fl/")) return 1;
   if (IS_NAMED_PRIM(obj, "unsafe-flabs")) return 1;
   if (IS_NAMED_PRIM(obj, "unsafe-fx->fl")) return 1;
+  if (IS_NAMED_PRIM(obj, "unsafe-f64vector-ref")) return 1;
 
   return 0;
 }
@@ -3618,7 +3633,7 @@ static int can_unbox(Scheme_Object *obj, int fuel, int regs)
       if (!can_unbox(app->rand1, fuel - 1, regs))
         return 0;
       return can_unbox(app->rand2, fuel - 1, regs - 1);
-    }
+    }    
   case scheme_toplevel_type:
   case scheme_local_type:
   case scheme_local_unbox_type:
@@ -3740,6 +3755,7 @@ static int can_fast_double(int arith, int cmp, int two_args)
 #define jit_ldi_d_fppush(rd, is)      jit_ldi_d(rd, is)
 #define jit_ldr_d_fppush(rd, rs)      jit_ldr_d(rd, rs)
 #define jit_ldxi_d_fppush(rd, rs, is) jit_ldxi_d(rd, rs, is)
+#define jit_ldxr_d_fppush(rd, rs, is) jit_ldxr_d(rd, rs, is)
 #define jit_addr_d_fppop(rd,s1,s2)    jit_addr_d(rd,s1,s2)
 #define jit_subr_d_fppop(rd,s1,s2)    jit_subr_d(rd,s1,s2)
 #define jit_subrr_d_fppop(rd,s1,s2)   jit_subrr_d(rd,s1,s2)
@@ -3751,6 +3767,7 @@ static int can_fast_double(int arith, int cmp, int two_args)
 #define jit_sti_d_fppop(id, rs)       jit_sti_d(id, rs)
 #define jit_str_d_fppop(id, rd, rs)   jit_str_d(id, rd, rs)
 #define jit_stxi_d_fppop(id, rd, rs)  jit_stxi_d(id, rd, rs)
+#define jit_stxr_d_fppop(id, rd, rs)  jit_stxr_d(id, rd, rs)
 #define jit_bger_d_fppop(d, s1, s2)   jit_bger_d(d, s1, s2)
 #define jit_bantiger_d_fppop(d, s1, s2) jit_bantiger_d(d, s1, s2)
 #define jit_bler_d_fppop(d, s1, s2)   jit_bler_d(d, s1, s2)
@@ -3990,7 +4007,7 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
 
 static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2, 
 			  int orig_args, int arith, int cmp, int v, jit_insn **for_branch, int branch_short,
-                          int unsafe_fx, int unsafe_fl)
+                          int unsafe_fx, int unsafe_fl, GC_CAN_IGNORE jit_insn *overflow_refslow)
 /* needs de-sync */
 /* Either arith is non-zero or it's a cmp; the value of each determines the operation:
         arith = 1 -> + or add1 (if !rand2)
@@ -4013,7 +4030,12 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
         cmp = +/-1 -> >=/<=
         cmp = +/-2 -> >/< or positive/negative?
         cmp = 3 -> bitwise-bit-test?
- */
+   If rand is NULL, then we're generating part of the fast path for an
+   nary arithmatic over a binary operator; the first argument is
+   already in R0 (fixnum or min/max) or a floating-point register
+   (flonum) and the second arguement is in R1 (fixnum or min/max) or a
+   floating-point register (flonum).
+*/
 {
   GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *ref4, *refd = NULL, *refdt = NULL, *refslow;
   int skipped, simple_rand, simple_rand2, reversed = 0, has_fixnum_fast = 1;
@@ -4021,11 +4043,16 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
   LOG_IT(("inlined %s\n", ((Scheme_Primitive_Proc *)rator)->name));
 
   if (unsafe_fl
-      && can_unbox(rand, 5, JIT_FPR_NUM-2)
-      && (!rand2 || can_unbox(rand2, 5, JIT_FPR_NUM-3))) {
+      && (!rand
+          || (can_unbox(rand, 5, JIT_FPR_NUM-2)
+              && (!rand2 || can_unbox(rand2, 5, JIT_FPR_NUM-3))))) {
     /* Unsafe, unboxed floating-point ops. */
-    jitter->unbox++;
-    if (!rand2) {
+    int args_unboxed = ((arith != 9) && (arith != 10));
+    if (args_unboxed)
+      jitter->unbox++;
+    if (!rand) {
+      CHECK_LIMIT();
+    } else if (!rand2) {
       mz_runstack_skipped(jitter, 1);
       generate(rand, jitter, 0, 1, JIT_R0);
       CHECK_LIMIT();
@@ -4038,12 +4065,15 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
       CHECK_LIMIT();
       mz_runstack_unskipped(jitter, 2);
     }
-    --jitter->unbox;
-    jitter->unbox_depth -= (rand2 ? 2 : 1);
+    if (args_unboxed) {
+      --jitter->unbox;
+      jitter->unbox_depth -= (rand2 ? 2 : 1);
+    }
     if (for_branch)
       mz_rs_sync(); /* needed if arguments were unboxed */
-    generate_double_arith(jitter, arith, cmp, 0, !!rand2, 0,
-                          &refd, &refdt, branch_short, 1, 1, jitter->unbox);
+    generate_double_arith(jitter, arith, cmp, reversed, !!rand2, 0,
+                          &refd, &refdt, branch_short, 1, 
+                          args_unboxed, jitter->unbox);
     CHECK_LIMIT();
     ref3 = NULL;
     ref = NULL;
@@ -4056,261 +4086,274 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
     /* While generating a fixnum op, don't unbox! */
     jitter->unbox = 0;
 
-    if (rand2) {
-      if (SCHEME_INTP(rand2)
-          && SCHEME_INT_SMALL_ENOUGH(rand2)
-          && ((arith != 6)
-              || ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT)
-                  && (SCHEME_INT_VAL(rand2) >= -MAX_TRY_SHIFT)))
-          && ((cmp != 3)
-              || ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT)
-                  && (SCHEME_INT_VAL(rand2) >= 0)))) {
-        /* Second is constant, so use constant mode.
-           For arithmetic shift, only do this if the constant
-           is in range. */
-        v = SCHEME_INT_VAL(rand2);
-        rand2 = NULL;
-      } else if (SCHEME_INTP(rand)
-                 && SCHEME_INT_SMALL_ENOUGH(rand)
-                 && (arith != 6) && (arith != -6)
-                 && (cmp != 3)) {
-        /* First is constant; swap argument order and use constant mode. */
-        v = SCHEME_INT_VAL(rand);
-        cmp = -cmp;
-        rand = rand2;
-        rand2 = NULL;
-        reversed = 1;
-      } else if ((ok_to_move_local(rand2)
-                  || SCHEME_INTP(rand2))
-                 && !(ok_to_move_local(rand)
-                      || SCHEME_INTP(rand))) {
-        /* Second expression is side-effect-free, unlike the first; 
-           swap order and use the fast path for when the first arg is
-           side-effect free. */
-        Scheme_Object *t = rand2;
-        rand2 = rand;
-        rand = t;
-        cmp = -cmp;
-        reversed = 1;
-      }
-    }
-
-    if ((arith == -1) && (orig_args == 1) && !v) {
-      /* Unary subtract */
+    if (!rand) {
+      /* generating for an nary operation; first arg in R0, 
+         second in R1 */
       reversed = 1;
-    }
-
-    if (rand2) {
-      simple_rand = (ok_to_move_local(rand)
-                     || SCHEME_INTP(rand));
-      if (!simple_rand)
-        simple_rand2 = SAME_TYPE(SCHEME_TYPE(rand2), scheme_local_type);
-      else
-        simple_rand2 = 0;
+      cmp = -cmp;
+      refslow = overflow_refslow;
+      refd = NULL;
+      refdt = NULL;
+      ref3 = NULL;
+      ref = NULL;
+      ref4 = NULL;
     } else {
-      simple_rand = 0;
-      simple_rand2 = 0;
-    }
+      if (rand2) {
+        if (SCHEME_INTP(rand2)
+            && SCHEME_INT_SMALL_ENOUGH(rand2)
+            && ((arith != 6)
+                || ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT)
+                    && (SCHEME_INT_VAL(rand2) >= -MAX_TRY_SHIFT)))
+            && ((cmp != 3)
+                || ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT)
+                    && (SCHEME_INT_VAL(rand2) >= 0)))) {
+          /* Second is constant, so use constant mode.
+             For arithmetic shift, only do this if the constant
+             is in range. */
+          v = SCHEME_INT_VAL(rand2);
+          rand2 = NULL;
+        } else if (SCHEME_INTP(rand)
+                   && SCHEME_INT_SMALL_ENOUGH(rand)
+                   && (arith != 6) && (arith != -6)
+                   && (cmp != 3)) {
+          /* First is constant; swap argument order and use constant mode. */
+          v = SCHEME_INT_VAL(rand);
+          cmp = -cmp;
+          rand = rand2;
+          rand2 = NULL;
+          reversed = 1;
+        } else if ((ok_to_move_local(rand2)
+                    || SCHEME_INTP(rand2))
+                   && !(ok_to_move_local(rand)
+                        || SCHEME_INTP(rand))) {
+          /* Second expression is side-effect-free, unlike the first; 
+             swap order and use the fast path for when the first arg is
+             side-effect free. */
+          Scheme_Object *t = rand2;
+          rand2 = rand;
+          rand = t;
+          cmp = -cmp;
+          reversed = 1;
+        }
+      }
 
-    if (rand2 && !simple_rand && !simple_rand2)
-      skipped = orig_args - 1;    
-    else
-      skipped = orig_args;
+      if ((arith == -1) && (orig_args == 1) && !v) {
+        /* Unary subtract */
+        reversed = 1;
+      }
+      
+      if (rand2) {
+        simple_rand = (ok_to_move_local(rand)
+                       || SCHEME_INTP(rand));
+        if (!simple_rand)
+          simple_rand2 = SAME_TYPE(SCHEME_TYPE(rand2), scheme_local_type);
+        else
+          simple_rand2 = 0;
+      } else {
+        simple_rand = 0;
+        simple_rand2 = 0;
+      }
 
-    mz_runstack_skipped(jitter, skipped);
+      if (rand2 && !simple_rand && !simple_rand2)
+        skipped = orig_args - 1;    
+      else
+        skipped = orig_args;
 
-    if (rand2 && !simple_rand && !simple_rand2) {
-      mz_runstack_skipped(jitter, 1);
-      generate_non_tail(rand, jitter, 0, 1); /* sync'd later */
-      CHECK_LIMIT();
-      mz_runstack_unskipped(jitter, 1);
-      mz_rs_dec(1);
-      CHECK_RUNSTACK_OVERFLOW();
-      mz_runstack_pushed(jitter, 1);
-      mz_rs_str(JIT_R0);
-    }
-    /* not sync'd... */
+      mz_runstack_skipped(jitter, skipped);
 
-    if (simple_rand2) {
-      if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type))
-        generate(rand, jitter, 0, 0, JIT_R1); /* sync'd below */
-      else {
-        generate_non_tail(rand, jitter, 0, 1); /* sync'd below */
+      if (rand2 && !simple_rand && !simple_rand2) {
+        mz_runstack_skipped(jitter, 1);
+        generate_non_tail(rand, jitter, 0, 1); /* sync'd later */
         CHECK_LIMIT();
-        jit_movr_p(JIT_R1, JIT_R0);
+        mz_runstack_unskipped(jitter, 1);
+        mz_rs_dec(1);
+        CHECK_RUNSTACK_OVERFLOW();
+        mz_runstack_pushed(jitter, 1);
+        mz_rs_str(JIT_R0);
+      }
+      /* not sync'd... */
+
+      if (simple_rand2) {
+        if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type))
+          generate(rand, jitter, 0, 0, JIT_R1); /* sync'd below */
+        else {
+          generate_non_tail(rand, jitter, 0, 1); /* sync'd below */
+          CHECK_LIMIT();
+          jit_movr_p(JIT_R1, JIT_R0);
+        }
+        CHECK_LIMIT();
+        generate(rand2, jitter, 0, 0, JIT_R0); /* sync'd below */
+      } else {
+        generate_non_tail(rand2 ? rand2 : rand, jitter, 0, 1); /* sync'd below */
       }
       CHECK_LIMIT();
-      generate(rand2, jitter, 0, 0, JIT_R0); /* sync'd below */
-    } else {
-      generate_non_tail(rand2 ? rand2 : rand, jitter, 0, 1); /* sync'd below */
-    }
-    CHECK_LIMIT();
-    /* sync'd in three branches below */
+      /* sync'd in three branches below */
 
-    if (arith == -2) {
-      if (rand2 || (v != 1) || reversed)
-        has_fixnum_fast = 0;
-    }
+      if (arith == -2) {
+        if (rand2 || (v != 1) || reversed)
+          has_fixnum_fast = 0;
+      }
 
-    /* rand2 in R0, and rand in R1 unless it's simple */
+      /* rand2 in R0, and rand in R1 unless it's simple */
 
-    if (simple_rand || simple_rand2) {
-      int pos, va;
+      if (simple_rand || simple_rand2) {
+        int pos, va;
 
-      if (simple_rand && SCHEME_INTP(rand)) {
-        (void)jit_movi_p(JIT_R1, rand);
-        va = JIT_R0;
-      } else {
-        if (simple_rand) {
-          pos = mz_remap(SCHEME_LOCAL_POS(rand));
-          mz_rs_ldxi(JIT_R1, pos);
+        if (simple_rand && SCHEME_INTP(rand)) {
+          (void)jit_movi_p(JIT_R1, rand);
+          va = JIT_R0;
+        } else {
+          if (simple_rand) {
+            pos = mz_remap(SCHEME_LOCAL_POS(rand));
+            mz_rs_ldxi(JIT_R1, pos);
+          }
+          if (!unsafe_fx && !unsafe_fl) {
+            /* check both fixnum bits at once by ANDing into R2: */
+            jit_andr_ul(JIT_R2, JIT_R0, JIT_R1);
+            va = JIT_R2;
+          }
         }
+
         if (!unsafe_fx && !unsafe_fl) {
+          mz_rs_sync();
+
+          __START_TINY_JUMPS__(1);
+          ref2 = jit_bmsi_ul(jit_forward(), va, 0x1);
+          __END_TINY_JUMPS__(1);
+        } else {
+          ref2 = NULL;
+          if (for_branch) mz_rs_sync();
+        }
+
+        if (unsafe_fl || (!unsafe_fx && !SCHEME_INTP(rand) && can_fast_double(arith, cmp, 1))) {
+          /* Maybe they're both doubles... */
+          if (unsafe_fl) mz_rs_sync();
+          generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl, 0, 0);
+          CHECK_LIMIT();
+        }
+
+        if (!unsafe_fx && !unsafe_fl) {
+          if (!has_fixnum_fast) {
+            __START_TINY_JUMPS__(1);
+            mz_patch_branch(ref2);
+            __END_TINY_JUMPS__(1);
+          }
+
+          /* Slow path */
+          refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 0, 0);
+
+          if (has_fixnum_fast) {
+            __START_TINY_JUMPS__(1);
+            mz_patch_branch(ref2);
+            __END_TINY_JUMPS__(1);
+          }
+        } else {
+          refslow = overflow_refslow;
+          ref = NULL;
+          ref4 = NULL;
+        }
+        CHECK_LIMIT();
+      } else if (rand2) {
+        /* Move rand result back into R1 */
+        mz_rs_ldr(JIT_R1);
+        mz_rs_inc(1);
+        mz_runstack_popped(jitter, 1);
+
+        if (!unsafe_fx && !unsafe_fl) {
+          mz_rs_sync();
+
           /* check both fixnum bits at once by ANDing into R2: */
           jit_andr_ul(JIT_R2, JIT_R0, JIT_R1);
-          va = JIT_R2;
-        }
-      }
-
-      if (!unsafe_fx && !unsafe_fl) {
-        mz_rs_sync();
-
-        __START_TINY_JUMPS__(1);
-        ref2 = jit_bmsi_ul(jit_forward(), va, 0x1);
-        __END_TINY_JUMPS__(1);
-      } else {
-        ref2 = NULL;
-        if (for_branch) mz_rs_sync();
-      }
-
-      if (unsafe_fl || (!unsafe_fx && !SCHEME_INTP(rand) && can_fast_double(arith, cmp, 1))) {
-        /* Maybe they're both doubles... */
-        if (unsafe_fl) mz_rs_sync();
-        generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl, 0, 0);
-        CHECK_LIMIT();
-      }
-
-      if (!unsafe_fx && !unsafe_fl) {
-        if (!has_fixnum_fast) {
           __START_TINY_JUMPS__(1);
-          mz_patch_branch(ref2);
+          ref2 = jit_bmsi_ul(jit_forward(), JIT_R2, 0x1);
           __END_TINY_JUMPS__(1);
+          CHECK_LIMIT();
+        } else {
+          if (for_branch) mz_rs_sync();
+          ref2 = NULL;
+          CHECK_LIMIT();
         }
 
-        /* Slow path */
-        refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 0, 0);
-
-        if (has_fixnum_fast) {
-          __START_TINY_JUMPS__(1);
-          mz_patch_branch(ref2);
-          __END_TINY_JUMPS__(1);
-        }
-      } else {
-        refslow = NULL;
-        ref = NULL;
-        ref4 = NULL;
-      }
-      CHECK_LIMIT();
-    } else if (rand2) {
-      /* Move rand result back into R1 */
-      mz_rs_ldr(JIT_R1);
-      mz_rs_inc(1);
-      mz_runstack_popped(jitter, 1);
-
-      if (!unsafe_fx && !unsafe_fl) {
-        mz_rs_sync();
-
-        /* check both fixnum bits at once by ANDing into R2: */
-        jit_andr_ul(JIT_R2, JIT_R0, JIT_R1);
-        __START_TINY_JUMPS__(1);
-        ref2 = jit_bmsi_ul(jit_forward(), JIT_R2, 0x1);
-        __END_TINY_JUMPS__(1);
-        CHECK_LIMIT();
-      } else {
-        if (for_branch) mz_rs_sync();
-        ref2 = NULL;
-        CHECK_LIMIT();
-      }
-
-      if (unsafe_fl || (!unsafe_fx && can_fast_double(arith, cmp, 1))) {
-        /* Maybe they're both doubles... */
-        if (unsafe_fl) mz_rs_sync();
-        generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl, 0, 0);
-        CHECK_LIMIT();
-      }
-
-      if (!unsafe_fx && !unsafe_fl) {
-        if (!has_fixnum_fast) {
-          __START_TINY_JUMPS__(1);
-          mz_patch_branch(ref2);
-          __END_TINY_JUMPS__(1);
+        if (unsafe_fl || (!unsafe_fx && can_fast_double(arith, cmp, 1))) {
+          /* Maybe they're both doubles... */
+          if (unsafe_fl) mz_rs_sync();
+          generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl, 0, 0);
+          CHECK_LIMIT();
         }
 
-        /* Slow path */
-        refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 0, 0);
+        if (!unsafe_fx && !unsafe_fl) {
+          if (!has_fixnum_fast) {
+            __START_TINY_JUMPS__(1);
+            mz_patch_branch(ref2);
+            __END_TINY_JUMPS__(1);
+          }
+
+          /* Slow path */
+          refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 0, 0);
       
-        if (has_fixnum_fast) {
-          /* Fixnum branch: */
-          __START_TINY_JUMPS__(1);
-          mz_patch_branch(ref2);
-          __END_TINY_JUMPS__(1);
-        }
-        CHECK_LIMIT();
-      } else {
-        refslow = NULL;
-        ref = NULL;
-        ref4 = NULL;
-      }
-    } else {
-      /* Only one argument: */
-      if (!unsafe_fx && !unsafe_fl) {
-        mz_rs_sync();
-        __START_TINY_JUMPS__(1);
-        ref2 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
-        __END_TINY_JUMPS__(1);
-      } else {
-        if (for_branch) mz_rs_sync();
-        ref2 = NULL;
-      }
-
-      if (unsafe_fl
-          || ((orig_args != 2) /* <- heuristic: we could generate code when an exact argument is
-                                  given, but the extra FP code is probably not worthwhile. */
-              && !unsafe_fx
-              && can_fast_double(arith, cmp, 0)
-              /* watch out: divide by 0 is special: */
-              && ((arith != -2) || v || reversed))) {
-        /* Maybe it's a double... */
-        generate_double_arith(jitter, arith, cmp, reversed, 0, v, &refd, &refdt, branch_short, unsafe_fl, 0, 0);
-        CHECK_LIMIT();
-      }
-
-      if (!unsafe_fx && !unsafe_fl) {
-        if (!has_fixnum_fast) {
-          __START_TINY_JUMPS__(1);
-          mz_patch_branch(ref2);
-          __END_TINY_JUMPS__(1);
-        }
-
-        /* Slow path */
-        refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 1, v);
-
-        if (has_fixnum_fast) {
-          __START_TINY_JUMPS__(1);
-          mz_patch_branch(ref2);
-          __END_TINY_JUMPS__(1);
+          if (has_fixnum_fast) {
+            /* Fixnum branch: */
+            __START_TINY_JUMPS__(1);
+            mz_patch_branch(ref2);
+            __END_TINY_JUMPS__(1);
+          }
+          CHECK_LIMIT();
+        } else {
+          refslow = overflow_refslow;
+          ref = NULL;
+          ref4 = NULL;
         }
       } else {
-        refslow = NULL;
-        ref = NULL;
-        ref4 = NULL;
+        /* Only one argument: */
+        if (!unsafe_fx && !unsafe_fl) {
+          mz_rs_sync();
+          __START_TINY_JUMPS__(1);
+          ref2 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
+          __END_TINY_JUMPS__(1);
+        } else {
+          if (for_branch) mz_rs_sync();
+          ref2 = NULL;
+        }
+
+        if (unsafe_fl
+            || ((orig_args != 2) /* <- heuristic: we could generate code when an exact argument is
+                                    given, but the extra FP code is probably not worthwhile. */
+                && !unsafe_fx
+                && can_fast_double(arith, cmp, 0)
+                /* watch out: divide by 0 is special: */
+                && ((arith != -2) || v || reversed))) {
+          /* Maybe it's a double... */
+          generate_double_arith(jitter, arith, cmp, reversed, 0, v, &refd, &refdt, branch_short, unsafe_fl, 0, 0);
+          CHECK_LIMIT();
+        }
+
+        if (!unsafe_fx && !unsafe_fl) {
+          if (!has_fixnum_fast) {
+            __START_TINY_JUMPS__(1);
+            mz_patch_branch(ref2);
+            __END_TINY_JUMPS__(1);
+          }
+
+          /* Slow path */
+          refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 1, v);
+
+          if (has_fixnum_fast) {
+            __START_TINY_JUMPS__(1);
+            mz_patch_branch(ref2);
+            __END_TINY_JUMPS__(1);
+          }
+        } else {
+          refslow = overflow_refslow;
+          ref = NULL;
+          ref4 = NULL;
+        }
       }
+
+      CHECK_LIMIT();
+
+      mz_runstack_unskipped(jitter, skipped);
     }
 
-    CHECK_LIMIT();
-
-    mz_runstack_unskipped(jitter, skipped);
-
     __START_SHORT_JUMPS__(branch_short);
 
     if (!unsafe_fl) {
@@ -4325,7 +4368,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
           /* First arg is in JIT_R1, second is in JIT_R0 */
           if (arith == 1) {
             jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
-            if (unsafe_fx)
+            if (unsafe_fx && !overflow_refslow)
               jit_addr_l(JIT_R2, JIT_R2, JIT_R0);
             else
               (void)jit_boaddr_l(refslow, JIT_R2, JIT_R0);
@@ -4333,13 +4376,13 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
           } else if (arith == -1) {
             if (reversed) {
               jit_movr_p(JIT_R2, JIT_R0);
-              if (unsafe_fx)
+              if (unsafe_fx && !overflow_refslow)
                 jit_subr_l(JIT_R2, JIT_R2, JIT_R1);
               else
                 (void)jit_bosubr_l(refslow, JIT_R2, JIT_R1);
             } else {
               jit_movr_p(JIT_R2, JIT_R1);
-              if (unsafe_fx)
+              if (unsafe_fx && !overflow_refslow)
                 (void)jit_subr_l(JIT_R2, JIT_R2, JIT_R0);
               else
                 (void)jit_bosubr_l(refslow, JIT_R2, JIT_R0);
@@ -4348,7 +4391,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
           } else if (arith == 2) {
             jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
             jit_rshi_l(JIT_V1, JIT_R0, 0x1);
-            if (unsafe_fx)
+            if (unsafe_fx && !overflow_refslow)
               jit_mulr_l(JIT_V1, JIT_V1, JIT_R2);
             else
               (void)jit_bomulr_l(refslow, JIT_V1, JIT_R2);
@@ -4363,14 +4406,14 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
             jit_rshi_l(JIT_V1, JIT_R0, 0x1);
             jit_rshi_l(JIT_R2, JIT_R1, 0x1);
             if (reversed) {
-              if (!unsafe_fx)
+              if (!unsafe_fx || overflow_refslow)
                 (void)jit_beqi_l(refslow, JIT_R2, 0);
               if (arith == -3)
                 jit_divr_l(JIT_R0, JIT_V1, JIT_R2);
               else
                 jit_modr_l(JIT_R0, JIT_V1, JIT_R2);
             } else {
-              if (!unsafe_fx)
+              if (!unsafe_fx || overflow_refslow)
                 (void)jit_beqi_l(refslow, JIT_V1, 0);
               if (arith == -3)
                 jit_divr_l(JIT_R0, JIT_R2, JIT_V1);
@@ -4397,14 +4440,14 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
             int v2 = (reversed ? JIT_R1 : JIT_R0);
             jit_insn *refi, *refc;
 
-            if (!unsafe_fx)
+            if (!unsafe_fx || overflow_refslow)
               refi = jit_bgei_l(jit_forward(), v2, (long)scheme_make_integer(0));
             else
               refi = NULL;
 
-            if (!unsafe_fx || (arith == -6)) {
+            if (!unsafe_fx || overflow_refslow || (arith == -6)) {
               /* Right shift */
-              if (!unsafe_fx) {
+              if (!unsafe_fx || overflow_refslow) {
                 /* check for a small enough shift */
                 (void)jit_blti_l(refslow, v2, scheme_make_integer(-MAX_TRY_SHIFT));
                 jit_notr_l(JIT_V1, v2);
@@ -4412,7 +4455,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
               } else {
                 jit_rshi_l(JIT_V1, v2, 0x1);
               }
-              if (!unsafe_fx)
+              if (!unsafe_fx || overflow_refslow)
                 jit_addi_l(JIT_V1, JIT_V1, 0x1);
               CHECK_LIMIT();
 #ifdef MZ_USE_JIT_I386
@@ -4423,7 +4466,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
               jit_rshr_l(JIT_R2, v1, JIT_V1);
 #endif
               jit_ori_l(JIT_R0, JIT_R2, 0x1);
-              if (!unsafe_fx)
+              if (!unsafe_fx || overflow_refslow)
                 refc = jit_jmpi(jit_forward());
               else
                 refc = NULL;
@@ -4432,10 +4475,10 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
               refc = NULL;
 
             /* Left shift */
-            if (!unsafe_fx || (arith == 6)) {
+            if (!unsafe_fx || overflow_refslow || (arith == 6)) {
               if (refi)
                 mz_patch_branch(refi);
-              if (!unsafe_fx)
+              if (!unsafe_fx || overflow_refslow)
                 (void)jit_bgti_l(refslow, v2, (long)scheme_make_integer(MAX_TRY_SHIFT));
               jit_rshi_l(JIT_V1, v2, 0x1);
               jit_andi_l(v1, v1, (~0x1));
@@ -4449,8 +4492,8 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
               CHECK_LIMIT();
               /* If shifting back right produces a different result, that's overflow... */
               jit_rshr_l(JIT_V1, JIT_R2, JIT_V1);
-              /* !! In case we go refslow, it nseed to add back tag to v1 !! */
-              if (!unsafe_fx)
+              /* !! In case we go refslow, it needs to add back tag to v1 !! */
+              if (!unsafe_fx || overflow_refslow)
                 (void)jit_bner_p(refslow, JIT_V1, v1);
               /* No overflow. */
               jit_ori_l(JIT_R0, JIT_R2, 0x1);
@@ -4479,7 +4522,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
           /* Non-constant arg is in JIT_R0 */
           if (arith == 1) {
             jit_movr_p(JIT_R2, JIT_R0);
-            if (unsafe_fx)
+            if (unsafe_fx && !overflow_refslow)
               jit_addi_l(JIT_R2, JIT_R2, v << 1);
             else
               (void)jit_boaddi_l(refslow, JIT_R2, v << 1);
@@ -4487,14 +4530,14 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
           } else if (arith == -1) {
             if (reversed) {
               (void)jit_movi_p(JIT_R2, scheme_make_integer(v));
-              if (unsafe_fx)
+              if (unsafe_fx && !overflow_refslow)
                 jit_subr_l(JIT_R2, JIT_R2, JIT_R0);
               else
                 (void)jit_bosubr_l(refslow, JIT_R2, JIT_R0);
               jit_addi_ul(JIT_R0, JIT_R2, 0x1);
             } else {
               jit_movr_p(JIT_R2, JIT_R0);
-              if (unsafe_fx)
+              if (unsafe_fx && !overflow_refslow)
                 jit_subi_l(JIT_R2, JIT_R2, v << 1);
               else
                 (void)jit_bosubi_l(refslow, JIT_R2, v << 1);
@@ -4509,7 +4552,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
               (void)jit_movi_p(JIT_R1, scheme_make_integer(v));
               jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
               jit_rshi_l(JIT_V1, JIT_R0, 0x1);
-              if (unsafe_fx)
+              if (unsafe_fx && !overflow_refslow)
                 jit_mulr_l(JIT_V1, JIT_V1, JIT_R2);
               else
                 (void)jit_bomulr_l(refslow, JIT_V1, JIT_R2);
@@ -4549,7 +4592,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
               } else {
                 jit_andi_l(JIT_R0, JIT_R0, (~0x1));
                 jit_lshi_l(JIT_R2, JIT_R0, v);
-                if (!unsafe_fx) {
+                if (!unsafe_fx && !overflow_refslow) {
                   /* If shifting back right produces a different result, that's overflow... */
                   jit_rshi_l(JIT_V1, JIT_R2, v);
                   /* !! In case we go refslow, it nseed to add back tag to JIT_R0 !! */
@@ -4584,7 +4627,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
               refc = jit_bgei_l(jit_forward(), JIT_R0, (long)scheme_make_integer(0));
               __END_INNER_TINY__(branch_short);
               /* watch out for most negative fixnum! */
-              if (!unsafe_fx)
+              if (!unsafe_fx || overflow_refslow)
                 (void)jit_beqi_p(refslow, JIT_R0, (void *)(((long)1 << ((8 * JIT_WORD_SIZE) - 1)) | 0x1));
               (void)jit_movi_p(JIT_R1, scheme_make_integer(0));
               jit_subr_l(JIT_R0, JIT_R1, JIT_R0);
@@ -4624,7 +4667,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
         switch (cmp) {
         case -3:
           if (rand2) {
-            if (!unsafe_fx) {
+            if (!unsafe_fx || overflow_refslow) {
               (void)jit_blti_l(refslow, JIT_R1, 0);
               (void)jit_bgti_l(refslow, JIT_R1, (long)scheme_make_integer(MAX_TRY_SHIFT));
             }
@@ -4677,7 +4720,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
         default:
         case 3:
           if (rand2) {
-            if (!unsafe_fx) {
+            if (!unsafe_fx || overflow_refslow) {
               (void)jit_blti_l(refslow, JIT_R0, 0);
               (void)jit_bgti_l(refslow, JIT_R0, (long)scheme_make_integer(MAX_TRY_SHIFT));
             }
@@ -4728,6 +4771,263 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
   return 1;  
 }
 
+#define MAX_NON_SIMPLE_ARGS 5
+
+static int extract_nary_arg(int reg, int n, mz_jit_state *jitter, Scheme_App_Rec *app, Scheme_Object **alt_args)
+{
+  if (!alt_args) {
+    jit_ldxi_p(reg, JIT_RUNSTACK, WORDS_TO_BYTES(n));
+    if (jitter->unbox)
+      generate_unboxing(jitter);
+  } else if (is_constant_and_avoids_r1(app->args[n+1])) {
+    generate(app->args[n+1], jitter, 0, 0, reg);
+  } else {
+    int i, j = 0;
+    for (i = 0; i < n; i++) {
+      if (!is_constant_and_avoids_r1(app->args[i+1]))
+        j++;
+    }
+    jit_ldxi_p(reg, JIT_RUNSTACK, WORDS_TO_BYTES(j));
+    if (jitter->unbox)
+      generate_unboxing(jitter);
+  }
+  CHECK_LIMIT();
+  return 1;
+}
+
+static void patch_nary_branches(mz_jit_state *jitter, jit_insn **refs, GC_CAN_IGNORE jit_insn *reffalse)
+{
+  if (refs[0]) {
+    mz_patch_branch_at(refs[0], reffalse);
+  }
+  if (refs[1]) {
+    mz_patch_branch_at(refs[1], reffalse);
+  }
+  if (refs[2]) {
+    jit_patch_movi(refs[2], reffalse);
+  }
+}
+
+static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
+                               int arith, int cmp, jit_insn **for_branch, int branch_short)
+{
+  int c, i, non_simple_c = 0, stack_c, use_fl = 1, use_fx = 1, trigger_arg = 0;
+  Scheme_Object *non_simples[1+MAX_NON_SIMPLE_ARGS], **alt_args, *v;
+  GC_CAN_IGNORE jit_insn *refslow, *reffx, *refdone;
+  GC_CAN_IGNORE jit_insn *refs[3], *reffalse = NULL, *refdone3 = NULL;
+#ifdef INLINE_FP_OPS
+  int args_unboxed;
+  GC_CAN_IGNORE jit_insn *reffl, *refdone2;
+#endif
+
+  if (arith == -2) {
+    /* can't inline fixnum '/' */
+    use_fx = 0;
+  } else if ((arith == 3)
+             || (arith == 4)
+             || (arith == 5)) {
+    /* bitwise operators are fixnum, only */
+    use_fl = 0;
+  }
+
+  c = app->num_args;
+  for (i = 0; i < c; i++) {
+    v = app->args[i+1];
+    if (!is_constant_and_avoids_r1(v)) {
+      if (non_simple_c < MAX_NON_SIMPLE_ARGS)
+        non_simples[1+non_simple_c] = v;
+      non_simple_c++;
+    }
+    if (SCHEME_INTP(v)) {
+      use_fl = 0;
+      if (trigger_arg == i)
+        trigger_arg++;
+    } else if (SCHEME_FLOATP(v)) {
+      use_fx = 0;
+      if (trigger_arg == i)
+        trigger_arg++;
+    }
+  }
+  if ((non_simple_c <= MAX_NON_SIMPLE_ARGS) && (non_simple_c < c)) {
+    stack_c = non_simple_c;
+    alt_args = non_simples;
+    non_simples[0] = app->args[0];
+    mz_runstack_skipped(jitter, c - stack_c);
+  } else {
+    stack_c = c;
+    alt_args = NULL;
+  }
+
+  if (stack_c)
+    generate_app(app, alt_args, stack_c, jitter, 0, 0, 2);
+  CHECK_LIMIT();
+  mz_rs_sync();
+
+  __START_SHORT_JUMPS__(c < 100);
+
+  if (trigger_arg > c) {
+    /* we don't expect this to happen, since constant-folding would
+       have collapsed it */
+    trigger_arg = 0;
+  }
+
+  extract_nary_arg(JIT_R0, trigger_arg, jitter, app, alt_args);
+  CHECK_LIMIT();
+  /* trigger argument a fixnum? */
+  reffx = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
+
+#ifdef INLINE_FP_OPS
+  if (use_fl) {
+    /* First argument a flonum? */
+    jit_ldxi_s(JIT_R0, JIT_R0, &((Scheme_Object *)0x0)->type);
+    reffl = jit_beqi_p(jit_forward(), JIT_R0, scheme_double_type);
+    CHECK_LIMIT();
+  } else {
+    reffl = NULL;
+  }
+#endif
+  
+  if (!use_fx) {
+    mz_patch_branch(reffx);
+  }
+
+  refslow = _jit.x.pc;
+  /* slow path */
+  if (alt_args) {
+    /* get all args on runstack */
+    int delta = stack_c - c;
+    for (i = 0; i < c; i++) {
+      if (delta) {
+        extract_nary_arg(JIT_R0, i, jitter, app, alt_args);
+        CHECK_LIMIT();
+        jit_stxi_p(WORDS_TO_BYTES(i+delta), JIT_RUNSTACK, JIT_R0);
+      } else
+        break;
+    }
+    jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c - stack_c));
+  }
+  (void)jit_movi_p(JIT_V1, ((Scheme_Primitive_Proc *)app->args[0])->prim_val);
+  (void)jit_movi_i(JIT_R1, c);
+  (void)jit_calli(call_original_nary_arith_code);
+  if (alt_args) {
+    jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c - stack_c));
+  }
+  refdone = jit_jmpi(jit_forward());
+  if (!arith) {
+    reffalse = _jit.x.pc;
+    jit_movi_p(JIT_R0, &scheme_false);
+    refdone3 = jit_jmpi(jit_forward());
+  } else {
+    reffalse = NULL;
+  }
+
+#ifdef INLINE_FP_OPS
+  if (use_fl) {
+    /* Flonum branch: */
+    mz_patch_branch(reffl);
+    for (i = 0; i < c; i++) {
+      if (i != trigger_arg) {
+        v = app->args[i+1];
+        if (!SCHEME_FLOATP(v)) {
+          extract_nary_arg(JIT_R0, i, jitter, app, alt_args);
+          (void)jit_bmsi_ul(refslow, JIT_R0, 0x1);
+          jit_ldxi_s(JIT_R0, JIT_R0, &((Scheme_Object *)0x0)->type);
+          (void)jit_bnei_p(refslow, JIT_R0, scheme_double_type);
+          CHECK_LIMIT();
+        }
+      }
+    }
+    /* All flonums, so inline fast flonum combination */
+    args_unboxed = ((arith != 9) && (arith != 10)); /* no unboxing for min & max */
+    if (args_unboxed)
+      jitter->unbox++;
+    extract_nary_arg(JIT_R0, 0, jitter, app, alt_args);
+    CHECK_LIMIT();
+    for (i = 1; i < c; i++) {
+      if (!arith && (i > 1))
+        extract_nary_arg(JIT_R0, i - 1, jitter, app, alt_args);
+      extract_nary_arg((args_unboxed ? JIT_R0 : JIT_R1), i, jitter, app, alt_args);
+      if ((i == c - 1) && args_unboxed) --jitter->unbox; /* box last result */
+      if (!arith) memset(refs, 0, sizeof(refs));
+      __END_SHORT_JUMPS__(c < 100);
+      generate_arith(jitter, NULL, NULL, scheme_void, 2, arith, cmp, 0,
+                     !arith ? refs : NULL, c < 100, 0, 1, NULL);
+      __START_SHORT_JUMPS__(c < 100);
+      if (!arith) patch_nary_branches(jitter, refs, reffalse);
+      CHECK_LIMIT();
+    }
+    if (use_fx) {
+      refdone2 = jit_jmpi(jit_forward());
+    } else {
+      refdone2 = NULL;
+    }
+  } else {
+    refdone2 = NULL;
+  }
+#endif
+
+  if (use_fx) {
+    /* Fixnum branch */
+    mz_patch_branch(reffx);
+    for (i = 0; i < c; i++) {
+      if (i != trigger_arg) {
+        v = app->args[i+1];
+        if (!SCHEME_INTP(v)) {
+          extract_nary_arg(JIT_R0, i, jitter, app, alt_args);
+          CHECK_LIMIT();
+          (void)jit_bmci_ul(refslow, JIT_R0, 0x1);
+          CHECK_LIMIT();
+        }
+      }
+    }
+    /* All fixnums, so inline fast fixnum combination;
+       on overflow, bail out to refslow. */
+    extract_nary_arg(JIT_R0, 0, jitter, app, alt_args);
+    for (i = 1; i < c; i++) {
+      if (!arith && (i > 1))
+        extract_nary_arg(JIT_R0, i - 1, jitter, app, alt_args);
+      extract_nary_arg(JIT_R1, i, jitter, app, alt_args);
+      CHECK_LIMIT();
+      if (!arith) memset(refs, 0, sizeof(refs));
+      __END_SHORT_JUMPS__(c < 100);
+      generate_arith(jitter, NULL, NULL, scheme_void, 2, arith, cmp, 0,
+                     !arith ? refs : NULL, c < 100, 1, 0, refslow);
+      __START_SHORT_JUMPS__(c < 100);
+      if (!arith) patch_nary_branches(jitter, refs, reffalse);
+      CHECK_LIMIT();
+    }
+  }
+
+#ifdef INLINE_FP_OPS
+  if (use_fl && use_fx) {
+    mz_patch_ucbranch(refdone2);
+  }
+#endif
+  if (!arith) {
+    jit_movi_p(JIT_R0, scheme_true);
+  }
+  mz_patch_ucbranch(refdone);
+  if (refdone3)
+    mz_patch_ucbranch(refdone3);
+
+  __END_SHORT_JUMPS__(c < 100);
+
+  if (stack_c) {
+    mz_rs_inc(stack_c); /* no sync */
+    mz_runstack_popped(jitter, stack_c);
+  }
+  if (c > stack_c)
+    mz_runstack_unskipped(jitter, c - stack_c);
+
+  if (!arith && for_branch) {
+    __START_SHORT_JUMPS__(branch_short);
+    for_branch[0] = jit_beqi_p(jit_forward(), JIT_R0, &scheme_false);
+    __END_SHORT_JUMPS__(branch_short);
+  }
+
+  return 1;
+}
+
 static int generate_inlined_constant_test(mz_jit_state *jitter, Scheme_App2_Rec *app,
 					  Scheme_Object *cnst, Scheme_Object *cnst2, 
 					  jit_insn **for_branch, int branch_short, int need_sync)
@@ -4978,13 +5278,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
     generate_inlined_constant_test(jitter, app, scheme_eof, NULL, for_branch, branch_short, need_sync);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "zero?")) {
-    generate_arith(jitter, rator, app->rand, NULL, 1, 0, 0, 0, for_branch, branch_short, 0, 0);
+    generate_arith(jitter, rator, app->rand, NULL, 1, 0, 0, 0, for_branch, branch_short, 0, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "negative?")) {
-    generate_arith(jitter, rator, app->rand, NULL, 1, 0, -2, 0, for_branch, branch_short, 0, 0);
+    generate_arith(jitter, rator, app->rand, NULL, 1, 0, -2, 0, for_branch, branch_short, 0, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "positive?")) {
-    generate_arith(jitter, rator, app->rand, NULL, 1, 0, 2, 0, for_branch, branch_short, 0, 0);
+    generate_arith(jitter, rator, app->rand, NULL, 1, 0, 2, 0, for_branch, branch_short, 0, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "exact-nonnegative-integer?")
              || IS_NAMED_PRIM(rator, "exact-positive-integer?")) {
@@ -5303,34 +5603,34 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
       
       return 1;
     } else if (IS_NAMED_PRIM(rator, "add1")) {
-      generate_arith(jitter, rator, app->rand, NULL, 1, 1, 0, 1, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand, NULL, 1, 1, 0, 1, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "sub1")) {
-      generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 1, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 1, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "-")) {
-      generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "abs")) {
-      generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fxabs")) {
-      generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-flabs")) {
-      generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 0, 1);
+      generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 0, 1, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "exact->inexact")) {
-      generate_arith(jitter, rator, app->rand, NULL, 1, 12, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand, NULL, 1, 12, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fx->fl")) {
-      generate_arith(jitter, rator, app->rand, NULL, 1, 12, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand, NULL, 1, 12, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "bitwise-not")) {
-      generate_arith(jitter, rator, app->rand, NULL, 1, 7, 0, 9, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand, NULL, 1, 7, 0, 9, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fxnot")) {
-      generate_arith(jitter, rator, app->rand, NULL, 1, 7, 0, 9, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand, NULL, 1, 7, 0, 9, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "vector-immutable")
                || IS_NAMED_PRIM(rator, "vector")) {
@@ -5712,134 +6012,134 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
     
     return 1;
   } else if (IS_NAMED_PRIM(rator, "=")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 0, 0);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 0, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "unsafe-fx=")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 1, 0);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 1, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "unsafe-fl=")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 0, 1);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 0, 1, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "<=")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 0, 0);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 0, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "unsafe-fx<=")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 1, 0);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 1, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "unsafe-fl<=")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 0, 1);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 0, 1, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "<")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 0, 0);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 0, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "unsafe-fx<")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 1, 0);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 1, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "unsafe-fl<")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 0, 1);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 0, 1, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, ">=")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 0, 0);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 0, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "unsafe-fx>=")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 1, 0);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 1, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "unsafe-fl>=")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 0, 1);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 0, 1, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, ">")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 0, 0);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 0, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "unsafe-fx>")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 1, 0);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 1, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "unsafe-fl>")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 0, 1);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 0, 1, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "bitwise-bit-set?")) {
-    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 3, 0, for_branch, branch_short, 0, 0);
+    generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 3, 0, for_branch, branch_short, 0, 0, NULL);
     return 1;
   } else if (IS_NAMED_PRIM(rator, "char=?")) {
     generate_binary_char(jitter, app, for_branch, branch_short);
     return 1;
   } else if (!for_branch) {
     if (IS_NAMED_PRIM(rator, "+")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fx+")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fl+")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 0, 1);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 0, 1, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "-")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fx-")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fl-")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 0, 1);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 0, 1, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "*")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fx*")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fl*")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 0, 1);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 0, 1, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "/")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -2, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -2, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fl/")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -2, 0, 0, NULL, 1, 0, 1);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -2, 0, 0, NULL, 1, 0, 1, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "quotient")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -3, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -3, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fxquotient")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -3, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -3, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "remainder")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fxremainder")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "min")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 9, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 9, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "max")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 10, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 10, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "bitwise-and")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fxand")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "bitwise-ior")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 4, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 4, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fxior")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 4, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 4, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "bitwise-xor")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 5, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 5, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fxxor")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 5, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 5, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "arithmetic-shift")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1, 0, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1, 0, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fxlshift")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-fxrshift")) {
-      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -6, 0, 0, NULL, 1, 1, 0);
+      generate_arith(jitter, rator, app->rand1, app->rand2, 2, -6, 0, 0, NULL, 1, 1, 0, NULL);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "vector-ref")
                || IS_NAMED_PRIM(rator, "unsafe-vector-ref")
@@ -5961,6 +6261,35 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
         mz_runstack_unskipped(jitter, 2);
       }
 
+      return 1;
+    } else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-ref")) {
+      int fpr0, unbox = jitter->unbox;
+
+      jitter->unbox = 0; /* no unboxing of vector and index arguments */
+      generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
+      jitter->unbox = unbox;
+      CHECK_LIMIT();
+
+      jit_ldxi_p(JIT_R0, JIT_R0, (long)&(((Scheme_Structure *)0x0)->slots[0]));
+      jit_ldxi_p(JIT_R0, JIT_R0, (long)&SCHEME_CPTR_VAL(0x0));
+      jit_rshi_ul(JIT_R1, JIT_R1, 1);
+      jit_lshi_ul(JIT_R1, JIT_R1, 3); /* 3 = log(sizeof(double)) */
+
+      if (jitter->unbox)
+        fpr0 = JIT_FPR(jitter->unbox_depth);
+      else
+        fpr0 = JIT_FPR0;
+
+      jit_ldxr_d_fppush(fpr0, JIT_R0, JIT_R1);
+      CHECK_LIMIT();
+
+      if (jitter->unbox)
+        jitter->unbox_depth++;
+      else {
+        mz_rs_sync();
+        generate_alloc_double(jitter);
+      }
+
       return 1;
     } else if (IS_NAMED_PRIM(rator, "set-mcar!")
                || IS_NAMED_PRIM(rator, "set-mcdr!")) {
@@ -6119,7 +6448,22 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
 
   scheme_direct_call_count++;
 
-  if (!for_branch) {
+  if (IS_NAMED_PRIM(rator, "=")) {
+    generate_nary_arith(jitter, app, 0, 0, for_branch, branch_short);
+    return 1;
+  } else if (IS_NAMED_PRIM(rator, "<")) {
+    generate_nary_arith(jitter, app, 0, -2, for_branch, branch_short);
+    return 1;
+  } else if (IS_NAMED_PRIM(rator, ">")) {
+    generate_nary_arith(jitter, app, 0, 2, for_branch, branch_short);
+    return 1;
+  } else if (IS_NAMED_PRIM(rator, "<=")) {
+    generate_nary_arith(jitter, app, 0, -1, for_branch, branch_short);
+    return 1;
+  } else if (IS_NAMED_PRIM(rator, ">=")) {
+    generate_nary_arith(jitter, app, 0, 1, for_branch, branch_short);
+    return 1;
+  } else if (!for_branch) {
     if (IS_NAMED_PRIM(rator, "vector-set!")
         || IS_NAMED_PRIM(rator, "unsafe-vector-set!")
         || IS_NAMED_PRIM(rator, "unsafe-struct-set!")
@@ -6277,6 +6621,44 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
 
       mz_runstack_unskipped(jitter, 3 - pushed);
 
+      return 1;
+    } else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-set!")) {
+      if (avoids_r1(app->args[1])
+          && is_constant_and_avoids_r1(app->args[2])
+          && can_unbox(app->args[3], 5, JIT_FPR_NUM-1)) {
+        mz_runstack_skipped(jitter, 3);
+        jitter->unbox++;
+        generate(app->args[3], jitter, 0, 0, JIT_R0); /* to FP reg */
+        CHECK_LIMIT();
+        --jitter->unbox;
+        jitter->unbox_depth -= 1;
+        generate(app->args[2], jitter, 0, 0, JIT_R1);
+        CHECK_LIMIT();
+        generate(app->args[1], jitter, 0, 0, JIT_R0);
+        mz_runstack_unskipped(jitter, 3);
+      } else {
+        generate_app(app, NULL, 3, jitter, 0, 0, 2);
+        CHECK_LIMIT();
+
+        mz_rs_ldxi(JIT_R0, 2);
+        jit_ldxi_d_fppush(JIT_FPR0, JIT_R0, &((Scheme_Double *)0x0)->double_val);  
+        mz_rs_ldr(JIT_R0);
+        mz_rs_ldxi(JIT_R1, 1);
+
+        mz_rs_inc(3); /* no sync */
+        mz_runstack_popped(jitter, 3);
+      }
+      CHECK_LIMIT();
+
+      jit_ldxi_p(JIT_R0, JIT_R0, (long)&(((Scheme_Structure *)0x0)->slots[0]));
+      jit_ldxi_p(JIT_R0, JIT_R0, (long)&SCHEME_CPTR_VAL(0x0));
+      jit_rshi_ul(JIT_R1, JIT_R1, 1);
+      jit_lshi_ul(JIT_R1, JIT_R1, 3); /* 3 = log(sizeof(double)) */
+      jit_stxr_d_fppop(JIT_R1, JIT_R0, JIT_FPR0);
+      CHECK_LIMIT();
+      
+      jit_movi_p(JIT_R0, &scheme_void);
+      
       return 1;
     } else if (IS_NAMED_PRIM(rator, "vector-immutable")
                || IS_NAMED_PRIM(rator, "vector")) {
@@ -6318,6 +6700,24 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
       }
 
       return 1;
+    } else if (IS_NAMED_PRIM(rator, "+")) {
+      return generate_nary_arith(jitter, app, 1, 0, NULL, 1);
+    } else if (IS_NAMED_PRIM(rator, "-")) {
+      return generate_nary_arith(jitter, app, -1, 0, NULL, 1);
+    } else if (IS_NAMED_PRIM(rator, "*")) {
+      return generate_nary_arith(jitter, app, 2, 0, NULL, 1);
+    } else if (IS_NAMED_PRIM(rator, "/")) {
+      return generate_nary_arith(jitter, app, -2, 0, NULL, 1);
+    } else if (IS_NAMED_PRIM(rator, "bitwise-and")) {
+      return generate_nary_arith(jitter, app, 3, 0, NULL, 1);
+    } else if (IS_NAMED_PRIM(rator, "bitwise-ior")) {
+      return generate_nary_arith(jitter, app, 4, 0, NULL, 1);
+    } else if (IS_NAMED_PRIM(rator, "bitwise-xor")) {
+      return generate_nary_arith(jitter, app, 5, 0, NULL, 1);
+    } else if (IS_NAMED_PRIM(rator, "min")) {
+      return generate_nary_arith(jitter, app, 9, 0, NULL, 1);
+    } else if (IS_NAMED_PRIM(rator, "max")) {
+      return generate_nary_arith(jitter, app, 10, 0, NULL, 1);
     } else if (IS_NAMED_PRIM(rator, "checked-procedure-check-and-extract")) {
       generate_app(app, NULL, 5, jitter, 0, 0, 2);  /* sync'd below */
       CHECK_LIMIT();
@@ -8257,7 +8657,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
       {
         /* May use JIT_R0 and create local branch: */
         mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK),
-                                jit_pusharg_p(JIT_R1),
+                                jit_pusharg_i(JIT_R1),
                                 JIT_R2, noncm_prim_indirect);
       }
       CHECK_LIMIT();
@@ -8283,6 +8683,32 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
     }
   }
 
+  /* *** call_original_nary_arith_code *** */
+  /* rator is in V1, count is in R1, args are on runstack */
+  {
+    void *code;
+
+    code = jit_get_ip().ptr;
+    call_original_nary_arith_code = code;
+
+    mz_prolog(JIT_R2);
+    JIT_UPDATE_THREAD_RSPTR();
+    mz_prepare_direct_prim(2);
+    {
+      /* May use JIT_R0 and create local branch: */
+      mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK),
+                              jit_pusharg_i(JIT_R1),
+                              JIT_V1, noncm_prim_indirect);
+    }
+    CHECK_LIMIT();
+    jit_retval(JIT_R0);
+    VALIDATE_RESULT(JIT_R0);
+    mz_epilog(JIT_R2);
+    CHECK_LIMIT();
+
+    register_sub_func(jitter, code, scheme_false);
+  }
+
   /* *** on_demand_jit_[arity_]code *** */
   /* Used as the code stub for a closure whose
      code is not yet compiled. See generate_function_prolog
diff --git a/src/mzscheme/src/lightning/i386/fp.h b/src/mzscheme/src/lightning/i386/fp.h
index d9f54757ff..a36f5e205d 100644
--- a/src/mzscheme/src/lightning/i386/fp.h
+++ b/src/mzscheme/src/lightning/i386/fp.h
@@ -201,6 +201,8 @@ union jit_double_imm {
   ((rd) == 0 ? (FSTPr (0), FPX(), FLDLm(0, (s1), (s2), 1))	\
    : (FPX(), FLDLm(0, (s1), (s2), 1), FSTPr ((rd) + 1)))
 
+#define jit_ldxr_d_fppush(rd, s1, s2) (FPX(), FLDLm(0, (s1), (s2), 1))
+
 #define jit_extr_i_d(rd, rs)   (PUSHLr((rs)),          \
   ((rd) == 0 ? (FSTPr (0), FILDLm(0, _ESP, 0, 0))      \
    : (FILDLm(0, _ESP, 0, 0), FSTPr ((rd) + 1))),       \
@@ -235,9 +237,10 @@ union jit_double_imm {
 
 #define jit_sti_d_fppop(id, rs)      (FPX(), FSTPLm((id), 0,    0, 0))
 #endif
-#define jit_stxi_d_fppop(id, rd, rs) (FPX(), FSTPLm((id), (rd), 0, 0))
 
+#define jit_stxi_d_fppop(id, rd, rs) (FPX(), FSTPLm((id), (rd), 0, 0))
 #define jit_str_d_fppop(rd, rs)      (FPX(), FSTPLm(0,    (rd), 0, 0))
+#define jit_stxr_d_fppop(d1, d2, rs) (FPX(), FSTPLm(0,    (d1), (d2), 1))
 
 /* Assume round to near mode */
 #define jit_floorr_d_i(rd, rs) \
diff --git a/src/mzscheme/src/numarith.c b/src/mzscheme/src/numarith.c
index a090f37e6c..605b894782 100644
--- a/src/mzscheme/src/numarith.c
+++ b/src/mzscheme/src/numarith.c
@@ -63,20 +63,24 @@ void scheme_init_numarith(Scheme_Env *env)
   scheme_add_global_constant("sub1", p, env);
 
   p = scheme_make_folding_prim(plus, "+", 0, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("+", p, env);
 
   p = scheme_make_folding_prim(minus, "-", 1, -1, 1);
   SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
-                                | SCHEME_PRIM_IS_UNARY_INLINED);
+                                | SCHEME_PRIM_IS_UNARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("-", p, env);
 
   p = scheme_make_folding_prim(mult, "*", 0, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("*", p, env);
 
   p = scheme_make_folding_prim(div_prim, "/", 1, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("/", p, env);
 
   p = scheme_make_folding_prim(scheme_abs, "abs", 1, 1, 1);
diff --git a/src/mzscheme/src/number.c b/src/mzscheme/src/number.c
index dbd681096d..af7445c20d 100644
--- a/src/mzscheme/src/number.c
+++ b/src/mzscheme/src/number.c
@@ -105,6 +105,8 @@ static Scheme_Object *fx_not (int argc, Scheme_Object *argv[]);
 static Scheme_Object *fx_lshift (int argc, Scheme_Object *argv[]);
 static Scheme_Object *fx_rshift (int argc, Scheme_Object *argv[]);
 static Scheme_Object *fx_to_fl (int argc, Scheme_Object *argv[]);
+static Scheme_Object *fl_ref (int argc, Scheme_Object *argv[]);
+static Scheme_Object *fl_set (int argc, Scheme_Object *argv[]);
 
 static double not_a_number_val;
 
@@ -312,15 +314,18 @@ scheme_init_number (Scheme_Env *env)
 			     env);
 
   p = scheme_make_folding_prim(scheme_bitwise_and, "bitwise-and", 0, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("bitwise-and", p, env);
 
   p = scheme_make_folding_prim(bitwise_or, "bitwise-ior", 0, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("bitwise-ior", p, env);
 
   p = scheme_make_folding_prim(bitwise_xor, "bitwise-xor", 0, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("bitwise-xor", p, env);
 
   p = scheme_make_folding_prim(bitwise_not, "bitwise-not", 1, 1, 1);
@@ -525,6 +530,18 @@ void scheme_init_unsafe_number(Scheme_Env *env)
   if (scheme_can_inline_fp_op())
     SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
   scheme_add_global_constant("unsafe-fx->fl", p, env);
+
+  p = scheme_make_noncm_prim(fl_ref, "unsafe-f64vector-ref",
+                             2, 2);
+  if (scheme_can_inline_fp_op())
+    SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  scheme_add_global_constant("unsafe-f64vector-ref", p, env);
+  
+  p = scheme_make_noncm_prim(fl_set, "unsafe-f64vector-set!",
+                             3, 3);
+  if (scheme_can_inline_fp_op())
+    SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
+  scheme_add_global_constant("unsafe-f64vector-set!", p, env);  
 }
 
 
@@ -2814,3 +2831,20 @@ static Scheme_Object *fx_to_fl (int argc, Scheme_Object *argv[])
   v = SCHEME_INT_VAL(argv[0]);
   return scheme_make_double(v);
 }
+
+static Scheme_Object *fl_ref (int argc, Scheme_Object *argv[])
+{
+  double v;
+  Scheme_Object *p;
+  p = ((Scheme_Structure *)argv[0])->slots[0];
+  v = ((double *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])];
+  return scheme_make_double(v);
+}
+
+static Scheme_Object *fl_set (int argc, Scheme_Object *argv[])
+{
+  Scheme_Object *p;
+  p = ((Scheme_Structure *)argv[0])->slots[0];
+  ((double *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])] = SCHEME_DBL_VAL(argv[2]);
+  return scheme_void;
+}
diff --git a/src/mzscheme/src/numcomp.c b/src/mzscheme/src/numcomp.c
index 6e678070d6..1095be750e 100644
--- a/src/mzscheme/src/numcomp.c
+++ b/src/mzscheme/src/numcomp.c
@@ -57,23 +57,28 @@ void scheme_init_numcomp(Scheme_Env *env)
   Scheme_Object *p;
 
   p = scheme_make_folding_prim(eq, "=", 2, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("=", p, env);
 
   p = scheme_make_folding_prim(lt, "<", 2, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_BINARY_INLINED);
   scheme_add_global_constant("<", p, env);
 
   p = scheme_make_folding_prim(gt, ">", 2, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant(">", p, env);
 
   p = scheme_make_folding_prim(lt_eq, "<=", 2, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("<=", p, env);
 
   p = scheme_make_folding_prim(gt_eq, ">=", 2, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant(">=", p, env);
 
   p = scheme_make_folding_prim(zero_p, "zero?", 1, 1, 1);
@@ -89,11 +94,13 @@ void scheme_init_numcomp(Scheme_Env *env)
   scheme_add_global_constant("negative?", p, env);
 
   p = scheme_make_folding_prim(sch_max, "max", 1, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("max", p, env);
 
   p = scheme_make_folding_prim(sch_min, "min", 1, -1, 1);
-  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
+                                | SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("min", p, env);
 }
 
diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h
index 35c3b7afb3..ab4f352503 100644
--- a/src/mzscheme/src/schminc.h
+++ b/src/mzscheme/src/schminc.h
@@ -14,7 +14,7 @@
 #define USE_COMPILED_STARTUP 1
 
 #define EXPECTED_PRIM_COUNT 959
-#define EXPECTED_UNSAFE_COUNT 47
+#define EXPECTED_UNSAFE_COUNT 49
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP
diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h
index a7586b1a72..82a03ebd66 100644
--- a/src/mzscheme/src/schvers.h
+++ b/src/mzscheme/src/schvers.h
@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.2.3.2"
+#define MZSCHEME_VERSION "4.2.3.3"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 2
 #define MZSCHEME_VERSION_Z 3
-#define MZSCHEME_VERSION_W 2
+#define MZSCHEME_VERSION_W 3
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

From 8365c0a9384fcd3e1f4dfc746a472c742969e3c7 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 26 Nov 2009 15:27:47 +0000
Subject: [PATCH 011/136] minor clean-up

svn: r17069
---
 src/mzscheme/src/jit.c | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c
index 577b27be65..0f8d67a596 100644
--- a/src/mzscheme/src/jit.c
+++ b/src/mzscheme/src/jit.c
@@ -4915,7 +4915,7 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
   refdone = jit_jmpi(jit_forward());
   if (!arith) {
     reffalse = _jit.x.pc;
-    jit_movi_p(JIT_R0, &scheme_false);
+    (void)jit_movi_p(JIT_R0, scheme_false);
     refdone3 = jit_jmpi(jit_forward());
   } else {
     reffalse = NULL;
@@ -5004,7 +5004,7 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
   }
 #endif
   if (!arith) {
-    jit_movi_p(JIT_R0, scheme_true);
+    (void)jit_movi_p(JIT_R0, scheme_true);
   }
   mz_patch_ucbranch(refdone);
   if (refdone3)
@@ -5021,7 +5021,7 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
 
   if (!arith && for_branch) {
     __START_SHORT_JUMPS__(branch_short);
-    for_branch[0] = jit_beqi_p(jit_forward(), JIT_R0, &scheme_false);
+    for_branch[0] = jit_beqi_p(jit_forward(), JIT_R0, scheme_false);
     __END_SHORT_JUMPS__(branch_short);
   }
 
@@ -6657,7 +6657,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
       jit_stxr_d_fppop(JIT_R1, JIT_R0, JIT_FPR0);
       CHECK_LIMIT();
       
-      jit_movi_p(JIT_R0, &scheme_void);
+      (void)jit_movi_p(JIT_R0, scheme_void);
       
       return 1;
     } else if (IS_NAMED_PRIM(rator, "vector-immutable")

From 5e9ead0e263d304afa199911d8ac8aceda5ecf7d Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 26 Nov 2009 15:44:43 +0000
Subject: [PATCH 012/136] fix unboxing offset

svn: r17070
---
 src/mzscheme/src/jit.c | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c
index 0f8d67a596..d91bccc3b2 100644
--- a/src/mzscheme/src/jit.c
+++ b/src/mzscheme/src/jit.c
@@ -4067,7 +4067,8 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
     }
     if (args_unboxed) {
       --jitter->unbox;
-      jitter->unbox_depth -= (rand2 ? 2 : 1);
+      if (rand)
+        jitter->unbox_depth -= (rand2 ? 2 : 1);
     }
     if (for_branch)
       mz_rs_sync(); /* needed if arguments were unboxed */

From d3fb995de1015be8ec3f33ca79b29359db0630d5 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 26 Nov 2009 16:31:43 +0000
Subject: [PATCH 013/136] make f64vector-ref and f64vector-set! use the unsafe
 versions after checking

svn: r17071
---
 collects/scheme/foreign.ss | 17 ++++++++++++-----
 1 file changed, 12 insertions(+), 5 deletions(-)

diff --git a/collects/scheme/foreign.ss b/collects/scheme/foreign.ss
index 66e3d94127..34a1674e99 100644
--- a/collects/scheme/foreign.ss
+++ b/collects/scheme/foreign.ss
@@ -1,7 +1,7 @@
 #lang scheme/base
 
 ;; Foreign Scheme interface
-(require '#%foreign setup/dirs
+(require '#%foreign setup/dirs scheme/unsafe/ops
          (for-syntax scheme/base scheme/list syntax/stx))
 
 ;; This module is full of unsafe bindings that are not provided to requiring
@@ -1081,7 +1081,8 @@
                      [TAG-set!     (id "" "-set!")]
                      [_TAG         (id "_" "")]
                      [_TAG*        (id "_" "*")]
-                     [TAGname      name])
+                     [TAGname      name]
+                     [f64?         (if (eq? (syntax-e #'TAG) 'f64) #'#t #'#f)])
          #'(begin
              (define-struct TAG (ptr length))
              (provide TAG? TAG-length (rename-out [TAG s:TAG]))
@@ -1102,14 +1103,19 @@
              (define* (TAG-ref v i)
                (if (TAG? v)
                    (if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
-                       (ptr-ref (TAG-ptr v) type i)
+                       (if f64? ;; use JIT-inlined operation
+                           (unsafe-f64vector-ref v i)
+                           (ptr-ref (TAG-ptr v) type i))
                        (error 'TAG-ref "bad index ~e for ~a bounds of 0..~e"
                               i 'TAG (sub1 (TAG-length v))))
                    (raise-type-error 'TAG-ref TAGname v)))
              (define* (TAG-set! v i x)
                (if (TAG? v)
                    (if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
-                       (ptr-set! (TAG-ptr v) type i x)
+                       (if (and f64? ;; use JIT-inlined operation
+                                (inexact-real? x))
+                           (unsafe-f64vector-set! v i x)
+                           (ptr-set! (TAG-ptr v) type i x))
                        (error 'TAG-set! "bad index ~e for ~a bounds of 0..~e"
                               i 'TAG (sub1 (TAG-length v))))
                    (raise-type-error 'TAG-set! TAGname v)))
@@ -1264,7 +1270,8 @@
     (raise-type-error 'cast "ctype" to-type))
   (unless (= (ctype-sizeof to-type)
              (ctype-sizeof from-type))
-    (raise-mismatch-error (format "representation sizes of types differ: ~e to "
+    (raise-mismatch-error 'cast
+                          (format "representation sizes of types differ: ~e to "
                                   from-type)
                           to-type))
   (let ([p2 (malloc from-type)])

From cd5220116aa7a9cc85f4f8940174379408fca5bf Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 26 Nov 2009 17:07:20 +0000
Subject: [PATCH 014/136] added underlay

svn: r17072
---
 collects/2htdp/image.ss                       |   3 +
 collects/2htdp/private/image-more.ss          |  28 +++-
 collects/2htdp/tests/test-image.ss            | 149 ++++++++++++++++--
 .../teachpack/2htdp/scribblings/image-gen.ss  |   8 +-
 .../teachpack/2htdp/scribblings/image-toc.ss  |  74 ++++++++-
 .../teachpack/2htdp/scribblings/image.scrbl   |  64 ++++++++
 .../2htdp/scribblings/img/157ab5efca7.png     | Bin 0 -> 179 bytes
 .../2htdp/scribblings/img/201c231dce2.png     | Bin 0 -> 965 bytes
 .../2htdp/scribblings/img/26bd803042c.png     | Bin 0 -> 117 bytes
 .../2htdp/scribblings/img/28253f4c3c.png      | Bin 0 -> 1648 bytes
 .../2htdp/scribblings/img/2d1e52503d7.png     | Bin 0 -> 1085 bytes
 .../2htdp/scribblings/img/42f9f9e4cf.png      | Bin 0 -> 178 bytes
 .../2htdp/scribblings/img/9858b8d5d.png       | Bin 0 -> 1144 bytes
 .../2htdp/scribblings/img/ff2fcb7b87.png      | Bin 0 -> 354 bytes
 14 files changed, 307 insertions(+), 19 deletions(-)
 create mode 100644 collects/teachpack/2htdp/scribblings/img/157ab5efca7.png
 create mode 100644 collects/teachpack/2htdp/scribblings/img/201c231dce2.png
 create mode 100644 collects/teachpack/2htdp/scribblings/img/26bd803042c.png
 create mode 100644 collects/teachpack/2htdp/scribblings/img/28253f4c3c.png
 create mode 100644 collects/teachpack/2htdp/scribblings/img/2d1e52503d7.png
 create mode 100644 collects/teachpack/2htdp/scribblings/img/42f9f9e4cf.png
 create mode 100644 collects/teachpack/2htdp/scribblings/img/9858b8d5d.png
 create mode 100644 collects/teachpack/2htdp/scribblings/img/ff2fcb7b87.png

diff --git a/collects/2htdp/image.ss b/collects/2htdp/image.ss
index eeb3fb0d4c..bf2612ed7d 100644
--- a/collects/2htdp/image.ss
+++ b/collects/2htdp/image.ss
@@ -52,6 +52,9 @@ and they all have good sample contracts. (It is amazing what we can do with kids
 (provide overlay
          overlay/align
          overlay/xy
+         underlay
+         underlay/align
+         underlay/xy
          
          beside
          beside/align
diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss
index aa8142316f..7b0e94034e 100644
--- a/collects/2htdp/private/image-more.ss
+++ b/collects/2htdp/private/image-more.ss
@@ -307,10 +307,14 @@
 
 ;; overlay : image image image ... -> image
 ;; places images on top of each other with their upper left corners aligned. last one goes on the bottom
-
 (define/chk (overlay image image2 . image3)
   (overlay/internal 'left 'top image (cons image2 image3)))
 
+;; underlay : image image image ... -> image
+(define (underlay image image2 . image3)
+  (let ([imgs (reverse (list* image image2 image3))])
+    (overlay/internal 'left 'top (car imgs) (cdr imgs))))
+
 ;; overlay/align : string string image image image ... -> image
 ;; the first string has to be one of "center" "middle" "left" or "right" (or symbols)
 ;; the second string has to be one of "center" "middle" "top" "bottom" or "baseline" (or symbols)
@@ -322,6 +326,10 @@
 (define/chk (overlay/align x-place y-place image image2 . image3)
   (overlay/internal x-place y-place image (cons image2 image3)))
 
+(define/chk (underlay/align x-place y-place image image2 . image3)
+  (let ([imgs (reverse (list* image image2 image3))])
+    (overlay/internal x-place y-place (car imgs) (cdr imgs))))
+
 (define (overlay/internal x-place y-place fst rst)
   (let loop ([fst fst]
              [rst rst])
@@ -346,14 +354,16 @@
   (case x-place
     [(left) 0]
     [(middle) (/ (image-right image) 2)]
-    [(right) (image-right image)]))
+    [(right) (image-right image)]
+    [else (error 'find-x-spot "~s" x-place)]))
 
 (define (find-y-spot y-place image)
   (case y-place
     [(top) 0]
     [(middle) (/ (image-bottom image) 2)]
     [(bottom) (image-bottom image)]
-    [(baseline) (image-baseline image)]))
+    [(baseline) (image-baseline image)]
+    [else (error 'find-y-spot "~s" y-place)]))
 
 ;; overlay/xy : image number number image -> image
 ;; places images on top of each other with their upper-left corners offset by the two numbers
@@ -366,6 +376,14 @@
              (if (< dx 0) 0 dx)
              (if (< dy 0) 0 dy)))
 
+(define/chk (underlay/xy image dx dy image2)
+  (overlay/δ image2
+             (if (< dx 0) 0 dx)
+             (if (< dy 0) 0 dy)
+             image
+             (if (< dx 0) (- dx) 0)
+             (if (< dy 0) (- dy) 0)))
+
 (define (overlay/δ image1 dx1 dy1 image2 dx2 dy2)
   (make-image (make-overlay (make-translate dx1 dy1 (image-shape image1))
                             (make-translate dx2 dy2 (image-shape image2)))
@@ -943,6 +961,10 @@
 (provide overlay
          overlay/align
          overlay/xy
+         underlay
+         underlay/align
+         underlay/xy
+         
          beside
          beside/align
          above
diff --git a/collects/2htdp/tests/test-image.ss b/collects/2htdp/tests/test-image.ss
index abb3d83197..64eb05ce34 100644
--- a/collects/2htdp/tests/test-image.ss
+++ b/collects/2htdp/tests/test-image.ss
@@ -285,9 +285,9 @@
        #f))
 
 (test (overlay/align 'middle
-                      'middle
-                      (ellipse 100 50 'solid 'green)
-                      (ellipse 50 100 'solid 'red))
+                     'middle
+                     (ellipse 100 50 'solid 'green)
+                     (ellipse 50 100 'solid 'red))
       =>
       (make-image
        (make-overlay
@@ -297,9 +297,9 @@
        #f))
 
 (test (overlay/align 'middle
-                      'middle
-                      (ellipse 50 100 'solid 'red)
-                      (ellipse 100 50 'solid 'green))
+                     'middle
+                     (ellipse 50 100 'solid 'red)
+                     (ellipse 100 50 'solid 'green))
       =>
       (make-image
        (make-overlay
@@ -310,9 +310,9 @@
 
 
 (test (overlay/align 'right
-                      'bottom
-                      (ellipse 50 100 'solid 'red)
-                      (ellipse 100 50 'solid 'green))
+                     'bottom
+                     (ellipse 50 100 'solid 'red)
+                     (ellipse 100 50 'solid 'green))
       =>
       (make-image
        (make-overlay
@@ -322,9 +322,9 @@
        #f))
 
 (test (overlay/align 'right
-                      'baseline
-                      (ellipse 50 100 'solid 'red)
-                      (ellipse 100 50 'solid 'green))
+                     'baseline
+                     (ellipse 50 100 'solid 'red)
+                     (ellipse 100 50 'solid 'green))
       =>
       (make-image
        (make-overlay
@@ -413,13 +413,136 @@
        #f))
 
 (test (above (ellipse 50 100 'solid 'red)
-              (ellipse 100 50 'solid 'blue))
+             (ellipse 100 50 'solid 'blue))
       =>
       (above/align 'left
                     (ellipse 50 100 'solid 'red)
                     (ellipse 100 50 'solid 'blue)))
 
 
+
+(test (underlay (ellipse 100 100 'solid 'blue)
+                (ellipse 120 120 'solid 'red))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 0 (image-shape (ellipse 120 120 'solid 'red)))
+        (make-translate 0 0 (image-shape (ellipse 100 100 'solid 'blue))))
+       (make-bb 120
+                120
+                120)
+       #f))
+
+(test (underlay/xy (ellipse 100 100 'solid 'blue)
+                   0 0
+                   (ellipse 120 120 'solid 'red))
+      =>
+      (underlay (ellipse 100 100 'solid 'blue)
+                (ellipse 120 120 'solid 'red)))
+
+
+(test (underlay/xy (ellipse 50 100 'solid 'red)
+                   -25 25
+                   (ellipse 100 50 'solid 'green))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green)))
+        (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red))))
+       (make-bb 100
+                100
+                100)
+       #f))
+
+(test (underlay/xy (ellipse 100 50 'solid 'green)
+                   10 10
+                   (ellipse 50 100 'solid 'red))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 10 10 (image-shape (ellipse 50 100 'solid 'red)))
+        (make-translate 0 0 (image-shape (ellipse 100 50 'solid 'green))))
+       (make-bb 100
+                110
+                110)
+       #f))
+
+(test (underlay (ellipse 100 50 'solid 'green)
+                (ellipse 50 100 'solid 'red))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 0 (image-shape (ellipse 50 100 'solid 'red)))
+        (make-translate 0 0 (image-shape (ellipse 100 50 'solid 'green))))
+       (make-bb 100
+                100
+                100)
+       #f))
+
+(test (underlay (ellipse 100 100 'solid 'blue)
+                (ellipse 120 120 'solid 'red)
+                (ellipse 140 140 'solid 'green))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 
+         0 0
+         (make-overlay
+          (make-translate 0 0 (image-shape (ellipse 140 140 'solid 'green)))
+          (make-translate 0 0 (image-shape (ellipse 120 120 'solid 'red)))))
+        (make-translate 0 0 (image-shape (ellipse 100 100 'solid 'blue))))
+       (make-bb 140 140 140)
+       #f))
+
+(test (underlay/align 'middle
+                      'middle
+                      (ellipse 100 50 'solid 'green)
+                      (ellipse 50 100 'solid 'red))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red)))
+        (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green))))
+       (make-bb 100 100 100)
+       #f))
+
+(test (underlay/align 'middle
+                      'middle
+                      (ellipse 50 100 'solid 'red)
+                      (ellipse 100 50 'solid 'green))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green)))
+        (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red))))
+       (make-bb 100 100 100)
+       #f))
+
+(test (underlay/align 'right
+                      'bottom
+                      (ellipse 50 100 'solid 'red)
+                      (ellipse 100 50 'solid 'green))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green)))
+        (make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red))))
+       (make-bb 100 100 100)
+       #f))
+
+(test (underlay/align "right"
+                      "baseline"
+                      (ellipse 50 100 'solid 'red)
+                      (ellipse 100 50 'solid 'green))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green)))
+        (make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red))))
+       (make-bb 100 100 100)
+       #f))
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  testing normalization
diff --git a/collects/teachpack/2htdp/scribblings/image-gen.ss b/collects/teachpack/2htdp/scribblings/image-gen.ss
index cbaf4b9c66..753806ba2e 100644
--- a/collects/teachpack/2htdp/scribblings/image-gen.ss
+++ b/collects/teachpack/2htdp/scribblings/image-gen.ss
@@ -28,7 +28,13 @@
 
 (define (handle-image exp)
   (printf ".") (flush-output)
-  (let ([result (parameterize ([current-namespace image-ns]) (eval exp))])
+  (let ([result 
+         (with-handlers ([exn:fail?
+                          (λ (x)
+                            (printf "\nerror evaluating:\n")
+                            (pretty-print exp)
+                            (raise x))])
+           (parameterize ([current-namespace image-ns]) (eval exp)))])
     (cond
       [(image? result)
        (let ([fn (exp->filename exp)])
diff --git a/collects/teachpack/2htdp/scribblings/image-toc.ss b/collects/teachpack/2htdp/scribblings/image-toc.ss
index 5ff0c76d67..314d641b85 100644
--- a/collects/teachpack/2htdp/scribblings/image-toc.ss
+++ b/collects/teachpack/2htdp/scribblings/image-toc.ss
@@ -8,8 +8,8 @@
   (list
    (list '(image-height (rectangle 100 100 "solid" "black")) 'val 100)
    (list '(image-baseline (rectangle 100 100 "solid" "black")) 'val 100)
-   (list '(image-height (text "Hello" 24 "black")) 'val 24.0)
-   (list '(image-baseline (text "Hello" 24 "black")) 'val 18.0)
+   (list '(image-height (text "Hello" 24 "black")) 'val 41.0)
+   (list '(image-baseline (text "Hello" 24 "black")) 'val 31.0)
    (list
     '(image-height
       (overlay (circle 20 "solid" "orange") (circle 30 "solid" "purple")))
@@ -114,6 +114,76 @@
       (ellipse 20 10 "solid" "black"))
     'image
     "28c73238138.png")
+   (list
+    '(underlay/xy
+      (underlay/xy
+       (ellipse 40 40 "solid" "gray")
+       10
+       15
+       (ellipse 10 10 "solid" "forestgreen"))
+      20
+      15
+      (ellipse 10 10 "solid" "forestgreen"))
+    'image
+    "201c231dce2.png")
+   (list
+    '(underlay/xy
+      (rectangle 20 20 "solid" "red")
+      -20
+      -20
+      (rectangle 20 20 "solid" "black"))
+    'image
+    "42f9f9e4cf.png")
+   (list
+    '(underlay/xy
+      (rectangle 20 20 "solid" "red")
+      20
+      20
+      (rectangle 20 20 "solid" "black"))
+    'image
+    "157ab5efca7.png")
+   (list
+    '(underlay/xy
+      (rectangle 20 20 "outline" "black")
+      20
+      0
+      (rectangle 20 20 "outline" "black"))
+    'image
+    "26bd803042c.png")
+   (list
+    '(underlay/align
+      "right"
+      "top"
+      (rectangle 50 50 "solid" "seagreen")
+      (rectangle 40 40 "solid" "silver")
+      (rectangle 30 30 "solid" "seagreen")
+      (rectangle 20 20 "solid" "silver"))
+    'image
+    "ff2fcb7b87.png")
+   (list
+    '(underlay/align
+      "middle"
+      "middle"
+      (rectangle 30 60 "solid" "orange")
+      (ellipse 60 30 "solid" "purple"))
+    'image
+    "2d1e52503d7.png")
+   (list
+    '(underlay
+      (ellipse 10 60 "solid" "red")
+      (ellipse 20 50 "solid" "black")
+      (ellipse 30 40 "solid" "red")
+      (ellipse 40 30 "solid" "black")
+      (ellipse 50 20 "solid" "red")
+      (ellipse 60 10 "solid" "black"))
+    'image
+    "28253f4c3c.png")
+   (list
+    '(underlay
+      (rectangle 30 60 "solid" "orange")
+      (ellipse 60 30 "solid" "purple"))
+    'image
+    "9858b8d5d.png")
    (list
     '(overlay/xy
       (overlay/xy
diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl
index 3698a01242..bc1f123196 100644
--- a/collects/teachpack/2htdp/scribblings/image.scrbl
+++ b/collects/teachpack/2htdp/scribblings/image.scrbl
@@ -318,6 +318,70 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                    (ellipse 10 10 "solid" "forestgreen"))]
 }
 
+@defproc[(underlay [i1 image?] [i2 image?] [is image?] ...) image?]{
+  Underlays all of its arguments building a single image.
+  
+  It behaves like @scheme[overlay], but with the arguments in the reverse order.
+  That is, the first argument goes
+  underneath of the second argument, which goes underneath the third argument, etc.
+  The images are all lined up on their upper-left corners.
+
+  @image-examples[(underlay (rectangle 30 60 "solid" "orange")
+                            (ellipse 60 30 "solid" "purple"))
+                  (underlay (ellipse 10 60 "solid" "red")
+                            (ellipse 20 50 "solid" "black")
+                            (ellipse 30 40 "solid" "red")
+                            (ellipse 40 30 "solid" "black")
+                            (ellipse 50 20 "solid" "red")
+                            (ellipse 60 10 "solid" "black"))]
+  
+  }
+
+@defproc[(underlay/align [x-place x-place?] [y-place y-place?] [i1 image?] [i2 image?] [is image?] ...) image?]{
+  Underlays all of its image arguments, much like the @scheme[underlay] function, but using
+  @scheme[x-place] and @scheme[y-place] to determine where the images are lined up. For example, if
+  @scheme[x-place] and @scheme[y-place] are both @scheme["middle"], then the images are lined up
+  on their centers.
+
+  @image-examples[(underlay/align "middle" "middle"
+                                  (rectangle 30 60 "solid" "orange")
+                                  (ellipse 60 30 "solid" "purple"))
+                  (underlay/align "right" "top"
+                                  (rectangle 50 50 "solid" "seagreen")
+                                  (rectangle 40 40 "solid" "silver")
+                                  (rectangle 30 30 "solid" "seagreen")
+                                  (rectangle 20 20 "solid" "silver"))]
+                                  
+  
+  }
+
+@defproc[(underlay/xy [i1 image?] [x real?] [y real?] [i2 image?]) image?]{
+  Constructs an image by underlaying @scheme[i1] underneath of @scheme[i2] after
+  shifting @scheme[i2] over by @scheme[x] pixels to the right and @scheme[y] 
+  pixels down.
+  
+  This is the same as @scheme[(overlay/xy i2 (- x) (- y) i1)].
+  
+  @image-examples[(underlay/xy (rectangle 20 20 "outline" "black")
+                               20 0
+                               (rectangle 20 20 "outline" "black"))
+                  (underlay/xy (rectangle 20 20 "solid" "red")
+                               20 20
+                               (rectangle 20 20 "solid" "black"))
+                  (underlay/xy (rectangle 20 20 "solid" "red")
+                               -20 -20
+                               (rectangle 20 20 "solid" "black"))
+                  (underlay/xy 
+                   (underlay/xy (ellipse 40 40 "solid" "gray")
+                                10
+                                15
+                                (ellipse 10 10 "solid" "forestgreen"))
+                   20
+                   15
+                   (ellipse 10 10 "solid" "forestgreen"))]
+}
+
+
 @defproc[(beside [i1 image?] [i2 image?] [is image?] ...) image?]{
   Constructs an image by placing all of the argument images in a
   horizontal row, aligned along their top edges.
diff --git a/collects/teachpack/2htdp/scribblings/img/157ab5efca7.png b/collects/teachpack/2htdp/scribblings/img/157ab5efca7.png
new file mode 100644
index 0000000000000000000000000000000000000000..59966a6bc9cb7c65315d62b114d4b63f4abd4bf8
GIT binary patch
literal 179
zcmeAS@N?(olHy`uVBq!ia0vp^njp-<1SHj&rY{6iRh}-6ArY-_uWb}OV8FrbVEKIE
z6~k#a8+OJVjh?7iyWrH^k}bQIUpevn*gcJwmdK?))Rcu*%&GoXv{mlC>$aSmn^I3t
z`)gm_bR=qOR<Qx2vhnGs#pm>LZ6~F*oqN#LaqIHCb$ivKAqxM^xT!fgX6f4Ww2XIK
a)8v*Wt_cfnJM<Um3I<PCKbLh*2~7YE=}u_?

literal 0
HcmV?d00001

diff --git a/collects/teachpack/2htdp/scribblings/img/201c231dce2.png b/collects/teachpack/2htdp/scribblings/img/201c231dce2.png
new file mode 100644
index 0000000000000000000000000000000000000000..0f7fef2922743c2b7f4c69c4c2782210d5eabb97
GIT binary patch
literal 965
zcmV;$13LVPP)<h;3K|Lk000e1NJLTq001cf001cn0ssI2CjytD000AwNkl<ZScScq
z%Wm306o$uRd{Jy{AjD2%<d8xx3Th%2S!S12yK3`zeTAyazCu)~k-9-4fD(`+0uBZv
zgM>}&>B5zp7#KqX{3~Yuqw{$N>zwfr2q7@H9LE_92DWXF$K#jtG)-@8Z16k}A)G&3
zY@Q&~G@qWHI-SmFG{S^I2t`qpWm%FWk|ZP35}0)(gxc-4rfGx0V4g<|L{XHYD5|RB
zpI|22vaE8syeRdh7=}4GI7p|{i?KCLySuydJnz53fijs)KA$HDBASg5s#Ge?X7laT
zK%1MJg+gI+|HH3kxm;c@7yw`xMyXVq+{IVy`}_M=tF>HkfWN)HoyqQYyY+f~6<}Yj
zRx7lyziiiaC!cHSs#GerZHL*Krs3<xQslaBtyX)*c3t=3;bGNaU%IXbH3RzNP<>vh
z8jZ$3cDvnP8yEo4>2&<1LeKO1{r)=Hp6BVh4giQ*mK9k$`{Vw#dEIk*005F8PsEe=
z-1|A*sWJ>hQ553w@$u&71{3$&{QdR*tL@n@CqHg~{Gxn`bZ3bq$@BAb=r|50s6Xyc
zrUn4~X#M!v{fT!mX<gSHjYbfEZn-wECsX_S_VDdj?-#~(k&DSZ91bInI9<Ct%j%7L
zwLuNzRtHr~X4|$S*i-v%prJd&xXlr+A3i@nN3cm^=Aj1?aEIN&xJ9vu$xKlcq-h!x
z@j?7B%es&*&QfO>H%TWknHh$G48vd|a$N4yyHAtz1)*@MT;g3!S^z*i9*^-nj}Q91
z^Ld-u{@(oVR}V<Q3+dugx%B@IygN%Q%hEJWAcU^2t|A+#hrG(5(i}C5iDHrpZzkTI
zR3?+z-`^(?Le*+@Z9UXiu~<wb5)c3&NzyvO9LFUR3E=loQ4~3jTN_(dRsRPJjaMz6
z=Ve)b#g=6`@`Zo92!c2~JPc|joI1NAsj4anLNNSSQw2fDX0xjUr&6iCy}g$+uj+X=
zo5g%KzD4nPyih2F_BGr~j*pL%$>`#+kOV<EJw1)Z!uJeQzJWc@E0s!}PG>1#Ns^9^
zj;3A$%>4GR*X#9qeWBZ!kVulu<#LLm%nHEWdA#N7VQXtEpU<-_i;2Op0RRXgUDq3p
z#&C!`q6C5vrqk)&-Q9VrMFcyLX_~sO8-_8p<B=qpOeRyQlq5+MMa`3N0d^qAaV*R7
nuh?R-7{f3e$FVH?A9d*uIoioj2)@KK00000NkvXXu0mjf4hYa8

literal 0
HcmV?d00001

diff --git a/collects/teachpack/2htdp/scribblings/img/26bd803042c.png b/collects/teachpack/2htdp/scribblings/img/26bd803042c.png
new file mode 100644
index 0000000000000000000000000000000000000000..ba29f9ce76abc6a7ea578a6eb2e50b4642609e73
GIT binary patch
literal 117
zcmeAS@N?(olHy`uVBq!ia0vp^nm{bd!2~2jb_J9JDH~50#}JRsx7RjuG8phMJ8Gx=
zpE^}ZT7ymaM}ACacC6`?x3&HT)4uG8J-A6b2Mpf)f3q=1ySggMN^A<h{3EGb>OgZC
NJYD@<);T3K0RS(<C076d

literal 0
HcmV?d00001

diff --git a/collects/teachpack/2htdp/scribblings/img/28253f4c3c.png b/collects/teachpack/2htdp/scribblings/img/28253f4c3c.png
new file mode 100644
index 0000000000000000000000000000000000000000..b9aa3d8d5f5d03cbf003181379d872d59fdf14e4
GIT binary patch
literal 1648
zcmV-$29NoPP)<h;3K|Lk000e1NJLTq002Dz002D*0ssI2kpT9-000IzNkl<ZXo1a|
zYiv_h9Ke6QeXu^}+|~^QhHPE71*lHOgaNWd81j&ps4?z?Ga+as1bigCLJWwq59-h*
z_=UubKnN0&8AA}G!vGP9gDfu5u`M_#xS2Uba9h@``}?8m)@^;<u8+$vP1Aesx&Qv!
zd(QpebMDcJ2*X^v#`oW|X%lH_SFc{ZaN&a6?Y0|@8zxUS+`ir9a{YSePFs8Xzun#4
z0|Nqz+dUxCH#lfC8Zj7BY&NUKqEi%aFrA`^)k<<Q-gl$XTb`7ZWHy^kCX>}_O-@d>
z+wB<{8R_ZicDvndHlq&Ri1+pD%$-Y5&$Tsc-e_;Hudkm9li@COK%dHZ(UG2>p5r4g
zFR!SmXx6M*dc8hCRS^*pm&^6VQ%|jfl!W-H$7ZuFS+Zo`zI~02jp7HLot+gG6$XPr
zYs2v5=jT^fSG(PA5uviOQfr^cC@wC(ckdnz4GlJ%O>3FRsHv$zM4Boq*Fm7h|Ip!Z
zII63wJsuBo=Z;t`0v&J&mOzr$a%0fz^~J@-yLRoWtE=;PJl=k3pthEt9$+$TgKf|U
zSK$&gKoc}UZ(>EK>Gipb7UkvV7Znv178W|4PK(7drjCL8_s0}Xf`zcqw>b!H&;qyN
z7Tko}@F#RZ7kDOQW`;CKgK01YvS12Kha7N#+2diy4pyxS5y2oPlP=_UD3Aj=LH7Ow
zozMl{@Gta258Q)6(7~gS1QtkvB%f<4gwKlCuZQve-EN;1HcD_(AvKD_gHlowdcSh9
zxA$B;zBn4zu4Tc3&{dRwIyzp1TZs`;!@PMMJsP%_g3I+6JOhmha0-o1$L7t{)sdp&
zF6o1^GVcd7d;)zSn!FqiIeS)A!-qvh{y$?T)PN_E#)XA);)L|~tCtoLYUa!te-a$<
zKD5SDw?8vewrr8}=OfY`@xC&9wlR1sDuIvS61ZdG`X8K!1Mu?n>Eg@S6T?7%|1vlm
z#QQQ_2EYo7pco3E0P-O@T+i{qEog>TXo8=i0R{m0c>8vI!?}r}yPT7A|Hh5yB0q8(
zWI_g{Lps=?8}9mEe}fC$fexHHb!tmX%lKQ4$oOgIOo8Q5#fXgB+S+JZ$WZ(KAty)R
zMxsWRTeohFURp#rlbh@9G+)Pm=&*6)#({x>*mxg%;)&t@{$)JXD=I2tB`qR+UQ*(J
zsrm*UiM6rGWU8vFik0z@_rcQAKSp0=Tm1$N(X)K{^5*8|*h&w1*NjUL9yk(wte_I7
z(|PLDshAs&c)u7Vy$!%u@N|T_CU_++?c&9YaWWq9w!(vu`T2J^1gjues?dQGwm~i2
z1vz;#uF@i6$go(t;TXIb{4ez8_HED)F1QIdp#w5tI%L5N7@0bnF@qOgi0~vuj3Lu%
z1*%{Zgq<Tah8!agv3oc1pKVkgvs!^>2tPJbLuo0SH^(GWXp||w$-$k_6=g89nIlKg
zg`U@l4N9ib=sl^O@K%(;4jm#lH+m;ED5k!?Jm1DwP&MI5d-f!zg?Ld&PA>G@eiv#c
z5N7XQ4jhP;lNuBh#ot@tb@&8CWdNIv<Hy;*KOS-+P_SB`99<;v9;}By!yf(o^E5W{
z>Z@^*3xym!_y8sa+GU1!pk-Y8ybtXwR>+kr@lJ}N@+B6F4NBp=ao)Y~DSQeAPz=+c
z1Ac?ftgO~EXQCX~Mu~w*lYrHMyod45-Vd|0yj;;#8c;}01=fN3Y*Aib9zP+K40%7U
zdPu)=<;ppMrnnM~{PK&pw|%RkvQDR~udmmzI}U@iwtBq>VRkt04I4ISEj$F$)ir#9
z`!QrIPf1B>YirY5cnCy9%;sVBEx}vJ>C>mRwjBWxk-WTN?+1YflzP4X@ZrN+tBwK@
zk!8#L(_t5^^^?xd&OUeUoYtOWF#u#``Tx6V@HJdsy7cGOs|yMW%F4<f!c`syfb8t?
zJ4#AROWuAv(K@P800QQba8Ew9MFE&S?!v9thkf#?Eee3c!I*_)PA3odVj2ZNuV>!8
zQN=4(Xkw!t-|gtL&yFg7>7~T0L_{F(++60))x<_UKJUegN2WfuZ`aBu0!C8MXP*hk
u{P~eSa@GXDb*3H<$Bwany{hF1TJt}fR9a`Ur~J<V0000<MNUMnLSTXdi6cP(

literal 0
HcmV?d00001

diff --git a/collects/teachpack/2htdp/scribblings/img/2d1e52503d7.png b/collects/teachpack/2htdp/scribblings/img/2d1e52503d7.png
new file mode 100644
index 0000000000000000000000000000000000000000..3d05fa71d1f511f54e9edc0362a8bec745093de9
GIT binary patch
literal 1085
zcmV-D1j74?P)<h;3K|Lk000e1NJLTq002Dz002D*0ssI2kpT9-000C8Nkl<ZXo2mT
zTWB0r7=ZtC=020lW;dDLG`j}dT`S#&przV)sTvjSQ&A{wL7%)l2t`3kQv?MceDOgF
z76tJ^1T9hopTt0$D7K^sHpG&ssil|Q?sT)+Y?9g8ot@bkA9giOyP3?i+nEi__cX)q
zne#FH=bZol8DyF!*e5pu*`FQ!-zMF=Kzz#42-4XE*>RXW>THM|wv9OT#?6;-1>f6U
zd~bL0z1_w4b{F5<U3_nMahMO@M!DEslEq>nT9$isP0%a6S_;&DLdY~t1OOQ86eH8@
zBE>HA9cjKp5<1hEsJQ2C8fYQ2J(t>%OYK<9ZY|7ht^8-{2!!>H(4|0lrn~Qa&wb~*
z<0Rqq33loRwP0Qy)zag-^sB5cGj||r4MFLV$JppF)&C;JiO9|nD{s?))R;E=t(N{p
zGqmPuTG$ZKx0_7tr(@4k$a3j5_BM5xJz2T%xw?GCxL1yrwD;qIx0v|LG+HB&8+fP2
z^xr-#EnW7;_+|nL{KyAf@8b>JS9$A2bK?E-Ki}WgN^dd<9ymzve2*phRdK)KEnhQE
zy{;7gu6kj&4#6Zb`~@%cu7rHuTak<(_Z8)o_pz}Sd<5_LPH2nO)iD4V8k~MZX=P~u
zP$XmY)uLLcM+XLgKR#3EFSKHK+`{q|<Lr@A?HcQfIsK*Tt&n}Lj%umXIsjnlT(z>~
zq}Ap%Q=gUr0Jr7_V!_;GRla6mv!z#KBTSe(U)_-Tw{pY4?Xiug-WJ7J+(}qxUabZ}
zLu81=d>BWcrM#AL!2Nq^CV(&i3?5>T(|W@r=nnMoVHRrVWoUrd{$}&5n5Kg;JoyRF
z^&t4ao`2|FHuhXgM++ig=p!yVT+hW<@>oNIGl!K+Ke$qmIfN9@6CZQ^dsg1;>Uzh7
zspIP8v9hUqAh#C5B(eJ#-??SguGgSWoBO?bc0?)6dVi3T0vbHTBwu50uQJ!Hi~syu
zojR_T=e<d}2nG`S>A|;IHrTi=VbzDwOXlo}%FI_4H>-MK6HXkUAAE&ox~v*0>-T+3
z12Sjyizh3oQ@U2XSFfMzL48kCoA*+YA=1wIZL42ZqpHI7Z%(9tN@p%Uvoycut~3Dv
z027sP|3q(myzhlr@TGUaR->wpgZ?1FK<v@WG3F=$lw@&1O6D^I3sQ0+Gq9LT7}fQ+
zf4=j2K%D7{Ob5i7uJClH_!mi)001_RIFfeeeKTBJmWyXM#m8#5MwL>PP+1A8#ZXBW
zRVAdU0>u;=KF@G@R>(1Yp5gN(t=!pkP4m75OlVxY#I;LJd77;mU7M-7_}=c~d%KJ8
z?JmBzyZGMjvQfPq=2f9xu<c0mEyB(|)&xg&Lrd{5<L7lQ6xwgx00000NkvXXu0mjf
DBPSxH

literal 0
HcmV?d00001

diff --git a/collects/teachpack/2htdp/scribblings/img/42f9f9e4cf.png b/collects/teachpack/2htdp/scribblings/img/42f9f9e4cf.png
new file mode 100644
index 0000000000000000000000000000000000000000..6f62addfae7063150797ad1cec1ae28539465dc8
GIT binary patch
literal 178
zcmeAS@N?(olHy`uVBq!ia0vp^njp-<1SHj&rY{6im7Xq+ArY-_uWb}OV8FrbU^#u^
z6~k#a8+OLrjGkyzy5Q8@k}bQIU%64ee(MKYm9uLCYJ>&1F4~>0AO8AdT*~Qby3yNm
zZvNk#KdJbf(`M@#4HIX6{bs3=YdgWfIlItRCBU-$t?A88sUU^lj^9~p)_Lh#v*fPo
bwbR)-@2?J<BCBo-bOeK^tDnm{r-UW|_@_x{

literal 0
HcmV?d00001

diff --git a/collects/teachpack/2htdp/scribblings/img/9858b8d5d.png b/collects/teachpack/2htdp/scribblings/img/9858b8d5d.png
new file mode 100644
index 0000000000000000000000000000000000000000..d3abd4688e285e450e438312da0426722774f4a8
GIT binary patch
literal 1144
zcmV-;1c&>HP)<h;3K|Lk000e1NJLTq002Dz002D*0ssI2kpT9-000C(Nkl<ZXo2mT
zS!^3c9Eblid)R9`iI2uf?4(vxJ9ipN)T&WQbI?{zTM?-UwFOFffl8GS;sLdY2VQ_m
zAcO?G0Z$-6;)O#Hh(tm`v=tFFKpRM%NVIio$97_y_*#1p9yT<Ge5UqpkoJ36?aq#7
zzFp1k%>J}U3|t2PMc63G2$Kjgv7jLt(s4<WV<|RD0{}2~q;C*K002w^rAKrnq6|n^
zhjdn~w_!|exK98868zu8<O>DX76l?S-x~CE2R+>pe{(p{oJtt8S7)=GKqOQ;u(65Q
zvV*AZCbo1EgccR)T>xytbZhF!+>Hai*?nxnR8$8U5jlv=3Xxgi=13X<2o2QkA?pVz
z$03Tb7IXnfynZ3u{T4;+nLg;Acyi7?DDd>X>*lv1z`l=k9j6-(PzdL$nfZQ;0_pzc
zv1>m*yR^_)7QrltJb1=A&p21%z@29`&SNynG9WS(d!`Rge0AZUh3(~a%*oPC;nKOp
z)O+mimzcV}86?*faVh<kFW#8FdO|L}JcQlC=&4xKNqX0dT2i-W+^={?Lyqr0_#`~v
zD!X1zM7Z%$D)<{e_^wW0w=(3H_u>)Tx9@+s>7@T-@jCzYu~_uBaJK{lfWXsZAATGS
zZB<SzKXIQhdMd_-Md=U&z#kW%Te#Dus8vBo5396~xg<69(^+MO3g^~n+B3!h0QOz8
zrIJ-j`xL?N?<4^LhyOM!ZBiV8Nj`d8z@n(MNU?|zxXR~T1Z-B~^8&7@SyEb~Xbklj
zTRXf63Hj@88VDL{dq}J^$Ld?YQCg-5whhx7Bf<dCHSik3ywW}eL06*tpVxvkUs~*w
z9ldWUt&|^xq4!N4Q;p#6x@zbCmm69~6t&6&BB1A0rhagF0lVytFyDXjbYs`2%8BKI
z)T6$)b*|$p--@eNv_z`+k*9a=e+6Mq3Ae16+lix}8yrJxf{V5D4ia|^ygu~QVWagg
zS=F*Y>QVQ3?a|K+RomCkj~V96>a9ON^vnahkDS-)1G4C4fY3n86ZFGBRCJutWc)PF
zl|yi8#yxTR&&y|)7PpmGa}|0UcAcPG9;Y>?TtP}MZwXPv-kJWHUmx{MA4;=^QhP4L
zR3m#o)i_Mm_K>-g6N&tJ6+(i|HD+^-@tpRKdtlD}pm%1VBq;@^pk^0Yx0kf{k>)l6
zib>iE%Go3cGTG2NBE9AlQESN8zUb`?`PxI?&PdQD@cDyET`e{?VN)|9ZL6G^WQvOg
zH{!h-#^7h1ew%Y#Iuv+{ja!m&GaIucqE<F;NgEGS&LNEvX-r6KMj8{+7}2^6<X+gI
z_c}0<W-5G4g>R*(%?$Sqm!$E`J(jQOvZ8v+i|Q>es<*tT-twY)%ZutQFRHh^sNV9T
zddrLIEibCKyr|ytqI$~<36?$3cCPdd*YuUX%~c@r|Mx=#0KmUV&qY?pO)MS&0000<
KMNUMnLSTXp7$d#_

literal 0
HcmV?d00001

diff --git a/collects/teachpack/2htdp/scribblings/img/ff2fcb7b87.png b/collects/teachpack/2htdp/scribblings/img/ff2fcb7b87.png
new file mode 100644
index 0000000000000000000000000000000000000000..0930b8b91a3e00a376c1c086fed05adc338c79a5
GIT binary patch
literal 354
zcmeAS@N?(olHy`uVBq!ia0vp^#vshW1SGc}US7+<z^Liz;usRq`u3WmH<P2pv5)21
z<~BRpuR6p`??~Y9WN~ugxcf@!%0~VN=C6XksO~9^?b73{+&D#7lPBtY-gc#eDe1?G
z_|E_Tb&lI!LgLs?fBDIY{vx7jvs-7bp4GQ$`||VQS4}>2rJfJ>6%XNSIvsY~cb@#Z
zymg`N=T@El{3611@862|eUn&st6$vLw#Hnt>qOhJXa8L!<x(rAJPd4ehcTA_@tkcw
zqi?r<xm5SPY3lV_uhTQ_y-mfU6P<JR`JVcqad<J$`M8-Ey>~~inG-g9^`e^XZ>Jv#
z5c{3@rd|8fACt0WNuP6rAm)8LHEqw9TlJNbzhzl(3R(7dy7|iB)g5QIdqOO`sa?!}
tXh(6$#=K+e`4;c$u&A83KH6x%{wgo)2N##$@&tw*gQu&X%Q~loCIAHMp*#Qp

literal 0
HcmV?d00001


From c0be5f0d12264832ddc99124963b4837ce5a6f07 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Thu, 26 Nov 2009 20:45:40 +0000
Subject: [PATCH 015/136] * Propagate all url arguments to links (except ones
 that are present) * Use ctxtname for the displayed label * `langindicator' ->
 `contextindicator' in css

svn: r17073
---
 collects/scribble/html-render.ss            |   2 +-
 collects/scribble/scribble-common.js        | 115 +++++++++++---------
 collects/scribble/scribble.css              |   2 +-
 collects/scribblings/main/private/search.js |  10 +-
 4 files changed, 68 insertions(+), 61 deletions(-)

diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
index 0acb2aff7b..5d89505c52 100644
--- a/collects/scribble/html-render.ss
+++ b/collects/scribble/html-render.ss
@@ -619,7 +619,7 @@
                        ,@(navigation d ri #t)
                        ,@(render-part d ri)
                        ,@(navigation d ri #f)))
-                   (div ([id "langindicator"]) nbsp)))))))))
+                   (div ([id "contextindicator"]) nbsp)))))))))
 
     (define/private (part-parent d ri)
       (collected-info-parent (part-collected-info d ri)))
diff --git a/collects/scribble/scribble-common.js b/collects/scribble/scribble-common.js
index b56fa3df76..34c0575ec8 100644
--- a/collects/scribble/scribble-common.js
+++ b/collects/scribble/scribble-common.js
@@ -1,5 +1,56 @@
 // Common functionality for PLT documentation pages
 
+// Page Parameters ------------------------------------------------------------
+
+var page_query_string =
+  (location.href.search(/\?([^#]+)(?:#|$)/) >= 0) && RegExp.$1;
+
+var page_args =
+  ((function(){
+      if (!page_query_string) return [];
+      var args = page_query_string.split(/[&;]/);
+      for (var i=0; i<args.length; i++) {
+        var a = args[i];
+        var p = a.indexOf('=');
+        if (p >= 0) args[i] = [a.substring(0,p), a.substring(p+1)];
+        else args[i] = [a, false];
+      }
+      return args;
+    })());
+
+function GetPageArg(key, def) {
+  for (var i=0; i<page_args.length; i++)
+    if (page_args[i][0] == key) return unescape(page_args[i][1]);
+  return def;
+}
+
+function MergePageArgsIntoLink(a) {
+  if (page_args.length == 0 ||
+      (!a.attributes["pltdoc"]) || (a.attributes["pltdoc"].value == ""))
+    return;
+  a.href.search(/^([^?#]*)(?:\?([^#]*))?(#.*)?$/);
+  if (RegExp.$2.length == 0) {
+    a.href = RegExp.$1 + "?" + page_query_string + RegExp.$3;
+  } else {
+    // need to merge here, precedence to arguments that exist in `a'
+    var i, j;
+    var prefix = RegExp.$1, str = RegExp.$2, suffix = RegExp.$3;
+    var args = str.split(/[&;]/);
+    for (i=0; i<args.length; i++) {
+      j = args[i].indexOf('=');
+      if (j) args[i] = args[i].substring(0,j);
+    }
+    var additions = "";
+    for (i=0; i<page_args.length; i++) {
+      var exists = false;
+      for (j=0; j<args.length; j++)
+        if (args[j] == page_args[i][0]) { exists = true; break; }
+      if (!exists) str += "&" + page_args[i][0] + "=" + page_args[i][1];
+    }
+    a.href = prefix + "?" + str + suffix;
+  }
+}
+
 // Cookies --------------------------------------------------------------------
 
 function GetCookie(key, def) {
@@ -38,38 +89,6 @@ function GotoPLTRoot(ver, relative) {
   return false;
 }
 
-// URL Parameters -------------------------------------------------------------
-
-// In the following functions, the `name' argument is assumed to be simple in
-// that it doesn't contain anything that isn't plain text in a regexp.  (This
-// is because JS doesn't have a `regexp-quote', easy to hack but not needed
-// here).  Also, the output value from the Get functions and the input value to
-// the Set functions is decoded/encoded.  Note that `SetArgInURL' mutates the
-// string in the url object.
-
-function GetArgFromString(str, name) {
-  var rx = new RegExp("(?:^|[;&])"+name+"=([^&;]*)(?:[;&]|$)");
-  return rx.test(str) && unescape(RegExp.$1);
-}
-
-function SetArgInString(str, name, val) {
-  val = escape(val);
-  if (str.length == 0) return name + "=" + val;
-  var rx = new RegExp("^((?:|.*[;&])"+name+"=)(?:[^&;]*)([;&].*|)$");
-  if (rx.test(str)) return RegExp.$1 + val + RegExp.$2;
-  else return name + "=" + val + "&" + str;
-}
-
-function GetArgFromURL(url, name) {
-  if (url.href.search(/\?([^#]*)(?:#|$)/) < 0) return false;
-  return GetArgFromString(RegExp.$1, name);
-}
-
-function SetArgInURL(url, name, val) { // note: mutates the string
-  url.href.search(/^([^?#]*)(?:\?([^#]*))?(#.*)?$/);
-  url.href = RegExp.$1 + "?" + SetArgInString(RegExp.$2,name,val) + RegExp.$3;
-}
-
 // Utilities ------------------------------------------------------------------
 
 normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/];
@@ -90,12 +109,10 @@ function DoSearchKey(event, field, ver, top_path) {
   var val = field.value;
   if (event && event.keyCode == 13) {
     var u = GetCookie("PLT_Root."+ver, null);
-    var args = "";
     if (u == null) u = top_path; // default: go to the top path
-    u += "search/index.html";
-    args = SetArgInString(args, "q", val);
-    if (cur_plt_lang) args = SetArgInString(args, "lang", cur_plt_lang);
-    location = u + "?" + args;
+    u += "search/index.html?q=" + escape(val);
+    if (page_query_string) u += "&" + page_query_string;
+    location = u;
     return false;
   }
   return true;
@@ -119,23 +136,13 @@ window.onload = function() {
   for (var i=0; i<on_load_funcs.length; i++) on_load_funcs[i]();
 };
 
-var cur_plt_lang = GetArgFromURL(location,"lang");
-
-function PropagateLangInLink(a) {
-  // the attribute's value doesn't matter
-  if (cur_plt_lang
-      && a.attributes["pltdoc"] && a.attributes["pltdoc"].value != ""
-      && !GetArgFromURL(a,"lang"))
-    SetArgInURL(a, "lang", cur_plt_lang);
-}
-
 AddOnLoad(function(){
-    if (!cur_plt_lang) return;
-    var indicator = document.getElementById("langindicator");
-    if (indicator) {
-      indicator.innerHTML = cur_plt_lang;
-      indicator.style.display = "block";
-    }
     var links = document.getElementsByTagName("a");
-    for (var i=0; i<links.length; i++) PropagateLangInLink(links[i]);
+    for (var i=0; i<links.length; i++) MergePageArgsIntoLink(links[i]);
+    var label = GetPageArg("ctxtname",false);
+    if (!label) return;
+    var indicator = document.getElementById("langindicator");
+    if (!indicator) return;
+    indicator.innerHTML = label;
+    indicator.style.display = "block";
   });
diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css
index cb71c09c9d..aa5c272ff9 100644
--- a/collects/scribble/scribble.css
+++ b/collects/scribble/scribble.css
@@ -119,7 +119,7 @@ table td {
   vertical-align: middle;
 }
 
-#langindicator {
+#contextindicator {
   position: fixed;
   background-color: #c6f;
   color: #000;
diff --git a/collects/scribblings/main/private/search.js b/collects/scribblings/main/private/search.js
index e0aeda00aa..632e0b24ee 100644
--- a/collects/scribblings/main/private/search.js
+++ b/collects/scribblings/main/private/search.js
@@ -226,7 +226,7 @@ function InitializeSearch() {
   result_links.push(n);
   AdjustResultsNum();
   // get search string
-  var init_q = GetArgFromURL(location,"q");
+  var init_q = GetPageArg("q",false);
   if (init_q && init_q != "") query.value = init_q;
   ContextFilter();
   DoSearch();
@@ -599,7 +599,7 @@ function UpdateResults() {
   if (first_search_result < 0 ||
       first_search_result >= search_results.length)
     first_search_result = 0;
-  var link_lang = (cur_plt_lang && ("?lang="+escape(cur_plt_lang)));
+  var link_args = (page_query_string && ("?"+page_query_string));
   for (var i=0; i<result_links.length; i++) {
     var n = i + first_search_result;
     if (n < search_results.length) {
@@ -639,12 +639,12 @@ function UpdateResults() {
       if (note)
         note = '&nbsp;&nbsp;<span class="smaller">' + note + '</span>';
       var href = UncompactUrl(res[1]);
-      if (link_lang) {
+      if (link_args) {
         var hash = href.indexOf("#");
         if (hash >= 0)
-          href = href.substring(0,hash) + link_lang + href.substring(hash);
+          href = href.substring(0,hash) + link_args + href.substring(hash);
         else
-          href = href + link_lang;
+          href = href + link_args;
       }
       result_links[i].innerHTML =
         '<a href="' + href + '" class="indexlink" tabIndex="2">'

From 64e018fffa2ee020ea1406c5de8e2e0470c8b137 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Fri, 27 Nov 2009 00:17:25 +0000
Subject: [PATCH 016/136] Leftover `langindicator' -> `contextindicator' change

svn: r17074
---
 collects/scribble/scribble-common.js | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/scribble/scribble-common.js b/collects/scribble/scribble-common.js
index 34c0575ec8..cc37899a09 100644
--- a/collects/scribble/scribble-common.js
+++ b/collects/scribble/scribble-common.js
@@ -141,7 +141,7 @@ AddOnLoad(function(){
     for (var i=0; i<links.length; i++) MergePageArgsIntoLink(links[i]);
     var label = GetPageArg("ctxtname",false);
     if (!label) return;
-    var indicator = document.getElementById("langindicator");
+    var indicator = document.getElementById("contextindicator");
     if (!indicator) return;
     indicator.innerHTML = label;
     indicator.style.display = "block";

From f03ab78c401e603bc5e950a29fec3431f9745ef1 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 27 Nov 2009 02:12:27 +0000
Subject: [PATCH 017/136] another syntax hack to fix 'scheme/package'; other
 test corrections

svn: r17075
---
 collects/scheme/package.ss                    | 16 +++--
 .../scribblings/reference/stx-trans.scrbl     |  5 +-
 collects/tests/mzscheme/compile.ss            |  4 +-
 collects/tests/mzscheme/package-gen.ss        |  4 +-
 collects/tests/mzscheme/package.ss            | 17 +++++
 collects/tests/mzscheme/parallel.ss           |  2 -
 collects/tests/mzscheme/prompt-sfs.ss         | 16 ++++-
 collects/tests/mzscheme/stream.ss             | 70 ++++++++++---------
 src/mzscheme/cmdline.inc                      |  2 +-
 src/mzscheme/src/env.c                        | 49 ++++++++-----
 10 files changed, 116 insertions(+), 69 deletions(-)

diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss
index 167c2c45dc..3052588932 100644
--- a/collects/scheme/package.ss
+++ b/collects/scheme/package.ss
@@ -317,9 +317,11 @@
                           (let* ([def-ctx (if star?
                                               (syntax-local-make-definition-context (car def-ctxes))
                                               (last def-ctxes))]
-                                 [ids (if star? 
-                                          (map (add-package-context (list def-ctx)) ids)
-                                          ids)])
+                                 [ids (map
+                                       (lambda (id) (syntax-property id 'unshadowable #t))
+                                       (if star? 
+                                           (map (add-package-context (list def-ctx)) ids)
+                                           ids))])
                             (syntax-local-bind-syntaxes ids #'rhs def-ctx)
                             (register-bindings! ids)
                             (loop (cdr exprs)
@@ -335,9 +337,11 @@
                         (let* ([def-ctx (if star?
                                             (syntax-local-make-definition-context (car def-ctxes))
                                             (last def-ctxes))]
-                               [ids (if star? 
-                                        (map (add-package-context (list def-ctx)) ids)
-                                        ids)])
+                               [ids (map
+                                     (lambda (id) (syntax-property id 'unshadowable #t))
+                                     (if star? 
+                                         (map (add-package-context (list def-ctx)) ids)
+                                         ids))])
                           (syntax-local-bind-syntaxes ids #f def-ctx)
                           (register-bindings! ids)
                           (loop (cdr exprs)
diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl
index 37c3056b97..003a7a4eaa 100644
--- a/collects/scribblings/reference/stx-trans.scrbl
+++ b/collects/scribblings/reference/stx-trans.scrbl
@@ -576,8 +576,9 @@ exports of the module.
 
 Returns @scheme[id-stx] if no binding in the current expansion context
 shadows @scheme[id-stx] (ignoring unsealed @tech{internal-definition
-contexts}), if @scheme[id-stx] has no module bindings in its lexical
-information, and if the current expansion context is not a
+contexts} and identifiers that had the @indexed-scheme['unshadowable]
+@tech{syntax property}), if @scheme[id-stx] has no module bindings in
+its lexical information, and if the current expansion context is not a
 @tech{module context}.
 
 If a binding of @scheme[inner-identifier] shadows @scheme[id-stx], the
diff --git a/collects/tests/mzscheme/compile.ss b/collects/tests/mzscheme/compile.ss
index 2137a8a52f..34a76a5c53 100644
--- a/collects/tests/mzscheme/compile.ss
+++ b/collects/tests/mzscheme/compile.ss
@@ -8,7 +8,7 @@
  'compile-load
  #f
  (lambda ()
-   (namespace-set-variable-value! 'compile-load "quiet.ss")))
+   (namespace-set-variable-value! 'compile-load "mzq.ss")))
 
 (define file
   (if #f
@@ -64,7 +64,7 @@
 	   [(x next-eval)
 	    (if (or (compiled-expression? x)
 		    (and (syntax? x) (compiled-expression? (syntax-e x)))
-		    (current-module-name-prefix))
+		    (current-module-declare-name))
 		(next-eval x)
 		(begin
 		  ;; (fprintf file ": ~a~n" +)
diff --git a/collects/tests/mzscheme/package-gen.ss b/collects/tests/mzscheme/package-gen.ss
index c2891b18dc..62d5126e2f 100644
--- a/collects/tests/mzscheme/package-gen.ss
+++ b/collects/tests/mzscheme/package-gen.ss
@@ -59,8 +59,8 @@
 (define combo-context-forms
   (list (lambda (p o) `(begin ,p ,o))
 	(lambda (p o) `(let () ,p ,o 10))
-	(lambda (p o) `(package out1 all-defined ,p ,o))
-	(lambda (p o) `(package out2 all-defined (package out1 all-defined ,p ,o)))))
+	(lambda (p o) `(define-package out1 #:all-defined ,p ,o))
+	(lambda (p o) `(define-package out2 #:all-defined (define-package out1 #:all-defined ,p ,o)))))
 
 (define all-forms
   (apply
diff --git a/collects/tests/mzscheme/package.ss b/collects/tests/mzscheme/package.ss
index b907652e5e..c60a471180 100644
--- a/collects/tests/mzscheme/package.ss
+++ b/collects/tests/mzscheme/package.ss
@@ -39,6 +39,7 @@
 
 (define (test-pack-seq* forms expr q-expr result)
   (let ([orig (current-namespace)])
+    ;; top level
     (let ([ns (make-base-namespace)])
       (parameterize ([current-namespace ns])
         (namespace-attach-module orig 'scheme/package)
@@ -48,6 +49,7 @@
         (if (fail? expr)
             (err/rt-test (eval (fail-expr expr)) result)
             (test result q-expr (eval expr)))))
+    ;; let
     (let ([ns (make-base-namespace)])
       (parameterize ([current-namespace ns])
         (namespace-attach-module orig 'scheme/package)
@@ -57,6 +59,21 @@
           (if (fail? expr)
               (err/rt-test (eval e) result)
               (test result `(let ... ,q-expr) (eval e))))))
+    ;; nested let
+    (let ([ns (make-base-namespace)])
+      (parameterize ([current-namespace ns])
+        (namespace-attach-module orig 'scheme/package)
+        (namespace-require '(for-syntax scheme/base))
+        (namespace-require 'scheme/package)
+        (let ([e (let loop ([forms forms])
+                   (if (null? (cdr forms))
+                       `(let () (begin . ,forms) ,(fail-expr expr))
+                       `(let () ,(car forms)
+                             ,(loop (cdr forms)))))])
+          (if (fail? expr)
+              (err/rt-test (eval e) result)
+              (test result `(let ... ,q-expr) (eval e))))))
+    ;; module
     (let ([ns (make-base-namespace)])
       (parameterize ([current-namespace ns])
         (namespace-attach-module orig 'scheme/package)
diff --git a/collects/tests/mzscheme/parallel.ss b/collects/tests/mzscheme/parallel.ss
index 037409ba6a..64a726e2d0 100644
--- a/collects/tests/mzscheme/parallel.ss
+++ b/collects/tests/mzscheme/parallel.ss
@@ -1,6 +1,4 @@
 
-do-not-run-me-yet
-
 ;; Runs 3 threads perfoming the test suite simultaneously. Each
 ;;  thread creates a directory sub<n> to run in, so that filesystem
 ;;  tests don't collide.
diff --git a/collects/tests/mzscheme/prompt-sfs.ss b/collects/tests/mzscheme/prompt-sfs.ss
index a967382bf5..ccc9ede999 100644
--- a/collects/tests/mzscheme/prompt-sfs.ss
+++ b/collects/tests/mzscheme/prompt-sfs.ss
@@ -1,16 +1,30 @@
 #lang scheme
+(require scheme/system)
 
 #|
 
 This test is designed to to check whether meta-continuations are
 correctly split when a continuation is delimited in the middle of
-a meta-continuation other than the current one. In aprticular,
+a meta-continuation other than the current one. In particular,
 the `x' binding is part of the deeper meta-continuation when `ak'
 is captured, but it is delimited inside the binding, so `x'
 should not be reated in `ak'.
 
+The test is implemented using `dump-memory-stats' in another mzscheme
+process.
+
 |#
 
+(when (equal? #() (current-command-line-arguments))
+  (let ([f (find-executable-path (find-system-path 'exec-file) #f)])
+    (let ([p (open-output-bytes)])
+      (parameterize ([current-error-port p])
+        (system* f "-l" "tests/mzscheme/prompt-sfs" "sub"))
+      (unless (regexp-match? #rx"<will-executor>: +1 +" (get-output-bytes p))
+        (error "wrong output")
+        (exit 1))))
+  (exit 0))
+
 (define (make-big-thing) (cons (make-string 100000) (make-will-executor)))
 (define (show-big-thing say x) (say (string-length (car x))))
 
diff --git a/collects/tests/mzscheme/stream.ss b/collects/tests/mzscheme/stream.ss
index 443166ea84..df6c622d21 100644
--- a/collects/tests/mzscheme/stream.ss
+++ b/collects/tests/mzscheme/stream.ss
@@ -1,6 +1,8 @@
 
 (printf "Stream Tests (current dir must be startup dir)~n")
 
+(require scheme/system)
+
 (define (log . args)
   '(begin
      (apply printf args)
@@ -9,13 +11,13 @@
 (define cs-prog
   '(define (copy-stream in out)
      (lambda ()
-       (let ([s (make-string 4096)])
+       (let ([s (make-bytes 4096)])
 	 (let loop ()
-	   (let ([l (read-string-avail! s in)])
+	   (let ([l (read-bytes-avail! s in)])
 	     (log "in: ~a" l)
 	     (unless (eof-object? l)
 	       (let loop ([p 0][l l])
-		 (let ([r (write-string-avail s out p (+ p l))])
+		 (let ([r (write-bytes-avail s out p (+ p l))])
 		   (log "out: ~a" r)
 		   (when (< r l)
 		     (loop (+ p r) (- l r)))))
@@ -29,9 +31,9 @@
 (define (feed-file out)
   (let ([p (open-input-file test-file)])
     (let loop ()
-      (let ([c (read-char p)])
+      (let ([c (read-byte p)])
 	(unless (eof-object? c)
-	  (write-char c out)
+	  (write-byte c out)
 	  (loop))))))
 	
 (define (feed-file/fast out)
@@ -42,15 +44,15 @@
 (define (check-file in)
   (let ([p (open-input-file test-file)])
     (let loop ([badc 0])
-      (let ([c (read-char p)]
-	    [c2 (read-char in)])
+      (let ([c (read-byte p)]
+	    [c2 (read-byte in)])
 	(unless (eq? c c2)
 	  (if (= badc 30)
 	      (error "check-failed" (file-position p) c c2)
 	      (begin
 		(fprintf (current-error-port)
-			 "fail: ~a ~s ~s~n"
-			 (file-position p) c c2)
+			 "fail: ~a ~s=~s ~s=~s~n"
+			 (file-position p) c (integer->char c) c2 (integer->char c2))
 		(loop (add1 badc)))))
 	(unless (eof-object? c)
 	  (loop badc))))
@@ -59,8 +61,8 @@
 (define (check-file/fast in)
   (let ([p (open-input-file test-file)])
     (let loop ()
-      (let* ([s (read-string 5000 p)]
-	     [s2 (read-string (if (string? s) (string-length s) 100) in)])
+      (let* ([s (read-bytes 5000 p)]
+	     [s2 (read-bytes (if (bytes? s) (bytes-length s) 100) in)])
 	(unless (equal? s s2)
 	  (error "fast check failed"))
 	(unless (eof-object? s)
@@ -69,23 +71,23 @@
 
 (define (check-file/fastest in)
   (let ([p (open-input-file test-file)]
-	[s1 (make-string 5000)]
-	[s2 (make-string 5000)])
+	[s1 (make-bytes 5000)]
+	[s2 (make-bytes 5000)])
     (let loop ([leftover 0][startpos 0][pos 0])
       (let* ([n1 (if (zero? leftover)
-		     (read-string-avail! s1 p)
+		     (read-bytes-avail! s1 p)
 		     leftover)]
-	     [n2 (read-string-avail! s2 in 0 (if (eof-object? n1)
-						 1
+	     [n2 (read-bytes-avail! s2 in 0 (if (eof-object? n1)
+                                                1
 						 n1))])
 	(unless (if (or (eof-object? n1)
 			(eof-object? n2))
 		    (and (eof-object? n1)
 			 (eof-object? n2))
 		    (if (= n2 n1 5000)
-			(string=? s1 s2)
-			(string=? (substring s1 startpos (+ startpos n2))
-				  (substring s2 0 n2))))
+			(bytes=? s1 s2)
+			(bytes=? (subbytes s1 startpos (+ startpos n2))
+				  (subbytes s2 0 n2))))
 	  (error 'check "failed at ~a (~a@~a ~a)" pos n1 startpos n2))
 	(unless (eof-object? n1)
 	  (loop (- n1 n2) 
@@ -95,11 +97,11 @@
 		(+ pos n2)))))
     (close-input-port p)))
 
-(define portno 40000)
+(define portno 40010)
 
 (define (setup-mzscheme-echo tcp?)
   (define p (process* test-file "-q" "-b"))
-  (define s (make-string 256))
+  (define s (make-bytes 256))
   (define r #f)
   (define w #f)
   (define r2 #f)
@@ -118,18 +120,18 @@
 		       (set! w2 ww2)))])
 	(fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))~n" portno)
 	(fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))~n" (add1 portno))
+        (flush-output (cadr p))
 	(thread-wait t)
 	(fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))~n"))
-      (fprintf (cadr p) "(begin ((copy-stream (current-input-port) (current-output-port))) (exit))~n"))
+      (fprintf (cadr p) "(begin (flush-output) ((copy-stream (current-input-port) (current-output-port))) (exit))~n"))
+  (flush-output (cadr p))
 
-  ;; Flush initial output:
-  (read-string (string-length (banner)) (car p))
-  (sleep 0.3)
-  (when (char-ready? (car p))
-    (read-string-avail! s (car p)))
-  (sleep 0.3)
-  (when (char-ready? (car p))
-    (read-string-avail! s (car p)))
+  (unless tcp?
+    ;; Flush initial output from other process:
+    (let loop ()
+      (sleep 0.3)
+      (unless (zero? (read-bytes-avail!* s (car p)))
+        (loop))))
 
   (if tcp?
       (values r w r2 w2)
@@ -218,7 +220,7 @@
 (start "To file and back:~n")
 (start " to...~n")
 (define-values (r w) (make-pipe))
-(define p (open-output-file tmp-file 'truncate))
+(define p (open-output-file tmp-file #:exists 'truncate))
 (define t (thread (copy-stream r p)))
 (feed-file w)
 (close-output-port w)
@@ -239,7 +241,7 @@
 (start "To file and back, faster:~n")
 (start " to...~n")
 (define-values (r w) (make-pipe))
-(define p (open-output-file tmp-file 'truncate))
+(define p (open-output-file tmp-file #:exists 'truncate))
 (define t (thread (copy-stream r p)))
 (feed-file/fast w)
 (close-output-port w)
@@ -295,8 +297,8 @@
 (check-file/fast rp2)
 (end)
 
-(define l1 (tcp-listen portno))
-(define l2 (tcp-listen (add1 portno)))
+(define l1 (tcp-listen portno 5 #t))
+(define l2 (tcp-listen (add1 portno) 5 #t))
 
 (start "TCP Echo...~n")
 (define-values (r w r2 w2) (setup-mzscheme-echo #t))
diff --git a/src/mzscheme/cmdline.inc b/src/mzscheme/cmdline.inc
index 9194656ae0..1c4901c88e 100644
--- a/src/mzscheme/cmdline.inc
+++ b/src/mzscheme/cmdline.inc
@@ -981,7 +981,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
 #endif
 	)
 #endif
-      PRINTF(BANNER);
+      PRINTF("%s", BANNER);
 #ifdef MZSCHEME_CMD_LINE  
 # ifdef DOS_FILE_SYSTEM
 #  if !defined(FILES_HAVE_FDS)
diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c
index 8336e4776e..5c9659a586 100644
--- a/src/mzscheme/src/env.c
+++ b/src/mzscheme/src/env.c
@@ -182,6 +182,8 @@ static void init_compile_data(Scheme_Comp_Env *env);
 
 #define ASSERT_IS_VARIABLE_BUCKET(b) /* if (((Scheme_Object *)b)->type != scheme_variable_type) abort() */
 
+static Scheme_Object *unshadowable_symbol;
+
 /*========================================================================*/
 /*                             initialization                             */
 /*========================================================================*/
@@ -632,6 +634,9 @@ static void make_kernel_env(void)
     scheme_current_thread->name = sym;
   }
 
+  REGISTER_SO(unshadowable_symbol);
+  unshadowable_symbol = scheme_intern_symbol("unshadowable");
+
   DONE_TIME(env);
 
   scheme_install_type_writer(scheme_toplevel_type, write_toplevel);
@@ -4687,7 +4692,7 @@ static Scheme_Object *
 local_get_shadower(int argc, Scheme_Object *argv[])
 {
   Scheme_Comp_Env *env, *frame;
-  Scheme_Object *sym, *esym, *sym_marks = NULL, *orig_sym, *uid = NULL, *env_marks;
+  Scheme_Object *sym, *esym, *sym_marks = NULL, *orig_sym, *uid = NULL, *env_marks, *prop;
 
   env = scheme_current_thread->current_local_env;
   if (!env)
@@ -4712,16 +4717,19 @@ local_get_shadower(int argc, Scheme_Object *argv[])
     for (i = frame->num_bindings; i--; ) {
       if (frame->values[i]) {
 	if (SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(frame->values[i])))  {
-	  esym = frame->values[i];
-	  env_marks = scheme_stx_extract_marks(esym);
-	  if (scheme_equal(env_marks, sym_marks)) {
-	    sym = esym;
-	    if (frame->uids)
-	      uid = frame->uids[i];
-	    else
-	      uid = frame->uid;
-	    break;
-	  }
+          prop = scheme_stx_property(frame->values[i], unshadowable_symbol, NULL);
+          if (SCHEME_FALSEP(prop)) {
+            esym = frame->values[i];
+            env_marks = scheme_stx_extract_marks(esym);
+            if (scheme_equal(env_marks, sym_marks)) {
+              sym = esym;
+              if (frame->uids)
+                uid = frame->uids[i];
+              else
+                uid = frame->uid;
+              break;
+            }
+          }
 	}
       }
     }
@@ -4734,14 +4742,17 @@ local_get_shadower(int argc, Scheme_Object *argv[])
           if (SAME_OBJ(SCHEME_STX_VAL(sym), 
                        SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))) {
             esym = COMPILE_DATA(frame)->const_names[i];
-            env_marks = scheme_stx_extract_marks(esym);
-            if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */
-              sym = esym;
-              if (COMPILE_DATA(frame)->const_uids)
-                uid = COMPILE_DATA(frame)->const_uids[i];
-              else
-                uid = frame->uid;
-              break;
+            prop = scheme_stx_property(esym, unshadowable_symbol, NULL);
+            if (SCHEME_FALSEP(prop)) {
+              env_marks = scheme_stx_extract_marks(esym);
+              if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */
+                sym = esym;
+                if (COMPILE_DATA(frame)->const_uids)
+                  uid = COMPILE_DATA(frame)->const_uids[i];
+                else
+                  uid = frame->uid;
+                break;
+              }
             }
 	  }
 	}

From d3ff1466436baa6339c7ecee15474ce3be553a94 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 27 Nov 2009 03:35:36 +0000
Subject: [PATCH 018/136] fix JIT bug in multi-arity arithmetic inlining

svn: r17076
---
 collects/tests/mzscheme/optimize.ss |  7 +++++
 src/mzscheme/src/jit.c              | 43 +++++++++++++++++------------
 2 files changed, 32 insertions(+), 18 deletions(-)

diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss
index 19c32bfd45..1a62a69916 100644
--- a/collects/tests/mzscheme/optimize.ss
+++ b/collects/tests/mzscheme/optimize.ss
@@ -108,6 +108,9 @@
 		   (check-effect)
 		   (test v name ((eval `(lambda (x y) ,(wrap `(,op (,get-arg1) x y)))) arg2 arg3))
 		   (check-effect)
+		   (eval `(define _arg2 ,arg2))
+		   (test v name ((eval `(lambda (y) ,(wrap `(,op (,get-arg1) _arg2 y)))) arg3))
+                   (check-effect)
 		   (test v name ((eval `(lambda (x y z) ,(wrap `(,op x y z)))) (get-arg1) arg2 arg3))
 		   (check-effect)))]
          [tri (lambda (v op get-arg1 arg2 arg3 check-effect #:wrap [wrap values])
@@ -285,6 +288,7 @@
     (bin (expt 2 30) '+ (expt 2 29) (expt 2 29))
     (bin (- (expt 2 31) 2) '+ (sub1 (expt 2 30)) (sub1 (expt 2 30)))
     (tri 6 '+ (lambda () 1) 2 3 void)
+    (tri 13/2 '+ (lambda () 1) 5/2 3 void)
 
     (bin 3 '- 7 4)
     (bin 11 '- 7 -4)
@@ -293,6 +297,7 @@
     (bin (- (expt 2 30)) '- (- (expt 2 29)) (expt 2 29))
     (bin (- 2 (expt 2 31)) '- (- 1 (expt 2 30)) (sub1 (expt 2 30)))
     (tri 6 '- (lambda () 10) 3 1 void)
+    (tri 13/2 '- (lambda () 10) 3 1/2 void)
 
     (bin 4 '* 1 4)
     (bin 0 '* 0 4)
@@ -305,6 +310,7 @@
     (bin (expt 2 31) '* 2 (expt 2 30))
     (bin (- (expt 2 30)) '* 2 (- (expt 2 29)))
     (tri 30 '* (lambda () 2) 3 5 void)
+    (tri 5 '* (lambda () 2) 3 5/6 void)
 
     (bin 0 '/ 0 4)
     (bin 1/4 '/ 1 4)
@@ -314,6 +320,7 @@
     (bin -4 '/ 16 -4)
     (bin 4 '/ -16 -4)
     (tri 3 '/ (lambda () 30) 5 2 void)
+    (tri 12 '/ (lambda () 30) 5 1/2 void)
 
     (bin-int 3 'quotient 10 3)
     (bin-int -3 'quotient 10 -3)
diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c
index d91bccc3b2..2dfb220d94 100644
--- a/src/mzscheme/src/jit.c
+++ b/src/mzscheme/src/jit.c
@@ -3833,10 +3833,10 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
     } else
       ref8 = NULL;
     jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
-    ref9 = jit_bnei_p(jit_forward(), JIT_R2, scheme_double_type);
+    ref9 = jit_bnei_i(jit_forward(), JIT_R2, scheme_double_type);
     if (two_args) {
       jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type);
-      ref10 = jit_bnei_p(jit_forward(), JIT_R2, scheme_double_type);
+      ref10 = jit_bnei_i(jit_forward(), JIT_R2, scheme_double_type);
     } else
       ref10 = NULL;
     CHECK_LIMIT();
@@ -4067,8 +4067,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
     }
     if (args_unboxed) {
       --jitter->unbox;
-      if (rand)
-        jitter->unbox_depth -= (rand2 ? 2 : 1);
+      jitter->unbox_depth -= (rand ? (rand2 ? 2 : 1) : 2);
     }
     if (for_branch)
       mz_rs_sync(); /* needed if arguments were unboxed */
@@ -4774,14 +4773,18 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
 
 #define MAX_NON_SIMPLE_ARGS 5
 
-static int extract_nary_arg(int reg, int n, mz_jit_state *jitter, Scheme_App_Rec *app, Scheme_Object **alt_args)
+static int extract_nary_arg(int reg, int n, mz_jit_state *jitter, Scheme_App_Rec *app, 
+                            Scheme_Object **alt_args, int old_short_jumps)
 {
   if (!alt_args) {
     jit_ldxi_p(reg, JIT_RUNSTACK, WORDS_TO_BYTES(n));
     if (jitter->unbox)
       generate_unboxing(jitter);
   } else if (is_constant_and_avoids_r1(app->args[n+1])) {
+    __END_SHORT_JUMPS__(old_short_jumps);
     generate(app->args[n+1], jitter, 0, 0, reg);
+    CHECK_LIMIT();
+    __START_SHORT_JUMPS__(old_short_jumps);
   } else {
     int i, j = 0;
     for (i = 0; i < n; i++) {
@@ -4847,8 +4850,12 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
       use_fx = 0;
       if (trigger_arg == i)
         trigger_arg++;
+    } else if (SCHEME_TYPE(v) >= _scheme_compiled_values_types_) {
+      use_fx = 0;
+      use_fl = 0;
     }
   }
+
   if ((non_simple_c <= MAX_NON_SIMPLE_ARGS) && (non_simple_c < c)) {
     stack_c = non_simple_c;
     alt_args = non_simples;
@@ -4872,7 +4879,7 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
     trigger_arg = 0;
   }
 
-  extract_nary_arg(JIT_R0, trigger_arg, jitter, app, alt_args);
+  extract_nary_arg(JIT_R0, trigger_arg, jitter, app, alt_args, c < 100);
   CHECK_LIMIT();
   /* trigger argument a fixnum? */
   reffx = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
@@ -4881,7 +4888,7 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
   if (use_fl) {
     /* First argument a flonum? */
     jit_ldxi_s(JIT_R0, JIT_R0, &((Scheme_Object *)0x0)->type);
-    reffl = jit_beqi_p(jit_forward(), JIT_R0, scheme_double_type);
+    reffl = jit_beqi_i(jit_forward(), JIT_R0, scheme_double_type);
     CHECK_LIMIT();
   } else {
     reffl = NULL;
@@ -4899,7 +4906,7 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
     int delta = stack_c - c;
     for (i = 0; i < c; i++) {
       if (delta) {
-        extract_nary_arg(JIT_R0, i, jitter, app, alt_args);
+        extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100);
         CHECK_LIMIT();
         jit_stxi_p(WORDS_TO_BYTES(i+delta), JIT_RUNSTACK, JIT_R0);
       } else
@@ -4930,10 +4937,10 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
       if (i != trigger_arg) {
         v = app->args[i+1];
         if (!SCHEME_FLOATP(v)) {
-          extract_nary_arg(JIT_R0, i, jitter, app, alt_args);
+          extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100);
           (void)jit_bmsi_ul(refslow, JIT_R0, 0x1);
           jit_ldxi_s(JIT_R0, JIT_R0, &((Scheme_Object *)0x0)->type);
-          (void)jit_bnei_p(refslow, JIT_R0, scheme_double_type);
+          (void)jit_bnei_i(refslow, JIT_R0, scheme_double_type);
           CHECK_LIMIT();
         }
       }
@@ -4942,12 +4949,12 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
     args_unboxed = ((arith != 9) && (arith != 10)); /* no unboxing for min & max */
     if (args_unboxed)
       jitter->unbox++;
-    extract_nary_arg(JIT_R0, 0, jitter, app, alt_args);
+    extract_nary_arg(JIT_R0, 0, jitter, app, alt_args, c < 100);
     CHECK_LIMIT();
     for (i = 1; i < c; i++) {
       if (!arith && (i > 1))
-        extract_nary_arg(JIT_R0, i - 1, jitter, app, alt_args);
-      extract_nary_arg((args_unboxed ? JIT_R0 : JIT_R1), i, jitter, app, alt_args);
+        extract_nary_arg(JIT_R0, i - 1, jitter, app, alt_args, c < 100);
+      extract_nary_arg((args_unboxed ? JIT_R0 : JIT_R1), i, jitter, app, alt_args, c < 100);
       if ((i == c - 1) && args_unboxed) --jitter->unbox; /* box last result */
       if (!arith) memset(refs, 0, sizeof(refs));
       __END_SHORT_JUMPS__(c < 100);
@@ -4974,7 +4981,7 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
       if (i != trigger_arg) {
         v = app->args[i+1];
         if (!SCHEME_INTP(v)) {
-          extract_nary_arg(JIT_R0, i, jitter, app, alt_args);
+          extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100);
           CHECK_LIMIT();
           (void)jit_bmci_ul(refslow, JIT_R0, 0x1);
           CHECK_LIMIT();
@@ -4983,11 +4990,11 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
     }
     /* All fixnums, so inline fast fixnum combination;
        on overflow, bail out to refslow. */
-    extract_nary_arg(JIT_R0, 0, jitter, app, alt_args);
+    extract_nary_arg(JIT_R0, 0, jitter, app, alt_args, c < 100);
     for (i = 1; i < c; i++) {
       if (!arith && (i > 1))
-        extract_nary_arg(JIT_R0, i - 1, jitter, app, alt_args);
-      extract_nary_arg(JIT_R1, i, jitter, app, alt_args);
+        extract_nary_arg(JIT_R0, i - 1, jitter, app, alt_args, c < 100);
+      extract_nary_arg(JIT_R1, i, jitter, app, alt_args, c < 100);
       CHECK_LIMIT();
       if (!arith) memset(refs, 0, sizeof(refs));
       __END_SHORT_JUMPS__(c < 100);
@@ -5310,7 +5317,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
     /* Check for positive bignum: */
     __START_SHORT_JUMPS__(branch_short);
     jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
-    ref2 = jit_bnei_p(jit_forward(), JIT_R2, scheme_bignum_type);
+    ref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_bignum_type);
     jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso));
     ref3 = jit_bmci_ul(jit_forward(), JIT_R2, 0x1);
     __END_SHORT_JUMPS__(branch_short);

From 70794d4a515218a64967f67e28622b22ffc1937b Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Fri, 27 Nov 2009 05:49:35 +0000
Subject: [PATCH 019/136] PR10614

svn: r17077
---
 collects/srfi/19/time.ss | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/collects/srfi/19/time.ss b/collects/srfi/19/time.ss
index 73d647c099..56dcc0a9f7 100644
--- a/collects/srfi/19/time.ss
+++ b/collects/srfi/19/time.ss
@@ -390,13 +390,13 @@
   
   (define (time>=? time1 time2)
     (tm:time-compare-check time1 time2 'time>=?)
-    (or (>= (time-second time1) (time-second time2))
+    (or (> (time-second time1) (time-second time2))
 	(and (= (time-second time1) (time-second time2))
 	     (>= (time-nanosecond time1) (time-nanosecond time2)))))
   
   (define (time<=? time1 time2)
     (tm:time-compare-check time1 time2 'time<=?)
-    (or (<= (time-second time1) (time-second time2))
+    (or (< (time-second time1) (time-second time2))
 	(and (= (time-second time1) (time-second time2))
 	     (<= (time-nanosecond time1) (time-nanosecond time2)))))
   

From 335d5353f85768174da50d6b1c8b5127f6e62aaf Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Fri, 27 Nov 2009 08:50:32 +0000
Subject: [PATCH 020/136] Welcome to a new PLT day.

svn: r17080
---
 collects/repos-time-stamp/stamp.ss | 2 +-
 src/worksp/mred/mred.manifest      | 2 +-
 src/worksp/mred/mred.rc            | 8 ++++----
 src/worksp/mzcom/mzcom.rc          | 8 ++++----
 src/worksp/mzcom/mzobj.rgs         | 6 +++---
 src/worksp/mzscheme/mzscheme.rc    | 8 ++++----
 src/worksp/starters/start.rc       | 8 ++++----
 7 files changed, 21 insertions(+), 21 deletions(-)

diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss
index 9aab326df9..79530a31a2 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "26nov2009")
+#lang scheme/base (provide stamp) (define stamp "27nov2009")
diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest
index 7b98bfb05e..5d8d4648b5 100644
--- a/src/worksp/mred/mred.manifest
+++ b/src/worksp/mred/mred.manifest
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8" standalone="yes"?> 
 <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> 
 <assemblyIdentity 
-version="4.2.3.2" 
+version="4.2.3.3" 
 processorArchitecture="X86" 
 name="Org.PLT-Scheme.MrEd" 
 type="win32" 
diff --git a/src/worksp/mred/mred.rc b/src/worksp/mred/mred.rc
index 3552f88b3c..876f2e8765 100644
--- a/src/worksp/mred/mred.rc
+++ b/src/worksp/mred/mred.rc
@@ -20,8 +20,8 @@ APPLICATION             ICON    DISCARDABLE     "mred.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,3,2
- PRODUCTVERSION 4,2,3,2
+ FILEVERSION 4,2,3,3
+ PRODUCTVERSION 4,2,3,3
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -39,11 +39,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme GUI application\0"
             VALUE "InternalName", "MrEd\0"
-            VALUE "FileVersion", "4, 2, 3, 2\0"
+            VALUE "FileVersion", "4, 2, 3, 3\0"
             VALUE "LegalCopyright", "Copyright � 1995-2009\0"
             VALUE "OriginalFilename", "MrEd.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 2, 3, 2\0"
+            VALUE "ProductVersion", "4, 2, 3, 3\0"
         END
     END
     BLOCK "VarFileInfo"
diff --git a/src/worksp/mzcom/mzcom.rc b/src/worksp/mzcom/mzcom.rc
index 3a936802d3..7a5d3628d0 100644
--- a/src/worksp/mzcom/mzcom.rc
+++ b/src/worksp/mzcom/mzcom.rc
@@ -53,8 +53,8 @@ END
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,3,2
- PRODUCTVERSION 4,2,3,2
+ FILEVERSION 4,2,3,3
+ PRODUCTVERSION 4,2,3,3
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -70,12 +70,12 @@ BEGIN
         BLOCK "040904b0"
         BEGIN
             VALUE "FileDescription", "MzCOM Module"
-            VALUE "FileVersion", "4, 2, 3, 2"
+            VALUE "FileVersion", "4, 2, 3, 3"
             VALUE "InternalName", "MzCOM"
             VALUE "LegalCopyright", "Copyright 2000-2009 PLT (Paul Steckler)"
             VALUE "OriginalFilename", "MzCOM.EXE"
             VALUE "ProductName", "MzCOM Module"
-            VALUE "ProductVersion", "4, 2, 3, 2"
+            VALUE "ProductVersion", "4, 2, 3, 3"
         END
     END
     BLOCK "VarFileInfo"
diff --git a/src/worksp/mzcom/mzobj.rgs b/src/worksp/mzcom/mzobj.rgs
index 105d46132b..bc9f515155 100644
--- a/src/worksp/mzcom/mzobj.rgs
+++ b/src/worksp/mzcom/mzobj.rgs
@@ -1,19 +1,19 @@
 HKCR
 {
-	MzCOM.MzObj.4.2.3.2 = s 'MzObj Class'
+	MzCOM.MzObj.4.2.3.3 = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
 	}
 	MzCOM.MzObj = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
-		CurVer = s 'MzCOM.MzObj.4.2.3.2'
+		CurVer = s 'MzCOM.MzObj.4.2.3.3'
 	}
 	NoRemove CLSID
 	{
 		ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
 		{
-			ProgID = s 'MzCOM.MzObj.4.2.3.2'
+			ProgID = s 'MzCOM.MzObj.4.2.3.3'
 			VersionIndependentProgID = s 'MzCOM.MzObj'
 			ForceRemove 'Programmable'
 			LocalServer32 = s '%MODULE%'
diff --git a/src/worksp/mzscheme/mzscheme.rc b/src/worksp/mzscheme/mzscheme.rc
index afd932b13b..736be425c3 100644
--- a/src/worksp/mzscheme/mzscheme.rc
+++ b/src/worksp/mzscheme/mzscheme.rc
@@ -29,8 +29,8 @@ APPLICATION             ICON    DISCARDABLE     "mzscheme.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,3,2
- PRODUCTVERSION 4,2,3,2
+ FILEVERSION 4,2,3,3
+ PRODUCTVERSION 4,2,3,3
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -48,11 +48,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme application\0"
             VALUE "InternalName", "MzScheme\0"
-            VALUE "FileVersion", "4, 2, 3, 2\0"
+            VALUE "FileVersion", "4, 2, 3, 3\0"
             VALUE "LegalCopyright", "Copyright �� 1995-2009\0"
             VALUE "OriginalFilename", "mzscheme.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 2, 3, 2\0"
+            VALUE "ProductVersion", "4, 2, 3, 3\0"
         END
     END
     BLOCK "VarFileInfo"
diff --git a/src/worksp/starters/start.rc b/src/worksp/starters/start.rc
index c1d525f508..0f89e496f1 100644
--- a/src/worksp/starters/start.rc
+++ b/src/worksp/starters/start.rc
@@ -22,8 +22,8 @@ APPLICATION             ICON    DISCARDABLE     "mzstart.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,3,2
- PRODUCTVERSION 4,2,3,2
+ FILEVERSION 4,2,3,3
+ PRODUCTVERSION 4,2,3,3
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -45,7 +45,7 @@ BEGIN
 #ifdef MZSTART
             VALUE "FileDescription", "PLT Scheme Launcher\0"
 #endif
-            VALUE "FileVersion", "4, 2, 3, 2\0"
+            VALUE "FileVersion", "4, 2, 3, 3\0"
 #ifdef MRSTART
             VALUE "InternalName", "mrstart\0"
 #endif
@@ -60,7 +60,7 @@ BEGIN
             VALUE "OriginalFilename", "MzStart.exe\0"
 #endif
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 2, 3, 2\0"
+            VALUE "ProductVersion", "4, 2, 3, 3\0"
         END
     END
     BLOCK "VarFileInfo"

From bad728f5b5b072e7cfa382c3279e1f2008d8b8b3 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 27 Nov 2009 14:04:35 +0000
Subject: [PATCH 021/136] fix getenv code for Windows

svn: r17081
---
 src/mzscheme/src/string.c | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/src/mzscheme/src/string.c b/src/mzscheme/src/string.c
index 8cd70ec7a6..9512b1a129 100644
--- a/src/mzscheme/src/string.c
+++ b/src/mzscheme/src/string.c
@@ -2102,7 +2102,7 @@ scheme_init_getenv(void)
 # include <windows.h>
 static char *dos_win_getenv(const char *name) {
   int value_size;
-  value_size = GetEnvironmentVariable(s, NULL, 0);
+  value_size = GetEnvironmentVariable(name, NULL, 0);
   if (value_size) {
     char *value;
     int got;
@@ -2112,7 +2112,7 @@ static char *dos_win_getenv(const char *name) {
       value[got] = 0;
     return value;
   }
-  return name;
+  return NULL;
 }
 #endif
 
@@ -2120,7 +2120,7 @@ static int sch_bool_getenv(const char* name) {
   int rc = 0;
 #ifdef GETENV_FUNCTION
 # ifdef DOS_FILE_SYSTEM
-  if (GetEnvironmentVariable(s, NULL, 0)) rc = 1;
+  if (GetEnvironmentVariable(name, NULL, 0)) rc = 1;
 # else
   if (getenv(name)) rc = 1;
 # endif
@@ -2159,6 +2159,7 @@ static Scheme_Object *sch_getenv(int argc, Scheme_Object *argv[])
   return value ? scheme_make_locale_string(value) : scheme_false;
 }
 
+#ifndef DOS_FILE_SYSTEM
 static int sch_unix_putenv(const char *var, const char *val, const long varlen, const long vallen) {
   char *buffer;
   long total_length;
@@ -2189,6 +2190,7 @@ static int sch_unix_putenv(const char *var, const char *val, const long varlen,
   putenv_str_table_put_name((Scheme_Object *)var, (Scheme_Object *)buffer);
   return putenv(buffer);
 } 
+#endif
 
 static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[])
 {

From 97a41443a9a03811f28e9a8e66606f949b15862c Mon Sep 17 00:00:00 2001
From: Mike Sperber <sperber@deinprogramm.de>
Date: Fri, 27 Nov 2009 16:40:44 +0000
Subject: [PATCH 022/136] Add string->symbol to DeinProgramm / DMdA advanced.

Also, exclude symbol-related stuff from everything below.

svn: r17082
---
 collects/deinprogramm/DMdA-assignments.ss | 2 +-
 collects/deinprogramm/DMdA-beginner.ss    | 2 +-
 collects/deinprogramm/DMdA-vanilla.ss     | 2 +-
 collects/deinprogramm/DMdA.ss             | 4 +++-
 4 files changed, 6 insertions(+), 4 deletions(-)

diff --git a/collects/deinprogramm/DMdA-assignments.ss b/collects/deinprogramm/DMdA-assignments.ss
index 895c51d6e3..e5643dd360 100644
--- a/collects/deinprogramm/DMdA-assignments.ss
+++ b/collects/deinprogramm/DMdA-assignments.ss
@@ -19,5 +19,5 @@
  procedures
  (all-from-except assignments: deinprogramm/DMdA procedures
 		  quote
-		  symbol?))
+		  symbol? string->symbol symbol->string))
 
diff --git a/collects/deinprogramm/DMdA-beginner.ss b/collects/deinprogramm/DMdA-beginner.ss
index c2d3e713fe..df0669ad0e 100644
--- a/collects/deinprogramm/DMdA-beginner.ss
+++ b/collects/deinprogramm/DMdA-beginner.ss
@@ -18,5 +18,5 @@
 		  quote
 		  make-pair pair? first rest
 		  length map for-each reverse append list list-ref fold
-		  symbol?
+		  symbol? string->symbol symbol->string
 		  apply))
diff --git a/collects/deinprogramm/DMdA-vanilla.ss b/collects/deinprogramm/DMdA-vanilla.ss
index 57e2ba777f..42eeac7356 100644
--- a/collects/deinprogramm/DMdA-vanilla.ss
+++ b/collects/deinprogramm/DMdA-vanilla.ss
@@ -17,5 +17,5 @@
 		  quote eq? equal?
 		  set!
 		  define-record-procedures-2
-		  symbol?
+		  symbol? string->symbol symbol->string
 		  apply))
diff --git a/collects/deinprogramm/DMdA.ss b/collects/deinprogramm/DMdA.ss
index a70bddc899..de333e253e 100644
--- a/collects/deinprogramm/DMdA.ss
+++ b/collects/deinprogramm/DMdA.ss
@@ -316,7 +316,9 @@
   (symbol? (%a -> boolean)
 	   "feststellen, ob ein Wert ein Symbol ist")
   (symbol->string (symbol -> string)
-		  "Symbol in Zeichenkette umwandeln"))
+		  "Symbol in Zeichenkette umwandeln")
+  (string->symbol (string -> symbol)
+		  "Zeichenkette in Symbol umwandeln"))
  
  ("Verschiedenes"
   (equal? (%a %b -> boolean)

From b2bcfdbec907c5a79efb14631a2d61dc7eae776f Mon Sep 17 00:00:00 2001
From: John Clements <clements@racket-lang.org>
Date: Sat, 28 Nov 2009 02:31:17 +0000
Subject: [PATCH 023/136] updated srfi 19 tests from dave gurnell

svn: r17084
---
 collects/tests/srfi/19/tests.ss | 282 +++++++++++++++-----------------
 1 file changed, 135 insertions(+), 147 deletions(-)

diff --git a/collects/tests/srfi/19/tests.ss b/collects/tests/srfi/19/tests.ss
index c6fa05db59..c12248d6bf 100644
--- a/collects/tests/srfi/19/tests.ss
+++ b/collects/tests/srfi/19/tests.ss
@@ -1,74 +1,84 @@
-(module tests mzscheme
+#lang scheme/base
 
-  ;; Tests by Will Fitzgerald, augmented by John Clements -- 2004-08-16
+;; Tests by Will Fitzgerald, augmented by:
+;;   John Clements                             -- 2004-08-16
+;;   Dave Gurnell (string->date, date->string) -- 2007-09-14 
+;;   Dave Gurnell (time{=,<,>,<=,>=}?)         -- 2009-11-26
 
-  ;; Updated to SchemeUnit 2 syntax by Dave Gurnell -- 2007-09-14
+(require srfi/19/time)
 
-  (require srfi/19/time)
+(require schemeunit/test
+         schemeunit/text-ui)
 
-  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
-           (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
+(define-check (check-comparisons comparison times expected)
+  (for ([time0    (in-list times)]
+        [expected (in-list expected)])
+    (for ([time1    (in-list times)]
+          [expected (in-list expected)])
+      (with-check-info (['comparison comparison]
+                        ['time0      time0]
+                        ['time1      time1])
+        (let ([actual (comparison time0 time1)])
+          (check-equal? actual expected))))))
 
-  (define cur-tz (date-zone-offset (current-date)))
-  
-  ; Test suite -----------------------------------
+(define cur-tz (date-zone-offset (current-date)))
 
-  (define srfi-19-test-suite
-    (test-suite
-     "Tests for SRFI 19"
+; Test suite -------------------------------------
 
-     (test-not-exn
-      "Creating time structures"
+(define srfi-19-test-suite
+  (test-suite "Tests for SRFI 19"
+    
+    (test-not-exn "Creating time structures"
       (lambda ()
         (list (current-time 'time-tai)
               (current-time 'time-utc)
               (current-time 'time-monotonic)
               (current-time 'time-thread)
               (current-time 'time-process))))
-
-     (test-not-exn
-      "Testing time resolutions"
+    
+    (test-not-exn "Testing time resolutions"
       (lambda ()
         (list (time-resolution 'time-tai)
               (time-resolution 'time-utc)
               (time-resolution 'time-monotonic)
               (time-resolution 'time-thread)
               (time-resolution 'time-process))))
-
-     (test-case 
-      "Time comparisons (time=?, etc.)"
-      (let ((t1 (make-time 'time-utc 0 1))
-            (t2 (make-time 'time-utc 0 1))
-            (t3 (make-time 'time-utc 0 2))
-            (t11 (make-time 'time-utc 1001 1))
-            (t12 (make-time 'time-utc 1001 1))
-            (t13 (make-time 'time-utc 1001 2)))
-        (check time=? t1 t2)
-        (check time>? t3 t2)
-        (check time<? t2 t3)
-        (check time>=? t1 t2)
-        (check time>=? t3 t2)
-        (check time<=? t1 t2)
-        (check time<=? t2 t3)
-        (check time=? t11 t12)
-        (check time>? t13 t12)
-        (check time<? t12 t13)
-        (check time>=? t11 t12)
-        (check time>=? t13 t12)
-        (check time<=? t11 t12)
-        (check time<=? t12 t13)))
-
-     (test-case
-      "Time difference"
+    
+    (test-case "Time comparisons (time=?, etc.)"
+      (let ([t0 (make-time 'time-utc 0 1)]
+            [t1 (make-time 'time-utc 0 1)]
+            [t2 (make-time 'time-utc 1 1)]
+            [t3 (make-time 'time-utc 0 2)])
+        (check-comparisons time=?  (list t0 t1 t2 t3) '((#t #t #f #f)
+                                                        (#t #t #f #f)
+                                                        (#f #f #t #f)
+                                                        (#f #f #f #t)))
+        (check-comparisons time<?  (list t0 t1 t2 t3) '((#f #f #t #t)
+                                                        (#f #f #t #t)
+                                                        (#f #f #f #t)
+                                                        (#f #f #f #f)))
+        (check-comparisons time>?  (list t0 t1 t2 t3) '((#f #f #f #f)
+                                                        (#f #f #f #f)
+                                                        (#t #t #f #f)
+                                                        (#t #t #t #f)))
+        (check-comparisons time<=? (list t0 t1 t2 t3) '((#t #t #t #t)
+                                                        (#t #t #t #t)
+                                                        (#f #f #t #t)
+                                                        (#f #f #f #t)))
+        (check-comparisons time>=? (list t0 t1 t2 t3) '((#t #t #f #f)
+                                                        (#t #t #f #f)
+                                                        (#t #t #t #f)
+                                                        (#t #t #t #t)))))
+    
+    (test-case "Time difference"
       (let ((t1 (make-time 'time-utc 0 3000))
             (t2 (make-time 'time-utc 0 1000))
             (t3 (make-time 'time-duration 0 2000))
             (t4 (make-time 'time-duration 0 -2000)))
         (check time=? t3 (time-difference t1 t2))
         (check time=? t4 (time-difference t2 t1))))
-
-     (test-case
-      "TAI-UTC Conversions"
+    
+    (test-case "TAI-UTC Conversions"
       (check-one-utc-tai-edge 915148800  32 31)
       (check-one-utc-tai-edge 867715200  31 30)
       (check-one-utc-tai-edge 820454400  30 29)
@@ -95,15 +105,8 @@
       (check-one-utc-tai-edge 0           0 0)   ;; at the epoch
       (check-one-utc-tai-edge 10          0 0)   ;; close to it ...
       (check-one-utc-tai-edge 1045789645 32 32)) ;; about now ...
-
-     (test-case
-      "time-second"
-      (check-equal? (time-second (make-time 'time-duration 34 52)) 52)
-      (check-equal? (time-nanosecond (make-time 'time-duration 34 52)) 34))
-     
-     
-     (test-case
-      "TAI-Date Conversions"
+    
+    (test-case "TAI-Date Conversions"
       (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0)
              (srfi:make-date 0 58 59 23 31 12 1998 0))
       (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0)
@@ -112,9 +115,8 @@
              (srfi:make-date 0 60 59 23 31 12 1998 0))
       (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0)
              (srfi:make-date 0 0 0 0 1 1 1999 0)))
-
-     (test-case 
-      "Date-UTC Conversions"
+    
+    (test-case "Date-UTC Conversions"
       (check time=? (make-time time-utc 0 (- 915148800 2))
              (date->time-utc (srfi:make-date 0 58 59 23 31 12 1998 0)))
       (check time=? (make-time time-utc 0 (- 915148800 1))
@@ -126,44 +128,36 @@
              (date->time-utc (srfi:make-date 0 0 0 0 1 1 1999 0)))
       (check time=? (make-time time-utc 0 (+ 915148800 1))
              (date->time-utc (srfi:make-date 0 1 0 0 1 1 1999 0))))
-
-     (test-case 
-      "TZ Offset conversions"
+    
+    (test-case "TZ Offset conversions"
       (let ((ct-utc (make-time time-utc 6320000 1045944859))
             (ct-tai (make-time time-tai 6320000 1045944891))
             (cd (srfi:make-date 6320000 19 14 15 22 2 2003 -18000)))
         (check time=? ct-utc (date->time-utc cd))
         (check time=? ct-tai (date->time-tai cd))))
-
-     
-     ;; NOTE: documentation doesn't fully specify, e.g., zero-padding on ~c option, so I'm just going 
-     ;; to change the test case to match the implementation...
-     (test-case
-      "date->string conversions"
+    
+    
+    ;; NOTE: documentation doesn't fully specify, e.g., zero-padding on ~c option, so I'm just going 
+    ;; to change the test case to match the implementation...
+    (test-case "date->string conversions"
       (check-equal? (date->string (srfi:make-date 1000 2 3 4 5 6 2007 (* 60 -120))
                                   "~~ @ ~a @ ~A @ ~b @ ~B @ ~c @ ~d @ ~D @ ~e @ ~f @ ~h @ ~H")
-                    "~ @ Tue @ Tuesday @ Jun @ June @ Tue Jun 05 04:03:02-0200 2007 @ 05 @ 06/05/07 @  5 @ 02.000001 @ Jun @ 04")
-      (check-equal? (date->string (srfi:make-date 1000 2 3 4 5 6 2007 (* 60 -120))
-                                  "~4")
-                    "2007-06-05T04:03:02-0200"))
-     
-
-     ;; looks like these tests need to ignore the time zone. -- JBC, 2009-08-27
-
-     (test-case
-      "[DJG] date->string conversions of dates with nanosecond components"
-      (check-equal? (date->string (srfi:make-date 123456789 2 3 4 5 6 2007 cur-tz) "~N") "123456789")
-      (check-equal? (date->string (srfi:make-date 12345678  2 3 4 5 6 2007 cur-tz) "~N") "012345678")
-      (check-equal? (date->string (srfi:make-date 1234567   2 3 4 5 6 2007 cur-tz) "~N") "001234567")
-      (check-equal? (date->string (srfi:make-date 123456    2 3 4 5 6 2007 cur-tz) "~N") "000123456")
-      (check-equal? (date->string (srfi:make-date 12345     2 3 4 5 6 2007 cur-tz) "~N") "000012345")
-      (check-equal? (date->string (srfi:make-date 1234      2 3 4 5 6 2007 cur-tz) "~N") "000001234")
-      (check-equal? (date->string (srfi:make-date 123       2 3 4 5 6 2007 cur-tz) "~N") "000000123")
-      (check-equal? (date->string (srfi:make-date 12        2 3 4 5 6 2007 cur-tz) "~N") "000000012")
-      (check-equal? (date->string (srfi:make-date 1         2 3 4 5 6 2007 cur-tz) "~N") "000000001"))
-      
-     (test-case
-      "[DJG] string->date conversions of dates with nanosecond components"
+                    "~ @ Tue @ Tuesday @ Jun @ June @ Tue Jun 05 04:03:02-0200 2007 @ 05 @ 06/05/07 @  5 @ 02.000001 @ Jun @ 04"))
+    
+    
+    
+    (test-case "[DJG] date->string conversions of dates with nanosecond components"
+      (check-equal? (date->string (srfi:make-date 123456789 2 3 4 5 6 2007 0) "~N") "123456789")
+      (check-equal? (date->string (srfi:make-date 12345678  2 3 4 5 6 2007 0) "~N") "012345678")
+      (check-equal? (date->string (srfi:make-date 1234567   2 3 4 5 6 2007 0) "~N") "001234567")
+      (check-equal? (date->string (srfi:make-date 123456    2 3 4 5 6 2007 0) "~N") "000123456")
+      (check-equal? (date->string (srfi:make-date 12345     2 3 4 5 6 2007 0) "~N") "000012345")
+      (check-equal? (date->string (srfi:make-date 1234      2 3 4 5 6 2007 0) "~N") "000001234")
+      (check-equal? (date->string (srfi:make-date 123       2 3 4 5 6 2007 0) "~N") "000000123")
+      (check-equal? (date->string (srfi:make-date 12        2 3 4 5 6 2007 0) "~N") "000000012")
+      (check-equal? (date->string (srfi:make-date 1         2 3 4 5 6 2007 0) "~N") "000000001"))
+    
+    (test-case "[DJG] string->date conversions of dates with nanosecond components"
       (check-equal? (string->date "12:00:00.123456789" "~H:~M:~S.~N") (srfi:make-date 123456789 0 0 12 #t #t #t cur-tz) "check 1")
       (check-equal? (string->date "12:00:00.12345678"  "~H:~M:~S.~N") (srfi:make-date 123456780 0 0 12 #t #t #t cur-tz) "check 2")
       (check-equal? (string->date "12:00:00.1234567"   "~H:~M:~S.~N") (srfi:make-date 123456700 0 0 12 #t #t #t cur-tz) "check 3")
@@ -182,73 +176,67 @@
       (check-equal? (string->date "12:00:00.000000123" "~H:~M:~S.~N") (srfi:make-date 123       0 0 12 #t #t #t cur-tz) "check 16")
       (check-equal? (string->date "12:00:00.000000012" "~H:~M:~S.~N") (srfi:make-date 12        0 0 12 #t #t #t cur-tz) "check 17")
       (check-equal? (string->date "12:00:00.000000001" "~H:~M:~S.~N") (srfi:make-date 1         0 0 12 #t #t #t cur-tz) "check 18"))
-      
-     (test-case
-      "date<->julian-day conversion"
+    
+    (test-case "date<->julian-day conversion"
       (check = 365 (- (date->julian-day (srfi:make-date 0 0 0 0 1 1 2004 0))
                       (date->julian-day (srfi:make-date 0 0 0 0 1 1 2003 0))))
       (let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)])
         (check tm:date= test-date (julian-day->date (date->julian-day test-date) -7200))))
-
-     (test-case
-      "date->modified-julian-day conversion"
+    
+    (test-case "date->modified-julian-day conversion"
       (check = 365 (- (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2004 0))
                       (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2003 0))))
       (let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)])
-        (check tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200))))
+        (check tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200))))))
 
-     ))
+; Helper checks and procedures -----------------
 
-  ; Helper checks and procedures -----------------
+(define-check (check-one-utc-tai-edge utc tai-diff tai-last-diff)
+  (let* (;; right on the edge they should be the same
+         (utc-basic (make-time 'time-utc 0 utc))
+         (tai-basic (make-time 'time-tai 0 (+ utc tai-diff)))
+         (utc->tai-basic (time-utc->time-tai utc-basic))
+         (tai->utc-basic (time-tai->time-utc tai-basic))
+         
+         ;; a second before they should be the old diff
+         (utc-basic-1 (make-time 'time-utc 0 (- utc 1)))
+         (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1)))
+         (utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
+         (tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
+         
+         ;; a second later they should be the new diff
+         (utc-basic+1 (make-time 'time-utc 0 (+ utc 1)))
+         (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1)))
+         (utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
+         (tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
+         
+         ;; ok, let's move the clock half a month or so plus half a second
+         (shy (* 15 24 60 60))
+         (hs (/ (expt 10 9) 2))
+         ;; a second later they should be the new diff
+         (utc-basic+2 (make-time 'time-utc hs (+ utc shy)))
+         (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy)))
+         (utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
+         (tai->utc-basic+2 (time-tai->time-utc tai-basic+2)))
+    
+    (check time=? utc-basic tai->utc-basic)
+    (check time=? tai-basic utc->tai-basic)
+    (check time=? utc-basic-1 tai->utc-basic-1)
+    (check time=? tai-basic-1 utc->tai-basic-1)
+    (check time=? utc-basic+1 tai->utc-basic+1)
+    (check time=? tai-basic+1 utc->tai-basic+1)
+    (check time=? utc-basic+2 tai->utc-basic+2)
+    (check time=? tai-basic+2 utc->tai-basic+2)))
 
-  (define-check (check-one-utc-tai-edge utc tai-diff tai-last-diff)
-    (let* (;; right on the edge they should be the same
-           (utc-basic (make-time 'time-utc 0 utc))
-           (tai-basic (make-time 'time-tai 0 (+ utc tai-diff)))
-           (utc->tai-basic (time-utc->time-tai utc-basic))
-           (tai->utc-basic (time-tai->time-utc tai-basic))
+(define (tm:date= d1 d2)
+  (and (= (srfi:date-year d1) (srfi:date-year d2))
+       (= (srfi:date-month d1) (srfi:date-month d2))
+       (= (srfi:date-day d1) (srfi:date-day d2))
+       (= (srfi:date-hour d1) (srfi:date-hour d2))
+       (= (srfi:date-second d1) (srfi:date-second d2))
+       (= (date-nanosecond d1) (date-nanosecond d2))
+       (= (date-zone-offset d1) (date-zone-offset d2))))
 
-           ;; a second before they should be the old diff
-           (utc-basic-1 (make-time 'time-utc 0 (- utc 1)))
-           (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1)))
-           (utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
-           (tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
+; Main module body -------------------------------
 
-           ;; a second later they should be the new diff
-           (utc-basic+1 (make-time 'time-utc 0 (+ utc 1)))
-           (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1)))
-           (utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
-           (tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
-
-           ;; ok, let's move the clock half a month or so plus half a second
-           (shy (* 15 24 60 60))
-           (hs (/ (expt 10 9) 2))
-           ;; a second later they should be the new diff
-           (utc-basic+2 (make-time 'time-utc hs (+ utc shy)))
-           (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy)))
-           (utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
-           (tai->utc-basic+2 (time-tai->time-utc tai-basic+2)))
-
-      (check time=? utc-basic tai->utc-basic)
-      (check time=? tai-basic utc->tai-basic)
-      (check time=? utc-basic-1 tai->utc-basic-1)
-      (check time=? tai-basic-1 utc->tai-basic-1)
-      (check time=? utc-basic+1 tai->utc-basic+1)
-      (check time=? tai-basic+1 utc->tai-basic+1)
-      (check time=? utc-basic+2 tai->utc-basic+2)
-      (check time=? tai-basic+2 utc->tai-basic+2)))
-
-  (define (tm:date= d1 d2)
-    (and (= (srfi:date-year d1) (srfi:date-year d2))
-         (= (srfi:date-month d1) (srfi:date-month d2))
-         (= (srfi:date-day d1) (srfi:date-day d2))
-         (= (srfi:date-hour d1) (srfi:date-hour d2))
-         (= (srfi:date-second d1) (srfi:date-second d2))
-         (= (date-nanosecond d1) (date-nanosecond d2))
-         (= (date-zone-offset d1) (date-zone-offset d2))))
-
-  ; Main module body -----------------------------
-
-  (test/text-ui srfi-19-test-suite)
-
-  )
+(run-tests srfi-19-test-suite)

From baa2e21fd22c93be757e616a1c01ab9e27d8ce59 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 28 Nov 2009 08:50:54 +0000
Subject: [PATCH 024/136] Welcome to a new PLT day.

svn: r17085
---
 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 79530a31a2..3d20560f81 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "27nov2009")
+#lang scheme/base (provide stamp) (define stamp "28nov2009")

From 45b979421a8f092766bbb5a659a0ceb9ec5de03e Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 29 Nov 2009 01:50:59 +0000
Subject: [PATCH 025/136] fix sequential-only processor-count

svn: r17091
---
 src/mzscheme/src/future.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c
index 4cd5930ec5..44372d4111 100644
--- a/src/mzscheme/src/future.c
+++ b/src/mzscheme/src/future.c
@@ -139,7 +139,7 @@ void scheme_init_futures(Scheme_Env *env)
   FUTURE_PRIM_W_ARITY("future?",          future_p,         1, 1, newenv);
   FUTURE_PRIM_W_ARITY("future",           future,           1, 1, newenv);
   FUTURE_PRIM_W_ARITY("touch",            touch,            1, 1, newenv);
-  FUTURE_PRIM_W_ARITY("processor-count",  processor_count,  1, 1, newenv);
+  FUTURE_PRIM_W_ARITY("processor-count",  processor_count,  0, 0, newenv);
 
   scheme_finish_primitive_module(newenv);
   scheme_protect_primitive_provide(newenv, NULL);

From 1cb4f3884fdb938ace179b8059689d87b07fe9b7 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sun, 29 Nov 2009 08:50:48 +0000
Subject: [PATCH 026/136] Welcome to a new PLT day.

svn: r17092
---
 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 3d20560f81..a577909113 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "28nov2009")
+#lang scheme/base (provide stamp) (define stamp "29nov2009")

From 06288a8b7fa26d4ef930c812980bda756e8daf46 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 29 Nov 2009 15:53:08 +0000
Subject: [PATCH 027/136] procedure-rename special treatment of struct
 accessors & mutators

svn: r17093
---
 .../scribblings/reference/procedures.scrbl    | 12 +++++++++-
 src/mzscheme/src/fun.c                        |  5 +++-
 src/mzscheme/src/schpriv.h                    |  2 ++
 src/mzscheme/src/struct.c                     | 23 +++++++++++++++++++
 4 files changed, 40 insertions(+), 2 deletions(-)

diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl
index 1332e6707e..7d5063cfdd 100644
--- a/collects/scribblings/reference/procedures.scrbl
+++ b/collects/scribblings/reference/procedures.scrbl
@@ -53,8 +53,18 @@ result is @scheme[values].
 
 Returns a procedure that is like @scheme[proc], except that its name
 as returned by @scheme[object-name] (and as printed for debugging) is
-@scheme[name].}
+@scheme[name].
 
+The given @scheme[name] is used for printing an error message if the
+resulting procedure is applied to the wrong number of arguments.  In
+addition, if @scheme[proc] is an @tech{accessor} or @tech{mutator}
+produced by @scheme[define-struct],
+@scheme[make-struct-field-accessor], or
+@scheme[make-struct-field-mutator], the resulting procedure also uses
+@scheme[name] when its (first) argument has the wrong type. More
+typically, however, @scheme[name] is not used for reporting errors,
+since the procedure name is typically hard-wired into an internal
+check.}
 
 @; ----------------------------------------
 @section{Keywords and Arity}
diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c
index 6354dbaeb0..da5af9f491 100644
--- a/src/mzscheme/src/fun.c
+++ b/src/mzscheme/src/fun.c
@@ -3661,13 +3661,16 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
 
 static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])
 {
-  Scheme_Object *aty;
+  Scheme_Object *p, *aty;
 
   if (!SCHEME_PROCP(argv[0]))
     scheme_wrong_type("procedure-rename", "procedure", 0, argc, argv);
   if (!SCHEME_SYMBOLP(argv[1]))
     scheme_wrong_type("procedure-rename", "symbol", 1, argc, argv);
 
+  p = scheme_rename_struct_proc(argv[0], argv[1]);
+  if (p) return p;
+
   aty = get_or_check_arity(argv[0], -1, NULL);  
 
   return make_reduced_proc(argv[0], aty, argv[1]);
diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h
index 5c4c3b6989..ae18b4d728 100644
--- a/src/mzscheme/src/schpriv.h
+++ b/src/mzscheme/src/schpriv.h
@@ -689,6 +689,8 @@ Scheme_Object *scheme_clone_prefab_struct_instance(Scheme_Structure *s);
 
 Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv);
 
+Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym);
+
 /*========================================================================*/
 /*                         syntax objects                                 */
 /*========================================================================*/
diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c
index 922ee76e37..3499e7c5b6 100644
--- a/src/mzscheme/src/struct.c
+++ b/src/mzscheme/src/struct.c
@@ -2779,6 +2779,29 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
   return p;
 }
 
+Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym)
+{
+  if (SCHEME_PRIMP(p)) {
+    int is_getter = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER);
+    int is_setter = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER);
+    
+    if (is_getter || is_setter) {
+      const char *func_name;
+      Struct_Proc_Info *i;
+
+      func_name = scheme_symbol_name(sym);
+      
+      i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(p)[0];
+      
+      return make_struct_proc(i->struct_type, (char *)func_name, 
+                              is_getter ? SCHEME_GETTER : SCHEME_SETTER,
+                              i->field);
+    }
+  }
+
+  return NULL;
+}
+
 static Scheme_Object *make_name(const char *pre, const char *tn, int ltn,
 				const char *post1, const char *fn, int lfn,
 				const char *post2, int sym)

From 06f231a0a7d2abaec4dd15994401e587ad59c4c0 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 30 Nov 2009 02:52:43 +0000
Subject: [PATCH 028/136] JIT tweaks

svn: r17102
---
 src/mzscheme/src/jit.c | 306 +++++++++++++++++++++++------------------
 1 file changed, 169 insertions(+), 137 deletions(-)

diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c
index 2dfb220d94..1880d9773b 100644
--- a/src/mzscheme/src/jit.c
+++ b/src/mzscheme/src/jit.c
@@ -207,7 +207,7 @@ typedef Scheme_Object *(*Native_Get_Arity_Proc)(Scheme_Object *o, int dumm1, int
 static Native_Check_Arity_Proc check_arity_code;
 static Native_Get_Arity_Proc get_arity_code;
 
-static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int need_ends);
+static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int need_ends, int ignored);
 static int generate(Scheme_Object *obj, mz_jit_state *jitter, int tail_ok, int multi_ok, int target);
 static void *generate_lambda_simple_arity_check(int num_params, int has_rest, int is_method, int permanent);
 static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Data *ndata, 
@@ -2098,17 +2098,25 @@ static int is_constant_and_avoids_r1(Scheme_Object *obj)
     return (t >= _scheme_compiled_values_types_);
 }
 
-static int avoids_r1(Scheme_Object *obj)
+static int is_relatively_constant_and_avoids_r1(Scheme_Object *obj, Scheme_Object *wrt)
 {
-  Scheme_Type t = SCHEME_TYPE(obj);
+  Scheme_Type t;
 
-  if (SAME_TYPE(t, scheme_toplevel_type)) {
+  if (is_constant_and_avoids_r1(obj))
     return 1;
-  } else if (SAME_TYPE(t, scheme_local_type)
-             || SAME_TYPE(t, scheme_local_unbox_type)) {
-    return 1;
-  } else
-    return is_constant_and_avoids_r1(obj);
+
+  t = SCHEME_TYPE(obj);
+  if (SAME_TYPE(t, scheme_local_type)) {
+    /* Must have clearing or other-clears flag set */
+    Scheme_Type t2 = SCHEME_TYPE(wrt);
+    if (t2 == scheme_local_type) {
+      /* If different local vars, then order doesn't matter */
+      if (SCHEME_LOCAL_POS(wrt) != SCHEME_LOCAL_POS(obj))
+        return 1;
+    }
+  }
+
+  return 0;
 }
 
 /*========================================================================*/
@@ -3396,7 +3404,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
       need_safety = 0;
     }
 
-    generate_non_tail(rator, jitter, 0, !need_non_tail); /* sync'd after args below */
+    generate_non_tail(rator, jitter, 0, !need_non_tail, 0); /* sync'd after args below */
     CHECK_LIMIT();
 
     if (num_rands) {
@@ -3432,7 +3440,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
       CHECK_LIMIT();
       need_safety = 0;
     }
-    generate_non_tail(arg, jitter, 0, !need_non_tail); /* sync'd below */
+    generate_non_tail(arg, jitter, 0, !need_non_tail, 0); /* sync'd below */
     RESUME_JIT_DATA();
     CHECK_LIMIT();
     if ((i == num_rands - 1) && !direct_prim && !reorder_ok && !direct_self && !proc_already_in_place) {
@@ -4163,7 +4171,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
 
       if (rand2 && !simple_rand && !simple_rand2) {
         mz_runstack_skipped(jitter, 1);
-        generate_non_tail(rand, jitter, 0, 1); /* sync'd later */
+        generate_non_tail(rand, jitter, 0, 1, 0); /* sync'd later */
         CHECK_LIMIT();
         mz_runstack_unskipped(jitter, 1);
         mz_rs_dec(1);
@@ -4177,14 +4185,14 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
         if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type))
           generate(rand, jitter, 0, 0, JIT_R1); /* sync'd below */
         else {
-          generate_non_tail(rand, jitter, 0, 1); /* sync'd below */
+          generate_non_tail(rand, jitter, 0, 1, 0); /* sync'd below */
           CHECK_LIMIT();
           jit_movr_p(JIT_R1, JIT_R0);
         }
         CHECK_LIMIT();
         generate(rand2, jitter, 0, 0, JIT_R0); /* sync'd below */
       } else {
-        generate_non_tail(rand2 ? rand2 : rand, jitter, 0, 1); /* sync'd below */
+        generate_non_tail(rand2 ? rand2 : rand, jitter, 0, 1, 0); /* sync'd below */
       }
       CHECK_LIMIT();
       /* sync'd in three branches below */
@@ -4369,10 +4377,11 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
           if (arith == 1) {
             jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
             if (unsafe_fx && !overflow_refslow)
-              jit_addr_l(JIT_R2, JIT_R2, JIT_R0);
-            else
+              jit_addr_l(JIT_R0, JIT_R2, JIT_R0);
+            else {
               (void)jit_boaddr_l(refslow, JIT_R2, JIT_R0);
-            jit_movr_p(JIT_R0, JIT_R2);
+              jit_movr_p(JIT_R0, JIT_R2);
+            }
           } else if (arith == -1) {
             if (reversed) {
               jit_movr_p(JIT_R2, JIT_R0);
@@ -4521,12 +4530,13 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
         } else {
           /* Non-constant arg is in JIT_R0 */
           if (arith == 1) {
-            jit_movr_p(JIT_R2, JIT_R0);
             if (unsafe_fx && !overflow_refslow)
-              jit_addi_l(JIT_R2, JIT_R2, v << 1);
-            else
+              jit_addi_l(JIT_R0, JIT_R0, v << 1);
+            else {
+              jit_movr_p(JIT_R2, JIT_R0);
               (void)jit_boaddi_l(refslow, JIT_R2, v << 1);
-            jit_movr_p(JIT_R0, JIT_R2);
+              jit_movr_p(JIT_R0, JIT_R2);
+            }
           } else if (arith == -1) {
             if (reversed) {
               (void)jit_movi_p(JIT_R2, scheme_make_integer(v));
@@ -4536,12 +4546,13 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
                 (void)jit_bosubr_l(refslow, JIT_R2, JIT_R0);
               jit_addi_ul(JIT_R0, JIT_R2, 0x1);
             } else {
-              jit_movr_p(JIT_R2, JIT_R0);
               if (unsafe_fx && !overflow_refslow)
-                jit_subi_l(JIT_R2, JIT_R2, v << 1);
-              else
+                jit_subi_l(JIT_R0, JIT_R0, v << 1);
+              else {
+                jit_movr_p(JIT_R2, JIT_R0);
                 (void)jit_bosubi_l(refslow, JIT_R2, v << 1);
-              jit_movr_p(JIT_R0, JIT_R2);
+                jit_movr_p(JIT_R0, JIT_R2);
+              }
             }
           } else if (arith == 2) {
             if (v == 1) {
@@ -5047,7 +5058,7 @@ static int generate_inlined_constant_test(mz_jit_state *jitter, Scheme_App2_Rec
 
   mz_runstack_skipped(jitter, 1);
 
-  generate_non_tail(app->rand, jitter, 0, 1);
+  generate_non_tail(app->rand, jitter, 0, 1, 0);
   CHECK_LIMIT();
 
   mz_runstack_unskipped(jitter, 1);
@@ -5092,7 +5103,7 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
 
   mz_runstack_skipped(jitter, 1);
 
-  generate_non_tail(app->rand, jitter, 0, 1);
+  generate_non_tail(app->rand, jitter, 0, 1, 0);
   CHECK_LIMIT();
 
   mz_runstack_unskipped(jitter, 1);
@@ -5302,7 +5313,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
     mz_runstack_skipped(jitter, 1);
     
-    generate_non_tail(app->rand, jitter, 0, 1);
+    generate_non_tail(app->rand, jitter, 0, 1, 0);
     CHECK_LIMIT();
 
     mz_runstack_unskipped(jitter, 1);
@@ -5375,7 +5386,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
       mz_runstack_skipped(jitter, 1);
 
-      generate_non_tail(app->rand, jitter, 0, 1);
+      generate_non_tail(app->rand, jitter, 0, 1, 0);
       CHECK_LIMIT();
 
       mz_runstack_unskipped(jitter, 1);
@@ -5444,7 +5455,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
       mz_runstack_skipped(jitter, 1);
 
-      generate_non_tail(app->rand, jitter, 0, 1);
+      generate_non_tail(app->rand, jitter, 0, 1, 0);
       CHECK_LIMIT();
 
       mz_runstack_unskipped(jitter, 1);
@@ -5485,7 +5496,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
       mz_runstack_skipped(jitter, 1);
 
-      generate_non_tail(app->rand, jitter, 0, 1);
+      generate_non_tail(app->rand, jitter, 0, 1, 0);
       CHECK_LIMIT();
 
       mz_runstack_unskipped(jitter, 1);
@@ -5506,7 +5517,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
       mz_runstack_skipped(jitter, 1);
 
-      generate_non_tail(app->rand, jitter, 0, 1);
+      generate_non_tail(app->rand, jitter, 0, 1, 0);
       CHECK_LIMIT();
 
       mz_runstack_unskipped(jitter, 1);
@@ -5539,7 +5550,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
       mz_runstack_skipped(jitter, 1);
 
-      generate_non_tail(app->rand, jitter, 0, 1);
+      generate_non_tail(app->rand, jitter, 0, 1, 0);
       CHECK_LIMIT();
 
       mz_runstack_unskipped(jitter, 1);
@@ -5559,7 +5570,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
       mz_runstack_skipped(jitter, 1);
 
-      generate_non_tail(app->rand, jitter, 0, 1);
+      generate_non_tail(app->rand, jitter, 0, 1, 0);
       CHECK_LIMIT();
 
       mz_runstack_unskipped(jitter, 1);
@@ -5587,7 +5598,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
       mz_runstack_skipped(jitter, 1);
 
-      generate_non_tail(app->rand, jitter, 0, 1);
+      generate_non_tail(app->rand, jitter, 0, 1, 0);
       CHECK_LIMIT();
 
       mz_runstack_unskipped(jitter, 1);
@@ -5600,7 +5611,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
       mz_runstack_skipped(jitter, 1);
 
-      generate_non_tail(app->rand, jitter, 0, 1);
+      generate_non_tail(app->rand, jitter, 0, 1, 0);
       CHECK_LIMIT();
 
       mz_runstack_unskipped(jitter, 1);
@@ -5646,13 +5657,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
     } else if (IS_NAMED_PRIM(rator, "list*")) {
       /* on a single argument, `list*' is identity */
       mz_runstack_skipped(jitter, 1);
-      generate_non_tail(app->rand, jitter, 0, 1);
+      generate_non_tail(app->rand, jitter, 0, 1, 0);
       CHECK_LIMIT();
       mz_runstack_unskipped(jitter, 1);
       return 1;
     } else if (IS_NAMED_PRIM(rator, "list")) {
       mz_runstack_skipped(jitter, 1);
-      generate_non_tail(app->rand, jitter, 0, 1);
+      generate_non_tail(app->rand, jitter, 0, 1, 0);
       CHECK_LIMIT();
       mz_rs_sync();
       mz_runstack_unskipped(jitter, 1);
@@ -5660,7 +5671,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
       return generate_cons_alloc(jitter, 0, 0);
     } else if (IS_NAMED_PRIM(rator, "box")) {
       mz_runstack_skipped(jitter, 1);
-      generate_non_tail(app->rand, jitter, 0, 1);
+      generate_non_tail(app->rand, jitter, 0, 1, 0);
       CHECK_LIMIT();
       mz_runstack_unskipped(jitter, 1);
       mz_rs_sync();
@@ -5704,14 +5715,14 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
 {
   int simple1, simple2, direction = 1;
   
-  simple1 = is_constant_and_avoids_r1(rand1);
-  simple2 = is_constant_and_avoids_r1(rand2);
+  simple1 = is_relatively_constant_and_avoids_r1(rand1, rand2);
+  simple2 = is_relatively_constant_and_avoids_r1(rand2, rand1);
 
   if (!simple1) {
     if (simple2) {
       mz_runstack_skipped(jitter, skipped);
 
-      generate_non_tail(rand1, jitter, 0, 1); /* no sync... */
+      generate_non_tail(rand1, jitter, 0, 1, 0); /* no sync... */
       CHECK_LIMIT();
       jit_movr_p(JIT_R1, JIT_R0);
 
@@ -5729,7 +5740,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
       mz_runstack_unskipped(jitter, skipped);
     } else {
       mz_runstack_skipped(jitter, skipped);
-      generate_non_tail(rand1, jitter, 0, 1); /* no sync... */
+      generate_non_tail(rand1, jitter, 0, 1, 0); /* no sync... */
       CHECK_LIMIT();
       mz_runstack_unskipped(jitter, skipped);
 
@@ -5739,7 +5750,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
       mz_rs_str(JIT_R0);
       mz_runstack_skipped(jitter, skipped-1);
 
-      generate_non_tail(rand2, jitter, 0, 1); /* no sync... */
+      generate_non_tail(rand2, jitter, 0, 1, 0); /* no sync... */
       CHECK_LIMIT();
 
       jit_movr_p(JIT_R1, JIT_R0);
@@ -5756,7 +5767,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
       generate(rand2, jitter, 0, 0, JIT_R1); /* no sync... */
       CHECK_LIMIT();
     } else {
-      generate_non_tail(rand2, jitter, 0, 1); /* no sync... */
+      generate_non_tail(rand2, jitter, 0, 1, 0); /* no sync... */
       CHECK_LIMIT();
       jit_movr_p(JIT_R1, JIT_R0);
     }
@@ -5960,7 +5971,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
 
       mz_runstack_skipped(jitter, 2);
 
-      generate_non_tail(a2, jitter, 0, 1);
+      generate_non_tail(a2, jitter, 0, 1, 0);
       CHECK_LIMIT();
       if (need_sync) mz_rs_sync();
       
@@ -6226,7 +6237,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
 
         mz_runstack_skipped(jitter, 2);
       
-        generate_non_tail(app->rand1, jitter, 0, 1);
+        generate_non_tail(app->rand1, jitter, 0, 1, 0);
         CHECK_LIMIT();
 
         mz_rs_sync();
@@ -6525,7 +6536,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
         CHECK_LIMIT();
       }
 
-      generate_non_tail(app->args[1], jitter, 0, 1); /* sync'd below */
+      generate_non_tail(app->args[1], jitter, 0, 1, 0); /* sync'd below */
       CHECK_LIMIT();
       if (!constval || !simple) {
 	mz_rs_str(JIT_R0);
@@ -6534,7 +6545,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
       }
 
       if (!simple) {
-	generate_non_tail(app->args[2], jitter, 0, 1); /* sync'd below */
+	generate_non_tail(app->args[2], jitter, 0, 1, 0); /* sync'd below */
 	CHECK_LIMIT();
 	if (!constval) {
 	  mz_rs_stxi(1, JIT_R0);
@@ -6543,7 +6554,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
 	}
       }
 
-      generate_non_tail(app->args[3], jitter, 0, 1); /* sync'd below */
+      generate_non_tail(app->args[3], jitter, 0, 1, 0); /* sync'd below */
       CHECK_LIMIT();
       mz_rs_sync();
  
@@ -6631,19 +6642,34 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
 
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-set!")) {
-      if (avoids_r1(app->args[1])
-          && is_constant_and_avoids_r1(app->args[2])
-          && can_unbox(app->args[3], 5, JIT_FPR_NUM-1)) {
-        mz_runstack_skipped(jitter, 3);
+      if (can_unbox(app->args[3], 5, JIT_FPR_NUM-1)) {
+        int got_two;
+        if (is_constant_and_avoids_r1(app->args[1])
+            && is_constant_and_avoids_r1(app->args[2])) {
+          mz_runstack_skipped(jitter, 3);
+          got_two = 0;
+        } else {
+          got_two = 1;
+          mz_runstack_skipped(jitter, 1);
+          generate_app(app, NULL, 2, jitter, 0, 0, 2);
+        }
         jitter->unbox++;
         generate(app->args[3], jitter, 0, 0, JIT_R0); /* to FP reg */
         CHECK_LIMIT();
         --jitter->unbox;
         jitter->unbox_depth -= 1;
-        generate(app->args[2], jitter, 0, 0, JIT_R1);
-        CHECK_LIMIT();
-        generate(app->args[1], jitter, 0, 0, JIT_R0);
-        mz_runstack_unskipped(jitter, 3);
+        if (!got_two) {
+          generate(app->args[2], jitter, 0, 0, JIT_R1);
+          CHECK_LIMIT();
+          generate(app->args[1], jitter, 0, 0, JIT_R0);
+          mz_runstack_unskipped(jitter, 3);
+        } else {
+          mz_rs_ldr(JIT_R0);
+          mz_rs_ldxi(JIT_R1, 1);
+          mz_rs_inc(2); /* no sync */
+          mz_runstack_popped(jitter, 2);
+          mz_runstack_unskipped(jitter, 1);
+        }
       } else {
         generate_app(app, NULL, 3, jitter, 0, 0, 2);
         CHECK_LIMIT();
@@ -6796,7 +6822,7 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator,
 
   if (app2) {
     mz_runstack_skipped(jitter, 1);
-    generate_non_tail(app2->rand, jitter, 0, 1); /* sync'd below */
+    generate_non_tail(app2->rand, jitter, 0, 1, 0); /* sync'd below */
     CHECK_LIMIT();
     mz_runstack_unskipped(jitter, 1);
     c = 1;
@@ -7121,14 +7147,15 @@ static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter)
   mz_tl_sti_l(tl_scheme_current_cont_mark_pos, JIT_R2, JIT_R0);
 }
 
-static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int mark_pos_ends)
+static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, 
+                             int multi_ok, int mark_pos_ends, int ignored)
 /* de-sync's rs */
 {
   if (is_simple(obj, INIT_SIMPLE_DEPTH, 0, jitter, 0)) {
     /* Simple; doesn't change the stack or set marks: */
     int v;
     FOR_LOG(jitter->log_depth++);
-    v = generate(obj, jitter, 0, multi_ok, JIT_R0);
+    v = generate(obj, jitter, 0, multi_ok, ignored ? -1 : JIT_R0);
     FOR_LOG(--jitter->log_depth);
     return v;
   }
@@ -7163,7 +7190,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi
     PAUSE_JIT_DATA();
     FOR_LOG(jitter->log_depth++);
 
-    generate(obj, jitter, 0, multi_ok, JIT_R0); /* no sync */
+    generate(obj, jitter, 0, multi_ok, ignored ? -1 : JIT_R0); /* no sync */
 
     FOR_LOG(--jitter->log_depth);
     RESUME_JIT_DATA();
@@ -7197,28 +7224,6 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi
 /*                          expression codegen                            */
 /*========================================================================*/
 
-static int generate_ignored_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int need_ends)
-/* de-sync's */
-{
-  Scheme_Type t = SCHEME_TYPE(obj);
-
-  if (SAME_TYPE(t, scheme_local_type)
-      || SAME_TYPE(t, scheme_local_unbox_type)) {
-    /* Must be here to clear */
-    if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) {
-      int pos;
-      START_JIT_DATA();
-      pos = mz_remap(SCHEME_LOCAL_POS(obj));
-      LOG_IT(("clear %d\n", pos));
-      mz_rs_stxi(pos, JIT_RUNSTACK);
-      END_JIT_DATA(2);      
-    }
-    return 1;
-  }
-
-  return generate_non_tail(obj, jitter, multi_ok, need_ends);
-}
-
 static Scheme_Object *generate_k(void)
 {
   Scheme_Thread *p = scheme_current_thread;
@@ -7238,6 +7243,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 /* de-sync's; result goes to target */
 {
   Scheme_Type type;
+  int result_ignored, orig_target;
 
 #ifdef DO_STACK_CHECK
 # include "mzstkchk.h"
@@ -7265,34 +7271,44 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
     return SCHEME_INT_VAL(ok);
   }
 #endif
+
+  orig_target = target;
+  result_ignored = (target < 0);
+  if (target < 0) target = JIT_R0;
   
   type = SCHEME_TYPE(obj);
   switch (type) {
   case scheme_toplevel_type:
     {
-      int pos;
+      int can_fail;
       /* Other parts of the JIT rely on this code not modifying R1 */
-      START_JIT_DATA();
-      LOG_IT(("top-level\n"));
-      mz_rs_sync_fail_branch();
-      /* Load global array: */
-      pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj));
-      mz_rs_ldxi(JIT_R2, pos);
-      /* Load bucket: */
-      pos = SCHEME_TOPLEVEL_POS(obj);
-      jit_ldxi_p(JIT_R2, JIT_R2, WORDS_TO_BYTES(pos));
-      /* Extract bucket value */
-      jit_ldxi_p(target, JIT_R2, &(SCHEME_VAR_BUCKET(0x0)->val));
-      CHECK_LIMIT();
-      if (!(SCHEME_TOPLEVEL_FLAGS(obj) 
-	    & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY))) {
-	/* Is it NULL? */
-        generate_pop_unboxed(jitter);
+      can_fail = !(SCHEME_TOPLEVEL_FLAGS(obj) 
+                   & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY));
+      if (!can_fail && result_ignored) {
+        /* skip */
+      } else {
+        int pos;
+        START_JIT_DATA();
+        LOG_IT(("top-level\n"));
+        mz_rs_sync_fail_branch();
+        /* Load global array: */
+        pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj));
+        mz_rs_ldxi(JIT_R2, pos);
+        /* Load bucket: */
+        pos = SCHEME_TOPLEVEL_POS(obj);
+        jit_ldxi_p(JIT_R2, JIT_R2, WORDS_TO_BYTES(pos));
+        /* Extract bucket value */
+        jit_ldxi_p(target, JIT_R2, &(SCHEME_VAR_BUCKET(0x0)->val));
         CHECK_LIMIT();
-	(void)jit_beqi_p(unbound_global_code, target, 0);
+        if (can_fail) {
+          /* Is it NULL? */
+          generate_pop_unboxed(jitter);
+          CHECK_LIMIT();
+          (void)jit_beqi_p(unbound_global_code, target, 0);
+        }
+        if (jitter->unbox) generate_unboxing(jitter);
+        END_JIT_DATA(0);
       }
-      if (jitter->unbox) generate_unboxing(jitter);
-      END_JIT_DATA(0);
       return 1;
     }
   case scheme_local_type:
@@ -7302,11 +7318,13 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       START_JIT_DATA();
       pos = mz_remap(SCHEME_LOCAL_POS(obj));
       LOG_IT(("local %d [%d]\n", pos, SCHEME_LOCAL_FLAGS(obj)));
-      if (pos || (mz_CURRENT_STATUS() != mz_RS_R0_HAS_RUNSTACK0)) {
-        mz_rs_ldxi(target, pos);
-        VALIDATE_RESULT(target);
-      } else if (target != JIT_R0) {
-        jit_movr_p(target, JIT_R0);
+      if (!result_ignored) {
+        if (pos || (mz_CURRENT_STATUS() != mz_RS_R0_HAS_RUNSTACK0)) {
+          mz_rs_ldxi(target, pos);
+          VALIDATE_RESULT(target);
+        } else if (target != JIT_R0) {
+          jit_movr_p(target, JIT_R0);
+        }
       }
       if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) {
         mz_rs_stxi(pos, JIT_RUNSTACK);
@@ -7323,8 +7341,10 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       LOG_IT(("unbox local\n"));
 
       pos = mz_remap(SCHEME_LOCAL_POS(obj));
-      mz_rs_ldxi(JIT_R0, pos);
-      jit_ldr_p(target, JIT_R0);
+      if (!result_ignored) {
+        mz_rs_ldxi(JIT_R0, pos);
+        jit_ldr_p(target, JIT_R0);
+      }
       if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) {
         LOG_IT(("clear-on-read\n"));
         mz_rs_stxi(pos, JIT_RUNSTACK);
@@ -7363,7 +7383,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 	
 	  /* Evaluate first expression, and for consistency with bytecode
 	     evaluation, allow multiple values. */
-	  generate_non_tail(seq->array[0], jitter, 1, 1);
+	  generate_non_tail(seq->array[0], jitter, 1, 1, 0);
 	  CHECK_LIMIT();
 
 	  /* Save value(s) */
@@ -7402,7 +7422,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 	  mz_patch_branch(ref2);
 	  __END_SHORT_JUMPS__(1);
 	  for (i = 1; i < seq->count; i++) {
-	    generate_ignored_non_tail(seq->array[i], jitter, 1, 1); /* sync's below */
+	    generate_non_tail(seq->array[i], jitter, 1, 1, 1); /* sync's below */
             CHECK_LIMIT();
 	  }
 
@@ -7444,7 +7464,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 	  v = SCHEME_CAR(p);
 	  p = SCHEME_CDR(p);
 
-	  generate_non_tail(p, jitter, 0, 1);
+	  generate_non_tail(p, jitter, 0, 1, 0);
 	  CHECK_LIMIT();
           mz_rs_sync();
           
@@ -7482,7 +7502,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 	  v = SCHEME_CAR(p);
           p = SCHEME_CDR(p);
 
-          generate_non_tail(v, jitter, 0, 1);
+          generate_non_tail(v, jitter, 0, 1, 0);
 	  CHECK_LIMIT();
 
           /* If v is not known to produce a procedure, then check result: */
@@ -7496,7 +7516,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
           }
 
           mz_pushr_p(JIT_R0);
-          generate_non_tail(p, jitter, 1, 1);
+          generate_non_tail(p, jitter, 1, 1, 0);
           CHECK_LIMIT();
 
           mz_popr_p(JIT_V1);
@@ -7635,7 +7655,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 	  jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_R0);
 	  CHECK_LIMIT();
 
-	  generate(p, jitter, is_tail, multi_ok, target);
+	  generate(p, jitter, is_tail, multi_ok, orig_target);
 
 	  END_JIT_DATA(8);
 	}
@@ -7772,19 +7792,20 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       LOG_IT(("begin\n"));
 
       for (i = 0; i < cnt - 1; i++) {
-	generate_ignored_non_tail(seq->array[i], jitter, 1, 1);
+	generate_non_tail(seq->array[i], jitter, 1, 1, 1);
 	CHECK_LIMIT();
       }
 
       END_JIT_DATA(11);
 
-      return generate(seq->array[cnt - 1], jitter, is_tail, multi_ok, target);
+      return generate(seq->array[cnt - 1], jitter, is_tail, multi_ok, orig_target);
     }
   case scheme_branch_type:
     {	
       Scheme_Branch_Rec *branch = (Scheme_Branch_Rec *)obj;
       jit_insn *refs[6], *ref2;
       int nsrs, nsrs1, g1, g2, amt, need_sync;
+      int else_is_empty = 0;
 #ifdef NEED_LONG_JUMPS
       int then_short_ok, else_short_ok;
 #else
@@ -7818,9 +7839,13 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       else
         need_sync = 1;
 
+      if (result_ignored 
+          && (SCHEME_TYPE(branch->fbranch) > _scheme_compiled_values_types_))
+        else_is_empty = 1;
+
       if (!generate_inlined_test(jitter, branch->test, then_short_ok, refs, need_sync)) {
 	CHECK_LIMIT();
-	generate_non_tail(branch->test, jitter, 0, 1);
+	generate_non_tail(branch->test, jitter, 0, 1, 0);
         if (need_sync) mz_rs_sync();
 	CHECK_LIMIT();
 	__START_SHORT_JUMPS__(then_short_ok);
@@ -7835,7 +7860,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       PAUSE_JIT_DATA();
       LOG_IT(("...then...\n"));
       FOR_LOG(++jitter->log_depth);
-      g1 = generate(branch->tbranch, jitter, is_tail, multi_ok, target);
+      g1 = generate(branch->tbranch, jitter, is_tail, multi_ok, orig_target);
       RESUME_JIT_DATA();
       CHECK_LIMIT();
       amt = mz_runstack_restored(jitter);
@@ -7846,7 +7871,10 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
           if (need_sync) mz_rs_sync();
         }
 	__START_SHORT_JUMPS__(else_short_ok);
-	ref2 = jit_jmpi(jit_forward());
+        if (else_is_empty)
+          ref2 = NULL;
+        else
+          ref2 = jit_jmpi(jit_forward());
 	__END_SHORT_JUMPS__(else_short_ok);
 	nsrs1 = jitter->need_set_rs;
       } else {
@@ -7882,7 +7910,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       FOR_LOG(jitter->log_depth--);
       LOG_IT(("...else\n"));
       FOR_LOG(++jitter->log_depth);
-      g2 = generate(branch->fbranch, jitter, is_tail, multi_ok, target);
+      g2 = generate(branch->fbranch, jitter, is_tail, multi_ok, orig_target);
       RESUME_JIT_DATA();
       CHECK_LIMIT();
       amt = mz_runstack_restored(jitter);
@@ -7897,7 +7925,9 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       }
       if (g1 != 2) {
 	__START_SHORT_JUMPS__(else_short_ok);
-	mz_patch_ucbranch(ref2);
+        if (!else_is_empty) {
+          mz_patch_ucbranch(ref2);
+        }
 	__END_SHORT_JUMPS__(else_short_ok);
       }
       FOR_LOG(jitter->log_depth--);
@@ -7946,7 +7976,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 
       if (lv->count == 1) {
 	/* Expect one result: */
-	generate_non_tail(lv->value, jitter, 0, 1); /* no sync */
+	generate_non_tail(lv->value, jitter, 0, 1, 0); /* no sync */
 	CHECK_LIMIT();
 	if (ab) {
 	  pos = mz_remap(lv->position);
@@ -7961,7 +7991,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 	/* Expect multiple results: */
 	jit_insn *ref, *ref2, *ref3;
 
-	generate_non_tail(lv->value, jitter, 1, 1);
+	generate_non_tail(lv->value, jitter, 1, 1, 0);
 	CHECK_LIMIT();
 
         mz_rs_sync();
@@ -8001,7 +8031,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 	CHECK_LIMIT();
 
 	/* Continue with expected values; R2 has value array: */
-	mz_patch_branch(ref2);
+        mz_patch_branch(ref2);
 	__END_SHORT_JUMPS__(1);
 	for (i = 0; i < lv->count; i++) {
 	  jit_ldxi_p(JIT_R1, JIT_R2, WORDS_TO_BYTES(i));
@@ -8021,7 +8051,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 
       LOG_IT(("...in\n"));
 
-      return generate(lv->body, jitter, is_tail, multi_ok, target);
+      return generate(lv->body, jitter, is_tail, multi_ok, orig_target);
     }
   case scheme_let_void_type:
     {
@@ -8056,7 +8086,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 
       LOG_IT(("...in\n"));
 
-      return generate(lv->body, jitter, is_tail, multi_ok, target);
+      return generate(lv->body, jitter, is_tail, multi_ok, orig_target);
     }
   case scheme_letrec_type:
     {
@@ -8111,7 +8141,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
         jitter->need_set_rs = nsrs;
       }
 
-      return generate(l->body, jitter, is_tail, multi_ok, target);
+      return generate(l->body, jitter, is_tail, multi_ok, orig_target);
     }
   case scheme_let_one_type:
     {
@@ -8123,7 +8153,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       mz_runstack_skipped(jitter, 1);
 
       PAUSE_JIT_DATA();
-      generate_non_tail(lv->value, jitter, 0, 1); /* no sync */
+      generate_non_tail(lv->value, jitter, 0, 1, 0); /* no sync */
       RESUME_JIT_DATA();
       CHECK_LIMIT();
       
@@ -8141,7 +8171,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 
       mz_RECORD_STATUS(mz_RS_R0_HAS_RUNSTACK0);
 
-      return generate(lv->body, jitter, is_tail, multi_ok, target);
+      return generate(lv->body, jitter, is_tail, multi_ok, orig_target);
     }
   case scheme_with_cont_mark_type:
     {
@@ -8151,16 +8181,16 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       LOG_IT(("wcm...\n"));
 
       /* Key: */
-      generate_non_tail(wcm->key, jitter, 0, 1); /* sync'd below */
+      generate_non_tail(wcm->key, jitter, 0, 1, 0); /* sync'd below */
       CHECK_LIMIT();
       if (SCHEME_TYPE(wcm->val) > _scheme_values_types_) {
 	/* No need to push mark onto value stack: */
 	jit_movr_p(JIT_V1, JIT_R0);
-	generate_non_tail(wcm->val, jitter, 0, 1); /* sync'd below */
+	generate_non_tail(wcm->val, jitter, 0, 1, 0); /* sync'd below */
 	CHECK_LIMIT();
       } else {
 	mz_pushr_p(JIT_R0);
-	generate_non_tail(wcm->val, jitter, 0, 1); /* sync'd below */
+	generate_non_tail(wcm->val, jitter, 0, 1, 0); /* sync'd below */
 	CHECK_LIMIT();
 	mz_popr_p(JIT_V1); /* sync'd below */
       }
@@ -8178,7 +8208,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 
       LOG_IT(("...in\n"));
 	
-      return generate(wcm->body, jitter, is_tail, multi_ok, target);
+      return generate(wcm->body, jitter, is_tail, multi_ok, orig_target);
     }
   case scheme_quote_syntax_type:
     {
@@ -8215,7 +8245,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       jit_movi_d_fppush(fpr0, d);
       jitter->unbox_depth++;
       return 1;
-    } else {
+    } else if (!result_ignored) {
       int retptr;
       Scheme_Type type = SCHEME_TYPE(obj);
       START_JIT_DATA();
@@ -8255,6 +8285,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 
       END_JIT_DATA(19);
       return 1;
+    } else {
+      return 1;
     }
   }
 }

From 3b9d254fdae36af0a728ceed20b3e678af8810d6 Mon Sep 17 00:00:00 2001
From: Carl Eastlund <cce@racket-lang.org>
Date: Mon, 30 Nov 2009 04:40:51 +0000
Subject: [PATCH 029/136] Merged changes from branches/cce/plt+contract-tests:
 - Added tests for make-proj-contract - Added tests for opt/c, specifically to
 track 'positive-position?' blame - Fixed 'positive-position?' in opt/c (bug
 10629)

svn: r17105
---
 collects/scheme/contract/private/opt-guts.ss |  23 +++-
 collects/scheme/contract/private/opt.ss      |   1 +
 collects/tests/mzscheme/contract-test.ss     | 130 ++++++++++++++++++-
 3 files changed, 147 insertions(+), 7 deletions(-)

diff --git a/collects/scheme/contract/private/opt-guts.ss b/collects/scheme/contract/private/opt-guts.ss
index d7efff5ecc..1dedd43c54 100644
--- a/collects/scheme/contract/private/opt-guts.ss
+++ b/collects/scheme/contract/private/opt-guts.ss
@@ -56,8 +56,14 @@
 
 
 ;; struct for color-keeping across opters
-(define-struct opt/info (contract val pos neg src-info orig-str positive-position?
-                         free-vars recf base-pred this that))
+(define-struct opt/info
+  (contract val pos neg src-info orig-str position-var position-swap?
+            free-vars recf base-pred this that))
+
+(define (opt/info-positive-position? oi)
+  (if (opt/info-position-swap? oi)
+    #`(not #,(opt/info-position-var oi))
+    (opt/info-position-var oi)))
 
 ;; opt/info-swap-blame : opt/info -> opt/info
 ;; swaps pos and neg
@@ -66,7 +72,8 @@
         (val (opt/info-val info))
         (pos (opt/info-pos info))
         (neg (opt/info-neg info))
-        (positive-position? (opt/info-positive-position? info))
+        (position-var (opt/info-position-var info))
+        (position-swap? (opt/info-position-swap? info))
         (src-info (opt/info-src-info info))
         (orig-str (opt/info-orig-str info))
         (free-vars (opt/info-free-vars info))
@@ -74,7 +81,8 @@
         (base-pred (opt/info-base-pred info))
         (this (opt/info-this info))
         (that (opt/info-that info)))
-    (make-opt/info ctc val neg pos src-info orig-str (not positive-position?)
+    (make-opt/info ctc val neg pos src-info orig-str
+                   position-var (not position-swap?)
                    free-vars recf base-pred this that)))
 
 ;; opt/info-change-val : identifier opt/info -> opt/info
@@ -83,7 +91,8 @@
   (let ((ctc (opt/info-contract info))
         (pos (opt/info-pos info))
         (neg (opt/info-neg info))
-        (positive-position? (opt/info-positive-position? info))
+        (position-var (opt/info-position-var info))
+        (position-swap? (opt/info-position-swap? info))
         (src-info (opt/info-src-info info))
         (orig-str (opt/info-orig-str info))
         (free-vars (opt/info-free-vars info))
@@ -91,7 +100,9 @@
         (base-pred (opt/info-base-pred info))
         (this (opt/info-this info))
         (that (opt/info-that info)))
-    (make-opt/info ctc val pos neg src-info orig-str positive-position? free-vars recf base-pred this that)))
+    (make-opt/info ctc val pos neg src-info orig-str
+                   position-var position-swap?
+                   free-vars recf base-pred this that)))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/collects/scheme/contract/private/opt.ss b/collects/scheme/contract/private/opt.ss
index d0383f4920..888b11c84c 100644
--- a/collects/scheme/contract/private/opt.ss
+++ b/collects/scheme/contract/private/opt.ss
@@ -127,6 +127,7 @@
                                           #'src-info
                                           #'orig-str
                                           #'positive-position?
+                                          #f
                                           (syntax->list #'(opt-recursive-args ...))
                                           #f
                                           #f
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index 89e6e5d1b7..3de105d6a2 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -2282,7 +2282,53 @@
                         'neg)
               'x)
    1)
-  
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;;  make-proj-contract
+  ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (contract-eval
+   '(define proj:add1->sub1
+      (make-proj-contract
+       'proj:add1->sub1
+       (lambda (pos neg src name blame)
+         (lambda (f)
+           (unless (and (procedure? f) (procedure-arity-includes? f 1))
+             (raise-contract-error f src pos name
+                                   "expected a unary function, got: ~e"
+                                   f))
+           (lambda (x)
+             (unless (and (integer? x) (exact? x))
+               (raise-contract-error x src neg name
+                                     "expected an integer, got: ~e"
+                                     x))
+             (let* ([y (f (add1 x))])
+               (unless (and (integer? y) (exact? y))
+                 (raise-contract-error y src pos name
+                                       "expected an integer, got: ~e"
+                                       y))
+               (sub1 y)))))
+       (lambda (f)
+         (and (procedure? f) (procedure-arity-includes? f 1))))))
+
+  (test/spec-passed/result
+   'make-proj-contract-1
+   '((contract proj:add1->sub1 sqrt 'pos 'neg) 15)
+   3)
+
+  (test/pos-blame
+   'make-proj-contract-2
+   '(contract proj:add1->sub1 'dummy 'pos 'neg))
+
+  (test/pos-blame
+   'make-proj-contract-3
+   '((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2))
+
+  (test/neg-blame
+   'make-proj-contract-4
+   '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))
   
 ;                                                                                           
 ;                                                                                           
@@ -5200,6 +5246,88 @@
   ;;  end of define-opt/c
   ;;
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;;  opt/c and blame
+  ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (contract-eval
+   '(begin
+
+      (define proj:blame/c
+        (make-proj-contract
+         'proj:blame/c
+         (lambda (pos neg src name blame)
+           (lambda (x)
+             (if blame 'positive 'negative)))
+         (lambda (x) #t)))
+
+      (define call*0 'dummy)
+      (define (call*1 x0) x0)
+      (define (call*2 f1 x0) (f1 x0))
+      (define (call*3 f2 x1 x0) (f2 x1 x0))))
+
+  (test/spec-passed/result
+   'opt/c-blame-0
+   '((contract
+      (-> (-> (-> proj:blame/c any/c) any/c any/c) (-> any/c any/c) any/c any/c)
+      call*3
+      'pos
+      'neg)
+     call*2
+     call*1
+     call*0)
+   'negative)
+
+  (test/spec-passed/result
+   'opt/c-blame-1
+   '((contract
+      (opt/c (-> (-> (-> proj:blame/c any/c) any/c any/c) (-> any/c any/c) any/c any/c))
+      call*3
+      'pos
+      'neg)
+     call*2
+     call*1
+     call*0)
+   'negative)
+
+  (test/spec-passed/result
+   'opt/c-blame-2
+   '((contract
+      (-> (opt/c (-> (-> proj:blame/c any/c) any/c any/c)) (-> any/c any/c) any/c any/c)
+      call*3
+      'pos
+      'neg)
+     call*2
+     call*1
+     call*0)
+   'negative)
+
+  (test/spec-passed/result
+   'opt/c-blame-3
+   '((contract
+      (-> (-> (opt/c (-> proj:blame/c any/c)) any/c any/c) (-> any/c any/c) any/c any/c)
+      call*3
+      'pos
+      'neg)
+     call*2
+     call*1
+     call*0)
+   'negative)
+
+  (test/spec-passed/result
+   'opt/c-blame-4
+   '((contract
+      (-> (-> (-> (opt/c proj:blame/c) any/c) any/c any/c) (-> any/c any/c) any/c any/c)
+      call*3
+      'pos
+      'neg)
+     call*2
+     call*1
+     call*0)
+   'negative)
   
   ;; NOT YET RELEASED
   #;

From 2400d130a784766894cadcb919776def199dce11 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 30 Nov 2009 08:50:47 +0000
Subject: [PATCH 030/136] Welcome to a new PLT day.

svn: r17106
---
 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 a577909113..e1fea1f73c 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "29nov2009")
+#lang scheme/base (provide stamp) (define stamp "30nov2009")

From 65f3695afb3bb97ba66e069d0e5df0582330aff2 Mon Sep 17 00:00:00 2001
From: Mike Sperber <sperber@deinprogramm.de>
Date: Mon, 30 Nov 2009 13:47:41 +0000
Subject: [PATCH 031/136] DMdA doc fix.

svn: r17107
---
 collects/deinprogramm/scribblings/DMdA-beginner.scrbl | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/deinprogramm/scribblings/DMdA-beginner.scrbl b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl
index 1797640669..c3d367c184 100644
--- a/collects/deinprogramm/scribblings/DMdA-beginner.scrbl
+++ b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl
@@ -341,7 +341,7 @@ Dieser Testfall überprüft experimentell, ob die @tech{Eigenschaft}
 @emph{Wichtig:} @scheme[check-property] funktioniert nur für
 Eigenschaften, bei denen aus den Verträgen sinnvoll Werte generiert
 werden können.  Dies ist für die meisten eingebauten Verträge der
-Fall, aber nicht für Verträge, die mit @scheme[predicate],
+Fall, aber nicht für Vertragsvariablen und Verträge, die mit @scheme[predicate],
 @scheme[property] oder @scheme[define-record-procedures] definiert
 wurden.  In diesen Fällen erzeugt @scheme[check-property] eine Fehlermeldung.
 }

From 2bb3403f887afcb95374e1b3454849bd1b5f5bd9 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Mon, 30 Nov 2009 15:31:38 +0000
Subject: [PATCH 032/136] modified error to take arbitrary number of arguments

svn: r17108
---
 collects/lang/private/teachprims.ss | 19 ++++++++++++++++++-
 1 file changed, 18 insertions(+), 1 deletion(-)

diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss
index 6a2b3d0159..e1ab3aa309 100644
--- a/collects/lang/private/teachprims.ss
+++ b/collects/lang/private/teachprims.ss
@@ -192,8 +192,25 @@ namespace.
           (apply append x)))))
 
 (define-teach beginner error
+  (lambda stuff0
+    (define-values (f stuff1)
+      (if (and (cons? stuff0) (symbol? (first stuff0)))
+          (values (first stuff0) (rest stuff0))
+          (values false stuff0)))
+    (define str
+      (let loop ([stuff stuff1][frmt ""][pieces '()])
+        (cond
+          [(empty? stuff) (apply format frmt (reverse pieces))]
+          [else 
+           (let ([f (first stuff)]
+                 [r (rest stuff)])
+             (if (string? f)
+                 (loop r (string-append frmt f) pieces)
+                 (loop r (string-append frmt "~e") (cons f pieces))))])))
+    (if f (error f str) (error str)))
+  #;
   (lambda (str)
-    (unless  (string? str)
+    (unless (string? str)
       (raise
        (make-exn:fail:contract
         (format "error: expected a string, got ~e and ~e" str)

From bd0f6948030926311d6b5280b4ba9b80314b7f4c Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Mon, 30 Nov 2009 16:16:50 +0000
Subject: [PATCH 033/136] svn: r17109

---
 collects/lang/info.ss       |  3 +++
 collects/lang/private/TODO  |  1 -
 collects/lang/test-error.ss | 16 ++++++++++++++++
 3 files changed, 19 insertions(+), 1 deletion(-)
 create mode 100644 collects/lang/test-error.ss

diff --git a/collects/lang/info.ss b/collects/lang/info.ss
index 1a57d67828..f6eaf6a761 100644
--- a/collects/lang/info.ss
+++ b/collects/lang/info.ss
@@ -8,6 +8,9 @@
 (define tool-names (list "How to Design Programs"))
 (define tool-urls (list "http://www.htdp.org/"))
 
+(define compile-omit-paths
+  '("test-error.ss"))
+
 (define textbook-pls
   (list (list '("htdp-icon.gif" "icons")
               "How to Design Programs"
diff --git a/collects/lang/private/TODO b/collects/lang/private/TODO
index 7f7f0cfc8b..c12461914a 100644
--- a/collects/lang/private/TODO
+++ b/collects/lang/private/TODO
@@ -38,4 +38,3 @@ string-ref  : String Nat -> Char
 
 NOTE: 
 substring consumes 2 or 3 arguments 
-
diff --git a/collects/lang/test-error.ss b/collects/lang/test-error.ss
new file mode 100644
index 0000000000..a2a20deb2f
--- /dev/null
+++ b/collects/lang/test-error.ss
@@ -0,0 +1,16 @@
+;; The first three lines of this file were inserted by DrScheme. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-beginner-reader.ss" "lang")((modname bar) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
+(check-error (error) "")
+(check-error (error 1) "1")
+(check-error (error 'a) "a: ")
+(check-error (error 'a "bad input") "a: bad input")
+(check-error (error 'a "bad input: " 1) "a: bad input: 1")
+(check-error (error 'a "bad input: " 1 " and " "hello") "a: bad input: 1 and hello")
+(check-error (error 'a "bad input: " 1 " and " false) "a: bad input: 1 and false")
+(check-error (error 'a "uhoh " (list 1 2 3)) "a: uhoh (cons 1 (cons 2 (cons 3 empty)))")
+
+(define-struct err (str))
+
+(check-error (error 'a "bad input: " 1 " and " (make-err "hello")) 
+             "a: bad input: 1 and (make-err \"hello\")")

From f18cc73dece4331a8c71fa2e3de64174d9242847 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Mon, 30 Nov 2009 16:51:53 +0000
Subject: [PATCH 034/136] stop the world and let me get off

svn: r17110
---
 collects/teachpack/2htdp/scribblings/universe.scrbl | 10 ++++++++++
 1 file changed, 10 insertions(+)

diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl
index be34e073f1..a68c4667b5 100644
--- a/collects/teachpack/2htdp/scribblings/universe.scrbl
+++ b/collects/teachpack/2htdp/scribblings/universe.scrbl
@@ -443,6 +443,16 @@ All @tech{MouseEvent}s are represented via strings:
 
 @item{
 
+@defproc[(STOP! [w (unsyntax @tech{WorldState})]) boolean?]{signals to
+DrScheme that the current world program should shut down. That is, any
+handler may return @scheme[(STOP! w)] provided @scheme[w] is a
+@tech{WorldState}. If it does, the state of the world becomes @scheme[w]
+but @scheme[big-bang] will close down all event handling.}
+
+}
+
+@item{
+
 @defform[(check-with world-expr?)
          #:contracts
          ([world-expr? (-> Any boolean?)])]{

From bb4c88338c43ff55ddee00b296f13dd665be3368 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Mon, 30 Nov 2009 16:52:01 +0000
Subject: [PATCH 035/136] stop the world and let me get off

svn: r17111
---
 collects/2htdp/private/stop.ss       |  5 +++++
 collects/2htdp/private/world.ss      | 14 ++++++++++++--
 collects/2htdp/tests/world0-stops.ss | 10 +++++++++-
 collects/2htdp/universe.ss           |  4 ++++
 4 files changed, 30 insertions(+), 3 deletions(-)
 create mode 100644 collects/2htdp/private/stop.ss

diff --git a/collects/2htdp/private/stop.ss b/collects/2htdp/private/stop.ss
new file mode 100644
index 0000000000..816d57201b
--- /dev/null
+++ b/collects/2htdp/private/stop.ss
@@ -0,0 +1,5 @@
+#lang scheme
+
+(provide (struct-out stop-the-world))
+
+(define-struct stop-the-world (world) #:transparent)
diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss
index 67f90960c9..59480ffe1a 100644
--- a/collects/2htdp/private/world.ss
+++ b/collects/2htdp/private/world.ss
@@ -4,6 +4,7 @@
          "timer.ss"
          "last.ss"
          "checked-cell.ss"
+         "stop.ss"
          htdp/image
          htdp/error
          mzlib/runtime-path
@@ -214,15 +215,20 @@
           (queue-callback 
            (lambda ()
              (with-handlers ([exn? (handler #t)])
+	       (define stop-it #f)
                (define tag (format "~a callback" 'transform))
                (define nw (transform (send world get) arg ...))
                (when (package? nw)
                  (broadcast (package-message nw))
                  (set! nw (package-world nw)))
+               (printf "~s\n" nw)
+	       (when (stop-the-world? nw)
+		 (set! nw (stop-the-world-world nw))
+		 (set! stop-it #t))
                (let ([changed-world? (send world set tag nw)])
                  (unless changed-world?
                    (when draw (pdraw))
-                   (when (pstop) 
+                   (when (or stop-it (pstop))
                      (when last-picture 
                        (set! draw last-picture)
                        (pdraw))
@@ -284,7 +290,11 @@
       ;; initialize the world and run 
       (super-new)
       (start!)
-      (when (stop (send world get)) (stop! (send world get)))))))
+      (let ([w (send world get)])
+        (cond
+          [(stop w) (stop! (send world get))]
+          [(stop-the-world? w) 
+           (stop! (stop-the-world-world (send world get)))]))))))
 
 ;; -----------------------------------------------------------------------------
 (define-runtime-path break-btn:path '(lib "icons/break.png"))
diff --git a/collects/2htdp/tests/world0-stops.ss b/collects/2htdp/tests/world0-stops.ss
index 60857b8753..54fda9bf27 100644
--- a/collects/2htdp/tests/world0-stops.ss
+++ b/collects/2htdp/tests/world0-stops.ss
@@ -1,5 +1,13 @@
 ;; The first three lines of this file were inserted by DrScheme. They record metadata
 ;; about the language level of this file in a form that our tools can easily process.
-#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ((lib "universe.ss" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp")))))
+#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
 
+(require 2htdp/universe)
+
+"does big-bang stop when the initial world is already a final world?"
 (big-bang 0 (stop-when zero?) (on-tick add1))
+
+"does big bang stop when the initial world is a stop world?"
+(big-bang (STOP! 0) (on-tick add1))
+
+(define-struct stop (x))
\ No newline at end of file
diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss
index 2c1e62050c..a13d4fd3ee 100644
--- a/collects/2htdp/universe.ss
+++ b/collects/2htdp/universe.ss
@@ -17,11 +17,15 @@
          "private/world.ss"
          "private/universe.ss"
          "private/launch-many-worlds.ss"
+         "private/stop.ss"
          htdp/error
          (rename-in lang/prim (first-order->higher-order f2h)))
 
 (provide (all-from-out "private/image.ss"))
 
+(provide 
+ (rename-out (make-stop-the-world STOP!))) ;; World -> STOP!
+
 (provide
  launch-many-worlds
  ;; (launch-many-worlds e1 ... e2)

From 571fec95aa37cb160f9de909cc39dce286a793f0 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Mon, 30 Nov 2009 18:22:38 +0000
Subject: [PATCH 036/136] stop the world and let me get off (2)

svn: r17112
---
 collects/2htdp/private/world.ss | 35 +++++++++++++++++++--------------
 collects/2htdp/universe.ss      |  2 +-
 2 files changed, 21 insertions(+), 16 deletions(-)

diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss
index 59480ffe1a..f3e13348f5 100644
--- a/collects/2htdp/private/world.ss
+++ b/collects/2htdp/private/world.ss
@@ -215,26 +215,31 @@
           (queue-callback 
            (lambda ()
              (with-handlers ([exn? (handler #t)])
-	       (define stop-it #f)
                (define tag (format "~a callback" 'transform))
                (define nw (transform (send world get) arg ...))
                (when (package? nw)
                  (broadcast (package-message nw))
                  (set! nw (package-world nw)))
-               (printf "~s\n" nw)
-	       (when (stop-the-world? nw)
-		 (set! nw (stop-the-world-world nw))
-		 (set! stop-it #t))
-               (let ([changed-world? (send world set tag nw)])
-                 (unless changed-world?
-                   (when draw (pdraw))
-                   (when (or stop-it (pstop))
-                     (when last-picture 
-                       (set! draw last-picture)
-                       (pdraw))
-                     (callback-stop! 'name)
-                     (enable-images-button)))
-                 changed-world?))))))
+               (if (stop-the-world? nw)
+		   (begin
+		     (set! nw (stop-the-world-world nw))
+		     (send world set tag nw)
+		     (when last-picture
+		       (set! draw last-picture))
+		     (when draw (pdraw))
+		     (callback-stop! 'name)
+		     (enable-images-button))
+		   (let ([changed-world? (send world set tag nw)])
+		     (unless changed-world?
+		       (when draw (pdraw))
+		       (when (pstop)
+			 (printf "!stop!\n")
+			 (when last-picture 
+			   (set! draw last-picture)
+			   (pdraw))
+			 (callback-stop! 'name)
+			 (enable-images-button)))
+		     changed-world?)))))))
       
       ;; tick, tock : deal with a tick event for this world 
       (def/pub-cback (ptock) tick)
diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss
index a13d4fd3ee..be9d563852 100644
--- a/collects/2htdp/universe.ss
+++ b/collects/2htdp/universe.ss
@@ -24,7 +24,7 @@
 (provide (all-from-out "private/image.ss"))
 
 (provide 
- (rename-out (make-stop-the-world STOP!))) ;; World -> STOP!
+ (rename-out (make-stop-the-world stop-with))) ;; World -> STOP
 
 (provide
  launch-many-worlds

From 5b3fa4c120aa7d65bc950a970e1e5d2621958fcd Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Mon, 30 Nov 2009 18:24:43 +0000
Subject: [PATCH 037/136] stop the world and let me get off (2)

svn: r17113
---
 collects/teachpack/2htdp/scribblings/universe.scrbl | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl
index a68c4667b5..c957110bd4 100644
--- a/collects/teachpack/2htdp/scribblings/universe.scrbl
+++ b/collects/teachpack/2htdp/scribblings/universe.scrbl
@@ -443,9 +443,9 @@ All @tech{MouseEvent}s are represented via strings:
 
 @item{
 
-@defproc[(STOP! [w (unsyntax @tech{WorldState})]) boolean?]{signals to
+@defproc[(stop-with [w (unsyntax @tech{WorldState})]) (stop-with (unsyntax @tech{WorldState}))]{signals to
 DrScheme that the current world program should shut down. That is, any
-handler may return @scheme[(STOP! w)] provided @scheme[w] is a
+handler may return @scheme[(stop-with w)] provided @scheme[w] is a
 @tech{WorldState}. If it does, the state of the world becomes @scheme[w]
 but @scheme[big-bang] will close down all event handling.}
 

From ef194eb948fe118f7452c9f61ceb447d6025c075 Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Mon, 30 Nov 2009 19:08:55 +0000
Subject: [PATCH 038/136] special case for delimiters

svn: r17114
---
 collects/honu/private/honu.ss  |  2 +-
 collects/honu/private/macro.ss | 25 +++++++++++++++++++++++--
 2 files changed, 24 insertions(+), 3 deletions(-)

diff --git a/collects/honu/private/honu.ss b/collects/honu/private/honu.ss
index 931bcfb78e..1c1396b0fb 100644
--- a/collects/honu/private/honu.ss
+++ b/collects/honu/private/honu.ss
@@ -126,7 +126,7 @@
                  (let ([v (syntax-local-value (stx-car first) (lambda () #f))])
                    (and (honu-transformer? v) v))]
                 [else #f]))))
-     (printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
+     ;; (printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
      (or (bound-transformer stx)
          (special-transformer stx)))
    
diff --git a/collects/honu/private/macro.ss b/collects/honu/private/macro.ss
index 90a0c9ee1c..b642ee2c35 100644
--- a/collects/honu/private/macro.ss
+++ b/collects/honu/private/macro.ss
@@ -153,7 +153,8 @@
            #'rest))])
     ))
 
-(define-for-syntax (delimiter? x) #f)
+(define-for-syntax (delimiter? x)
+  (or (free-identifier=? x #'\;)))
 
 (define-syntax (my-ellipses stx) (raise-syntax-error 'my-ellipses "dont use this"))
 ;; (define-syntax (wrapped stx) (raise-syntax-error 'wrapped "dont use wrap"))
@@ -166,6 +167,8 @@
   (define (reverse-syntax stx)
     (with-syntax ([(x ...) (reverse (syntax->list stx))])
       #'(x ...)))
+  (define-syntax-class delimiter-class
+    (pattern x:id #:when (delimiter? #'x)))
   (define-syntax-class ellipses-class
                        (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
   ;; use this if you are defining your own ellipses identifier
@@ -180,6 +183,19 @@
       ;; (printf "stx is ~a\n" stx)
       ;; (printf "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx)))
       (syntax-parse stx
+        [(ellipses1:ellipses-class ellipses:ellipses-class ... delimiter:delimiter-class x ...)
+         (with-syntax ([(x* ...) (reverse-syntax (pull #'(delimiter x ...)))])
+           (reverse-syntax
+             (with-syntax ([wrapped #'wrapped]
+                           [original
+                            (with-syntax ([(ellipses* ...) (map (lambda (_)
+                                                            #'((... ...) (... ...)))
+                                                          (syntax->list #'(ellipses1 ellipses ...)))]
+                                          [(x-new ...) (generate-temporaries #'(delimiter x ...))])
+                              (reverse-syntax #'(ellipses* ... x-new ...)))]
+                           #;
+                           [original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))])
+               #'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))]
         [(ellipses1:ellipses-class ellipses:ellipses-class ... x ...)
          (with-syntax ([(x* ...) (reverse-syntax (pull #'(x ...)))])
            (reverse-syntax
@@ -196,13 +212,18 @@
         [(x ...) (with-syntax ([(x* ...) (map pull (syntax->list #'(x ...)))])
                    (reverse-syntax #'(x* ...)))]))))
 
-(begin-for-syntax (trace pull))
+;; (begin-for-syntax (trace pull))
 
 (define-for-syntax (unpull stx)
   (define-syntax-class ellipses-class
     (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
+  (define-syntax-class delimiter-class
+    (pattern x:id #:when (delimiter? #'x)))
   (syntax-parse stx
                 #:literals (wrapped unwrap)
+                [(unwrap (wrapped x ... delimiter:delimiter-class) ...)
+                 (with-syntax ([(x1 ...) (apply append (map syntax->list (syntax->list #'((x ... delimiter) ...))))])
+                 #'(x1 ...))]
                 [(unwrap (wrapped x ... y) ...)
                  (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
                    (with-syntax ([(x1* ...) (map unpull (syntax->list #'(x1 ...)))]

From aee5ba80d7ffa523723f021b7eb60d6239454067 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Mon, 30 Nov 2009 20:35:06 +0000
Subject: [PATCH 039/136] svn: r17115

---
 collects/2htdp/tests/stop.ss         | 23 +++++++++++++++++++++++
 collects/2htdp/tests/world0-stops.ss |  4 ++--
 2 files changed, 25 insertions(+), 2 deletions(-)
 create mode 100644 collects/2htdp/tests/stop.ss

diff --git a/collects/2htdp/tests/stop.ss b/collects/2htdp/tests/stop.ss
new file mode 100644
index 0000000000..f0307f3e5f
--- /dev/null
+++ b/collects/2htdp/tests/stop.ss
@@ -0,0 +1,23 @@
+;; The first three lines of this file were inserted by DrScheme. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname test-stop) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
+
+(require 2htdp/universe)
+
+;; on RETURN stop 
+
+(define (main debug?)
+  (big-bang ""
+            (on-key (lambda (w ke) 
+                      (cond
+                        [(key=? ke "\r") (stop-with w)]
+                        [(= (string-length ke) 1)
+                         (string-append w ke)]
+                        [else w])))
+            (state debug?)
+            (on-draw (lambda (w)
+                       (place-image 
+                        (text w 22 'black)
+                        3 3
+                        (empty-scene 100 100))))))
+  
\ No newline at end of file
diff --git a/collects/2htdp/tests/world0-stops.ss b/collects/2htdp/tests/world0-stops.ss
index 54fda9bf27..828a602cf5 100644
--- a/collects/2htdp/tests/world0-stops.ss
+++ b/collects/2htdp/tests/world0-stops.ss
@@ -8,6 +8,6 @@
 (big-bang 0 (stop-when zero?) (on-tick add1))
 
 "does big bang stop when the initial world is a stop world?"
-(big-bang (STOP! 0) (on-tick add1))
+(big-bang (stop-with 0) (on-tick add1))
 
-(define-struct stop (x))
\ No newline at end of file
+(define-struct stop (x))

From f01aa1161aea7fb21e6bde39350fde01a6fe73f9 Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Mon, 30 Nov 2009 22:37:33 +0000
Subject: [PATCH 040/136] hopefully better algorithm

svn: r17118
---
 collects/honu/private/macro.ss | 60 ++++++++++++++++++++++++++++++++--
 1 file changed, 58 insertions(+), 2 deletions(-)

diff --git a/collects/honu/private/macro.ss b/collects/honu/private/macro.ss
index b642ee2c35..934bad9a77 100644
--- a/collects/honu/private/macro.ss
+++ b/collects/honu/private/macro.ss
@@ -162,7 +162,56 @@
 (define wrapped #f)
 (define unwrap #f)
 
+(define-for-syntax (pull stx)
+  (define (reverse-syntax stx)
+    (with-syntax ([(x ...) (reverse (syntax->list stx))])
+      #'(x ...)))
+  (define-syntax-class stop-class
+    (pattern x:id #:when (or (free-identifier=? #'x #'(... ...))
+                             (free-identifier=? #'x #'\;))))
+  (define (do-ellipses stx)
+    (let loop ([ellipses '()]
+               [body '()]
+               [stx stx])
+      (cond
+        [(null? stx) (values (with-syntax ([(ellipses ...) ellipses]
+                                           [(body ...) body])
+                               #'(ellipses ... body ...))
+                             stx)]
+        [(and (identifier? (car stx))
+              (free-identifier=? (car stx) #'(... ...)))
+         (loop (cons #'(... ...) ellipses) body (cdr stx))]
+        [(and (identifier? (car stx))
+              (free-identifier=? (car stx) #'\;))
+         ;; (printf "Found a ; in ~a\n" (syntax->datum stx))
+         (with-syntax ([all (cdr stx)])
+           ;; (printf "Found a ; -- ~a\n" (syntax->datum #'all))
+           (syntax-parse #'all
+                         [((~and x (~not _:stop-class)) ... stop:stop-class y ...)
+                          (with-syntax ([(ellipses ...) ellipses]
+                                        [(x* ...) (reverse-syntax #'(x ...))])
+                            (values #'(ellipses ... (wrapped x* ... \;) unwrap)
+                                    #'(stop y ...)))]
+                         [else (with-syntax ([(f ...) (reverse-syntax #'all)]
+                                             [(ellipses ...) ellipses])
+                                 (values #'(ellipses ... (wrapped f ... \;) unwrap)
+                                         #'()))]))])))
+  (let loop ([all '()]
+             [stx (reverse (syntax->list stx))])
+    (if (null? stx)
+        (with-syntax ([x all])
+          #'x)
+        (let ([head (car stx)]
+              [tail (cdr stx)])
+          (cond
+            [(and (identifier? head)
+                  (free-identifier=? head #'(... ...)))
+             (let-values ([(wrapped rest) (do-ellipses (cons head tail))])
+               (loop (cons (reverse-syntax wrapped) all) (syntax->list rest)))]
+            [else (loop (cons head all) tail)])))))
+
 ;; rename this to wrap
+#;
 (define-for-syntax (pull stx)
   (define (reverse-syntax stx)
     (with-syntax ([(x ...) (reverse (syntax->list stx))])
@@ -171,6 +220,8 @@
     (pattern x:id #:when (delimiter? #'x)))
   (define-syntax-class ellipses-class
                        (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
+  (define-syntax-class not-ellipses-class
+                       (pattern x:id #:when (not (free-identifier=? #'x #'(... ...)))))
   ;; use this if you are defining your own ellipses identifier
   #;
   (define-syntax-class ellipses-class
@@ -183,7 +234,7 @@
       ;; (printf "stx is ~a\n" stx)
       ;; (printf "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx)))
       (syntax-parse stx
-        [(ellipses1:ellipses-class ellipses:ellipses-class ... delimiter:delimiter-class x ...)
+        [(before:not-ellipses-class ... ellipses1:ellipses-class ellipses:ellipses-class ... delimiter:delimiter-class x ...)
          (with-syntax ([(x* ...) (reverse-syntax (pull #'(delimiter x ...)))])
            (reverse-syntax
              (with-syntax ([wrapped #'wrapped]
@@ -192,7 +243,7 @@
                                                             #'((... ...) (... ...)))
                                                           (syntax->list #'(ellipses1 ellipses ...)))]
                                           [(x-new ...) (generate-temporaries #'(delimiter x ...))])
-                              (reverse-syntax #'(ellipses* ... x-new ...)))]
+                              (reverse-syntax #'(before ... ellipses* ... x-new ...)))]
                            #;
                            [original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))])
                #'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))]
@@ -219,8 +270,13 @@
     (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
   (define-syntax-class delimiter-class
     (pattern x:id #:when (delimiter? #'x)))
+  ;; (printf "unpull ~a\n" (syntax->datum stx))
   (syntax-parse stx
                 #:literals (wrapped unwrap)
+                [((~and z (~not (unwrap _ ...))) ... (unwrap (wrapped x ... delimiter:delimiter-class) ...) rest ...)
+                 (with-syntax ([(x1 ...) (apply append (map syntax->list (syntax->list #'((x ... delimiter) ...))))]
+                               [(rest* ...) (unpull #'(rest ...))])
+                 #'(z ... x1 ... rest* ...))]
                 [(unwrap (wrapped x ... delimiter:delimiter-class) ...)
                  (with-syntax ([(x1 ...) (apply append (map syntax->list (syntax->list #'((x ... delimiter) ...))))])
                  #'(x1 ...))]

From b4a32ddc1c5e8e8f9f410329b8f7817b8d60b13e Mon Sep 17 00:00:00 2001
From: Carl Eastlund <cce@racket-lang.org>
Date: Tue, 1 Dec 2009 02:10:50 +0000
Subject: [PATCH 041/136] Merged changes from branches/cce/plt+addon-dir: -
 Added PLTADDONDIR environment variable to control the location of   generated
 files from Planet and Scribble, specifically by overriding   the result of
 (find-system-path 'addon-dir). - Updated documentation of find-system-path to
 report this change.

svn: r17121
---
 .../scribblings/reference/filesystem.scrbl    |  8 ++++---
 src/mzscheme/src/file.c                       | 24 +++++++++++++++++++
 2 files changed, 29 insertions(+), 3 deletions(-)

diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl
index 240ece9b6d..39e9e5d4d7 100644
--- a/collects/scribblings/reference/filesystem.scrbl
+++ b/collects/scribblings/reference/filesystem.scrbl
@@ -81,9 +81,11 @@ by @scheme[kind], which must be one of the following:
   ]}
 
  @item{@indexed-scheme['addon-dir] --- a directory for installing PLT Scheme
- extensions. It's the same as @scheme['pref-dir], except under Mac OS
- X, where it is @filepath{Library/PLT Scheme} in the user's home
- directory. This directory might not exist.}
+ extensions. This directory is specified by the @indexed-envvar{PLTADDONDIR}
+ environment variable.  If the environment variable is undefined or not a legal
+ path name, this directory defaults to @filepath{Library/PLT Scheme} in the
+ user's home directory under Mac OS X and @scheme['pref-dir] otherwise.  This
+ directory might not exist.}
 
  @item{@indexed-scheme['doc-dir] --- the standard directory for
  storing the current user's documents. Under Unix, it's the same as
diff --git a/src/mzscheme/src/file.c b/src/mzscheme/src/file.c
index ef2652bfc0..337118b3a2 100644
--- a/src/mzscheme/src/file.c
+++ b/src/mzscheme/src/file.c
@@ -5768,6 +5768,19 @@ find_system_path(int argc, Scheme_Object **argv)
 
     return CURRENT_WD();
   }
+
+  /* first option for addon_dir: PLTADDONDIR environment variable */
+  if (which == id_addon_dir) {
+    char* p;
+
+    if ((p = getenv("PLTADDONDIR"))) {
+      p = scheme_expand_filename(p, -1, NULL, NULL, 0);
+      if (p)
+        return scheme_make_path(p);
+    }
+
+    /* If PLTADDONDIR is undefined or malformed, fall through to default */
+  }
   
   {
     /* Everything else is in ~: */
@@ -5854,6 +5867,17 @@ find_system_path(int argc, Scheme_Object **argv)
       return CURRENT_WD();
     }
 
+    /* first option for addon_dir: PLTADDONDIR environment variable */
+    if (which == id_addon_dir) {
+      if ((p = getenv("PLTADDONDIR"))) {
+        p = scheme_expand_filename(p, -1, NULL, NULL, 0);
+        if (p)
+          return scheme_make_path(p);
+      }
+
+      /* If PLTADDONDIR is undefined or malformed, fall through to default */
+    }
+
     home = NULL;
 
     {

From 2fd3c233937904213f3e5389acaad2a516659f6b Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Tue, 1 Dec 2009 02:16:19 +0000
Subject: [PATCH 042/136] Undo this change.  Like I said on the list, it is
 wrong to poll the environment variable every time it is accessed (especially
 given that there will be a command-line option for this).  I'll commit a
 proper thing later tonight if I get to it.

svn: r17122
---
 .../scribblings/reference/filesystem.scrbl    |  8 +++----
 src/mzscheme/src/file.c                       | 24 -------------------
 2 files changed, 3 insertions(+), 29 deletions(-)

diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl
index 39e9e5d4d7..240ece9b6d 100644
--- a/collects/scribblings/reference/filesystem.scrbl
+++ b/collects/scribblings/reference/filesystem.scrbl
@@ -81,11 +81,9 @@ by @scheme[kind], which must be one of the following:
   ]}
 
  @item{@indexed-scheme['addon-dir] --- a directory for installing PLT Scheme
- extensions. This directory is specified by the @indexed-envvar{PLTADDONDIR}
- environment variable.  If the environment variable is undefined or not a legal
- path name, this directory defaults to @filepath{Library/PLT Scheme} in the
- user's home directory under Mac OS X and @scheme['pref-dir] otherwise.  This
- directory might not exist.}
+ extensions. It's the same as @scheme['pref-dir], except under Mac OS
+ X, where it is @filepath{Library/PLT Scheme} in the user's home
+ directory. This directory might not exist.}
 
  @item{@indexed-scheme['doc-dir] --- the standard directory for
  storing the current user's documents. Under Unix, it's the same as
diff --git a/src/mzscheme/src/file.c b/src/mzscheme/src/file.c
index 337118b3a2..ef2652bfc0 100644
--- a/src/mzscheme/src/file.c
+++ b/src/mzscheme/src/file.c
@@ -5768,19 +5768,6 @@ find_system_path(int argc, Scheme_Object **argv)
 
     return CURRENT_WD();
   }
-
-  /* first option for addon_dir: PLTADDONDIR environment variable */
-  if (which == id_addon_dir) {
-    char* p;
-
-    if ((p = getenv("PLTADDONDIR"))) {
-      p = scheme_expand_filename(p, -1, NULL, NULL, 0);
-      if (p)
-        return scheme_make_path(p);
-    }
-
-    /* If PLTADDONDIR is undefined or malformed, fall through to default */
-  }
   
   {
     /* Everything else is in ~: */
@@ -5867,17 +5854,6 @@ find_system_path(int argc, Scheme_Object **argv)
       return CURRENT_WD();
     }
 
-    /* first option for addon_dir: PLTADDONDIR environment variable */
-    if (which == id_addon_dir) {
-      if ((p = getenv("PLTADDONDIR"))) {
-        p = scheme_expand_filename(p, -1, NULL, NULL, 0);
-        if (p)
-          return scheme_make_path(p);
-      }
-
-      /* If PLTADDONDIR is undefined or malformed, fall through to default */
-    }
-
     home = NULL;
 
     {

From 0de55b5f3a4c38f5097d4cb66a595f889798a81b Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Tue, 1 Dec 2009 02:19:38 +0000
Subject: [PATCH 043/136] set svn:eol-style

svn: r17123
---
 collects/2htdp/tests/stop.ss | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/collects/2htdp/tests/stop.ss b/collects/2htdp/tests/stop.ss
index f0307f3e5f..680fc14cd5 100644
--- a/collects/2htdp/tests/stop.ss
+++ b/collects/2htdp/tests/stop.ss
@@ -4,11 +4,11 @@
 
 (require 2htdp/universe)
 
-;; on RETURN stop 
+;; on RETURN stop
 
 (define (main debug?)
   (big-bang ""
-            (on-key (lambda (w ke) 
+            (on-key (lambda (w ke)
                       (cond
                         [(key=? ke "\r") (stop-with w)]
                         [(= (string-length ke) 1)
@@ -16,8 +16,7 @@
                         [else w])))
             (state debug?)
             (on-draw (lambda (w)
-                       (place-image 
+                       (place-image
                         (text w 22 'black)
                         3 3
                         (empty-scene 100 100))))))
-  
\ No newline at end of file

From d36297d176c879675af9d5c1e21d0e6bfecce909 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 1 Dec 2009 07:57:33 +0000
Subject: [PATCH 044/136] reference: added spacing in sequence boilerplate
 macro Please propagate to release branch if possible.

svn: r17129
---
 collects/scribblings/reference/mz.ss | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/collects/scribblings/reference/mz.ss b/collects/scribblings/reference/mz.ss
index 5381a13a70..d9b3976907 100644
--- a/collects/scribblings/reference/mz.ss
+++ b/collects/scribblings/reference/mz.ss
@@ -128,6 +128,6 @@
   (define-syntax speed
     (syntax-rules ()
       [(_ id what)
-       (t "An" (scheme id) "application can provide better performance for"
+       (t "An " (scheme id) " application can provide better performance for "
           (elem what)
-          "iteration when it appears directly in a" (scheme for) "clause.")])))
+          " iteration when it appears directly in a " (scheme for) " clause.")])))

From e63e96f07c4427dc986980822bb0c36de647d57a Mon Sep 17 00:00:00 2001
From: Mike Sperber <sperber@deinprogramm.de>
Date: Tue, 1 Dec 2009 12:59:26 +0000
Subject: [PATCH 045/136] Typo fix.

svn: r17132
---
 collects/deinprogramm/scribblings/image.scrbl | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/collects/deinprogramm/scribblings/image.scrbl b/collects/deinprogramm/scribblings/image.scrbl
index 5c1b46baa3..73998dfe5a 100644
--- a/collects/deinprogramm/scribblings/image.scrbl
+++ b/collects/deinprogramm/scribblings/image.scrbl
@@ -88,20 +88,20 @@ Die folgenden Prozeduren erzeugen Bilder mit einfachen geometrischen Formen:
 @defthing[ellipse (natural natural mode image-color -> image)]{
  Der Aufruf @scheme[(ellipse w h m c)]
  erzeugt eine Ellipse mit Breite @scheme[w] und Höhe @scheme[h], gefüllt mit Modus
- @scheme[m] uns in Farbe @scheme[c].}
+ @scheme[m] und in Farbe @scheme[c].}
 
 @defthing[triangle (integer mode image-color -> image)]{ 
  Der Aufruf @scheme[(triangle s m c)]
  erzeugt ein nach oben zeigendes gleichseitiges Dreieck, wobei
  @scheme[s] die Seitenlänge angibt, gefüllt mit Modus
- @scheme[m] uns in Farbe @scheme[c].}
+ @scheme[m] und in Farbe @scheme[c].}
 
 @defthing[line (natural natural number number number number image-color -> image)]{
  Der Aufruf @scheme[(line w h sx sy ex ey c)]
  erzeugt ein Bild mit einer farbigen Strecke, wobei @scheme[w] die Breite und @scheme[h] die Höhe des Bilds,
  sowie @scheme[sx] die X- und @scheme[sx] die Y-Koordinate des Anfangspunkts und 
  @scheme[ex] die X- und @scheme[ey] die Y-Koordinate des Endpunkts angeben, gefüllt mit Modus
- @scheme[m] uns in Farbe @scheme[c].}
+ @scheme[m] und in Farbe @scheme[c].}
 
 @defthing[text (string natural image-color -> image)]{
  Der Aufruf @scheme[(text s f c)]

From 771b203610228e6a51ab7b10b2359fc3328d0c01 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Tue, 1 Dec 2009 13:08:44 +0000
Subject: [PATCH 046/136] removed old translation of --no-argv to -A

svn: r17133
---
 src/mzscheme/cmdline.inc | 2 --
 1 file changed, 2 deletions(-)

diff --git a/src/mzscheme/cmdline.inc b/src/mzscheme/cmdline.inc
index 1c4901c88e..250b7a5b16 100644
--- a/src/mzscheme/cmdline.inc
+++ b/src/mzscheme/cmdline.inc
@@ -681,8 +681,6 @@ static int run_from_cmd_line(int argc, char *_argv[],
       argv[0] = "-j";
     else if (!strcmp("--no-delay", argv[0]))
       argv[0] = "-d";
-    else if (!strcmp("--no-argv", argv[0]))
-      argv[0] = "-A";
     else if (!strcmp("--repl", argv[0]))
       argv[0] = "-i";
     else if (!strcmp("--binary", argv[0]))

From ca5f5656c0f4e2294277b5da46d0e57946f1ec67 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 1 Dec 2009 14:33:09 +0000
Subject: [PATCH 047/136] document `file->list' fix typos in contracts.

svn: r17134
---
 .../scribblings/reference/filesystem.scrbl    | 32 ++++++++++++-------
 1 file changed, 20 insertions(+), 12 deletions(-)

diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl
index 240ece9b6d..9e094ada08 100644
--- a/collects/scribblings/reference/filesystem.scrbl
+++ b/collects/scribblings/reference/filesystem.scrbl
@@ -593,17 +593,6 @@ Reads all characters from @scheme[path] and returns them as a
 @tech{byte string}.  The @scheme[mode-flag] argument is the same as
 for @scheme[open-input-file].}
 
-@defproc[(file->lines [path path-string?]
-                      [#:mode mode-flag (or/c 'binary 'text) 'binary]
-                      [#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any])
-         bytes?]{
-
-Read all characters from @scheme[path], breaking them into lines. The
-@scheme[line-mode] argument is the same as the second argument to
-@scheme[read-line], but the default is @scheme['any] instead of
-@scheme['linefeed]. The @scheme[mode-flag] argument is the same as for
-@scheme[open-input-file].}
-
 @defproc[(file->value [path path-string?]
                       [#:mode mode-flag (or/c 'binary 'text) 'binary])
          bytes?]{
@@ -612,10 +601,29 @@ Reads a single S-expression from @scheme[path] using @scheme[read].
 The @scheme[mode-flag] argument is the same as for
 @scheme[open-input-file].}
 
+@defproc[(file->list [path path-string?] 
+		     [proc (input-port? . -> . any/c) read]
+		     [#:mode mode-flag (or/c 'binary 'text) 'binary])
+		     (listof any/c)]{
+Repeatedly calls @scheme[proc] to consume the contents of
+@scheme[path], until @scheme[eof] is produced. The @scheme[mode-flag]
+argument is the same as for @scheme[open-input-file].  }
+
+@defproc[(file->lines [path path-string?]
+                      [#:mode mode-flag (or/c 'binary 'text) 'binary]
+                      [#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any])
+         (listof string?)]{
+
+Read all characters from @scheme[path], breaking them into lines. The
+@scheme[line-mode] argument is the same as the second argument to
+@scheme[read-line], but the default is @scheme['any] instead of
+@scheme['linefeed]. The @scheme[mode-flag] argument is the same as for
+@scheme[open-input-file].}
+
 @defproc[(file->bytes-lines [path path-string?]
                       [#:mode mode-flag (or/c 'binary 'text) 'binary]
                       [#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any])
-         bytes?]{
+         (listof bytes?)]{
 
 Like @scheme[file->lines], but reading bytes and collecting them into
 lines like @scheme[read-bytes-line].}

From f4049e8c63ade315ab44e071ddd69e7a807b45a9 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 1 Dec 2009 15:05:49 +0000
Subject: [PATCH 048/136] user-defined keybindings now override menu items

svn: r17135
---
 collects/drscheme/private/frame.ss | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/collects/drscheme/private/frame.ss b/collects/drscheme/private/frame.ss
index c1569033b5..26a5b13b37 100644
--- a/collects/drscheme/private/frame.ss
+++ b/collects/drscheme/private/frame.ss
@@ -27,6 +27,13 @@
   
   (define basics-mixin
     (mixin (frame:standard-menus<%>) (basics<%>)
+      
+      (define/override (on-subwindow-char receiver event)
+        (let ([user-key? (send (keymap:get-user) handle-key-event receiver event)])
+          ;; (printf "user-key? ~s\n" user-key?) returns #t for key release events -- is this a problem? (we'll find out!)
+          (or user-key?
+              (super on-subwindow-char receiver event))))
+      
       (inherit get-edit-target-window get-edit-target-object get-menu-bar)
       (define/private (get-menu-bindings)
         (let ([name-ht (make-hasheq)])

From 3d9c4b0ac52dc8d6bb2f3b4eaa676641f70f2cd5 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Tue, 1 Dec 2009 15:11:45 +0000
Subject: [PATCH 049/136] Added `--addon'/`-A', in addition to $PLTADDONDIR
 from revision 17121.

svn: r17136
---
 collects/scribblings/inside/hooks.scrbl       |  7 ++++
 .../scribblings/reference/filesystem.scrbl    | 13 +++++---
 src/mzscheme/cmdline.inc                      | 32 ++++++++++++++++++-
 src/mzscheme/include/scheme.h                 |  1 +
 src/mzscheme/src/file.c                       | 12 ++++++-
 5 files changed, 59 insertions(+), 6 deletions(-)

diff --git a/collects/scribblings/inside/hooks.scrbl b/collects/scribblings/inside/hooks.scrbl
index 52b38198d4..f792483917 100644
--- a/collects/scribblings/inside/hooks.scrbl
+++ b/collects/scribblings/inside/hooks.scrbl
@@ -57,6 +57,13 @@ Sets the path to be returned by @scheme[(find-system-path
 'collects-dir)].}
 
 
+@function[(void scheme_set_addon_path
+           [Scheme_Object* path])]{
+
+Sets the path to be returned by @scheme[(find-system-path
+'addon-dir)].}
+
+
 @function[(void scheme_init_collection_paths_post
            [Scheme_Env* env]
            [Scheme_Object* pre_extra_paths]
diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl
index 9e094ada08..edc90374b2 100644
--- a/collects/scribblings/reference/filesystem.scrbl
+++ b/collects/scribblings/reference/filesystem.scrbl
@@ -80,10 +80,15 @@ by @scheme[kind], which must be one of the following:
 
   ]}
 
- @item{@indexed-scheme['addon-dir] --- a directory for installing PLT Scheme
- extensions. It's the same as @scheme['pref-dir], except under Mac OS
- X, where it is @filepath{Library/PLT Scheme} in the user's home
- directory. This directory might not exist.}
+ @item{@indexed-scheme['addon-dir] --- a directory for installing PLT
+ Scheme extensions. This directory is specified by the
+ @indexed-envvar{PLTADDONDIR} environment variable, and it can be
+ overridden by the @DFlag{addon} or @Flag{A} command-line flag.  If no
+ environment variable or flag is specified, or if the value is not a
+ legal path name, then this directory defaults to
+ @filepath{Library/PLT Scheme} in the user's home directory under Mac
+ OS X and @scheme['pref-dir] otherwise.  This directory might not
+ exist.}
 
  @item{@indexed-scheme['doc-dir] --- the standard directory for
  storing the current user's documents. Under Unix, it's the same as
diff --git a/src/mzscheme/cmdline.inc b/src/mzscheme/cmdline.inc
index 250b7a5b16..ef5510a7af 100644
--- a/src/mzscheme/cmdline.inc
+++ b/src/mzscheme/cmdline.inc
@@ -456,7 +456,9 @@ static int run_from_cmd_line(int argc, char *_argv[],
   GC_CAN_IGNORE char **argv = _argv;
   Scheme_Env *global_env;
   char *prog, *sprog = NULL;
-  Scheme_Object *sch_argv, *collects_path = NULL, *collects_extra = NULL;
+  Scheme_Object *sch_argv,
+                *collects_path = NULL, *collects_extra = NULL,
+                *addon_dir = NULL;
   int i;
 #ifndef DONT_PARSE_COMMAND_LINE
   char **evals_and_loads, *real_switch = NULL, specific_switch[2];
@@ -693,6 +695,8 @@ static int run_from_cmd_line(int argc, char *_argv[],
       argv[0] = "-X";
     else if (!strcmp("--search", argv[0]))
       argv[0] = "-S";
+    else if (!strcmp("--addon", argv[0]))
+      argv[0] = "-A";
 # ifdef CMDLINE_STDIO_FLAG
     else if (!strcmp("--stdio", argv[0]))
       argv[0] = "-z";
@@ -738,6 +742,17 @@ static int run_from_cmd_line(int argc, char *_argv[],
 	  collects_path = scheme_make_path(argv[0]);
           was_config_flag = 1;
 	  break;
+	case 'A':
+	  if (argc < 2) {
+	    PRINTF("%s: missing path after %s switch\n", 
+		   prog, real_switch);
+	    goto show_need_help;
+	  }
+	  argv++;
+	  --argc;
+	  addon_dir = scheme_make_path(argv[0]);
+          was_config_flag = 1;
+	  break;
 	case 'U':
 	  scheme_set_ignore_user_paths(1);
           was_config_flag = 1;
@@ -1041,6 +1056,20 @@ static int run_from_cmd_line(int argc, char *_argv[],
   }
 
 #ifndef NO_FILE_SYSTEM_UTILS
+  /* Setup path for "addon" directory: */
+  {
+#ifdef GETENV_FUNCTION
+    if (!addon_dir) {
+      char *s;
+      s = getenv("PLTADDONDIR");
+      if (s) {
+        s = scheme_expand_filename(s, -1, NULL, NULL, 0);
+        if (s) addon_dir = scheme_make_path(s);
+      }
+    }
+#endif
+    if (addon_dir) scheme_set_addon_dir(addon_dir);
+  }
   /* Setup path for "collects" collection directory: */
   {
     Scheme_Object *l, *r;
@@ -1149,6 +1178,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
          "  -I <path> : Set <init-lib> to <path>\n"
 	 "  -X <dir>, --collects <dir> : Main collects at <dir>\n"
 	 "  -S <dir>, --search <dir> : More collects at <dir> (after main collects)\n"
+	 "  -A <dir>, --addon <dir> : Addon directory at <dir>\n"
 	 "  -U, --no-user-path : Ignore user-specific collects, etc.\n"
 	 "  -N <file>, --name <file> : Sets `(find-system-path 'run-file)' to <file>\n"
 # ifdef MZ_USE_JIT
diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h
index 891b1c4caa..53e15c63f0 100644
--- a/src/mzscheme/include/scheme.h
+++ b/src/mzscheme/include/scheme.h
@@ -1745,6 +1745,7 @@ MZ_EXTERN Scheme_Object *scheme_set_exec_cmd(char *s);
 MZ_EXTERN Scheme_Object *scheme_set_run_cmd(char *s);
 MZ_EXTERN void scheme_set_collects_path(Scheme_Object *p);
 MZ_EXTERN void scheme_set_original_dir(Scheme_Object *d);
+MZ_EXTERN void scheme_set_addon_dir(Scheme_Object *p);
 
 MZ_EXTERN void scheme_init_collection_paths(Scheme_Env *global_env, Scheme_Object *extra_dirs);
 MZ_EXTERN void scheme_init_collection_paths_post(Scheme_Env *global_env, Scheme_Object *extra_dirs, Scheme_Object *extra_post_dirs);
diff --git a/src/mzscheme/src/file.c b/src/mzscheme/src/file.c
index ef2652bfc0..a056c3556b 100644
--- a/src/mzscheme/src/file.c
+++ b/src/mzscheme/src/file.c
@@ -227,7 +227,8 @@ static Scheme_Object *init_dir_symbol, *init_file_symbol, *sys_dir_symbol;
 static Scheme_Object *exec_file_symbol, *run_file_symbol, *collects_dir_symbol;
 static Scheme_Object *pref_file_symbol, *orig_dir_symbol, *addon_dir_symbol;
 
-static Scheme_Object *exec_cmd, *run_cmd, *collects_path, *original_pwd;
+static Scheme_Object *exec_cmd, *run_cmd;
+static Scheme_Object *collects_path, *original_pwd = NULL, *addon_dir = NULL;
 #endif
 static Scheme_Object *windows_symbol, *unix_symbol;
 
@@ -5734,6 +5735,7 @@ find_system_path(int argc, Scheme_Object **argv)
   } else if (argv[0] == orig_dir_symbol) {
     return original_pwd;
   } else if (argv[0] == addon_dir_symbol) {
+    if (addon_dir) return addon_dir;
     which = id_addon_dir;
   } else {
     scheme_wrong_type("find-system-path", "system-path-symbol",
@@ -6023,6 +6025,14 @@ void scheme_set_original_dir(Scheme_Object *d)
   original_pwd = d;
 }
 
+void scheme_set_addon_dir(Scheme_Object *p)
+{
+  if (!addon_dir) {
+    REGISTER_SO(addon_dir);
+  }
+  addon_dir = p;
+}
+
 /********************************************************************************/
 
 #ifdef DOS_FILE_SYSTEM

From 86697e85555f6cdecd3a4276c8d980c12839597f Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 1 Dec 2009 15:59:49 +0000
Subject: [PATCH 050/136] fixed a bug in the last commit (it made keybindings
 get the editor-canvas instead of the editor)

svn: r17138
---
 collects/drscheme/private/frame.ss | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/collects/drscheme/private/frame.ss b/collects/drscheme/private/frame.ss
index 26a5b13b37..ff8c7ca4b0 100644
--- a/collects/drscheme/private/frame.ss
+++ b/collects/drscheme/private/frame.ss
@@ -29,7 +29,12 @@
     (mixin (frame:standard-menus<%>) (basics<%>)
       
       (define/override (on-subwindow-char receiver event)
-        (let ([user-key? (send (keymap:get-user) handle-key-event receiver event)])
+        (let ([user-key? (send (keymap:get-user) 
+                               handle-key-event
+                               (if (is-a? receiver editor-canvas%)
+                                   (send receiver get-editor)
+                                   receiver)
+                               event)])
           ;; (printf "user-key? ~s\n" user-key?) returns #t for key release events -- is this a problem? (we'll find out!)
           (or user-key?
               (super on-subwindow-char receiver event))))

From 788d913bba8b69332970402ca10776846093e0e2 Mon Sep 17 00:00:00 2001
From: Kevin Tew <tewk@racket-lang.org>
Date: Tue, 1 Dec 2009 17:26:45 +0000
Subject: [PATCH 051/136] [Places] MasterGC allocation and collection;
 place_wait; master initiated child collection

svn: r17139
---
 src/mzscheme/gc2/gc2.h     |  11 +-
 src/mzscheme/gc2/newgc.c   | 432 +++++++++++++++++++++++++++++++++----
 src/mzscheme/gc2/newgc.h   |   3 +
 src/mzscheme/gc2/sighand.c |   8 +
 src/mzscheme/src/env.c     |  21 +-
 src/mzscheme/src/mzrt.c    |  21 ++
 src/mzscheme/src/mzrt.h    |   1 +
 src/mzscheme/src/places.c  |  75 ++++++-
 src/mzscheme/src/thread.c  |   9 +
 9 files changed, 529 insertions(+), 52 deletions(-)

diff --git a/src/mzscheme/gc2/gc2.h b/src/mzscheme/gc2/gc2.h
index 8e7f14b69c..6df25495b4 100644
--- a/src/mzscheme/gc2/gc2.h
+++ b/src/mzscheme/gc2/gc2.h
@@ -1,4 +1,3 @@
-
 #ifndef __mzscheme_gc_2__
 #define __mzscheme_gc_2__
 
@@ -419,6 +418,16 @@ GC2_EXTERN unsigned long GC_make_jit_nursery_page();
    with the next GC.
 */
 
+GC2_EXTERN void GC_check_master_gc_request();
+/*
+   Checks to see if the master has requested a places major GC run 
+   and executes a GC if requested
+*/
+
+GC2_EXTERN void GC_set_put_external_event_fd(void *fd);
+/*
+   Sets the fd that can be passed to scheme_signal_received_at to wake up the place for GC
+*/
 
 # ifdef __cplusplus
 };
diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c
index bd6eda90c3..1999ea4e97 100644
--- a/src/mzscheme/gc2/newgc.c
+++ b/src/mzscheme/gc2/newgc.c
@@ -58,6 +58,12 @@
 # define GC_ASSERT(x) /* empty */
 #endif
 
+#if 0
+# define GC_LOCK_DEBUG(args) printf(args)
+#else
+# define GC_LOCK_DEBUG(args) /* empty */
+#endif
+
 /* the page type constants */
 enum {
   PAGE_TAGGED   = 0,
@@ -70,6 +76,12 @@ enum {
   PAGE_TYPES    = 6,
 };
 
+enum {
+  SIZE_CLASS_MED_PAGE   = 1,
+  SIZE_CLASS_BIG_PAGE   = 2,
+  SIZE_CLASS_BIG_PAGE_MARKED = 3,
+};
+
 static const char *type_name[PAGE_TYPES] = { 
   "tagged", 
   "atomic", 
@@ -81,21 +93,53 @@ static const char *type_name[PAGE_TYPES] = {
 
 
 #include "newgc.h"
+
 #ifdef MZ_USE_PLACES
 static NewGC *MASTERGC;
 static NewGCMasterInfo *MASTERGCINFO;
 THREAD_LOCAL_DECL(static objhead GC_objhead_template);
+inline static int premaster_or_master_gc(NewGC *gc) {
+  return (!MASTERGC || gc == MASTERGC);
+}
+inline static int premaster_or_place_gc(NewGC *gc) {
+  return (!MASTERGC || gc != MASTERGC);
+}
+inline static int postmaster_and_master_gc(NewGC *gc) {
+  return (MASTERGC && gc == MASTERGC);
+}
+inline static int postmaster_and_place_gc(NewGC *gc) {
+  return (MASTERGC && gc != MASTERGC);
+}
+static FILE *GCVERBOSEFH;
+static FILE* gcdebugOUT() {
+  if (GCVERBOSEFH) { fflush(GCVERBOSEFH); }
+  else { GCVERBOSEFH = fopen("GCDEBUGOUT", "w"); }
+  return GCVERBOSEFH;
+}
+
+inline static size_t real_page_size(mpage* page);
+#ifdef DEBUG_GC_PAGES
+static void GCVERBOSEPAGE(const char *msg, mpage* page) {
+  fprintf(gcdebugOUT(), "%s %p %p %p\n", msg, page, page->addr, (void*)((long)page->addr + real_page_size(page)));
+}
+#else
+#define GCVERBOSEPAGE(msg, page) /* EMPTY */
 #endif
+
+/* #define KILLING_DEBUG */
+#ifdef KILLING_DEBUG
+static void killing_debug(NewGC *gc, void *info);
+static void marking_rmp_debug(NewGC *gc, void *info);
+#endif
+#else
+#define GCVERBOSEPAGE(msg, page) /* EMPTY */
+#endif
+
 THREAD_LOCAL_DECL(static NewGC *GC);
 #define GCTYPE NewGC
 #define GC_get_GC() (GC)
 #define GC_set_GC(gc) (GC = gc)
 
-#ifdef MZ_USE_PLACES
-inline static int is_master_gc(NewGC *gc) {
-  return (MASTERGC == gc);
-}
-#endif
 
 #include "msgprint.c"
 
@@ -538,7 +582,30 @@ static inline void* REMOVE_BIG_PAGE_PTR_TAG(void *p) {
   return ((void *)((~((unsigned long) 1)) & ((unsigned long) p)));
 }
 
+void GC_check_master_gc_request() {
+#ifdef MZ_USE_PLACES 
+  if (MASTERGC && MASTERGC->major_places_gc == 1 && MASTERGCINFO->have_collected[GC_objhead_template.owner] != 0) {
+    GC_gcollect();
+  }
+#endif
+}
 
+static inline void gc_if_needed_account_alloc_size(NewGC *gc, size_t allocate_size) {
+  if((gc->gen0.current_size + allocate_size) >= gc->gen0.max_size) {
+#ifdef MZ_USE_PLACES 
+    if (postmaster_and_master_gc(gc)) {
+      MASTERGC->major_places_gc = 1;
+    }
+    else {
+#endif
+    if (!gc->dumping_avoid_collection)
+      garbage_collect(gc, 0);
+#ifdef MZ_USE_PLACES 
+    }
+#endif
+  }
+  gc->gen0.current_size += allocate_size;
+}
 
 /* the core allocation functions */
 static void *allocate_big(const size_t request_size_bytes, int type)
@@ -550,6 +617,9 @@ static void *allocate_big(const size_t request_size_bytes, int type)
 
 #ifdef NEWGC_BTC_ACCOUNT
   if(GC_out_of_memory) {
+#ifdef MZ_USE_PLACES 
+  if (premaster_or_place_gc(gc)) {
+#endif
     if (BTC_single_allocation_limit(gc, request_size_bytes)) {
       /* We're allowed to fail. Check for allocations that exceed a single-time
          limit. Otherwise, the limit doesn't work as intended, because
@@ -560,6 +630,9 @@ static void *allocate_big(const size_t request_size_bytes, int type)
          is independent of any existing object, then we can enforce the limit. */
       GC_out_of_memory();
     }
+#ifdef MZ_USE_PLACES 
+  }
+#endif
   }
 #endif
 
@@ -569,10 +642,7 @@ static void *allocate_big(const size_t request_size_bytes, int type)
      aligned for Sparcs. */
   allocate_size = COMPUTE_ALLOC_SIZE_FOR_BIG_PAGE_SIZE(request_size_bytes);
 
-  if((gc->gen0.current_size + allocate_size) >= gc->gen0.max_size) {
-    if (!gc->dumping_avoid_collection)
-      garbage_collect(gc, 0);
-  }
+  gc_if_needed_account_alloc_size(gc, allocate_size);
 
   /* The following allocations may fail and escape if GC_out_of_memory is set.
      We not only need APAGE_SIZE alignment, we 
@@ -590,6 +660,7 @@ static void *allocate_big(const size_t request_size_bytes, int type)
   bpage->size = allocate_size;
   bpage->size_class = 2;
   bpage->page_type = type;
+  GCVERBOSEPAGE("NEW BIG PAGE", bpage);
 
 #ifdef MZ_USE_PLACES
     memcpy(BIG_PAGE_TO_OBJHEAD(bpage), &GC_objhead_template, sizeof(objhead));
@@ -619,6 +690,7 @@ inline static mpage *create_new_medium_page(NewGC *gc, const int sz, const int p
   page->page_type = PAGE_BIG;
   page->previous_size = PREFIX_SIZE;
   page->live_size = sz;
+  GCVERBOSEPAGE("NEW MED PAGE", page);
 
   for (n = page->previous_size; ((n + sz) <= APAGE_SIZE); n += sz) {
     objhead *info = (objhead *)PTR(NUM(page->addr) + n);
@@ -663,6 +735,29 @@ inline static void *medium_page_realloc_dead_slot(NewGC *gc, const int sz, const
   }
   return 0;
 }
+#if defined(linux)
+/* #define MASTER_ALLOC_DEBUG */
+#if defined(MASTER_ALLOC_DEBUG)
+#include <execinfo.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+/* Obtain a backtrace and print it to stdout. */
+void print_libc_backtrace (FILE *file)
+{
+  void *array[100];
+  size_t size;
+  char **strings;
+  size_t i;
+
+  size = backtrace (array, 100);
+  strings = backtrace_symbols (array, size);
+  for (i = 0; i < size; i++)
+    fprintf(file, "%s\n", strings[i]);
+  free (strings);
+}
+#endif
+#endif
 
 static void *allocate_medium(const size_t request_size_bytes, const int type)
 {
@@ -683,7 +778,11 @@ static void *allocate_medium(const size_t request_size_bytes, const int type)
 
   {
     NewGC *gc = GC_get_GC();
-    void * objptr = medium_page_realloc_dead_slot(gc, sz, pos, type);
+    void *objptr;
+
+    /* gc_if_needed_account_alloc_size(gc, sz); */
+
+    objptr = medium_page_realloc_dead_slot(gc, sz, pos, type);
     if (!objptr) {
       mpage *page;
       objhead *info;
@@ -696,6 +795,13 @@ static void *allocate_medium(const size_t request_size_bytes, const int type)
 
       objptr = OBJHEAD_TO_OBJPTR(info);
     }
+#ifdef MASTER_ALLOC_DEBUG
+  if (postmaster_and_master_gc(gc)) {
+    fprintf(gcdebugOUT(), "MASTERGC_allocate_medium %zi %i %i %i %i %p\n", request_size_bytes, type, sz, pos, 1 << (pos +3), objptr);
+    /* print_libc_backtrace(gcdebugOUT()); */
+  }
+#endif
+
     ASSERT_VALID_OBJPTR(objptr);
     return objptr;
   }
@@ -709,6 +815,7 @@ inline static mpage *gen0_create_new_nursery_mpage(NewGC *gc, const size_t page_
   newmpage->size_class = 0;
   newmpage->size = PREFIX_SIZE;
   pagemap_add_with_size(gc->page_maps, newmpage, page_size);
+  GCVERBOSEPAGE("NEW gen0", newmpage);
 
   return newmpage;
 }
@@ -794,6 +901,11 @@ inline static void *allocate(const size_t request_size, const int type)
 
   while (OVERFLOWS_GEN0(newptr)) {
     NewGC *gc = GC_get_GC();
+#ifdef MZ_USE_PLACES
+    if (postmaster_and_master_gc(gc)) {
+      return allocate_medium(request_size, type);
+    }
+#endif
     /* bring page size used up to date */
     gc->gen0.curr_alloc_page->size = GC_gen0_alloc_page_ptr - NUM(gc->gen0.curr_alloc_page->addr);
     gc->gen0.current_size += gc->gen0.curr_alloc_page->size;
@@ -852,7 +964,9 @@ inline static void *allocate(const size_t request_size, const int type)
     info->type = type;
     info->size = BYTES_MULTIPLE_OF_WORD_TO_WORDS(allocate_size); /* ALIGN_BYTES_SIZE bumbed us up to the next word boundary */
     {
+      /* NewGC *gc = GC_get_GC(); */
       void * objptr = OBJHEAD_TO_OBJPTR(info);
+      /* fprintf(gcdebugOUT(), "ALLOCATE page %p %zi %i %p\n", gc->gen0.curr_alloc_page->addr, request_size, type,  objptr); */
       ASSERT_VALID_OBJPTR(objptr);
       return objptr;
     }
@@ -1699,6 +1813,10 @@ int GC_merely_accounting()
 /* administration / initialization                                           */
 /*****************************************************************************/
 
+static inline size_t real_page_size(mpage *page) {
+  return (page->size_class > 1) ? round_to_apage_size(page->size) : APAGE_SIZE;
+}
+
 static int designate_modified_gc(NewGC *gc, void *p)
 {
   mpage *page = pagemap_find_page(gc->page_maps, p);
@@ -1711,7 +1829,7 @@ static int designate_modified_gc(NewGC *gc, void *p)
   if(page) {
     if (!page->back_pointers) {
       page->mprotected = 0;
-      vm_protect_pages(page->addr, (page->size_class > 1) ? round_to_apage_size(page->size) : APAGE_SIZE, 1);
+      vm_protect_pages(page->addr, real_page_size(page), 1);
       page->back_pointers = 1;
     }
     /* For a single mutator thread, we shouldn't get here
@@ -1754,11 +1872,76 @@ static void NewGCMasterInfo_cleanup() {
   MASTERGCINFO = NULL;
 }
 
+static void NewGCMasterInfo_set_have_collected() {
+  MASTERGCINFO->have_collected[GC_objhead_template.owner] = 1;
+}
+
+static void Master_collect() {
+
+  NewGC *gc = GC_get_GC();
+  if (premaster_or_master_gc(gc)) return; /* master shouldn't attempt to start itself */
+
+  GC_switch_to_master_gc();
+  GC_LOCK_DEBUG("MGCLOCK Master_collect\n");
+  
+  if ( MASTERGC->major_places_gc ) {
+    int i = 0;
+    int children_ready = 1;
+    int maxid = MASTERGCINFO->next_GC_id;
+    for (i=1; i < maxid; i++) {
+      int have_collected = MASTERGCINFO->have_collected[i];
+
+      if (have_collected == 1) {
+        printf("%i READY\n", i);
+      }
+      else if ( have_collected == 0) {
+        void *signal_fd = MASTERGCINFO->signal_fds[i];
+        printf("%i NOT COLLECTED\n", i);
+        children_ready = 0;
+        MASTERGCINFO->have_collected[i] = -1;
+        if (signal_fd >= 0 ) { 
+          scheme_signal_received_at(signal_fd);
+        }
+      }
+      else {
+        printf("%i SIGNALED BUT NOT COLLECTED\n", i);
+      }
+    }
+    if (children_ready) {
+      for (i=0; i < maxid; i++) {
+        MASTERGCINFO->have_collected[i] = 0;
+      }
+      printf("START MASTER COLLECTION\n");
+      fprintf(gcdebugOUT(), "START MASTER COLLECTION\n");
+      MASTERGC->major_places_gc = 0;
+      garbage_collect(MASTERGC, 1);
+      printf("END MASTER COLLECTION\n");
+      fprintf(gcdebugOUT(), "END MASTER COLLECTION\n");
+    }
+  }
+
+  GC_LOCK_DEBUG("UNMGCLOCK Master_collect\n");
+  GC_switch_back_from_master(gc);
+}
+
 static void NewGCMasterInfo_get_next_id(NewGC *newgc) {
+  int newid;
   /* this could just be an atomic op if we had those */
   /* waiting for other threads to finish a possible concurrent GC is not optimal*/
   mzrt_rwlock_wrlock(MASTERGCINFO->cangc);
-  GC_objhead_template.owner = MASTERGCINFO->next_GC_id++;
+  newid = MASTERGCINFO->next_GC_id++;
+  GC_objhead_template.owner = newid;
+  /* printf("ALLOCATED GC OID %li\n", GC_objhead_template.owner); */
+  MASTERGCINFO->have_collected = realloc(MASTERGCINFO->have_collected, sizeof(char) * MASTERGCINFO->next_GC_id);
+  MASTERGCINFO->signal_fds = realloc(MASTERGCINFO->signal_fds, sizeof(void*) * MASTERGCINFO->next_GC_id);
+  MASTERGCINFO->have_collected[newid] = 0;
+  MASTERGCINFO->signal_fds[newid] = -1;
+  mzrt_rwlock_unlock(MASTERGCINFO->cangc);
+}
+
+void GC_set_put_external_event_fd(void *fd) {
+  mzrt_rwlock_wrlock(MASTERGCINFO->cangc);
+  MASTERGCINFO->signal_fds[GC_objhead_template.owner] = fd;
   mzrt_rwlock_unlock(MASTERGCINFO->cangc);
 }
 #endif
@@ -1882,8 +2065,16 @@ void GC_switch_out_master_gc() {
   static int initialized = 0;
 
   if(!initialized) {
+    NewGC *gc = GC_get_GC();
     initialized = 1;
-    MASTERGC = GC_get_GC();
+    garbage_collect(gc, 1);
+
+#ifdef MZ_USE_PLACES
+    GC_gen0_alloc_page_ptr = 2;
+    GC_gen0_alloc_page_end = 1;
+#endif
+ 
+    MASTERGC = gc;
     MASTERGC->dumping_avoid_collection = 1;
     save_globals_to_gc(MASTERGC);
     GC_construct_child_gc();
@@ -1905,13 +2096,13 @@ void GC_switch_in_master_gc() {
 void *GC_switch_to_master_gc() {
   NewGC *gc = GC_get_GC();
   /* return if MASTERGC hasn't been constructed yet, allow recursive locking */
-  if (!MASTERGC || gc == MASTERGC) {
-    return MASTERGC;
-  }
+  if (premaster_or_master_gc(gc)) { return MASTERGC; }
+
   save_globals_to_gc(gc);
 
   /*obtain exclusive access to MASTERGC*/
   mzrt_rwlock_wrlock(MASTERGCINFO->cangc);
+  GC_LOCK_DEBUG("MGCLOCK GC_switch_to_master_gc\n");
 
   GC_set_GC(MASTERGC);
   restore_globals_from_gc(MASTERGC);
@@ -1920,19 +2111,18 @@ void *GC_switch_to_master_gc() {
 
 void GC_switch_back_from_master(void *gc) {
   /* return if MASTERGC hasn't been constructed yet, allow recursive locking */
-  if (!MASTERGC || gc == MASTERGC) {
-    return;
-  }
+  if (premaster_or_master_gc(gc)) { return; }
   save_globals_to_gc(MASTERGC);
 
   /*release exclusive access to MASTERGC*/
+  GC_LOCK_DEBUG("UNMGCLOCK GC_switch_to_master_gc\n");
   mzrt_rwlock_unlock(MASTERGCINFO->cangc);
 
   GC_set_GC(gc);
   restore_globals_from_gc(gc);
 }
 
-  
+
 #endif
 
 void GC_gcollect(void)
@@ -1995,8 +2185,13 @@ void GC_mark(const void *const_p)
 
   gc = GC_get_GC();
   if(!(page = pagemap_find_page(gc->page_maps, p))) {
-    GCDEBUG((DEBUGOUTF,"Not marking %p (no page)\n",p));
-    return;
+#ifdef MZ_USE_PLACES
+    if (!MASTERGC || !(page = pagemap_find_page(MASTERGC->page_maps, p)))
+#endif
+    {
+      GCDEBUG((DEBUGOUTF,"Not marking %p (no page)\n",p));
+      return;
+    }
   }
 
   /* toss this over to the BTC mark routine if we're doing accounting */
@@ -2191,6 +2386,11 @@ static inline void propagate_marks_worker(PageMap pagemap, Mark_Proc *mark_table
     mpage *page;
     p = REMOVE_BIG_PAGE_PTR_TAG(pp);
     page = pagemap_find_page(pagemap, p);
+#ifdef MZ_USE_PLACES
+    if (!page) {
+      page = pagemap_find_page(MASTERGC->page_maps, p);
+    }
+#endif
     start = PPTR(BIG_PAGE_TO_OBJECT(page));
     alloc_type = page->page_type;
     end = PAGE_END_VSS(page);
@@ -2526,9 +2726,7 @@ static void reset_gen1_page(NewGC *gc, mpage *work)
 {
   if (gc->generations_available && work->mprotected) {
     work->mprotected = 0;
-    add_protect_page_range(gc->protect_range, work->addr, 
-                           (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, 
-                           APAGE_SIZE, 1);
+    add_protect_page_range(gc->protect_range, work->addr, real_page_size(work), APAGE_SIZE, 1);
   }
 }
 
@@ -2564,9 +2762,7 @@ static void remove_gen1_page_from_pagemap(NewGC *gc, mpage *work)
 {
   if (gc->generations_available && work->back_pointers && work->mprotected) {
     work->mprotected = 0;
-    add_protect_page_range(gc->protect_range, work->addr, 
-                           (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, 
-                           APAGE_SIZE, 1);
+    add_protect_page_range(gc->protect_range, work->addr, real_page_size(work), APAGE_SIZE, 1);
   }
   pagemap_remove(gc->page_maps, work);
   work->added = 0;
@@ -2685,6 +2881,7 @@ mpage *allocate_compact_target(NewGC *gc, mpage *work)
   npage->page_type = work->page_type;
   npage->marked_on = 1;
   backtrace_new_page(gc, npage);
+  GCVERBOSEPAGE("NEW COMPACT PAGE", npage);
   /* Link in this new replacement page */
   npage->prev = work;
   npage->next = work->next;
@@ -2790,22 +2987,84 @@ inline static void do_heap_compact(NewGC *gc)
   }
 }
 
+#ifdef KILLING_DEBUG
+#include <ctype.h>
+static void fprintf_buffer(FILE* file, char* buf, int l) {
+  int i;
+  for (i=0; i < l; i++ ) { fprintf(file, "%02hhx",buf[i]); }
+  fprintf(file, "\n"); 
+  for (i=0; i < l; i++ ) {
+    unsigned char c = buf[i];
+    if(isprint(c)) { fprintf(file, "%c ", c); }
+    else           { fprintf(file, "  "); }
+  }
+  fprintf(file, "\n"); 
+}
+
+static void fprintf_debug(NewGC *gc, const char *msg, objhead *info, FILE* file, int isgc) {
+  if (!isgc || postmaster_and_master_gc(gc)) {
+    Scheme_Object *obj = OBJHEAD_TO_OBJPTR(info);
+    fprintf(file, "%s %p ot %i it %i im %i is %i is >> 3 %i\n", msg, obj, obj->type, info->type, info->mark, info->size, info->size >> 3);
+    switch (obj->type) {
+      case scheme_unix_path_type:
+        if (pagemap_find_page(gc->page_maps, SCHEME_PATH_VAL(obj))) {
+          fprintf_buffer(file, SCHEME_PATH_VAL(obj), SCHEME_PATH_LEN(obj));
+        }
+        else {
+          fprintf(file, "%p already freed and out of bounds\n", SCHEME_PATH_VAL(obj));
+        }
+        break;
+      case scheme_symbol_type:
+        fprintf_buffer(file, SCHEME_SYM_VAL(obj), SCHEME_SYM_LEN(obj));
+        break;
+      case scheme_resolved_module_path_type:
+        if (pagemap_find_page(gc->page_maps, SCHEME_PTR_VAL(obj))) {
+          fprintf_debug(gc, "RMP ", OBJPTR_TO_OBJHEAD(SCHEME_PTR_VAL(obj)), file, isgc);
+        }
+        else {
+          fprintf(file, "RMP %p already freed and out of bounds\n", SCHEME_PATH_VAL(obj));
+        }
+      default:
+        fprintf_buffer(file, ((char *)obj), (info->size * WORD_SIZE));
+        break;
+    }
+  }
+}
+static void killing_debug(NewGC *gc, void *info) {
+  fprintf_debug(gc, "killing", (objhead *) info, gcdebugOUT(), 1);
+}
+static void marking_rmp_debug(NewGC *gc, void *info) {
+  fprintf_debug(gc, "marking rmp", (objhead *) info, gcdebugOUT(), 0);
+}
+#endif
+
 static void repair_heap(NewGC *gc)
 {
   mpage *page;
   int i;
   Fixup_Proc *fixup_table = gc->fixup_table;
+#ifdef MZ_USE_PLACES
+  int master_has_switched = postmaster_and_master_gc(gc);
+#endif
 
   for(i = 0; i < PAGE_TYPES; i++) {
     for(page = gc->gen1_pages[i]; page; page = page->next) {
-      if(page->marked_on) {
+#ifdef MZ_USE_PLACES
+      if (master_has_switched || page->marked_on) {
+#else
+      if (page->marked_on) {
+#endif
         page->has_new = 0;
         /* these are guaranteed not to be protected */
         if(page->size_class)  {
           /* since we get here via gen1_pages, it's a big page */
           void **start = PPTR(BIG_PAGE_TO_OBJECT(page));
           void **end = PAGE_END_VSS(page);
-
+#ifdef MZ_USE_PLACES
+          objhead *info = BIG_PAGE_TO_OBJHEAD(page);
+          if (page->marked_on || info->mark) {
+          page->marked_on = 1;
+#endif
           GCDEBUG((DEBUGOUTF, "Cleaning objs on page %p, starting with %p\n",
                    page, start));
           page->size_class = 2; /* remove the mark */
@@ -2828,6 +3087,9 @@ static void repair_heap(NewGC *gc)
             break;
           }
           }
+#ifdef MZ_USE_PLACES
+          }
+#endif
         } else {
           void **start = PPTR(NUM(page->addr) + page->previous_size);
           void **end = PAGE_END_VSS(page);
@@ -2912,7 +3174,11 @@ static void repair_heap(NewGC *gc)
 
   for (i = 0; i < NUM_MED_PAGE_SIZES; i++) {
     for (page = gc->med_pages[i]; page; page = page->next) {
+#ifdef MZ_USE_PLACES
+      if (master_has_switched || page->marked_on) {
+#else
       if (page->marked_on) {
+#endif
         void **start = PPTR(NUM(page->addr) + PREFIX_SIZE);
         void **end = PPTR(NUM(page->addr) + APAGE_SIZE - page->size);
         
@@ -2936,9 +3202,17 @@ static void repair_heap(NewGC *gc)
                 start += info->size;
               }
               break;
+            case PAGE_ATOMIC:
+              start += info->size;
             }
             info->mark = 0;
+#ifdef MZ_USE_PLACES
+            page->marked_on = 1;
+#endif
           } else {
+#ifdef KILLING_DEBUG
+            killing_debug(gc, info);
+#endif
             info->dead = 1;
             start += info->size;
           }
@@ -2949,10 +3223,9 @@ static void repair_heap(NewGC *gc)
 }
 
 static inline void gen1_free_mpage(PageMap pagemap, mpage *page) {
-  size_t real_page_size = (page->size_class > 1) ? round_to_apage_size(page->size) : APAGE_SIZE;
   pagemap_remove(pagemap, page);
   free_backtrace(page);
-  free_pages(GC, page->addr, real_page_size);
+  free_pages(GC, page->addr, real_page_size(page));
   free_mpage(page);
 }
 
@@ -2963,6 +3236,7 @@ static inline void cleanup_vacated_pages(NewGC *gc) {
   /* Free pages vacated by compaction: */
   while (pages) {
     mpage *next = pages->next;
+    GCVERBOSEPAGE("Cleaning up vacated", pages);
     gen1_free_mpage(pagemap, pages);
     pages = next;
   }
@@ -2980,6 +3254,9 @@ inline static void gen0_free_big_pages(NewGC *gc) {
     free_pages(gc, work->addr, round_to_apage_size(work->size));
     free_mpage(work);
   }
+
+  /* They are all gone, set the pointer to NULL */
+  gc->gen0.big_pages = NULL; 
 }
 
 static void clean_up_heap(NewGC *gc)
@@ -3000,6 +3277,7 @@ static void clean_up_heap(NewGC *gc)
           /* remove work from list */
           if(prev) prev->next = next; else gc->gen1_pages[i] = next;
           if(next) work->next->prev = prev;
+          GCVERBOSEPAGE("Cleaning up BIGPAGE", work);
           gen1_free_mpage(pagemap, work);
         } else {
           pagemap_add(pagemap, work);
@@ -3050,6 +3328,7 @@ static void clean_up_heap(NewGC *gc)
           /* free the page */
           if(prev) prev->next = next; else gc->med_pages[i] = next;
           if(next) work->next->prev = prev;
+          GCVERBOSEPAGE("Cleaning up MED PAGE NO OBJ", work);
           gen1_free_mpage(pagemap, work);
         }
       } else if (gc->gc_full || !work->generation) {
@@ -3058,6 +3337,7 @@ static void clean_up_heap(NewGC *gc)
         next = work->next;
         if(prev) prev->next = next; else gc->med_pages[i] = next;
         if(next) work->next->prev = prev;
+        GCVERBOSEPAGE("Cleaning up MED NO MARKEDON", work);
         gen1_free_mpage(pagemap, work);
       } else {
         /* not touched during minor gc */
@@ -3076,6 +3356,34 @@ static void clean_up_heap(NewGC *gc)
   cleanup_vacated_pages(gc);
 }
 
+static void unprotect_old_pages(NewGC *gc)
+{
+  Page_Range *protect_range = gc->protect_range;
+  mpage *page;
+  int i;
+
+  for(i = 0; i < PAGE_TYPES; i++) {
+    if(i != PAGE_ATOMIC)
+      for(page = gc->gen1_pages[i]; page; page = page->next)
+        if(page->page_type != PAGE_ATOMIC)  {
+          if (page->mprotected) {
+            page->mprotected = 0;
+            add_protect_page_range(protect_range, page->addr, page->size, APAGE_SIZE, 1);
+          }
+        }
+  }
+
+  for (i = 0; i < NUM_MED_PAGE_SIZES; i++) {
+    for (page = gc->med_pages[i]; page; page = page->next) {
+      if (page->mprotected) {
+        page->mprotected = 0;
+        add_protect_page_range(protect_range, page->addr, page->size, APAGE_SIZE, 1);
+      }
+    }
+  }
+
+  flush_protect_page_ranges(protect_range, 0);
+}
 static void protect_old_pages(NewGC *gc)
 {
   Page_Range *protect_range = gc->protect_range;
@@ -3126,9 +3434,21 @@ extern double scheme_get_inexact_milliseconds(void);
 
 static void garbage_collect(NewGC *gc, int force_full)
 {
-  unsigned long old_mem_use = gc->memory_in_use;
-  unsigned long old_gen0    = gc->gen0.current_size;
+  unsigned long old_mem_use;
+  unsigned long old_gen0;
+
   int next_gc_full;
+
+#ifdef MZ_USE_PLACES
+  if (postmaster_and_place_gc(gc)) {
+    mzrt_rwlock_rdlock(MASTERGCINFO->cangc);
+    /* printf("RD MGCLOCK garbage_collect %i\n", GC_objhead_template.owner); */
+  }
+#endif
+
+  old_mem_use = gc->memory_in_use;
+  old_gen0    = gc->gen0.current_size;
+
   TIME_DECLS();
 
   /* determine if this should be a full collection or not */
@@ -3190,7 +3510,7 @@ static void garbage_collect(NewGC *gc, int force_full)
   mark_immobiles(gc);
   TIME_STEP("rooted");
 #ifdef MZ_USE_PLACES
-  if (!is_master_gc(gc))
+  if (premaster_or_place_gc(gc))
 #endif
     GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL);
 
@@ -3234,8 +3554,11 @@ static void garbage_collect(NewGC *gc, int force_full)
 
   TIME_STEP("zeroed");
 
-  if(gc->gc_full) do_heap_compact(gc);
-
+  if(gc->gc_full)
+#ifdef MZ_USE_PLACES
+  if (!MASTERGC)
+#endif
+    do_heap_compact(gc);
   TIME_STEP("compacted");
 
   /* do some cleanup structures that either change state based on the
@@ -3250,7 +3573,7 @@ static void garbage_collect(NewGC *gc, int force_full)
   repair_roots(gc);
   repair_immobiles(gc);
 #ifdef MZ_USE_PLACES
-  if (!is_master_gc(gc))
+  if (premaster_or_place_gc(gc))
 #endif
     GC_fixup_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL);
   TIME_STEP("reparied roots");
@@ -3258,15 +3581,28 @@ static void garbage_collect(NewGC *gc, int force_full)
   TIME_STEP("repaired");
   clean_up_heap(gc);
   TIME_STEP("cleaned heap");
-  reset_nursery(gc);
+#ifdef MZ_USE_PLACES
+  if (premaster_or_place_gc(gc))
+#endif
+    reset_nursery(gc);
   TIME_STEP("reset nursurey");
 #ifdef NEWGC_BTC_ACCOUNT
   if (gc->gc_full)
     BTC_do_accounting(gc);
 #endif
   TIME_STEP("accounted");
-  if (gc->generations_available)
+  if (gc->generations_available) {
+#ifdef MZ_USE_PLACES
+    if (postmaster_and_master_gc(gc)) {
+      unprotect_old_pages(gc);
+    }
+    else {
+      protect_old_pages(gc);
+    }
+#else
     protect_old_pages(gc);
+#endif
+}
   TIME_STEP("protect");
   if (gc->gc_full)
     vm_flush_freed_pages(gc->vm);
@@ -3353,6 +3689,19 @@ static void garbage_collect(NewGC *gc, int force_full)
 
   if (next_gc_full)
     gc->full_needed_for_finalization = 1;
+
+#ifdef MZ_USE_PLACES
+  if (postmaster_and_place_gc(gc)) {
+    if (gc->gc_full) { 
+      NewGCMasterInfo_set_have_collected();
+    }
+    /* printf("UN RD MGCLOCK garbage_collect %i\n", GC_objhead_template.owner); */
+    mzrt_rwlock_unlock(MASTERGCINFO->cangc);
+    if (gc->gc_full) { 
+      Master_collect();
+    }
+  }
+#endif
 }
 
 #if MZ_GC_BACKTRACE
@@ -3412,7 +3761,8 @@ void GC_free_all(void)
       next = work->next;
 
       if (work->mprotected)
-        vm_protect_pages(work->addr, (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, 1);
+        vm_protect_pages(work->addr, real_page_size(work), 1);
+      GCVERBOSEPAGE("Cleaning up GC DYING", work);
       gen1_free_mpage(pagemap, work);
     }
   }
diff --git a/src/mzscheme/gc2/newgc.h b/src/mzscheme/gc2/newgc.h
index cc5962bde8..cfb3acca3c 100644
--- a/src/mzscheme/gc2/newgc.h
+++ b/src/mzscheme/gc2/newgc.h
@@ -88,6 +88,8 @@ typedef struct Page_Range {
 #ifdef MZ_USE_PLACES
 typedef struct NewGCMasterInfo {
   unsigned short next_GC_id;
+  unsigned char *have_collected;
+  void **signal_fds;
   mzrt_rwlock *cangc;
 } NewGCMasterInfo;
 #endif
@@ -173,6 +175,7 @@ typedef struct NewGC {
   /* Distributed GC over places info */
 #ifdef MZ_USE_PLACES
   objhead       saved_GC_objhead_template;
+  int           major_places_gc;   /* :1; */
 #endif
 
  struct mpage *thread_local_pages;
diff --git a/src/mzscheme/gc2/sighand.c b/src/mzscheme/gc2/sighand.c
index 02b69091ad..eea8aeef28 100644
--- a/src/mzscheme/gc2/sighand.c
+++ b/src/mzscheme/gc2/sighand.c
@@ -41,6 +41,8 @@ static void launchgdb() {
 void fault_handler(int sn, struct siginfo *si, void *ctx)
 {
   void *p = si->si_addr;
+  int c = si->si_code;
+  int m = 0;
   if (si->si_code != SEGV_ACCERR) { /*SEGV_MAPERR*/
     printf("SIGSEGV fault on %p\n", p);
 #if WAIT_FOR_GDB
@@ -51,6 +53,12 @@ void fault_handler(int sn, struct siginfo *si, void *ctx)
 
   if (!designate_modified(p)) {
     if (si->si_code == SEGV_ACCERR) {
+#ifdef MZ_USE_PLACES
+      if(pagemap_find_page(MASTERGC->page_maps, p)) {
+        m = 1;
+        printf("OWNED BY MASTER %p\n", p);
+      }
+#endif
       printf("mprotect fault on %p\n", p);
     }
     else {
diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c
index 5c9659a586..d4978d0cb4 100644
--- a/src/mzscheme/src/env.c
+++ b/src/mzscheme/src/env.c
@@ -365,6 +365,14 @@ Scheme_Env *scheme_engine_instance_init() {
   scheme_init_parameterization_readonly_globals();
   env = place_instance_init_post_kernel(1);
 
+#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
+{
+  int signal_fd;
+  signal_fd = scheme_get_signal_handle();
+  GC_set_put_external_event_fd(signal_fd);
+}
+#endif
+
   return env;
 }
 
@@ -498,8 +506,19 @@ static Scheme_Env *place_instance_init_post_kernel(int initial_main_os_thread) {
 }
 
 Scheme_Env *scheme_place_instance_init(void *stack_base) {
+  Scheme_Env *env;
+#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
+  int signal_fd;
+  GC_construct_child_gc();
+#endif
   place_instance_init_pre_kernel(stack_base);
-  return place_instance_init_post_kernel(0);
+  env = place_instance_init_post_kernel(0);
+#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
+  signal_fd = scheme_get_signal_handle();
+  GC_set_put_external_event_fd(signal_fd);
+#endif
+  scheme_set_can_break(1);
+  return env; 
 }
 
 void scheme_place_instance_destroy() {
diff --git a/src/mzscheme/src/mzrt.c b/src/mzscheme/src/mzrt.c
index 352d453011..9bbe396fb0 100644
--- a/src/mzscheme/src/mzrt.c
+++ b/src/mzscheme/src/mzrt.c
@@ -35,6 +35,12 @@ START_XFORM_SUSPEND;
 # endif
 #endif
 
+#ifndef MZ_PRECISE_GC
+int GC_pthread_join(pthread_t thread, void **retval);
+int GC_pthread_create(pthread_t *thread, const pthread_attr_t *attr, void *(*start_routine)(void*), void * arg);
+int GC_pthread_detach(pthread_t thread);
+#endif
+
 void mzrt_set_user_break_handler(void (*user_break_handler)(int))
 {
 #ifdef WIN32
@@ -227,6 +233,21 @@ void * mz_proc_thread_wait(mz_proc_thread *thread) {
 #endif
 }
 
+int mz_proc_thread_detach(mz_proc_thread *thread) {
+#ifdef WIN32
+  DWORD rc;
+  return (void *) rc;
+#else
+  int rc;
+#   ifndef MZ_PRECISE_GC
+  rc = GC_pthread_detach(thread->threadid);
+#   else
+  rc = pthread_detach(thread->threadid);
+#   endif
+  return rc;
+#endif
+}
+
 /***********************************************************************/
 /*                RW Lock                                              */
 /***********************************************************************/
diff --git a/src/mzscheme/src/mzrt.h b/src/mzscheme/src/mzrt.h
index f97ae6e579..751239405c 100644
--- a/src/mzscheme/src/mzrt.h
+++ b/src/mzscheme/src/mzrt.h
@@ -42,6 +42,7 @@ typedef void *(mz_proc_thread_start)(void*);
 mz_proc_thread* mzrt_proc_first_thread_init();
 mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start*, void* data);
 void *mz_proc_thread_wait(mz_proc_thread *thread);
+int mz_proc_thread_detach(mz_proc_thread *thread);
 
 void mzrt_sleep(int seconds);
 
diff --git a/src/mzscheme/src/places.c b/src/mzscheme/src/places.c
index 49abf639f8..7a17ae0a9b 100644
--- a/src/mzscheme/src/places.c
+++ b/src/mzscheme/src/places.c
@@ -132,14 +132,70 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
   return (Scheme_Object*) place;
 }
 
+#ifdef MZ_PRECISE_GC
+typedef struct {
+  mz_proc_thread *proc_thread;
+  Scheme_Place   *waiting_place; 
+  int             wake_fd;
+  int             ready;
+  long            rc;
+} proc_thread_wait_data;
+
+
+static void *mz_proc_thread_wait_worker(void *data) {
+  void           *rc;
+  proc_thread_wait_data *wd = (proc_thread_wait_data*) data;
+
+  rc = mz_proc_thread_wait(wd->proc_thread);
+  wd->rc = (long) rc;
+  wd->ready = 1;
+  scheme_signal_received_at(&wd->wake_fd);
+  return NULL;
+}
+
+static int place_wait_ready(Scheme_Object *o) {
+  proc_thread_wait_data *wd = (proc_thread_wait_data*) o;
+  if (wd->ready) {
+    return 1;
+  }
+  return 0;
+}
+#endif
+
 static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]) {
-  void                  *rc;
   Scheme_Place          *place;
   place = (Scheme_Place *) args[0];
+ 
+#ifdef MZ_PRECISE_GC
+   {
+    Scheme_Object *rc;
+    mz_proc_thread *worker_thread;
+    Scheme_Place *waiting_place;
+    int wake_fd;
 
-  rc = mz_proc_thread_wait((mz_proc_thread *)place->proc_thread);
-  
-  return scheme_void;
+    proc_thread_wait_data *wd;
+    wd = (proc_thread_wait_data*) malloc(sizeof(proc_thread_wait_data));
+    wd->proc_thread = (mz_proc_thread *)place->proc_thread;
+    wd->waiting_place = waiting_place;
+    wake_fd = scheme_get_signal_handle();
+    wd->wake_fd = wake_fd;
+    wd->ready   = 0;
+
+    worker_thread = mz_proc_thread_create(mz_proc_thread_wait_worker, wd);
+    mz_proc_thread_detach(worker_thread);
+    scheme_block_until(place_wait_ready, NULL, (Scheme_Object *) wd, 1.0);
+
+    rc = scheme_make_integer((long)wd->rc);
+    free(wd);
+    return rc;
+  }
+#else
+  {
+    void *rcvoid;
+    rcvoid = mz_proc_thread_wait((mz_proc_thread *)place->proc_thread);
+    return scheme_make_integer((long) rcvoid);
+  }
+#endif
 }
 
 static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[])
@@ -181,6 +237,9 @@ Scheme_Object *scheme_places_deep_copy(Scheme_Object *so)
     case scheme_char_string_type: /*43*/
       new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1);
       break;
+    case scheme_byte_string_type:
+      new_so = scheme_make_sized_offset_byte_string(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
+      break;
     case scheme_unix_path_type:
       new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
       break;
@@ -232,10 +291,8 @@ static void *place_start_proc(void *data_arg) {
   null_out_runtime_globals();
 
   /* scheme_make_thread behaves differently if the above global vars are not null */
-#ifdef MZ_PRECISE_GC
-  GC_construct_child_gc();
-#endif
   scheme_place_instance_init(stack_base);
+
   a[0] = place_data->current_library_collection_paths;
   scheme_current_library_collection_paths(1, a);
 
@@ -337,8 +394,8 @@ void spawn_master_scheme_place() {
   mzrt_proc_first_thread_init();
   
 
-  //scheme_master_proc_thread = mz_proc_thread_create(master_scheme_place, NULL);
-  scheme_master_proc_thread = ~0;
+  /* scheme_master_proc_thread = mz_proc_thread_create(master_scheme_place, NULL); */
+  scheme_master_proc_thread = (void*) ~0;
 
 }
 #endif
diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c
index 86995727bc..7d97d9bfdc 100644
--- a/src/mzscheme/src/thread.c
+++ b/src/mzscheme/src/thread.c
@@ -4142,6 +4142,10 @@ void scheme_thread_block(float sleep_time)
   }
 #endif
 
+/*####################################*/
+/* THREAD CONTEXT SWITCH HAPPENS HERE */
+/*####################################*/
+
   if (next) {
     /* Swap in `next', but first clear references to other threads. */
     swap_target = next;
@@ -4188,6 +4192,11 @@ void scheme_thread_block(float sleep_time)
   if (p->external_break && !p->suspend_break && scheme_can_break(p)) {
     raise_break(p);
   }
+
+  /* Check for major GC request from master GC */
+#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
+  GC_check_master_gc_request(); 
+#endif
   
   if (sleep_end > 0) {
     if (sleep_end > scheme_get_inexact_milliseconds()) {

From 93488dfe1eac324a4525b6e6d4b407d925f2ac8b Mon Sep 17 00:00:00 2001
From: Kevin Tew <tewk@racket-lang.org>
Date: Tue, 1 Dec 2009 17:26:54 +0000
Subject: [PATCH 052/136] [Places] Fix SIGCHLD

svn: r17140
---
 src/mzscheme/src/env.c     |   8 +-
 src/mzscheme/src/mzmark.c  |   2 +-
 src/mzscheme/src/mzrt.c    |   3 +-
 src/mzscheme/src/places.c  | 155 +++++++++++++++++++++++++++++++++--
 src/mzscheme/src/port.c    | 160 +++++++++++++++++++++++++++----------
 src/mzscheme/src/print.c   |   2 +
 src/mzscheme/src/schpriv.h |   5 +-
 src/mzscheme/src/thread.c  |   6 +-
 8 files changed, 287 insertions(+), 54 deletions(-)

diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c
index d4978d0cb4..73ce18a60e 100644
--- a/src/mzscheme/src/env.c
+++ b/src/mzscheme/src/env.c
@@ -356,8 +356,10 @@ Scheme_Env *scheme_engine_instance_init() {
 #endif
 
 #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
+  scheme_places_block_child_signal();
+
   GC_switch_out_master_gc();
-  spawn_master_scheme_place();
+  scheme_spawn_master_place();
 #endif
   
   place_instance_init_pre_kernel(stack_base);
@@ -367,7 +369,7 @@ Scheme_Env *scheme_engine_instance_init() {
 
 #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
 {
-  int signal_fd;
+  int *signal_fd;
   signal_fd = scheme_get_signal_handle();
   GC_set_put_external_event_fd(signal_fd);
 }
@@ -508,7 +510,7 @@ static Scheme_Env *place_instance_init_post_kernel(int initial_main_os_thread) {
 Scheme_Env *scheme_place_instance_init(void *stack_base) {
   Scheme_Env *env;
 #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
-  int signal_fd;
+  int *signal_fd;
   GC_construct_child_gc();
 #endif
   place_instance_init_pre_kernel(stack_base);
diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c
index 5ff15d2952..4e97078bc5 100644
--- a/src/mzscheme/src/mzmark.c
+++ b/src/mzscheme/src/mzmark.c
@@ -3582,7 +3582,7 @@ static int mark_input_fd_FIXUP(void *p) {
 
 #endif
 
-#if defined(UNIX_PROCESSES)
+#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
 static int mark_system_child_SIZE(void *p) {
   return
   gcBYTES_TO_WORDS(sizeof(System_Child));
diff --git a/src/mzscheme/src/mzrt.c b/src/mzscheme/src/mzrt.c
index 9bbe396fb0..4cdad99dc9 100644
--- a/src/mzscheme/src/mzrt.c
+++ b/src/mzscheme/src/mzrt.c
@@ -72,7 +72,8 @@ static void rungdb() {
       case 'd':
         snprintf(outbuffer, 100, "xterm -e gdb ./mzscheme3m %d &", pid);
         fprintf(stderr, "%s\n", outbuffer);
-        system(outbuffer);
+        if(system(outbuffer)) 
+          fprintf(stderr, "system failed\n");
         break;
       case 'e':
       default:
diff --git a/src/mzscheme/src/places.c b/src/mzscheme/src/places.c
index 7a17ae0a9b..ae92403141 100644
--- a/src/mzscheme/src/places.c
+++ b/src/mzscheme/src/places.c
@@ -39,6 +39,7 @@ static Scheme_Object *not_implemented(int argc, Scheme_Object **argv)
 
 # ifdef MZ_PRECISE_GC
 static void register_traversers(void) { }
+
 # endif
 
 #endif
@@ -133,10 +134,151 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
 }
 
 #ifdef MZ_PRECISE_GC
+/*============= SIGNAL HANDLER =============*/
+#include <signal.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+#include <errno.h>
+
+
+static void error_info() {
+  char *erstr;
+  erstr = strerror(errno);
+  printf("errno %i %s\n", errno, erstr);
+}
+
+typedef struct Child_Status {
+  int pid;
+  int status;
+  void *signal_fd;
+  struct Child_Status *next;
+} Child_Status;
+
+static Child_Status *child_statuses = NULL;
+static mzrt_mutex* child_status_lock = NULL;
+
+static void add_child_status(int pid, int status) {
+  Child_Status *st;
+  st = malloc(sizeof(Child_Status));
+  st->pid = pid;
+  st->signal_fd = NULL;
+  st->status = status;
+
+  mzrt_mutex_lock(child_status_lock);
+  st->next = child_statuses;
+  child_statuses = st;
+  mzrt_mutex_unlock(child_status_lock);
+}
+
+static int raw_get_child_status(int pid, int *status) {
+  Child_Status *st;
+  Child_Status *prev;
+  int found = 0;
+
+  for (st = child_statuses, prev = NULL; st; prev = st, st = st->next) {
+    if (st->pid == pid) {
+      *status = st->status;
+      found = 1;
+      if (prev) {
+        prev->next = st->next;
+      }
+      else {
+        child_statuses = st->next;
+      }
+      free(st);
+      break;
+    }
+  }
+  return found;
+}
+
+int scheme_get_child_status(int pid, int *status) {
+  int found = 0;
+  mzrt_mutex_lock(child_status_lock);
+  found = raw_get_child_status(pid, status);
+  mzrt_mutex_unlock(child_status_lock);
+  /* printf("scheme_get_child_status found %i pid %i status %i\n", found,  pid, *status); */
+  return found;
+}
+
+int scheme_places_register_child(int pid, void *signal_fd, int *status) {
+  int found = 0;
+
+  mzrt_mutex_lock(child_status_lock);
+  found = raw_get_child_status(pid, status);
+  if (!found) {
+    Child_Status *st;
+    st = malloc(sizeof(Child_Status));
+    st->pid = pid;
+    st->signal_fd = signal_fd;
+    st->status = 0;
+
+    st->next = child_statuses;
+    child_statuses = st;
+  }
+  mzrt_mutex_unlock(child_status_lock);
+  return found;
+}
+
+static void *mz_proc_thread_signal_worker(void *data) {
+  int status;
+  int pid;
+  sigset_t set;
+  //GC_CAN_IGNORE siginfo_t info;
+  {
+    sigemptyset(&set);
+    sigaddset(&set, SIGCHLD);
+    pthread_sigmask(SIG_UNBLOCK, &set, NULL);
+  }
+
+  while(1) {
+    int rc;
+    int signalid;
+    do {
+      rc = sigwait(&set, &signalid);
+      if (rc == -1) {
+        if (errno != EINTR ) {
+        error_info();
+        }
+      }
+    } while (rc == -1 && errno == EINTR);
+
+    pid = waitpid((pid_t)-1, &status, WNOHANG);
+    if (pid == -1) {
+      char *erstr;
+      erstr = strerror(errno);
+      /* printf("errno %i %s\n", errno, erstr); */
+    }
+    else {
+      /* printf("SIGCHILD pid %i with status %i %i\n", pid, status, WEXITSTATUS(status)); */
+      add_child_status(pid, status);
+    }
+  };
+  return NULL;
+}
+
+
+void scheme_places_block_child_signal() {
+  {
+    sigset_t set;
+    sigemptyset(&set);
+    sigaddset(&set, SIGCHLD);
+    pthread_sigmask(SIG_BLOCK, &set, NULL);
+  }
+
+  {
+    mz_proc_thread *signal_thread;
+    mzrt_mutex_create(&child_status_lock);
+    signal_thread = mz_proc_thread_create(mz_proc_thread_signal_worker, NULL);
+    mz_proc_thread_detach(signal_thread);
+  }
+}
+
+/*============= THREAD JOIN HANDLER =============*/
 typedef struct {
   mz_proc_thread *proc_thread;
   Scheme_Place   *waiting_place; 
-  int             wake_fd;
+  int            *wake_fd;
   int             ready;
   long            rc;
 } proc_thread_wait_data;
@@ -149,7 +291,7 @@ static void *mz_proc_thread_wait_worker(void *data) {
   rc = mz_proc_thread_wait(wd->proc_thread);
   wd->rc = (long) rc;
   wd->ready = 1;
-  scheme_signal_received_at(&wd->wake_fd);
+  scheme_signal_received_at(wd->wake_fd);
   return NULL;
 }
 
@@ -171,7 +313,7 @@ static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]) {
     Scheme_Object *rc;
     mz_proc_thread *worker_thread;
     Scheme_Place *waiting_place;
-    int wake_fd;
+    int *wake_fd;
 
     proc_thread_wait_data *wd;
     wd = (proc_thread_wait_data*) malloc(sizeof(proc_thread_wait_data));
@@ -285,7 +427,7 @@ static void *place_start_proc(void *data_arg) {
   stack_base = PROMPT_STACK(stack_base);
   place_data = (Place_Start_Data *) data_arg;
  
-  printf("Startin place: proc thread id%u\n", ptid);
+  /* printf("Startin place: proc thread id%u\n", ptid); */
 
   /* create pristine THREAD_LOCAL variables*/
   null_out_runtime_globals();
@@ -328,6 +470,8 @@ Scheme_Object *scheme_places_deep_copy_in_master(Scheme_Object *so) {
 
 #ifdef MZ_PRECISE_GC
 static void* scheme_master_place_handlemsg(int msg_type, void *msg_payload);
+
+#if 0
 static void *master_scheme_place(void *data) {
   mz_proc_thread *myself;
   myself = proc_thread_self;
@@ -345,6 +489,7 @@ static void *master_scheme_place(void *data) {
   }
   return NULL;
 }
+#endif
 
 static void* scheme_master_place_handlemsg(int msg_type, void *msg_payload)
 {
@@ -390,7 +535,7 @@ void* scheme_master_fast_path(int msg_type, void *msg_payload) {
 }
 
 
-void spawn_master_scheme_place() {
+void scheme_spawn_master_place() {
   mzrt_proc_first_thread_init();
   
 
diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c
index be14d99b34..b265a2accd 100644
--- a/src/mzscheme/src/port.c
+++ b/src/mzscheme/src/port.c
@@ -169,7 +169,7 @@ int scheme_stupid_windows_machine;
 
 /******************** Unix Subprocesses ********************/
 
-#if defined(UNIX_PROCESSES)
+#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
 /* For process & system: */
 typedef struct System_Child {
   MZTAG_IF_REQUIRED
@@ -186,6 +186,10 @@ typedef struct Scheme_Subprocess {
   Scheme_Object so;
   void *handle;
   int pid;
+#if defined(UNIX_PROCESSES) && defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+  short done;
+  int status;
+#endif
 } Scheme_Subprocess;
 
 #ifdef USE_FD_PORTS
@@ -486,7 +490,7 @@ scheme_init_port (Scheme_Env *env)
   REGISTER_SO(scheme_null_output_port_type);
   REGISTER_SO(scheme_redirect_output_port_type);
 
-#if defined(UNIX_PROCESSES)
+#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
   REGISTER_SO(scheme_system_children);
 #endif
 
@@ -6787,7 +6791,7 @@ static int MyPipe(int *ph, int near_index) {
 
 /**************** Unix: signal stuff ******************/
 
-#if defined(UNIX_PROCESSES)
+#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
 
 # define WAITANY(s) waitpid((pid_t)-1, s, WNOHANG)
 
@@ -6800,6 +6804,7 @@ static int need_to_check_children;
 void scheme_block_child_signals(int block)
   XFORM_SKIP_PROC
 {
+#if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
   sigset_t sigs;
 
   sigemptyset(&sigs);
@@ -6808,6 +6813,7 @@ void scheme_block_child_signals(int block)
   sigaddset(&sigs, SIGPROF);
 #endif
   sigprocmask(block ? SIG_BLOCK : SIG_UNBLOCK, &sigs, NULL);
+#endif
 }
 
 static void child_done(int ingored)
@@ -6825,6 +6831,7 @@ static int sigchld_installed = 0;
 
 static void init_sigchld(void)
 {
+#if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
   if (!sigchld_installed) {
     /* Catch child-done signals */
     START_XFORM_SKIP;
@@ -6833,6 +6840,7 @@ static void init_sigchld(void)
 
     sigchld_installed = 1;
   }
+#endif
 }
 
 static void check_child_done()
@@ -7073,24 +7081,47 @@ scheme_make_redirect_output_port(Scheme_Object *port)
 
 #if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES)
 
-static int subp_done(Scheme_Object *sp)
+static int subp_done(Scheme_Object *so)
 {
-  void *sci = ((Scheme_Subprocess *)sp)->handle;
+  Scheme_Subprocess *sp;
+  sp = (Scheme_Subprocess*) so;
 
 #if defined(UNIX_PROCESSES)
-  System_Child *sc = (System_Child *)sci;
-  check_child_done();
-  return sc->done;
-#endif
-#ifdef WINDOWS_PROCESSES
-  DWORD w;
-  if (sci) {
-    if (GetExitCodeProcess((HANDLE)sci, &w))
-      return w != STILL_ACTIVE;
+# if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+  {
+    int status;
+    if(! sp->done) {
+      if(scheme_get_child_status(((Scheme_Subprocess *)sp)->pid, &status)) {
+        sp->done = 1;
+        sp->status = status;
+        return 1;
+      }
+      return 0;
+    }
     else
       return 1;
-  } else
-    return 1;
+  }
+# else
+  {
+    System_Child *sc;
+    sc = ((System_Child *) ((Scheme_Subprocess *)sp)->handle);
+    check_child_done();
+    return sc->done;
+  }
+# endif
+#endif
+#ifdef WINDOWS_PROCESSES
+  {
+    HANDLE sci = (HANDLE) ((Scheme_Subprocess *)sp)->handle;
+    DWORD w;
+    if (sci) {
+      if (GetExitCodeProcess(sci, &w))
+        return w != STILL_ACTIVE;
+      else
+        return 1;
+    } else
+      return 1;
+  }
 #endif
 }
 
@@ -7116,14 +7147,23 @@ static Scheme_Object *subprocess_status(int argc, Scheme_Object **argv)
     int going = 0, status = MZ_FAILURE_STATUS;
 
 #if defined(UNIX_PROCESSES)
-    System_Child *sc = (System_Child *)sp->handle;
-
-    check_child_done();
-
-    if (sc->done)
-      status = sc->status;
-    else
+# if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+  if (sp->done)
+    status = sp->status;
+  else {
+    if(!scheme_get_child_status(((Scheme_Subprocess *)sp)->pid, &status)) {
       going = 1;
+    }
+  }
+# else
+  System_Child *sc = (System_Child *)sp->handle;
+  check_child_done();
+
+  if (sc->done)
+    status = sc->status;
+  else
+   going = 1;
+# endif
 #else
 # ifdef WINDOWS_PROCESSES
     DWORD w;
@@ -7189,23 +7229,34 @@ static Scheme_Object *subprocess_kill(int argc, Scheme_Object **argv)
     Scheme_Subprocess *sp = (Scheme_Subprocess *)argv[0];
 
 #if defined(UNIX_PROCESSES)
-    {
-      System_Child *sc = (System_Child *)sp->handle;
-
-      check_child_done();
-
-      while (1) {
-	if (sc->done)
-	  return scheme_void;
-
-	if (!kill(sp->pid, SCHEME_TRUEP(argv[1]) ? SIGKILL : SIGINT))
-	  return scheme_void;
-
-	if (errno != EINTR)
-	  break;
-	/* Otherwise we were interrupted. Try `kill' again. */
-      }
+# if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+  {
+    int status;
+    if (sp->done)
+      return scheme_void;
+    if(scheme_get_child_status(sp->pid, &status)) {
+	   return scheme_void;
     }
+  }
+# else
+  {
+    System_Child *sc = (System_Child *)sp->handle;
+
+    check_child_done();
+    if (sc->done)
+      return scheme_void;
+  }
+# endif
+
+  while (1) {
+
+    if (!kill(sp->pid, SCHEME_TRUEP(argv[1]) ? SIGKILL : SIGINT))
+      return scheme_void;
+
+    if (errno != EINTR)
+      break;
+    /* Otherwise we were interrupted. Try `kill' again. */
+  }
 #else
     if (SCHEME_TRUEP(argv[1])) {
       DWORD w;
@@ -7369,6 +7420,16 @@ static long mz_spawnv(char *command, const char * const *argv,
 static void close_subprocess_handle(void *sp, void *ignored)
 {
   Scheme_Subprocess *subproc = (Scheme_Subprocess *)sp;
+  #if defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC)
+  {
+    int status;
+    int pid = ((Scheme_Subprocess *)sp)->pid;
+    scheme_get_child_status(pid, &status)
+    /* printf("close_subprocess_handle pid %i status %i\n", pid status); */
+
+  }
+  #endif
+
   CloseHandle(subproc->handle);
 }
 
@@ -7387,7 +7448,9 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
   char **argv;
   Scheme_Object *in, *out, *err;
 #if defined(UNIX_PROCESSES)
+# if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
   System_Child *sc;
+# endif
   int fork_errno = 0;
 #else
   void *sc = 0;
@@ -7609,6 +7672,7 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
   /*--------------------------------------*/
 
   {
+#if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
     init_sigchld();
 
     sc = MALLOC_ONE_RT(System_Child);
@@ -7619,13 +7683,25 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
     sc->done = 0;
 
     scheme_block_child_signals(1);
+#endif
 
     pid = fork();
 
     if (pid > 0) {
+#if defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC)
+      {
+        int *signal_fd;
+        int status;
+        signal_fd = scheme_get_signal_handle();
+        scheme_places_register_child(pid, signal_fd, &status);
+
+        /* printf("SUBPROCESS  %i\n", pid); */
+      }
+#else
       sc->next = scheme_system_children;
       scheme_system_children = sc;
       sc->id = pid;
+#endif
     } else if (!pid) {
 #ifdef USE_ITIMER
       /* Turn off the timer. */
@@ -7659,7 +7735,9 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
       fork_errno = errno;
     }
 
+#if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
     scheme_block_child_signals(0);
+#endif
   }
 
   switch (pid)
@@ -7807,7 +7885,9 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
 
   subproc = MALLOC_ONE_TAGGED(Scheme_Subprocess);
   subproc->so.type = scheme_subprocess_type;
+#if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
   subproc->handle = (void *)sc;
+#endif
   subproc->pid = pid;
 # if defined(WINDOWS_PROCESSES)
   scheme_add_finalizer(subproc, close_subprocess_handle, NULL);
@@ -8781,7 +8861,7 @@ static void register_traversers(void)
   GC_REG_TRAV(scheme_rt_input_fd, mark_input_fd);
 #endif
 
-#if defined(UNIX_PROCESSES)
+#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC))
   GC_REG_TRAV(scheme_rt_system_child, mark_system_child);
 #endif
 
diff --git a/src/mzscheme/src/print.c b/src/mzscheme/src/print.c
index 6a960455ea..5c797bb912 100644
--- a/src/mzscheme/src/print.c
+++ b/src/mzscheme/src/print.c
@@ -539,6 +539,7 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht
    version takes to long, we back out to the general case. (We don't
    even check for stack overflow, so keep the max limit low.) */
 
+#if !defined(MZ_USE_PLACES)
 static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_checker_counter)
   XFORM_SKIP_PROC
 {
@@ -614,6 +615,7 @@ static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_chec
 
   return cycle;
 }
+#endif
 
 #ifdef DO_STACK_CHECK
 static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht, int *counter, PrintParams *pp);
diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h
index ae18b4d728..91d1b32c7e 100644
--- a/src/mzscheme/src/schpriv.h
+++ b/src/mzscheme/src/schpriv.h
@@ -3250,8 +3250,11 @@ typedef struct Scheme_Symbol_Parts {
   const char *name;
 } Scheme_Symbol_Parts;
 
-void spawn_master_scheme_place();
+void scheme_spawn_master_place();
 void *scheme_master_fast_path(int msg_type, void *msg_payload);
+void scheme_places_block_child_signal();
+int scheme_get_child_status(int pid, int *status);
+int scheme_places_register_child(int pid, void *signal_fd, int *status);
 # endif
 Scheme_Object *scheme_places_deep_copy(Scheme_Object *so);
 #endif
diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c
index 7d97d9bfdc..33341d05b8 100644
--- a/src/mzscheme/src/thread.c
+++ b/src/mzscheme/src/thread.c
@@ -4057,7 +4057,7 @@ void scheme_thread_block(float sleep_time)
   /* Check scheduled_kills early and often. */
   check_scheduled_kills();
 
-#ifdef UNIX_PROCESSES
+#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
   /* Reap zombie processes: */
   scheme_check_child_done();
 #endif
@@ -7371,7 +7371,7 @@ static void get_ready_for_GC()
 #ifdef WINDOWS_PROCESSES
   scheme_suspend_remembered_threads();
 #endif
-#ifdef UNIX_PROCESSES
+#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
   scheme_block_child_signals(1);
 #endif
 
@@ -7402,7 +7402,7 @@ static void done_with_GC()
 #ifdef WINDOWS_PROCESSES
   scheme_resume_remembered_threads();
 #endif
-#ifdef UNIX_PROCESSES
+#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
   scheme_block_child_signals(0);
 #endif
 

From a9f964094af24469cf36f39d2024d5bb25ec5671 Mon Sep 17 00:00:00 2001
From: Kevin Tew <tewk@racket-lang.org>
Date: Tue, 1 Dec 2009 17:27:02 +0000
Subject: [PATCH 053/136] [Places] register OSX mach threads

svn: r17141
---
 src/mzscheme/gc2/sighand.c |  8 +++--
 src/mzscheme/gc2/vm_osx.c  | 73 +++++++++++++++++++++++++++++++++++++-
 src/mzscheme/src/mzrt.c    | 15 ++++++--
 3 files changed, 91 insertions(+), 5 deletions(-)

diff --git a/src/mzscheme/gc2/sighand.c b/src/mzscheme/gc2/sighand.c
index eea8aeef28..6512d3b61e 100644
--- a/src/mzscheme/gc2/sighand.c
+++ b/src/mzscheme/gc2/sighand.c
@@ -1,6 +1,6 @@
 /* 
    Provides:
-      initialize_signal_handler();
+      initialize_signal_handler(GCTYPE *gc)
       remove_signal_handler();
    Requires:
       generations_available - mutable int, Windows only
@@ -147,7 +147,11 @@ void fault_handler(int sn, siginfo_t *si, void *ctx)
 static void initialize_signal_handler(GCTYPE *gc)
 {
 # ifdef NEED_OSX_MACH_HANDLER
-  macosx_init_exception_handler();
+#  if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+  macosx_init_exception_handler(MASTERGC == 0);
+#  else
+  macosx_init_exception_handler(1);
+#  endif
 # endif
 # ifdef NEED_SIGACTION
   {
diff --git a/src/mzscheme/gc2/vm_osx.c b/src/mzscheme/gc2/vm_osx.c
index 6d01b12103..4cf8233177 100644
--- a/src/mzscheme/gc2/vm_osx.c
+++ b/src/mzscheme/gc2/vm_osx.c
@@ -35,6 +35,64 @@ static int designate_modified(void *p);
 int designate_modified(void *p);
 #endif
 
+#if defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC)
+typedef struct OSXThreadData {
+  struct OSXThreadData *next;
+  mach_port_t thread_port_id;
+  Thread_Local_Variables  *tlvs;
+} OSXThreadData; 
+
+/* static const int OSX_THREAD_TABLE_SIZE = 256; */
+#define OSX_THREAD_TABLE_SIZE 256
+static OSXThreadData *osxthreads[OSX_THREAD_TABLE_SIZE];
+static pthread_mutex_t osxthreadsmutex = PTHREAD_MUTEX_INITIALIZER;
+
+static Thread_Local_Variables *get_mach_thread_tlvs(mach_port_t threadid) {
+  int index = threadid % OSX_THREAD_TABLE_SIZE;
+  OSXThreadData *thread;
+  Thread_Local_Variables *tlvs = NULL;
+
+  pthread_mutex_lock(&osxthreadsmutex);
+  {
+    for (thread = osxthreads[index]; thread; thread = thread->next)
+    {
+      if (thread->thread_port_id == threadid) {
+        tlvs = thread->tlvs;
+        break;
+      }
+    }
+  }
+  pthread_mutex_unlock(&osxthreadsmutex);
+
+  return tlvs;
+}
+
+static void set_thread_locals_from_mach_thread_id(mach_port_t threadid) {
+  Thread_Local_Variables *tlvs = get_mach_thread_tlvs(threadid);
+#ifdef USE_THREAD_LOCAL
+  pthread_setspecific(scheme_thread_local_key, tlvs);
+#endif
+}
+
+static void register_mach_thread() {
+  mach_port_t thread_self = mach_thread_self();
+  int index = thread_self % OSX_THREAD_TABLE_SIZE;
+  OSXThreadData * thread = malloc(sizeof(OSXThreadData));
+
+  thread->thread_port_id = thread_self;
+  thread->tlvs = scheme_get_thread_local_variables();
+
+  /* PUSH thread record onto osxthreads datastructure */
+  pthread_mutex_lock(&osxthreadsmutex);
+  {
+    thread->next = osxthreads[index];
+    osxthreads[index] = thread;
+  }
+  pthread_mutex_unlock(&osxthreadsmutex);
+}
+
+#endif
+
 #if defined(__POWERPC__)
 # define ARCH_thread_state_t ppc_thread_state_t
 # define ARCH_THREAD_STATE PPC_THREAD_STATE
@@ -227,6 +285,11 @@ kern_return_t GC_catch_exception_raise(mach_port_t port,
                            &exc_state_count);
     p = (void *)exc_state.__faultvaddr;
 #endif
+
+#if defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC)
+  set_thread_locals_from_mach_thread_id(thread_port);
+#endif
+
     if (designate_modified(p))
       return KERN_SUCCESS;
     else
@@ -306,14 +369,22 @@ void GC_attach_current_thread_exceptions_to_handler()
     GCPRINT(GCOUTF, "Couldn't set exception ports: %s\n", mach_error_string(retval));
     abort();
   }
+#if defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC)
+  register_mach_thread();
+#endif
 }
 
 /* this initializes the subsystem (sets the exception port, starts the
    exception handling thread, etc) */
-static void macosx_init_exception_handler() 
+static void macosx_init_exception_handler(int isMASTERGC)
 {
   kern_return_t retval;
 
+  if (!isMASTERGC) {
+    GC_attach_current_thread_exceptions_to_handler();
+    return;
+  }
+
   if(!task_self) task_self = mach_task_self();
 
   /* allocate the port we're going to get exceptions on */
diff --git a/src/mzscheme/src/mzrt.c b/src/mzscheme/src/mzrt.c
index 4cdad99dc9..2cf35c6197 100644
--- a/src/mzscheme/src/mzrt.c
+++ b/src/mzscheme/src/mzrt.c
@@ -196,6 +196,17 @@ mz_proc_thread* mzrt_proc_first_thread_init() {
 
 mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* data) {
   mz_proc_thread *thread = (mz_proc_thread*)malloc(sizeof(mz_proc_thread));
+  pthread_attr_t *attr;
+
+#ifdef OS_X
+  pthread_attr_t attr_storage;
+  attr = &attr_storage;
+  pthread_attr_init(attr);
+  pthread_attr_setstacksize(attr, 8*1024*1024); /*8MB*/
+#else
+  attr = NULL;
+#endif
+
 #ifdef MZ_PRECISE_GC
   mzrt_thread_stub_data *stub_data = (mzrt_thread_stub_data*)malloc(sizeof(mzrt_thread_stub_data));
   thread->mbox = pt_mbox_create();
@@ -205,13 +216,13 @@ mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* dat
 #   ifdef WIN32
   thread->threadid = CreateThread(NULL, 0, start_proc, data, 0, NULL);
 #   else
-  pthread_create(&thread->threadid, NULL, mzrt_thread_stub, stub_data);
+  pthread_create(&thread->threadid, attr, mzrt_thread_stub, stub_data);
 #   endif
 #else
 #   ifdef WIN32
   thread->threadid = GC_CreateThread(NULL, 0, start_proc, data, 0, NULL);
 #   else
-  GC_pthread_create(&thread->threadid, NULL, start_proc, data);
+  GC_pthread_create(&thread->threadid, attr, start_proc, data);
 #   endif
 #endif
   return thread;

From cb56a1e6041fb9905c033cddff666453f3c50c58 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 1 Dec 2009 18:09:29 +0000
Subject: [PATCH 054/136] added open-in-new-tab docs

svn: r17142
---
 collects/scribblings/tools/unit.scrbl | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/collects/scribblings/tools/unit.scrbl b/collects/scribblings/tools/unit.scrbl
index 10a6699d3d..2f98278140 100644
--- a/collects/scribblings/tools/unit.scrbl
+++ b/collects/scribblings/tools/unit.scrbl
@@ -574,6 +574,11 @@ Shows the interactions window
 Returns the currently active tab.
 
 }
+                                          
+@defmethod[(open-in-new-tab [filename (or/c path-string? #f)]) void?]{
+  Opens a new tab in this frame. If @scheme[filename] is a @scheme[path-string?],
+  It loads that file in the definitions window of the new tab.
+}
 
 @defmethod[#:mode public-final (close-current-tab) void?]{
   Closes the current tab, making some other tab visible.

From 4495620f3b7c57bcf69d5eb4edf3d6b94fc6c930 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 1 Dec 2009 18:33:59 +0000
Subject: [PATCH 055/136] bug fix for syntax-local-value with internal
 definitions context

svn: r17143
---
 src/mzscheme/src/env.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c
index 73ce18a60e..1eb4d678ce 100644
--- a/src/mzscheme/src/env.c
+++ b/src/mzscheme/src/env.c
@@ -4412,7 +4412,7 @@ do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int r
       Scheme_Comp_Env *stx_env;
       if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[2])))
 	scheme_wrong_type(name, "internal-definition context or #f", 2, argc, argv);
-      stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[2]);
+      stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[0];
       if (!scheme_is_sub_env(stx_env, env)) {
 	scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does "
 			 "not match given internal-definition context",

From f8e22d4cadf581e5b221c5a0f03c2c266ddc1427 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 1 Dec 2009 20:32:32 +0000
Subject: [PATCH 056/136] syntax/parse: changed minimatch to use make, catch
 struct errors unstable: added syntax-local-eval,
 internal-definition-context-apply

svn: r17144
---
 collects/syntax/private/stxparse/minimatch.ss |  31 ++++-
 collects/syntax/private/stxparse/rep.ss       |   8 +-
 .../syntax/private/stxparse/runtime-prose.ss  |  30 ++---
 collects/syntax/private/stxparse/runtime.ss   | 112 +++++++++---------
 collects/unstable/scribblings/syntax.scrbl    |  58 +++++++++
 collects/unstable/syntax.ss                   |  59 ++++++++-
 6 files changed, 219 insertions(+), 79 deletions(-)

diff --git a/collects/syntax/private/stxparse/minimatch.ss b/collects/syntax/private/stxparse/minimatch.ss
index b0cf4080db..65c3889edd 100644
--- a/collects/syntax/private/stxparse/minimatch.ss
+++ b/collects/syntax/private/stxparse/minimatch.ss
@@ -1,7 +1,7 @@
 #lang scheme/base
 (require unstable/struct
-         (for-syntax scheme/base unstable/struct))
-(provide match)
+         (for-syntax scheme/base scheme/struct-info unstable/struct))
+(provide match make)
 
 (define-syntax (match stx)
   (syntax-case stx ()
@@ -25,7 +25,7 @@
 
 ;; (match-p id Pattern SuccessExpr FailureExpr)
 (define-syntax (match-p stx)
-  (syntax-case stx (quote cons list)
+  (syntax-case stx (quote cons list make struct)
     [(match-p x wildcard success failure)
      (and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_))
      #'success]
@@ -46,6 +46,27 @@
     [(match-p x var success failure)
      (identifier? #'var)
      #'(let ([var x]) success)]
+    [(match-p x (make S p ...) success failure)
+     #'(match-p x (struct S (p ...)) success failure)]
+    [(match-p x (struct S (p ...)) success failure)
+     (identifier? #'S)
+     (let ()
+       (define (not-a-struct)
+         (raise-syntax-error #f "expected struct name" #'S))
+       (define si (syntax-local-value #'S not-a-struct))
+       (unless (struct-info? si)
+         (not-a-struct))
+       (let* ([si (extract-struct-info si)]
+              [predicate (list-ref si 2)]
+              [accessors (reverse (list-ref si 3))])
+         (unless (andmap identifier? accessors)
+           (raise-syntax-error #f "struct has incomplete information" #'S))
+         (with-syntax ([predicate predicate]
+                       [(accessor ...) accessors])
+           #'(if (predicate x)
+                 (let ([y (list (accessor x) ...)])
+                   (match-p y (list p ...) success failure))
+                 failure))))]
     [(match-p x s success failure)
      (prefab-struct-key (syntax-e #'s))
      (with-syntax ([key (prefab-struct-key (syntax-e #'s))]
@@ -55,3 +76,7 @@
                (let ([xps (cdr (vector->list (struct->vector x)))])
                  (match-p xps (list p ...) success failure))
                failure)))]))
+
+(define-syntax struct
+  (lambda (stx)
+    (raise-syntax-error #f "illegal use of keyword" stx)))
diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss
index c6f02a7256..a907511461 100644
--- a/collects/syntax/private/stxparse/rep.ss
+++ b/collects/syntax/private/stxparse/rep.ss
@@ -693,13 +693,13 @@
 
 (define (check-list-pattern pattern stx)
   (match pattern
-    [#s(pat:datum _base '())
+    [(make pat:datum _base '())
      #t]
-    [#s(pat:head _base _head tail)
+    [(make pat:head _base _head tail)
      (check-list-pattern tail stx)]
-    [#s(pat:dots _base _head tail)
+    [(make pat:dots _base _head tail)
      (check-list-pattern tail stx)]
-    [#s(pat:compound _base '#:pair (list _head tail))
+    [(make pat:compound _base '#:pair (list _head tail))
      (check-list-pattern tail stx)]
     [_
      (wrong-syntax stx "expected proper list pattern")]))
diff --git a/collects/syntax/private/stxparse/runtime-prose.ss b/collects/syntax/private/stxparse/runtime-prose.ss
index 7aa46a6933..7cec766378 100644
--- a/collects/syntax/private/stxparse/runtime-prose.ss
+++ b/collects/syntax/private/stxparse/runtime-prose.ss
@@ -18,7 +18,7 @@
 
 (define (default-failure-handler stx0 f)
   (match (simplify-failure f)
-    [#s(failure x frontier expectation)
+    [(make failure x frontier expectation)
      (report-failure stx0 x (dfc->index frontier) (dfc->stx frontier) expectation)]))
 
 (define current-failure-handler
@@ -68,14 +68,14 @@
 ;; simplify* : Failure -> SimpleFailure
 (define (simplify* f)
   (match f
-    [#s(join-failures f1 f2)
+    [(make join-failures f1 f2)
      (choose-error (simplify* f1) (simplify* f2))]
-    [#s(failure x frontier expectation)
+    [(make failure x frontier expectation)
      (match expectation
-       [#s(expect:thing description '#t chained)
+       [(make expect:thing description '#t chained)
         (let ([chained* (simplify* chained)])
           (match chained*
-            [#s(failure _ chained*-frontier chained*-expectation)
+            [(make failure _ chained*-frontier chained*-expectation)
              (cond [(ineffable? chained*-expectation)
                     ;; If simplified chained failure is ineffable,
                     ;; keep (& adjust) its frontier
@@ -93,14 +93,14 @@
 ;; FIXME: try different selection/simplification algorithms/heuristics
 (define (simplify-failure0 f)
   (match f
-    [#s(join-failures f1 f2)
+    [(make join-failures f1 f2)
      (choose-error (simplify-failure0 f1) (simplify-failure0 f2))]
-    [#s(failure x frontier expectation)
+    [(make failure x frontier expectation)
      (match expectation
-       [#s(expect:thing description '#t chained)
+       [(make expect:thing description '#t chained)
         (let ([chained* (simplify-failure0 chained)])
           (match chained*
-            [#s(failure _ _ chained*-expectation)
+            [(make failure _ _ chained*-expectation)
              (cond [(ineffable? chained*-expectation)
                     ;; If simplified chained failure is ineffable, ignore it
                     ;; and stick to the one with the description
@@ -113,7 +113,7 @@
 
 (define (adjust-failure f base-frontier)
   (match f
-    [#s(failure x frontier expectation)
+    [(make failure x frontier expectation)
      (let ([frontier (dfc-append base-frontier frontier)])
        (make-failure x frontier expectation))]))
 
@@ -147,15 +147,15 @@
 
 (define (for-alternative e index stx)
   (match e
-    [#s(expect:thing description transparent? chained)
+    [(make expect:thing description transparent? chained)
      (format "expected ~a" description)]
-    [#s(expect:atom atom)
+    [(make expect:atom atom)
      (format "expected the literal ~s" atom)]
-    [#s(expect:literal literal)
+    [(make expect:literal literal)
      (format "expected the literal identifier ~s" (syntax-e literal))]
-    [#s(expect:message message)
+    [(make expect:message message)
      (format "~a" message)]
-    [#s(expect:pair)
+    [(make expect:pair)
      (cond [(= index 0)
             "expected sequence of terms"]
            [else
diff --git a/collects/syntax/private/stxparse/runtime.ss b/collects/syntax/private/stxparse/runtime.ss
index 29ee0e8578..5b34ed2353 100644
--- a/collects/syntax/private/stxparse/runtime.ss
+++ b/collects/syntax/private/stxparse/runtime.ss
@@ -2,6 +2,7 @@
 (require scheme/contract/base
          scheme/stxparam
          scheme/list
+         unstable/struct
          "minimatch.ss"
          (for-syntax scheme/base
                      syntax/stx
@@ -159,18 +160,18 @@ A Dynamic Frontier Context (DFC) is one of
 (define-struct dfc:pre (parent stx) #:prefab)
 (define-struct dfc:post (parent stx) #:prefab)
 
-(define (dfc-empty x) (make-dfc:empty x))
+(define (dfc-empty x) (make dfc:empty x))
 (define (dfc-add-car parent stx)
-  (make-dfc:car parent stx))
+  (make dfc:car parent stx))
 (define (dfc-add-cdr parent _)
   (match parent
-    [#s(dfc:cdr uberparent n)
-     (make-dfc:cdr uberparent (add1 n))]
-    [_ (make-dfc:cdr parent 1)]))
+    [(make dfc:cdr uberparent n)
+     (make dfc:cdr uberparent (add1 n))]
+    [_ (make dfc:cdr parent 1)]))
 (define (dfc-add-pre parent stx)
-  (make-dfc:pre parent stx))
+  (make dfc:pre parent stx))
 (define (dfc-add-post parent stx)
-  (make-dfc:post parent stx))
+  (make dfc:post parent stx))
 
 (define (dfc-add-unbox parent stx)
   (dfc-add-car parent stx))
@@ -181,16 +182,16 @@ A Dynamic Frontier Context (DFC) is one of
 
 (define (dfc->index dfc)
   (match dfc
-    [#s(dfc:cdr parent n) n]
+    [(make dfc:cdr parent n) n]
     [_ 0]))
 
 (define (dfc->stx dfc)
   (match dfc
-    [#s(dfc:empty stx) stx]
-    [#s(dfc:car parent stx) stx]
-    [#s(dfc:cdr parent n) (dfc->stx parent)]
-    [#s(dfc:pre parent stx) stx]
-    [#s(dfc:post parent stx) stx]))
+    [(make dfc:empty stx) stx]
+    [(make dfc:car parent stx) stx]
+    [(make dfc:cdr parent n) (dfc->stx parent)]
+    [(make dfc:pre parent stx) stx]
+    [(make dfc:post parent stx) stx]))
 
 ;; dfc-difference : DFC DFC -> nat
 ;; Returns N s.t. B = (dfc-add-cdr^N A)
@@ -199,10 +200,10 @@ A Dynamic Frontier Context (DFC) is one of
     (error 'dfc-difference "~e is not an extension of ~e"
            (frontier->sexpr b) (frontier->sexpr a)))
   (match (list a b)
-    [(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb))
+    [(list (make dfc:cdr pa na) (make dfc:cdr pb nb))
      (unless (equal? pa pb) (whoops))
      (- nb na)]
-    [(list pa #s(dfc:cdr pb nb))
+    [(list pa (make dfc:cdr pb nb))
      (unless (equal? pa pb) (whoops))
      nb]
     [_
@@ -213,16 +214,16 @@ A Dynamic Frontier Context (DFC) is one of
 ;; puts A at the base, B on top
 (define (dfc-append a b)
   (match b
-    [#s(dfc:empty stx) a]
-    [#s(dfc:car pb stx) (make-dfc:car (dfc-append a pb) stx)]
-    [#s(dfc:cdr #s(dfc:empty _) nb)
+    [(make dfc:empty stx) a]
+    [(make dfc:car pb stx) (make dfc:car (dfc-append a pb) stx)]
+    [(make dfc:cdr (make dfc:empty _) nb)
      ;; Special case to merge "consecutive" cdr frames
      (match a
-       [#s(dfc:cdr pa na) (make-dfc:cdr pa (+ na nb))]
-       [_ (make-dfc:cdr a nb)])]
-    [#s(dfc:cdr pb nb) (make-dfc:cdr (dfc-append a pb) nb)]
-    [#s(dfc:pre pb stx) (make-dfc:pre (dfc-append a pb) stx)]
-    [#s(dfc:post pb stx) (make-dfc:post (dfc-append a pb) stx)]))
+       [(make dfc:cdr pa na) (make dfc:cdr pa (+ na nb))]
+       [_ (make dfc:cdr a nb)])]
+    [(make dfc:cdr pb nb) (make dfc:cdr (dfc-append a pb) nb)]
+    [(make dfc:pre pb stx) (make dfc:pre (dfc-append a pb) stx)]
+    [(make dfc:post pb stx) (make dfc:post (dfc-append a pb) stx)]))
 
 
 ;; An Inverted DFC (IDFC) is a DFC inverted for easy comparison.
@@ -230,15 +231,15 @@ A Dynamic Frontier Context (DFC) is one of
 (define (invert-dfc dfc)
   (define (invert dfc acc)
     (match dfc
-      [#s(dfc:empty _) acc]
-      [#s(dfc:car parent stx)
-       (invert parent (make-dfc:car acc stx))]
-      [#s(dfc:cdr parent n)
-       (invert parent (make-dfc:cdr acc n))]
-      [#s(dfc:pre parent stx)
-       (invert parent (make-dfc:pre acc stx))]
-      [#s(dfc:post parent stx)
-       (invert parent (make-dfc:post acc stx))]))
+      [(make dfc:empty _) acc]
+      [(make dfc:car parent stx)
+       (invert parent (make dfc:car acc stx))]
+      [(make dfc:cdr parent n)
+       (invert parent (make dfc:cdr acc n))]
+      [(make dfc:pre parent stx)
+       (invert parent (make dfc:pre acc stx))]
+      [(make dfc:post parent stx)
+       (invert parent (make dfc:post acc stx))]))
   (invert dfc (dfc-empty 'dummy)))
 
 ;; compare-idfcs : IDFC IDFC -> (one-of '< '= '>)
@@ -247,28 +248,28 @@ A Dynamic Frontier Context (DFC) is one of
 (define (compare-idfcs a b)
   (match (list a b)
     ;; Same constructors
-    [(list #s(dfc:empty _) #s(dfc:empty _)) '=]
-    [(list #s(dfc:car pa _) #s(dfc:car pb _))
+    [(list (make dfc:empty _) (make dfc:empty _)) '=]
+    [(list (make dfc:car pa _) (make dfc:car pb _))
      (compare-idfcs pa pb)]
-    [(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb))
+    [(list (make dfc:cdr pa na) (make dfc:cdr pb nb))
      (cond [(< na nb) '<]
            [(> na nb) '>]
            [(= na nb) (compare-idfcs pa pb)])]
-    [(list #s(dfc:pre pa _) #s(dfc:pre pb _))
+    [(list (make dfc:pre pa _) (make dfc:pre pb _))
      ;; FIXME: possibly just '= here, treat all sides as equiv
      (compare-idfcs pa pb)]
-    [(list #s(dfc:post pa _) #s(dfc:post pb _))
+    [(list (make dfc:post pa _) (make dfc:post pb _))
      ;; FIXME: possibly just '= here, treat all sides as equiv
      (compare-idfcs pa pb)]
     ;; Different constructors
-    [(list #s(dfc:empty _) _) '<]
-    [(list _ #s(dfc:empty _)) '>]
-    [(list #s(dfc:pre _ _) _) '<]
-    [(list _ #s(dfc:pre _ _)) '>]
-    [(list #s(dfc:car _ _) _) '<]
-    [(list _ #s(dfc:car _ _)) '>]
-    [(list #s(dfc:cdr _ _) _) '<]
-    [(list _ #s(dfc:cdr _ _)) '>]))
+    [(list (make dfc:empty _) _) '<]
+    [(list _ (make dfc:empty _)) '>]
+    [(list (make dfc:pre _ _) _) '<]
+    [(list _ (make dfc:pre _ _)) '>]
+    [(list (make dfc:car _ _) _) '<]
+    [(list _ (make dfc:car _ _)) '>]
+    [(list (make dfc:cdr _ _) _) '<]
+    [(list _ (make dfc:cdr _ _)) '>]))
 
 (define (idfc>? a b)
   (eq? (compare-idfcs a b) '>))
@@ -344,7 +345,7 @@ A Dynamic Frontier Context (DFC) is one of
                (lambda (f1)
                  (let ([combining-fail
                         (lambda (f2)
-                          (fail (make-join-failures f1 f2)))])
+                          (fail (make join-failures f1 f2)))])
                    (try* rest-attempts combining-fail)))])
           (first-attempt next-fail)))))
 
@@ -380,7 +381,7 @@ An Expectation is one of
   (or/c expect? (symbols 'ineffable)))
 
 (define (merge-expectations a b)
-  (make-expect:disj a b))
+  (make expect:disj a b))
 
 ;; expect->alternatives : Expectation -> (listof Expectation)/#f
 ;; #f indicates 'ineffable somewhere in expectation
@@ -541,7 +542,7 @@ An Expectation is one of
   (define fs
     (let loop ([f f])
       (match f
-        [#s(join-failures f1 f2)
+        [(make join-failures f1 f2)
          (append (loop f1) (loop f2))]
         [_ (list f)])))
   (case (length fs)
@@ -550,20 +551,21 @@ An Expectation is one of
 
 (define (one-failure->sexpr f)
   (match f
-    [#s(failure x frontier expectation)
+    [(make failure x frontier expectation)
      `(failure ,(frontier->sexpr frontier)
                #:term ,(syntax->datum x)
                #:expected ,(expectation->sexpr expectation))]))
 
 (define (frontier->sexpr dfc)
   (match (invert-dfc dfc)
-    [#s(dfc:empty _) '()]
-    [#s(dfc:car p _) (cons 0 (frontier->sexpr p))]
-    [#s(dfc:cdr p n) (cons n (frontier->sexpr p))]
-    [#s(dfc:side p _) (cons 'side (frontier->sexpr p))]))
+    [(make dfc:empty _) '()]
+    [(make dfc:car p _) (cons 0 (frontier->sexpr p))]
+    [(make dfc:cdr p n) (cons n (frontier->sexpr p))]
+    [(make dfc:pre p _) (cons 'pre (frontier->sexpr p))]
+    [(make dfc:post p _) (cons 'post (frontier->sexpr p))]))
 
 (define (expectation->sexpr expectation)
   (match expectation
-    [#s(expect:thing thing '#t chained)
-     (make-expect:thing thing #t (failure->sexpr chained))]
+    [(make expect:thing thing '#t chained)
+     (make expect:thing thing #t (failure->sexpr chained))]
     [_ expectation]))
diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl
index cca32cc1bb..ac2459fc98 100644
--- a/collects/unstable/scribblings/syntax.scrbl
+++ b/collects/unstable/scribblings/syntax.scrbl
@@ -88,6 +88,20 @@ expression.
 
 @;{----}
 
+@defform[(define/with-syntax pattern expr)]{
+
+Definition form of @scheme[with-syntax]. That is, it matches the
+syntax object result of @scheme[expr] against @scheme[pattern] and
+creates pattern variable definitions for the pattern variables of
+@scheme[pattern].
+
+@examples[#:eval the-eval
+(define/with-syntax (px ...) #'(a b c))
+(define/with-syntax (tmp ...) (generate-temporaries #'(px ...)))
+#'([tmp px] ...)
+]
+}
+
 @defform[(define-pattern-variable id expr)]{
 
 Evaluates @scheme[expr] and binds it to @scheme[id] as a pattern
@@ -234,6 +248,50 @@ in the argument list are automatically converted to symbols.
 the second error but not of the first.)
 }
 
+@defproc[(internal-definition-context-apply [intdef-ctx internal-definition-context?]
+                                            [stx syntax?])
+         syntax?]{
+
+Applies the renamings of @scheme[intdef-ctx] to @scheme[stx].
+
+}
+
+@defproc[(syntax-local-eval [stx syntax?]
+                            [intdef-ctx (or/c internal-definition-context? #f) #f])
+         any]{
+
+Evaluates @scheme[stx] as an expression in the current transformer
+environment (that is, at phase level 1), optionally extended with
+@scheme[intdef-ctx].
+
+@examples[#:eval the-eval
+(define-syntax (show-me stx)
+  (syntax-case stx ()
+    [(show-me expr)
+     (begin
+       (printf "at compile time produces ~s\n"
+               (syntax-local-eval #'expr))
+       #'(printf "at run time produes ~s\n"
+                 expr))]))
+(show-me (+ 2 5))
+(define-for-syntax fruit 'apple)
+(define fruit 'pear)
+(show-me fruit)
+#|
+(define-syntax (show-me* stx)
+  (syntax-case stx ()
+    [(show-me expr1)
+     (call-with-values (lambda () (syntax-local-eval #'expr1))
+                       (lambda vals
+                         (with-syntax ([vals vals])
+                           #'(quote vals))))]))
+(define-for-syntax (sum-and-difference a b)
+  (values (+ a b) (- a b)))
+(show-me* (sum-and-difference 12 9))
+|#
+]
+}
+
 @addition{Sam Tobin-Hochstadt}
                      
 @defform[(with-syntax* ([pattern stx-expr] ...)
diff --git a/collects/unstable/syntax.ss b/collects/unstable/syntax.ss
index e4f5e4fb6d..9397876fd8 100644
--- a/collects/unstable/syntax.ss
+++ b/collects/unstable/syntax.ss
@@ -9,6 +9,7 @@
 (provide unwrap-syntax
 
          define-pattern-variable
+         define/with-syntax
 
          with-temporaries
          generate-temporary
@@ -25,7 +26,10 @@
 
          current-syntax-context
          wrong-syntax
-         
+
+         internal-definition-context-apply
+         syntax-local-eval
+
          with-syntax*
          syntax-map)
 
@@ -182,6 +186,57 @@
                         extras)))
 ;; Eli: The `report-error-as' thing seems arbitrary to me.
 
+(define (internal-definition-context-apply intdefs stx)
+  (let ([qastx (local-expand #`(quote #,stx) 'expression (list #'quote) intdefs)])
+    (with-syntax ([(q astx) qastx]) #'astx)))
+
+(define (syntax-local-eval stx [intdef0 #f])
+  (let* ([name (generate-temporary)]
+         [intdefs (syntax-local-make-definition-context intdef0)])
+    (syntax-local-bind-syntaxes (list name)
+                                #`(call-with-values (lambda () #,stx) list)
+                                intdefs)
+    (internal-definition-context-seal intdefs)
+    (apply values
+           (syntax-local-value (internal-definition-context-apply intdefs name)
+                               #f intdefs))))
+
+(define-syntax (define/with-syntax stx)
+  (syntax-case stx ()
+    [(define/with-syntax pattern rhs)
+     (let* ([pvar-env (get-match-vars #'define/with-syntax
+                                      stx
+                                      #'pattern
+                                      '())]
+            [depthmap (for/list ([x pvar-env])
+                        (let loop ([x x] [d 0])
+                          (if (pair? x)
+                              (loop (car x) (add1 d))
+                              (cons x d))))]
+            [pvars (map car depthmap)]
+            [depths (map cdr depthmap)]
+            [mark (make-syntax-introducer)])
+       (with-syntax ([(pvar ...) pvars]
+                     [(depth ...) depths]
+                     [(valvar ...) (generate-temporaries pvars)])
+         #'(begin (define-values (valvar ...)
+                    (with-syntax ([pattern rhs])
+                      (values (pvar-value pvar) ...)))
+                  (define-syntax pvar
+                    (make-syntax-mapping 'depth (quote-syntax valvar)))
+                  ...)))]))
+
+;; auxiliary macro
+(define-syntax (pvar-value stx)
+  (syntax-case stx ()
+    [(_ pvar)
+     (identifier? #'pvar)
+     (let ([mapping (syntax-local-value #'pvar)])
+       (unless (syntax-pattern-variable? mapping)
+         (raise-syntax-error #f "not a pattern variable" #'pvar))
+       (syntax-mapping-valvar mapping))]))
+
+
 (define-syntax (with-syntax* stx)
   (syntax-case stx ()
     [(_ (cl) body ...) #'(with-syntax (cl) body ...)]
@@ -189,4 +244,4 @@
      #'(with-syntax (cl) (with-syntax* (cls ...) body ...))]))
 
 (define (syntax-map f . stxls)
-  (apply map f (map syntax->list stxls)))
\ No newline at end of file
+  (apply map f (map syntax->list stxls)))

From a22d201d85036e8d964d8c3eea08deb66199dbac Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 1 Dec 2009 20:34:42 +0000
Subject: [PATCH 057/136] Changes so far.

svn: r17146
---
 collects/drscheme/private/tools.ss            |  4 +++-
 collects/scribble/lp-include.ss               |  4 ++--
 collects/syntax/module-reader.ss              | 24 ++++++++++++++++++-
 .../syntax/scribblings/module-reader.scrbl    |  9 +++++--
 4 files changed, 35 insertions(+), 6 deletions(-)

diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss
index 3e16767fcc..e446f0b925 100644
--- a/collects/drscheme/private/tools.ss
+++ b/collects/drscheme/private/tools.ss
@@ -316,6 +316,8 @@
        
        (let loop ([sexp full-sexp])
          (match sexp
+           [`((#%module-begin ,body ...))
+            (loop body)]
            [`((provide/doc (,x ,name ,ctc ,other ...) ...) ,rest ...)
             #`(let #,(map (λ (name ctc) 
                             (with-syntax ([name (datum->syntax #'tool-name name)]
@@ -331,7 +333,7 @@
            [`(,a . ,b) 
             (loop b)]
            [`()
-            (error 'tcl.ss "did not find provide/doc" full-sexp)])))]))
+            (error 'tcl.ss "did not find provide/doc: ~a" full-sexp)])))]))
 
 ;; invoke-tool : unit/sig string -> (values (-> void) (-> void))
 ;; invokes the tools and returns the two phase thunks.
diff --git a/collects/scribble/lp-include.ss b/collects/scribble/lp-include.ss
index dfc75496a8..09a3262180 100644
--- a/collects/scribble/lp-include.ss
+++ b/collects/scribble/lp-include.ss
@@ -7,8 +7,8 @@
 (provide lp-include)
 
 (define-syntax (module stx)
-  (syntax-case stx ()
-    [(module name base body ...)
+  (syntax-case stx (#%module-begin)
+    [(module name base (#%module-begin body ...))
      (begin
        #'(begin body ...))]))
 
diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index ad3f13e394..a84fb571a4 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -10,6 +10,20 @@
 
   (define ar? procedure-arity-includes?)
 
+  ;; Takes either a syntax object representing a list of expressions
+  ;; or a list of s-expressions, and checks to see if it's a single
+  ;; expression that begins with the literal #%module-begin.
+  (define (contains-#%module-begin exps)
+    (let ([exps (if (syntax? exps) (syntax->list exps) exps)])
+      (and exps
+           (pair? exps) 
+           (null? (cdr exps))
+           (let ([exp (car exps)])
+             (let ([lst (if (syntax? exp) (syntax->list exp) exp)])
+               (and lst
+                    (let ([head (if (syntax? (car lst)) (syntax-e (car lst)) (car lst))])
+                      (eq? '#%module-begin head))))))))
+
   (define-syntax (provide-module-reader stx)
     (define (err str [sub #f])
       (raise-syntax-error 'syntax/module-reader str sub))
@@ -170,7 +184,15 @@
                                         (- (or (syntax-position modpath) (add1 pos))
                                            pos)))
                           v))]
-           [r `(,(tag-src 'module) ,(tag-src name) ,lang . ,body)])
+           ;; Since there are users that wrap with #%module-begin in their reader,
+           ;; we need to avoid double-wrapping. 
+           [wrapped-body (if (contains-#%module-begin body)
+                             body
+                             (let ([wrapped `(#%module-begin . ,body)])
+                               (if stx?
+                                   (datum->syntax #f wrapped all-loc)
+                                   wrapped)))]
+           [r `(,(tag-src 'module) ,(tag-src name) ,lang ,wrapped-body)])
       (if stx? (datum->syntax #f r all-loc) r)))
 
   (define (wrap lang port read modpath src line col pos)
diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl
index 378f19af64..624f717ed5 100644
--- a/collects/syntax/scribblings/module-reader.scrbl
+++ b/collects/syntax/scribblings/module-reader.scrbl
@@ -46,7 +46,7 @@ into
 
 @schemeblock[
 (module _name-id module-path
-  ....)
+  (#%module-begin ....))
 ]
 
 where @scheme[_name-id] is derived from the name of the port used by
@@ -136,7 +136,12 @@ In some cases, the reader functions read the whole file, so there is
 no need to iterate them (e.g., Scribble's @scheme[read-inside] and
 @scheme[read-syntax-inside]).  In these cases you can specify
 @scheme[#:whole-body-readers?] as @scheme[#t] --- the readers are
-expected to return a list of expressions in this case.
+expected to return a list of expressions in this case.  If those
+reader functions return a list with a single expression that begins
+with @scheme[#%module-begin], then the @scheme[syntax/module-reader]
+language will not inappropriately add another.  This is to be
+backwards-compatible with older code, and adding @scheme[#%module-begin]
+in the reader functions should be considered deprecated behavior.
 
 In addition, the two wrappers can return a different value than the
 wrapped function.  This introduces two more customization points for

From 53eb309b75b334f09ef7aaa6329d7d5cc83b9aed Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 1 Dec 2009 20:36:38 +0000
Subject: [PATCH 058/136] Revert previous bad addition to trunk, forgot to
 switch first.

svn: r17147
---
 collects/drscheme/private/tools.ss            |  4 +---
 collects/scribble/lp-include.ss               |  4 ++--
 collects/syntax/module-reader.ss              | 24 +------------------
 .../syntax/scribblings/module-reader.scrbl    |  9 ++-----
 4 files changed, 6 insertions(+), 35 deletions(-)

diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss
index e446f0b925..3e16767fcc 100644
--- a/collects/drscheme/private/tools.ss
+++ b/collects/drscheme/private/tools.ss
@@ -316,8 +316,6 @@
        
        (let loop ([sexp full-sexp])
          (match sexp
-           [`((#%module-begin ,body ...))
-            (loop body)]
            [`((provide/doc (,x ,name ,ctc ,other ...) ...) ,rest ...)
             #`(let #,(map (λ (name ctc) 
                             (with-syntax ([name (datum->syntax #'tool-name name)]
@@ -333,7 +331,7 @@
            [`(,a . ,b) 
             (loop b)]
            [`()
-            (error 'tcl.ss "did not find provide/doc: ~a" full-sexp)])))]))
+            (error 'tcl.ss "did not find provide/doc" full-sexp)])))]))
 
 ;; invoke-tool : unit/sig string -> (values (-> void) (-> void))
 ;; invokes the tools and returns the two phase thunks.
diff --git a/collects/scribble/lp-include.ss b/collects/scribble/lp-include.ss
index 09a3262180..dfc75496a8 100644
--- a/collects/scribble/lp-include.ss
+++ b/collects/scribble/lp-include.ss
@@ -7,8 +7,8 @@
 (provide lp-include)
 
 (define-syntax (module stx)
-  (syntax-case stx (#%module-begin)
-    [(module name base (#%module-begin body ...))
+  (syntax-case stx ()
+    [(module name base body ...)
      (begin
        #'(begin body ...))]))
 
diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index a84fb571a4..ad3f13e394 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -10,20 +10,6 @@
 
   (define ar? procedure-arity-includes?)
 
-  ;; Takes either a syntax object representing a list of expressions
-  ;; or a list of s-expressions, and checks to see if it's a single
-  ;; expression that begins with the literal #%module-begin.
-  (define (contains-#%module-begin exps)
-    (let ([exps (if (syntax? exps) (syntax->list exps) exps)])
-      (and exps
-           (pair? exps) 
-           (null? (cdr exps))
-           (let ([exp (car exps)])
-             (let ([lst (if (syntax? exp) (syntax->list exp) exp)])
-               (and lst
-                    (let ([head (if (syntax? (car lst)) (syntax-e (car lst)) (car lst))])
-                      (eq? '#%module-begin head))))))))
-
   (define-syntax (provide-module-reader stx)
     (define (err str [sub #f])
       (raise-syntax-error 'syntax/module-reader str sub))
@@ -184,15 +170,7 @@
                                         (- (or (syntax-position modpath) (add1 pos))
                                            pos)))
                           v))]
-           ;; Since there are users that wrap with #%module-begin in their reader,
-           ;; we need to avoid double-wrapping. 
-           [wrapped-body (if (contains-#%module-begin body)
-                             body
-                             (let ([wrapped `(#%module-begin . ,body)])
-                               (if stx?
-                                   (datum->syntax #f wrapped all-loc)
-                                   wrapped)))]
-           [r `(,(tag-src 'module) ,(tag-src name) ,lang ,wrapped-body)])
+           [r `(,(tag-src 'module) ,(tag-src name) ,lang . ,body)])
       (if stx? (datum->syntax #f r all-loc) r)))
 
   (define (wrap lang port read modpath src line col pos)
diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl
index 624f717ed5..378f19af64 100644
--- a/collects/syntax/scribblings/module-reader.scrbl
+++ b/collects/syntax/scribblings/module-reader.scrbl
@@ -46,7 +46,7 @@ into
 
 @schemeblock[
 (module _name-id module-path
-  (#%module-begin ....))
+  ....)
 ]
 
 where @scheme[_name-id] is derived from the name of the port used by
@@ -136,12 +136,7 @@ In some cases, the reader functions read the whole file, so there is
 no need to iterate them (e.g., Scribble's @scheme[read-inside] and
 @scheme[read-syntax-inside]).  In these cases you can specify
 @scheme[#:whole-body-readers?] as @scheme[#t] --- the readers are
-expected to return a list of expressions in this case.  If those
-reader functions return a list with a single expression that begins
-with @scheme[#%module-begin], then the @scheme[syntax/module-reader]
-language will not inappropriately add another.  This is to be
-backwards-compatible with older code, and adding @scheme[#%module-begin]
-in the reader functions should be considered deprecated behavior.
+expected to return a list of expressions in this case.
 
 In addition, the two wrappers can return a different value than the
 wrapped function.  This introduces two more customization points for

From 6639a2982927729466b32da3cae75a0f99db33ed Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Tue, 1 Dec 2009 20:39:46 +0000
Subject: [PATCH 059/136] non-greedy matching

svn: r17149
---
 collects/honu/private/macro.ss | 20 +++++++++++++++++---
 1 file changed, 17 insertions(+), 3 deletions(-)

diff --git a/collects/honu/private/macro.ss b/collects/honu/private/macro.ss
index 934bad9a77..1043c8c224 100644
--- a/collects/honu/private/macro.ss
+++ b/collects/honu/private/macro.ss
@@ -368,12 +368,26 @@
           (#%braces (#%braces name pattern ...))
           (#%braces (#%braces template ...))
           . rest)
-       (with-syntax ([pulled (pull #'(template ...))])
+       (with-syntax ([pulled (pull #'(template ...))]
+                     [(pattern* ...) (map (lambda (stx)
+                                            (if (and (identifier? stx)
+                                                     (not (ormap (lambda (f)
+                                                                   (free-identifier=? stx f))
+                                                                 (syntax->list #'(honu-literal ...))))
+                                                     (not (free-identifier=? stx #'(... ...))))
+                                                (with-syntax ([x stx])
+                                                  #'(~and x (~not (~or honu-literal ...))))
+                                                stx))
+                                          (syntax->list #'(pattern ...)))]
+                     )
          (values
           #'(define-honu-syntax name
               (lambda (stx ctx)
-                (syntax-case stx (honu-literal ...)
-                  [(name pattern ... . rrest)
+                ;; (define-literal-set literals (honu-literal ...))
+                (syntax-parse stx
+                              ;; #:literal-sets (literals)
+                              #:literals (honu-literal ...)
+                  [(name pattern* ... . rrest)
                    (with-syntax ([(out (... ...)) (unpull #'pulled)])
                      (values
                       #'(honu-unparsed-block

From 75803d488132e6824e27c443370d7ff60eaf4011 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 1 Dec 2009 20:39:58 +0000
Subject: [PATCH 060/136] Here's the changes that accidentally went to trunk
 first.

svn: r17150
---
 collects/drscheme/private/tools.ss            |  4 +++-
 collects/scribble/lp-include.ss               |  4 ++--
 collects/syntax/module-reader.ss              | 24 ++++++++++++++++++-
 .../syntax/scribblings/module-reader.scrbl    |  9 +++++--
 4 files changed, 35 insertions(+), 6 deletions(-)

diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss
index 3e16767fcc..e446f0b925 100644
--- a/collects/drscheme/private/tools.ss
+++ b/collects/drscheme/private/tools.ss
@@ -316,6 +316,8 @@
        
        (let loop ([sexp full-sexp])
          (match sexp
+           [`((#%module-begin ,body ...))
+            (loop body)]
            [`((provide/doc (,x ,name ,ctc ,other ...) ...) ,rest ...)
             #`(let #,(map (λ (name ctc) 
                             (with-syntax ([name (datum->syntax #'tool-name name)]
@@ -331,7 +333,7 @@
            [`(,a . ,b) 
             (loop b)]
            [`()
-            (error 'tcl.ss "did not find provide/doc" full-sexp)])))]))
+            (error 'tcl.ss "did not find provide/doc: ~a" full-sexp)])))]))
 
 ;; invoke-tool : unit/sig string -> (values (-> void) (-> void))
 ;; invokes the tools and returns the two phase thunks.
diff --git a/collects/scribble/lp-include.ss b/collects/scribble/lp-include.ss
index dfc75496a8..09a3262180 100644
--- a/collects/scribble/lp-include.ss
+++ b/collects/scribble/lp-include.ss
@@ -7,8 +7,8 @@
 (provide lp-include)
 
 (define-syntax (module stx)
-  (syntax-case stx ()
-    [(module name base body ...)
+  (syntax-case stx (#%module-begin)
+    [(module name base (#%module-begin body ...))
      (begin
        #'(begin body ...))]))
 
diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index ad3f13e394..a84fb571a4 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -10,6 +10,20 @@
 
   (define ar? procedure-arity-includes?)
 
+  ;; Takes either a syntax object representing a list of expressions
+  ;; or a list of s-expressions, and checks to see if it's a single
+  ;; expression that begins with the literal #%module-begin.
+  (define (contains-#%module-begin exps)
+    (let ([exps (if (syntax? exps) (syntax->list exps) exps)])
+      (and exps
+           (pair? exps) 
+           (null? (cdr exps))
+           (let ([exp (car exps)])
+             (let ([lst (if (syntax? exp) (syntax->list exp) exp)])
+               (and lst
+                    (let ([head (if (syntax? (car lst)) (syntax-e (car lst)) (car lst))])
+                      (eq? '#%module-begin head))))))))
+
   (define-syntax (provide-module-reader stx)
     (define (err str [sub #f])
       (raise-syntax-error 'syntax/module-reader str sub))
@@ -170,7 +184,15 @@
                                         (- (or (syntax-position modpath) (add1 pos))
                                            pos)))
                           v))]
-           [r `(,(tag-src 'module) ,(tag-src name) ,lang . ,body)])
+           ;; Since there are users that wrap with #%module-begin in their reader,
+           ;; we need to avoid double-wrapping. 
+           [wrapped-body (if (contains-#%module-begin body)
+                             body
+                             (let ([wrapped `(#%module-begin . ,body)])
+                               (if stx?
+                                   (datum->syntax #f wrapped all-loc)
+                                   wrapped)))]
+           [r `(,(tag-src 'module) ,(tag-src name) ,lang ,wrapped-body)])
       (if stx? (datum->syntax #f r all-loc) r)))
 
   (define (wrap lang port read modpath src line col pos)
diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl
index 378f19af64..624f717ed5 100644
--- a/collects/syntax/scribblings/module-reader.scrbl
+++ b/collects/syntax/scribblings/module-reader.scrbl
@@ -46,7 +46,7 @@ into
 
 @schemeblock[
 (module _name-id module-path
-  ....)
+  (#%module-begin ....))
 ]
 
 where @scheme[_name-id] is derived from the name of the port used by
@@ -136,7 +136,12 @@ In some cases, the reader functions read the whole file, so there is
 no need to iterate them (e.g., Scribble's @scheme[read-inside] and
 @scheme[read-syntax-inside]).  In these cases you can specify
 @scheme[#:whole-body-readers?] as @scheme[#t] --- the readers are
-expected to return a list of expressions in this case.
+expected to return a list of expressions in this case.  If those
+reader functions return a list with a single expression that begins
+with @scheme[#%module-begin], then the @scheme[syntax/module-reader]
+language will not inappropriately add another.  This is to be
+backwards-compatible with older code, and adding @scheme[#%module-begin]
+in the reader functions should be considered deprecated behavior.
 
 In addition, the two wrappers can return a different value than the
 wrapped function.  This introduces two more customization points for

From d113d2d19a425ae11bba08ba244b2fbe3c938322 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 1 Dec 2009 20:44:27 +0000
Subject: [PATCH 061/136] Specifically mention #:wrapper1 as well, since that's
 also a common place for doing this.

svn: r17151
---
 collects/syntax/scribblings/module-reader.scrbl | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl
index 624f717ed5..395852dc16 100644
--- a/collects/syntax/scribblings/module-reader.scrbl
+++ b/collects/syntax/scribblings/module-reader.scrbl
@@ -141,7 +141,8 @@ reader functions return a list with a single expression that begins
 with @scheme[#%module-begin], then the @scheme[syntax/module-reader]
 language will not inappropriately add another.  This is to be
 backwards-compatible with older code, and adding @scheme[#%module-begin]
-in the reader functions should be considered deprecated behavior.
+in the reader functions or in the function specified by @scheme[#:wrapper1]
+should be considered deprecated behavior.
 
 In addition, the two wrappers can return a different value than the
 wrapped function.  This introduces two more customization points for

From 39689ae4e7c482c92b8bf4ba6ac41279532c00c3 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 1 Dec 2009 21:14:24 +0000
Subject: [PATCH 062/136] Elaborate in this comment.

svn: r17152
---
 collects/syntax/module-reader.ss | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index a84fb571a4..a66b1248cb 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -184,8 +184,10 @@
                                         (- (or (syntax-position modpath) (add1 pos))
                                            pos)))
                           v))]
-           ;; Since there are users that wrap with #%module-begin in their reader,
-           ;; we need to avoid double-wrapping. 
+           ;; Since there are users that wrap with #%module-begin in their reader
+           ;; or wrapper1 functions, we need to avoid double-wrapping.  Having to
+           ;; do this for #lang readers should be considered deprecated, and
+           ;; hopefully one day we'll move to just doing it unilaterally.
            [wrapped-body (if (contains-#%module-begin body)
                              body
                              (let ([wrapped `(#%module-begin . ,body)])

From a24dd4affb74fad2e3704eb3f66e6b4f4ae74e57 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 1 Dec 2009 21:27:55 +0000
Subject: [PATCH 063/136] Have to handle the fact that "body" is a (possibly
 syntax) list of expressions here.  Could also pull out the car of said list
 and just return that, but eh.  This code is going to be crap until (if) we
 can ever remove the need to be backwards compatible.

svn: r17153
---
 collects/syntax/module-reader.ss | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index a66b1248cb..1908e90f45 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -192,9 +192,9 @@
                              body
                              (let ([wrapped `(#%module-begin . ,body)])
                                (if stx?
-                                   (datum->syntax #f wrapped all-loc)
-                                   wrapped)))]
-           [r `(,(tag-src 'module) ,(tag-src name) ,lang ,wrapped-body)])
+                                   (list (datum->syntax #f wrapped all-loc))
+                                   (list wrapped))))]
+           [r `(,(tag-src 'module) ,(tag-src name) ,lang . ,wrapped-body)])
       (if stx? (datum->syntax #f r all-loc) r)))
 
   (define (wrap lang port read modpath src line col pos)

From 4c61aabea04fba12037203821caaa97e1619d82a Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 1 Dec 2009 21:58:58 +0000
Subject: [PATCH 064/136] Actually, just have the descender return the
 #%module-begin expression, if it finds one, and otherwise do the wrapping
 appropriately.

svn: r17154
---
 collects/syntax/module-reader.ss | 39 +++++++++++++++++---------------
 1 file changed, 21 insertions(+), 18 deletions(-)

diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index 1908e90f45..d96afb82ee 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -12,17 +12,25 @@
 
   ;; Takes either a syntax object representing a list of expressions
   ;; or a list of s-expressions, and checks to see if it's a single
-  ;; expression that begins with the literal #%module-begin.
-  (define (contains-#%module-begin exps)
-    (let ([exps (if (syntax? exps) (syntax->list exps) exps)])
-      (and exps
-           (pair? exps) 
-           (null? (cdr exps))
-           (let ([exp (car exps)])
-             (let ([lst (if (syntax? exp) (syntax->list exp) exp)])
-               (and lst
-                    (let ([head (if (syntax? (car lst)) (syntax-e (car lst)) (car lst))])
-                      (eq? '#%module-begin head))))))))
+  ;; expression that begins with the literal #%module-begin.  If so,
+  ;; it just returns that expression, else it wraps with #%module-begin.
+  (define (wrap-#%module-begin exps stx?)
+    (define wrapped-exps 
+      (let ([wrapped `(#%module-begin . ,exps)])
+        (if stx?
+            (datum->syntax #f wrapped)
+            wrapped)))
+    (let ([exps (if stx? (syntax->list exps) exps)])
+      (cond
+        [(null? exps) wrapped-exps]
+        [(not (null? (cdr exps))) wrapped-exps]
+        [else (let ([exp (if stx? (syntax-e (car exps)) (car exps))])
+                (cond
+                  [(not (pair? exp)) wrapped-exps]
+                  [(eq? '#%module-begin
+                        (if stx? (syntax-e (car exp)) (car exp)))
+                   (car exp)]
+                  [else wrapped-exps]))])))
 
   (define-syntax (provide-module-reader stx)
     (define (err str [sub #f])
@@ -188,13 +196,8 @@
            ;; or wrapper1 functions, we need to avoid double-wrapping.  Having to
            ;; do this for #lang readers should be considered deprecated, and
            ;; hopefully one day we'll move to just doing it unilaterally.
-           [wrapped-body (if (contains-#%module-begin body)
-                             body
-                             (let ([wrapped `(#%module-begin . ,body)])
-                               (if stx?
-                                   (list (datum->syntax #f wrapped all-loc))
-                                   (list wrapped))))]
-           [r `(,(tag-src 'module) ,(tag-src name) ,lang . ,wrapped-body)])
+           [wrapped-body (wrap-#%module-begin body stx?)]
+           [r `(,(tag-src 'module) ,(tag-src name) ,lang ,wrapped-body)])
       (if stx? (datum->syntax #f r all-loc) r)))
 
   (define (wrap lang port read modpath src line col pos)

From 152ea3c6c848bfb5cedba776d14abed3991e1d46 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 1 Dec 2009 22:00:43 +0000
Subject: [PATCH 065/136] Move it into the only place it's used.

svn: r17155
---
 collects/syntax/module-reader.ss | 43 ++++++++++++++++----------------
 1 file changed, 21 insertions(+), 22 deletions(-)

diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index d96afb82ee..630adff4dc 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -10,28 +10,6 @@
 
   (define ar? procedure-arity-includes?)
 
-  ;; Takes either a syntax object representing a list of expressions
-  ;; or a list of s-expressions, and checks to see if it's a single
-  ;; expression that begins with the literal #%module-begin.  If so,
-  ;; it just returns that expression, else it wraps with #%module-begin.
-  (define (wrap-#%module-begin exps stx?)
-    (define wrapped-exps 
-      (let ([wrapped `(#%module-begin . ,exps)])
-        (if stx?
-            (datum->syntax #f wrapped)
-            wrapped)))
-    (let ([exps (if stx? (syntax->list exps) exps)])
-      (cond
-        [(null? exps) wrapped-exps]
-        [(not (null? (cdr exps))) wrapped-exps]
-        [else (let ([exp (if stx? (syntax-e (car exps)) (car exps))])
-                (cond
-                  [(not (pair? exp)) wrapped-exps]
-                  [(eq? '#%module-begin
-                        (if stx? (syntax-e (car exp)) (car exp)))
-                   (car exp)]
-                  [else wrapped-exps]))])))
-
   (define-syntax (provide-module-reader stx)
     (define (err str [sub #f])
       (raise-syntax-error 'syntax/module-reader str sub))
@@ -163,6 +141,27 @@
 
   (define (wrap-internal lang port read whole? wrapper stx?
                          modpath src line col pos)
+    ;; Takes either a syntax object representing a list of expressions
+    ;; or a list of s-expressions, and checks to see if it's a single
+    ;; expression that begins with the literal #%module-begin.  If so,
+    ;; it just returns that expression, else it wraps with #%module-begin.
+    (define (wrap-#%module-begin exps stx?)
+      (define wrapped-exps 
+        (let ([wrapped `(#%module-begin . ,exps)])
+          (if stx?
+              (datum->syntax #f wrapped)
+              wrapped)))
+      (let ([exps (if stx? (syntax->list exps) exps)])
+        (cond
+          [(null? exps) wrapped-exps]
+          [(not (null? (cdr exps))) wrapped-exps]
+          [else (let ([exp (if stx? (syntax-e (car exps)) (car exps))])
+                  (cond
+                    [(not (pair? exp)) wrapped-exps]
+                    [(eq? '#%module-begin
+                          (if stx? (syntax-e (car exp)) (car exp)))
+                     (car exp)]
+                    [else wrapped-exps]))])))
     (let* ([lang (if stx? (datum->syntax #f lang modpath modpath) lang)]
            [body (lambda ()
                    (if whole?

From 4c18e8212f0978cc98d2151163b6993e4bd8bd46 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 2 Dec 2009 04:42:35 +0000
Subject: [PATCH 066/136] PR 10635

svn: r17156
---
 collects/2htdp/tests/test-image.ss          | 19 +++++++++++++++++++
 collects/mrlib/private/image-core-bitmap.ss |  4 ++--
 2 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/collects/2htdp/tests/test-image.ss b/collects/2htdp/tests/test-image.ss
index 64eb05ce34..f18b6e67d2 100644
--- a/collects/2htdp/tests/test-image.ss
+++ b/collects/2htdp/tests/test-image.ss
@@ -954,3 +954,22 @@
               16)
 (check-equal? (image-height (bitmap icons/stop-16x16.png))
               16)
+
+(check-equal? (let ()
+                (define bmp (make-object bitmap% 4 4))
+                (define mask (make-object bitmap% 4 4))
+                (define bdc (make-object bitmap-dc% bmp))
+                (send bdc set-brush "black" 'solid)
+                (send bdc draw-rectangle 0 0 4 4)
+                (send bdc set-bitmap mask)
+                (send bdc set-brush "black" 'solid)
+                (send bdc clear)
+                (send bdc draw-rectangle 1 1 1 1)
+                (send bdc set-bitmap #f)
+                (let-values ([(bytes w h) (bitmap->bytes bmp mask)])
+                  bytes))
+              (bytes-append #"\0\0\0\0" #"\0\0\0\0"   #"\0\0\0\0" #"\0\0\0\0"
+                            #"\0\0\0\0" #"\377\0\0\0" #"\0\0\0\0" #"\0\0\0\0"
+                            #"\0\0\0\0" #"\0\0\0\0"   #"\0\0\0\0" #"\0\0\0\0"
+                            #"\0\0\0\0" #"\0\0\0\0"   #"\0\0\0\0" #"\0\0\0\0"))
+                            
\ No newline at end of file
diff --git a/collects/mrlib/private/image-core-bitmap.ss b/collects/mrlib/private/image-core-bitmap.ss
index 7491cb4f9d..112af70085 100644
--- a/collects/mrlib/private/image-core-bitmap.ss
+++ b/collects/mrlib/private/image-core-bitmap.ss
@@ -59,8 +59,8 @@ instead of this scaling code, we use the dc<%>'s scaling code.
          [h (send bm get-height)]
          [bytes (make-bytes (* w h NUM-CHANNELS) 0)])
     (send bm get-argb-pixels 0 0 w h bytes #f)
-    (when (send bm get-loaded-mask)
-      (send (send bm get-loaded-mask) get-argb-pixels 0 0 w h bytes #t))
+    (when mask
+      (send mask get-argb-pixels 0 0 w h bytes #t))
     (values bytes w h)))
 
 (define (bytes->bitmap bytes w h)

From 7c24f19675324a2966f426d8d7646519e8c2fba7 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Wed, 2 Dec 2009 04:57:25 +0000
Subject: [PATCH 067/136] what used to not work now works

svn: r17157
---
 collects/scheme/private/at-syntax.ss | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/collects/scheme/private/at-syntax.ss b/collects/scheme/private/at-syntax.ss
index 4753d40918..e6130c473e 100644
--- a/collects/scheme/private/at-syntax.ss
+++ b/collects/scheme/private/at-syntax.ss
@@ -49,12 +49,12 @@ And another example, creating a macro for syntax-time expressions:
 
 but the `quote' here is a hint that this can get 3d values into
 syntax, and all the problems that are involved.  Also, note that it
-breaks if you try to do something like:
+even works if you try to do something like:
 
   > (compile-time-value (begin (set! x 11) x))
-  8
+  11
 
-(and, of course, it cannot be used to define new bindings).
+(but, of course, it cannot be used to define new bindings).
 
 |#
 

From b310c35a3892149ad80f7a7a5463600a3f7de9af Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 2 Dec 2009 05:01:08 +0000
Subject: [PATCH 068/136] PR 10634

svn: r17158
---
 collects/mrlib/image-core.ss | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/collects/mrlib/image-core.ss b/collects/mrlib/image-core.ss
index 8f77c5b7b6..875bc9a745 100644
--- a/collects/mrlib/image-core.ss
+++ b/collects/mrlib/image-core.ss
@@ -626,8 +626,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          [orig-h (send orig-bm get-height)]
          [x-scale (bitmap-x-scale bitmap)]
          [y-scale (bitmap-y-scale bitmap)]
-         [scale-w (* x-scale (send orig-bm get-width))]
-         [scale-h (* y-scale (send orig-bm get-height))]
+         [scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))]
+         [scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))]
          [new-bm (make-object bitmap% scale-w scale-h)]
          [new-mask (make-object bitmap% scale-w scale-h)])
     (send new-bm set-loaded-mask new-mask)
@@ -734,6 +734,6 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          render-image)
 
 ;; method names
-(provide get-shape get-bb get-normalized?)
+(provide get-shape get-bb get-normalized? get-normalized-shape)
 
 (provide np-atomic-shape? atomic-shape? simple-shape?)

From 57f9a7063e24cdae76bb7eb749453ed8f77f6713 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 2 Dec 2009 05:08:04 +0000
Subject: [PATCH 069/136] PR 10633

svn: r17159
---
 collects/2htdp/tests/test-image.ss |  6 +++++-
 collects/mrlib/image-core.ss       | 14 ++++++++------
 2 files changed, 13 insertions(+), 7 deletions(-)

diff --git a/collects/2htdp/tests/test-image.ss b/collects/2htdp/tests/test-image.ss
index f18b6e67d2..3554b60c5c 100644
--- a/collects/2htdp/tests/test-image.ss
+++ b/collects/2htdp/tests/test-image.ss
@@ -972,4 +972,8 @@
                             #"\0\0\0\0" #"\377\0\0\0" #"\0\0\0\0" #"\0\0\0\0"
                             #"\0\0\0\0" #"\0\0\0\0"   #"\0\0\0\0" #"\0\0\0\0"
                             #"\0\0\0\0" #"\0\0\0\0"   #"\0\0\0\0" #"\0\0\0\0"))
-                            
\ No newline at end of file
+ 
+;; ensure no error
+(check-equal? (begin (scale 2 (make-object bitmap% 10 10))
+                     (void))
+              (void))
diff --git a/collects/mrlib/image-core.ss b/collects/mrlib/image-core.ss
index 875bc9a745..d216c6dfc3 100644
--- a/collects/mrlib/image-core.ss
+++ b/collects/mrlib/image-core.ss
@@ -629,18 +629,20 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          [scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))]
          [scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))]
          [new-bm (make-object bitmap% scale-w scale-h)]
-         [new-mask (make-object bitmap% scale-w scale-h)])
-    (send new-bm set-loaded-mask new-mask)
+         [new-mask (and orig-mask (make-object bitmap% scale-w scale-h))])
+    (when new-mask
+      (send new-bm set-loaded-mask new-mask))
     
     (send bdc set-bitmap new-bm)
     (send bdc set-scale x-scale y-scale)
     (send bdc clear)
     (send bdc draw-bitmap orig-bm 0 0)
 
-    (send bdc set-bitmap new-mask)
-    (send bdc set-scale x-scale y-scale)
-    (send bdc clear)
-    (send bdc draw-bitmap orig-mask 0 0)
+    (when new-mask
+      (send bdc set-bitmap new-mask)
+      (send bdc set-scale x-scale y-scale)
+      (send bdc clear)
+      (send bdc draw-bitmap orig-mask 0 0))
     
     (send bdc set-bitmap #f)
     

From a941cfd17a6964adfc600ee970d2cd1fdfae1307 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Wed, 2 Dec 2009 08:50:27 +0000
Subject: [PATCH 070/136] Welcome to a new PLT day.

svn: r17161
---
 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 e1fea1f73c..94220c8f4c 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "30nov2009")
+#lang scheme/base (provide stamp) (define stamp "2dec2009")

From ac1f4171fa7b064148c089c9c4178a3f8d355793 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Wed, 2 Dec 2009 14:44:29 +0000
Subject: [PATCH 071/136] Tutorial escaping clarification

svn: r17162
---
 collects/web-server/scribblings/tutorial/continue.scrbl | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl
index b366eb8322..263236034a 100644
--- a/collects/web-server/scribblings/tutorial/continue.scrbl
+++ b/collects/web-server/scribblings/tutorial/continue.scrbl
@@ -100,7 +100,7 @@ responses.  One basic kind of response is to show an HTML page.
 
 For example:
 
-The HTML @tt{hello} is represented as @scheme["hello"].
+The HTML @tt{hello} is represented as @scheme["hello"]. Strings are automatically escaped when output. This guarantees valid HTML. Therefore, the value @scheme["<b>Unfinished tag"] is rendered as @tt{&lt;b&gt;Unfinished tag} not @tt{<b>Unfinished tag}. Similarly, @scheme["<i>Finished tag</i>"] is rendered as @tt{&lt;i&gt;Finished tag&lt;/i&gt;} not @tt{<i>Finished tag</i>}.
 
 @tt{<p>This is an example</p>} is
 

From 61da010d5f61abda44f375523955e260544a08f2 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 2 Dec 2009 17:09:07 +0000
Subject: [PATCH 072/136] PR 10636

svn: r17163
---
 collects/scheme/contract/private/guts.ss | 10 ++++++++--
 collects/tests/mzscheme/contract-test.ss |  6 ++++++
 2 files changed, 14 insertions(+), 2 deletions(-)

diff --git a/collects/scheme/contract/private/guts.ss b/collects/scheme/contract/private/guts.ss
index 96e85aac05..cf5e50b4f6 100644
--- a/collects/scheme/contract/private/guts.ss
+++ b/collects/scheme/contract/private/guts.ss
@@ -66,9 +66,14 @@
 (define-values (flat-prop flat-pred? flat-get)
   (make-struct-type-property 'contract-flat))
 
-(define-values (first-order-prop first-order-pred? first-order-get)
+(define-values (first-order-prop first-order-pred? raw-first-order-get)
   (make-struct-type-property 'contract-first-order))
 
+(define (first-order-get stct)
+  (cond
+    [(flat-pred? stct) (flat-get stct)]
+    [else (raw-first-order-get stct)]))
+
 (define (contract-first-order-passes? c v)
   (let ([ctc (coerce-contract 'contract-first-order-passes? c)])
     (cond
@@ -404,7 +409,8 @@
   #:property name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc)))
   #:property first-order-prop
   (λ (ctc)
-    (let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))])
+    (let ([tests (map (λ (x) ((first-order-get x) x))
+                      (and/c-ctcs ctc))])
       (λ (x) 
         (andmap (λ (f) (f x)) tests))))
   #:property stronger-prop
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index 3de105d6a2..2769651825 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -2060,6 +2060,12 @@
       x)
    '(2))
 
+  (test/spec-passed
+   'or/c-hmm
+   (let ([funny/c (or/c (and/c procedure? (-> any)) (listof (-> number?)))])
+     (contract (-> funny/c any) void 'pos 'neg)))
+
+  
   
 ;                                          
 ;                                          

From ec7dbeee657584aa80e32d200ac15c8c168c7c65 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 2 Dec 2009 19:39:21 +0000
Subject: [PATCH 073/136] fix runstack reset in future thread

svn: r17164
---
 src/mzscheme/src/future.c | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c
index 44372d4111..fccd214156 100644
--- a/src/mzscheme/src/future.c
+++ b/src/mzscheme/src/future.c
@@ -820,7 +820,9 @@ void *worker_thread_future_loop(void *arg)
   //including runtime calls. 
   //If jitcode asks the runrtime thread to do work, then
   //a GC can occur.
-  LOG("Running JIT code at %p...\n", ft->code);    
+  LOG("Running JIT code at %p...\n", ft->code);
+
+  MZ_RUNSTACK = MZ_RUNSTACK_START + fts->runstack_size;
 
   scheme_current_thread->error_buf = &newbuf;
   if (scheme_future_setjmp(newbuf)) {

From 7015edb0705e8d6badde2769de78d470cb8f4627 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 2 Dec 2009 20:00:32 +0000
Subject: [PATCH 074/136] fix corner case of futures where the initial
 procedure needs too deep a Scheme stack

svn: r17165
---
 src/mzscheme/src/future.c | 14 ++++++++++++--
 src/mzscheme/src/future.h |  1 +
 2 files changed, 13 insertions(+), 2 deletions(-)

diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c
index fccd214156..bdf43c12d3 100644
--- a/src/mzscheme/src/future.c
+++ b/src/mzscheme/src/future.c
@@ -163,6 +163,7 @@ static void init_future_thread(struct Scheme_Future_State *fs, int i);
 
 #define THREAD_POOL_SIZE 12
 #define INITIAL_C_STACK_SIZE 500000
+#define FUTURE_RUNSTACK_SIZE 1000
 
 typedef struct Scheme_Future_State {
   struct Scheme_Future_Thread_State *pool_threads[THREAD_POOL_SIZE];
@@ -397,7 +398,7 @@ static void init_future_thread(Scheme_Future_State *fs, int i)
 
   {
     Scheme_Object **rs_start, **rs;
-    long init_runstack_size = 1000;
+    long init_runstack_size = FUTURE_RUNSTACK_SIZE;
     rs_start = scheme_alloc_runstack(init_runstack_size);
     rs = rs_start XFORM_OK_PLUS init_runstack_size;
     params.runstack_start = rs_start;
@@ -565,6 +566,11 @@ Scheme_Object *future(int argc, Scheme_Object *argv[])
       scheme_on_demand_generate_lambda(nc, 0, NULL);
     }
 
+  if (ncd->max_let_depth > FUTURE_RUNSTACK_SIZE * sizeof(void*)) {
+    /* Can't even call it in a future thread */
+    ft->status = PENDING_OVERSIZE;
+  }
+
   ft->code = (void*)ncd->code;
 
   pthread_mutex_lock(&fs->future_mutex);
@@ -631,7 +637,11 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
 #endif
 
   pthread_mutex_lock(&fs->future_mutex);
-  if (ft->status == PENDING) {
+  if ((ft->status == PENDING) || (ft->status == PENDING_OVERSIZE)) {
+    if (ft->status == PENDING_OVERSIZE) {
+      scheme_log(scheme_main_logger, SCHEME_LOG_DEBUG, 0,
+                 "future: oversize procedure deferred to runtime thread");
+    }
     ft->status = RUNNING;
     pthread_mutex_unlock(&fs->future_mutex);
 
diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h
index a2c8eee44e..e1bad68ffe 100644
--- a/src/mzscheme/src/future.h
+++ b/src/mzscheme/src/future.h
@@ -34,6 +34,7 @@ typedef void* (*prim_pvoid_pvoid_pvoid_t)(void*, void*);
 #define RUNNING 1
 #define WAITING_FOR_PRIM 2
 #define FINISHED 3
+#define PENDING_OVERSIZE 4
 
 #define FSRC_OTHER 0
 #define FSRC_RATOR 1

From ae7482d572ba044f32effcd645778e41035a7922 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Wed, 2 Dec 2009 20:45:59 +0000
Subject: [PATCH 075/136] Converting to scheme/base. Adding atomic renaming of
 compiled zos. Simplifying some parts with library functions. Using a low-tech
 continuation barrier, re: robby. Using define to reduce left creep. Adding
 commentary on design choices. Tested on Linux and Mac OS X. Based on code
 from Petey Aldous.

svn: r17166
---
 collects/mzlib/compile.ss | 116 ++++++++++++++++++++------------------
 1 file changed, 61 insertions(+), 55 deletions(-)

diff --git a/collects/mzlib/compile.ss b/collects/mzlib/compile.ss
index 45e24bab81..db8ecc77c1 100644
--- a/collects/mzlib/compile.ss
+++ b/collects/mzlib/compile.ss
@@ -1,57 +1,63 @@
+#lang scheme/base
+(require scheme/function
+         scheme/path
+         scheme/file)
+(provide compile-file)
 
-(module compile mzscheme
-  (require "file.ss" 
-	   "port.ss")
-  (provide compile-file)
-  
-  ;; (require compiler/src2src)
-
-  (define compile-file
-    (case-lambda
-     [(src)
-      (let-values ([(base name dir?) (split-path src)])
-	(let ([cdir (build-path
-		     (if (symbol? base)
-			 'same
-			 base)
-		     "compiled")])
-	  (unless (directory-exists? cdir)
-	    (make-directory cdir))
-	  (compile-file src (build-path cdir (path-add-suffix name #".zo")))))]
-     [(src dest) (compile-file src dest values)]
-     [(src dest filter)
-      (let ([in (open-input-file src)])
-	(dynamic-wind
-	 void
-	 (lambda ()
-	   (port-count-lines! in)
-	   (with-handlers ([void
-			    (lambda (exn)
-			      (with-handlers ([void void])
-				(delete-file dest))
-			      (raise exn))])
-	     (let ([out (open-output-file dest 'truncate/replace)]
-		   [ok? #f])
-	       (let ([dir (let-values ([(base name dir?) (split-path src)])
-			    (if (eq? base 'relative)
-				(current-directory)
-				(path->complete-path base (current-directory))))])
-		 (parameterize ([current-load-relative-directory dir]
-				[current-write-relative-directory dir])
-		   (dynamic-wind
-		       void
-		       (lambda ()
-			 (let loop ()
-			   (let ([r (read-syntax src in)])
-			     (unless (eof-object? r)
-			       (write (compile-syntax (filter (namespace-syntax-introduce r))) out)
-			       (loop))))
-			 (set! ok? #t))
-		       (lambda () 
-			 (close-output-port out)
-			 (unless ok?
-			   (with-handlers ([void void])
-			     (delete-file dest))))))))))
-	 (lambda () (close-input-port in))))
-      dest])))
+(define compile-file
+  (case-lambda
+    [(src)
+     (define cdir (build-path (path-only src) "compiled"))
+     (make-directory* cdir)
+     (compile-file src (build-path cdir (path-add-suffix (file-name-from-path src) #".zo")))]
+    [(src dest) 
+     (compile-file src dest values)]
+    [(src dest filter)
+     (define in (open-input-file src))
+     (dynamic-wind
+      void
+      (lambda ()
+        (define ok? #f)
+        ; This must be based on the path to dest. Renaming typically cannot be done
+        ; atomically across file systems, so the temporary directory is not an option
+        ; because it is often a ram disk. src (or dir below) couldn't be used because
+        ; it may be on a different filesystem. Since dest must be a file path, this
+        ; guarantees that the temp file is in the same directory. It would take a weird
+        ; filesystem configuration to break that.
+        (define temp-filename (make-temporary-file "tmp~a" #f (path-only dest)))
+        (port-count-lines! in)
+        (dynamic-wind
+         void
+         (lambda ()
+           ; XXX: This seems like it should be a library function named 'relative-path-only'
+           (define dir
+             (let-values ([(base name dir?) (split-path src)])
+               (if (eq? base 'relative)
+                   (current-directory)
+                   (path->complete-path base (current-directory)))))
+           (define out (open-output-file temp-filename #:exists 'truncate/replace))
+           (parameterize ([current-load-relative-directory dir]
+                          [current-write-relative-directory dir])
+             ; Rather than installing a continuation barrier, we detect reinvocation.
+             ; The only thing that can cause reinvocation is if the filter captures the
+             ; continuation and communicates it externally.
+             (define count 0)
+             (dynamic-wind
+              (lambda ()
+                (if (zero? count)
+                    (set! count 1)
+                    (error 'compile-file "filter function should not be re-entrant")))
+              (lambda ()
+                (for ([r (in-port (curry read-syntax src) in)])
+                  (write (compile-syntax (filter (namespace-syntax-introduce r))) out))
+                (set! ok? #t))
+              (lambda () 
+                (close-output-port out)))))
+         (lambda ()
+           (if ok?
+               (rename-file-or-directory temp-filename dest)
+               (with-handlers ([exn:fail:filesystem? void])
+                 (delete-file temp-filename))))))
+      (lambda () (close-input-port in)))
+     dest]))
 

From 366ba64bc54de7f4e2b2844fb25cb3c976f92e60 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 2 Dec 2009 23:18:47 +0000
Subject: [PATCH 076/136] macro-stepper: fixed ? position in arrows

svn: r17167
---
 collects/macro-debugger/syntax-browser/text.ss | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss
index d492aa859d..335f1206a8 100644
--- a/collects/macro-debugger/syntax-browser/text.ss
+++ b/collects/macro-debugger/syntax-browser/text.ss
@@ -285,7 +285,7 @@
                          (send dc set-text-foreground color)
                          (send dc draw-text "?" 
                                (+ endx dx fw)
-                               (- endy dy fh)))))))])
+                               (- (+ endy dy) fh)))))))])
           (add-mouse-drawing from1 from2 draw tack-box)
           (add-mouse-drawing to1 to2 draw tack-box))))
 

From d42a6f1582de5f401335dd9a58f829c90f4c8a51 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 2 Dec 2009 23:39:55 +0000
Subject: [PATCH 077/136] replaced at-syntax with syntax-local-eval

svn: r17168
---
 collects/scheme/private/at-syntax.ss | 71 ----------------------------
 collects/scheme/provide.ss           |  4 +-
 collects/scheme/require.ss           |  4 +-
 collects/unstable/syntax.ss          |  3 +-
 4 files changed, 6 insertions(+), 76 deletions(-)
 delete mode 100644 collects/scheme/private/at-syntax.ss

diff --git a/collects/scheme/private/at-syntax.ss b/collects/scheme/private/at-syntax.ss
deleted file mode 100644
index e6130c473e..0000000000
--- a/collects/scheme/private/at-syntax.ss
+++ /dev/null
@@ -1,71 +0,0 @@
-#lang scheme/base
-
-(require (for-template scheme/base))
-
-(provide at-syntax)
-
-;; -------------------------------------------------------------------
-;; NOTE: This library is for internal use only, it is can change
-;; and/or disappear.  Do not use without protective eyewear!
-;; -------------------------------------------------------------------
-
-#|
-
-The `(at-syntax expr)' form is a useful syntax-time utility that can
-be used to sort of evaluate an expression at syntax time, and doing so
-in a well behaved way (eg, it respects the source for-syntax bindings,
-but it does have some issues).  It can be used to implement an escape
-to the syntax level that is not restricted like `begin-for-syntax'.
-
-The basic idea of the code is to plant the given expression on the
-right hand side of a `let-syntax' -- inside a `(lambda (stx) ...)'  to
-make it a valid transformer, with a singe use of this macro so that we
-get it to execute with `local-expand'.  The macro returns a 3d
-expression that contains the evaluated expression "somehwhere",
-depending on the expansion of `let-syntax' -- so to make it easy to
-find we plant it inside a thunk (so this works as long as `let-syntax'
-does not include 3d procedure values in its expansion).  Finally, the
-constructed `let-syntax' is expanded, we search through the resulting
-syntax for the thunk, then apply it to get the desired value.
-
-Here's a silly example to demonstrate:
-
-  > (define-syntax (compile-time-if stx)
-      (syntax-case stx ()
-        [(_ cond expr1 expr2)
-         (if (at-syntax #'cond) #'expr1 #'expr2)]))
-  > (define-for-syntax x 8)
-  > (define x 100)
-  > (compile-time-if (< x 10) (+ x 10) (- x 10))
-  110
-
-And another example, creating a macro for syntax-time expressions:
-
-  > (define-syntax (compile-time-value stx)
-      (syntax-case stx ()
-        [(_ expr) #`(quote #,(at-syntax #'expr))]))
-  > (compile-time-value (* x 2))
-  16
-
-but the `quote' here is a hint that this can get 3d values into
-syntax, and all the problems that are involved.  Also, note that it
-even works if you try to do something like:
-
-  > (compile-time-value (begin (set! x 11) x))
-  11
-
-(but, of course, it cannot be used to define new bindings).
-
-|#
-
-(define (at-syntax expr)
-  (let loop ([x (with-syntax ([e expr])
-                  (local-expand
-                   #'(let-syntax ([here (lambda (stx)
-                                          (datum->syntax stx (lambda () e)))])
-                       here)
-                   'expression '()))])
-    (cond [(procedure? x) (x)]
-          [(pair? x) (or (loop (car x)) (loop (cdr x)))]
-          [(syntax? x) (loop (syntax-e x))]
-          [else #f])))
diff --git a/collects/scheme/provide.ss b/collects/scheme/provide.ss
index 9c4cd9b446..b3bdbd12f1 100644
--- a/collects/scheme/provide.ss
+++ b/collects/scheme/provide.ss
@@ -1,7 +1,7 @@
 #lang scheme/base
 
 (require (for-syntax scheme/base scheme/provide-transform scheme/list
-                     "private/at-syntax.ss"))
+                     (only-in unstable/syntax syntax-local-eval)))
 
 (provide matching-identifiers-out)
 (define-syntax matching-identifiers-out
@@ -21,7 +21,7 @@
    (lambda (stx modes)
      (syntax-case stx ()
        [(_ proc spec)
-        (let ([proc (at-syntax #'proc)])
+        (let ([proc (syntax-local-eval #'proc)])
           (filter-map
            (lambda (e)
              (let* ([s1 (symbol->string (export-out-sym e))]
diff --git a/collects/scheme/require.ss b/collects/scheme/require.ss
index 0349b3df30..b40197f910 100644
--- a/collects/scheme/require.ss
+++ b/collects/scheme/require.ss
@@ -1,7 +1,7 @@
 #lang scheme/base
 
 (require (for-syntax scheme/base scheme/require-transform scheme/list
-                     "private/at-syntax.ss")
+                     (only-in unstable/syntax syntax-local-eval))
          "require-syntax.ss")
 
 (provide matching-identifiers-in)
@@ -43,7 +43,7 @@
    (lambda (stx)
      (syntax-case stx ()
        [(_ proc spec)
-        (let ([proc (at-syntax #'proc)])
+        (let ([proc (syntax-local-eval #'proc)])
           (define-values [imports sources] (expand-import #'spec))
           (values
            (filter-map
diff --git a/collects/unstable/syntax.ss b/collects/unstable/syntax.ss
index 9397876fd8..0ad94ddeb0 100644
--- a/collects/unstable/syntax.ss
+++ b/collects/unstable/syntax.ss
@@ -4,7 +4,8 @@
          syntax/stx
          unstable/struct
          (for-syntax scheme/base
-                     scheme/private/sc))
+                     scheme/private/sc)
+         (for-template scheme/base))
 
 (provide unwrap-syntax
 

From 3d10bff57c6408535cbdd26c9458633aad681216 Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Thu, 3 Dec 2009 00:01:52 +0000
Subject: [PATCH 078/136] experiment with different unparsed forms

svn: r17169
---
 collects/honu/private/macro.ss | 14 +++++++++++++-
 1 file changed, 13 insertions(+), 1 deletion(-)

diff --git a/collects/honu/private/macro.ss b/collects/honu/private/macro.ss
index 1043c8c224..95ecfb1ef8 100644
--- a/collects/honu/private/macro.ss
+++ b/collects/honu/private/macro.ss
@@ -389,10 +389,22 @@
                               #:literals (honu-literal ...)
                   [(name pattern* ... . rrest)
                    (with-syntax ([(out (... ...)) (unpull #'pulled)])
+                     ;; TODO: use the proper `honu-unparsed' form depending on the context
                      (values
+                      #'(honu-unparsed-begin out (... ...))
+                      #'rrest)
+                     #;
+                     #'(honu-unparsed-block
+                        #f obj 'obj #f ctx
+                        out (... ...))
+                     #;
+                     (values
+                      #;
+                      #'(honu-unparsed-expr out (... ...))
                       #'(honu-unparsed-block
                          #f obj 'obj #f ctx
-                         out (... ...))
+                         out (... ...) rrest)
+                      #;
                       #'rrest))])))
           #'rest))])))
 

From 81b30db001ae4ca991b4c69a2848e47f0197c902 Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Thu, 3 Dec 2009 00:44:11 +0000
Subject: [PATCH 079/136] check the context we are expanding into

svn: r17170
---
 collects/honu/private/macro.ss | 18 +++++++++++++++++-
 1 file changed, 17 insertions(+), 1 deletion(-)

diff --git a/collects/honu/private/macro.ss b/collects/honu/private/macro.ss
index 95ecfb1ef8..9003b17776 100644
--- a/collects/honu/private/macro.ss
+++ b/collects/honu/private/macro.ss
@@ -2,6 +2,7 @@
 
 (require "honu.ss"
          (for-syntax "debug.ss"
+                     "contexts.ss"
                      scheme/base
                      syntax/parse
                      syntax/stx
@@ -389,8 +390,23 @@
                               #:literals (honu-literal ...)
                   [(name pattern* ... . rrest)
                    (with-syntax ([(out (... ...)) (unpull #'pulled)])
-                     ;; TODO: use the proper `honu-unparsed' form depending on the context
+                     (define (X) (raise-syntax-error (syntax->datum #'name) "implement for this context"))
                      (values
+                      ;; this is sort of ugly, is there a better way?
+                      (cond
+                        [(type-context? ctx) (X)]
+                        [(type-or-expression-context? ctx) (X)]
+                        [(expression-context? ctx) #'(honu-unparsed-expr out (... ...))]
+                        [(expression-block-context? ctx)
+                         #'(honu-unparsed-begin out (... ...))]
+                        [(block-context? ctx)
+                         #'(honu-unparsed-begin out (... ...))]
+                        [(variable-definition-context? ctx) (X)]
+                        [(constant-definition-context? ctx) (X)]
+                        [(function-definition-context? ctx) (X)]
+                        [(prototype-context? ctx) (X)]
+                        [else #'(honu-unparsed-expr out (... ...))])
+                      #;
                       #'(honu-unparsed-begin out (... ...))
                       #'rrest)
                      #;

From 2634eccdc796e6ed0b242f69f00e9e896d8fb171 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 3 Dec 2009 00:54:02 +0000
Subject: [PATCH 080/136] unstable/contract: added if/c combinator other minor
 changes

svn: r17171
---
 collects/unstable/contract.ss                | 43 +++++++++++++++++++-
 collects/unstable/mutated-vars.ss            |  6 ++-
 collects/unstable/scribblings/contract.scrbl | 38 +++++++++++++++--
 collects/unstable/struct.ss                  | 25 +++++++-----
 4 files changed, 94 insertions(+), 18 deletions(-)

diff --git a/collects/unstable/contract.ss b/collects/unstable/contract.ss
index a7b22b9c50..f3d7d286c1 100644
--- a/collects/unstable/contract.ss
+++ b/collects/unstable/contract.ss
@@ -1,4 +1,5 @@
-#lang scheme
+#lang scheme/base
+(require scheme/contract)
 
 (define path-element?
   (or/c path-string? (symbols 'up 'same)))
@@ -13,7 +14,45 @@
 ;; Eli: If this gets in, there should also be versions for bytes, lists, and
 ;;   vectors.
 
+;; ryanc added:
+
+;; (if/c predicate then/c else/c) applies then/c to satisfying
+;;   predicate, else/c to those that don't.
+(define (if/c predicate then/c else/c)
+  #|
+  Naive version:
+    (or/c (and/c predicate then/c)
+          (and/c (not/c predicate) else/c))
+  But that applies predicate twice.
+  |#
+  (let ([then-ctc (coerce-contract 'if/c then/c)]
+        [else-ctc (coerce-contract 'if/c else/c)])
+    (define name (build-compound-type-name 'if/c predicate then-ctc else-ctc))
+    ;; Special case: if both flat contracts, make a flat contract.
+    (if (and (flat-contract? then-ctc)
+             (flat-contract? else-ctc))
+        ;; flat contract
+        (let ([then-pred (flat-contract-predicate then-ctc)]
+              [else-pred (flat-contract-predicate else-ctc)])
+          (define (pred x)
+            (if (predicate x) (then-pred x) (else-pred x)))
+          (flat-named-contract name pred))
+        ;; ho contract
+        (let ([then-proj ((proj-get then-ctc) then-ctc)]
+              [then-fo ((first-order-get then-ctc) then-ctc)]
+              [else-proj ((proj-get else-ctc) else-ctc)]
+              [else-fo ((first-order-get else-ctc) else-ctc)])
+          (define ((proj pos neg srcinfo name pos?) x)
+            (if (predicate x)
+                ((then-proj pos neg srcinfo name pos?) x)
+                ((else-proj pos neg srcinfo name pos?) x)))
+          (make-proj-contract
+           name
+           proj
+           (lambda (x) (if (predicate x) (then-fo x) (else-fo x))))))))
+
 (provide/contract
  [non-empty-string/c contract?]
  [path-element? contract?]
- [port-number? contract?])
+ [port-number? contract?]
+ [if/c (-> procedure? contract? contract? contract?)])
diff --git a/collects/unstable/mutated-vars.ss b/collects/unstable/mutated-vars.ss
index efa9b39e49..a585a2c321 100644
--- a/collects/unstable/mutated-vars.ss
+++ b/collects/unstable/mutated-vars.ss
@@ -13,8 +13,7 @@
   ;; syntax -> void
   (define (fmv/list lstx)
     (for-each find-mutated-vars (syntax->list lstx)))
-  ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (syntax->datum form)))
-  (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal)     
+  (kernel-syntax-case* form #f ()
     ;; what we care about: set!
     [(set! v e)
      (begin
@@ -51,5 +50,8 @@
 ;;   less general.
 ;; - What's with the typed-scheme literals?  If they were needed, then
 ;;   typed-scheme is probably broken now.
+;; ryanc:
+;; - The for-template is needed.
+;; - I've removed the bogus literals.
 
 (provide find-mutated-vars is-var-mutated?)
diff --git a/collects/unstable/scribblings/contract.scrbl b/collects/unstable/scribblings/contract.scrbl
index b7851a4629..a774deb59b 100644
--- a/collects/unstable/scribblings/contract.scrbl
+++ b/collects/unstable/scribblings/contract.scrbl
@@ -1,6 +1,7 @@
 #lang scribble/doc
 @(require scribble/base
           scribble/manual
+          "utils.ss"
           (for-label unstable/contract
                      scheme/contract
                      scheme/base))
@@ -9,8 +10,39 @@
 
 @defmodule[unstable/contract]
 
-@defthing[non-empty-string/c contract?]{Contract for non-empty strings.}
+@defthing[non-empty-string/c contract?]{
+Contract for non-empty strings.
+}
 
-@defthing[port-number? contract?]{Equivalent to @scheme[(between/c 1 65535)].}
+@defthing[port-number? contract?]{
+Equivalent to @scheme[(between/c 1 65535)].
+}
 
-@defthing[path-element? contract?]{Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))].}
+@defthing[path-element? contract?]{
+Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))].
+}
+
+@addition{Ryan Culpepper}
+
+@defproc[(if/c [predicate (-> any/c any/c)]
+               [then-contract contract?]
+               [else-contract contract?])
+         contract?]{
+
+Produces a contract that, when applied to a value, first tests the
+value with @scheme[predicate]; if @scheme[predicate] returns true, the
+@scheme[then-contract] is applied; otherwise, the
+@scheme[else-contract] is applied. The resulting contract is a flat
+contract if both @scheme[then-contract] and @scheme[else-contract] are
+flat contracts.
+
+For example, the following contract enforces that if a value is a
+procedure, it is a thunk; otherwise it can be any (non-procedure)
+value:
+  @schemeblock[(if/c procedure? (-> any) any/c)]
+Note that the following contract is @bold{not} equivalent:
+  @schemeblock[(or/c (-> any) any/c) (code:comment "wrong!")]
+The last contract is the same as @scheme[any/c] because
+@scheme[or/c] tries flat contracts before higher-order contracts.
+
+}
diff --git a/collects/unstable/struct.ss b/collects/unstable/struct.ss
index 1384d643fb..9a272bddad 100644
--- a/collects/unstable/struct.ss
+++ b/collects/unstable/struct.ss
@@ -3,24 +3,27 @@
 (require (for-syntax scheme/base
                      scheme/struct-info))
 (provide make
-         struct->list)
+         struct->list
+         (for-syntax get-struct-info))
+
+;; get-struct-info : identifier stx -> struct-info-list
+(define-for-syntax (get-struct-info id ctx)
+  (define (bad-struct-name x)
+    (raise-syntax-error #f "expected struct name" ctx x))
+  (unless (identifier? id)
+    (bad-struct-name id))
+  (let ([value (syntax-local-value id (lambda () #f))])
+    (unless (struct-info? value)
+      (bad-struct-name id))
+    (extract-struct-info value)))
 
 ;; (make struct-name field-expr ...)
 ;; Checks that correct number of fields given.
 (define-syntax (make stx)
-  (define (bad-struct-name x)
-    (raise-syntax-error #f "expected struct name" stx x))
-  (define (get-struct-info id)
-    (unless (identifier? id)
-      (bad-struct-name id))
-    (let ([value (syntax-local-value id (lambda () #f))])
-      (unless (struct-info? value)
-        (bad-struct-name id))
-      (extract-struct-info value)))
   (syntax-case stx ()
     [(make S expr ...)
      (let ()
-       (define info (get-struct-info #'S))
+       (define info (get-struct-info #'S stx))
        (define constructor (list-ref info 1))
        (define accessors (list-ref info 3))
        (unless (identifier? #'constructor)

From bf64d93c64654f0b9aa0e923e997fca9b44212a6 Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Thu, 3 Dec 2009 03:51:41 +0000
Subject: [PATCH 081/136] Fixed a case where `term' raised an exception without
 a source location.

svn: r17172
---
 collects/redex/private/term-test.ss | 29 +++++++++++++++++++++++++++++
 collects/redex/private/term.ss      | 10 +++++-----
 2 files changed, 34 insertions(+), 5 deletions(-)

diff --git a/collects/redex/private/term-test.ss b/collects/redex/private/term-test.ss
index fa35933612..6d271f4eaf 100644
--- a/collects/redex/private/term-test.ss
+++ b/collects/redex/private/term-test.ss
@@ -136,6 +136,35 @@
       src)
      src))
   
+  (let ([src 'ellipsis-args])
+    (test
+     (runtime-error-source 
+      '(term-let-fn ((f car))
+                    (term-let ([(x ...) '(a b)]
+                               [(y ...) '(c d e)])
+                              (term (f ((x y) ...)))))
+      src)
+     src))
+  
+  (let ([src 'ellipsis-args/map])
+    (test
+     (runtime-error-source 
+      '(term-let-fn ((f car))
+                    (term-let ([(x ...) '(a b)]
+                               [(y ...) '(c d e)])
+                              (term ((f (x y)) ...))))
+      src)
+     src))
+  
+  (let ([src 'ellipsis-args/in-hole])
+    (test
+     (runtime-error-source 
+      '(term-let ([(x ...) '(a b)]
+                  [(y ...) '(c d e)])
+                 (term ((in-hole hole (x y)) ...)))
+      src)
+     src))
+  
   (let ([src 'term-let-rhs])
     (test
      (runtime-error-source
diff --git a/collects/redex/private/term.ss b/collects/redex/private/term.ss
index 04c0f32927..bda4c28747 100644
--- a/collects/redex/private/term.ss
+++ b/collects/redex/private/term.ss
@@ -32,11 +32,11 @@
       (let ([result-id (car (generate-temporaries '(f-results)))])
         (with-syntax ([fn fn])
           (let loop ([func (syntax (λ (x) (fn (syntax->datum x))))]
-                     [args rewritten]
+                     [args-stx rewritten]
                      [res result-id]
                      [args-depth (min depth max-depth)])
             (with-syntax ([func func]
-                          [args args]
+                          [args args-stx]
                           [res res])
               (if (zero? args-depth)
                   (begin
@@ -45,7 +45,7 @@
                                 outer-bindings))
                     (values result-id (min depth max-depth)))
                   (loop (syntax (λ (l) (map func (syntax->list l))))
-                        (syntax (args (... ...)))
+                        (syntax/loc args-stx (args (... ...)))
                         (syntax (res (... ...)))
                         (sub1 args-depth)))))))))
   
@@ -55,7 +55,7 @@
        (and (identifier? (syntax metafunc-name))
             (term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f))))
        (rewrite-application (term-fn-get-id (syntax-local-value/catch (syntax metafunc-name) (λ (x) #t)))
-                            (syntax (arg ...))
+                            (syntax/loc stx (arg ...))
                             depth)]
       [f
        (and (identifier? (syntax f))
@@ -76,7 +76,7 @@
       [(unquote-splicing . x)
        (raise-syntax-error 'term "malformed unquote splicing" orig-stx stx)]
       [(in-hole id body)
-       (rewrite-application (syntax (λ (x) (apply plug x))) (syntax (id body)) depth)]
+       (rewrite-application (syntax (λ (x) (apply plug x))) (syntax/loc stx (id body)) depth)]
       [(in-hole . x)
        (raise-syntax-error 'term "malformed in-hole" orig-stx stx)]
       [hole (values (syntax (unsyntax the-hole)) 0)]

From 5dfa0d34731f9d024894a14f5f84dbed74a8629d Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 3 Dec 2009 05:03:13 +0000
Subject: [PATCH 082/136] unstable/list: added check-duplicate

svn: r17173
---
 collects/unstable/list.ss                | 75 +++++++++++++++++++-----
 collects/unstable/scribblings/list.scrbl | 44 ++++++++++++--
 2 files changed, 100 insertions(+), 19 deletions(-)

diff --git a/collects/unstable/list.ss b/collects/unstable/list.ss
index 697f100c98..661721467a 100644
--- a/collects/unstable/list.ss
+++ b/collects/unstable/list.ss
@@ -1,19 +1,15 @@
-#lang scheme
+#lang scheme/base
+(require scheme/contract
+         scheme/dict)
 
-; list-prefix : list? list? -> (or/c list? false/c)
-; Is l a prefix or r?, and what is that prefix?
+; list-prefix : list? list? -> boolean?
+; Is l a prefix or r?
 (define (list-prefix? ls rs)
-  (match ls
-    [(list)
-     #t]
-    [(list-rest l0 ls)
-     (match rs
-       [(list)
-        #f]
-       [(list-rest r0 rs)
-        (if (equal? l0 r0)
-            (list-prefix? ls rs)
-            #f)])]))
+  (or (null? ls)
+      (and (pair? rs)
+           (equal? (car ls) (car rs))
+           (list-prefix? (cdr ls) (cdr rs)))))
+
 ;; Eli: Is this some `match' obsession syndrom?  The simple definition:
 ;;   (define (list-prefix? ls rs)
 ;;     (or (null? ls) (and (pair? rs) (equal? (car ls) (car rs))
@@ -25,6 +21,7 @@
 ;;   (Which can be useful for things like making a path relative to
 ;;   another path.)  A nice generalization is to make it get two or more
 ;;   lists, and return a matching number of values.
+;; ryanc: changed to use Eli's version
 
 (provide/contract
  [list-prefix? (list? list? . -> . boolean?)])
@@ -38,4 +35,52 @@
 (define (extend s t extra)
   (append t (build-list (- (length s) (length t)) (lambda _ extra))))
 
-(provide filter-multiple extend)
\ No newline at end of file
+(provide filter-multiple extend)
+
+;; ryanc added:
+
+(provide/contract
+ [check-duplicate
+  (->* (list?)
+       (#:key (-> any/c any/c)
+        #:same? (or/c dict? (-> any/c any/c any/c)))
+       any)])
+
+;; check-duplicate : (listof X)
+;;                   #:key (X -> K)
+;;                   #:same? (or/c (K K -> bool) dict?)
+;;                -> X or #f
+(define (check-duplicate items
+                        #:key [key values]
+                        #:same? [same? equal?])
+  (cond [(procedure? same?)
+         (cond [(eq? same? equal?)
+                (check-duplicate/t items key (make-hash) #t)]
+               [(eq? same? eq?)
+                (check-duplicate/t items key (make-hasheq) #t)]
+               [(eq? same? eqv?)
+                (check-duplicate/t items key (make-hasheqv) #t)]
+               [else
+                (check-duplicate/list items key same?)])]
+        [(dict? same?)
+         (let ([dict same?])
+           (if (dict-mutable? dict)
+               (check-duplicate/t items key dict #t)
+               (check-duplicate/t items key dict #f)))]))
+(define (check-duplicate/t items key table mutating?)
+  (let loop ([items items] [table table])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (dict-ref table key-item #f)
+               (car items)
+               (loop (cdr items) (if mutating?
+                                     (begin (dict-set! table key-item #t) table)
+                                     (dict-set table key-item #t))))))))
+(define (check-duplicate/list items key same?)
+  (let loop ([items items] [sofar null])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (for/or ([prev (in-list sofar)])
+                 (same? key-item prev))
+               (car items)
+               (loop (cdr items) (cons key-item sofar)))))))
diff --git a/collects/unstable/scribblings/list.scrbl b/collects/unstable/scribblings/list.scrbl
index ac5f7bf9ed..aedc04c1b5 100644
--- a/collects/unstable/scribblings/list.scrbl
+++ b/collects/unstable/scribblings/list.scrbl
@@ -3,9 +3,11 @@
           scribble/manual
           scribble/eval
 	  "utils.ss"
-         (for-label unstable/list
-                    scheme/contract
-                    scheme/base))
+          (for-label scheme/dict
+                     unstable/list
+                     syntax/id-table
+                     scheme/contract
+                     scheme/base))
 
 @(define the-eval (make-base-eval))
 @(the-eval '(require unstable/list))
@@ -40,4 +42,38 @@ Extends @scheme[l2] to be as long as @scheme[l1] by adding @scheme[(-
 
 @examples[#:eval the-eval]
 (extend '(1 2 3) '(a) 'b)
-}
\ No newline at end of file
+}
+
+
+@addition{Ryan Culpepper}
+
+@defproc[(check-duplicate [lst list?]
+                          [#:key extract-key (-> any/c any/c) (lambda (x) x)]
+                          [#:same? same?
+                                   (or/c (any/c any/c . -> . any/c)
+                                         dict?)
+                                   equal?])
+         (or/c any/c #f)]{
+
+Returns the first duplicate item in @scheme[lst]. More precisely, it
+returns the first @scheme[_x] such that there was a previous
+@scheme[_y] where @scheme[(same? (extract-key _x) (extract-key _y))].
+
+The @scheme[same?] argument can either be an equivalence predicate
+such as @scheme[equal?] or @scheme[eqv?] or a dictionary. In the
+latter case, the elements of the list are mapped to @scheme[#t] in the
+dictionary until an element is discovered that is already mapped to a
+true value. The procedures @scheme[equal?], @scheme[eqv?], and
+@scheme[eq?] automatically use a dictionary for speed.
+
+@(the-eval '(require syntax/id-table scheme/dict))
+@examples[#:eval the-eval
+(check-duplicate '(1 2 3 4))
+(check-duplicate '(1 2 3 2 1))
+(check-duplicate '((a 1) (b 2) (a 3)) #:key car)
+(define id-t (make-free-id-table))
+(check-duplicate (syntax->list #'(a b c d a b))
+                 #:same? id-t)
+(dict-map id-t list)
+]
+}

From ed805668cdb322b1788095bcc93ecb4eaf6d3332 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Thu, 3 Dec 2009 08:16:38 +0000
Subject: [PATCH 083/136] typo

svn: r17175
---
 collects/scribblings/gui/text-class.scrbl | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl
index c4fccef743..8e2e1cd278 100644
--- a/collects/scribblings/gui/text-class.scrbl
+++ b/collects/scribblings/gui/text-class.scrbl
@@ -1735,7 +1735,7 @@ If @scheme[end] is not @scheme['same] and not the same as @scheme[start],
 
 When the specified range cannot fit in the visible area, @scheme[bias]
  indicates which end of the range to display. When @scheme[bias] is
- @scheme['same], then the start of the range is displayed. When
+ @scheme['start], then the start of the range is displayed. When
  @scheme[bias] is @scheme['end], then the end of the range is
  displayed. Otherwise, @scheme[bias] must be @scheme['none].
 
@@ -1747,7 +1747,7 @@ If the editor is scrolled, then the editor is redrawn and the return
  scroll-editor-to].
 
 Scrolling is disallowed when the editor is internally locked for
- reflowing (see also @|lockdiscuss|). 
+ reflowing (see also @|lockdiscuss|).
 
 The system may scroll the editor without calling this method. For
  example, a canvas displaying an editor might scroll the editor to

From 61cc458a7278cbe1b405b4ab63acb3b68aea940c Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Thu, 3 Dec 2009 08:50:40 +0000
Subject: [PATCH 084/136] Welcome to a new PLT day.

svn: r17176
---
 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 94220c8f4c..6bc39c1c80 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "2dec2009")
+#lang scheme/base (provide stamp) (define stamp "3dec2009")

From 4eef1b3ceebf04ac2267ebfe28d5dd8f46f7eafd Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 3 Dec 2009 16:42:32 +0000
Subject: [PATCH 085/136] flvectors

svn: r17177
---
 collects/scribblings/inside/custodians.scrbl |   5 +-
 collects/scribblings/reference/numbers.scrbl |  52 ++
 collects/scribblings/reference/unsafe.scrbl  |  12 +
 collects/tests/mzscheme/optimize.ss          |   7 +-
 collects/tests/mzscheme/unsafe.ss            |  13 +
 doc/release-notes/mzscheme/HISTORY.txt       |   3 +
 src/mzscheme/include/scheme.h                |  11 +
 src/mzscheme/src/cstartup.inc                | 526 +++++++++----------
 src/mzscheme/src/jit.c                       | 163 +++++-
 src/mzscheme/src/jit_ts.c                    |   4 +
 src/mzscheme/src/mzmark.c                    |  28 +
 src/mzscheme/src/mzmarksrc.c                 |   9 +
 src/mzscheme/src/number.c                    | 236 ++++++++-
 src/mzscheme/src/schminc.h                   |   4 +-
 src/mzscheme/src/schpriv.h                   |   6 +
 src/mzscheme/src/schvers.h                   |   4 +-
 src/mzscheme/src/stypes.h                    | 145 ++---
 src/mzscheme/src/type.c                      |   2 +
 src/mzscheme/src/vector.c                    |  24 +-
 19 files changed, 878 insertions(+), 376 deletions(-)

diff --git a/collects/scribblings/inside/custodians.scrbl b/collects/scribblings/inside/custodians.scrbl
index e2cffb78d7..b9f5a3b269 100644
--- a/collects/scribblings/inside/custodians.scrbl
+++ b/collects/scribblings/inside/custodians.scrbl
@@ -36,7 +36,6 @@ Creates a new custodian as a subordinate of @var{m}. If @var{m} is
 Places the value @var{o} into the management of the custodian
  @var{m}. If @var{m} is @cpp{NULL}, the current custodian is used.
 
-
 The @var{f} function is called by the custodian if it is ever asked to
 ``shutdown'' its values; @var{o} and @var{data} are passed on to
 @var{f}, which has the type
@@ -52,6 +51,10 @@ be remembered until either the custodian shuts it down or
 zero, the value is allowed to be garbaged collected (and automatically
 removed from the custodian).
 
+Independent of whether @var{strong} is zero, the value @var{o} is
+initially weakly held. A value associated with a custodian can
+therefore be finalized via will executors.
+
 The return value from @cpp{scheme_add_managed} can be used to refer
 to the value's custodian later in a call to
 @cpp{scheme_remove_managed}. A value can be registered with at
diff --git a/collects/scribblings/reference/numbers.scrbl b/collects/scribblings/reference/numbers.scrbl
index 59acdabaac..7537bbf5c7 100644
--- a/collects/scribblings/reference/numbers.scrbl
+++ b/collects/scribblings/reference/numbers.scrbl
@@ -849,6 +849,58 @@ Returns @scheme[#t] if the native encoding of numbers is big-endian
 for the machine running Scheme, @scheme[#f] if the native encoding
 is little-endian.}
 
+@; ------------------------------------------------------------------------
+@section{Inexact-Real Vectors}
+
+A @deftech{flvector} is like a @tech{vector}, but it holds only
+inexact real numbers. This representation can be more compact, and
+unsafe operations on @tech{flvector}s (see
+@schememodname[scheme/unsafe/ops]) can execute more efficiently than
+unsafe operations on @tech{vectors} of inexact reals.
+
+An f64vector as provided by @schememodname[scheme/foreign] stores the
+same kinds of values as an @tech{flvector}, but with extra
+indirections that make f64vectors more convenient for working with
+foreign libraries. The lack of indirections make unsafe
+@tech{flvector} access more efficient.
+
+@defproc[(flvector? [v any/c]) boolean?]{
+
+Returns @scheme[#t] if @scheme[v] is a @tech{flvector}, @scheme[#f] otherwise.}
+
+@defproc[(flvector [x inexact-real?] ...) flvector?]{
+
+Creates a @tech{flvector} containing the given inexact real numbers.}
+
+@defproc[(make-flvector [size exact-nonnegative-integer?]
+                        [x inexact-real? 0.0]) 
+         flvector?]{
+
+Creates a @tech{flvector} with @scheme[size] elements, where every
+slot in the @tech{flvector} is filled with @scheme[x].}
+
+@defproc[(flvector-length [vec flvector?]) exact-nonnegative-integer?]{
+
+Returns the length of @scheme[vec] (i.e., the number of slots in the
+@tech{flvector}).}
+
+
+@defproc[(flvector-ref [vec flvector?] [pos exact-nonnegative-integer?])
+         inexact-real?]{
+
+Returns the inexact real number in slot @scheme[pos] of
+@scheme[vec]. The first slot is position @scheme[0], and the last slot
+is one less than @scheme[(flvector-length vec)].}
+
+@defproc[(flvector-set! [vec flvector?] [pos exact-nonnegative-integer?]
+                        [x inexact-real?])
+         inexact-real?]{
+
+Sets the inexact real number in slot @scheme[pos] of @scheme[vec]. The
+first slot is position @scheme[0], and the last slot is one less than
+@scheme[(flvector-length vec)].}
+
+
 @; ------------------------------------------------------------------------
 @section{Extra Constants and Functions}
 
diff --git a/collects/scribblings/reference/unsafe.scrbl b/collects/scribblings/reference/unsafe.scrbl
index 35202bb503..acee583bf8 100644
--- a/collects/scribblings/reference/unsafe.scrbl
+++ b/collects/scribblings/reference/unsafe.scrbl
@@ -169,6 +169,18 @@ Unsafe versions of @scheme[bytes-length], @scheme[bytes-ref], and
 fixnum).}
 
 
+@deftogether[(
+@defproc[(unsafe-flvector-length [v flvector?]) fixnum?]
+@defproc[(unsafe-flvector-ref [v flvector?][k fixnum?]) any/c]
+@defproc[(unsafe-flvector-set! [v flvector?][k fixnum?][x inexact-real?]) void?]
+)]{
+
+Unsafe versions of @scheme[flvector-length], @scheme[flvector-ref], and
+@scheme[flvector-set!]. A @tech{flvector}'s size can never be larger than a
+@tech{fixnum} (so even @scheme[flvector-length] always returns a
+fixnum).}
+
+
 @deftogether[(
 @defproc[(unsafe-f64vector-ref [vec f64vector?][k fixnum?]) inexact-real?]
 @defproc[(unsafe-f64vector-set! [vec f64vector?][k fixnum?][n inexact-real?]) void?]
diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss
index 1a62a69916..00b3e2ba15 100644
--- a/collects/tests/mzscheme/optimize.ss
+++ b/collects/tests/mzscheme/optimize.ss
@@ -413,6 +413,10 @@
     (un-exact 'a 'unbox (box 'a))
     (un-exact 3 'vector-length (vector 'a 'b 'c))
 
+    (bin-exact 1.1 'flvector-ref (flvector 1.1 2.2 3.3) 0)
+    (bin-exact 3.3 'flvector-ref (flvector 1.1 2.2 3.3) 2)
+    (un-exact 3 'flvector-length (flvector 1.1 2.2 3.3))
+
     (bin-exact #\a 'string-ref "abc\u2001" 0)
     (bin-exact #\b 'string-ref "abc\u2001" 1)
     (bin-exact #\c 'string-ref "abc\u2001" 2)
@@ -454,7 +458,8 @@
 			 '(0 1 2))))])
       (test-setter make-vector #f 7 'vector-set! vector-set! vector-ref)
       (test-setter make-bytes 0 7 'bytes-set! bytes-set! bytes-ref)
-      (test-setter make-string #\a #\7 'string-set! string-set! string-ref))
+      (test-setter make-string #\a #\7 'string-set! string-set! string-ref)
+      (test-setter make-flvector 1.0 7.0 'flvector-set! flvector-set! flvector-ref))
 
     ))
 
diff --git a/collects/tests/mzscheme/unsafe.ss b/collects/tests/mzscheme/unsafe.ss
index fdfd47803c..c404722667 100644
--- a/collects/tests/mzscheme/unsafe.ss
+++ b/collects/tests/mzscheme/unsafe.ss
@@ -187,6 +187,19 @@
               #:post (lambda (x) (list x (string-ref v 2)))
               #:literal-ok? #f))
 
+  (let ([flvector (lambda args
+                    (let ([v (make-flvector (length args))])
+                      (for ([a args]
+                            [i (in-naturals)])
+                        (flvector-set! v i a))
+                      v))])
+    (test-bin 9.5 'unsafe-flvector-ref (flvector 1.0 9.5 18.7) 1)
+    (let ([v (flvector 1.0 9.5 18.7)])
+      (test-tri (list (void) 27.4) 'unsafe-flvector-set! v 2 27.4
+                #:pre (lambda () (flvector-set! v 2 0.0)) 
+                #:post (lambda (x) (list x (flvector-ref v 2)))
+                #:literal-ok? #f)))
+
   (test-bin 9.5 'unsafe-f64vector-ref (f64vector 1.0 9.5 18.7) 1)
   (let ([v (f64vector 1.0 9.5 18.7)])
     (test-tri (list (void) 27.4) 'unsafe-f64vector-set! v 2 27.4
diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt
index fa874ddc03..ae7d173969 100644
--- a/doc/release-notes/mzscheme/HISTORY.txt
+++ b/doc/release-notes/mzscheme/HISTORY.txt
@@ -1,3 +1,6 @@
+Version 4.2.3.4
+Added flvectors
+
 Version 4.2.3.3
 Added unsafe-f64vector-ref and unsafe-f64vector-set!
 Changed JIT to inline numeric ops with more than 2 arguments
diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h
index 53e15c63f0..7589873457 100644
--- a/src/mzscheme/include/scheme.h
+++ b/src/mzscheme/include/scheme.h
@@ -318,6 +318,12 @@ typedef struct Scheme_Vector {
   Scheme_Object *els[1];
 } Scheme_Vector;
 
+typedef struct Scheme_Double_Vector {
+  Scheme_Object so;
+  long size;
+  double els[1];
+} Scheme_Double_Vector;
+
 typedef struct Scheme_Print_Params Scheme_Print_Params;
 typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Print_Params *pp);
 
@@ -435,6 +441,8 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data)
 #define SCHEME_MUTABLE_VECTORP(obj)  (SCHEME_VECTORP(obj) && SCHEME_MUTABLEP(obj))
 #define SCHEME_IMMUTABLE_VECTORP(obj)  (SCHEME_VECTORP(obj) && SCHEME_IMMUTABLEP(obj))
 
+#define SCHEME_FLVECTORP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_flvector_type)
+
 #define SCHEME_STRUCTP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_structure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type))
 #define SCHEME_STRUCT_TYPEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_struct_type_type)
 
@@ -539,6 +547,9 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data)
 #define SCHEME_VEC_ELS(obj)  (((Scheme_Vector *)(obj))->els)
 #define SCHEME_VEC_BASE(obj) SCHEME_VEC_ELS(obj)
 
+#define SCHEME_FLVEC_SIZE(obj) (((Scheme_Double_Vector *)(obj))->size)
+#define SCHEME_FLVEC_ELS(obj)  (((Scheme_Double_Vector *)(obj))->els)
+
 #define SCHEME_ENVBOX_VAL(obj)  (*((Scheme_Object **)(obj)))
 #define SCHEME_WEAK_BOX_VAL(obj) SCHEME_BOX_VAL(obj)
 
diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc
index 2173ba0593..a3bcfd6396 100644
--- a/src/mzscheme/src/cstartup.inc
+++ b/src/mzscheme/src/cstartup.inc
@@ -1,12 +1,12 @@
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,51,50,0,0,0,1,0,0,3,0,12,0,
-25,0,29,0,34,0,41,0,44,0,49,0,56,0,63,0,67,0,72,0,78,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,52,50,0,0,0,1,0,0,3,0,12,0,
+19,0,23,0,28,0,41,0,44,0,49,0,56,0,63,0,67,0,72,0,78,
 0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
 177,0,179,0,193,0,4,1,33,1,44,1,55,1,65,1,101,1,134,1,167,
 1,226,1,36,2,114,2,180,2,185,2,205,2,96,3,116,3,167,3,233,3,
 118,4,4,5,56,5,79,5,158,5,0,0,105,7,0,0,29,11,11,68,104,
-101,114,101,45,115,116,120,72,112,97,114,97,109,101,116,101,114,105,122,101,63,
-97,110,100,64,108,101,116,42,66,100,101,102,105,110,101,62,111,114,64,99,111,
+101,114,101,45,115,116,120,66,100,101,102,105,110,101,63,97,110,100,64,108,101,
+116,42,72,112,97,114,97,109,101,116,101,114,105,122,101,62,111,114,64,99,111,
 110,100,66,108,101,116,114,101,99,66,117,110,108,101,115,115,63,108,101,116,64,
 119,104,101,110,65,113,117,111,116,101,29,94,2,13,68,35,37,107,101,114,110,
 101,108,11,29,94,2,13,68,35,37,112,97,114,97,109,122,11,62,105,102,65,
@@ -21,57 +21,57 @@
 2,161,2,1,36,2,2,2,1,2,2,96,11,11,8,240,35,79,0,0,16,
 0,96,37,11,8,240,35,79,0,0,16,0,13,16,4,35,29,11,11,2,1,
 11,18,16,2,99,64,104,101,114,101,8,31,8,30,8,29,8,28,8,27,93,
-8,224,42,79,0,0,95,9,8,224,42,79,0,0,2,1,27,248,22,137,4,
-195,249,22,130,4,80,158,38,35,251,22,77,2,16,248,22,92,199,12,249,22,
-67,2,17,248,22,94,201,27,248,22,137,4,195,249,22,130,4,80,158,38,35,
+8,224,42,79,0,0,95,9,8,224,42,79,0,0,2,1,27,248,22,143,4,
+195,249,22,136,4,80,158,38,35,251,22,77,2,16,248,22,92,199,12,249,22,
+67,2,17,248,22,94,201,27,248,22,143,4,195,249,22,136,4,80,158,38,35,
 251,22,77,2,16,248,22,92,199,249,22,67,2,17,248,22,94,201,12,27,248,
-22,69,248,22,137,4,196,28,248,22,75,193,20,15,159,36,35,36,28,248,22,
-75,248,22,69,194,248,22,68,193,249,22,130,4,80,158,38,35,251,22,77,2,
+22,69,248,22,143,4,196,28,248,22,75,193,20,15,159,36,35,36,28,248,22,
+75,248,22,69,194,248,22,68,193,249,22,136,4,80,158,38,35,251,22,77,2,
 16,248,22,68,199,249,22,67,2,4,248,22,69,201,11,18,16,2,101,10,8,
 31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,3,1,8,101,110,118,
 49,50,57,54,48,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,54,
 49,93,8,224,43,79,0,0,95,9,8,224,43,79,0,0,2,1,27,248,22,
-69,248,22,137,4,196,28,248,22,75,193,20,15,159,36,35,36,28,248,22,75,
-248,22,69,194,248,22,68,193,249,22,130,4,80,158,38,35,250,22,77,2,20,
+69,248,22,143,4,196,28,248,22,75,193,20,15,159,36,35,36,28,248,22,75,
+248,22,69,194,248,22,68,193,249,22,136,4,80,158,38,35,250,22,77,2,20,
 248,22,77,249,22,77,248,22,77,2,21,248,22,68,201,251,22,77,2,16,2,
 21,2,21,249,22,67,2,7,248,22,69,204,18,16,2,101,11,8,31,8,30,
 8,29,8,28,8,27,16,4,11,11,2,18,3,1,8,101,110,118,49,50,57,
 54,51,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,54,52,93,8,
-224,44,79,0,0,95,9,8,224,44,79,0,0,2,1,248,22,137,4,193,27,
-248,22,137,4,194,249,22,67,248,22,77,248,22,68,196,248,22,69,195,27,248,
-22,69,248,22,137,4,23,197,1,249,22,130,4,80,158,38,35,28,248,22,53,
-248,22,131,4,248,22,68,23,198,2,27,249,22,2,32,0,89,162,8,44,36,
-42,9,222,33,39,248,22,137,4,248,22,92,23,200,2,250,22,77,2,22,248,
+224,44,79,0,0,95,9,8,224,44,79,0,0,2,1,248,22,143,4,193,27,
+248,22,143,4,194,249,22,67,248,22,77,248,22,68,196,248,22,69,195,27,248,
+22,69,248,22,143,4,23,197,1,249,22,136,4,80,158,38,35,28,248,22,53,
+248,22,137,4,248,22,68,23,198,2,27,249,22,2,32,0,89,162,8,44,36,
+42,9,222,33,39,248,22,143,4,248,22,92,23,200,2,250,22,77,2,22,248,
 22,77,249,22,77,248,22,77,248,22,68,23,204,2,250,22,78,2,23,249,22,
 2,22,68,23,204,2,248,22,94,23,206,2,249,22,67,248,22,68,23,202,1,
 249,22,2,22,92,23,200,1,250,22,78,2,20,249,22,2,32,0,89,162,8,
-44,36,46,9,222,33,40,248,22,137,4,248,22,68,201,248,22,69,198,27,248,
-22,137,4,194,249,22,67,248,22,77,248,22,68,196,248,22,69,195,27,248,22,
-69,248,22,137,4,23,197,1,249,22,130,4,80,158,38,35,250,22,78,2,22,
-249,22,2,32,0,89,162,8,44,36,46,9,222,33,42,248,22,137,4,248,22,
-68,201,248,22,69,198,27,248,22,69,248,22,137,4,196,27,248,22,137,4,248,
-22,68,195,249,22,130,4,80,158,39,35,28,248,22,75,195,250,22,78,2,20,
+44,36,46,9,222,33,40,248,22,143,4,248,22,68,201,248,22,69,198,27,248,
+22,143,4,194,249,22,67,248,22,77,248,22,68,196,248,22,69,195,27,248,22,
+69,248,22,143,4,23,197,1,249,22,136,4,80,158,38,35,250,22,78,2,22,
+249,22,2,32,0,89,162,8,44,36,46,9,222,33,42,248,22,143,4,248,22,
+68,201,248,22,69,198,27,248,22,69,248,22,143,4,196,27,248,22,143,4,248,
+22,68,195,249,22,136,4,80,158,39,35,28,248,22,75,195,250,22,78,2,20,
 9,248,22,69,199,250,22,77,2,11,248,22,77,248,22,68,199,250,22,78,2,
-5,248,22,69,201,248,22,69,202,27,248,22,69,248,22,137,4,23,197,1,27,
-249,22,1,22,81,249,22,2,22,137,4,248,22,137,4,248,22,68,199,249,22,
-130,4,80,158,39,35,251,22,77,1,22,119,105,116,104,45,99,111,110,116,105,
+5,248,22,69,201,248,22,69,202,27,248,22,69,248,22,143,4,23,197,1,27,
+249,22,1,22,81,249,22,2,22,143,4,248,22,143,4,248,22,68,199,249,22,
+136,4,80,158,39,35,251,22,77,1,22,119,105,116,104,45,99,111,110,116,105,
 110,117,97,116,105,111,110,45,109,97,114,107,2,24,250,22,78,1,23,101,120,
 116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,
 21,95,1,27,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,
 45,115,101,116,45,102,105,114,115,116,11,2,24,201,250,22,78,2,20,9,248,
-22,69,203,27,248,22,69,248,22,137,4,196,28,248,22,75,193,20,15,159,36,
-35,36,249,22,130,4,80,158,38,35,27,248,22,137,4,248,22,68,197,28,249,
-22,167,8,62,61,62,248,22,131,4,248,22,92,196,250,22,77,2,20,248,22,
+22,69,203,27,248,22,69,248,22,143,4,196,28,248,22,75,193,20,15,159,36,
+35,36,249,22,136,4,80,158,38,35,27,248,22,143,4,248,22,68,197,28,249,
+22,173,8,62,61,62,248,22,137,4,248,22,92,196,250,22,77,2,20,248,22,
 77,249,22,77,21,93,2,25,248,22,68,199,250,22,78,2,8,249,22,77,2,
 25,249,22,77,248,22,101,203,2,25,248,22,69,202,251,22,77,2,16,28,249,
-22,167,8,248,22,131,4,248,22,68,200,64,101,108,115,101,10,248,22,68,197,
+22,173,8,248,22,137,4,248,22,68,200,64,101,108,115,101,10,248,22,68,197,
 250,22,78,2,20,9,248,22,69,200,249,22,67,2,8,248,22,69,202,100,8,
 31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,3,1,8,101,110,118,
 49,50,57,56,54,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,56,
 55,93,8,224,45,79,0,0,18,16,2,158,94,10,64,118,111,105,100,8,47,
-95,9,8,224,45,79,0,0,2,1,27,248,22,69,248,22,137,4,196,249,22,
-130,4,80,158,38,35,28,248,22,53,248,22,131,4,248,22,68,197,250,22,77,
-2,26,248,22,77,248,22,68,199,248,22,92,198,27,248,22,131,4,248,22,68,
+95,9,8,224,45,79,0,0,2,1,27,248,22,69,248,22,143,4,196,249,22,
+136,4,80,158,38,35,28,248,22,53,248,22,137,4,248,22,68,197,250,22,77,
+2,26,248,22,77,248,22,68,199,248,22,92,198,27,248,22,137,4,248,22,68,
 197,250,22,77,2,26,248,22,77,248,22,68,197,250,22,78,2,23,248,22,69,
 199,248,22,69,202,159,35,20,102,159,35,16,1,11,16,0,83,158,41,20,100,
 144,69,35,37,109,105,110,45,115,116,120,2,1,11,11,11,10,35,80,158,35,
@@ -90,16 +90,16 @@
 44,36,57,9,223,0,33,41,35,20,102,159,35,16,1,2,2,16,0,11,16,
 5,2,9,89,162,8,44,36,52,9,223,0,33,43,35,20,102,159,35,16,1,
 2,2,16,0,11,16,5,2,5,89,162,8,44,36,53,9,223,0,33,44,35,
-20,102,159,35,16,1,2,2,16,0,11,16,5,2,3,89,162,8,44,36,54,
+20,102,159,35,16,1,2,2,16,0,11,16,5,2,6,89,162,8,44,36,54,
 9,223,0,33,45,35,20,102,159,35,16,1,2,2,16,0,11,16,5,2,8,
 89,162,8,44,36,57,9,223,0,33,46,35,20,102,159,35,16,1,2,2,16,
-1,33,48,11,16,5,2,6,89,162,8,44,36,53,9,223,0,33,49,35,20,
+1,33,48,11,16,5,2,3,89,162,8,44,36,53,9,223,0,33,49,35,20,
 102,159,35,16,1,2,2,16,0,11,16,0,94,2,14,2,15,93,2,14,9,
 9,35,0};
     EVAL_ONE_SIZED_STR((char *)expr, 2018);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,51,59,0,0,0,1,0,0,13,0,18,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,52,59,0,0,0,1,0,0,13,0,18,0,
 35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226,
 0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1,
 199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100,
@@ -131,176 +131,176 @@
 116,101,32,115,116,114,105,110,103,6,36,36,99,97,110,110,111,116,32,97,100,
 100,32,97,32,115,117,102,102,105,120,32,116,111,32,97,32,114,111,111,116,32,
 112,97,116,104,58,32,5,0,27,20,14,159,80,158,36,50,250,80,158,39,51,
-249,22,27,11,80,158,41,50,22,189,12,10,248,22,160,5,23,196,2,28,248,
-22,157,6,23,194,2,12,87,94,248,22,171,8,23,194,1,248,80,159,37,53,
+249,22,27,11,80,158,41,50,22,131,13,10,248,22,166,5,23,196,2,28,248,
+22,163,6,23,194,2,12,87,94,248,22,177,8,23,194,1,248,80,159,37,53,
 36,195,28,248,22,75,23,195,2,9,27,248,22,68,23,196,2,27,28,248,22,
-171,13,23,195,2,23,194,1,28,248,22,170,13,23,195,2,249,22,172,13,23,
-196,1,250,80,158,42,48,248,22,187,13,2,19,11,10,250,80,158,40,48,248,
-22,187,13,2,19,23,197,1,10,28,23,193,2,249,22,67,248,22,174,13,249,
-22,172,13,23,198,1,247,22,188,13,27,248,22,69,23,200,1,28,248,22,75,
-23,194,2,9,27,248,22,68,23,195,2,27,28,248,22,171,13,23,195,2,23,
-194,1,28,248,22,170,13,23,195,2,249,22,172,13,23,196,1,250,80,158,47,
-48,248,22,187,13,2,19,11,10,250,80,158,45,48,248,22,187,13,2,19,23,
-197,1,10,28,23,193,2,249,22,67,248,22,174,13,249,22,172,13,23,198,1,
-247,22,188,13,248,80,159,45,52,36,248,22,69,23,199,1,87,94,23,193,1,
+177,13,23,195,2,23,194,1,28,248,22,176,13,23,195,2,249,22,178,13,23,
+196,1,250,80,158,42,48,248,22,129,14,2,19,11,10,250,80,158,40,48,248,
+22,129,14,2,19,23,197,1,10,28,23,193,2,249,22,67,248,22,180,13,249,
+22,178,13,23,198,1,247,22,130,14,27,248,22,69,23,200,1,28,248,22,75,
+23,194,2,9,27,248,22,68,23,195,2,27,28,248,22,177,13,23,195,2,23,
+194,1,28,248,22,176,13,23,195,2,249,22,178,13,23,196,1,250,80,158,47,
+48,248,22,129,14,2,19,11,10,250,80,158,45,48,248,22,129,14,2,19,23,
+197,1,10,28,23,193,2,249,22,67,248,22,180,13,249,22,178,13,23,198,1,
+247,22,130,14,248,80,159,45,52,36,248,22,69,23,199,1,87,94,23,193,1,
 248,80,159,43,52,36,248,22,69,23,197,1,87,94,23,193,1,27,248,22,69,
 23,198,1,28,248,22,75,23,194,2,9,27,248,22,68,23,195,2,27,28,248,
-22,171,13,23,195,2,23,194,1,28,248,22,170,13,23,195,2,249,22,172,13,
-23,196,1,250,80,158,45,48,248,22,187,13,2,19,11,10,250,80,158,43,48,
-248,22,187,13,2,19,23,197,1,10,28,23,193,2,249,22,67,248,22,174,13,
-249,22,172,13,23,198,1,247,22,188,13,248,80,159,43,52,36,248,22,69,23,
-199,1,248,80,159,41,52,36,248,22,69,196,27,248,22,147,13,23,195,2,28,
-23,193,2,192,87,94,23,193,1,28,248,22,162,6,23,195,2,27,248,22,169,
-13,195,28,192,192,248,22,170,13,195,11,87,94,28,28,248,22,148,13,23,195,
-2,10,27,248,22,147,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28,
-248,22,162,6,23,196,2,27,248,22,169,13,23,197,2,28,23,193,2,192,87,
-94,23,193,1,248,22,170,13,23,197,2,11,12,250,22,135,9,76,110,111,114,
+22,177,13,23,195,2,23,194,1,28,248,22,176,13,23,195,2,249,22,178,13,
+23,196,1,250,80,158,45,48,248,22,129,14,2,19,11,10,250,80,158,43,48,
+248,22,129,14,2,19,23,197,1,10,28,23,193,2,249,22,67,248,22,180,13,
+249,22,178,13,23,198,1,247,22,130,14,248,80,159,43,52,36,248,22,69,23,
+199,1,248,80,159,41,52,36,248,22,69,196,27,248,22,153,13,23,195,2,28,
+23,193,2,192,87,94,23,193,1,28,248,22,168,6,23,195,2,27,248,22,175,
+13,195,28,192,192,248,22,176,13,195,11,87,94,28,28,248,22,154,13,23,195,
+2,10,27,248,22,153,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28,
+248,22,168,6,23,196,2,27,248,22,175,13,23,197,2,28,23,193,2,192,87,
+94,23,193,1,248,22,176,13,23,197,2,11,12,250,22,141,9,76,110,111,114,
 109,97,108,45,112,97,116,104,45,99,97,115,101,6,42,42,112,97,116,104,32,
 40,102,111,114,32,97,110,121,32,115,121,115,116,101,109,41,32,111,114,32,118,
 97,108,105,100,45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,28,28,
-248,22,148,13,23,195,2,249,22,167,8,248,22,149,13,23,197,2,2,20,249,
-22,167,8,247,22,181,7,2,20,27,28,248,22,162,6,23,196,2,23,195,2,
-248,22,171,7,248,22,152,13,23,197,2,28,249,22,136,14,0,21,35,114,120,
+248,22,154,13,23,195,2,249,22,173,8,248,22,155,13,23,197,2,2,20,249,
+22,173,8,247,22,187,7,2,20,27,28,248,22,168,6,23,196,2,23,195,2,
+248,22,177,7,248,22,158,13,23,197,2,28,249,22,142,14,0,21,35,114,120,
 34,94,91,92,92,93,91,92,92,93,91,63,93,91,92,92,93,34,23,195,2,
-28,248,22,162,6,195,248,22,155,13,195,194,27,248,22,137,7,23,195,1,249,
-22,156,13,248,22,174,7,250,22,142,14,0,6,35,114,120,34,47,34,28,249,
-22,136,14,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47,
-92,92,93,42,36,34,23,201,2,23,199,1,250,22,142,14,0,19,35,114,120,
+28,248,22,168,6,195,248,22,161,13,195,194,27,248,22,143,7,23,195,1,249,
+22,162,13,248,22,180,7,250,22,148,14,0,6,35,114,120,34,47,34,28,249,
+22,142,14,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47,
+92,92,93,42,36,34,23,201,2,23,199,1,250,22,148,14,0,19,35,114,120,
 34,91,32,46,93,43,40,91,47,92,92,93,42,41,36,34,23,202,1,6,2,
-2,92,49,80,159,43,36,37,2,20,28,248,22,162,6,194,248,22,155,13,194,
-193,87,94,28,27,248,22,147,13,23,196,2,28,23,193,2,192,87,94,23,193,
-1,28,248,22,162,6,23,196,2,27,248,22,169,13,23,197,2,28,23,193,2,
-192,87,94,23,193,1,248,22,170,13,23,197,2,11,12,250,22,135,9,23,196,
-2,2,21,23,197,2,28,248,22,169,13,23,195,2,12,248,22,165,11,249,22,
-174,10,248,22,191,6,250,22,146,7,2,22,23,200,1,23,201,1,247,22,23,
-87,94,28,27,248,22,147,13,23,196,2,28,23,193,2,192,87,94,23,193,1,
-28,248,22,162,6,23,196,2,27,248,22,169,13,23,197,2,28,23,193,2,192,
-87,94,23,193,1,248,22,170,13,23,197,2,11,12,250,22,135,9,23,196,2,
-2,21,23,197,2,28,248,22,169,13,23,195,2,12,248,22,165,11,249,22,174,
-10,248,22,191,6,250,22,146,7,2,22,23,200,1,23,201,1,247,22,23,87,
-94,87,94,28,27,248,22,147,13,23,196,2,28,23,193,2,192,87,94,23,193,
-1,28,248,22,162,6,23,196,2,27,248,22,169,13,23,197,2,28,23,193,2,
-192,87,94,23,193,1,248,22,170,13,23,197,2,11,12,250,22,135,9,195,2,
-21,23,197,2,28,248,22,169,13,23,195,2,12,248,22,165,11,249,22,174,10,
-248,22,191,6,250,22,146,7,2,22,199,23,201,1,247,22,23,249,22,3,89,
-162,8,44,36,49,9,223,2,33,33,196,248,22,165,11,249,22,140,11,23,196,
+2,92,49,80,159,43,36,37,2,20,28,248,22,168,6,194,248,22,161,13,194,
+193,87,94,28,27,248,22,153,13,23,196,2,28,23,193,2,192,87,94,23,193,
+1,28,248,22,168,6,23,196,2,27,248,22,175,13,23,197,2,28,23,193,2,
+192,87,94,23,193,1,248,22,176,13,23,197,2,11,12,250,22,141,9,23,196,
+2,2,21,23,197,2,28,248,22,175,13,23,195,2,12,248,22,171,11,249,22,
+180,10,248,22,133,7,250,22,152,7,2,22,23,200,1,23,201,1,247,22,23,
+87,94,28,27,248,22,153,13,23,196,2,28,23,193,2,192,87,94,23,193,1,
+28,248,22,168,6,23,196,2,27,248,22,175,13,23,197,2,28,23,193,2,192,
+87,94,23,193,1,248,22,176,13,23,197,2,11,12,250,22,141,9,23,196,2,
+2,21,23,197,2,28,248,22,175,13,23,195,2,12,248,22,171,11,249,22,180,
+10,248,22,133,7,250,22,152,7,2,22,23,200,1,23,201,1,247,22,23,87,
+94,87,94,28,27,248,22,153,13,23,196,2,28,23,193,2,192,87,94,23,193,
+1,28,248,22,168,6,23,196,2,27,248,22,175,13,23,197,2,28,23,193,2,
+192,87,94,23,193,1,248,22,176,13,23,197,2,11,12,250,22,141,9,195,2,
+21,23,197,2,28,248,22,175,13,23,195,2,12,248,22,171,11,249,22,180,10,
+248,22,133,7,250,22,152,7,2,22,199,23,201,1,247,22,23,249,22,3,89,
+162,8,44,36,49,9,223,2,33,33,196,248,22,171,11,249,22,146,11,23,196,
 1,247,22,23,87,94,250,80,159,38,39,36,2,6,196,197,251,80,159,39,41,
 36,2,6,32,0,89,162,8,44,36,44,9,222,33,35,197,198,32,37,89,162,
 43,41,58,65,99,108,111,111,112,222,33,38,28,248,22,75,23,199,2,87,94,
-23,198,1,248,23,196,1,251,22,146,7,2,23,23,199,1,28,248,22,75,23,
-203,2,87,94,23,202,1,23,201,1,250,22,1,22,165,13,23,204,1,23,205,
-1,23,198,1,27,249,22,165,13,248,22,68,23,202,2,23,199,2,28,248,22,
-160,13,23,194,2,27,250,22,1,22,165,13,23,197,1,23,202,2,28,248,22,
-160,13,23,194,2,192,87,94,23,193,1,27,248,22,69,23,202,1,28,248,22,
-75,23,194,2,87,94,23,193,1,248,23,199,1,251,22,146,7,2,23,23,202,
-1,28,248,22,75,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,165,
-13,23,207,1,23,208,1,23,201,1,27,249,22,165,13,248,22,68,23,197,2,
-23,202,2,28,248,22,160,13,23,194,2,27,250,22,1,22,165,13,23,197,1,
-204,28,248,22,160,13,193,192,253,2,37,203,204,205,206,23,15,248,22,69,201,
+23,198,1,248,23,196,1,251,22,152,7,2,23,23,199,1,28,248,22,75,23,
+203,2,87,94,23,202,1,23,201,1,250,22,1,22,171,13,23,204,1,23,205,
+1,23,198,1,27,249,22,171,13,248,22,68,23,202,2,23,199,2,28,248,22,
+166,13,23,194,2,27,250,22,1,22,171,13,23,197,1,23,202,2,28,248,22,
+166,13,23,194,2,192,87,94,23,193,1,27,248,22,69,23,202,1,28,248,22,
+75,23,194,2,87,94,23,193,1,248,23,199,1,251,22,152,7,2,23,23,202,
+1,28,248,22,75,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,171,
+13,23,207,1,23,208,1,23,201,1,27,249,22,171,13,248,22,68,23,197,2,
+23,202,2,28,248,22,166,13,23,194,2,27,250,22,1,22,171,13,23,197,1,
+204,28,248,22,166,13,193,192,253,2,37,203,204,205,206,23,15,248,22,69,201,
 253,2,37,202,203,204,205,206,248,22,69,200,87,94,23,193,1,27,248,22,69,
 23,201,1,28,248,22,75,23,194,2,87,94,23,193,1,248,23,198,1,251,22,
-146,7,2,23,23,201,1,28,248,22,75,23,205,2,87,94,23,204,1,23,203,
-1,250,22,1,22,165,13,23,206,1,23,207,1,23,200,1,27,249,22,165,13,
-248,22,68,23,197,2,23,201,2,28,248,22,160,13,23,194,2,27,250,22,1,
-22,165,13,23,197,1,203,28,248,22,160,13,193,192,253,2,37,202,203,204,205,
-206,248,22,69,201,253,2,37,201,202,203,204,205,248,22,69,200,27,247,22,189,
-13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,148,13,23,194,2,
-10,27,248,22,147,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248,
-22,162,6,23,195,2,27,248,22,169,13,23,196,2,28,23,193,2,192,87,94,
-23,193,1,248,22,170,13,23,196,2,11,12,252,22,135,9,23,200,2,2,24,
-35,23,198,2,23,199,2,28,28,248,22,162,6,23,195,2,10,248,22,150,7,
-23,195,2,87,94,23,194,1,12,252,22,135,9,23,200,2,2,25,36,23,198,
-2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,168,13,23,197,2,87,
-94,23,195,1,87,94,28,192,12,250,22,136,9,23,201,1,2,26,23,199,1,
-249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,148,
-13,23,196,2,10,27,248,22,147,13,23,197,2,28,23,193,2,192,87,94,23,
-193,1,28,248,22,162,6,23,197,2,27,248,22,169,13,23,198,2,28,23,193,
-2,192,87,94,23,193,1,248,22,170,13,23,198,2,11,12,252,22,135,9,2,
-9,2,24,35,23,200,2,23,201,2,28,28,248,22,162,6,23,197,2,10,248,
-22,150,7,23,197,2,12,252,22,135,9,2,9,2,25,36,23,200,2,23,201,
-2,91,159,38,11,90,161,38,35,11,248,22,168,13,23,199,2,87,94,23,195,
-1,87,94,28,192,12,250,22,136,9,2,9,2,26,23,201,2,249,22,7,194,
-195,27,249,22,157,13,250,22,141,14,0,20,35,114,120,35,34,40,63,58,91,
-46,93,91,94,46,93,42,124,41,36,34,248,22,153,13,23,201,1,28,248,22,
-162,6,23,203,2,249,22,174,7,23,204,1,8,63,23,202,1,28,248,22,148,
-13,23,199,2,248,22,149,13,23,199,1,87,94,23,198,1,247,22,150,13,28,
-248,22,147,13,194,249,22,165,13,195,194,192,91,159,37,11,90,161,37,35,11,
-87,95,28,28,248,22,148,13,23,196,2,10,27,248,22,147,13,23,197,2,28,
-23,193,2,192,87,94,23,193,1,28,248,22,162,6,23,197,2,27,248,22,169,
-13,23,198,2,28,23,193,2,192,87,94,23,193,1,248,22,170,13,23,198,2,
-11,12,252,22,135,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22,
-162,6,23,197,2,10,248,22,150,7,23,197,2,12,252,22,135,9,2,10,2,
-25,36,23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,168,13,
-23,199,2,87,94,23,195,1,87,94,28,192,12,250,22,136,9,2,10,2,26,
-23,201,2,249,22,7,194,195,27,249,22,157,13,249,22,160,7,250,22,142,14,
-0,9,35,114,120,35,34,91,46,93,34,248,22,153,13,23,203,1,6,1,1,
-95,28,248,22,162,6,23,202,2,249,22,174,7,23,203,1,8,63,23,201,1,
-28,248,22,148,13,23,199,2,248,22,149,13,23,199,1,87,94,23,198,1,247,
-22,150,13,28,248,22,147,13,194,249,22,165,13,195,194,192,249,247,22,129,5,
+152,7,2,23,23,201,1,28,248,22,75,23,205,2,87,94,23,204,1,23,203,
+1,250,22,1,22,171,13,23,206,1,23,207,1,23,200,1,27,249,22,171,13,
+248,22,68,23,197,2,23,201,2,28,248,22,166,13,23,194,2,27,250,22,1,
+22,171,13,23,197,1,203,28,248,22,166,13,193,192,253,2,37,202,203,204,205,
+206,248,22,69,201,253,2,37,201,202,203,204,205,248,22,69,200,27,247,22,131,
+14,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,154,13,23,194,2,
+10,27,248,22,153,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248,
+22,168,6,23,195,2,27,248,22,175,13,23,196,2,28,23,193,2,192,87,94,
+23,193,1,248,22,176,13,23,196,2,11,12,252,22,141,9,23,200,2,2,24,
+35,23,198,2,23,199,2,28,28,248,22,168,6,23,195,2,10,248,22,156,7,
+23,195,2,87,94,23,194,1,12,252,22,141,9,23,200,2,2,25,36,23,198,
+2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,174,13,23,197,2,87,
+94,23,195,1,87,94,28,192,12,250,22,142,9,23,201,1,2,26,23,199,1,
+249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,154,
+13,23,196,2,10,27,248,22,153,13,23,197,2,28,23,193,2,192,87,94,23,
+193,1,28,248,22,168,6,23,197,2,27,248,22,175,13,23,198,2,28,23,193,
+2,192,87,94,23,193,1,248,22,176,13,23,198,2,11,12,252,22,141,9,2,
+9,2,24,35,23,200,2,23,201,2,28,28,248,22,168,6,23,197,2,10,248,
+22,156,7,23,197,2,12,252,22,141,9,2,9,2,25,36,23,200,2,23,201,
+2,91,159,38,11,90,161,38,35,11,248,22,174,13,23,199,2,87,94,23,195,
+1,87,94,28,192,12,250,22,142,9,2,9,2,26,23,201,2,249,22,7,194,
+195,27,249,22,163,13,250,22,147,14,0,20,35,114,120,35,34,40,63,58,91,
+46,93,91,94,46,93,42,124,41,36,34,248,22,159,13,23,201,1,28,248,22,
+168,6,23,203,2,249,22,180,7,23,204,1,8,63,23,202,1,28,248,22,154,
+13,23,199,2,248,22,155,13,23,199,1,87,94,23,198,1,247,22,156,13,28,
+248,22,153,13,194,249,22,171,13,195,194,192,91,159,37,11,90,161,37,35,11,
+87,95,28,28,248,22,154,13,23,196,2,10,27,248,22,153,13,23,197,2,28,
+23,193,2,192,87,94,23,193,1,28,248,22,168,6,23,197,2,27,248,22,175,
+13,23,198,2,28,23,193,2,192,87,94,23,193,1,248,22,176,13,23,198,2,
+11,12,252,22,141,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22,
+168,6,23,197,2,10,248,22,156,7,23,197,2,12,252,22,141,9,2,10,2,
+25,36,23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,174,13,
+23,199,2,87,94,23,195,1,87,94,28,192,12,250,22,142,9,2,10,2,26,
+23,201,2,249,22,7,194,195,27,249,22,163,13,249,22,166,7,250,22,148,14,
+0,9,35,114,120,35,34,91,46,93,34,248,22,159,13,23,203,1,6,1,1,
+95,28,248,22,168,6,23,202,2,249,22,180,7,23,203,1,8,63,23,201,1,
+28,248,22,154,13,23,199,2,248,22,155,13,23,199,1,87,94,23,198,1,247,
+22,156,13,28,248,22,153,13,194,249,22,171,13,195,194,192,249,247,22,135,5,
 194,11,249,80,159,37,46,36,9,9,249,80,159,37,46,36,195,9,27,247,22,
-191,13,249,80,158,38,47,28,23,195,2,27,248,22,179,7,6,11,11,80,76,
+133,14,249,80,158,38,47,28,23,195,2,27,248,22,185,7,6,11,11,80,76,
 84,67,79,76,76,69,67,84,83,28,192,192,6,0,0,6,0,0,27,28,23,
-196,1,250,22,165,13,248,22,187,13,69,97,100,100,111,110,45,100,105,114,247,
-22,177,7,6,8,8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52,
-36,250,22,81,23,203,1,248,22,77,248,22,187,13,72,99,111,108,108,101,99,
+196,1,250,22,171,13,248,22,129,14,69,97,100,100,111,110,45,100,105,114,247,
+22,183,7,6,8,8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52,
+36,250,22,81,23,203,1,248,22,77,248,22,129,14,72,99,111,108,108,101,99,
 116,115,45,100,105,114,23,204,1,28,193,249,22,67,195,194,192,32,47,89,162,
-8,44,38,54,2,18,222,33,48,27,249,22,134,14,23,197,2,23,198,2,28,
+8,44,38,54,2,18,222,33,48,27,249,22,140,14,23,197,2,23,198,2,28,
 23,193,2,87,94,23,196,1,27,248,22,92,23,195,2,27,27,248,22,101,23,
-197,1,27,249,22,134,14,23,201,2,23,196,2,28,23,193,2,87,94,23,194,
+197,1,27,249,22,140,14,23,201,2,23,196,2,28,23,193,2,87,94,23,194,
 1,27,248,22,92,23,195,2,27,250,2,47,23,203,2,23,204,1,248,22,101,
-23,199,1,28,249,22,156,7,23,196,2,2,27,249,22,81,23,202,2,194,249,
-22,67,248,22,156,13,23,197,1,194,87,95,23,199,1,23,193,1,28,249,22,
-156,7,23,196,2,2,27,249,22,81,23,200,2,9,249,22,67,248,22,156,13,
-23,197,1,9,28,249,22,156,7,23,196,2,2,27,249,22,81,197,194,87,94,
-23,196,1,249,22,67,248,22,156,13,23,197,1,194,87,94,23,193,1,28,249,
-22,156,7,23,198,2,2,27,249,22,81,195,9,87,94,23,194,1,249,22,67,
-248,22,156,13,23,199,1,9,87,95,28,28,248,22,150,7,194,10,248,22,162,
-6,194,12,250,22,135,9,2,13,6,21,21,98,121,116,101,32,115,116,114,105,
+23,199,1,28,249,22,162,7,23,196,2,2,27,249,22,81,23,202,2,194,249,
+22,67,248,22,162,13,23,197,1,194,87,95,23,199,1,23,193,1,28,249,22,
+162,7,23,196,2,2,27,249,22,81,23,200,2,9,249,22,67,248,22,162,13,
+23,197,1,9,28,249,22,162,7,23,196,2,2,27,249,22,81,197,194,87,94,
+23,196,1,249,22,67,248,22,162,13,23,197,1,194,87,94,23,193,1,28,249,
+22,162,7,23,198,2,2,27,249,22,81,195,9,87,94,23,194,1,249,22,67,
+248,22,162,13,23,199,1,9,87,95,28,28,248,22,156,7,194,10,248,22,168,
+6,194,12,250,22,141,9,2,13,6,21,21,98,121,116,101,32,115,116,114,105,
 110,103,32,111,114,32,115,116,114,105,110,103,196,28,28,248,22,76,195,249,22,
-4,22,147,13,196,11,12,250,22,135,9,2,13,6,13,13,108,105,115,116,32,
-111,102,32,112,97,116,104,115,197,250,2,47,197,195,28,248,22,162,6,197,248,
-22,173,7,197,196,32,50,89,162,8,44,39,57,2,18,222,33,53,32,51,89,
+4,22,153,13,196,11,12,250,22,141,9,2,13,6,13,13,108,105,115,116,32,
+111,102,32,112,97,116,104,115,197,250,2,47,197,195,28,248,22,168,6,197,248,
+22,179,7,197,196,32,50,89,162,8,44,39,57,2,18,222,33,53,32,51,89,
 162,8,44,38,54,70,102,111,117,110,100,45,101,120,101,99,222,33,52,28,23,
-193,2,91,159,38,11,90,161,38,35,11,248,22,168,13,23,199,2,87,95,23,
-195,1,23,194,1,27,28,23,198,2,27,248,22,173,13,23,201,2,28,249,22,
-169,8,23,195,2,23,202,2,11,28,248,22,169,13,23,194,2,250,2,51,23,
-201,2,23,202,2,249,22,165,13,23,200,2,23,198,1,250,2,51,23,201,2,
+193,2,91,159,38,11,90,161,38,35,11,248,22,174,13,23,199,2,87,95,23,
+195,1,23,194,1,27,28,23,198,2,27,248,22,179,13,23,201,2,28,249,22,
+175,8,23,195,2,23,202,2,11,28,248,22,175,13,23,194,2,250,2,51,23,
+201,2,23,202,2,249,22,171,13,23,200,2,23,198,1,250,2,51,23,201,2,
 23,202,2,23,196,1,11,28,23,193,2,192,87,94,23,193,1,27,28,248,22,
-147,13,23,196,2,27,249,22,165,13,23,198,2,23,201,2,28,28,248,22,160,
-13,193,10,248,22,159,13,193,192,11,11,28,23,193,2,192,87,94,23,193,1,
-28,23,199,2,11,27,248,22,173,13,23,202,2,28,249,22,169,8,23,195,2,
-23,203,1,11,28,248,22,169,13,23,194,2,250,2,51,23,202,1,23,203,1,
-249,22,165,13,23,201,1,23,198,1,250,2,51,201,202,195,194,28,248,22,75,
-23,197,2,11,27,248,22,172,13,248,22,68,23,199,2,27,249,22,165,13,23,
-196,1,23,197,2,28,248,22,159,13,23,194,2,250,2,51,198,199,195,87,94,
+153,13,23,196,2,27,249,22,171,13,23,198,2,23,201,2,28,28,248,22,166,
+13,193,10,248,22,165,13,193,192,11,11,28,23,193,2,192,87,94,23,193,1,
+28,23,199,2,11,27,248,22,179,13,23,202,2,28,249,22,175,8,23,195,2,
+23,203,1,11,28,248,22,175,13,23,194,2,250,2,51,23,202,1,23,203,1,
+249,22,171,13,23,201,1,23,198,1,250,2,51,201,202,195,194,28,248,22,75,
+23,197,2,11,27,248,22,178,13,248,22,68,23,199,2,27,249,22,171,13,23,
+196,1,23,197,2,28,248,22,165,13,23,194,2,250,2,51,198,199,195,87,94,
 23,193,1,27,248,22,69,23,200,1,28,248,22,75,23,194,2,11,27,248,22,
-172,13,248,22,68,23,196,2,27,249,22,165,13,23,196,1,23,200,2,28,248,
-22,159,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1,27,248,22,69,
-23,197,1,28,248,22,75,23,194,2,11,27,248,22,172,13,248,22,68,195,27,
-249,22,165,13,23,196,1,202,28,248,22,159,13,193,250,2,51,204,205,195,251,
-2,50,204,205,206,248,22,69,199,87,95,28,27,248,22,147,13,23,196,2,28,
-23,193,2,192,87,94,23,193,1,28,248,22,162,6,23,196,2,27,248,22,169,
-13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,170,13,23,197,2,
-11,12,250,22,135,9,2,14,6,25,25,112,97,116,104,32,111,114,32,115,116,
+178,13,248,22,68,23,196,2,27,249,22,171,13,23,196,1,23,200,2,28,248,
+22,165,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1,27,248,22,69,
+23,197,1,28,248,22,75,23,194,2,11,27,248,22,178,13,248,22,68,195,27,
+249,22,171,13,23,196,1,202,28,248,22,165,13,193,250,2,51,204,205,195,251,
+2,50,204,205,206,248,22,69,199,87,95,28,27,248,22,153,13,23,196,2,28,
+23,193,2,192,87,94,23,193,1,28,248,22,168,6,23,196,2,27,248,22,175,
+13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,176,13,23,197,2,
+11,12,250,22,141,9,2,14,6,25,25,112,97,116,104,32,111,114,32,115,116,
 114,105,110,103,32,40,115,97,110,115,32,110,117,108,41,23,197,2,28,28,23,
-195,2,28,27,248,22,147,13,23,197,2,28,23,193,2,192,87,94,23,193,1,
-28,248,22,162,6,23,197,2,27,248,22,169,13,23,198,2,28,23,193,2,192,
-87,94,23,193,1,248,22,170,13,23,198,2,11,248,22,169,13,23,196,2,11,
-10,12,250,22,135,9,2,14,6,29,29,35,102,32,111,114,32,114,101,108,97,
+195,2,28,27,248,22,153,13,23,197,2,28,23,193,2,192,87,94,23,193,1,
+28,248,22,168,6,23,197,2,27,248,22,175,13,23,198,2,28,23,193,2,192,
+87,94,23,193,1,248,22,176,13,23,198,2,11,248,22,175,13,23,196,2,11,
+10,12,250,22,141,9,2,14,6,29,29,35,102,32,111,114,32,114,101,108,97,
 116,105,118,101,32,112,97,116,104,32,111,114,32,115,116,114,105,110,103,23,198,
-2,28,28,248,22,169,13,23,195,2,91,159,38,11,90,161,38,35,11,248,22,
-168,13,23,198,2,249,22,167,8,194,68,114,101,108,97,116,105,118,101,11,27,
-248,22,179,7,6,4,4,80,65,84,72,251,2,50,23,199,1,23,200,1,23,
-201,1,28,23,197,2,27,249,80,159,43,47,37,23,200,1,9,28,249,22,167,
-8,247,22,181,7,2,20,249,22,67,248,22,156,13,5,1,46,194,192,9,27,
-248,22,172,13,23,196,1,28,248,22,159,13,193,250,2,51,198,199,195,11,250,
+2,28,28,248,22,175,13,23,195,2,91,159,38,11,90,161,38,35,11,248,22,
+174,13,23,198,2,249,22,173,8,194,68,114,101,108,97,116,105,118,101,11,27,
+248,22,185,7,6,4,4,80,65,84,72,251,2,50,23,199,1,23,200,1,23,
+201,1,28,23,197,2,27,249,80,159,43,47,37,23,200,1,9,28,249,22,173,
+8,247,22,187,7,2,20,249,22,67,248,22,162,13,5,1,46,194,192,9,27,
+248,22,178,13,23,196,1,28,248,22,165,13,193,250,2,51,198,199,195,11,250,
 80,159,38,48,36,196,197,11,250,80,159,38,48,36,196,11,11,87,94,249,22,
-153,6,247,22,189,4,195,248,22,179,5,249,22,174,3,35,249,22,158,3,197,
+159,6,247,22,131,5,195,248,22,185,5,249,22,180,3,35,249,22,164,3,197,
 198,27,28,23,197,2,87,95,23,196,1,23,195,1,23,197,1,87,94,23,197,
-1,27,248,22,187,13,2,19,27,249,80,159,40,48,36,23,196,1,11,27,27,
-248,22,177,3,23,200,1,28,192,192,35,27,27,248,22,177,3,23,202,1,28,
-192,192,35,249,22,156,5,23,197,1,83,158,39,20,97,95,89,162,8,44,35,
-47,9,224,3,2,33,57,23,195,1,23,196,1,27,248,22,141,5,23,195,1,
+1,27,248,22,129,14,2,19,27,249,80,159,40,48,36,23,196,1,11,27,27,
+248,22,183,3,23,200,1,28,192,192,35,27,27,248,22,183,3,23,202,1,28,
+192,192,35,249,22,162,5,23,197,1,83,158,39,20,97,95,89,162,8,44,35,
+47,9,224,3,2,33,57,23,195,1,23,196,1,27,248,22,147,5,23,195,1,
 248,80,159,38,53,36,193,159,35,20,102,159,35,16,1,11,16,0,83,158,41,
 20,100,144,67,35,37,117,116,105,108,115,29,11,11,11,11,11,10,42,80,158,
 35,35,20,102,159,37,16,17,2,1,2,2,2,3,2,4,2,5,2,6,2,
@@ -316,7 +316,7 @@
 83,158,35,16,2,89,162,43,36,48,2,18,223,0,33,28,80,159,35,53,36,
 83,158,35,16,2,89,162,8,44,36,55,2,18,223,0,33,29,80,159,35,52,
 36,83,158,35,16,2,32,0,89,162,43,36,44,2,1,222,33,30,80,159,35,
-35,36,83,158,35,16,2,249,22,164,6,7,92,7,92,80,159,35,36,36,83,
+35,36,83,158,35,16,2,249,22,170,6,7,92,7,92,80,159,35,36,36,83,
 158,35,16,2,89,162,43,36,53,2,3,223,0,33,31,80,159,35,37,36,83,
 158,35,16,2,32,0,89,162,8,44,37,49,2,4,222,33,32,80,159,35,38,
 36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,5,222,33,34,80,159,
@@ -329,8 +329,8 @@
 11,222,33,43,80,159,35,45,36,83,158,35,16,2,83,158,38,20,96,96,2,
 12,89,162,43,35,43,9,223,0,33,44,89,162,43,36,44,9,223,0,33,45,
 89,162,43,37,54,9,223,0,33,46,80,159,35,46,36,83,158,35,16,2,27,
-248,22,130,14,248,22,173,7,27,28,249,22,167,8,247,22,181,7,2,20,6,
-1,1,59,6,1,1,58,250,22,146,7,6,14,14,40,91,94,126,97,93,42,
+248,22,136,14,248,22,179,7,27,28,249,22,173,8,247,22,187,7,2,20,6,
+1,1,59,6,1,1,58,250,22,152,7,6,14,14,40,91,94,126,97,93,42,
 41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,47,2,13,
 223,0,33,49,80,159,35,47,36,83,158,35,16,2,83,158,38,20,96,96,2,
 14,89,162,8,44,38,53,9,223,0,33,54,89,162,43,37,46,9,223,0,33,
@@ -341,7 +341,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 5006);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,51,8,0,0,0,1,0,0,6,0,19,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,52,8,0,0,0,1,0,0,6,0,19,0,
 34,0,48,0,62,0,76,0,118,0,0,0,38,1,0,0,65,113,117,111,116,
 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
@@ -360,7 +360,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 331);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,51,56,0,0,0,1,0,0,11,0,38,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,52,56,0,0,0,1,0,0,11,0,38,0,
 44,0,57,0,66,0,73,0,95,0,117,0,143,0,155,0,173,0,193,0,205,
 0,221,0,244,0,0,1,31,1,38,1,43,1,48,1,53,1,58,1,67,1,
 72,1,76,1,84,1,93,1,101,1,204,1,249,1,13,2,42,2,73,2,129,
@@ -383,48 +383,48 @@
 29,94,2,3,2,5,11,64,98,111,111,116,64,115,101,97,108,64,115,97,109,
 101,5,3,46,122,111,6,6,6,110,97,116,105,118,101,64,108,111,111,112,63,
 108,105,98,67,105,103,110,111,114,101,100,249,22,14,195,80,159,37,45,37,249,
-80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,167,8,23,197,2,80,
-158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,176,4,23,197,2,28,
-248,22,147,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,168,13,23,
+80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,173,8,23,197,2,80,
+158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,182,4,23,197,2,28,
+248,22,153,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,174,13,23,
 197,1,87,95,83,160,37,11,80,158,40,46,198,83,160,37,11,80,158,40,47,
-192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,130,5,28,192,
-192,247,22,188,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27,11,
-80,158,40,39,22,130,5,28,248,22,147,13,23,198,2,23,197,1,87,94,23,
-197,1,247,22,188,13,247,194,250,22,165,13,23,197,1,23,199,1,249,80,158,
-42,38,23,198,1,2,22,252,22,165,13,23,199,1,23,201,1,2,23,247,22,
-182,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87,94,23,194,1,27,
-250,22,182,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,
-67,195,194,11,27,252,22,165,13,23,200,1,23,202,1,2,23,247,22,182,7,
-249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,182,13,196,11,32,
+192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,136,5,28,192,
+192,247,22,130,14,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27,11,
+80,158,40,39,22,136,5,28,248,22,153,13,23,198,2,23,197,1,87,94,23,
+197,1,247,22,130,14,247,194,250,22,171,13,23,197,1,23,199,1,249,80,158,
+42,38,23,198,1,2,22,252,22,171,13,23,199,1,23,201,1,2,23,247,22,
+188,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87,94,23,194,1,27,
+250,22,188,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,
+67,195,194,11,27,252,22,171,13,23,200,1,23,202,1,2,23,247,22,188,7,
+249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,188,13,196,11,32,
 0,89,162,8,44,35,40,9,222,11,28,192,249,22,67,195,194,11,249,247,22,
-129,14,248,22,68,195,195,27,250,22,165,13,23,198,1,23,200,1,249,80,158,
-43,38,23,199,1,2,22,27,250,22,182,13,196,11,32,0,89,162,8,44,35,
-40,9,222,11,28,192,249,22,67,195,194,11,249,247,22,128,5,248,22,68,195,
-195,249,247,22,128,5,194,195,87,94,28,248,80,158,36,37,23,195,2,12,250,
-22,135,9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,
+135,14,248,22,68,195,195,27,250,22,171,13,23,198,1,23,200,1,249,80,158,
+43,38,23,199,1,2,22,27,250,22,188,13,196,11,32,0,89,162,8,44,35,
+40,9,222,11,28,192,249,22,67,195,194,11,249,247,22,134,5,248,22,68,195,
+195,249,247,22,134,5,194,195,87,94,28,248,80,158,36,37,23,195,2,12,250,
+22,141,9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,
 6,25,25,112,97,116,104,32,111,114,32,118,97,108,105,100,45,112,97,116,104,
 32,115,116,114,105,110,103,23,197,2,91,159,41,11,90,161,36,35,11,28,248,
-22,171,13,23,201,2,23,200,1,27,247,22,130,5,28,23,193,2,249,22,172,
-13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,168,13,23,194,2,87,
-94,23,196,1,90,161,36,39,11,28,249,22,167,8,23,196,2,68,114,101,108,
+22,177,13,23,201,2,23,200,1,27,247,22,136,5,28,23,193,2,249,22,178,
+13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,174,13,23,194,2,87,
+94,23,196,1,90,161,36,39,11,28,249,22,173,8,23,196,2,68,114,101,108,
 97,116,105,118,101,87,94,23,194,1,2,21,23,194,1,90,161,36,40,11,247,
-22,190,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,31,27,89,162,
+22,132,14,27,89,162,43,36,49,62,122,111,225,7,5,3,33,31,27,89,162,
 43,36,51,9,225,8,6,4,33,32,27,249,22,5,89,162,8,44,36,46,9,
 223,5,33,33,23,203,2,27,28,23,195,1,27,249,22,5,89,162,8,44,36,
 52,9,225,13,11,9,33,34,23,205,2,27,28,23,196,2,11,193,28,192,192,
-28,193,28,23,196,2,28,249,22,170,3,248,22,69,196,248,22,69,23,199,2,
+28,193,28,23,196,2,28,249,22,176,3,248,22,69,196,248,22,69,23,199,2,
 193,11,11,11,11,28,23,193,2,249,80,159,47,58,36,202,89,162,43,35,45,
 9,224,14,2,33,35,87,94,23,193,1,27,28,23,197,1,27,249,22,5,83,
 158,39,20,97,94,89,162,8,44,36,50,9,225,14,12,10,33,36,23,203,1,
-23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28,249,22,170,3,248,
+23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28,249,22,176,3,248,
 22,69,196,248,22,69,199,193,11,11,11,11,28,192,249,80,159,48,58,36,203,
 89,162,43,35,45,9,224,15,2,33,37,249,80,159,48,58,36,203,89,162,43,
 35,44,9,224,15,7,33,38,32,40,89,162,8,44,36,54,2,24,222,33,42,
 0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42,41,36,34,27,249,
-22,134,14,2,41,23,196,2,28,23,193,2,87,94,23,194,1,249,22,67,248,
-22,92,23,196,2,27,248,22,101,23,197,1,27,249,22,134,14,2,41,23,196,
+22,140,14,2,41,23,196,2,28,23,193,2,87,94,23,194,1,249,22,67,248,
+22,92,23,196,2,27,248,22,101,23,197,1,27,249,22,140,14,2,41,23,196,
 2,28,23,193,2,87,94,23,194,1,249,22,67,248,22,92,23,196,2,27,248,
-22,101,23,197,1,27,249,22,134,14,2,41,23,196,2,28,23,193,2,87,94,
+22,101,23,197,1,27,249,22,140,14,2,41,23,196,2,28,23,193,2,87,94,
 23,194,1,249,22,67,248,22,92,23,196,2,248,2,40,248,22,101,23,197,1,
 248,22,77,194,248,22,77,194,248,22,77,194,32,43,89,162,43,36,54,2,24,
 222,33,44,28,248,22,75,248,22,69,23,195,2,249,22,7,9,248,22,68,195,
@@ -434,95 +434,95 @@
 195,91,159,37,11,90,161,37,35,11,248,2,43,248,22,69,196,249,22,7,249,
 22,67,248,22,68,199,196,195,249,22,7,249,22,67,248,22,68,199,196,195,249,
 22,7,249,22,67,248,22,68,199,196,195,27,248,2,40,23,195,1,28,194,192,
-248,2,43,193,87,95,28,248,22,174,4,195,12,250,22,135,9,2,17,6,20,
+248,2,43,193,87,95,28,248,22,180,4,195,12,250,22,141,9,2,17,6,20,
 20,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,
 197,28,24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,141,
-2,80,159,41,42,37,248,22,154,14,247,22,129,12,11,28,23,193,2,192,87,
+2,80,159,41,42,37,248,22,160,14,247,22,135,12,11,28,23,193,2,192,87,
 94,23,193,1,27,247,22,125,87,94,250,22,139,2,80,159,42,42,37,248,22,
-154,14,247,22,129,12,195,192,250,22,139,2,195,198,66,97,116,116,97,99,104,
-251,211,197,198,199,10,28,192,250,22,134,9,11,196,195,248,22,132,9,194,28,
-249,22,168,6,194,6,1,1,46,2,21,28,249,22,168,6,194,6,2,2,46,
-46,62,117,112,192,28,249,22,169,8,248,22,69,23,200,2,23,197,1,28,249,
-22,167,8,248,22,68,23,200,2,23,196,1,251,22,132,9,2,17,6,26,26,
+160,14,247,22,135,12,195,192,250,22,139,2,195,198,66,97,116,116,97,99,104,
+251,211,197,198,199,10,28,192,250,22,140,9,11,196,195,248,22,138,9,194,28,
+249,22,174,6,194,6,1,1,46,2,21,28,249,22,174,6,194,6,2,2,46,
+46,62,117,112,192,28,249,22,175,8,248,22,69,23,200,2,23,197,1,28,249,
+22,173,8,248,22,68,23,200,2,23,196,1,251,22,138,9,2,17,6,26,26,
 99,121,99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116,32,126,
 101,58,32,126,101,23,200,1,249,22,2,22,69,248,22,82,249,22,67,23,206,
 1,23,202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,67,248,22,
-154,14,247,22,129,12,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,
-249,22,27,11,80,158,44,39,22,156,4,23,196,1,249,247,22,129,5,23,198,
-1,248,22,55,248,22,151,13,23,198,1,87,94,28,28,248,22,147,13,23,196,
-2,10,248,22,180,4,23,196,2,12,28,23,197,2,250,22,134,9,11,6,15,
+160,14,247,22,135,12,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,
+249,22,27,11,80,158,44,39,22,162,4,23,196,1,249,247,22,135,5,23,198,
+1,248,22,55,248,22,157,13,23,198,1,87,94,28,28,248,22,153,13,23,196,
+2,10,248,22,186,4,23,196,2,12,28,23,197,2,250,22,140,9,11,6,15,
 15,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,200,2,250,22,
-135,9,2,17,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,111,114,
-32,112,97,116,104,23,198,2,28,28,248,22,65,23,196,2,249,22,167,8,248,
-22,68,23,198,2,2,3,11,248,22,175,4,248,22,92,196,28,28,248,22,65,
-23,196,2,249,22,167,8,248,22,68,23,198,2,66,112,108,97,110,101,116,11,
+141,9,2,17,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,111,114,
+32,112,97,116,104,23,198,2,28,28,248,22,65,23,196,2,249,22,173,8,248,
+22,68,23,198,2,2,3,11,248,22,181,4,248,22,92,196,28,28,248,22,65,
+23,196,2,249,22,173,8,248,22,68,23,198,2,66,112,108,97,110,101,116,11,
 87,94,28,207,12,20,14,159,80,158,36,51,80,158,36,49,90,161,36,35,10,
-249,22,157,4,21,94,2,25,6,18,18,112,108,97,110,101,116,47,114,101,115,
+249,22,163,4,21,94,2,25,6,18,18,112,108,97,110,101,116,47,114,101,115,
 111,108,118,101,114,46,115,115,1,27,112,108,97,110,101,116,45,109,111,100,117,
 108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,12,252,212,199,200,
 201,202,80,158,41,49,87,94,23,193,1,27,89,162,8,44,36,45,79,115,104,
 111,119,45,99,111,108,108,101,99,116,105,111,110,45,101,114,114,223,5,33,48,
 27,28,248,22,53,23,198,2,27,250,22,141,2,80,159,42,43,37,249,22,67,
-23,203,2,247,22,189,13,11,28,23,193,2,192,87,94,23,193,1,91,159,37,
+23,203,2,247,22,131,14,11,28,23,193,2,192,87,94,23,193,1,91,159,37,
 11,90,161,37,35,11,249,80,159,43,48,36,248,22,58,23,203,2,11,27,251,
 80,158,46,52,2,17,23,202,1,28,248,22,75,23,199,2,23,199,2,248,22,
-68,23,199,2,28,248,22,75,23,199,2,9,248,22,69,23,199,2,249,22,165,
+68,23,199,2,28,248,22,75,23,199,2,9,248,22,69,23,199,2,249,22,171,
 13,23,195,1,28,248,22,75,23,197,1,87,94,23,197,1,6,7,7,109,97,
-105,110,46,115,115,249,22,185,6,23,199,1,6,3,3,46,115,115,28,248,22,
-162,6,23,198,2,87,94,23,194,1,27,248,80,159,40,59,36,23,200,2,27,
+105,110,46,115,115,249,22,191,6,23,199,1,6,3,3,46,115,115,28,248,22,
+168,6,23,198,2,87,94,23,194,1,27,248,80,159,40,59,36,23,200,2,27,
 250,22,141,2,80,159,43,43,37,249,22,67,23,204,2,23,199,2,11,28,23,
 193,2,192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,44,
-48,36,23,203,2,11,250,22,1,22,165,13,23,199,1,249,22,81,249,22,2,
+48,36,23,203,2,11,250,22,1,22,171,13,23,199,1,249,22,81,249,22,2,
 32,0,89,162,8,44,36,43,9,222,33,49,23,200,1,248,22,77,23,200,1,
-28,248,22,147,13,23,198,2,87,94,23,194,1,28,248,22,170,13,23,198,2,
+28,248,22,153,13,23,198,2,87,94,23,194,1,28,248,22,176,13,23,198,2,
 23,197,2,248,22,77,6,26,26,32,40,97,32,112,97,116,104,32,109,117,115,
-116,32,98,101,32,97,98,115,111,108,117,116,101,41,28,249,22,167,8,248,22,
+116,32,98,101,32,97,98,115,111,108,117,116,101,41,28,249,22,173,8,248,22,
 68,23,200,2,2,25,27,250,22,141,2,80,159,42,43,37,249,22,67,23,203,
-2,247,22,189,13,11,28,23,193,2,192,87,94,23,193,1,91,159,38,11,90,
+2,247,22,131,14,11,28,23,193,2,192,87,94,23,193,1,91,159,38,11,90,
 161,37,35,11,249,80,159,44,48,36,248,22,92,23,204,2,11,90,161,36,37,
-11,28,248,22,75,248,22,94,23,203,2,28,248,22,75,23,194,2,249,22,136,
+11,28,248,22,75,248,22,94,23,203,2,28,248,22,75,23,194,2,249,22,142,
 14,0,8,35,114,120,34,91,46,93,34,23,196,2,11,10,27,27,28,23,197,
 2,249,22,81,28,248,22,75,248,22,94,23,207,2,21,93,6,5,5,109,122,
 108,105,98,249,22,1,22,81,249,22,2,80,159,50,8,25,36,248,22,94,23,
 210,2,23,197,2,28,248,22,75,23,196,2,248,22,77,23,197,2,23,195,2,
 251,80,158,48,52,2,17,23,204,1,248,22,68,23,198,2,248,22,69,23,198,
-1,249,22,165,13,23,195,1,28,23,198,1,87,94,23,196,1,23,197,1,28,
+1,249,22,171,13,23,195,1,28,23,198,1,87,94,23,196,1,23,197,1,28,
 248,22,75,23,197,1,87,94,23,197,1,6,7,7,109,97,105,110,46,115,115,
-28,249,22,136,14,0,8,35,114,120,34,91,46,93,34,23,199,2,23,197,1,
-249,22,185,6,23,199,1,6,3,3,46,115,115,28,249,22,167,8,248,22,68,
-23,200,2,64,102,105,108,101,249,22,172,13,248,22,176,13,248,22,92,23,201,
-2,248,80,159,41,59,36,23,201,2,12,87,94,28,28,248,22,147,13,23,194,
-2,10,248,22,184,7,23,194,2,87,94,23,199,1,12,28,23,199,2,250,22,
-134,9,67,114,101,113,117,105,114,101,249,22,146,7,6,17,17,98,97,100,32,
+28,249,22,142,14,0,8,35,114,120,34,91,46,93,34,23,199,2,23,197,1,
+249,22,191,6,23,199,1,6,3,3,46,115,115,28,249,22,173,8,248,22,68,
+23,200,2,64,102,105,108,101,249,22,178,13,248,22,182,13,248,22,92,23,201,
+2,248,80,159,41,59,36,23,201,2,12,87,94,28,28,248,22,153,13,23,194,
+2,10,248,22,190,7,23,194,2,87,94,23,199,1,12,28,23,199,2,250,22,
+140,9,67,114,101,113,117,105,114,101,249,22,152,7,6,17,17,98,97,100,32,
 109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,68,23,
-199,2,6,0,0,23,202,1,87,94,23,199,1,250,22,135,9,2,17,249,22,
-146,7,6,13,13,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,
-2,248,22,68,23,199,2,6,0,0,23,200,2,27,28,248,22,184,7,23,195,
-2,249,22,189,7,23,196,2,35,249,22,174,13,248,22,175,13,23,197,2,11,
-27,28,248,22,184,7,23,196,2,249,22,189,7,23,197,2,36,248,80,158,41,
-53,23,195,2,91,159,38,11,90,161,38,35,11,28,248,22,184,7,23,199,2,
-250,22,7,2,26,249,22,189,7,23,203,2,37,2,26,248,22,168,13,23,198,
-2,87,95,23,195,1,23,193,1,27,28,248,22,184,7,23,200,2,249,22,189,
-7,23,201,2,38,249,80,158,46,54,23,197,2,5,0,27,28,248,22,184,7,
-23,201,2,249,22,189,7,23,202,2,39,248,22,175,4,23,200,2,27,27,250,
-22,141,2,80,159,50,42,37,248,22,154,14,247,22,129,12,11,28,23,193,2,
+199,2,6,0,0,23,202,1,87,94,23,199,1,250,22,141,9,2,17,249,22,
+152,7,6,13,13,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,
+2,248,22,68,23,199,2,6,0,0,23,200,2,27,28,248,22,190,7,23,195,
+2,249,22,131,8,23,196,2,35,249,22,180,13,248,22,181,13,23,197,2,11,
+27,28,248,22,190,7,23,196,2,249,22,131,8,23,197,2,36,248,80,158,41,
+53,23,195,2,91,159,38,11,90,161,38,35,11,28,248,22,190,7,23,199,2,
+250,22,7,2,26,249,22,131,8,23,203,2,37,2,26,248,22,174,13,23,198,
+2,87,95,23,195,1,23,193,1,27,28,248,22,190,7,23,200,2,249,22,131,
+8,23,201,2,38,249,80,158,46,54,23,197,2,5,0,27,28,248,22,190,7,
+23,201,2,249,22,131,8,23,202,2,39,248,22,181,4,23,200,2,27,27,250,
+22,141,2,80,159,50,42,37,248,22,160,14,247,22,135,12,11,28,23,193,2,
 192,87,94,23,193,1,27,247,22,125,87,94,250,22,139,2,80,159,51,42,37,
-248,22,154,14,247,22,129,12,195,192,87,95,28,23,208,1,27,250,22,141,2,
+248,22,160,14,247,22,135,12,195,192,87,95,28,23,208,1,27,250,22,141,2,
 23,197,2,197,11,28,23,193,1,12,87,95,27,27,28,248,22,17,80,159,50,
 45,37,80,159,49,45,37,247,22,19,250,22,25,248,22,23,23,197,2,80,159,
-52,44,37,23,196,1,27,248,22,154,14,247,22,129,12,249,22,3,83,158,39,
+52,44,37,23,196,1,27,248,22,160,14,247,22,135,12,249,22,3,83,158,39,
 20,97,94,89,162,8,44,36,54,9,226,12,11,2,3,33,50,23,195,1,23,
 196,1,248,28,248,22,17,80,159,49,45,37,32,0,89,162,43,36,41,9,222,
 33,51,80,159,48,8,26,36,89,162,43,35,50,9,227,13,9,8,4,3,33,
-52,250,22,139,2,23,197,1,197,10,12,28,28,248,22,184,7,23,202,1,11,
-27,248,22,162,6,23,207,2,28,192,192,27,248,22,53,23,208,2,28,192,192,
-28,248,22,65,23,208,2,249,22,167,8,248,22,68,23,210,2,2,25,11,250,
-22,139,2,80,159,49,43,37,28,248,22,162,6,23,209,2,249,22,67,23,210,
+52,250,22,139,2,23,197,1,197,10,12,28,28,248,22,190,7,23,202,1,11,
+27,248,22,168,6,23,207,2,28,192,192,27,248,22,53,23,208,2,28,192,192,
+28,248,22,65,23,208,2,249,22,173,8,248,22,68,23,210,2,2,25,11,250,
+22,139,2,80,159,49,43,37,28,248,22,168,6,23,209,2,249,22,67,23,210,
 1,248,80,159,52,59,36,23,212,1,87,94,23,209,1,249,22,67,23,210,1,
-247,22,189,13,252,22,186,7,23,208,1,23,207,1,23,205,1,23,203,1,201,
+247,22,131,14,252,22,128,8,23,208,1,23,207,1,23,205,1,23,203,1,201,
 12,193,87,96,83,160,37,11,80,158,35,49,248,80,158,36,57,249,22,27,11,
-80,158,38,51,248,22,155,4,80,159,36,50,37,248,22,129,5,80,159,36,36,
-36,248,22,184,12,80,159,36,41,36,83,160,37,11,80,158,35,49,248,80,158,
+80,158,38,51,248,22,161,4,80,159,36,50,37,248,22,135,5,80,159,36,36,
+36,248,22,190,12,80,159,36,41,36,83,160,37,11,80,158,35,49,248,80,158,
 36,57,249,22,27,11,80,158,38,51,159,35,20,102,159,35,16,1,11,16,0,
 83,158,41,20,100,144,66,35,37,98,111,111,116,29,11,11,11,11,11,10,37,
 80,158,35,35,20,102,159,39,16,23,2,1,2,2,30,2,4,72,112,97,116,
@@ -543,7 +543,7 @@
 0,33,28,80,159,35,8,25,36,83,158,35,16,2,89,162,43,36,48,67,103,
 101,116,45,100,105,114,223,0,33,29,80,159,35,59,36,83,158,35,16,2,89,
 162,43,37,48,68,119,105,116,104,45,100,105,114,223,0,33,30,80,159,35,58,
-36,83,158,35,16,2,248,22,181,7,69,115,111,45,115,117,102,102,105,120,80,
+36,83,158,35,16,2,248,22,187,7,69,115,111,45,115,117,102,102,105,120,80,
 159,35,35,36,83,158,35,16,2,89,162,43,37,59,2,2,223,0,33,39,80,
 159,35,36,36,83,158,35,16,2,32,0,89,162,8,44,36,41,2,8,222,192,
 80,159,35,41,36,83,158,35,16,2,247,22,128,2,80,159,35,42,36,83,158,
diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c
index 1880d9773b..3eb280393e 100644
--- a/src/mzscheme/src/jit.c
+++ b/src/mzscheme/src/jit.c
@@ -88,6 +88,8 @@ END_XFORM_ARITH;
 #define WORDS_TO_BYTES(x) ((x) << JIT_LOG_WORD_SIZE)
 #define MAX_TRY_SHIFT 30
 
+#define JIT_LOG_DOUBLE_SIZE 3
+
 /* a mzchar is an int: */
 #define LOG_MZCHAR_SIZE 2
 
@@ -144,6 +146,7 @@ static void *bad_vector_length_code;
 static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *vector_set_check_index_code;
 static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code;
 static void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code;
+static void *flvector_ref_check_index_code, *flvector_set_check_index_code;
 static void *syntax_e_code;
 void *scheme_on_demand_jit_code;
 static void *on_demand_jit_arity_code;
@@ -3248,7 +3251,9 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
 
   rator = (alt_rands ? alt_rands[0] : app->args[0]);
 
-  if (SCHEME_PRIMP(rator)) {
+  if (no_call == 2) {
+    direct_prim = 1;
+  } else if (SCHEME_PRIMP(rator)) {
     if ((num_rands >= ((Scheme_Primitive_Proc *)rator)->mina)
 	&& ((num_rands <= ((Scheme_Primitive_Proc *)rator)->mu.maxa)
 	    || (((Scheme_Primitive_Proc *)rator)->mina < 0))
@@ -3594,6 +3599,7 @@ static int is_unboxable_op(Scheme_Object *obj, int flag)
   if (IS_NAMED_PRIM(obj, "unsafe-flabs")) return 1;
   if (IS_NAMED_PRIM(obj, "unsafe-fx->fl")) return 1;
   if (IS_NAMED_PRIM(obj, "unsafe-f64vector-ref")) return 1;
+  if (IS_NAMED_PRIM(obj, "unsafe-flvector-ref")) return 1;
 
   return 0;
 }
@@ -5870,7 +5876,8 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app,
   return 1;
 }
 
-static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int base_offset, int unsafe)
+static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int base_offset, 
+                              int for_fl, int unsafe)
 /* if int_ready, JIT_R1 has num index (for safe mode) and JIT_V1 has pre-computed offset,
    otherwise JIT_R1 has fixnum index */
 {
@@ -5887,9 +5894,15 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
       jit_ori_l(JIT_R1, JIT_R1, 0x1);
     }
     if (set) {
-      (void)jit_calli(vector_set_check_index_code);
+      if (!for_fl)
+        (void)jit_calli(vector_set_check_index_code);
+      else
+        (void)jit_calli(flvector_set_check_index_code);
     } else {
-      (void)jit_calli(vector_ref_check_index_code);
+      if (!for_fl)
+        (void)jit_calli(vector_ref_check_index_code);
+      else
+        (void)jit_calli(flvector_ref_check_index_code);
     }
     /* doesn't return */
     CHECK_LIMIT();
@@ -5899,8 +5912,13 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
     if (!int_ready)
       (void)jit_bmci_ul(reffail, JIT_R1, 0x1);
     jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
-    (void)jit_bnei_i(reffail, JIT_R2, scheme_vector_type);
-    jit_ldxi_i(JIT_R2, JIT_R0, (int)&SCHEME_VEC_SIZE(0x0));
+    if (!for_fl) {
+      (void)jit_bnei_i(reffail, JIT_R2, scheme_vector_type);
+      jit_ldxi_i(JIT_R2, JIT_R0, (int)&SCHEME_VEC_SIZE(0x0));
+    } else {
+      (void)jit_bnei_i(reffail, JIT_R2, scheme_flvector_type);
+      jit_ldxi_l(JIT_R2, JIT_R0, (int)&SCHEME_FLVEC_SIZE(0x0));
+    }
     if (!int_ready) {
       jit_rshi_ul(JIT_V1, JIT_R1, 1);
       (void)jit_bler_ul(reffail, JIT_R2, JIT_V1);
@@ -5908,6 +5926,15 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
       (void)jit_bler_ul(reffail, JIT_R2, JIT_R1);
     }
     CHECK_LIMIT();
+
+    if (for_fl && set) {
+      jit_ldr_p(JIT_R2, JIT_RUNSTACK);
+      (void)jit_bmsi_ul(reffail, JIT_R2, 0x1);
+      jit_ldxi_s(JIT_R2, JIT_R2, &((Scheme_Object *)0x0)->type);
+      (void)jit_bnei_i(reffail, JIT_R2, scheme_double_type);
+      CHECK_LIMIT();
+    }
+
     __END_TINY_JUMPS__(1);
   } else {
     if (!int_ready)
@@ -5915,15 +5942,28 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
   }
 
   if (!int_ready) {
-    jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
+    if (!for_fl)
+      jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
+    else
+      jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_DOUBLE_SIZE);
     jit_addi_p(JIT_V1, JIT_V1, base_offset);
   }
   if (set) {
     jit_ldr_p(JIT_R2, JIT_RUNSTACK);
-    jit_stxr_p(JIT_V1, JIT_R0, JIT_R2);
+    if (!for_fl) {
+      jit_stxr_p(JIT_V1, JIT_R0, JIT_R2);
+    } else {
+      jit_ldxi_d_fppush(JIT_FPR0, JIT_R2, &((Scheme_Double *)0x0)->double_val);  
+      jit_stxr_d_fppop(JIT_V1, JIT_R0, JIT_FPR0);
+    }
     (void)jit_movi_p(JIT_R0, scheme_void);
   } else {
-    jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1);
+    if (!for_fl) {
+      jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1);
+    } else {
+      jit_ldxr_d_fppush(JIT_FPR0, JIT_R0, JIT_V1);
+      generate_alloc_double(jitter);
+    }
   }
 
   return 1;
@@ -6166,7 +6206,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
 	       || IS_NAMED_PRIM(rator, "string-ref")
                || IS_NAMED_PRIM(rator, "unsafe-string-ref")
 	       || IS_NAMED_PRIM(rator, "bytes-ref")
-	       || IS_NAMED_PRIM(rator, "unsafe-bytes-ref")) {
+	       || IS_NAMED_PRIM(rator, "unsafe-bytes-ref")
+	       || IS_NAMED_PRIM(rator, "flvector-ref")) {
       int simple;
       int which, unsafe = 0, base_offset = ((int)&SCHEME_VEC_ELS(0x0));
 
@@ -6175,6 +6216,9 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
       else if (IS_NAMED_PRIM(rator, "unsafe-vector-ref")) {
 	which = 0;
         unsafe = 1;
+      } else if (IS_NAMED_PRIM(rator, "flvector-ref")) {
+	which = 3;
+        base_offset = ((int)&SCHEME_FLVEC_ELS(0x0));
       } else if (IS_NAMED_PRIM(rator, "unsafe-struct-ref")) {
 	which = 0;
         unsafe = 1;
@@ -6204,7 +6248,11 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
 
         if (!which) {
           /* vector-ref is relatively simple and worth inlining */
-          generate_vector_op(jitter, 0, 0, base_offset, unsafe);
+          generate_vector_op(jitter, 0, 0, base_offset, 0, unsafe);
+          CHECK_LIMIT();
+	} else if (which == 3) {
+          /* flvector-ref is relatively simple and worth inlining */
+          generate_vector_op(jitter, 0, 0, base_offset, 1, unsafe);
           CHECK_LIMIT();
 	} else if (which == 1) {
           if (unsafe) {
@@ -6247,12 +6295,18 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
           (void)jit_movi_p(JIT_R1, offset);
 	if (!which)
 	  offset = base_offset + WORDS_TO_BYTES(offset);
+	else if (which == 3)
+	  offset = base_offset + (offset * sizeof(double));
 	else if (which == 1)
 	  offset = offset << LOG_MZCHAR_SIZE;
 	jit_movi_l(JIT_V1, offset);
 	if (!which) {
           /* vector-ref is relatively simple and worth inlining */
-          generate_vector_op(jitter, 0, 1, base_offset, unsafe);
+          generate_vector_op(jitter, 0, 1, base_offset, 0, unsafe);
+          CHECK_LIMIT();
+	} else if (which == 3) {
+          /* flvector-ref is relatively simple and worth inlining */
+          generate_vector_op(jitter, 0, 1, base_offset, 1, unsafe);
           CHECK_LIMIT();
 	} else if (which == 1) {
           if (unsafe) {
@@ -6281,18 +6335,27 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
       }
 
       return 1;
-    } else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-ref")) {
+    } else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-ref")
+               || IS_NAMED_PRIM(rator, "unsafe-flvector-ref")) {
       int fpr0, unbox = jitter->unbox;
+      int is_f64;
 
+      is_f64 = IS_NAMED_PRIM(rator, "unsafe-f64vector-ref");
+      
       jitter->unbox = 0; /* no unboxing of vector and index arguments */
       generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
       jitter->unbox = unbox;
       CHECK_LIMIT();
 
-      jit_ldxi_p(JIT_R0, JIT_R0, (long)&(((Scheme_Structure *)0x0)->slots[0]));
-      jit_ldxi_p(JIT_R0, JIT_R0, (long)&SCHEME_CPTR_VAL(0x0));
+      if (is_f64) {
+        jit_ldxi_p(JIT_R0, JIT_R0, (long)&(((Scheme_Structure *)0x0)->slots[0]));
+        jit_ldxi_p(JIT_R0, JIT_R0, (long)&SCHEME_CPTR_VAL(0x0));
+      }
       jit_rshi_ul(JIT_R1, JIT_R1, 1);
-      jit_lshi_ul(JIT_R1, JIT_R1, 3); /* 3 = log(sizeof(double)) */
+      jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_DOUBLE_SIZE);
+      if (!is_f64) {
+        jit_addi_ul(JIT_R1, JIT_R1, (int)(&SCHEME_FLVEC_ELS(0x0)));
+      }
 
       if (jitter->unbox)
         fpr0 = JIT_FPR(jitter->unbox_depth);
@@ -6485,6 +6548,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
   } else if (!for_branch) {
     if (IS_NAMED_PRIM(rator, "vector-set!")
         || IS_NAMED_PRIM(rator, "unsafe-vector-set!")
+        || IS_NAMED_PRIM(rator, "flvector-set!")
         || IS_NAMED_PRIM(rator, "unsafe-struct-set!")
 	|| IS_NAMED_PRIM(rator, "string-set!")
 	|| IS_NAMED_PRIM(rator, "unsafe-string-set!")
@@ -6499,6 +6563,9 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
       else if (IS_NAMED_PRIM(rator, "unsafe-vector-set!")) {
         which = 0;
         unsafe = 1;
+      } else if (IS_NAMED_PRIM(rator, "flvector-set!")) {
+	which = 3;
+        base_offset = ((int)&SCHEME_FLVEC_ELS(0x0));
       } else if (IS_NAMED_PRIM(rator, "unsafe-struct-set!")) {
         which = 0;
         unsafe = 1;
@@ -6573,7 +6640,11 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
       if (!simple) {
 	if (!which) {
           /* vector-set! is relatively simple and worth inlining */
-          generate_vector_op(jitter, 1, 0, base_offset, unsafe);
+          generate_vector_op(jitter, 1, 0, base_offset, 0, unsafe);
+          CHECK_LIMIT();
+	} else if (which == 3) {
+          /* flvector-set! is relatively simple and worth inlining */
+          generate_vector_op(jitter, 1, 0, base_offset, 1, unsafe);
           CHECK_LIMIT();
 	} else if (which == 1) {
           if (unsafe) {
@@ -6605,12 +6676,18 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
 	(void)jit_movi_p(JIT_R1, offset);
 	if (!which)
 	  offset = base_offset + WORDS_TO_BYTES(offset);
+	else if (which == 3)
+	  offset = base_offset + (offset * sizeof(double));
 	else if (which == 1)
 	  offset = offset << LOG_MZCHAR_SIZE;
 	jit_movi_l(JIT_V1, offset);
 	if (!which) {
           /* vector-set! is relatively simple and worth inlining */
-          generate_vector_op(jitter, 1, 1, base_offset, unsafe);
+          generate_vector_op(jitter, 1, 1, base_offset, 0, unsafe);
+          CHECK_LIMIT();
+	} else if (which == 3) {
+          /* flvector-set! is relatively simple and worth inlining */
+          generate_vector_op(jitter, 1, 1, base_offset, 1, unsafe);
           CHECK_LIMIT();
 	} else if (which == 1) {
           if (unsafe) {
@@ -6641,7 +6718,10 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
       mz_runstack_unskipped(jitter, 3 - pushed);
 
       return 1;
-    } else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-set!")) {
+    } else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-set!")
+               || IS_NAMED_PRIM(rator, "unsafe-flvector-set!")) {
+      int is_f64;
+      is_f64 = IS_NAMED_PRIM(rator, "unsafe-f64vector-set!");
       if (can_unbox(app->args[3], 5, JIT_FPR_NUM-1)) {
         int got_two;
         if (is_constant_and_avoids_r1(app->args[1])
@@ -6684,10 +6764,15 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
       }
       CHECK_LIMIT();
 
-      jit_ldxi_p(JIT_R0, JIT_R0, (long)&(((Scheme_Structure *)0x0)->slots[0]));
-      jit_ldxi_p(JIT_R0, JIT_R0, (long)&SCHEME_CPTR_VAL(0x0));
+      if (is_f64) {
+        jit_ldxi_p(JIT_R0, JIT_R0, (long)&(((Scheme_Structure *)0x0)->slots[0]));
+        jit_ldxi_p(JIT_R0, JIT_R0, (long)&SCHEME_CPTR_VAL(0x0));
+      }
       jit_rshi_ul(JIT_R1, JIT_R1, 1);
-      jit_lshi_ul(JIT_R1, JIT_R1, 3); /* 3 = log(sizeof(double)) */
+      jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_DOUBLE_SIZE);
+      if (!is_f64) {
+        jit_addi_ul(JIT_R1, JIT_R1, (int)(&SCHEME_FLVEC_ELS(0x0)));
+      }
       jit_stxr_d_fppop(JIT_R1, JIT_R0, JIT_FPR0);
       CHECK_LIMIT();
       
@@ -9150,6 +9235,40 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
     }
   }
 
+  /* *** {flvector}_{ref,set}_check_index_code *** */
+  /* Same calling convention as for vector ops.    */
+  for (i = 0; i < 2; i++) {
+    if (!i) {
+      flvector_ref_check_index_code = jit_get_ip().ptr;
+    } else {
+      flvector_set_check_index_code = jit_get_ip().ptr;
+    }
+
+    mz_prolog(JIT_R2);
+
+    jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
+    CHECK_RUNSTACK_OVERFLOW();
+    jit_str_p(JIT_RUNSTACK, JIT_R0);
+    jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1);
+    if (!i) {
+      jit_movi_i(JIT_R1, 2);
+    } else {
+      /* In set mode, value was already on run stack */
+      jit_movi_i(JIT_R1, 3);
+    }
+    JIT_UPDATE_THREAD_RSPTR();
+    jit_prepare(2);
+    jit_pusharg_p(JIT_RUNSTACK);
+    jit_pusharg_i(JIT_R1);
+    if (!i) {
+      (void)mz_finish(ts_scheme_checked_flvector_ref);
+    } else {
+      (void)mz_finish(ts_scheme_checked_flvector_set);
+    }
+    /* does not return */
+  }
+
+
   /* *** syntax_ecode *** */
   /* R0 is (potential) syntax object */
   {
diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c
index a43e0e5827..819c2ad0cf 100644
--- a/src/mzscheme/src/jit_ts.c
+++ b/src/mzscheme/src/jit_ts.c
@@ -70,6 +70,8 @@ define_ts_iS_s(scheme_checked_string_ref, FSRC_OTHER)
 define_ts_iS_s(scheme_checked_string_set, FSRC_OTHER)
 define_ts_iS_s(scheme_checked_byte_string_ref, FSRC_OTHER)
 define_ts_iS_s(scheme_checked_byte_string_set, FSRC_OTHER)
+define_ts_iS_s(scheme_checked_flvector_ref, FSRC_OTHER)
+define_ts_iS_s(scheme_checked_flvector_set, FSRC_OTHER)
 define_ts_iS_s(scheme_checked_syntax_e, FSRC_OTHER)
 define_ts_iS_s(scheme_extract_checked_procedure, FSRC_OTHER)
 define_ts_S_s(apply_checked_fail, FSRC_OTHER)
@@ -130,6 +132,8 @@ define_ts_siS_v(wrong_argument_count, FSRC_OTHER)
 # define ts_scheme_checked_string_set scheme_checked_string_set
 # define ts_scheme_checked_byte_string_ref scheme_checked_byte_string_ref
 # define ts_scheme_checked_byte_string_set scheme_checked_byte_string_set
+# define ts_scheme_checked_flvector_ref scheme_checked_flvector_ref
+# define ts_scheme_checked_flvector_set scheme_checked_flvector_set
 # define ts_scheme_checked_syntax_e scheme_checked_syntax_e
 # define ts_scheme_extract_checked_procedure scheme_extract_checked_procedure
 # define ts_apply_checked_fail apply_checked_fail
diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c
index 4e97078bc5..a302d65f43 100644
--- a/src/mzscheme/src/mzmark.c
+++ b/src/mzscheme/src/mzmark.c
@@ -1449,6 +1449,34 @@ static int vector_obj_FIXUP(void *p) {
 #define vector_obj_IS_CONST_SIZE 0
 
 
+static int flvector_obj_SIZE(void *p) {
+  Scheme_Double_Vector *vec = (Scheme_Double_Vector *)p;
+
+  return
+  gcBYTES_TO_WORDS((sizeof(Scheme_Double_Vector) 
+		    + ((vec->size - 1) * sizeof(double))));
+}
+
+static int flvector_obj_MARK(void *p) {
+  Scheme_Double_Vector *vec = (Scheme_Double_Vector *)p;
+
+  return
+  gcBYTES_TO_WORDS((sizeof(Scheme_Double_Vector) 
+		    + ((vec->size - 1) * sizeof(double))));
+}
+
+static int flvector_obj_FIXUP(void *p) {
+  Scheme_Double_Vector *vec = (Scheme_Double_Vector *)p;
+
+  return
+  gcBYTES_TO_WORDS((sizeof(Scheme_Double_Vector) 
+		    + ((vec->size - 1) * sizeof(double))));
+}
+
+#define flvector_obj_IS_ATOMIC 1
+#define flvector_obj_IS_CONST_SIZE 0
+
+
 static int input_port_SIZE(void *p) {
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Input_Port));
diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c
index e850efbb0b..a16deaaff4 100644
--- a/src/mzscheme/src/mzmarksrc.c
+++ b/src/mzscheme/src/mzmarksrc.c
@@ -546,6 +546,15 @@ vector_obj {
 		    + ((vec->size - 1) * sizeof(Scheme_Object *))));
 }
 
+flvector_obj {
+  Scheme_Double_Vector *vec = (Scheme_Double_Vector *)p;
+
+ mark:
+ size:
+  gcBYTES_TO_WORDS((sizeof(Scheme_Double_Vector) 
+		    + ((vec->size - 1) * sizeof(double))));
+}
+
 input_port {
  mark:
   Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
diff --git a/src/mzscheme/src/number.c b/src/mzscheme/src/number.c
index af7445c20d..fd4b97f4db 100644
--- a/src/mzscheme/src/number.c
+++ b/src/mzscheme/src/number.c
@@ -98,6 +98,11 @@ static Scheme_Object *angle (int argc, Scheme_Object *argv[]);
 static Scheme_Object *int_sqrt (int argc, Scheme_Object *argv[]);
 static Scheme_Object *int_sqrt_rem (int argc, Scheme_Object *argv[]);
 
+static Scheme_Object *flvector (int argc, Scheme_Object *argv[]);
+static Scheme_Object *flvector_p (int argc, Scheme_Object *argv[]);
+static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[]);
+static Scheme_Object *flvector_length (int argc, Scheme_Object *argv[]);
+
 static Scheme_Object *fx_and (int argc, Scheme_Object *argv[]);
 static Scheme_Object *fx_or (int argc, Scheme_Object *argv[]);
 static Scheme_Object *fx_xor (int argc, Scheme_Object *argv[]);
@@ -108,6 +113,10 @@ static Scheme_Object *fx_to_fl (int argc, Scheme_Object *argv[]);
 static Scheme_Object *fl_ref (int argc, Scheme_Object *argv[]);
 static Scheme_Object *fl_set (int argc, Scheme_Object *argv[]);
 
+static Scheme_Object *unsafe_flvector_length (int argc, Scheme_Object *argv[]);
+static Scheme_Object *unsafe_flvector_ref (int argc, Scheme_Object *argv[]);
+static Scheme_Object *unsafe_flvector_set (int argc, Scheme_Object *argv[]);
+
 static double not_a_number_val;
 
 Scheme_Object *scheme_inf_object, *scheme_minus_inf_object, *scheme_nan_object;
@@ -284,7 +293,7 @@ scheme_init_number (Scheme_Env *env)
   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
   scheme_add_global_constant("exact-positive-integer?", p, env);
 
-  p = scheme_make_noncm_prim(fixnum_p, "fixnum?", 1, 1);
+  p = scheme_make_immed_prim(fixnum_p, "fixnum?", 1, 1);
   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
   scheme_add_global_constant("fixnum?", p, env);
 
@@ -496,6 +505,39 @@ scheme_init_number (Scheme_Env *env)
 						      "inexact->exact",
 						      1, 1, 1),
 			     env);
+
+  scheme_add_global_constant("flvector",
+                             scheme_make_prim_w_arity(flvector,
+                                                      "flvector",
+                                                      0, -1),
+			     env);
+  scheme_add_global_constant("flvector?",
+                             scheme_make_folding_prim(flvector_p,
+                                                      "flvector?",
+                                                      1, 1, 1),
+			     env);
+  scheme_add_global_constant("make-flvector",
+                             scheme_make_immed_prim(make_flvector,
+                                                    "make-flvector",
+                                                    1, 2),
+			     env);
+  scheme_add_global_constant("flvector-length",
+                             scheme_make_immed_prim(flvector_length,
+                                                    "flvector-length",
+                                                    1, 1),
+			     env);
+  p = scheme_make_immed_prim(scheme_checked_flvector_ref,
+                             "flvector-ref",
+                             2, 2);
+  if (scheme_can_inline_fp_op())
+    SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  scheme_add_global_constant("flvector-ref", p, env);
+
+  p = scheme_make_immed_prim(scheme_checked_flvector_set,
+                             "flvector-set!",
+                             3, 3);
+  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
+  scheme_add_global_constant("flvector-set!", p, env);
 }
 
 void scheme_init_unsafe_number(Scheme_Env *env)
@@ -531,19 +573,34 @@ void scheme_init_unsafe_number(Scheme_Env *env)
     SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
   scheme_add_global_constant("unsafe-fx->fl", p, env);
 
-  p = scheme_make_noncm_prim(fl_ref, "unsafe-f64vector-ref",
+  p = scheme_make_immed_prim(fl_ref, "unsafe-f64vector-ref",
                              2, 2);
   if (scheme_can_inline_fp_op())
     SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
   scheme_add_global_constant("unsafe-f64vector-ref", p, env);
   
-  p = scheme_make_noncm_prim(fl_set, "unsafe-f64vector-set!",
+  p = scheme_make_immed_prim(fl_set, "unsafe-f64vector-set!",
                              3, 3);
   if (scheme_can_inline_fp_op())
     SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
   scheme_add_global_constant("unsafe-f64vector-set!", p, env);  
-}
 
+  p = scheme_make_immed_prim(unsafe_flvector_length, "unsafe-flvector-length",
+                             1, 1);
+  /* SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; */
+  scheme_add_global_constant("unsafe-flvector-length", p, env);
+
+  p = scheme_make_immed_prim(unsafe_flvector_ref, "unsafe-flvector-ref",
+                             2, 2);
+  if (scheme_can_inline_fp_op())
+    SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  scheme_add_global_constant("unsafe-flvector-ref", p, env);
+
+  p = scheme_make_immed_prim(unsafe_flvector_set, "unsafe-flvector-set!",
+                             3, 3);
+  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
+  scheme_add_global_constant("unsafe-flvector-set!", p, env);
+}
 
 
 Scheme_Object *
@@ -2787,6 +2844,151 @@ long scheme_integer_length(Scheme_Object *n)
   return SCHEME_INT_VAL(r);
 }
 
+
+/************************************************************************/
+/*                             flvectors                               */
+/************************************************************************/
+
+static Scheme_Double_Vector *alloc_flvector(long size)
+{
+  Scheme_Double_Vector *vec;
+
+  vec = (Scheme_Double_Vector *)scheme_malloc_fail_ok(scheme_malloc_atomic_tagged, 
+                                                      sizeof(Scheme_Double_Vector) 
+                                                      + ((size - 1) * sizeof(double)));
+  vec->so.type = scheme_flvector_type;
+  vec->size = size;
+
+  return vec;
+}
+
+static Scheme_Object *flvector (int argc, Scheme_Object *argv[])
+{
+  int i;
+  Scheme_Double_Vector *vec;
+
+  for (i = 0; i < argc; i++) {
+    if (!SCHEME_FLOATP(argv[i])) {
+      scheme_wrong_type("flvector", "inexact real", i, argc, argv);
+      return NULL;
+    }
+  }
+
+  vec = alloc_flvector(argc);
+
+  for (i = 0; i < argc; i++) {
+    vec->els[i] = SCHEME_FLOAT_VAL(argv[i]);
+  }
+
+  return (Scheme_Object *)vec;
+}
+
+
+static Scheme_Object *flvector_p (int argc, Scheme_Object *argv[])
+{
+  if (SCHEME_FLVECTORP(argv[0]))
+    return scheme_true;
+  else
+    return scheme_false;
+}
+
+static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[])
+{
+  Scheme_Double_Vector *vec;
+  long size;
+
+  if (SCHEME_INTP(argv[0]))
+    size = SCHEME_INT_VAL(argv[0]);
+  else if (SCHEME_BIGNUMP(argv[0])) {
+    if (SCHEME_BIGPOS(argv[0])) {
+      scheme_raise_out_of_memory("make-flvector", NULL);
+      return NULL;
+    } else
+      size = -1;
+  } else
+    size = -1;
+
+  if (size < 0)
+    scheme_wrong_type("make-flvector", "exact non-negative integer", 0, argc, argv);
+
+  if (argc > 1) {
+    if (!SCHEME_FLOATP(argv[1]))
+      scheme_wrong_type("make-flvector", "inexact real", 1, argc, argv);
+  }
+
+  vec = alloc_flvector(size);
+
+  if (argc > 1) {
+    int i;
+    double d = SCHEME_FLOAT_VAL(argv[1]);
+    for (i = 0; i < size; i++) {
+      vec->els[i] = d;
+    }
+  }
+
+  return (Scheme_Object *)vec;
+}
+
+static Scheme_Object *flvector_length (int argc, Scheme_Object *argv[])
+{
+  if (!SCHEME_FLVECTORP(argv[0]))
+    scheme_wrong_type("flvector-length", "flvector", 0, argc, argv);
+
+  return scheme_make_integer(SCHEME_FLVEC_SIZE(argv[0]));
+}
+
+Scheme_Object *scheme_checked_flvector_ref (int argc, Scheme_Object *argv[])
+{
+  double d;
+  Scheme_Object *vec;
+  long len, pos;
+
+  vec = argv[0];
+  if (!SCHEME_FLVECTORP(vec))
+    scheme_wrong_type("flvector-ref", "flvector", 0, argc, argv);
+  
+  len = SCHEME_FLVEC_SIZE(vec);
+  pos = scheme_extract_index("flvector-ref", 1, argc, argv, len, 0);
+
+  if (pos >= len) {
+    scheme_bad_vec_index("flvector-ref", argv[1], 
+                         "flvector", vec,
+                         0, len);
+    return NULL;
+  }
+
+  d = SCHEME_FLVEC_ELS(vec)[pos];
+
+  return scheme_make_double(d);
+}
+
+Scheme_Object *scheme_checked_flvector_set (int argc, Scheme_Object *argv[])
+{
+  Scheme_Object *vec;
+  long len, pos;
+
+  vec = argv[0];
+  if (!SCHEME_FLVECTORP(vec))
+    scheme_wrong_type("flvector-set!", "flvector", 0, argc, argv);
+  
+  len = SCHEME_FLVEC_SIZE(vec);
+  pos = scheme_extract_index("flvector-set!", 1, argc, argv, len, 0);
+  
+  if (!SCHEME_FLOATP(argv[2]))
+    scheme_wrong_type("flvector-set!", "inexact real", 2, argc, argv);
+
+  if (pos >= len) {
+    scheme_bad_vec_index("flvector-set!", argv[1], 
+                         "flvector", vec,
+                         0, len);
+    return NULL;
+  }
+
+  SCHEME_FLVEC_ELS(vec)[pos] = SCHEME_FLOAT_VAL(argv[2]);
+
+  return scheme_void;
+}
+
 /************************************************************************/
 /*                               Unsafe                                 */
 /************************************************************************/
@@ -2848,3 +3050,29 @@ static Scheme_Object *fl_set (int argc, Scheme_Object *argv[])
   ((double *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])] = SCHEME_DBL_VAL(argv[2]);
   return scheme_void;
 }
+
+static Scheme_Object *unsafe_flvector_length (int argc, Scheme_Object *argv[])
+{
+  return scheme_make_integer(SCHEME_FLVEC_SIZE(argv[0]));
+}
+
+static Scheme_Object *unsafe_flvector_ref (int argc, Scheme_Object *argv[])
+{
+  long pos;
+  double d;
+
+  pos = SCHEME_INT_VAL(argv[1]);
+  d = SCHEME_FLVEC_ELS(argv[0])[pos];
+
+  return scheme_make_double(d);
+}
+
+static Scheme_Object *unsafe_flvector_set (int argc, Scheme_Object *argv[])
+{
+  long pos;
+
+  pos = SCHEME_INT_VAL(argv[1]);
+  SCHEME_FLVEC_ELS(argv[0])[pos] = SCHEME_FLOAT_VAL(argv[2]);
+
+  return scheme_void;
+}
diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h
index ab4f352503..26c15eb7ff 100644
--- a/src/mzscheme/src/schminc.h
+++ b/src/mzscheme/src/schminc.h
@@ -13,8 +13,8 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 959
-#define EXPECTED_UNSAFE_COUNT 49
+#define EXPECTED_PRIM_COUNT 965
+#define EXPECTED_UNSAFE_COUNT 52
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP
diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h
index 91d1b32c7e..1ca42a86e3 100644
--- a/src/mzscheme/src/schpriv.h
+++ b/src/mzscheme/src/schpriv.h
@@ -3192,6 +3192,12 @@ Scheme_Object *scheme_checked_byte_string_ref(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_checked_byte_string_set(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_vector_length(Scheme_Object *v);
+Scheme_Object *scheme_checked_flvector_ref(int argc, Scheme_Object **argv);
+Scheme_Object *scheme_checked_flvector_set(int argc, Scheme_Object **argv);
+
+void scheme_bad_vec_index(char *name, Scheme_Object *i, 
+                          const char *what, Scheme_Object *vec, 
+                          long bottom, long len);
 
 Scheme_Bucket_Table *scheme_make_weak_equal_table(void);
 
diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h
index 82a03ebd66..febb42eae0 100644
--- a/src/mzscheme/src/schvers.h
+++ b/src/mzscheme/src/schvers.h
@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.2.3.3"
+#define MZSCHEME_VERSION "4.2.3.4"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 2
 #define MZSCHEME_VERSION_Z 3
-#define MZSCHEME_VERSION_W 3
+#define MZSCHEME_VERSION_W 4
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
diff --git a/src/mzscheme/src/stypes.h b/src/mzscheme/src/stypes.h
index ea2d45731e..62ac0382b2 100644
--- a/src/mzscheme/src/stypes.h
+++ b/src/mzscheme/src/stypes.h
@@ -171,84 +171,85 @@ enum {
   scheme_noninline_proc_type,           /* 153 */
   scheme_prune_context_type,            /* 154 */
   scheme_future_type,                   /* 155 */
+  scheme_flvector_type,                 /* 156 */
 
 #ifdef MZTAG_REQUIRED
-  _scheme_last_normal_type_,            /* 156 */
+  _scheme_last_normal_type_,            /* 157 */
 
-  scheme_rt_weak_array,                 /* 157 */
+  scheme_rt_weak_array,                 /* 158 */
 
-  scheme_rt_comp_env,                   /* 158 */
-  scheme_rt_constant_binding,           /* 159 */
-  scheme_rt_resolve_info,               /* 160 */
-  scheme_rt_optimize_info,              /* 161 */
-  scheme_rt_compile_info,               /* 162 */
-  scheme_rt_cont_mark,                  /* 163 */
-  scheme_rt_saved_stack,                /* 164 */
-  scheme_rt_reply_item,                 /* 165 */
-  scheme_rt_closure_info,               /* 166 */
-  scheme_rt_overflow,                   /* 167 */
-  scheme_rt_overflow_jmp,               /* 168 */
-  scheme_rt_meta_cont,                  /* 169 */
-  scheme_rt_dyn_wind_cell,              /* 170 */
-  scheme_rt_dyn_wind_info,              /* 171 */
-  scheme_rt_dyn_wind,                   /* 172 */
-  scheme_rt_dup_check,                  /* 173 */
-  scheme_rt_thread_memory,              /* 174 */
-  scheme_rt_input_file,                 /* 175 */
-  scheme_rt_input_fd,                   /* 176 */
-  scheme_rt_oskit_console_input,        /* 177 */
-  scheme_rt_tested_input_file,          /* 178 */
-  scheme_rt_tested_output_file,         /* 179 */
-  scheme_rt_indexed_string,             /* 180 */
-  scheme_rt_output_file,                /* 181 */
-  scheme_rt_load_handler_data,          /* 182 */
-  scheme_rt_pipe,                       /* 183 */
-  scheme_rt_beos_process,               /* 184 */
-  scheme_rt_system_child,               /* 185 */
-  scheme_rt_tcp,                        /* 186 */
-  scheme_rt_write_data,                 /* 187 */
-  scheme_rt_tcp_select_info,            /* 188 */
-  scheme_rt_namespace_option,           /* 189 */
-  scheme_rt_param_data,                 /* 190 */
-  scheme_rt_will,                       /* 191 */
-  scheme_rt_struct_proc_info,           /* 192 */
-  scheme_rt_linker_name,                /* 193 */
-  scheme_rt_param_map,                  /* 194 */
-  scheme_rt_finalization,               /* 195 */
-  scheme_rt_finalizations,              /* 196 */
-  scheme_rt_cpp_object,                 /* 197 */
-  scheme_rt_cpp_array_object,           /* 198 */
-  scheme_rt_stack_object,               /* 199 */
-  scheme_rt_preallocated_object,        /* 200 */
-  scheme_thread_hop_type,               /* 201 */
-  scheme_rt_srcloc,                     /* 202 */
-  scheme_rt_evt,                        /* 203 */
-  scheme_rt_syncing,                    /* 204 */
-  scheme_rt_comp_prefix,                /* 205 */
-  scheme_rt_user_input,                 /* 206 */
-  scheme_rt_user_output,                /* 207 */
-  scheme_rt_compact_port,               /* 208 */
-  scheme_rt_read_special_dw,            /* 209 */
-  scheme_rt_regwork,                    /* 210 */
-  scheme_rt_buf_holder,                 /* 211 */
-  scheme_rt_parameterization,           /* 212 */
-  scheme_rt_print_params,               /* 213 */
-  scheme_rt_read_params,                /* 214 */
-  scheme_rt_native_code,                /* 215 */
-  scheme_rt_native_code_plus_case,      /* 216 */
-  scheme_rt_jitter_data,                /* 217 */
-  scheme_rt_module_exports,             /* 218 */
-  scheme_rt_delay_load_info,            /* 219 */
-  scheme_rt_marshal_info,               /* 220 */
-  scheme_rt_unmarshal_info,             /* 221 */
-  scheme_rt_runstack,                   /* 222 */
-  scheme_rt_sfs_info,                   /* 223 */
-  scheme_rt_validate_clearing,          /* 224 */
-  scheme_rt_rb_node,                    /* 225 */
+  scheme_rt_comp_env,                   /* 159 */
+  scheme_rt_constant_binding,           /* 160 */
+  scheme_rt_resolve_info,               /* 161 */
+  scheme_rt_optimize_info,              /* 162 */
+  scheme_rt_compile_info,               /* 163 */
+  scheme_rt_cont_mark,                  /* 164 */
+  scheme_rt_saved_stack,                /* 165 */
+  scheme_rt_reply_item,                 /* 166 */
+  scheme_rt_closure_info,               /* 167 */
+  scheme_rt_overflow,                   /* 168 */
+  scheme_rt_overflow_jmp,               /* 169 */
+  scheme_rt_meta_cont,                  /* 170 */
+  scheme_rt_dyn_wind_cell,              /* 171 */
+  scheme_rt_dyn_wind_info,              /* 172 */
+  scheme_rt_dyn_wind,                   /* 173 */
+  scheme_rt_dup_check,                  /* 174 */
+  scheme_rt_thread_memory,              /* 175 */
+  scheme_rt_input_file,                 /* 176 */
+  scheme_rt_input_fd,                   /* 177 */
+  scheme_rt_oskit_console_input,        /* 178 */
+  scheme_rt_tested_input_file,          /* 179 */
+  scheme_rt_tested_output_file,         /* 180 */
+  scheme_rt_indexed_string,             /* 181 */
+  scheme_rt_output_file,                /* 182 */
+  scheme_rt_load_handler_data,          /* 183 */
+  scheme_rt_pipe,                       /* 184 */
+  scheme_rt_beos_process,               /* 185 */
+  scheme_rt_system_child,               /* 186 */
+  scheme_rt_tcp,                        /* 187 */
+  scheme_rt_write_data,                 /* 188 */
+  scheme_rt_tcp_select_info,            /* 189 */
+  scheme_rt_namespace_option,           /* 190 */
+  scheme_rt_param_data,                 /* 191 */
+  scheme_rt_will,                       /* 192 */
+  scheme_rt_struct_proc_info,           /* 193 */
+  scheme_rt_linker_name,                /* 194 */
+  scheme_rt_param_map,                  /* 195 */
+  scheme_rt_finalization,               /* 196 */
+  scheme_rt_finalizations,              /* 197 */
+  scheme_rt_cpp_object,                 /* 198 */
+  scheme_rt_cpp_array_object,           /* 199 */
+  scheme_rt_stack_object,               /* 200 */
+  scheme_rt_preallocated_object,        /* 201 */
+  scheme_thread_hop_type,               /* 202 */
+  scheme_rt_srcloc,                     /* 203 */
+  scheme_rt_evt,                        /* 204 */
+  scheme_rt_syncing,                    /* 205 */
+  scheme_rt_comp_prefix,                /* 206 */
+  scheme_rt_user_input,                 /* 207 */
+  scheme_rt_user_output,                /* 208 */
+  scheme_rt_compact_port,               /* 209 */
+  scheme_rt_read_special_dw,            /* 210 */
+  scheme_rt_regwork,                    /* 211 */
+  scheme_rt_buf_holder,                 /* 212 */
+  scheme_rt_parameterization,           /* 213 */
+  scheme_rt_print_params,               /* 214 */
+  scheme_rt_read_params,                /* 215 */
+  scheme_rt_native_code,                /* 216 */
+  scheme_rt_native_code_plus_case,      /* 217 */
+  scheme_rt_jitter_data,                /* 218 */
+  scheme_rt_module_exports,             /* 219 */
+  scheme_rt_delay_load_info,            /* 220 */
+  scheme_rt_marshal_info,               /* 221 */
+  scheme_rt_unmarshal_info,             /* 222 */
+  scheme_rt_runstack,                   /* 223 */
+  scheme_rt_sfs_info,                   /* 224 */
+  scheme_rt_validate_clearing,          /* 225 */
+  scheme_rt_rb_node,                    /* 226 */
 #endif
 
-  scheme_place_type,                    /* 226 */
-  scheme_engine_type,                   /* 227 */
+  scheme_place_type,                    /* 227 */
+  scheme_engine_type,                   /* 228 */
 
   _scheme_last_type_
 };
diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c
index 297e0ab71f..5408530458 100644
--- a/src/mzscheme/src/type.c
+++ b/src/mzscheme/src/type.c
@@ -161,6 +161,7 @@ scheme_init_type ()
   set_name(scheme_syntax_compiler_type, "<syntax-compiler>");
   set_name(scheme_macro_type, "<macro>");
   set_name(scheme_vector_type, "<vector>");
+  set_name(scheme_flvector_type, "<flvector>");
   set_name(scheme_bignum_type, "<bignum-integer>");
   set_name(scheme_escaping_cont_type, "<escape-continuation>");
   set_name(scheme_sema_type, "<semaphore>");
@@ -540,6 +541,7 @@ void scheme_register_traversers(void)
   GC_REG_TRAV(scheme_mutable_pair_type, cons_cell);
   GC_REG_TRAV(scheme_raw_pair_type, cons_cell);
   GC_REG_TRAV(scheme_vector_type, vector_obj);
+  GC_REG_TRAV(scheme_flvector_type, flvector_obj);
   GC_REG_TRAV(scheme_cpointer_type, cpointer_obj);
   GC_REG_TRAV(scheme_offset_cpointer_type, offset_cpointer_obj);
 
diff --git a/src/mzscheme/src/vector.c b/src/mzscheme/src/vector.c
index 3a3d661da4..2818ebdcb2 100644
--- a/src/mzscheme/src/vector.c
+++ b/src/mzscheme/src/vector.c
@@ -321,27 +321,33 @@ Scheme_Object *scheme_vector_length(Scheme_Object *v)
   return vector_length(1, a);
 }
 
-static Scheme_Object *
-bad_index(char *name, Scheme_Object *i, Scheme_Object *vec, int bottom)
+void scheme_bad_vec_index(char *name, Scheme_Object *i, const char *what, Scheme_Object *vec, 
+                          long bottom, long len)
 {
-  int n = SCHEME_VEC_SIZE(vec) - 1;
-
-  if (SCHEME_VEC_SIZE(vec)) {
+  if (len) {
+    long n = len - 1;
     char *vstr;
     int vlen;
     vstr = scheme_make_provided_string(vec, 2, &vlen);
     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
-		     "%s: index %s out of range [%d, %d] for vector: %t",
+		     "%s: index %s out of range [%ld, %ld] for %s: %t",
 		     name, 
 		     scheme_make_provided_string(i, 2, NULL), 
 		     bottom, n,
+                     what,
 		     vstr, vlen);
   } else
     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
-		     "%s: bad index %s for empty vector",
+		     "%s: bad index %s for empty %s",
 		     name,
-		     scheme_make_provided_string(i, 0, NULL));
-  
+		     scheme_make_provided_string(i, 0, NULL),
+                     what);
+}
+
+static Scheme_Object *
+bad_index(char *name, Scheme_Object *i, Scheme_Object *vec, int bottom)
+{
+  scheme_bad_vec_index(name, i, "vector", vec, bottom, SCHEME_VEC_SIZE(vec));
   return NULL;
 }
 

From c73b587e980ef3ff15b36a9fb982ca5af28fc142 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 3 Dec 2009 18:04:02 +0000
Subject: [PATCH 086/136] inline flvector-length

svn: r17178
---
 collects/tests/mzscheme/unsafe.ss | 19 +++++---------
 src/mzscheme/src/jit.c            | 43 +++++++++++++++++++++++++++----
 src/mzscheme/src/jit_ts.c         |  2 ++
 src/mzscheme/src/number.c         | 27 +++++++++++--------
 src/mzscheme/src/schpriv.h        |  1 +
 5 files changed, 64 insertions(+), 28 deletions(-)

diff --git a/collects/tests/mzscheme/unsafe.ss b/collects/tests/mzscheme/unsafe.ss
index c404722667..7304c90968 100644
--- a/collects/tests/mzscheme/unsafe.ss
+++ b/collects/tests/mzscheme/unsafe.ss
@@ -187,18 +187,13 @@
               #:post (lambda (x) (list x (string-ref v 2)))
               #:literal-ok? #f))
 
-  (let ([flvector (lambda args
-                    (let ([v (make-flvector (length args))])
-                      (for ([a args]
-                            [i (in-naturals)])
-                        (flvector-set! v i a))
-                      v))])
-    (test-bin 9.5 'unsafe-flvector-ref (flvector 1.0 9.5 18.7) 1)
-    (let ([v (flvector 1.0 9.5 18.7)])
-      (test-tri (list (void) 27.4) 'unsafe-flvector-set! v 2 27.4
-                #:pre (lambda () (flvector-set! v 2 0.0)) 
-                #:post (lambda (x) (list x (flvector-ref v 2)))
-                #:literal-ok? #f)))
+  (test-bin 9.5 'unsafe-flvector-ref (flvector 1.0 9.5 18.7) 1)
+  (test-un 5 'unsafe-flvector-length (flvector 1.1 2.0 3.1 4.5 5.7))
+  (let ([v (flvector 1.0 9.5 18.7)])
+    (test-tri (list (void) 27.4) 'unsafe-flvector-set! v 2 27.4
+              #:pre (lambda () (flvector-set! v 2 0.0)) 
+              #:post (lambda (x) (list x (flvector-ref v 2)))
+              #:literal-ok? #f))
 
   (test-bin 9.5 'unsafe-f64vector-ref (f64vector 1.0 9.5 18.7) 1)
   (let ([v (f64vector 1.0 9.5 18.7)])
diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c
index 3eb280393e..a845e2b62b 100644
--- a/src/mzscheme/src/jit.c
+++ b/src/mzscheme/src/jit.c
@@ -143,6 +143,7 @@ static void *bad_mcar_code, *bad_mcdr_code;
 static void *bad_set_mcar_code, *bad_set_mcdr_code;
 static void *bad_unbox_code;
 static void *bad_vector_length_code;
+static void *bad_flvector_length_code;
 static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *vector_set_check_index_code;
 static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code;
 static void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code;
@@ -5516,8 +5517,21 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
       return 1;
     } else if (IS_NAMED_PRIM(rator, "vector-length")
-               || IS_NAMED_PRIM(rator, "unsafe-vector-length")) {
+               || IS_NAMED_PRIM(rator, "unsafe-vector-length")
+               || IS_NAMED_PRIM(rator, "flvector-length")
+               || IS_NAMED_PRIM(rator, "unsafe-flvector-length")) {
       GC_CAN_IGNORE jit_insn *reffail, *ref;
+      int unsafe = 0, for_fl = 0;
+
+      if (IS_NAMED_PRIM(rator, "unsafe-vector-length")) {
+        unsafe = 1;
+      } else if (IS_NAMED_PRIM(rator, "flvector-length")) {
+        for_fl = 1;
+      } else if (IS_NAMED_PRIM(rator, "unsafe-flvector-length")) {
+        unsafe = 1;
+        for_fl = 1;
+      }
+      
 
       LOG_IT(("inlined vector-length\n"));
 
@@ -5528,7 +5542,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
       mz_runstack_unskipped(jitter, 1);
 
-      if (!IS_NAMED_PRIM(rator, "unsafe-vector-length")) {
+      if (!unsafe) {
         mz_rs_sync_fail_branch();
 
         __START_TINY_JUMPS__(1);
@@ -5536,16 +5550,25 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
         __END_TINY_JUMPS__(1);
         
         reffail = _jit.x.pc;
-        (void)jit_calli(bad_vector_length_code);
+        if (!for_fl)
+          (void)jit_calli(bad_vector_length_code);
+        else
+          (void)jit_calli(bad_flvector_length_code);
 
         __START_TINY_JUMPS__(1);
         mz_patch_branch(ref);
         jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
-        (void)jit_bnei_i(reffail, JIT_R1, scheme_vector_type);
+        if (!for_fl)
+          (void)jit_bnei_i(reffail, JIT_R1, scheme_vector_type);
+        else
+          (void)jit_bnei_i(reffail, JIT_R1, scheme_flvector_type);
         __END_TINY_JUMPS__(1);
       }
 
-      (void)jit_ldxi_i(JIT_R0, JIT_R0, &SCHEME_VEC_SIZE(0x0));
+      if (!for_fl)
+        (void)jit_ldxi_i(JIT_R0, JIT_R0, &SCHEME_VEC_SIZE(0x0));
+      else
+        (void)jit_ldxi_l(JIT_R0, JIT_R0, &SCHEME_FLVEC_SIZE(0x0));
       jit_lshi_l(JIT_R0, JIT_R0, 1);
       jit_ori_l(JIT_R0, JIT_R0, 0x1);
             
@@ -8735,6 +8758,16 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
   CHECK_LIMIT();
   register_sub_func(jitter, bad_vector_length_code, scheme_false);
 
+  /* *** bad_flvector_length_code *** */
+  /* R0 is argument */
+  bad_flvector_length_code = jit_get_ip().ptr;
+  mz_prolog(JIT_R1);
+  jit_prepare(1);
+  jit_pusharg_i(JIT_R0);
+  (void)mz_finish(ts_scheme_flvector_length);
+  CHECK_LIMIT();
+  register_sub_func(jitter, bad_flvector_length_code, scheme_false);
+
   /* *** call_original_unary_arith_code *** */
   /* R0 is arg, R2 is code pointer, V1 is return address */
   for (i = 0; i < 3; i++) {
diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c
index 819c2ad0cf..640e456944 100644
--- a/src/mzscheme/src/jit_ts.c
+++ b/src/mzscheme/src/jit_ts.c
@@ -60,6 +60,7 @@ define_ts_iS_s(scheme_checked_set_mcar, FSRC_OTHER)
 define_ts_iS_s(scheme_checked_set_mcdr, FSRC_OTHER)
 define_ts_s_s(scheme_unbox, FSRC_OTHER)
 define_ts_s_s(scheme_vector_length, FSRC_OTHER)
+define_ts_s_s(scheme_flvector_length, FSRC_OTHER)
 define_ts_s_s(tail_call_with_values_from_multiple_result, FSRC_OTHER)
 define_ts_s_v(raise_bad_call_with_values, FSRC_OTHER)
 define_ts_s_s(call_with_values_from_multiple_result_multi, FSRC_OTHER)
@@ -122,6 +123,7 @@ define_ts_siS_v(wrong_argument_count, FSRC_OTHER)
 # define ts_scheme_checked_set_mcdr scheme_checked_set_mcdr
 # define ts_scheme_unbox scheme_unbox
 # define ts_scheme_vector_length scheme_vector_length
+# define ts_scheme_flvector_length scheme_flvector_length
 # define ts_tail_call_with_values_from_multiple_result tail_call_with_values_from_multiple_result
 # define ts_raise_bad_call_with_values raise_bad_call_with_values
 # define ts_call_with_values_from_multiple_result_multi call_with_values_from_multiple_result_multi
diff --git a/src/mzscheme/src/number.c b/src/mzscheme/src/number.c
index fd4b97f4db..5e5f6171f4 100644
--- a/src/mzscheme/src/number.c
+++ b/src/mzscheme/src/number.c
@@ -100,8 +100,8 @@ static Scheme_Object *int_sqrt_rem (int argc, Scheme_Object *argv[]);
 
 static Scheme_Object *flvector (int argc, Scheme_Object *argv[]);
 static Scheme_Object *flvector_p (int argc, Scheme_Object *argv[]);
-static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[]);
 static Scheme_Object *flvector_length (int argc, Scheme_Object *argv[]);
+static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[]);
 
 static Scheme_Object *fx_and (int argc, Scheme_Object *argv[]);
 static Scheme_Object *fx_or (int argc, Scheme_Object *argv[]);
@@ -521,11 +521,11 @@ scheme_init_number (Scheme_Env *env)
                                                     "make-flvector",
                                                     1, 2),
 			     env);
-  scheme_add_global_constant("flvector-length",
-                             scheme_make_immed_prim(flvector_length,
-                                                    "flvector-length",
-                                                    1, 1),
-			     env);
+
+  p = scheme_make_immed_prim(flvector_length, "flvector-length", 1, 1);
+  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
+  scheme_add_global_constant("flvector-length", p, env);
+
   p = scheme_make_immed_prim(scheme_checked_flvector_ref,
                              "flvector-ref",
                              2, 2);
@@ -587,7 +587,7 @@ void scheme_init_unsafe_number(Scheme_Env *env)
 
   p = scheme_make_immed_prim(unsafe_flvector_length, "unsafe-flvector-length",
                              1, 1);
-  /* SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; */
+  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
   scheme_add_global_constant("unsafe-flvector-length", p, env);
 
   p = scheme_make_immed_prim(unsafe_flvector_ref, "unsafe-flvector-ref",
@@ -2929,12 +2929,17 @@ static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[])
   return (Scheme_Object *)vec;
 }
 
+Scheme_Object *scheme_flvector_length(Scheme_Object *vec)
+{
+  if (!SCHEME_FLVECTORP(vec))
+    scheme_wrong_type("flvector-length", "flvector", 0, 1, &vec);
+
+  return scheme_make_integer(SCHEME_FLVEC_SIZE(vec));
+}
+
 static Scheme_Object *flvector_length (int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_FLVECTORP(argv[0]))
-    scheme_wrong_type("flvector-length", "flvector", 0, argc, argv);
-
-  return scheme_make_integer(SCHEME_FLVEC_SIZE(argv[0]));
+  return scheme_flvector_length(argv[0]);
 }
 
 Scheme_Object *scheme_checked_flvector_ref (int argc, Scheme_Object *argv[])
diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h
index 1ca42a86e3..c8fb71f3ac 100644
--- a/src/mzscheme/src/schpriv.h
+++ b/src/mzscheme/src/schpriv.h
@@ -3194,6 +3194,7 @@ Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_vector_length(Scheme_Object *v);
 Scheme_Object *scheme_checked_flvector_ref(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_checked_flvector_set(int argc, Scheme_Object **argv);
+Scheme_Object *scheme_flvector_length(Scheme_Object *v);
 
 void scheme_bad_vec_index(char *name, Scheme_Object *i, 
                           const char *what, Scheme_Object *vec, 

From 8c5089c37faacb6f255a14299fe386a2abb9606e Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Thu, 3 Dec 2009 21:45:57 +0000
Subject: [PATCH 087/136] PR 10027

svn: r17179
---
 collects/redex/private/matcher.ss             |   6 --
 .../redex/private/rewrite-side-conditions.ss  |  16 ++-
 collects/redex/private/term-test.ss           | 102 ++++++++----------
 collects/redex/private/test-util.ss           |  24 ++++-
 collects/redex/private/tl-test.ss             |   9 ++
 5 files changed, 90 insertions(+), 67 deletions(-)

diff --git a/collects/redex/private/matcher.ss b/collects/redex/private/matcher.ss
index 96bd946974..6e9a2beff3 100644
--- a/collects/redex/private/matcher.ss
+++ b/collects/redex/private/matcher.ss
@@ -712,12 +712,6 @@ before the pattern compiler is invoked.
          [(has-underscore? pattern)
           (let*-values ([(binder before-underscore)
                          (let ([before (split-underscore pattern)])
-                           (unless (or (hash-maps? clang-ht before)
-                                       (memq before underscore-allowed))
-                             (error 'compile-pattern "before underscore must be either a non-terminal ~a or a built-in pattern, found ~a in ~s" 
-                                    before
-                                    (format "~s" (list* 'one 'of: (hash-map clang-ht (λ (x y) x))))
-                                    pattern))
                            (values pattern before))]
                         [(match-raw-name has-hole?)
                          (compile-id-pattern before-underscore)])
diff --git a/collects/redex/private/rewrite-side-conditions.ss b/collects/redex/private/rewrite-side-conditions.ss
index 4f853a95fe..e0db2ae638 100644
--- a/collects/redex/private/rewrite-side-conditions.ss
+++ b/collects/redex/private/rewrite-side-conditions.ss
@@ -1,4 +1,4 @@
-(module rewrite-side-conditions scheme/base
+(module rewrite-side-conditions scheme
   (require (lib "list.ss")
            "underscore-allowed.ss")
   (require (for-template
@@ -74,6 +74,20 @@
         [(cross a) #`(cross #,(loop #'a))]
         [(cross a ...) (expected-exact 'cross 1 term)]
         [cross (expected-arguments 'cross term)]
+        [_
+         (identifier? term)
+         (match (regexp-match #rx"^([^_]*)_.*" (symbol->string (syntax-e term)))
+           [(list _ (app string->symbol s))
+            (if (or (memq s (cons '... underscore-allowed))
+                    (memq s all-nts))
+                term
+                (raise-syntax-error
+                 what
+                 (format "before underscore must be either a non-terminal or a built-in pattern, found ~a in ~s"
+                         s (syntax-e term))
+                 orig-stx 
+                 term))]
+           [_ term])]
         [(terms ...)
          (map loop (syntax->list (syntax (terms ...))))]
         [else
diff --git a/collects/redex/private/term-test.ss b/collects/redex/private/term-test.ss
index 6d271f4eaf..25059c7bbf 100644
--- a/collects/redex/private/term-test.ss
+++ b/collects/redex/private/term-test.ss
@@ -1,9 +1,7 @@
 (module term-test scheme
   (require "term.ss"
            "matcher.ss"
-           "test-util.ss"
-           errortrace/errortrace-lib
-           errortrace/errortrace-key)
+           "test-util.ss")
   
   (reset-count)
   (test (term 1) 1)
@@ -105,87 +103,75 @@
   (define-namespace-anchor here)
   (define ns (namespace-anchor->namespace here))
   
-  (define (runtime-error-source sexp src)
-    (let/ec return
-      (cadar
-       (continuation-mark-set->list
-        (exn-continuation-marks
-         (with-handlers ((exn:fail? values))
-           (parameterize ([current-namespace ns])
-             (parameterize ([current-compile (make-errortrace-compile-handler)])
-               (eval (read-syntax src (open-input-string (format "~s" sexp))))))
-           (return 'no-source)))
-        errortrace-key))))
-  
   (let ([src 'term-template])
     (test
-     (runtime-error-source
-      '(term-let ([(x ...) '(a b c)]
-                  [((y ...) ...) '((1 2) (4 5 6) (7 8 9))])
-                 (term (((x y) ...) ...)))
-      src)
+     (parameterize ([current-namespace ns])
+       (runtime-error-source
+        '(term-let ([(x ...) '(a b c)]
+                    [((y ...) ...) '((1 2) (4 5 6) (7 8 9))])
+                   (term (((x y) ...) ...)))
+        src))
      src))
   
   (let ([src 'term-template-metafunc])
     (test
-     (runtime-error-source 
-      '(term-let-fn ((f car))
-                    (term-let ([(x ...) '(a b c)]
-                               [((y ...) ...) '((1 2) (4 5 6) (7 8 9))])
-                              (term ((((f x) y) ...) ...))))
-      src)
+     (parameterize ([current-namespace ns])
+       (runtime-error-source 
+        '(term-let-fn ((f car))
+                      (term-let ([(x ...) '(a b c)]
+                                 [((y ...) ...) '((1 2) (4 5 6) (7 8 9))])
+                                (term ((((f x) y) ...) ...))))
+        src))
      src))
   
   (let ([src 'ellipsis-args])
     (test
-     (runtime-error-source 
-      '(term-let-fn ((f car))
-                    (term-let ([(x ...) '(a b)]
-                               [(y ...) '(c d e)])
-                              (term (f ((x y) ...)))))
-      src)
+     (parameterize ([current-namespace ns])
+       (runtime-error-source 
+        '(term-let-fn ((f car))
+                      (term-let ([(x ...) '(a b)]
+                                 [(y ...) '(c d e)])
+                                (term (f ((x y) ...)))))
+        src))
      src))
   
   (let ([src 'ellipsis-args/map])
     (test
-     (runtime-error-source 
-      '(term-let-fn ((f car))
-                    (term-let ([(x ...) '(a b)]
-                               [(y ...) '(c d e)])
-                              (term ((f (x y)) ...))))
-      src)
+     (parameterize ([current-namespace ns])
+       (runtime-error-source 
+        '(term-let-fn ((f car))
+                      (term-let ([(x ...) '(a b)]
+                                 [(y ...) '(c d e)])
+                                (term ((f (x y)) ...))))
+        src))
      src))
   
   (let ([src 'ellipsis-args/in-hole])
     (test
-     (runtime-error-source 
-      '(term-let ([(x ...) '(a b)]
-                  [(y ...) '(c d e)])
-                 (term ((in-hole hole (x y)) ...)))
-      src)
+     (parameterize ([current-namespace ns])
+       (runtime-error-source 
+        '(term-let ([(x ...) '(a b)]
+                    [(y ...) '(c d e)])
+                   (term ((in-hole hole (x y)) ...)))
+        src))
      src))
   
   (let ([src 'term-let-rhs])
     (test
-     (runtime-error-source
-      '(term-let ([(x ...) 'a])
-                 3)
-      src)
+     (parameterize ([current-namespace ns])
+       (runtime-error-source
+        '(term-let ([(x ...) 'a])
+                   3)
+        src))
      src))
   
-  (define (syntax-error-sources sexp src)
-    (let ([p (read-syntax src (open-input-string (format "~s" sexp)))])
-      (with-handlers ((exn:srclocs? (λ (x) (map srcloc-source ((exn:srclocs-accessor x) x)))))
-        (parameterize ([current-namespace ns])
-          (expand p))
-        null)))
-  
   (let ([src 'term-template])
     (test 
-     (syntax-error-sources
-      '(term-let ([(x ...) '(a b c)])
-                 (term x))
-      src)
+     (parameterize ([current-namespace ns])
+       (syntax-error-sources
+        '(term-let ([(x ...) '(a b c)])
+                   (term x))
+        src))
      (list src)))
   
   (print-tests-passed 'term-test.ss))
diff --git a/collects/redex/private/test-util.ss b/collects/redex/private/test-util.ss
index e973b69762..283a6596a0 100644
--- a/collects/redex/private/test-util.ss
+++ b/collects/redex/private/test-util.ss
@@ -1,10 +1,13 @@
 #lang scheme
 
-(require "matcher.ss")
+(require "matcher.ss"
+         errortrace/errortrace-lib
+         errortrace/errortrace-key)
 (provide test test-syn-err tests reset-count
          syn-err-test-namespace
          print-tests-passed
-         equal/bindings?)
+         equal/bindings?
+         runtime-error-source syntax-error-sources)
 
 (define syn-err-test-namespace (make-base-namespace))
 (parameterize ([current-namespace syn-err-test-namespace])
@@ -108,3 +111,20 @@
 ;; rib-lt : rib rib -> boolean
 (define (rib-lt r1 r2) (string<=? (format "~s" (bind-name r1))
                                   (format "~s" (bind-name r2))))
+
+(define (runtime-error-source sexp src)
+  (let/ec return
+    (cadar
+     (continuation-mark-set->list
+      (exn-continuation-marks
+       (with-handlers ((exn:fail? values))
+         (parameterize ([current-compile (make-errortrace-compile-handler)])
+           (eval (read-syntax src (open-input-string (format "~s" sexp)))))
+         (return 'no-source)))
+      errortrace-key))))
+
+(define (syntax-error-sources sexp src)
+    (let ([p (read-syntax src (open-input-string (format "~s" sexp)))])
+      (with-handlers ((exn:srclocs? (λ (x) (map srcloc-source ((exn:srclocs-accessor x) x)))))
+        (expand p)
+        null)))
\ No newline at end of file
diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss
index e6c82aa862..d59d570d7c 100644
--- a/collects/redex/private/tl-test.ss
+++ b/collects/redex/private/tl-test.ss
@@ -261,7 +261,16 @@
       (term (f 1)))
     (test rhs-eval-count 2))
   
+  (define-namespace-anchor here)
+  (define ns (namespace-anchor->namespace here))
   
+  (let ([src 'bad-underscore])
+    (test 
+     (parameterize ([current-namespace ns])
+       (syntax-error-sources
+        '(define-language L (n m_1))
+        src))
+     (list src)))
   
 ;                                                                                             
 ;                                                                                             

From 5a57905065b732c078f1eb7f3ec339095e1b5742 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Fri, 4 Dec 2009 08:50:54 +0000
Subject: [PATCH 088/136] Welcome to a new PLT day.

svn: r17181
---
 collects/repos-time-stamp/stamp.ss | 2 +-
 src/worksp/mred/mred.manifest      | 2 +-
 src/worksp/mred/mred.rc            | 8 ++++----
 src/worksp/mzcom/mzcom.rc          | 8 ++++----
 src/worksp/mzcom/mzobj.rgs         | 6 +++---
 src/worksp/mzscheme/mzscheme.rc    | 8 ++++----
 src/worksp/starters/start.rc       | 8 ++++----
 7 files changed, 21 insertions(+), 21 deletions(-)

diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss
index 6bc39c1c80..6865e59a76 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "3dec2009")
+#lang scheme/base (provide stamp) (define stamp "4dec2009")
diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest
index 5d8d4648b5..a9be731446 100644
--- a/src/worksp/mred/mred.manifest
+++ b/src/worksp/mred/mred.manifest
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8" standalone="yes"?> 
 <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> 
 <assemblyIdentity 
-version="4.2.3.3" 
+version="4.2.3.4" 
 processorArchitecture="X86" 
 name="Org.PLT-Scheme.MrEd" 
 type="win32" 
diff --git a/src/worksp/mred/mred.rc b/src/worksp/mred/mred.rc
index 876f2e8765..46c2afdba6 100644
--- a/src/worksp/mred/mred.rc
+++ b/src/worksp/mred/mred.rc
@@ -20,8 +20,8 @@ APPLICATION             ICON    DISCARDABLE     "mred.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,3,3
- PRODUCTVERSION 4,2,3,3
+ FILEVERSION 4,2,3,4
+ PRODUCTVERSION 4,2,3,4
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -39,11 +39,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme GUI application\0"
             VALUE "InternalName", "MrEd\0"
-            VALUE "FileVersion", "4, 2, 3, 3\0"
+            VALUE "FileVersion", "4, 2, 3, 4\0"
             VALUE "LegalCopyright", "Copyright � 1995-2009\0"
             VALUE "OriginalFilename", "MrEd.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 2, 3, 3\0"
+            VALUE "ProductVersion", "4, 2, 3, 4\0"
         END
     END
     BLOCK "VarFileInfo"
diff --git a/src/worksp/mzcom/mzcom.rc b/src/worksp/mzcom/mzcom.rc
index 7a5d3628d0..e96afb3bcb 100644
--- a/src/worksp/mzcom/mzcom.rc
+++ b/src/worksp/mzcom/mzcom.rc
@@ -53,8 +53,8 @@ END
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,3,3
- PRODUCTVERSION 4,2,3,3
+ FILEVERSION 4,2,3,4
+ PRODUCTVERSION 4,2,3,4
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -70,12 +70,12 @@ BEGIN
         BLOCK "040904b0"
         BEGIN
             VALUE "FileDescription", "MzCOM Module"
-            VALUE "FileVersion", "4, 2, 3, 3"
+            VALUE "FileVersion", "4, 2, 3, 4"
             VALUE "InternalName", "MzCOM"
             VALUE "LegalCopyright", "Copyright 2000-2009 PLT (Paul Steckler)"
             VALUE "OriginalFilename", "MzCOM.EXE"
             VALUE "ProductName", "MzCOM Module"
-            VALUE "ProductVersion", "4, 2, 3, 3"
+            VALUE "ProductVersion", "4, 2, 3, 4"
         END
     END
     BLOCK "VarFileInfo"
diff --git a/src/worksp/mzcom/mzobj.rgs b/src/worksp/mzcom/mzobj.rgs
index bc9f515155..f5803d369a 100644
--- a/src/worksp/mzcom/mzobj.rgs
+++ b/src/worksp/mzcom/mzobj.rgs
@@ -1,19 +1,19 @@
 HKCR
 {
-	MzCOM.MzObj.4.2.3.3 = s 'MzObj Class'
+	MzCOM.MzObj.4.2.3.4 = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
 	}
 	MzCOM.MzObj = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
-		CurVer = s 'MzCOM.MzObj.4.2.3.3'
+		CurVer = s 'MzCOM.MzObj.4.2.3.4'
 	}
 	NoRemove CLSID
 	{
 		ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
 		{
-			ProgID = s 'MzCOM.MzObj.4.2.3.3'
+			ProgID = s 'MzCOM.MzObj.4.2.3.4'
 			VersionIndependentProgID = s 'MzCOM.MzObj'
 			ForceRemove 'Programmable'
 			LocalServer32 = s '%MODULE%'
diff --git a/src/worksp/mzscheme/mzscheme.rc b/src/worksp/mzscheme/mzscheme.rc
index 736be425c3..eb59cfecb5 100644
--- a/src/worksp/mzscheme/mzscheme.rc
+++ b/src/worksp/mzscheme/mzscheme.rc
@@ -29,8 +29,8 @@ APPLICATION             ICON    DISCARDABLE     "mzscheme.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,3,3
- PRODUCTVERSION 4,2,3,3
+ FILEVERSION 4,2,3,4
+ PRODUCTVERSION 4,2,3,4
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -48,11 +48,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme application\0"
             VALUE "InternalName", "MzScheme\0"
-            VALUE "FileVersion", "4, 2, 3, 3\0"
+            VALUE "FileVersion", "4, 2, 3, 4\0"
             VALUE "LegalCopyright", "Copyright �� 1995-2009\0"
             VALUE "OriginalFilename", "mzscheme.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 2, 3, 3\0"
+            VALUE "ProductVersion", "4, 2, 3, 4\0"
         END
     END
     BLOCK "VarFileInfo"
diff --git a/src/worksp/starters/start.rc b/src/worksp/starters/start.rc
index 0f89e496f1..239fdfd64f 100644
--- a/src/worksp/starters/start.rc
+++ b/src/worksp/starters/start.rc
@@ -22,8 +22,8 @@ APPLICATION             ICON    DISCARDABLE     "mzstart.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,3,3
- PRODUCTVERSION 4,2,3,3
+ FILEVERSION 4,2,3,4
+ PRODUCTVERSION 4,2,3,4
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -45,7 +45,7 @@ BEGIN
 #ifdef MZSTART
             VALUE "FileDescription", "PLT Scheme Launcher\0"
 #endif
-            VALUE "FileVersion", "4, 2, 3, 3\0"
+            VALUE "FileVersion", "4, 2, 3, 4\0"
 #ifdef MRSTART
             VALUE "InternalName", "mrstart\0"
 #endif
@@ -60,7 +60,7 @@ BEGIN
             VALUE "OriginalFilename", "MzStart.exe\0"
 #endif
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 2, 3, 3\0"
+            VALUE "ProductVersion", "4, 2, 3, 4\0"
         END
     END
     BLOCK "VarFileInfo"

From 5650cb96479e93d90671ccbbccb7a466df45fd88 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 4 Dec 2009 20:18:14 +0000
Subject: [PATCH 089/136] Fix the module-reader tests.

svn: r17183
---
 collects/tests/mzscheme/module-reader.ss | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/collects/tests/mzscheme/module-reader.ss b/collects/tests/mzscheme/module-reader.ss
index a2d7e5660f..6a109b41a7 100644
--- a/collects/tests/mzscheme/module-reader.ss
+++ b/collects/tests/mzscheme/module-reader.ss
@@ -20,7 +20,7 @@
 ;; plain version
 (module r0 syntax/module-reader scheme/base)
 (test-both '(r0) "#reader '~s (define FoO #:bAr)"
-           '(module page scheme/base (define FoO #:bAr)))
+           '(module page scheme/base (#%module-begin (define FoO #:bAr))))
 
 ;; using a simple wrapper to get a case-insensitive reader
 (module r1 syntax/module-reader scheme/base
@@ -35,7 +35,7 @@
     (parameterize ([read-case-sensitive #f]) (apply reader args))))
 ;;
 (test-both '(r1 r2 r3) "#reader '~s (define FoO #:bAr)"
-           '(module page scheme/base (define foo #:bar)))
+           '(module page scheme/base (#%module-begin (define foo #:bar))))
 
 ;; add something to the result
 (module r4 syntax/module-reader zzz
@@ -45,7 +45,7 @@
   #:wrapper1 (lambda (t stx?) (cons (if stx? #'foo 'foo) (t))))
 ;;
 (test-both '(r4 r5) "#reader '~s (define foo #:bar)"
-           '(module page zzz foo (define foo #:bar)))
+           '(module page zzz (#%module-begin foo (define foo #:bar))))
 
 ;; make an empty module, after reading the contents
 (module r6 syntax/module-reader zzz
@@ -56,14 +56,14 @@
 ;; forget about the input -- just return a fixed empty input module
 (module r8 syntax/module-reader whatever
   #:wrapper2 (lambda (in rd)
-               (if (syntax? (rd in)) #'(module page zzz) '(module page zzz))))
+               (if (syntax? (rd in)) #'(module page zzz (#%module-begin)) '(module page zzz (#%module-begin)))))
 ;; the same, the easy way
 (module r9 syntax/module-reader
   #:language (lambda () 'zzz)
   #:wrapper1 (lambda (t) '()))
 ;;
 (test-both '(r6 r7 r8 r9) "#reader '~s (define foo #:bar)"
-           '(module page zzz))
+           '(module page zzz (#%module-begin)))
 
 ;; a module that uses the scribble syntax with a specified language
 (module r10 syntax/module-reader -ignored-
@@ -89,9 +89,9 @@
   (require scribble/reader))
 ;;
 (test-both '(r10 r11) "#reader '~s scheme/base (define foo 1)"
-           '(module page scheme/base (define foo 1)))
+           '(module page scheme/base (#%module-begin (define foo 1))))
 (test-both '(r10 r11) "#reader '~s scheme/base @define[foo]{one}"
-           '(module page scheme/base (define foo "one")))
+           '(module page scheme/base (#%module-begin (define foo "one"))))
 
 ;; ----------------------------------------
 

From d97e18c9a66dd38dc35676cf02ffe14248ba0e8f Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 4 Dec 2009 21:07:13 +0000
Subject: [PATCH 090/136] Allow for contracts without having to require
 scheme/contract in the scheme/signature language.

svn: r17185
---
 collects/scheme/signature/lang.ss | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/collects/scheme/signature/lang.ss b/collects/scheme/signature/lang.ss
index 8635cae591..0752de7fe5 100644
--- a/collects/scheme/signature/lang.ss
+++ b/collects/scheme/signature/lang.ss
@@ -1,6 +1,7 @@
 #lang scheme/base
 
 (require scheme/unit
+         scheme/contract
          (for-syntax scheme/base
                      mzlib/private/unit-compiletime
                      mzlib/private/unit-syntax))
@@ -8,6 +9,7 @@
 (provide (rename-out [module-begin #%module-begin])
          (except-out (all-from-out scheme/base) #%module-begin)
          (all-from-out scheme/unit)
+         (all-from-out scheme/contract)
          (for-syntax (all-from-out scheme/base)))
 
 (define-for-syntax (make-name s)

From aacffcc2bf7bb5c851ce4238dfc51894890dbc7c Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 4 Dec 2009 22:01:43 +0000
Subject: [PATCH 091/136] fix docs on collection paths (PR 10641)

svn: r17186
---
 collects/scribblings/reference/collects.scrbl | 25 +++++++++++++++----
 1 file changed, 20 insertions(+), 5 deletions(-)

diff --git a/collects/scribblings/reference/collects.scrbl b/collects/scribblings/reference/collects.scrbl
index ace19f3652..4b6c9b0880 100644
--- a/collects/scribblings/reference/collects.scrbl
+++ b/collects/scribblings/reference/collects.scrbl
@@ -33,11 +33,26 @@ scheme
 ....
 ]
 
-In general, the @scheme[_rel-string] in @scheme[(lib _rel-string)]
-consists of one or more path elements that name collections, and then
-a final path element that names a library file; the path elements are
-separated by @litchar{/}. If the final element has no file suffix,
-then @litchar{/main.ss} is implicitly appended to the path.
+This example is more compactly and more commonly written as
+
+@schememod[
+scheme
+(require setup/getinfo
+         games/cards/cards)
+....
+]
+
+When an identifier @scheme[_id] is used in a @scheme[require] form, it
+is converted to @scheme[(lib _rel-string)] where @scheme[_rel-string]
+is the string form of @scheme[_id].
+
+A @scheme[_rel-string] in @scheme[(lib _rel-string)] consists of one
+or more path elements that name collections, and then a final path
+element that names a library file; the path elements are separated by
+@litchar{/}. If @scheme[_rel-string] contains no @litchar{/}s, then
+then @litchar{/main.ss} is implicitly appended to the path. If
+@scheme[_rel-string] contains @litchar{/} but does not end with a file
+suffix, then @litchar{.ss} is implicitly appended to the path.
 
 The translation of a @scheme[planet] or @scheme[lib] path to a
 @scheme[module] declaration is determined by the @tech{module name

From 2e166e14e91a5f52a69ca814845d5d7a7f3192a7 Mon Sep 17 00:00:00 2001
From: Kevin Tew <tewk@racket-lang.org>
Date: Fri, 4 Dec 2009 22:51:02 +0000
Subject: [PATCH 092/136] Fixed compiler warning

svn: r17187
---
 src/mzscheme/src/string.c | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/mzscheme/src/string.c b/src/mzscheme/src/string.c
index 9512b1a129..e7bca46d91 100644
--- a/src/mzscheme/src/string.c
+++ b/src/mzscheme/src/string.c
@@ -2006,7 +2006,7 @@ static void putenv_str_table_put_name(Scheme_Object *name, Scheme_Object *value)
   void *original_gc;
   Scheme_Object *name_copy;
   original_gc = GC_switch_to_master_gc();
-  name_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) name);
+  name_copy = (Scheme_Object *) clone_str_with_gc((const char *) name);
   create_putenv_str_table_if_needed();
   scheme_hash_set(putenv_str_table, name_copy, value);
   GC_switch_back_from_master(original_gc);
@@ -2024,8 +2024,8 @@ static void putenv_str_table_put_name_value(Scheme_Object *name, Scheme_Object *
   Scheme_Object *name_copy;
   Scheme_Object *value_copy;
   original_gc = GC_switch_to_master_gc();
-  name_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) name);
-  value_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) value);
+  name_copy = (Scheme_Object *) clone_str_with_gc((const char *) name);
+  value_copy = (Scheme_Object *) clone_str_with_gc((const char *) value);
   create_putenv_str_table_if_needed();
   scheme_hash_set(putenv_str_table, name_copy, value_copy);
   GC_switch_back_from_master(original_gc);

From b844179642317d205f4cfc2fd988439c9de3394c Mon Sep 17 00:00:00 2001
From: James Swaine <jamesswaine@racket-lang.org>
Date: Fri, 4 Dec 2009 23:37:15 +0000
Subject: [PATCH 093/136] added to futures documentation

svn: r17188
---
 collects/scribblings/futures/futures.scrbl | 123 +++++++++++++++++----
 1 file changed, 101 insertions(+), 22 deletions(-)

diff --git a/collects/scribblings/futures/futures.scrbl b/collects/scribblings/futures/futures.scrbl
index 3039ff4ff8..8d9d0291aa 100644
--- a/collects/scribblings/futures/futures.scrbl
+++ b/collects/scribblings/futures/futures.scrbl
@@ -7,12 +7,110 @@
 @(require scribble/manual
           scribble/urls
           scribble/struct
-          (for-label scheme/base
-                     scheme/contract
-                     scheme/future))
+          (for-label  scheme
+		      scheme/base
+		      scheme/contract
+		      scheme/future))
 
 @; ----------------------------------------------------------------------
 
+The PLT futures API enables the development of parallel programs which take advantage of machines with multiple processors, cores, or hardware threads.
+
+@defmodule[scheme/future]{}
+
+@defproc[(future [thunk (-> any)]) future?]{
+  Starts running @scheme[thunk] in parallel.  The @scheme[future] procedure returns immediately with a future descriptor value.
+}
+
+@defproc[(touch [f future?]) any]{
+  Returns the value computed in the future @scheme[f], blocking until the future completes (if it has not already completed).
+}
+
+@defproc[(future? [x any/c]) boolean?]{
+  Returns @scheme[#t] if @scheme[x] is a future.                               
+}
+
+@defproc[(processor-count) exact-positive-integer?]{
+  Returns the number of processors/cores/hardware threads available on the current system.
+}
+
+@section[#:tag "besteffortpar"]{Best-Effort Parallelism}
+
+The @scheme[future] API represents a best-effort attempt to execute an arbitrary segment of code in parallel.  When designing programs and algorithms which leverage @scheme[future] for parallel speedup, there are a number of performance considerations to be aware of. 
+
+Futures are designed to accommodate the fact that many low-level functions provided by the MzScheme virtual machine are not reentrant.  Thus, a future will execute its work in parallel until it detects an attempt to perform an ``unsafe'' operation (e.g. invoking a non-reentrant function).  When such an operation is detected, the future will block until @scheme[touch]ed, upon which the remainder of its work will be done sequentially with respect to the touching thread (in this case, ``thread'' refers to an OS thread).  
+
+To guarantee that unsafe operations never execute simultaneously, only the initial OS thread used to start the MzScheme virtual machine (the ``runtime thread'') is allowed to execute them.  If a parallel future detects an attempted unsafe operation, it will signal the runtime thread that pending unsafe work is available, then block, waiting for the runtime thread to complete it.  Note that as mentioned above, the runtime thread will not attempt to do this work until the future is explicitly touched.  Also note that calls to @scheme[future] and @scheme[touch] are themselves considered unsafe operations.
+
+Consider the following contrived example:
+
+@schemeblock[
+(define (add-in-parallel a b) 
+  (let ([f (future (lambda () (+ a b)))]) 
+    (touch f)))
+
+(add-in-parallel 4 8)
+]
+
+The output of this program is, as expected: 
+
+@verbatim|{
+12 
+}|
+
+Now suppose we add a print message to our function for debugging purposes: 
+
+@schemeblock[
+(define (add-in-parallel a b) 
+  (let ([f (future 
+            (lambda () 
+              (begin 
+                (printf "Adding ~a and ~a together!~n" a b) 
+                (+ a b))))])
+    (printf "About to touch my future...~n") 
+    (touch f)))
+
+(add-in-parallel 4 8)
+]
+
+Though this program still produces the same output, no work is being done in parallel.  Because @scheme[printf] is considered an unsafe operation, f will block, and the print invocation (along with the subsequent add) will not be performed until the @scheme[touch] call.  
+
+@section[#:tag "logging"]{How Do I Keep Those Cores Busy?}
+
+Because it is not always obvious when or where unsafe operations may be causing unacceptable performance degradation in parallel programs, futures can be configured to generate trace output using the standard logging command-line switches.  This output can tell us which operations a given future is waiting on at a particular point during the program run.  For example, running the code in the previous example in the debug log level produces the following output: 
+
+@verbatim|{
+About to touch my future...
+future: 0 waiting for runtime at 1259702453747.720947: printf
+Adding 4 and 8 together! 
+12 
+}|
+
+To be sure we are not merely seeing the effects of a race condition in this example, we can force the main thread to @scheme[sleep] for an unreasonable amount of time:
+
+@schemeblock[
+(define (add-in-parallel a b) 
+  (let ([f (future 
+            (lambda () 
+              (begin 
+                (printf "Adding ~a and ~a together!~n" a b) 
+                (+ a b))))])
+    (sleep 10.0)
+    (printf "About to touch my future...~n") 
+    (touch f)))
+
+(add-in-parallel 4 8)
+]
+
+@verbatim|{
+About to touch my future...
+future: 0 waiting for runtime at 1259702453747.720947: printf
+Adding 4 and 8 together! 
+12 
+}|
+
+@section[#:tag "compiling"]{Enabling Futures in MzScheme Builds}
+
 PLT's parallel-future support is only enabled if you pass
 @DFlag{enable-futures} to @exec{configure} when you build PLT (and
 that build currently only works with @exec{mzscheme}, not with
@@ -20,22 +118,3 @@ that build currently only works with @exec{mzscheme}, not with
 @scheme[future] just remembers the given thunk to call sequentially
 on a later @scheme[touch].
 
-@defmodule[scheme/future]{}
-
-@defproc[(future [thunk (-> any)]) future?]{
-  Starts running @scheme[thunk] in parallel.
-}
-
-@defproc[(touch [f future?]) any]{
-  Returns the value computed in the future @scheme[f], blocking
-  to let it complete if it hasn't yet completed.
-}
-
-@defproc[(future? [x any/c]) boolean?]{
-  Returns @scheme[#t] if @scheme[x] is a future.                               
-}
-
-@defproc[(processor-count) exact-positive-integer?]{
-  Returns the number of processors available on the current system.
-}
-

From 76b10347da4dc11ac3420a0dc9b3c65f61d1696d Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Sat, 5 Dec 2009 00:48:46 +0000
Subject: [PATCH 094/136] Support some keyword arguments in type
 parsing/type->contract.

svn: r17189
---
 collects/typed-scheme/private/parse-type.ss   | 33 +++++++++++++++----
 .../typed-scheme/private/type-contract.ss     |  5 +--
 2 files changed, 29 insertions(+), 9 deletions(-)

diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss
index 613c5a5768..098596766b 100644
--- a/collects/typed-scheme/private/parse-type.ss
+++ b/collects/typed-scheme/private/parse-type.ss
@@ -66,6 +66,12 @@
          (make-Poly vars (parse-type #'t))))]
     [(t:All . rest) (tc-error "All: bad syntax")]))
 
+(define-splicing-syntax-class keyword-tys
+  (pattern (~seq k:keyword t:expr)
+           #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #t))
+  (pattern (~seq [k:keyword t:expr])
+           #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f)))
+
 (define (parse-type stx)    
   (parameterize ([current-orig-stx stx])    
     (syntax-parse
@@ -119,10 +125,15 @@
       (add-type-name-reference #'kw)
       ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
       (make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (parse-type #'pred-ty))]
-     [(dom ... rest ddd:star (~and kw t:->) rng)
+     [(dom:expr ... rest:expr ddd:star kws:keyword-tys ... (~and kw t:->) rng)
       (add-type-name-reference #'kw)
-      (->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rest) (parse-values-type #'rng))]
-     [(dom ... rest :ddd/bound (~and kw t:->) rng)
+      (make-Function
+       (list (make-arr
+              (map parse-type (syntax->list #'(dom ...)))
+              (parse-values-type #'rng)
+              #:rest (parse-type #'rest)
+              #:kws (attribute kws.Keyword))))]
+     [(dom:expr ... rest:expr :ddd/bound (~and kw t:->) rng)
       (add-type-name-reference #'kw)
       (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))])
         (if (not (Dotted? var))
@@ -141,7 +152,7 @@
                                       (current-tvars))])
                                  (parse-type #'rest))
                                (syntax-e #'bound))))))]
-     [(dom ... rest _:ddd (~and kw t:->) rng)
+     [(dom:expr ... rest:expr _:ddd (~and kw t:->) rng)
       (add-type-name-reference #'kw)
       (let ([bounds (filter (compose Dotted? cdr)
                             (env-keys+vals (current-tvars)))])
@@ -160,11 +171,19 @@
                                                        (current-tvars))])
                              (parse-type #'rest))
                            var)))))]
-     ;; has to be below the previous one
-     [(dom ... (~and kw t:->) rng) 
+    #| ;; has to be below the previous one
+     [(dom:expr ... (~and kw t:->) rng) 
       (add-type-name-reference #'kw)
       (->* (map parse-type (syntax->list #'(dom ...)))
-           (parse-values-type #'rng))]     
+           (parse-values-type #'rng))]     |#
+     ;; use expr to rule out keywords
+     [(dom:expr ... kws:keyword-tys ... (~and kw t:->) rng)
+      (add-type-name-reference #'kw)
+      (make-Function
+       (list (make-arr
+              (map parse-type (syntax->list #'(dom ...)))
+              (parse-values-type #'rng)
+              #:kws (attribute kws.Keyword))))]
      [((~and kw case-lambda) tys ...)
       (add-type-name-reference #'kw)
       (make-Function 
diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss
index 0d8806c7e8..21276de570 100644
--- a/collects/typed-scheme/private/type-contract.ss
+++ b/collects/typed-scheme/private/type-contract.ss
@@ -72,8 +72,9 @@
            (define (f a)
              (define-values (dom* rngs* rst)
                (match a
-                 [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f '())
-                  (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))]
+                 [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f (list (Keyword: kws ktys #t) ...))
+                  (values (append (map t->c/neg dom) (append-map (lambda (kw kty) (list kw (t->c/neg kty))) kws ktys))
+                          (map t->c rngs) (and rst (t->c/neg rst)))]
                  [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '())
                   (if (and out? pos?)
                       (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))

From 9c60a2749302276404272ad16e447cdde6322c73 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 02:14:51 +0000
Subject: [PATCH 095/136] improve formatting

svn: r17190
---
 collects/scribblings/futures/futures.scrbl | 137 +++++++++++++--------
 1 file changed, 85 insertions(+), 52 deletions(-)

diff --git a/collects/scribblings/futures/futures.scrbl b/collects/scribblings/futures/futures.scrbl
index 8d9d0291aa..42c937708c 100644
--- a/collects/scribblings/futures/futures.scrbl
+++ b/collects/scribblings/futures/futures.scrbl
@@ -7,106 +7,140 @@
 @(require scribble/manual
           scribble/urls
           scribble/struct
-          (for-label  scheme
-		      scheme/base
-		      scheme/contract
-		      scheme/future))
+          (for-label scheme
+                     scheme/base
+                     scheme/contract
+                     scheme/future))
 
 @; ----------------------------------------------------------------------
 
-The PLT futures API enables the development of parallel programs which take advantage of machines with multiple processors, cores, or hardware threads.
+The PLT futures API enables the development of parallel programs which
+take advantage of machines with multiple processors, cores, or
+hardware threads.
 
 @defmodule[scheme/future]{}
 
 @defproc[(future [thunk (-> any)]) future?]{
-  Starts running @scheme[thunk] in parallel.  The @scheme[future] procedure returns immediately with a future descriptor value.
+  Starts running @scheme[thunk] in parallel.  The @scheme[future]
+  procedure returns immediately with a future descriptor value.
 }
 
 @defproc[(touch [f future?]) any]{
-  Returns the value computed in the future @scheme[f], blocking until the future completes (if it has not already completed).
+  Returns the value computed in the future @scheme[f], blocking until
+  the future completes (if it has not already completed).
 }
 
 @defproc[(future? [x any/c]) boolean?]{
-  Returns @scheme[#t] if @scheme[x] is a future.                               
+  Returns @scheme[#t] if @scheme[x] is a future.
 }
 
 @defproc[(processor-count) exact-positive-integer?]{
-  Returns the number of processors/cores/hardware threads available on the current system.
+  Returns the number of processors/cores/hardware threads available on
+  the current system.
 }
 
 @section[#:tag "besteffortpar"]{Best-Effort Parallelism}
 
-The @scheme[future] API represents a best-effort attempt to execute an arbitrary segment of code in parallel.  When designing programs and algorithms which leverage @scheme[future] for parallel speedup, there are a number of performance considerations to be aware of. 
+The @scheme[future] API represents a best-effort attempt to execute an
+arbitrary segment of code in parallel.  When designing programs and
+algorithms which leverage @scheme[future] for parallel speedup, there
+are a number of performance considerations to be aware of.
 
-Futures are designed to accommodate the fact that many low-level functions provided by the MzScheme virtual machine are not reentrant.  Thus, a future will execute its work in parallel until it detects an attempt to perform an ``unsafe'' operation (e.g. invoking a non-reentrant function).  When such an operation is detected, the future will block until @scheme[touch]ed, upon which the remainder of its work will be done sequentially with respect to the touching thread (in this case, ``thread'' refers to an OS thread).  
+Futures are designed to accommodate the fact that many low-level
+functions provided by the MzScheme virtual machine are not reentrant.
+Thus, a future will execute its work in parallel until it detects an
+attempt to perform an ``unsafe'' operation (e.g. invoking a
+non-reentrant function).  When such an operation is detected, the
+future will block until @scheme[touch]ed, upon which the remainder of
+its work will be done sequentially with respect to the touching
+thread (in this case, ``thread'' refers to an OS thread).
 
-To guarantee that unsafe operations never execute simultaneously, only the initial OS thread used to start the MzScheme virtual machine (the ``runtime thread'') is allowed to execute them.  If a parallel future detects an attempted unsafe operation, it will signal the runtime thread that pending unsafe work is available, then block, waiting for the runtime thread to complete it.  Note that as mentioned above, the runtime thread will not attempt to do this work until the future is explicitly touched.  Also note that calls to @scheme[future] and @scheme[touch] are themselves considered unsafe operations.
+To guarantee that unsafe operations never execute simultaneously, only
+the initial OS thread used to start the MzScheme virtual machine (the
+``runtime thread'') is allowed to execute them.  If a parallel future
+detects an attempted unsafe operation, it will signal the runtime
+thread that pending unsafe work is available, then block, waiting for
+the runtime thread to complete it.  Note that as mentioned above, the
+runtime thread will not attempt to do this work until the future is
+explicitly touched.  Also note that calls to @scheme[future] and
+@scheme[touch] are themselves considered unsafe operations.
 
 Consider the following contrived example:
 
 @schemeblock[
-(define (add-in-parallel a b) 
-  (let ([f (future (lambda () (+ a b)))]) 
-    (touch f)))
+  (define (add-in-parallel a b)
+    (let ([f (future (lambda () (+ a b)))])
+      (touch f)))
 
-(add-in-parallel 4 8)
+  (add-in-parallel 4 8)
 ]
 
-The output of this program is, as expected: 
+The output of this program is, as expected:
 
 @verbatim|{
-12 
+  12
 }|
 
-Now suppose we add a print message to our function for debugging purposes: 
+Now suppose we add a print message to our function for debugging purposes:
 
 @schemeblock[
-(define (add-in-parallel a b) 
-  (let ([f (future 
-            (lambda () 
-              (begin 
-                (printf "Adding ~a and ~a together!~n" a b) 
-                (+ a b))))])
-    (printf "About to touch my future...~n") 
-    (touch f)))
+  (define (add-in-parallel a b)
+    (let ([f (future
+              (lambda ()
+                (begin
+                  (printf "Adding ~a and ~a together!~n" a b)
+                  (+ a b))))])
+      (printf "About to touch my future...~n")
+      (touch f)))
 
-(add-in-parallel 4 8)
+  (add-in-parallel 4 8)
 ]
 
-Though this program still produces the same output, no work is being done in parallel.  Because @scheme[printf] is considered an unsafe operation, f will block, and the print invocation (along with the subsequent add) will not be performed until the @scheme[touch] call.  
+Though this program still produces the same output, no work is being
+done in parallel.  Because @scheme[printf] is considered an unsafe
+operation, f will block, and the print invocation (along with the
+subsequent add) will not be performed until the @scheme[touch] call.
 
 @section[#:tag "logging"]{How Do I Keep Those Cores Busy?}
 
-Because it is not always obvious when or where unsafe operations may be causing unacceptable performance degradation in parallel programs, futures can be configured to generate trace output using the standard logging command-line switches.  This output can tell us which operations a given future is waiting on at a particular point during the program run.  For example, running the code in the previous example in the debug log level produces the following output: 
+Because it is not always obvious when or where unsafe operations may
+be causing unacceptable performance degradation in parallel programs,
+futures can be configured to generate trace output using the standard
+logging command-line switches.  This output can tell us which
+operations a given future is waiting on at a particular point during
+the program run.  For example, running the code in the previous
+example in the debug log level produces the following output:
 
 @verbatim|{
-About to touch my future...
-future: 0 waiting for runtime at 1259702453747.720947: printf
-Adding 4 and 8 together! 
-12 
+  About to touch my future...
+  future: 0 waiting for runtime at 1259702453747.720947: printf
+  Adding 4 and 8 together!
+  12
 }|
 
-To be sure we are not merely seeing the effects of a race condition in this example, we can force the main thread to @scheme[sleep] for an unreasonable amount of time:
+To be sure we are not merely seeing the effects of a race condition in
+this example, we can force the main thread to @scheme[sleep] for an
+unreasonable amount of time:
 
 @schemeblock[
-(define (add-in-parallel a b) 
-  (let ([f (future 
-            (lambda () 
-              (begin 
-                (printf "Adding ~a and ~a together!~n" a b) 
-                (+ a b))))])
-    (sleep 10.0)
-    (printf "About to touch my future...~n") 
-    (touch f)))
+  (define (add-in-parallel a b)
+    (let ([f (future
+              (lambda ()
+                (begin
+                  (printf "Adding ~a and ~a together!~n" a b)
+                  (+ a b))))])
+      (sleep 10.0)
+      (printf "About to touch my future...~n")
+      (touch f)))
 
-(add-in-parallel 4 8)
+  (add-in-parallel 4 8)
 ]
 
 @verbatim|{
-About to touch my future...
-future: 0 waiting for runtime at 1259702453747.720947: printf
-Adding 4 and 8 together! 
-12 
+  About to touch my future...
+  future: 0 waiting for runtime at 1259702453747.720947: printf
+  Adding 4 and 8 together!
+  12
 }|
 
 @section[#:tag "compiling"]{Enabling Futures in MzScheme Builds}
@@ -115,6 +149,5 @@ PLT's parallel-future support is only enabled if you pass
 @DFlag{enable-futures} to @exec{configure} when you build PLT (and
 that build currently only works with @exec{mzscheme}, not with
 @exec{mred}). When parallel-future support is not enabled,
-@scheme[future] just remembers the given thunk to call sequentially
-on a later @scheme[touch].
-
+@scheme[future] just remembers the given thunk to call sequentially on
+a later @scheme[touch].

From c5565d46113f82d725a75522da43259137775098 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 02:21:25 +0000
Subject: [PATCH 096/136] instead of allowing no #%module-begin, catch it and
 report a suitable error

svn: r17191
---
 collects/scribble/lp-include.ss | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/collects/scribble/lp-include.ss b/collects/scribble/lp-include.ss
index 09a3262180..f494e0dc47 100644
--- a/collects/scribble/lp-include.ss
+++ b/collects/scribble/lp-include.ss
@@ -9,12 +9,12 @@
 (define-syntax (module stx)
   (syntax-case stx (#%module-begin)
     [(module name base (#%module-begin body ...))
-     (begin
-       #'(begin body ...))]))
+     #'(begin body ...)]
+    [(module name base body ...)
+     (raise-syntax-error #f "missing #%module-begin" stx)]))
 
 (define-syntax (lp-include stx)
   (syntax-case stx ()
     [(_ name)
      (with-syntax ([there (datum->syntax stx 'there)])
        #'(include-at/relative-to here there name))]))
-

From b5114a14c14e7ea98ed070a9aff63350ddb41f0e Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 02:23:46 +0000
Subject: [PATCH 097/136] formatting

svn: r17192
---
 collects/tests/mzscheme/module-reader.ss | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/collects/tests/mzscheme/module-reader.ss b/collects/tests/mzscheme/module-reader.ss
index 6a109b41a7..826f9c5adf 100644
--- a/collects/tests/mzscheme/module-reader.ss
+++ b/collects/tests/mzscheme/module-reader.ss
@@ -56,7 +56,9 @@
 ;; forget about the input -- just return a fixed empty input module
 (module r8 syntax/module-reader whatever
   #:wrapper2 (lambda (in rd)
-               (if (syntax? (rd in)) #'(module page zzz (#%module-begin)) '(module page zzz (#%module-begin)))))
+               (if (syntax? (rd in))
+                 #'(module page zzz (#%module-begin))
+                 '(module page zzz (#%module-begin)))))
 ;; the same, the easy way
 (module r9 syntax/module-reader
   #:language (lambda () 'zzz)

From 49df9502a4c70bc45c534e485ea18c04c9f2e28a Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 02:30:44 +0000
Subject: [PATCH 098/136] Some improvements to the description

svn: r17193
---
 collects/syntax/scribblings/module-reader.scrbl | 15 ++++++++-------
 1 file changed, 8 insertions(+), 7 deletions(-)

diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl
index 395852dc16..26725ed5d0 100644
--- a/collects/syntax/scribblings/module-reader.scrbl
+++ b/collects/syntax/scribblings/module-reader.scrbl
@@ -136,13 +136,14 @@ In some cases, the reader functions read the whole file, so there is
 no need to iterate them (e.g., Scribble's @scheme[read-inside] and
 @scheme[read-syntax-inside]).  In these cases you can specify
 @scheme[#:whole-body-readers?] as @scheme[#t] --- the readers are
-expected to return a list of expressions in this case.  If those
-reader functions return a list with a single expression that begins
-with @scheme[#%module-begin], then the @scheme[syntax/module-reader]
-language will not inappropriately add another.  This is to be
-backwards-compatible with older code, and adding @scheme[#%module-begin]
-in the reader functions or in the function specified by @scheme[#:wrapper1]
-should be considered deprecated behavior.
+expected to return a list of expressions in this case.
+
+[If such whole-body reader functions return a list with a single
+expression that begins with @scheme[#%module-begin], then the
+@scheme[syntax/module-reader] language will not inappropriately add
+another.  This for backwards-compatibility with older code: having a
+whole-body reader functions or wrapper functions that return a
+@scheme[#%module-begin]-wrapped body is deprectaed.]
 
 In addition, the two wrappers can return a different value than the
 wrapped function.  This introduces two more customization points for

From ac0a1dc7d8d44aed15b380b91357b3546ad930a0 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 02:41:35 +0000
Subject: [PATCH 099/136] General reformat, and move the new comment about
 #%module-begin to the end of the section

svn: r17194
---
 .../syntax/scribblings/module-reader.scrbl    | 186 +++++++++---------
 1 file changed, 96 insertions(+), 90 deletions(-)

diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl
index 26725ed5d0..3b7f2c91a9 100644
--- a/collects/syntax/scribblings/module-reader.scrbl
+++ b/collects/syntax/scribblings/module-reader.scrbl
@@ -2,7 +2,8 @@
 @(require "common.ss")
 
 @(require (for-label syntax/module-reader
-                     (only-in scribble/reader read-syntax-inside read-inside)))
+                     (only-in scribble/reader
+                              read-syntax-inside read-inside)))
 
 @title[#:tag "module-reader"]{Module Reader}
 
@@ -15,16 +16,17 @@ is the name of the module that will be used in the language position
 of read modules; using keywords, the resulting readers can be
 customized in a number of ways.
 
-@defform*/subs[[(#%module-begin module-path)
-                (#%module-begin module-path reader-option ... body ....)
-                (#%module-begin             reader-option ... body ....)]
-               ([reader-option (code:line #:language    lang-expr)
-                               (code:line #:read        read-expr)
-                               (code:line #:read-syntax read-syntax-expr)
-                               (code:line #:info        info-expr)
-                               (code:line #:wrapper1    wrapper1-expr)
-                               (code:line #:wrapper2    wrapper2-expr)
-                               (code:line #:whole-body-readers? whole?-expr)])]{
+@defform*/subs[
+  [(#%module-begin module-path)
+   (#%module-begin module-path reader-option ... body ....)
+   (#%module-begin             reader-option ... body ....)]
+  ([reader-option (code:line #:language    lang-expr)
+                  (code:line #:read        read-expr)
+                  (code:line #:read-syntax read-syntax-expr)
+                  (code:line #:info        info-expr)
+                  (code:line #:wrapper1    wrapper1-expr)
+                  (code:line #:wrapper2    wrapper2-expr)
+                  (code:line #:whole-body-readers? whole?-expr)])]{
 
 Causes a module written in the @schememodname[syntax/module-reader]
 language to define and provide @schemeidfont{read} and
@@ -37,16 +39,15 @@ That is, a module @scheme[_something]@scheme[/lang/reader] implemented
 as
 
 @schemeblock[
-(module reader syntax/module-reader
-  module-path)
+  (module reader syntax/module-reader
+    module-path)
 ]
 
-creates a reader that converts @scheme[#,(hash-lang)_something]
-into
+creates a reader that converts @scheme[#,(hash-lang)_something] into
 
 @schemeblock[
-(module _name-id module-path
-  (#%module-begin ....))
+  (module _name-id module-path
+    (#%module-begin ....))
 ]
 
 where @scheme[_name-id] is derived from the name of the port used by
@@ -55,8 +56,8 @@ the reader.
 For example, @scheme[scheme/base/lang/reader] is implemented as
 
 @schemeblock[
-(module reader syntax/module-reader
-  scheme/base)
+  (module reader syntax/module-reader
+    scheme/base)
 ]
 
 The reader functions can be customized in a number of ways, using
@@ -68,10 +69,10 @@ reading.  For example, you can implement a
 using:
 
 @schemeblock[
-(module reader syntax/module-reader
-  honu
-  #:read read-honu
-  #:read-syntax read-honu-syntax)
+  (module reader syntax/module-reader
+    honu
+    #:read read-honu
+    #:read-syntax read-honu-syntax)
 ]
 
 Similarly, the @scheme[#:info] keyword supplies a procedure to be used
@@ -82,17 +83,17 @@ procedure (to be called with the key and default result for default
 handling). If @scheme[#:info] is not supplied, the default
 info-getting procedure is used.
 
-You can also use the (optional) module @scheme[body] forms to provide more
-definitions that might be needed to implement your reader functions.
-For example, here is a case-insensitive reader for the
+You can also use the (optional) module @scheme[body] forms to provide
+more definitions that might be needed to implement your reader
+functions.  For example, here is a case-insensitive reader for the
 @scheme[scheme/base] language:
 
 @schemeblock[
-(module reader syntax/module-reader
-  scheme/base
-  #:read (wrap read) #:read-syntax (wrap read-syntax)
-  (define ((wrap reader) . args)
-    (parameterize ([read-case-sensitive #f]) (apply reader args))))
+  (module reader syntax/module-reader
+    scheme/base
+    #:read (wrap read) #:read-syntax (wrap read-syntax)
+    (define ((wrap reader) . args)
+      (parameterize ([read-case-sensitive #f]) (apply reader args))))
 ]
 
 In many cases, however, the standard @scheme[read] and
@@ -105,11 +106,11 @@ alternative definition of the case-insensitive language using
 @scheme[#:wrapper1]:
 
 @schemeblock[
-(module reader syntax/module-reader
-  scheme/base
-  #:wrapper1 (lambda (t)
-               (parameterize ([read-case-sensitive #f])
-                 (t))))
+  (module reader syntax/module-reader
+    scheme/base
+    #:wrapper1 (lambda (t)
+                 (parameterize ([read-case-sensitive #f])
+                   (t))))
 ]
 
 Note that using a @tech[#:doc refman]{readtable}, you can implement
@@ -125,11 +126,11 @@ that corresponds to a file).  Here is the case-insensitive implemented
 using this option:
 
 @schemeblock[
-(module reader syntax/module-reader
-  scheme/base
-  #:wrapper2 (lambda (in r)
-               (parameterize ([read-case-sensitive #f])
-                 (r in))))
+  (module reader syntax/module-reader
+    scheme/base
+    #:wrapper2 (lambda (in r)
+                 (parameterize ([read-case-sensitive #f])
+                   (r in))))
 ]
 
 In some cases, the reader functions read the whole file, so there is
@@ -138,13 +139,6 @@ no need to iterate them (e.g., Scribble's @scheme[read-inside] and
 @scheme[#:whole-body-readers?] as @scheme[#t] --- the readers are
 expected to return a list of expressions in this case.
 
-[If such whole-body reader functions return a list with a single
-expression that begins with @scheme[#%module-begin], then the
-@scheme[syntax/module-reader] language will not inappropriately add
-another.  This for backwards-compatibility with older code: having a
-whole-body reader functions or wrapper functions that return a
-@scheme[#%module-begin]-wrapped body is deprectaed.]
-
 In addition, the two wrappers can return a different value than the
 wrapped function.  This introduces two more customization points for
 the resulting readers:
@@ -155,10 +149,9 @@ the resulting readers:
     following reader defines a ``language'' that ignores the contents
     of the file, and simply reads files as if they were empty:
     @schemeblock[
-    (module ignored syntax/module-reader
-      scheme/base
-      #:wrapper1 (lambda (t) (t) '()))
-    ]
+      (module ignored syntax/module-reader
+        scheme/base
+        #:wrapper1 (lambda (t) (t) '()))]
     Note that it is still performing the read, otherwise the module
     loader will complain about extra expressions.}
   @item{The reader function that is passed to a @scheme[#:wrapper2]
@@ -175,22 +168,22 @@ scribble syntax, and the first datum in the file determines the actual
 language (which means that the library specification is effectively
 ignored):
 @schemeblock[
-(module reader syntax/module-reader
-  -ignored-
-  #:wrapper2
-  (lambda (in rd stx?)
-    (let* ([lang (read in)]
-           [mod  (parameterize ([current-readtable 
-                                 (make-at-readtable)])
-                   (rd in))]
-           [mod  (if stx? mod (datum->syntax #f mod))]
-           [r (syntax-case mod ()
-                [(module name lang* . body)
-                 (with-syntax ([lang (datum->syntax
-                                      #'lang* lang #'lang*)])
-                   (syntax/loc mod (module name lang . body)))])])
-      (if stx? r (syntax->datum r))))
-  (require scribble/reader))
+  (module reader syntax/module-reader
+    -ignored-
+    #:wrapper2
+    (lambda (in rd stx?)
+      (let* ([lang (read in)]
+             [mod  (parameterize ([current-readtable
+                                   (make-at-readtable)])
+                     (rd in))]
+             [mod  (if stx? mod (datum->syntax #f mod))]
+             [r (syntax-case mod ()
+                  [(module name lang* . body)
+                   (with-syntax ([lang (datum->syntax
+                                        #'lang* lang #'lang*)])
+                     (syntax/loc mod (module name lang . body)))])])
+        (if stx? r (syntax->datum r))))
+    (require scribble/reader))
 ]
 
 This ability to change the language position in the resulting module
@@ -198,22 +191,33 @@ expression can be useful in cases such as the above, where the base
 language module is chosen based on the input.  To make this more
 convenient, you can omit the @scheme[module-path] and instead specify
 it via a @scheme[#:language] expression.  This expression can evaluate
-to a datum or syntax object that is used as a language, or it can evaluate to a thunk.
-In the latter case, the thunk is invoked to obtain such a datum
-before reading the module body begins, in a dynamic extent where
-@scheme[current-input-port] is the source input. A syntax object is converted
-using @scheme[syntax->datum] when a datum is needed (for @scheme[read] instead of @scheme[read-syntax]). 
-Using @scheme[#:language], the last
-example above can be written more concisely:
+to a datum or syntax object that is used as a language, or it can
+evaluate to a thunk.  In the latter case, the thunk is invoked to
+obtain such a datum before reading the module body begins, in a
+dynamic extent where @scheme[current-input-port] is the source
+input. A syntax object is converted using @scheme[syntax->datum] when
+a datum is needed (for @scheme[read] instead of @scheme[read-syntax]).
+Using @scheme[#:language], the last example above can be written more
+concisely:
+
 @schemeblock[
-(module reader syntax/module-reader
-  #:language read
-  #:wrapper2 (lambda (in rd stx?)
-               (parameterize ([current-readtable 
-                               (make-at-readtable)])
-                 (rd in)))
-  (require scribble/reader))
+  (module reader syntax/module-reader
+    #:language read
+    #:wrapper2 (lambda (in rd stx?)
+                 (parameterize ([current-readtable
+                                 (make-at-readtable)])
+                   (rd in)))
+    (require scribble/reader))
 ]
+
+
+Note: if such whole-body reader functions return a list with a single
+expression that begins with @scheme[#%module-begin], then the
+@scheme[syntax/module-reader] language will not inappropriately add
+another.  This for backwards-compatibility with older code: having a
+whole-body reader functions or wrapper functions that return a
+@scheme[#%module-begin]-wrapped body is deprectaed.
+
 }
 
 
@@ -234,7 +238,8 @@ procedures chains to another language that is specified in an input
 stream.
 
 @margin-note{The @schememodname[at-exp], @schememodname[reader], and
-@schememodname[planet] languages are implemented using this function.}
+  @schememodname[planet] languages are implemented using this
+  function.}
 
 The generated functions expect a target language description in the
 input stream that is provided to @scheme[read-spec]. The default
@@ -246,8 +251,9 @@ reader exception is raised, and @scheme[path-desc-str] is used as a
 description of the expected language form in the error message.
 
 @margin-note{The @schememodname[reader] language supplies
-@scheme[read] for @scheme[read-spec]. The @schememodname[at-exp] and
-@schememodname[planet] languages use the default @scheme[read-spec].}
+  @scheme[read] for @scheme[read-spec]. The @schememodname[at-exp] and
+  @schememodname[planet] languages use the default
+  @scheme[read-spec].}
 
 The result of @scheme[read-spec] is converted to a module path using
 @scheme[module-path-parser]. If @scheme[module-path-parser] produces
@@ -263,9 +269,9 @@ passed to @scheme[convert-read], @scheme[convert-read-syntax], or
 @scheme[convert-get-info], respectively.
 
 @margin-note{The @schememodname[at-exp] language supplies
-@scheme[convert-read] and @scheme[convert-read-syntax] to add
-@"@"-expression support to the current readtable before chaining to
-the given procedures.}
+  @scheme[convert-read] and @scheme[convert-read-syntax] to add
+  @"@"-expression support to the current readtable before chaining to
+  the given procedures.}
 
 The procedures generated by @scheme[make-meta-reader] are not meant
 for use with the @schememodname[syntax/module-reader] language; they
@@ -288,10 +294,10 @@ various keywords to arbitrary readers, and please use it instead.}
 
 Repeatedly calls @scheme[read] on @scheme[in] until an end of file,
 collecting the results in order into @scheme[_lst], and derives a
-@scheme[_name-id] from @scheme[(object-name in)].  The last five 
+@scheme[_name-id] from @scheme[(object-name in)].  The last five
 arguments are used to construct the syntax object for the language
 position of the module.  The result is roughly
 
 @schemeblock[
-`(module ,_name-id ,mod-path ,@_lst)
+  `(module ,_name-id ,mod-path ,@_lst)
 ]}

From e76b516e1d953ea3e6dbdae9214e4fe5b1a3cdcf Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Sat, 5 Dec 2009 03:27:19 +0000
Subject: [PATCH 100/136] Fixes a bug if #%module-begin was already there.

svn: r17195
---
 collects/syntax/module-reader.ss | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index 630adff4dc..eeb0c6483e 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -160,7 +160,7 @@
                     [(not (pair? exp)) wrapped-exps]
                     [(eq? '#%module-begin
                           (if stx? (syntax-e (car exp)) (car exp)))
-                     (car exp)]
+                     (car exps)]
                     [else wrapped-exps]))])))
     (let* ([lang (if stx? (datum->syntax #f lang modpath modpath) lang)]
            [body (lambda ()

From af998f0d560e48ff699e625113257e2e3f8b0143 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 03:49:24 +0000
Subject: [PATCH 101/136] mostly reformatting

svn: r17196
---
 collects/at-exp/lang/reader.ss                |  31 +--
 collects/planet/lang/reader.ss                |  21 +-
 collects/reader/lang/reader.ss                |  16 +-
 collects/syntax/module-reader.ss              | 218 +++++++++---------
 .../syntax/scribblings/module-reader.scrbl    |   2 +-
 5 files changed, 150 insertions(+), 138 deletions(-)

diff --git a/collects/at-exp/lang/reader.ss b/collects/at-exp/lang/reader.ss
index b519a3f079..5a9deb10e1 100644
--- a/collects/at-exp/lang/reader.ss
+++ b/collects/at-exp/lang/reader.ss
@@ -14,18 +14,19 @@
         (apply p args))))
 
   (define-values (at-read at-read-syntax at-get-info)
-    (make-meta-reader 'at-exp
-                      "language path"
-                      (lambda (str)
-                        (let ([s (string->symbol
-                                  (string-append (bytes->string/latin-1 str)
-                                                 "/lang/reader"))])
-                          (and (module-path? s) s)))
-                      wrap-reader
-                      wrap-reader
-                      (lambda (proc)
-                        (lambda (key defval)
-                          (case key
-                            [(color-lexer)
-                             (dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
-                            [else (if proc (proc key defval) defval)]))))))
+    (make-meta-reader
+     'at-exp
+     "language path"
+     (lambda (str)
+       (let ([s (string->symbol
+                 (string-append (bytes->string/latin-1 str)
+                                "/lang/reader"))])
+         (and (module-path? s) s)))
+     wrap-reader
+     wrap-reader
+     (lambda (proc)
+       (lambda (key defval)
+         (case key
+           [(color-lexer)
+            (dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
+           [else (if proc (proc key defval) defval)]))))))
diff --git a/collects/planet/lang/reader.ss b/collects/planet/lang/reader.ss
index 95d632e2dd..09a8aaf71c 100644
--- a/collects/planet/lang/reader.ss
+++ b/collects/planet/lang/reader.ss
@@ -6,13 +6,14 @@
                        [planet-get-info get-info]))
 
   (define-values (planet-read planet-read-syntax planet-get-info)
-    (make-meta-reader 'planet
-                      "planet path"
-                      (lambda (str)
-                        (let ([str (bytes->string/latin-1 str)])
-                          (if (module-path? `(planet ,(string->symbol str)))
-                              `(planet ,(string->symbol (string-append str "/lang/reader")))
-                              #f)))
-                      values
-                      values
-                      values)))
+    (make-meta-reader
+     'planet
+     "planet path"
+     (lambda (str)
+       (let ([str (bytes->string/latin-1 str)])
+         (if (module-path? `(planet ,(string->symbol str)))
+           `(planet ,(string->symbol (string-append str "/lang/reader")))
+           #f)))
+     values
+     values
+     values)))
diff --git a/collects/reader/lang/reader.ss b/collects/reader/lang/reader.ss
index 1c8ebd8c14..1473e045f9 100644
--- a/collects/reader/lang/reader.ss
+++ b/collects/reader/lang/reader.ss
@@ -6,11 +6,11 @@
                        [-get-info get-info]))
 
   (define-values (-read -read-syntax -get-info)
-    (make-meta-reader 'reader
-                      "language path"
-                      #:read-spec (lambda (in) (read in))
-                      (lambda (s)
-                        (and (module-path? s) s))
-                      values
-                      values
-                      values)))
+    (make-meta-reader
+     'reader
+     "language path"
+     #:read-spec (lambda (in) (read in))
+     (lambda (s) (and (module-path? s) s))
+     values
+     values
+     values)))
diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index eeb0c6483e..8d1dd31ece 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -21,41 +21,42 @@
                 (if (not (and (pair? body)
                               (pair? (cdr body))
                               (keyword? (syntax-e (car body)))))
-                    (datum->syntax stx body stx)
-                    (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)])
-                      (case k*
-                        [(kwd) (if var
-                                   (err (format "got two ~s keywords" k*) k)
-                                   (begin (set! var v) (loop (cddr body))))]
-                        ...
-                        [else (err "got an unknown keyword" (car body))])))))
+                  (datum->syntax stx body stx)
+                  (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)])
+                    (case k*
+                      [(kwd) (if var
+                               (err (format "got two ~s keywords" k*) k)
+                               (begin (set! var v) (loop (cddr body))))]
+                      ...
+                      [else (err "got an unknown keyword" (car body))])))))
         checks ...
         (unless var (set! var default)) ...))
     (define <lang-id> (datum->syntax stx 'language-module stx))
     (define <data-id> (datum->syntax stx 'language-data   stx))
     (define (construct-reader lang body)
       (keywords body
-                [#:language            ~lang                lang]
-                [#:read                ~read                #'read]
-                [#:read-syntax         ~read-syntax         #'read-syntax]
-                [#:wrapper1            ~wrapper1            #'#f]
-                [#:wrapper2            ~wrapper2            #'#f]
-                [#:whole-body-readers? ~whole-body-readers? #'#f]
-                [#:info                ~info                #'#f]
-                [(when (equal? (and lang #t) (and ~lang #t))
-                   (err (string-append
-                         "must specify either a module language, or #:language"
-                         (if (and lang ~lang) ", not both" ""))))
-                 (unless (equal? (and ~read #t) (and ~read-syntax #t))
-                   (err "must specify either both #:read and #:read-syntax, or none"))
-                 (when (and ~whole-body-readers? (not (and ~read ~read-syntax)))
-                   (err "got a #:whole-body-readers? without #:read and #:read-syntax"))])
-      ;; FIXME: a lot of the generated code is constant and should be lifted 
+        [#:language            ~lang                lang]
+        [#:read                ~read                #'read]
+        [#:read-syntax         ~read-syntax         #'read-syntax]
+        [#:wrapper1            ~wrapper1            #'#f]
+        [#:wrapper2            ~wrapper2            #'#f]
+        [#:whole-body-readers? ~whole-body-readers? #'#f]
+        [#:info                ~info                #'#f]
+        [(when (equal? (and lang #t) (and ~lang #t))
+           (err (string-append
+                 "must specify either a module language, or #:language"
+                 (if (and lang ~lang) ", not both" ""))))
+         (unless (equal? (and ~read #t) (and ~read-syntax #t))
+           (err "must specify either both #:read and #:read-syntax, or none"))
+         (when (and ~whole-body-readers? (not (and ~read ~read-syntax)))
+           (err "got a #:whole-body-readers? without #:read and #:read-syntax"))])
+      ;; FIXME: a lot of the generated code is constant and should be lifted
       ;; out of the template:
       (quasisyntax/loc stx
         (#%module-begin
          #,@body
-         (#%provide (rename lang:read read) (rename lang:read-syntax read-syntax)
+         (#%provide (rename lang:read read)
+                    (rename lang:read-syntax read-syntax)
                     read-properties get-info-getter get-info)
          (define (lang:read in modpath line col pos)
            (wrap-internal/wrapper #f #f in modpath line col pos))
@@ -66,41 +67,43 @@
                   [lang (car  props)] [#,<lang-id> lang] ;\ visible in
                   [data (cadr props)] [#,<data-id> data] ;/ user-code
                   [read (if stx?
-                            (let ([rd #,~read-syntax]) (lambda (in) (rd src in)))
-                            #,~read)]
+                          (let ([rd #,~read-syntax])
+                            (lambda (in) (rd src in)))
+                          #,~read)]
                   [w1 #,~wrapper1]
                   [w2 #,~wrapper2]
                   [whole? #,~whole-body-readers?]
-                  [rd (lambda (in) (wrap-internal (if (and (not stx?) (syntax? lang))
-                                                      (syntax->datum lang) 
-                                                      lang)
-                                                  in read whole? w1 stx?
-                                                  modpath src line col pos))]
+                  [rd (lambda (in)
+                        (wrap-internal (if (and (not stx?) (syntax? lang))
+                                         (syntax->datum lang)
+                                         lang)
+                                       in read whole? w1 stx?
+                                       modpath src line col pos))]
                   [r (cond [(not w2) (rd in)]
                            [(ar? w2 3) (w2 in rd stx?)]
                            [else (w2 in rd)])])
              (if stx?
-                 (syntax-property r 'module-language
-                                  (vector (syntax->datum modpath) 'get-info-getter
-                                          props))
-                 r)))
+               (syntax-property r
+                 'module-language
+                 (vector (syntax->datum modpath) 'get-info-getter props))
+               r)))
          (define lang*
            (let ([lang #,~lang])
              (if (not (procedure? lang))
-                 (list lang #f)
-                 (cond [(ar? lang 5) lang]
-                       [(ar? lang 1) (lambda (in . _) (lang in))]
-                       [(ar? lang 0) (lambda _ (lang))]
-                       [else (raise-type-error
-                              'syntax/module-reader
-                              "language+reader procedure of 5, 1, or 0 arguments"
-                              lang)]))))
+               (list lang #f)
+               (cond [(ar? lang 5) lang]
+                     [(ar? lang 1) (lambda (in . _) (lang in))]
+                     [(ar? lang 0) (lambda _ (lang))]
+                     [else (raise-type-error
+                            'syntax/module-reader
+                            "language+reader procedure of 5, 1, or 0 arguments"
+                            lang)]))))
          (define (read-properties in modpath line col pos)
            (if (not (procedure? lang*))
-               lang*
-               (call-with-values
-                   (lambda () (parameterize ([current-input-port in])
-                                (lang* in modpath line col pos)))
+             lang*
+             (call-with-values
+                 (lambda () (parameterize ([current-input-port in])
+                              (lang* in modpath line col pos)))
                  (lambda xs
                    (case (length xs)
                      [(2) xs] [(1) (list (car xs) #f)]
@@ -124,14 +127,14 @@
                     [#,<data-id> data] ;/ user-code
                     [info #,~info])
                (if (or (not info) (and (procedure? info) (ar? info 3)))
-                   info
-                   (raise-type-error 'syntax/module-reader
-                                     "info procedure of 3 arguments" info))))
+                 info
+                 (raise-type-error 'syntax/module-reader
+                                   "info procedure of 3 arguments" info))))
            (define (language-info what defval)
              (if info
-                 (let ([r (info what defval default-info)])
-                   (if (eq? r default-info) (default-info what defval) r))
-                 (default-info what defval)))
+               (let ([r (info what defval default-info)])
+                 (if (eq? r default-info) (default-info what defval) r))
+               (default-info what defval)))
            language-info))))
     (syntax-case stx ()
       [(_ lang body ...)
@@ -146,11 +149,9 @@
     ;; expression that begins with the literal #%module-begin.  If so,
     ;; it just returns that expression, else it wraps with #%module-begin.
     (define (wrap-#%module-begin exps stx?)
-      (define wrapped-exps 
+      (define wrapped-exps
         (let ([wrapped `(#%module-begin . ,exps)])
-          (if stx?
-              (datum->syntax #f wrapped)
-              wrapped)))
+          (if stx? (datum->syntax #f wrapped) wrapped)))
       (let ([exps (if stx? (syntax->list exps) exps)])
         (cond
           [(null? exps) wrapped-exps]
@@ -165,10 +166,12 @@
     (let* ([lang (if stx? (datum->syntax #f lang modpath modpath) lang)]
            [body (lambda ()
                    (if whole?
-                       (read port)
-                       (let loop ([a null])
-                         (let ([v (read port)])
-                           (if (eof-object? v) (reverse a) (loop (cons v a)))))))]
+                     (read port)
+                     (let loop ([a null])
+                       (let ([v (read port)])
+                         (if (eof-object? v)
+                           (reverse a)
+                           (loop (cons v a)))))))]
            [body (cond [(not wrapper)   (body)]
                        [(ar? wrapper 2) (wrapper body stx?)]
                        [else            (wrapper body)])]
@@ -176,25 +179,27 @@
                             (let-values ([(l c p) (port-next-location port)])
                               (and p (- p pos))))]
            [body (if (and stx? (not (syntax? body)))
-                     (datum->syntax #f body all-loc)
-                     body)]
+                   (datum->syntax #f body all-loc)
+                   body)]
            [p-name (object-name port)]
            [name (if (path? p-name)
-                     (let-values ([(base name dir?) (split-path p-name)])
-                       (string->symbol
-                        (path->string (path-replace-suffix name #""))))
-                     'page)]
+                   (let-values ([(base name dir?) (split-path p-name)])
+                     (string->symbol
+                      (path->string (path-replace-suffix name #""))))
+                   'page)]
            [tag-src (lambda (v)
                       (if stx?
-                          (datum->syntax
-                           #f v (vector src line col pos
-                                        (- (or (syntax-position modpath) (add1 pos))
-                                           pos)))
-                          v))]
-           ;; Since there are users that wrap with #%module-begin in their reader
-           ;; or wrapper1 functions, we need to avoid double-wrapping.  Having to
-           ;; do this for #lang readers should be considered deprecated, and
-           ;; hopefully one day we'll move to just doing it unilaterally.
+                        (datum->syntax
+                         #f v (vector src line col pos
+                                      (- (or (syntax-position modpath)
+                                             (add1 pos))
+                                         pos)))
+                        v))]
+           ;; Since there are users that wrap with #%module-begin in their
+           ;; reader or wrapper1 functions, we need to avoid double-wrapping.
+           ;; Having to do this for #lang readers should be considered
+           ;; deprecated, and hopefully one day we'll move to just doing it
+           ;; unilaterally.
            [wrapped-body (wrap-#%module-begin body stx?)]
            [r `(,(tag-src 'module) ,(tag-src name) ,lang ,wrapped-body)])
       (if stx? (datum->syntax #f r all-loc) r)))
@@ -202,18 +207,17 @@
   (define (wrap lang port read modpath src line col pos)
     (wrap-internal lang port read #f #f #f modpath src line col pos))
 
-  (define (make-meta-reader self-sym module-path-desc spec->module-path
-                            convert-read
-                            convert-read-syntax
-                            convert-get-info
-                            #:read-spec [read-spec
-                                         (lambda (in)
-                                           (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)])
-                                             (and spec
-                                                  (let ([s (cadr spec)])
-                                                    (if (equal? s "")
-                                                        #f
-                                                        s)))))])
+  (define (make-meta-reader
+           self-sym module-path-desc spec->module-path
+           convert-read
+           convert-read-syntax
+           convert-get-info
+           #:read-spec
+           [read-spec
+            (lambda (in)
+              (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)])
+                (and spec (let ([s (cadr spec)])
+                            (if (equal? s "") #f s)))))])
     (define (get in export-sym src line col pos mk-fail-thunk)
       (define (bad str eof?)
         ((if eof? raise-read-eof-error raise-read-error)
@@ -224,17 +228,20 @@
            (and pos pos2 (- pos2 pos)))))
       (define spec (read-spec in))
       (if (not spec)
-          (bad #f (eof-object? (peek-byte in)))
-          (let ([parsed-spec (spec->module-path spec)])
-            (if parsed-spec
-                (begin ((current-reader-guard) parsed-spec)
-                       (dynamic-require parsed-spec export-sym (mk-fail-thunk spec)))
-                (bad spec #f)))))
+        (bad #f (eof-object? (peek-byte in)))
+        (let ([parsed-spec (spec->module-path spec)])
+          (if parsed-spec
+            (begin ((current-reader-guard) parsed-spec)
+                   (dynamic-require parsed-spec export-sym
+                                    (mk-fail-thunk spec)))
+            (bad spec #f)))))
 
     (define (-get-info inp mod line col pos)
       (let ([r (get inp 'get-info (object-name inp) line col pos
-                    (lambda (spec) (lambda () (lambda (inp mod line col pos)
-                                                (lambda (tag defval) defval)))))])
+                    (lambda (spec)
+                      (lambda ()
+                        (lambda (inp mod line col pos)
+                          (lambda (tag defval) defval)))))])
         (convert-get-info (r inp mod line col pos))))
 
     (define (read-fn in read-sym args src mod line col pos convert)
@@ -245,14 +252,17 @@
                                self-sym
                                spec))))])
         (let ([r (convert r)])
-          (if (and (procedure? r) (procedure-arity-includes? r (+ 5 (length args))))
-              (apply r (append args (list in mod line col pos)))
-              (apply r (append args (list in)))))))
-    
+          (if (and (procedure? r)
+                   (procedure-arity-includes? r (+ 5 (length args))))
+            (apply r (append args (list in mod line col pos)))
+            (apply r (append args (list in)))))))
+
     (define (-read inp mod line col pos)
-      (read-fn inp 'read null (object-name inp) mod line col pos convert-read))
-    
+      (read-fn inp 'read null (object-name inp) mod line col pos
+               convert-read))
+
     (define (-read-syntax src inp mod line col pos)
-      (read-fn inp 'read-syntax (list src) src mod line col pos convert-read-syntax))
+      (read-fn inp 'read-syntax (list src) src mod line col pos
+               convert-read-syntax))
 
     (values -read -read-syntax -get-info)))
diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl
index 3b7f2c91a9..695cc879f8 100644
--- a/collects/syntax/scribblings/module-reader.scrbl
+++ b/collects/syntax/scribblings/module-reader.scrbl
@@ -290,7 +290,7 @@ are meant to be exported directly.}
 
 @emph{This function is deprecated; the
 @schememodname[syntax/module-reader] language can be adapted using the
-various keywords to arbitrary readers, and please use it instead.}
+various keywords to arbitrary readers; please use it instead.}
 
 Repeatedly calls @scheme[read] on @scheme[in] until an end of file,
 collecting the results in order into @scheme[_lst], and derives a

From 6ab2e7edad3d606fcdcb6d33868e6aaed8dd5909 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 05:53:15 +0000
Subject: [PATCH 102/136] A little simpler and a little more robust (eg, using
 source location for the wrapped body, and accepting any syntax/sexpr
 combination).

svn: r17197
---
 collects/syntax/module-reader.ss | 51 ++++++++++++++------------------
 1 file changed, 22 insertions(+), 29 deletions(-)

diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index 8d1dd31ece..15d2c2f075 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -142,27 +142,28 @@
        (construct-reader #''lang (syntax->list #'(body ...)))]
       [(_ body ...) (construct-reader #f (syntax->list #'(body ...)))]))
 
+  ;; Since there are users that wrap with `#%module-begin' in their reader
+  ;;   or wrapper1 functions, we need to avoid double-wrapping.  Having to do
+  ;;   this for #lang readers should be considered deprecated, and hopefully
+  ;;   one day we'll move to just doing it unilaterally (making this code throw
+  ;;   an error in that case before that's done).
+  ;; This function takes "body" as a sequence of expressions (can be syntaxes
+  ;;   and/or sexprs) and returns a new body as a *single* expression that is
+  ;;   wrapped in a `#%module-begin' -- using the input if it was a single
+  ;;   pre-wrapped expression.
+  (define (wrap-module-begin body)
+    (let ([exprs (if (syntax? body) (syntax->list body) body)])
+      (if (and (pair? exprs) (null? (cdr exprs))
+               (let* ([x (car exprs)]
+                      [x (if (syntax? x) (syntax-e x) x)]
+                      [x (and (pair? x) (car x))]
+                      [x (if (syntax? x) (syntax-e x) x)])
+                 (eq? x '#%module-begin)))
+        (car exprs)
+        (cons '#%module-begin body))))
+
   (define (wrap-internal lang port read whole? wrapper stx?
                          modpath src line col pos)
-    ;; Takes either a syntax object representing a list of expressions
-    ;; or a list of s-expressions, and checks to see if it's a single
-    ;; expression that begins with the literal #%module-begin.  If so,
-    ;; it just returns that expression, else it wraps with #%module-begin.
-    (define (wrap-#%module-begin exps stx?)
-      (define wrapped-exps
-        (let ([wrapped `(#%module-begin . ,exps)])
-          (if stx? (datum->syntax #f wrapped) wrapped)))
-      (let ([exps (if stx? (syntax->list exps) exps)])
-        (cond
-          [(null? exps) wrapped-exps]
-          [(not (null? (cdr exps))) wrapped-exps]
-          [else (let ([exp (if stx? (syntax-e (car exps)) (car exps))])
-                  (cond
-                    [(not (pair? exp)) wrapped-exps]
-                    [(eq? '#%module-begin
-                          (if stx? (syntax-e (car exp)) (car exp)))
-                     (car exps)]
-                    [else wrapped-exps]))])))
     (let* ([lang (if stx? (datum->syntax #f lang modpath modpath) lang)]
            [body (lambda ()
                    (if whole?
@@ -175,12 +176,10 @@
            [body (cond [(not wrapper)   (body)]
                        [(ar? wrapper 2) (wrapper body stx?)]
                        [else            (wrapper body)])]
+           [body (wrap-module-begin body)]
            [all-loc (vector src line col pos
                             (let-values ([(l c p) (port-next-location port)])
                               (and p (- p pos))))]
-           [body (if (and stx? (not (syntax? body)))
-                   (datum->syntax #f body all-loc)
-                   body)]
            [p-name (object-name port)]
            [name (if (path? p-name)
                    (let-values ([(base name dir?) (split-path p-name)])
@@ -195,13 +194,7 @@
                                              (add1 pos))
                                          pos)))
                         v))]
-           ;; Since there are users that wrap with #%module-begin in their
-           ;; reader or wrapper1 functions, we need to avoid double-wrapping.
-           ;; Having to do this for #lang readers should be considered
-           ;; deprecated, and hopefully one day we'll move to just doing it
-           ;; unilaterally.
-           [wrapped-body (wrap-#%module-begin body stx?)]
-           [r `(,(tag-src 'module) ,(tag-src name) ,lang ,wrapped-body)])
+           [r `(,(tag-src 'module) ,(tag-src name) ,lang ,body)])
       (if stx? (datum->syntax #f r all-loc) r)))
 
   (define (wrap lang port read modpath src line col pos)

From 3caf087c9748c9132fd08addcc7d6c5fa94bf538 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 05:54:22 +0000
Subject: [PATCH 103/136] error symbol typo

svn: r17198
---
 collects/syntax/module-reader.ss | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index 15d2c2f075..fddb3cf800 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -241,7 +241,7 @@
       (let ([r (get in read-sym src #|mod|# line col pos
                     (lambda (spec)
                       (lambda ()
-                        (error self-sym "cannot find reader for `#lang ~a ~a'"
+                        (error read-sym "cannot find reader for `#lang ~a ~a'"
                                self-sym
                                spec))))])
         (let ([r (convert r)])

From 2ea73bb1bdcd921f9604fb913bb03163e92892bb Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 08:35:37 +0000
Subject: [PATCH 104/136] Move some code outside of the main macro, a few other
 simplifications.

svn: r17202
---
 collects/syntax/module-reader.ss | 59 +++++++++++++++++---------------
 1 file changed, 32 insertions(+), 27 deletions(-)

diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index fddb3cf800..316f1137e5 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -50,8 +50,8 @@
            (err "must specify either both #:read and #:read-syntax, or none"))
          (when (and ~whole-body-readers? (not (and ~read ~read-syntax)))
            (err "got a #:whole-body-readers? without #:read and #:read-syntax"))])
-      ;; FIXME: a lot of the generated code is constant and should be lifted
-      ;; out of the template:
+      ;; FIXME: some generated code is constant and should be lifted out of the
+      ;; template:
       (quasisyntax/loc stx
         (#%module-begin
          #,@body
@@ -87,31 +87,7 @@
                  'module-language
                  (vector (syntax->datum modpath) 'get-info-getter props))
                r)))
-         (define lang*
-           (let ([lang #,~lang])
-             (if (not (procedure? lang))
-               (list lang #f)
-               (cond [(ar? lang 5) lang]
-                     [(ar? lang 1) (lambda (in . _) (lang in))]
-                     [(ar? lang 0) (lambda _ (lang))]
-                     [else (raise-type-error
-                            'syntax/module-reader
-                            "language+reader procedure of 5, 1, or 0 arguments"
-                            lang)]))))
-         (define (read-properties in modpath line col pos)
-           (if (not (procedure? lang*))
-             lang*
-             (call-with-values
-                 (lambda () (parameterize ([current-input-port in])
-                              (lang* in modpath line col pos)))
-                 (lambda xs
-                   (case (length xs)
-                     [(2) xs] [(1) (list (car xs) #f)]
-                     [else (error 'syntax/module-reader
-                                  "wrong number of results from ~a, ~a ~e"
-                                  "the #:language function"
-                                  "expected 1 or 2 values, got"
-                                  (length xs))])))))
+         (define read-properties (lang->read-properties #,~lang))
          (define (get-info in modpath line col pos)
            (get-info-getter (read-properties in modpath line col pos)))
          (define (get-info-getter props)
@@ -142,6 +118,35 @@
        (construct-reader #''lang (syntax->list #'(body ...)))]
       [(_ body ...) (construct-reader #f (syntax->list #'(body ...)))]))
 
+  ;; turns the language specification (either a language or some flavor of a
+  ;; function that returns a language and some properties) into a function that
+  ;; returns (list <lang> <props>)
+  (define (lang->read-properties lang)
+    (define lang*
+      (cond [(not (procedure? lang)) (list lang #f)]
+            [(ar? lang 5) lang]
+            [(ar? lang 1) (lambda (in . _) (lang in))]
+            [(ar? lang 0) (lambda _ (lang))]
+            [else (raise-type-error
+                   'syntax/module-reader
+                   "language+reader procedure of 5, 1, or 0 arguments"
+                   lang)]))
+    (define (read-properties in modpath line col pos)
+      (if (not (procedure? lang*))
+        lang*
+        (parameterize ([current-input-port in])
+          (call-with-values
+              (lambda () (lang* in modpath line col pos))
+              (lambda xs
+                (case (length xs)
+                  [(2) xs] [(1) (list (car xs) #f)]
+                  [else (error 'syntax/module-reader
+                               "wrong number of results from ~a, ~a ~e"
+                               "the #:language function"
+                               "expected 1 or 2 values, got"
+                               (length xs))]))))))
+    read-properties)
+
   ;; Since there are users that wrap with `#%module-begin' in their reader
   ;;   or wrapper1 functions, we need to avoid double-wrapping.  Having to do
   ;;   this for #lang readers should be considered deprecated, and hopefully

From 4df0d11db5f9308cd0616cc564b1ab51fd4cc41a Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 09:07:17 +0000
Subject: [PATCH 105/136] promise code moved to scheme/private

svn: r17205
---
 collects/scheme/mzscheme.ss        |   2 +-
 collects/scheme/private/promise.ss | 440 ++++++++++++++++++++++++++++
 collects/scheme/promise.ss         | 443 +----------------------------
 3 files changed, 444 insertions(+), 441 deletions(-)
 create mode 100644 collects/scheme/private/promise.ss

diff --git a/collects/scheme/mzscheme.ss b/collects/scheme/mzscheme.ss
index a5d78c657f..fff161e0c4 100644
--- a/collects/scheme/mzscheme.ss
+++ b/collects/scheme/mzscheme.ss
@@ -16,7 +16,7 @@
              "private/old-procs.ss"
              "private/map.ss" ; shadows #%kernel bindings
              "private/kernstruct.ss"
-             "promise.ss"
+             "private/promise.ss"
              (only "private/cond.ss" old-cond)
              "tcp.ss"
              "udp.ss"
diff --git a/collects/scheme/private/promise.ss b/collects/scheme/private/promise.ss
new file mode 100644
index 0000000000..6d2454585c
--- /dev/null
+++ b/collects/scheme/private/promise.ss
@@ -0,0 +1,440 @@
+(module promise '#%kernel
+(#%require "small-scheme.ss"
+           "more-scheme.ss"
+           "define.ss"
+           (rename "define-struct.ss" define-struct define-struct*)
+           (for-syntax '#%kernel "stxcase-scheme.ss" "name.ss")
+           '#%unsafe)
+(#%provide force promise? promise-forced? promise-running?)
+
+;; This module implements "lazy" (composable) promises and a `force'
+;; that is iterated through them.
+
+;; This is similar to the *new* version of srfi-45 -- see the
+;; post-finalization discussion at http://srfi.schemers.org/srfi-45/ for
+;; more details; specifically, this version is the `lazy2' version from
+;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html.
+;; Note: if you use only `force'+`delay' it behaves as in Scheme (except
+;; that `force' is identity for non promise values), and `force'+`lazy'
+;; are sufficient for implementing the lazy language.
+
+;; unsafe accessors
+(define-syntax pref  (syntax-rules () [(_ p) (unsafe-struct-ref p 0)]))
+(define-syntax pset! (syntax-rules () [(_ p x) (unsafe-struct-set! p 0 x)]))
+
+;; ----------------------------------------------------------------------------
+;; Forcers
+
+;; force/composable iterates on composable promises
+;; * (force X) = X for non promises
+;; * does not deal with multiple values in the composable case
+(define (force/composable root)
+  (let ([v (pref root)])
+    (cond
+      [(procedure? v)
+       ;; mark the root as running: avoids cycles, and no need to keep banging
+       ;; the root promise value; it makes this non-r5rs, but the only
+       ;; practical uses of these things could be ones that use state to avoid
+       ;; an infinite loop.  (See the generic forcer below.)
+       ;; (careful: avoid holding a reference to the thunk, to allow
+       ;; safe-for-space loops)
+       (pset! root (make-running (object-name v)))
+       (call-with-exception-handler
+        (lambda (e) (pset! root (make-reraise e)) e)
+        (lambda ()
+          ;; iterate carefully through chains of composable promises
+          (let loop ([v (v)]) ; does not handle multiple values!
+            (cond [(composable-promise? v)
+                   (let ([v* (pref v)])
+                     (pset! v root) ; share with root
+                     (cond [(procedure? v*) (loop (v*))]
+                           ;; it must be a list of one value (because
+                           ;; composable promises never hold multiple values),
+                           ;; or a composable promise
+                           [(pair? v*) (pset! root v*) (unsafe-car v*)]
+                           ;; note: for the promise case we could jump only to
+                           ;; the last `let' (for `v*'), but that makes the
+                           ;; code heavier, and runs slower (probably goes over
+                           ;; some inlining/unfolding threshold).
+                           [else (loop v*)]))]
+                  ;; reached a non-composable promise: share and force it now
+                  [(promise? v) (pset! root v) (force v)]
+                  ;; error here for "library approach" (see above URL)
+                  [else (pset! root (list v)) v]))))]
+      ;; try to make the order efficient, with common cases first
+      [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
+      ;; follow all sharings (and shortcut directly to the right force)
+      [(composable-promise? v) (force/composable v) (force v)]
+      [(null? v) (values)]
+      [else (error 'force "composable promise with invalid contents: ~e" v)])))
+
+(define (reify-result v)
+  (cond
+    [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
+    [(null? v) (values)]
+    [(reraise? v) (v)]
+    [else (error 'force "promise with invalid contents: ~e" v)]))
+
+;; generic force for "old-style" promises -- they're still useful in
+;; that they allow multiple values.  In general, this is slower, but has
+;; more features.  (They could allow self loops, but this means holding
+;; on to the procedure and its resources while it is running, and lose
+;; the ability to know that it is running; the second can be resolved
+;; with a new kind of `running' value that can be used again, but the
+;; first cannot be solved.  I still didn't ever see any use for them, so
+;; they're still forbidden.)
+(define (force/generic promise)
+  (reify-result
+   (let ([v (pref promise)])
+     (if (procedure? v)
+       (begin
+         (pset! promise (make-running (object-name v)))
+         (call-with-exception-handler
+          (lambda (e) (pset! promise (make-reraise e)) e)
+          (lambda ()
+            (let ([vs (call-with-values v list)]) (pset! promise vs) vs))))
+       v))))
+
+;; dispatcher for composable promises, generic promises, and other values
+(define (force promise)
+  (if (promise? promise)
+    ((promise-forcer promise) promise) ; dispatch to specific forcer
+    promise)) ; different from srfi-45: identity for non-promises
+
+;; ----------------------------------------------------------------------------
+;; Struct definitions
+
+;; generic promise printer
+(define (promise-printer promise port write?)
+  (let loop ([v (pref promise)])
+    (cond
+      [(reraise? v)
+       (let ([r (reraise-val v)])
+         (if (exn? r)
+           (fprintf port (if write? "#<promise!exn!~s>" "#<promise!exn!~a>")
+                    (exn-message r))
+           (fprintf port (if write? "#<promise!raise!~s>" "#<promise!raise!~a>")
+                    r)))]
+      [(running? v)
+       (let ([r (running-name v)])
+         (if r
+           (fprintf port "#<promise:!running!~a>" r)
+           (fprintf port "#<promise:!running>")))]
+      [(procedure? v)
+       (cond [(object-name v)
+              => (lambda (n) (fprintf port "#<promise:~a>" n))]
+             [else (display "#<promise>" port)])]
+      [(promise? v) (loop (pref v))] ; hide sharing
+      ;; values
+      [(null? v) (fprintf port "#<promise!(values)>")]
+      [(null? (cdr v))
+       (fprintf port (if write? "#<promise!~s>" "#<promise!~a>") (car v))]
+      [else (display "#<promise!(values" port)
+            (let ([fmt (if write? " ~s" " ~a")])
+              (for-each (lambda (x) (fprintf port fmt x)) v))
+            (display ")>" port)])))
+
+;; property value for the right forcer to use
+(define-values [prop:force promise-forcer]
+  (let-values ([(prop pred? get) ; no need for the predicate
+                (make-struct-type-property 'forcer
+                  (lambda (v info)
+                    (unless (and (procedure? v)
+                                 (procedure-arity-includes? v 1))
+                      (raise-type-error 'prop:force "a unary function" v))
+                    v))])
+    (values prop get)))
+
+;; A promise value can hold
+;; - (list <value> ...): forced promise (possibly multiple-values)
+;;        - composable promises deal with only one value
+;; - <promise>: a shared (redirected) promise that points at another one
+;;        - possible only with composable promises
+;; - <thunk>: usually a delayed promise,
+;;        - can also hold a `running' thunk that will throw a reentrant error
+;;        - can also hold a raising-a-value thunk on exceptions and other
+;;          `raise'd values (actually, applicable structs for printouts)
+;; First, a generic struct, which is used for all promise-like values
+(define-struct promise ([val #:mutable])
+  #:property prop:custom-write promise-printer
+  #:property prop:force force/generic)
+;; Then, a subtype for composable promises
+(define-struct (composable-promise promise) ()
+  #:property prop:force force/composable)
+
+;; template for all delay-like constructs
+;; (with simple keyword matching: keywords is an alist with default exprs)
+(define-for-syntax (make-delayer stx maker keywords)
+  ;; no `cond', `and', `or', `let', `define', etc here
+  (letrec-values
+      ([(exprs+kwds)
+        (lambda (stxs exprs kwds)
+          (if (null? stxs)
+            (values (reverse exprs) (reverse kwds))
+            (if (not (keyword? (syntax-e (car stxs))))
+              (exprs+kwds (cdr stxs) (cons (car stxs) exprs) kwds)
+              (if (if (pair? (cdr stxs))
+                    (if (assq (syntax-e (car stxs)) keywords)
+                      (not (assq (syntax-e (car stxs)) kwds))
+                      #f)
+                    #f)
+                (exprs+kwds (cddr stxs) exprs
+                            (cons (cons (syntax-e (car stxs)) (cadr stxs))
+                                  kwds))
+                (values #f #f)))))]
+       [(stxs) (syntax->list stx)]
+       [(exprs kwds) (exprs+kwds (if stxs (cdr stxs) '()) '() '())]
+       [(kwd-args) (if kwds
+                     (map (lambda (k)
+                            (let-values ([(x) (assq (car k) kwds)])
+                              (if x (cdr x) (cdr k))))
+                          keywords)
+                     #f)]
+       ;; some strange bug with `syntax-local-expand-expression' makes this not
+       ;; work well with identifiers, so turn the name into a symbol to work
+       ;; around this for now
+       [(name0) (syntax-local-infer-name stx)]
+       [(name) (if (syntax? name0) (syntax-e name0) name0)])
+    (syntax-case stx ()
+      [_ (pair? exprs) ; throw a syntax error if anything is wrong
+         (with-syntax ([(expr ...) exprs]
+                       [(kwd-arg ...) kwd-args])
+           (with-syntax ([proc (syntax-property
+                                (syntax/loc stx (lambda () expr ...))
+                                'inferred-name name)]
+                         [make maker])
+             (syntax/loc stx (make proc kwd-arg ...))))])))
+
+;; Creates a composable promise
+;;   X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X))
+(#%provide (rename lazy* lazy))
+(define lazy make-composable-promise)
+(define-syntax (lazy* stx) (make-delayer stx #'lazy '()))
+
+;; Creates a (generic) promise that does not compose
+;;   X = (force (delay X)) = (force (lazy (delay X)))
+;;                         = (force (lazy^n (delay X)))
+;;   X = (force (force (delay (delay X)))) != (force (delay (delay X)))
+;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a
+;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0)
+;; (This is not needed with a lazy language (see the above URL for details),
+;; but provided for regular delay/force uses.)
+(#%provide (rename delay* delay))
+(define delay make-promise)
+(define-syntax (delay* stx) (make-delayer stx #'delay '()))
+
+;; For simplicity and efficiency this code uses thunks in promise values for
+;; exceptions: this way, we don't need to tag exception values in some special
+;; way and test for them -- we just use a thunk that will raise the exception.
+;; But it's still useful to refer to the exception value, so use an applicable
+;; struct for them.  The same goes for a promise that is being forced: we use a
+;; thunk that will throw a "reentrant promise" error -- and use an applicable
+;; struct so it is identifiable.
+(define-struct reraise (val)
+  #:property prop:procedure (lambda (this) (raise (reraise-val this))))
+(define-struct running (name)
+  #:property prop:procedure (lambda (this)
+                              (let ([name (running-name this)])
+                                (if name
+                                  (error 'force "reentrant promise ~e" name)
+                                  (error 'force "reentrant promise")))))
+
+;; ----------------------------------------------------------------------------
+;; Utilities
+
+(define (promise-forced? promise)
+  (if (promise? promise)
+    (let ([v (pref promise)])
+      (or (not (procedure? v)) (reraise? v))) ; #f when running
+    (raise-type-error 'promise-forced? "promise" promise)))
+
+(define (promise-running? promise)
+  (if (promise? promise)
+    (running? (pref promise))
+    (raise-type-error 'promise-running? "promise" promise)))
+
+;; ----------------------------------------------------------------------------
+;; More delay-like values, with different ways of deferring computations
+
+(define-struct (promise/name promise) ()
+  #:property prop:force (lambda (p) ((pref p))))
+
+(#%provide (rename delay/name* delay/name))
+(define delay/name make-promise/name)
+(define-syntax (delay/name* stx) (make-delayer stx #'delay/name '()))
+
+;; utility struct
+(define-struct (running-thread running) (thread))
+
+;; used in promise/sync until it's forced
+(define-struct syncinfo ([thunk #:mutable] done-evt done-sema access-sema))
+
+(define-struct (promise/sync promise) ()
+  #:property prop:custom-write
+  (lambda (p port write?)
+    (promise-printer
+     (let ([v (pref p)])
+       (if (syncinfo? v) (make-promise (syncinfo-thunk v)) p))
+     port write?))
+  #:property prop:force
+  (lambda (p)
+    (reify-result
+     (let ([v (pref p)])
+       (cond
+         ;; already forced
+         [(not (syncinfo? v)) v]
+         ;; being forced...
+         [(running-thread? (syncinfo-thunk v))
+          (let ([r (syncinfo-thunk v)])
+            (if (eq? (running-thread-thread r) (current-thread))
+              ;; ... by the current thread => throw the usual reentrant error
+              (r)
+              ;; ... by a different thread => just wait for it
+              (begin (sync (syncinfo-done-evt v)) (pref p))))]
+         [else
+          ;; wasn't forced yet: try to do it now
+          (call-with-semaphore (syncinfo-access-sema v)
+            (lambda ()
+              (let ([thunk (syncinfo-thunk v)] [done (syncinfo-done-sema v)])
+                ;; set the thread last
+                (set-syncinfo-thunk!
+                 v (make-running-thread (object-name thunk) (current-thread)))
+                (call-with-exception-handler
+                 (lambda (e)
+                   (pset! p (make-reraise e))
+                   (semaphore-post done)
+                   e)
+                 (lambda ()
+                   (pset! p (call-with-values thunk list))
+                   (semaphore-post done))))))
+          ;; whether it was this thread that forced it or not, the results are
+          ;; now in
+          (pref p)]))))
+  #:property prop:evt
+  (lambda (p)
+    (let ([v (pref p)])
+      (handle-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void))))
+
+(#%provide (rename delay/sync* delay/sync))
+(define (delay/sync thunk)
+  (let ([done-sema (make-semaphore 0)])
+    (make-promise/sync (make-syncinfo thunk
+                                      (semaphore-peek-evt done-sema) done-sema
+                                      (make-semaphore 1)))))
+(define-syntax (delay/sync* stx) (make-delayer stx #'delay/sync '()))
+
+;; threaded promises
+
+(define-struct (promise/thread promise) ()
+  #:property prop:force
+  (lambda (p)
+    (reify-result (let ([v (pref p)])
+                    (if (running-thread? v)
+                      (begin (thread-wait (running-thread-thread v))
+                             (pref p))
+                      v))))
+  #:property prop:evt
+  (lambda (p)
+    (let ([v (pref p)])
+      (handle-evt (if (running? v) (running-thread-thread v) always-evt)
+                  void))))
+
+(#%provide (rename delay/thread* delay/thread))
+(define (delay/thread thunk group)
+  (define (run)
+    (call-with-exception-handler
+     (lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
+     (lambda () (pset! p (call-with-values thunk list)))))
+  (define p
+    (make-promise/thread
+     (make-running-thread
+      (object-name thunk)
+      (if group
+        (parameterize ([current-thread-group (make-thread-group)]) (thread run))
+        (thread run)))))
+  p)
+(define-syntax delay/thread*
+  (let-values ([(kwds) (list (cons '#:group #'#t))])
+    (lambda (stx) (make-delayer stx #'delay/thread kwds))))
+
+(define-struct (promise/idle promise/thread) ()
+  #:property prop:force
+  (lambda (p)
+    (reify-result (let ([v (pref p)])
+                    (if (procedure? v)
+                      ;; either running-thread, or returns the controller
+                      (let ([controller (if (running-thread? v)
+                                          (running-thread-thread v)
+                                          (v))])
+                        (thread-send controller 'force!)
+                        (thread-wait controller)
+                        (pref p))
+                      v)))))
+
+(#%provide (rename delay/idle* delay/idle))
+(define (delay/idle thunk wait-for work-while tick use*)
+  (define use (cond [(use* . <= . 0) 0] [(use* . >= . 1) 1] [else use*]))
+  (define work-time (* tick use))
+  (define rest-time (- tick work-time))
+  (define (work)
+    (call-with-exception-handler
+     (lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
+     (lambda () (pset! p (call-with-values thunk list)))))
+  (define (run)
+    ;; this thread is dedicated to controlling the worker thread, so it's
+    ;; possible to dedicate messages to signaling a `force'.
+    (define force-evt (thread-receive-evt))
+    (sync wait-for force-evt)
+    (pset! p (make-running-thread (object-name thunk) controller-thread))
+    (let ([worker (parameterize ([current-thread-group (make-thread-group)])
+                    (thread work))])
+      (cond
+        [(and (use . >= . 1) (equal? work-while always-evt))
+         ;; as if it was pre-forced
+         (thread-wait worker)]
+        [(use . <= . 0)
+         ;; work only when explicitly forced
+         (thread-suspend worker)
+         (sync force-evt)
+         (thread-wait worker)]
+        [else
+         (thread-suspend worker)
+         (let loop ()
+           ;; rest, then wait for idle time, then resume working
+           (if (eq? (begin0 (or (sync/timeout rest-time force-evt)
+                                (sync work-while force-evt))
+                      (thread-resume worker))
+                    force-evt)
+             ;; forced during one of these => let it run to completion
+             (thread-wait worker)
+             ;; not forced
+             (unless (sync/timeout work-time worker)
+               (thread-suspend worker)
+               (loop))))])))
+  ;; I don't think that a thread-group here is needed, but it doesn't hurt
+  (define controller-thread
+    (parameterize ([current-thread-group (make-thread-group)])
+      (thread run)))
+  ;; the thunk is not really used in the above, make it a function that returns
+  ;; the controller thread so it can be forced (used in the `prop:force')
+  (define p (make-promise/idle
+             (procedure-rename (lambda () controller-thread)
+                               (or (object-name thunk) 'idle-thread))))
+  p)
+(define-syntax delay/idle*
+  (let-values ([(kwds) (list (cons '#:wait-for #'(system-idle-evt))
+                             (cons '#:work-while #'(system-idle-evt))
+                             (cons '#:tick #'0.2)
+                             (cons '#:use #'0.12))])
+    (lambda (stx) (make-delayer stx #'delay/idle kwds))))
+
+)
+
+#|
+Simple code for timings:
+  (define (c n) (lazy (if (zero? n) (delay 'hey!) (c (sub1 n)))))
+  (for ([i (in-range 9)])
+    (collect-garbage) (collect-garbage) (collect-garbage)
+    (time (for ([i (in-range 10000)]) (force (c 2000)))))
+Also, run (force (c -1)) and check constant space
+|#
diff --git a/collects/scheme/promise.ss b/collects/scheme/promise.ss
index 755ef5e516..b6a3844f36 100644
--- a/collects/scheme/promise.ss
+++ b/collects/scheme/promise.ss
@@ -1,440 +1,3 @@
-(module promise '#%kernel
-(#%require "private/small-scheme.ss"
-           "private/more-scheme.ss"
-           "private/define.ss"
-           (rename "private/define-struct.ss" define-struct define-struct*)
-           (for-syntax '#%kernel "private/stxcase-scheme.ss" "private/name.ss")
-           '#%unsafe)
-(#%provide force promise? promise-forced? promise-running?)
-
-;; This module implements "lazy" (composable) promises and a `force'
-;; that is iterated through them.
-
-;; This is similar to the *new* version of srfi-45 -- see the
-;; post-finalization discussion at http://srfi.schemers.org/srfi-45/ for
-;; more details; specifically, this version is the `lazy2' version from
-;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html.
-;; Note: if you use only `force'+`delay' it behaves as in Scheme (except
-;; that `force' is identity for non promise values), and `force'+`lazy'
-;; are sufficient for implementing the lazy language.
-
-;; unsafe accessors
-(define-syntax pref  (syntax-rules () [(_ p) (unsafe-struct-ref p 0)]))
-(define-syntax pset! (syntax-rules () [(_ p x) (unsafe-struct-set! p 0 x)]))
-
-;; ----------------------------------------------------------------------------
-;; Forcers
-
-;; force/composable iterates on composable promises
-;; * (force X) = X for non promises
-;; * does not deal with multiple values in the composable case
-(define (force/composable root)
-  (let ([v (pref root)])
-    (cond
-      [(procedure? v)
-       ;; mark the root as running: avoids cycles, and no need to keep banging
-       ;; the root promise value; it makes this non-r5rs, but the only
-       ;; practical uses of these things could be ones that use state to avoid
-       ;; an infinite loop.  (See the generic forcer below.)
-       ;; (careful: avoid holding a reference to the thunk, to allow
-       ;; safe-for-space loops)
-       (pset! root (make-running (object-name v)))
-       (call-with-exception-handler
-        (lambda (e) (pset! root (make-reraise e)) e)
-        (lambda ()
-          ;; iterate carefully through chains of composable promises
-          (let loop ([v (v)]) ; does not handle multiple values!
-            (cond [(composable-promise? v)
-                   (let ([v* (pref v)])
-                     (pset! v root) ; share with root
-                     (cond [(procedure? v*) (loop (v*))]
-                           ;; it must be a list of one value (because
-                           ;; composable promises never hold multiple values),
-                           ;; or a composable promise
-                           [(pair? v*) (pset! root v*) (unsafe-car v*)]
-                           ;; note: for the promise case we could jump only to
-                           ;; the last `let' (for `v*'), but that makes the
-                           ;; code heavier, and runs slower (probably goes over
-                           ;; some inlining/unfolding threshold).
-                           [else (loop v*)]))]
-                  ;; reached a non-composable promise: share and force it now
-                  [(promise? v) (pset! root v) (force v)]
-                  ;; error here for "library approach" (see above URL)
-                  [else (pset! root (list v)) v]))))]
-      ;; try to make the order efficient, with common cases first
-      [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
-      ;; follow all sharings (and shortcut directly to the right force)
-      [(composable-promise? v) (force/composable v) (force v)]
-      [(null? v) (values)]
-      [else (error 'force "composable promise with invalid contents: ~e" v)])))
-
-(define (reify-result v)
-  (cond
-    [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
-    [(null? v) (values)]
-    [(reraise? v) (v)]
-    [else (error 'force "promise with invalid contents: ~e" v)]))
-
-;; generic force for "old-style" promises -- they're still useful in
-;; that they allow multiple values.  In general, this is slower, but has
-;; more features.  (They could allow self loops, but this means holding
-;; on to the procedure and its resources while it is running, and lose
-;; the ability to know that it is running; the second can be resolved
-;; with a new kind of `running' value that can be used again, but the
-;; first cannot be solved.  I still didn't ever see any use for them, so
-;; they're still forbidden.)
-(define (force/generic promise)
-  (reify-result
-   (let ([v (pref promise)])
-     (if (procedure? v)
-       (begin
-         (pset! promise (make-running (object-name v)))
-         (call-with-exception-handler
-          (lambda (e) (pset! promise (make-reraise e)) e)
-          (lambda ()
-            (let ([vs (call-with-values v list)]) (pset! promise vs) vs))))
-       v))))
-
-;; dispatcher for composable promises, generic promises, and other values
-(define (force promise)
-  (if (promise? promise)
-    ((promise-forcer promise) promise) ; dispatch to specific forcer
-    promise)) ; different from srfi-45: identity for non-promises
-
-;; ----------------------------------------------------------------------------
-;; Struct definitions
-
-;; generic promise printer
-(define (promise-printer promise port write?)
-  (let loop ([v (pref promise)])
-    (cond
-      [(reraise? v)
-       (let ([r (reraise-val v)])
-         (if (exn? r)
-           (fprintf port (if write? "#<promise!exn!~s>" "#<promise!exn!~a>")
-                    (exn-message r))
-           (fprintf port (if write? "#<promise!raise!~s>" "#<promise!raise!~a>")
-                    r)))]
-      [(running? v)
-       (let ([r (running-name v)])
-         (if r
-           (fprintf port "#<promise:!running!~a>" r)
-           (fprintf port "#<promise:!running>")))]
-      [(procedure? v)
-       (cond [(object-name v)
-              => (lambda (n) (fprintf port "#<promise:~a>" n))]
-             [else (display "#<promise>" port)])]
-      [(promise? v) (loop (pref v))] ; hide sharing
-      ;; values
-      [(null? v) (fprintf port "#<promise!(values)>")]
-      [(null? (cdr v))
-       (fprintf port (if write? "#<promise!~s>" "#<promise!~a>") (car v))]
-      [else (display "#<promise!(values" port)
-            (let ([fmt (if write? " ~s" " ~a")])
-              (for-each (lambda (x) (fprintf port fmt x)) v))
-            (display ")>" port)])))
-
-;; property value for the right forcer to use
-(define-values [prop:force promise-forcer]
-  (let-values ([(prop pred? get) ; no need for the predicate
-                (make-struct-type-property 'forcer
-                  (lambda (v info)
-                    (unless (and (procedure? v)
-                                 (procedure-arity-includes? v 1))
-                      (raise-type-error 'prop:force "a unary function" v))
-                    v))])
-    (values prop get)))
-
-;; A promise value can hold
-;; - (list <value> ...): forced promise (possibly multiple-values)
-;;        - composable promises deal with only one value
-;; - <promise>: a shared (redirected) promise that points at another one
-;;        - possible only with composable promises
-;; - <thunk>: usually a delayed promise,
-;;        - can also hold a `running' thunk that will throw a reentrant error
-;;        - can also hold a raising-a-value thunk on exceptions and other
-;;          `raise'd values (actually, applicable structs for printouts)
-;; First, a generic struct, which is used for all promise-like values
-(define-struct promise ([val #:mutable])
-  #:property prop:custom-write promise-printer
-  #:property prop:force force/generic)
-;; Then, a subtype for composable promises
-(define-struct (composable-promise promise) ()
-  #:property prop:force force/composable)
-
-;; template for all delay-like constructs
-;; (with simple keyword matching: keywords is an alist with default exprs)
-(define-for-syntax (make-delayer stx maker keywords)
-  ;; no `cond', `and', `or', `let', `define', etc here
-  (letrec-values
-      ([(exprs+kwds)
-        (lambda (stxs exprs kwds)
-          (if (null? stxs)
-            (values (reverse exprs) (reverse kwds))
-            (if (not (keyword? (syntax-e (car stxs))))
-              (exprs+kwds (cdr stxs) (cons (car stxs) exprs) kwds)
-              (if (if (pair? (cdr stxs))
-                    (if (assq (syntax-e (car stxs)) keywords)
-                      (not (assq (syntax-e (car stxs)) kwds))
-                      #f)
-                    #f)
-                (exprs+kwds (cddr stxs) exprs
-                            (cons (cons (syntax-e (car stxs)) (cadr stxs))
-                                  kwds))
-                (values #f #f)))))]
-       [(stxs) (syntax->list stx)]
-       [(exprs kwds) (exprs+kwds (if stxs (cdr stxs) '()) '() '())]
-       [(kwd-args) (if kwds
-                     (map (lambda (k)
-                            (let-values ([(x) (assq (car k) kwds)])
-                              (if x (cdr x) (cdr k))))
-                          keywords)
-                     #f)]
-       ;; some strange bug with `syntax-local-expand-expression' makes this not
-       ;; work well with identifiers, so turn the name into a symbol to work
-       ;; around this for now
-       [(name0) (syntax-local-infer-name stx)]
-       [(name) (if (syntax? name0) (syntax-e name0) name0)])
-    (syntax-case stx ()
-      [_ (pair? exprs) ; throw a syntax error if anything is wrong
-         (with-syntax ([(expr ...) exprs]
-                       [(kwd-arg ...) kwd-args])
-           (with-syntax ([proc (syntax-property
-                                (syntax/loc stx (lambda () expr ...))
-                                'inferred-name name)]
-                         [make maker])
-             (syntax/loc stx (make proc kwd-arg ...))))])))
-
-;; Creates a composable promise
-;;   X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X))
-(#%provide (rename lazy* lazy))
-(define lazy make-composable-promise)
-(define-syntax (lazy* stx) (make-delayer stx #'lazy '()))
-
-;; Creates a (generic) promise that does not compose
-;;   X = (force (delay X)) = (force (lazy (delay X)))
-;;                         = (force (lazy^n (delay X)))
-;;   X = (force (force (delay (delay X)))) != (force (delay (delay X)))
-;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a
-;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0)
-;; (This is not needed with a lazy language (see the above URL for details),
-;; but provided for regular delay/force uses.)
-(#%provide (rename delay* delay))
-(define delay make-promise)
-(define-syntax (delay* stx) (make-delayer stx #'delay '()))
-
-;; For simplicity and efficiency this code uses thunks in promise values for
-;; exceptions: this way, we don't need to tag exception values in some special
-;; way and test for them -- we just use a thunk that will raise the exception.
-;; But it's still useful to refer to the exception value, so use an applicable
-;; struct for them.  The same goes for a promise that is being forced: we use a
-;; thunk that will throw a "reentrant promise" error -- and use an applicable
-;; struct so it is identifiable.
-(define-struct reraise (val)
-  #:property prop:procedure (lambda (this) (raise (reraise-val this))))
-(define-struct running (name)
-  #:property prop:procedure (lambda (this)
-                              (let ([name (running-name this)])
-                                (if name
-                                  (error 'force "reentrant promise ~e" name)
-                                  (error 'force "reentrant promise")))))
-
-;; ----------------------------------------------------------------------------
-;; Utilities
-
-(define (promise-forced? promise)
-  (if (promise? promise)
-    (let ([v (pref promise)])
-      (or (not (procedure? v)) (reraise? v))) ; #f when running
-    (raise-type-error 'promise-forced? "promise" promise)))
-
-(define (promise-running? promise)
-  (if (promise? promise)
-    (running? (pref promise))
-    (raise-type-error 'promise-running? "promise" promise)))
-
-;; ----------------------------------------------------------------------------
-;; More delay-like values, with different ways of deferring computations
-
-(define-struct (promise/name promise) ()
-  #:property prop:force (lambda (p) ((pref p))))
-
-(#%provide (rename delay/name* delay/name))
-(define delay/name make-promise/name)
-(define-syntax (delay/name* stx) (make-delayer stx #'delay/name '()))
-
-;; utility struct
-(define-struct (running-thread running) (thread))
-
-;; used in promise/sync until it's forced
-(define-struct syncinfo ([thunk #:mutable] done-evt done-sema access-sema))
-
-(define-struct (promise/sync promise) ()
-  #:property prop:custom-write
-  (lambda (p port write?)
-    (promise-printer
-     (let ([v (pref p)])
-       (if (syncinfo? v) (make-promise (syncinfo-thunk v)) p))
-     port write?))
-  #:property prop:force
-  (lambda (p)
-    (reify-result
-     (let ([v (pref p)])
-       (cond
-         ;; already forced
-         [(not (syncinfo? v)) v]
-         ;; being forced...
-         [(running-thread? (syncinfo-thunk v))
-          (let ([r (syncinfo-thunk v)])
-            (if (eq? (running-thread-thread r) (current-thread))
-              ;; ... by the current thread => throw the usual reentrant error
-              (r)
-              ;; ... by a different thread => just wait for it
-              (begin (sync (syncinfo-done-evt v)) (pref p))))]
-         [else
-          ;; wasn't forced yet: try to do it now
-          (call-with-semaphore (syncinfo-access-sema v)
-            (lambda ()
-              (let ([thunk (syncinfo-thunk v)] [done (syncinfo-done-sema v)])
-                ;; set the thread last
-                (set-syncinfo-thunk!
-                 v (make-running-thread (object-name thunk) (current-thread)))
-                (call-with-exception-handler
-                 (lambda (e)
-                   (pset! p (make-reraise e))
-                   (semaphore-post done)
-                   e)
-                 (lambda ()
-                   (pset! p (call-with-values thunk list))
-                   (semaphore-post done))))))
-          ;; whether it was this thread that forced it or not, the results are
-          ;; now in
-          (pref p)]))))
-  #:property prop:evt
-  (lambda (p)
-    (let ([v (pref p)])
-      (handle-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void))))
-
-(#%provide (rename delay/sync* delay/sync))
-(define (delay/sync thunk)
-  (let ([done-sema (make-semaphore 0)])
-    (make-promise/sync (make-syncinfo thunk
-                                      (semaphore-peek-evt done-sema) done-sema
-                                      (make-semaphore 1)))))
-(define-syntax (delay/sync* stx) (make-delayer stx #'delay/sync '()))
-
-;; threaded promises
-
-(define-struct (promise/thread promise) ()
-  #:property prop:force
-  (lambda (p)
-    (reify-result (let ([v (pref p)])
-                    (if (running-thread? v)
-                      (begin (thread-wait (running-thread-thread v))
-                             (pref p))
-                      v))))
-  #:property prop:evt
-  (lambda (p)
-    (let ([v (pref p)])
-      (handle-evt (if (running? v) (running-thread-thread v) always-evt)
-                  void))))
-
-(#%provide (rename delay/thread* delay/thread))
-(define (delay/thread thunk group)
-  (define (run)
-    (call-with-exception-handler
-     (lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
-     (lambda () (pset! p (call-with-values thunk list)))))
-  (define p
-    (make-promise/thread
-     (make-running-thread
-      (object-name thunk)
-      (if group
-        (parameterize ([current-thread-group (make-thread-group)]) (thread run))
-        (thread run)))))
-  p)
-(define-syntax delay/thread*
-  (let-values ([(kwds) (list (cons '#:group #'#t))])
-    (lambda (stx) (make-delayer stx #'delay/thread kwds))))
-
-(define-struct (promise/idle promise/thread) ()
-  #:property prop:force
-  (lambda (p)
-    (reify-result (let ([v (pref p)])
-                    (if (procedure? v)
-                      ;; either running-thread, or returns the controller
-                      (let ([controller (if (running-thread? v)
-                                          (running-thread-thread v)
-                                          (v))])
-                        (thread-send controller 'force!)
-                        (thread-wait controller)
-                        (pref p))
-                      v)))))
-
-(#%provide (rename delay/idle* delay/idle))
-(define (delay/idle thunk wait-for work-while tick use*)
-  (define use (cond [(use* . <= . 0) 0] [(use* . >= . 1) 1] [else use*]))
-  (define work-time (* tick use))
-  (define rest-time (- tick work-time))
-  (define (work)
-    (call-with-exception-handler
-     (lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
-     (lambda () (pset! p (call-with-values thunk list)))))
-  (define (run)
-    ;; this thread is dedicated to controlling the worker thread, so it's
-    ;; possible to dedicate messages to signaling a `force'.
-    (define force-evt (thread-receive-evt))
-    (sync wait-for force-evt)
-    (pset! p (make-running-thread (object-name thunk) controller-thread))
-    (let ([worker (parameterize ([current-thread-group (make-thread-group)])
-                    (thread work))])
-      (cond
-        [(and (use . >= . 1) (equal? work-while always-evt))
-         ;; as if it was pre-forced
-         (thread-wait worker)]
-        [(use . <= . 0)
-         ;; work only when explicitly forced
-         (thread-suspend worker)
-         (sync force-evt)
-         (thread-wait worker)]
-        [else
-         (thread-suspend worker)
-         (let loop ()
-           ;; rest, then wait for idle time, then resume working
-           (if (eq? (begin0 (or (sync/timeout rest-time force-evt)
-                                (sync work-while force-evt))
-                      (thread-resume worker))
-                    force-evt)
-             ;; forced during one of these => let it run to completion
-             (thread-wait worker)
-             ;; not forced
-             (unless (sync/timeout work-time worker)
-               (thread-suspend worker)
-               (loop))))])))
-  ;; I don't think that a thread-group here is needed, but it doesn't hurt
-  (define controller-thread
-    (parameterize ([current-thread-group (make-thread-group)])
-      (thread run)))
-  ;; the thunk is not really used in the above, make it a function that returns
-  ;; the controller thread so it can be forced (used in the `prop:force')
-  (define p (make-promise/idle
-             (procedure-rename (lambda () controller-thread)
-                               (or (object-name thunk) 'idle-thread))))
-  p)
-(define-syntax delay/idle*
-  (let-values ([(kwds) (list (cons '#:wait-for #'(system-idle-evt))
-                             (cons '#:work-while #'(system-idle-evt))
-                             (cons '#:tick #'0.2)
-                             (cons '#:use #'0.12))])
-    (lambda (stx) (make-delayer stx #'delay/idle kwds))))
-
-)
-
-#|
-Simple code for timings:
-  (define (c n) (lazy (if (zero? n) (delay 'hey!) (c (sub1 n)))))
-  (for ([i (in-range 9)])
-    (collect-garbage) (collect-garbage) (collect-garbage)
-    (time (for ([i (in-range 10000)]) (force (c 2000)))))
-Also, run (force (c -1)) and check constant space
-|#
+#lang scheme/base
+(require "private/promise.ss")
+(provide (all-from-out "private/promise.ss"))

From 9cc6cd0db45546f7c645b6b4074e3e0e1d5023b3 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 09:28:41 +0000
Subject: [PATCH 106/136] moved extra promise types back to scheme/promise

svn: r17207
---
 collects/scheme/private/promise.ss | 193 ++---------------------------
 collects/scheme/promise.ss         | 179 +++++++++++++++++++++++++-
 2 files changed, 188 insertions(+), 184 deletions(-)

diff --git a/collects/scheme/private/promise.ss b/collects/scheme/private/promise.ss
index 6d2454585c..314f073e46 100644
--- a/collects/scheme/private/promise.ss
+++ b/collects/scheme/private/promise.ss
@@ -5,7 +5,12 @@
            (rename "define-struct.ss" define-struct define-struct*)
            (for-syntax '#%kernel "stxcase-scheme.ss" "name.ss")
            '#%unsafe)
-(#%provide force promise? promise-forced? promise-running?)
+(#%provide force promise? promise-forced? promise-running?
+           ;; provided to create extensions
+           (struct promise ()) pref pset! prop:force reify-result
+           promise-printer
+           (struct running ()) (struct reraise ())
+           (for-syntax make-delayer))
 
 ;; This module implements "lazy" (composable) promises and a `force'
 ;; that is iterated through them.
@@ -19,7 +24,7 @@
 ;; are sufficient for implementing the lazy language.
 
 ;; unsafe accessors
-(define-syntax pref  (syntax-rules () [(_ p) (unsafe-struct-ref p 0)]))
+(define-syntax pref  (syntax-rules () [(_ p  ) (unsafe-struct-ref  p 0  )]))
 (define-syntax pset! (syntax-rules () [(_ p x) (unsafe-struct-set! p 0 x)]))
 
 ;; ----------------------------------------------------------------------------
@@ -69,11 +74,10 @@
       [else (error 'force "composable promise with invalid contents: ~e" v)])))
 
 (define (reify-result v)
-  (cond
-    [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
-    [(null? v) (values)]
-    [(reraise? v) (v)]
-    [else (error 'force "promise with invalid contents: ~e" v)]))
+  (cond [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
+        [(null? v) (values)]
+        [(reraise? v) (v)]
+        [else (error 'force "promise with invalid contents: ~e" v)]))
 
 ;; generic force for "old-style" promises -- they're still useful in
 ;; that they allow multiple values.  In general, this is slower, but has
@@ -253,181 +257,6 @@
     (running? (pref promise))
     (raise-type-error 'promise-running? "promise" promise)))
 
-;; ----------------------------------------------------------------------------
-;; More delay-like values, with different ways of deferring computations
-
-(define-struct (promise/name promise) ()
-  #:property prop:force (lambda (p) ((pref p))))
-
-(#%provide (rename delay/name* delay/name))
-(define delay/name make-promise/name)
-(define-syntax (delay/name* stx) (make-delayer stx #'delay/name '()))
-
-;; utility struct
-(define-struct (running-thread running) (thread))
-
-;; used in promise/sync until it's forced
-(define-struct syncinfo ([thunk #:mutable] done-evt done-sema access-sema))
-
-(define-struct (promise/sync promise) ()
-  #:property prop:custom-write
-  (lambda (p port write?)
-    (promise-printer
-     (let ([v (pref p)])
-       (if (syncinfo? v) (make-promise (syncinfo-thunk v)) p))
-     port write?))
-  #:property prop:force
-  (lambda (p)
-    (reify-result
-     (let ([v (pref p)])
-       (cond
-         ;; already forced
-         [(not (syncinfo? v)) v]
-         ;; being forced...
-         [(running-thread? (syncinfo-thunk v))
-          (let ([r (syncinfo-thunk v)])
-            (if (eq? (running-thread-thread r) (current-thread))
-              ;; ... by the current thread => throw the usual reentrant error
-              (r)
-              ;; ... by a different thread => just wait for it
-              (begin (sync (syncinfo-done-evt v)) (pref p))))]
-         [else
-          ;; wasn't forced yet: try to do it now
-          (call-with-semaphore (syncinfo-access-sema v)
-            (lambda ()
-              (let ([thunk (syncinfo-thunk v)] [done (syncinfo-done-sema v)])
-                ;; set the thread last
-                (set-syncinfo-thunk!
-                 v (make-running-thread (object-name thunk) (current-thread)))
-                (call-with-exception-handler
-                 (lambda (e)
-                   (pset! p (make-reraise e))
-                   (semaphore-post done)
-                   e)
-                 (lambda ()
-                   (pset! p (call-with-values thunk list))
-                   (semaphore-post done))))))
-          ;; whether it was this thread that forced it or not, the results are
-          ;; now in
-          (pref p)]))))
-  #:property prop:evt
-  (lambda (p)
-    (let ([v (pref p)])
-      (handle-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void))))
-
-(#%provide (rename delay/sync* delay/sync))
-(define (delay/sync thunk)
-  (let ([done-sema (make-semaphore 0)])
-    (make-promise/sync (make-syncinfo thunk
-                                      (semaphore-peek-evt done-sema) done-sema
-                                      (make-semaphore 1)))))
-(define-syntax (delay/sync* stx) (make-delayer stx #'delay/sync '()))
-
-;; threaded promises
-
-(define-struct (promise/thread promise) ()
-  #:property prop:force
-  (lambda (p)
-    (reify-result (let ([v (pref p)])
-                    (if (running-thread? v)
-                      (begin (thread-wait (running-thread-thread v))
-                             (pref p))
-                      v))))
-  #:property prop:evt
-  (lambda (p)
-    (let ([v (pref p)])
-      (handle-evt (if (running? v) (running-thread-thread v) always-evt)
-                  void))))
-
-(#%provide (rename delay/thread* delay/thread))
-(define (delay/thread thunk group)
-  (define (run)
-    (call-with-exception-handler
-     (lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
-     (lambda () (pset! p (call-with-values thunk list)))))
-  (define p
-    (make-promise/thread
-     (make-running-thread
-      (object-name thunk)
-      (if group
-        (parameterize ([current-thread-group (make-thread-group)]) (thread run))
-        (thread run)))))
-  p)
-(define-syntax delay/thread*
-  (let-values ([(kwds) (list (cons '#:group #'#t))])
-    (lambda (stx) (make-delayer stx #'delay/thread kwds))))
-
-(define-struct (promise/idle promise/thread) ()
-  #:property prop:force
-  (lambda (p)
-    (reify-result (let ([v (pref p)])
-                    (if (procedure? v)
-                      ;; either running-thread, or returns the controller
-                      (let ([controller (if (running-thread? v)
-                                          (running-thread-thread v)
-                                          (v))])
-                        (thread-send controller 'force!)
-                        (thread-wait controller)
-                        (pref p))
-                      v)))))
-
-(#%provide (rename delay/idle* delay/idle))
-(define (delay/idle thunk wait-for work-while tick use*)
-  (define use (cond [(use* . <= . 0) 0] [(use* . >= . 1) 1] [else use*]))
-  (define work-time (* tick use))
-  (define rest-time (- tick work-time))
-  (define (work)
-    (call-with-exception-handler
-     (lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
-     (lambda () (pset! p (call-with-values thunk list)))))
-  (define (run)
-    ;; this thread is dedicated to controlling the worker thread, so it's
-    ;; possible to dedicate messages to signaling a `force'.
-    (define force-evt (thread-receive-evt))
-    (sync wait-for force-evt)
-    (pset! p (make-running-thread (object-name thunk) controller-thread))
-    (let ([worker (parameterize ([current-thread-group (make-thread-group)])
-                    (thread work))])
-      (cond
-        [(and (use . >= . 1) (equal? work-while always-evt))
-         ;; as if it was pre-forced
-         (thread-wait worker)]
-        [(use . <= . 0)
-         ;; work only when explicitly forced
-         (thread-suspend worker)
-         (sync force-evt)
-         (thread-wait worker)]
-        [else
-         (thread-suspend worker)
-         (let loop ()
-           ;; rest, then wait for idle time, then resume working
-           (if (eq? (begin0 (or (sync/timeout rest-time force-evt)
-                                (sync work-while force-evt))
-                      (thread-resume worker))
-                    force-evt)
-             ;; forced during one of these => let it run to completion
-             (thread-wait worker)
-             ;; not forced
-             (unless (sync/timeout work-time worker)
-               (thread-suspend worker)
-               (loop))))])))
-  ;; I don't think that a thread-group here is needed, but it doesn't hurt
-  (define controller-thread
-    (parameterize ([current-thread-group (make-thread-group)])
-      (thread run)))
-  ;; the thunk is not really used in the above, make it a function that returns
-  ;; the controller thread so it can be forced (used in the `prop:force')
-  (define p (make-promise/idle
-             (procedure-rename (lambda () controller-thread)
-                               (or (object-name thunk) 'idle-thread))))
-  p)
-(define-syntax delay/idle*
-  (let-values ([(kwds) (list (cons '#:wait-for #'(system-idle-evt))
-                             (cons '#:work-while #'(system-idle-evt))
-                             (cons '#:tick #'0.2)
-                             (cons '#:use #'0.12))])
-    (lambda (stx) (make-delayer stx #'delay/idle kwds))))
-
 )
 
 #|
diff --git a/collects/scheme/promise.ss b/collects/scheme/promise.ss
index b6a3844f36..ab67dd1848 100644
--- a/collects/scheme/promise.ss
+++ b/collects/scheme/promise.ss
@@ -1,3 +1,178 @@
 #lang scheme/base
-(require "private/promise.ss")
-(provide (all-from-out "private/promise.ss"))
+(require "private/promise.ss" (for-syntax scheme/base))
+(provide delay lazy force promise? promise-forced? promise-running?)
+
+;; ----------------------------------------------------------------------------
+;; More delay-like values, with different ways of deferring computations
+
+(define-struct (promise/name promise) ()
+  #:property prop:force (lambda (p) ((pref p))))
+
+(provide (rename-out [delay/name* delay/name]))
+(define delay/name make-promise/name)
+(define-syntax (delay/name* stx) (make-delayer stx #'delay/name '()))
+
+;; utility struct
+(define-struct (running-thread running) (thread))
+
+;; used in promise/sync until it's forced
+(define-struct syncinfo ([thunk #:mutable] done-evt done-sema access-sema))
+
+(define-struct (promise/sync promise) ()
+  #:property prop:custom-write
+  (lambda (p port write?)
+    (promise-printer
+     (let ([v (pref p)])
+       (if (syncinfo? v) (make-promise (syncinfo-thunk v)) p))
+     port write?))
+  #:property prop:force
+  (lambda (p)
+    (reify-result
+     (let ([v (pref p)])
+       (cond
+         ;; already forced
+         [(not (syncinfo? v)) v]
+         ;; being forced...
+         [(running-thread? (syncinfo-thunk v))
+          (let ([r (syncinfo-thunk v)])
+            (if (eq? (running-thread-thread r) (current-thread))
+              ;; ... by the current thread => throw the usual reentrant error
+              (r)
+              ;; ... by a different thread => just wait for it
+              (begin (sync (syncinfo-done-evt v)) (pref p))))]
+         [else
+          ;; wasn't forced yet: try to do it now
+          (call-with-semaphore (syncinfo-access-sema v)
+            (lambda ()
+              (let ([thunk (syncinfo-thunk v)] [done (syncinfo-done-sema v)])
+                ;; set the thread last
+                (set-syncinfo-thunk!
+                 v (make-running-thread (object-name thunk) (current-thread)))
+                (call-with-exception-handler
+                 (lambda (e)
+                   (pset! p (make-reraise e))
+                   (semaphore-post done)
+                   e)
+                 (lambda ()
+                   (pset! p (call-with-values thunk list))
+                   (semaphore-post done))))))
+          ;; whether it was this thread that forced it or not, the results are
+          ;; now in
+          (pref p)]))))
+  #:property prop:evt
+  (lambda (p)
+    (let ([v (pref p)])
+      (handle-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void))))
+
+(provide (rename-out [delay/sync* delay/sync]))
+(define (delay/sync thunk)
+  (let ([done-sema (make-semaphore 0)])
+    (make-promise/sync (make-syncinfo thunk
+                                      (semaphore-peek-evt done-sema) done-sema
+                                      (make-semaphore 1)))))
+(define-syntax (delay/sync* stx) (make-delayer stx #'delay/sync '()))
+
+;; threaded promises
+
+(define-struct (promise/thread promise) ()
+  #:property prop:force
+  (lambda (p)
+    (reify-result (let ([v (pref p)])
+                    (if (running-thread? v)
+                      (begin (thread-wait (running-thread-thread v))
+                             (pref p))
+                      v))))
+  #:property prop:evt
+  (lambda (p)
+    (let ([v (pref p)])
+      (handle-evt (if (running? v) (running-thread-thread v) always-evt)
+                  void))))
+
+(provide (rename-out [delay/thread* delay/thread]))
+(define (delay/thread thunk group)
+  (define (run)
+    (call-with-exception-handler
+     (lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
+     (lambda () (pset! p (call-with-values thunk list)))))
+  (define p
+    (make-promise/thread
+     (make-running-thread
+      (object-name thunk)
+      (if group
+        (parameterize ([current-thread-group (make-thread-group)]) (thread run))
+        (thread run)))))
+  p)
+(define-syntax delay/thread*
+  (let ([kwds (list (cons '#:group #'#t))])
+    (lambda (stx) (make-delayer stx #'delay/thread kwds))))
+
+(define-struct (promise/idle promise/thread) ()
+  #:property prop:force
+  (lambda (p)
+    (reify-result (let ([v (pref p)])
+                    (if (procedure? v)
+                      ;; either running-thread, or returns the controller
+                      (let ([controller (if (running-thread? v)
+                                          (running-thread-thread v)
+                                          (v))])
+                        (thread-send controller 'force!)
+                        (thread-wait controller)
+                        (pref p))
+                      v)))))
+
+(provide (rename-out [delay/idle* delay/idle]))
+(define (delay/idle thunk wait-for work-while tick use*)
+  (define use (cond [(use* . <= . 0) 0] [(use* . >= . 1) 1] [else use*]))
+  (define work-time (* tick use))
+  (define rest-time (- tick work-time))
+  (define (work)
+    (call-with-exception-handler
+     (lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
+     (lambda () (pset! p (call-with-values thunk list)))))
+  (define (run)
+    ;; this thread is dedicated to controlling the worker thread, so it's
+    ;; possible to dedicate messages to signaling a `force'.
+    (define force-evt (thread-receive-evt))
+    (sync wait-for force-evt)
+    (pset! p (make-running-thread (object-name thunk) controller-thread))
+    (let ([worker (parameterize ([current-thread-group (make-thread-group)])
+                    (thread work))])
+      (cond
+        [(and (use . >= . 1) (equal? work-while always-evt))
+         ;; as if it was pre-forced
+         (thread-wait worker)]
+        [(use . <= . 0)
+         ;; work only when explicitly forced
+         (thread-suspend worker)
+         (sync force-evt)
+         (thread-wait worker)]
+        [else
+         (thread-suspend worker)
+         (let loop ()
+           ;; rest, then wait for idle time, then resume working
+           (if (eq? (begin0 (or (sync/timeout rest-time force-evt)
+                                (sync work-while force-evt))
+                      (thread-resume worker))
+                    force-evt)
+             ;; forced during one of these => let it run to completion
+             (thread-wait worker)
+             ;; not forced
+             (unless (sync/timeout work-time worker)
+               (thread-suspend worker)
+               (loop))))])))
+  ;; I don't think that a thread-group here is needed, but it doesn't hurt
+  (define controller-thread
+    (parameterize ([current-thread-group (make-thread-group)])
+      (thread run)))
+  ;; the thunk is not really used in the above, make it a function that returns
+  ;; the controller thread so it can be forced (used in the `prop:force')
+  (define p (make-promise/idle
+             (procedure-rename (lambda () controller-thread)
+                               (or (object-name thunk) 'idle-thread))))
+  p)
+(define-syntax delay/idle*
+  (let ([kwds (list (cons '#:wait-for   #'(system-idle-evt))
+                    (cons '#:work-while #'(system-idle-evt))
+                    (cons '#:tick       #'0.2)
+                    (cons '#:use        #'0.12))])
+    (lambda (stx) (make-delayer stx #'delay/idle kwds))))

From 3f2e1c4b20cc0855b23af0b0830e50408bccd243 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 09:35:18 +0000
Subject: [PATCH 107/136] Welcome to a new PLT day.

svn: r17208
---
 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 6865e59a76..5fdefe8006 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "4dec2009")
+#lang scheme/base (provide stamp) (define stamp "5dec2009")

From 1a8bca736f386dc81b9e0d75d280eb588aa66a39 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 5 Dec 2009 18:35:25 +0000
Subject: [PATCH 108/136] PR 10581

svn: r17210
---
 collects/htdp/image.ss                | 2 +-
 collects/tests/mzscheme/htdp-image.ss | 4 ++++
 2 files changed, 5 insertions(+), 1 deletion(-)

diff --git a/collects/htdp/image.ss b/collects/htdp/image.ss
index 2f5b66c5e8..182c2a099d 100644
--- a/collects/htdp/image.ss
+++ b/collects/htdp/image.ss
@@ -407,7 +407,7 @@ plt/collects/tests/mzscheme/htdp-image.ss
   (cond
     [(string=? str "")
      (let-values ([(tw th) (get-text-size size "dummyX")])
-       (rectangle 0 th 'solid 'black))]
+       (put-pinhole (rectangle 0 th 'solid 'black) 0 0))]
     [else
      (let ([color (make-color% color-in)])
        (let-values ([(tw th) (get-text-size size str)])
diff --git a/collects/tests/mzscheme/htdp-image.ss b/collects/tests/mzscheme/htdp-image.ss
index 45dd5a6525..995c2ad941 100644
--- a/collects/tests/mzscheme/htdp-image.ss
+++ b/collects/tests/mzscheme/htdp-image.ss
@@ -830,6 +830,10 @@
       'ph-text
       (list (pinhole-x (text "10" 10 'red))
             (pinhole-y (text "10" 10 'red))))
+(test (list 0 0)
+      'ph-text
+      (list (pinhole-x (text "" 10 'red))
+            (pinhole-y (text "" 10 'red))))
 
 (test (list 3 3)
       'ph-add-line

From ada899f158d89e57af44bb2936c32b24f7101263 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 5 Dec 2009 20:38:38 +0000
Subject: [PATCH 109/136] added more examples and tests for order-of-magnitude

svn: r17212
---
 collects/scribblings/reference/numbers.scrbl | 6 ++++--
 collects/tests/mzscheme/math.ss              | 2 ++
 2 files changed, 6 insertions(+), 2 deletions(-)

diff --git a/collects/scribblings/reference/numbers.scrbl b/collects/scribblings/reference/numbers.scrbl
index 7537bbf5c7..4512716c9e 100644
--- a/collects/scribblings/reference/numbers.scrbl
+++ b/collects/scribblings/reference/numbers.scrbl
@@ -955,11 +955,13 @@ Computes the greatest exact integer @scheme[m] such that:
                  (inexact->exact r))]
 Hence also
 @schemeblock[(< (inexact->exact r)
-                (expt 10 (add1 m)))].
+                (expt 10 (add1 m)))]
 
 @mz-examples[#:eval math-eval 
                     (order-of-magnitude 999)
-                    (order-of-magnitude 1000)]
+                    (order-of-magnitude 1000)
+                    (order-of-magnitude 1/100)
+                    (order-of-magnitude 1/101)]
 }
 
 @; ----------------------------------------------------------------------
diff --git a/collects/tests/mzscheme/math.ss b/collects/tests/mzscheme/math.ss
index 51f6bc5b2a..1ca07b9eea 100644
--- a/collects/tests/mzscheme/math.ss
+++ b/collects/tests/mzscheme/math.ss
@@ -14,6 +14,8 @@
 (test 3 order-of-magnitude 5000)
 (test 3 order-of-magnitude 9999)
 (test 4 order-of-magnitude 10000)
+(test -2 order-of-magnitude 1/100)
+(test -3 order-of-magnitude 1/101)
 
 (test 25 sqr 5)
 (test 25 sqr -5)

From 63469d2f3d78ae6780e0bc5e7b1d37c3d20622ad Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sat, 5 Dec 2009 22:02:46 +0000
Subject: [PATCH 110/136] scribblings: fixed misc doc typos syntax/id-table:
 disabled debugging code

svn: r17215
---
 collects/scribblings/reference/contracts.scrbl  | 4 ++--
 collects/scribblings/reference/numbers.scrbl    | 2 +-
 collects/scribblings/reference/pairs.scrbl      | 2 +-
 collects/scribblings/reference/procedures.scrbl | 6 +++---
 collects/syntax/private/id-table.ss             | 3 ++-
 5 files changed, 9 insertions(+), 8 deletions(-)

diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index 2114c3b961..6e9a8aa3fd 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -1196,8 +1196,8 @@ This property should only be present if the contract is a flat contract. In the
      
      @mz-examples[#:eval (contract-eval)
                          (flat-pred? (-> integer? integer?))
-                         (let ([c (between/c 1 10)]
-                               [pred ((flat-get c) c)])
+                         (let* ([c (between/c 1 10)]
+                                [pred ((flat-get c) c)])
                            (list (pred 9)
                                  (pred 11)))]
 }
diff --git a/collects/scribblings/reference/numbers.scrbl b/collects/scribblings/reference/numbers.scrbl
index 4512716c9e..9426b51eb1 100644
--- a/collects/scribblings/reference/numbers.scrbl
+++ b/collects/scribblings/reference/numbers.scrbl
@@ -953,7 +953,7 @@ Returns the hyperbolic tangent of @scheme[z].}
 Computes the greatest exact integer @scheme[m] such that:
 @schemeblock[(<= (expt 10 m)
                  (inexact->exact r))]
-Hence also
+Hence also:
 @schemeblock[(< (inexact->exact r)
                 (expt 10 (add1 m)))]
 
diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl
index 0f0fff21d6..0d20c1df32 100644
--- a/collects/scribblings/reference/pairs.scrbl
+++ b/collects/scribblings/reference/pairs.scrbl
@@ -885,7 +885,7 @@ without building the intermediate list.
 Returns @scheme[(length (filter proc lst ...))], but
 without building the intermediate list.
 
-@mz-examples[
+@mz-examples[#:eval list-eval
 (count positive? '(1 -1 2 3 -2 5))
 ]}
 
diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl
index 7d5063cfdd..bc33071700 100644
--- a/collects/scribblings/reference/procedures.scrbl
+++ b/collects/scribblings/reference/procedures.scrbl
@@ -253,7 +253,7 @@ See also @scheme[procedure-arity?].}
 
 @defthing[prop:procedure struct-type-property?]{
 
-A @tech{structure type property} to indentify structure types whose
+A @tech{structure type property} to identify structure types whose
 instances can be applied as procedures. In particular, when
 @scheme[procedure?] is applied to the instance, the result will be
 @scheme[#t], and when an instance is used in the function position of
@@ -451,8 +451,8 @@ primitive closure rather than a simple primitive procedure,
 
 Returns the arity of the result of the primitive procedure
 @scheme[prim] (as opposed to the procedure's input arity as returned
-by @scheme[arity]). For most primitives, this procedure returns
-@scheme[1], since most primitives return a single value when
+by @scheme[procedure-arity]). For most primitives, this procedure
+returns @scheme[1], since most primitives return a single value when
 applied.}
 
 @; ----------------------------------------
diff --git a/collects/syntax/private/id-table.ss b/collects/syntax/private/id-table.ss
index 8241924e91..58a5426ee1 100644
--- a/collects/syntax/private/id-table.ss
+++ b/collects/syntax/private/id-table.ss
@@ -4,6 +4,7 @@
          scheme/dict)
 (provide id-table-position?)
 
+#|
 (require (rename-in scheme/base [car s:car]))
 (define-syntax (car stx)
   (syntax-case stx ()
@@ -13,7 +14,7 @@
                                     '#,(syntax-line stx)
                                     '#,(syntax-column stx))))
               (s:car x))]))
-
+|#
 
 (define-struct id-table-position (a b))
 

From 7090e676fccd6ceb700ae8e93e047fdb5a5d5f12 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sat, 5 Dec 2009 23:16:18 +0000
Subject: [PATCH 111/136] reformat

svn: r17217
---
 collects/browser/browser.scrbl | 704 ++++++++++++++++-----------------
 1 file changed, 345 insertions(+), 359 deletions(-)

diff --git a/collects/browser/browser.scrbl b/collects/browser/browser.scrbl
index 4a1032c9b2..aacb2bb56a 100644
--- a/collects/browser/browser.scrbl
+++ b/collects/browser/browser.scrbl
@@ -23,24 +23,24 @@
 
 @title{@bold{Browser}: Simple HTML Rendering}
 
-The @schememodname[browser] library provides the following
-procedures and classes for parsing and viewing HTML files.  The
-@schememodname[browser/htmltext] library provides a simplified
-interface for rendering to a subclass of the MrEd @scheme[text%]
-class. The @schememodname[browser/external] library provides utilities
-for launching an external browser (such as Firefox).
+The @schememodname[browser] library provides the following procedures
+and classes for parsing and viewing HTML files.  The
+@schememodname[browser/htmltext] library provides a simplified interface
+for rendering to a subclass of the MrEd @scheme[text%] class.  The
+@schememodname[browser/external] library provides utilities for
+launching an external browser (such as Firefox).
 
 @section[#:tag "browser"]{Browser}
 
 @defmodule[browser]
 
-The browser supports basic HTML commands, plus special Scheme
-hyperlinks of the form @(litchar "<A MZSCHEME=sexpr>...</A>"). When
-the user clicks on such a link, the string @scheme[sexpr] is parsed as
-a Scheme program and evaluated. Since @scheme[sexpr] is likely to
-contain Scheme strings, and since escape characters are difficult for
-people to read, a @litchar{|} character in @scheme[sexpr] is
-converted to a @litchar{"} character before it is parsed. Thus,
+The browser supports basic HTML commands, plus special Scheme hyperlinks
+of the form @litchar{<A MZSCHEME=sexpr>...</A>}.  When the user clicks
+on such a link, the string @scheme[sexpr] is parsed as a Scheme program
+and evaluated.  Since @scheme[sexpr] is likely to contain Scheme
+strings, and since escape characters are difficult for people to read, a
+@litchar{|} character in @scheme[sexpr] is converted to a @litchar{"}
+character before it is parsed.  Thus,
 
 @verbatim[#:indent 2]{
   <A MZSCHEME="|This goes nowhere.|">Nowhere</A>
@@ -49,214 +49,211 @@ converted to a @litchar{"} character before it is parsed. Thus,
 creates a ``Nowhere'' hyperlink, which executes the Scheme program
 
 @schemeblock[
-"This goes nowhere."
+  "This goes nowhere."
 ]
 
-The value of that program is a string. When a Scheme hyperlink returns
-a string, it is parsed as a new HTML document. Thus, where the use
+The value of that program is a string.  When a Scheme hyperlink returns
+a string, it is parsed as a new HTML document.  Thus, where the use
 clicks on ``Nowhere,'' the result is a new page that says ``This goes
 nowhere.''
 
-The browser also treats comment forms containing @(litchar "MZSCHEME=sexpr")
-specially.  Whereas the @(litchar "<A MZSCHEME=sexpr>...</A>") form executes the
-expression when the user clicks, the @(litchar "MZSCHEME") expression in a comment
-is executed immediately during HTML rendering. If the result is a
-string, the comment is replaced in the input HTML stream with the
-content of the string. Thus,
+The browser also treats comment forms containing
+@litchar{MZSCHEME=sexpr} specially.   Whereas the
+@litchar{<A MZSCHEME=sexpr>...</A>} form executes the expression when
+the user clicks, the @litchar{MZSCHEME} expression in a comment is
+executed immediately during HTML rendering.  If the result is a string,
+the comment is replaced in the input HTML stream with the content of the
+string.  Thus,
 
 @verbatim[#:indent 2]{
   <!-- MZSCHEME="(format |<B>Here</B>: ~a| (current-directory))" -->
 }
 
 inserts the path of the current working directory into the containing
-document (and ``Here'' is boldfaced). If the result is a snip instead
-of a string, it replaces the comment in the document. Other types of
+document (and ``Here'' is boldfaced).  If the result is a snip instead
+of a string, it replaces the comment in the document.  Other types of
 return values are ignored.
 
-If the html file is being accessed as a @(litchar "file:") url, the
+If the html file is being accessed as a @litchar{file:} url, the
 @scheme[current-load-relative-directory] parameter is set to the
 directory during the evaluation of the mzscheme code (in both
-examples). The Scheme code is executed through @scheme[eval].
+examples).  The Scheme code is executed through @scheme[eval].
 
-The @(litchar "MZSCHEME") forms are disabled unless the web page is a
-@(litchar "file:") url that points into the @scheme[doc] collection.
+The @litchar{MZSCHEME} forms are disabled unless the web page is a
+@litchar{file:} url that points into the @scheme[doc] collection.
 
 @defproc[(open-url [url (or/c url? string? input-port?)]) (is-a?/c hyper-frame%)]{
-        Opens the given url 
-        in a vanilla browser frame and returns
-        the frame. The frame is an instance of
-        @scheme[hyper-frame%].
+  Opens the given url in a vanilla browser frame and returns the
+  frame.  The frame is an instance of @scheme[hyper-frame%].
 }
 
 @defboolparam[html-img-ok ok?]{
-        A parameter that determines whether the browser attempts to
-        download and render images.
+  A parameter that determines whether the browser attempts to download
+  and render images.
 }
 
 @defboolparam[html-eval-ok ok?]{
-        A parameter that determines whether @(litchar "MZSCHEME=")
-        tags are evaluated.
+  A parameter that determines whether @litchar{MZSCHEME=} tags are
+  evaluated.
 }
 
 @; ----------------------------------------------------------------------
 
 @defmixin[hyper-frame-mixin (frame%) ()]{
 
-        @defconstructor/auto-super[([url (or/c url? string? input-port?)])]{
-         Shows the frame and visits @scheme[url].
-        }
+  @defconstructor/auto-super[([url (or/c url? string? input-port?)])]{
+    Shows the frame and visits @scheme[url].
+  }
 
-        @defmethod[(get-hyper-panel%) (subclass?/c panel%)]{
-        Returns the class that is instantiated when the frame is created.
-        Must be a panel with hyper-panel-mixin mixed in. Defaults to
-        just returning @scheme[hyper-panel%].
-        }
+  @defmethod[(get-hyper-panel%) (subclass?/c panel%)]{
+    Returns the class that is instantiated when the frame is created.
+    Must be a panel with hyper-panel-mixin mixed in.  Defaults to just
+    returning @scheme[hyper-panel%].
+  }
 
-        @defmethod[(get-hyper-panel) (is-a?/c panel%)]{
-        Returns the hyper panel in this frame.
-        }
+  @defmethod[(get-hyper-panel) (is-a?/c panel%)]{
+    Returns the hyper panel in this frame.
+  }
 }
 
 @; ----------------------------------------------------------------------
 
-@defclass[hyper-no-show-frame% (hyper-frame-mixin (frame:status-line-mixin frame:basic%)) ()]
+@defclass[hyper-no-show-frame%
+          (hyper-frame-mixin (frame:status-line-mixin frame:basic%))
+          ()]
 
 @; ----------------------------------------------------------------------
 
 @defmixin[hyper-no-show-frame-mixin (frame%) ()]{
-        The same as the @scheme[hyper-frame-mixin], except that it
-        doesn't show the frame and the initialization arguments
-        are unchanged.
+  The same as the @scheme[hyper-frame-mixin], except that it doesn't
+  show the frame and the initialization arguments are unchanged.
 }
 
 @; ----------------------------------------------------------------------
 
-@defclass[hyper-frame% (hyper-no-show-frame-mixin (frame:status-line-mixin frame:basic%)) ()]
+@defclass[hyper-frame%
+          (hyper-no-show-frame-mixin (frame:status-line-mixin frame:basic%))
+          ()]
 
 @; ----------------------------------------------------------------------
 
 @defmixin[hyper-text-mixin (text%) ()]{
 
-        An instance of a @scheme[hyper-text-mixin]-extended class
-        should be displayed only in an instance of a class created
-        with @scheme[hyper-canvas-mixin].
+  An instance of a @scheme[hyper-text-mixin]-extended class should be
+  displayed only in an instance of a class created with
+  @scheme[hyper-canvas-mixin].
 
-        @defconstructor/auto-super[([url (or/c url? string? input-port?)]
-                                    [status-frame (or/c (is-a?/c top-level-window<%>) false/c)]
-                                    [post-data (or/c false/c bytes?)])]{
-        The @scheme[url] is loaded into the @scheme[text%] object
-        (using the @method[hyper-text-mixin reload] method), a
-        top-level window for status messages and dialogs, a progress
-        procedure used as for @scheme[get-url], and either @scheme[#f]
-        or a post string to be sent to a web server (technically
-        changing the GET to a POST).
+  @defconstructor/auto-super[([url (or/c url? string? input-port?)]
+                              [status-frame
+                               (or/c (is-a?/c top-level-window<%>) false/c)]
+                              [post-data (or/c false/c bytes?)])]{
+    The @scheme[url] is loaded into the @scheme[text%] object (using the
+    @method[hyper-text-mixin reload] method), a top-level window for
+    status messages and dialogs, a progress procedure used as for
+    @scheme[get-url], and either @scheme[#f] or a post string to be sent
+    to a web server (technically changing the GET to a POST).
 
-        Sets the autowrap-bitmap to @scheme[#f].   
-        }
+    Sets the autowrap-bitmap to @scheme[#f].
+  }
 
-        @defmethod[(map-shift-style [start exact-nonnegative-integer?]
-                                    [end exact-nonnegative-integer?]
-                                    [shift-style style<%>])
-                   void?]{
-                Maps the given style over the given range.
-        }
+  @defmethod[(map-shift-style [start exact-nonnegative-integer?]
+                              [end exact-nonnegative-integer?]
+                              [shift-style style<%>])
+             void?]{
+    Maps the given style over the given range.
+  }
 
-        @defmethod[(make-link-style [start exact-nonnegative-integer?]
-                                    [end exact-nonnegative-integer?])
-                   void?]{
-                Changes the style for the given range to the link style.
-        }
+  @defmethod[(make-link-style [start exact-nonnegative-integer?]
+                              [end exact-nonnegative-integer?])
+             void?]{
+    Changes the style for the given range to the link style.
+  }
 
-        @defmethod[(get-url) (or/c url? string? input-port? false/c)]{
-                Returns the URL displayed by the editor, or @scheme[#f] if there
-            is none.
-        }
+  @defmethod[(get-url) (or/c url? string? input-port? false/c)]{
+    Returns the URL displayed by the editor, or @scheme[#f] if there is
+    none.
+  }
 
-        @defmethod[(get-title) string?]{
-                Gets the page's title.
-        }
+  @defmethod[(get-title) string?]{
+    Gets the page's title.
+  }
 
-        @defmethod[(set-title [str string?]) void?]{
-                Sets the page's title.
-        }
+  @defmethod[(set-title [str string?]) void?]{
+    Sets the page's title.
+  }
 
-        @defmethod[(hyper-delta) style-delta%]{
-                Override this method to set the link style.
-        }
+  @defmethod[(hyper-delta) style-delta%]{
+    Override this method to set the link style.
+  }
 
-        @defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{
-                Installs a tag.
-        }
+  @defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{
+    Installs a tag.
+  }
 
-        @defmethod[(find-tag [name/number (or/c string? exact-nonnegative-integer?)]) 
-                   (or/c exact-nonnegative-integer? false/c)]{
-                Finds the location of a tag in the buffer (where tags
-                are installed in HTML with @(litchar "<A
-                NAME=\"name\">")) and returns its position. If
-                @scheme[name] is a number, the number is returned
-                (assumed to be an offset rather than a
-                tag). Otherwise, if the tag is not found, @scheme[#f]
-                is returned.
-        }
+  @defmethod[(find-tag [name/number (or/c string? exact-nonnegative-integer?)])
+             (or/c exact-nonnegative-integer? false/c)]{
+    Finds the location of a tag in the buffer (where tags are installed
+    in HTML with @litchar{<A NAME="name">}) and returns its position.
+    If @scheme[name] is a number, the number is returned (assumed to be
+    an offset rather than a tag).  Otherwise, if the tag is not found,
+    @scheme[#f] is returned.
+  }
 
-        @defmethod[(remove-tag [name string?]) void?]{
-                Removes a tag.
-        }
+  @defmethod[(remove-tag [name string?]) void?]{
+    Removes a tag.
+  }
 
-        @defmethod[(post-url [url (or/c string? url?)]  
-                             [post-data-bytes (or/c bytes? false/c) #f]) void?]{
-                Follows the link, optionally with the given post data.
-        }
+  @defmethod[(post-url [url (or/c string? url?)]
+                       [post-data-bytes (or/c bytes? false/c) #f]) void?]{
+    Follows the link, optionally with the given post data.
+  }
 
-        @defmethod[(add-link [start exact-nonnegative-integer?] 
-                             [end exact-nonnegative-integer?]
-                             [url (or/c url? string?)])
-                   void?]{
-                Installs a hyperlink.
-        }
+  @defmethod[(add-link [start exact-nonnegative-integer?]
+                       [end exact-nonnegative-integer?]
+                       [url (or/c url? string?)])
+             void?]{
+    Installs a hyperlink.
+  }
 
-        @defmethod[(add-scheme-callback [start exact-nonnegative-integer?] 
-                                        [end exact-nonnegative-integer?]
-                                        [scheme-expr string?])
-                   void?]{
-                Installs a Scheme evaluation hyperlink.
-        }
+  @defmethod[(add-scheme-callback [start exact-nonnegative-integer?]
+                                  [end exact-nonnegative-integer?]
+                                  [scheme-expr string?])
+             void?]{
+    Installs a Scheme evaluation hyperlink.
+  }
 
-        @defmethod[(add-thunk-callback [start exact-nonnegative-integer?] 
-                                       [end exact-nonnegative-integer?]
-                                       [thunk (-> any)])
-                   void?]{
-                Installs a thunk-based hyperlink.
-        }
+  @defmethod[(add-thunk-callback [start exact-nonnegative-integer?]
+                                 [end exact-nonnegative-integer?]
+                                 [thunk (-> any)])
+             void?]{
+    Installs a thunk-based hyperlink.
+  }
 
-        @defmethod[(eval-scheme-string [str string?]) any]{
-                Called to handle the @(litchar "<A MZSCHEME=\"expr\">...</A>") 
-                tag and @(litchar "<! MZSCHEME=\"expr\">") comments (see above). 
-                Evaluates the string; if the result is a string, 
-                it is opened as an HTML page.
-        }
+  @defmethod[(eval-scheme-string [str string?]) any]{
+    Called to handle the @litchar{<A MZSCHEME="expr">...</A>} tag and
+    @litchar{<! MZSCHEME="expr">} comments (see above).  Evaluates the
+    string; if the result is a string, it is opened as an HTML page.
+  }
 
-        @defmethod[(reload) void?]{
-                Reloads the current page.
+  @defmethod[(reload) void?]{
+    Reloads the current page.
 
-                The text defaultly uses the basic style named
-                @scheme["Html Standard"] in the editor (if it exists).
-        }
+    The text defaultly uses the basic style named
+    @scheme["Html Standard"] in the editor (if it exists).
+  }
 
-        @defmethod[(remap-url [url (or/c url? string?)]) (or/c url? string?)]{
-                When visiting a new page, this method is called to remap
-                the url. The remapped url is used in place of the
-                original url. If this method returns @scheme[#f], the page doesn't
-                go anywhere.
+  @defmethod[(remap-url [url (or/c url? string?)]) (or/c url? string?)]{
+    When visiting a new page, this method is called to remap the url.
+    The remapped url is used in place of the original url.  If this
+    method returns @scheme[#f], the page doesn't go anywhere.
 
-                This method may be killed (if the user clicks the
-                ``stop'' button).
-        }
-        
-        @defmethod[(get-hyper-keymap) (is-a?/c keymap%)]{
-                Returns a keymap suitable for frame-level handling of events to
-                redirect page-up, @|etc| to the browser canvas.
-        }
+    This method may be killed (if the user clicks the ``stop'' button).
+  }
+
+  @defmethod[(get-hyper-keymap) (is-a?/c keymap%)]{
+    Returns a keymap suitable for frame-level handling of events to
+    redirect page-up, @|etc| to the browser canvas.
+  }
 
 }
 
@@ -264,8 +261,8 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a
 
 @defclass[hyper-text% (hyper-text-mixin text:keymap%) ()]{
 
-        Extends the @scheme[text:keymap%] class to support standard
-        key bindings in the browser window.
+  Extends the @scheme[text:keymap%] class to support standard key
+  bindings in the browser window.
 
 }
 
@@ -273,135 +270,130 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a
 
 @defmixin[hyper-canvas-mixin (editor-canvas%) ()]{
 
-        A @scheme[hyper-can-mixin]-extended canvas's parent should be
-        an instance of a class derived with
-        @scheme[hyper-panel-mixin].
+  A @scheme[hyper-can-mixin]-extended canvas's parent should be an
+  instance of a class derived with @scheme[hyper-panel-mixin].
 
-        @defconstructor/auto-super[()]{
-        }
+  @defconstructor/auto-super[()]{
+  }
 
-        @defmethod[(get-editor%) (subclass?/c text%)]{
+  @defmethod[(get-editor%) (subclass?/c text%)]{
 
-        Returns the class used to implement the editor in the browser
-        window. It should be derived from @scheme[hyper-text%] and
-        should pass on the initialization arguments to
-        @scheme[hyper-text%].
+    Returns the class used to implement the editor in the browser
+    window.  It should be derived from @scheme[hyper-text%] and should
+    pass on the initialization arguments to @scheme[hyper-text%].
 
-        The dynamic extent of the initialization of this
-        editor is called on a thread that may be killed (via a
-        custodian shutdown). In that case, the editor in the browser's
-        editor-canvas may not be an instance of this class.
-        }
+    The dynamic extent of the initialization of this editor is called on
+    a thread that may be killed (via a custodian shutdown).  In that
+    case, the editor in the browser's editor-canvas may not be an
+    instance of this class.
+  }
 
-        @defmethod[(current-page) any/c]{
-        Returns a representation of the currently displayed page, which
-        includes a particular editor and a visible range within the
-        editor.
-        }
+  @defmethod[(current-page) any/c]{
+    Returns a representation of the currently displayed page, which
+    includes a particular editor and a visible range within the editor.
+  }
 
-        @defmethod[(goto-url [url (or/c url? string?)]
-                             [relative-to-url (or/c url? string? false/c)] 
-                             [progress-proc (boolean? . -> . any) void]
-                             [post-data (or/c bytes? false/c) #f])
-                    void?]{
-        Changes to the given url, loading it by calling the @scheme[make-editor]
-        method. If @scheme[relative-to-url] is not @scheme[#f], it must be 
-        a URL for resolving @scheme[url] as a relative URL. 
-        @scheme[url] may also be a port, in which case, 
-        @scheme[relative-to-url] must be @scheme[#f].
+  @defmethod[(goto-url [url (or/c url? string?)]
+                       [relative-to-url (or/c url? string? false/c)]
+                       [progress-proc (boolean? . -> . any) void]
+                       [post-data (or/c bytes? false/c) #f])
+             void?]{
+    Changes to the given url, loading it by calling the
+    @scheme[make-editor] method.  If @scheme[relative-to-url] is not
+    @scheme[#f], it must be a URL for resolving @scheme[url] as a
+    relative URL.  @scheme[url] may also be a port, in which case,
+    @scheme[relative-to-url] must be @scheme[#f].
 
-        The @scheme[progress-proc] procedure is called with a boolean at the
-        point where the URL has been resolved and enough progress has
-        been made to dismiss any message that the URL is being
-        resolved. The procedure is called with @scheme[#t] if the URL will be
-        loaded into a browser window, @scheme[#f] otherwise (e.g., the user will
-        save the URL content to a file).
+    The @scheme[progress-proc] procedure is called with a boolean at the
+    point where the URL has been resolved and enough progress has been
+    made to dismiss any message that the URL is being resolved.  The
+    procedure is called with @scheme[#t] if the URL will be loaded into
+    a browser window, @scheme[#f] otherwise (e.g., the user will save
+    the URL content to a file).
 
-        If @scheme[post-data-bytes] is a byte string instead of false, the URL
-        GET is changed to a POST with the given data.
-        }
+    If @scheme[post-data-bytes] is a byte string instead of false, the
+    URL GET is changed to a POST with the given data.
+  }
 
-        @defmethod[(set-page [page any/c] [notify? any/c]) void?]{
-        Changes to the given page. If @scheme[notify?] is not @scheme[#f], 
-        the canvas's parent is notified about the change by calling its 
-        @scheme[leaving-page] method.           
-        }
+  @defmethod[(set-page [page any/c] [notify? any/c]) void?]{
+    Changes to the given page.  If @scheme[notify?] is not @scheme[#f],
+    the canvas's parent is notified about the change by calling its
+    @scheme[leaving-page] method.
+  }
 
-        @defmethod[(after-set-page) void?]{
-        Called during @scheme[set-page]. Defaultly does nothing.
-        }
+  @defmethod[(after-set-page) void?]{
+    Called during @scheme[set-page].  Defaultly does nothing.
+  }
 }
 
 @; ----------------------------------------------------------------------
 
 @defmixin[hyper-panel-mixin (area-container<%>) ()]{
 
-        @defconstructor/auto-super[([info-line? any/c])]{
-        Creates controls and a hyper text canvas.  The
-        controls permit a user to move back and forth in the hypertext
-        history.
-        
-        The @scheme[info-line?] argument indicates whether the browser
-        should contain a line to display special @(litchar "DOCNOTE")
-        tags in a page.  Such tags are used primarily by the PLT
-        documentation.}
-        
-        @defmethod[(make-canvas [container (is-a?/c area-container<%>)]) void?]{
-        Creates the panel's hypertext canvas, an instance of a class
-        derived using @scheme[hyper-canvas-mixin]. This
-        method is called during initialization.
-        }
+  @defconstructor/auto-super[([info-line? any/c])]{
+    Creates controls and a hyper text canvas.  The controls permit a
+    user to move back and forth in the hypertext history.
 
-        @defmethod[(get-canvas%) (subclass?/c editor-canvas%)]{
-        Returns the class instantiated by make-canvas. It must be derived from
-        @scheme[hyper-canvas-mixin].
-        }
+    The @scheme[info-line?] argument indicates whether the browser
+    should contain a line to display special @litchar{DOCNOTE} tags in a
+    page.  Such tags are used primarily by the PLT documentation.
+  }
 
-        @defmethod[(make-control-bar-panel [container (is-a?/c area-container<%>)]) 
-                   any/c]{
-        Creates the panel's sub-container for the control bar containing
-        the navigation buttons. If @scheme[#f] is returned, the panel will 
-        have no control bar. The default method instantiates
-        @scheme[horizontal-panel%].
-        }
+  @defmethod[(make-canvas [container (is-a?/c area-container<%>)]) void?]{
+    Creates the panel's hypertext canvas, an instance of a class derived
+    using @scheme[hyper-canvas-mixin].  This method is called during
+    initialization.
+  }
 
-        @defmethod[(rewind) void?]{
-        Goes back one page, if possible.
-        }
+  @defmethod[(get-canvas%) (subclass?/c editor-canvas%)]{
+    Returns the class instantiated by make-canvas.  It must be derived
+    from @scheme[hyper-canvas-mixin].
+  }
 
-        @defmethod[(forward) void?]{
-        Goes forward one page, if possible.
-        }
+  @defmethod[(make-control-bar-panel [container (is-a?/c area-container<%>)])
+             any/c]{
+    Creates the panel's sub-container for the control bar containing the
+    navigation buttons.  If @scheme[#f] is returned, the panel will have
+    no control bar.  The default method instantiates
+    @scheme[horizontal-panel%].
+  }
 
-        @defmethod[(get-canvas) (is-a?/c editor-canvas%)]{
-        Gets the hypertext canvas.
-        }
+  @defmethod[(rewind) void?]{
+    Goes back one page, if possible.
+  }
 
-        @defmethod[(on-navigate) void?]{
-        Callback that is invoked any time the displayed hypertext page
-        changes (either by clicking on a link in the canvas or by
-        @scheme[rewind] or @scheme[forward] calls).
-        }
+  @defmethod[(forward) void?]{
+    Goes forward one page, if possible.
+  }
 
-        @defmethod[(leaving-page [page any/c] [new-page any/c])
-                   any]{
-        This method is called by the hypertext canvas to notify the
-        panel that the hypertext page changed. The @scheme[page] is @scheme[#f]
-        if @scheme[new-page] is the first page for the canvas. See also
-        @scheme[page->editor].
-        }
+  @defmethod[(get-canvas) (is-a?/c editor-canvas%)]{
+    Gets the hypertext canvas.
+  }
 
-        @defmethod[(filter-notes [notes (listof string?)])
-                   (listof string?)]{
-        Given the notes from a page as a list of strings (where
-        each string is a note), returns a single string to print
-        above the page.
-        }
+  @defmethod[(on-navigate) void?]{
+    Callback that is invoked any time the displayed hypertext page
+    changes (either by clicking on a link in the canvas or by
+    @scheme[rewind] or @scheme[forward] calls).
+  }
 
-        @defmethod[(reload) void?]{
-        Reloads the currently visible page by calling the @scheme[reload] 
-        method of the currently displayed hyper-text.
-        }
+  @defmethod[(leaving-page [page any/c] [new-page any/c])
+             any]{
+    This method is called by the hypertext canvas to notify the panel
+    that the hypertext page changed.  The @scheme[page] is @scheme[#f]
+    if @scheme[new-page] is the first page for the canvas.  See also
+    @scheme[page->editor].
+  }
+
+  @defmethod[(filter-notes [notes (listof string?)])
+             (listof string?)]{
+    Given the notes from a page as a list of strings (where each string
+    is a note), returns a single string to print above the page.
+  }
+
+  @defmethod[(reload) void?]{
+    Reloads the currently visible page by calling the @scheme[reload]
+    method of the currently displayed hyper-text.
+  }
 }
 
 @; ----------------------------------------------------------------------
@@ -411,46 +403,43 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a
 @; ----------------------------------------------------------------------
 
 @defproc[(editor->page [editor (is-a?/c text%)]) any/c]{
-        Creates a page record for the given editor,
-        suitable for use with the @scheme[set-page] method of 
-        @scheme[hyper-canvas-mixin].
+  Creates a page record for the given editor, suitable for use with the
+  @scheme[set-page] method of @scheme[hyper-canvas-mixin].
 }
 
 @defproc[(page->editor [page any/c]) (is-a?/c text%)]{
-        Extracts the editor from a page record.
+  Extracts the editor from a page record.
 }
 
 @defparam[bullet-size n exact-nonnegative-integer?]{
-        Parameter controlling the point size of a
-        bullet. 
+  Parameter controlling the point size of a bullet.
 }
 
 @defclass[image-map-snip% snip% ()]{
-        Instances of this class behave like @scheme[image-snip%] objects,
-        except they have a @(litchar "<map> ... </map>") associated with them and
-        when clicking on them (in the map) they will cause their
-        init arg text to follow the corresponding link.
+  Instances of this class behave like @scheme[image-snip%] objects,
+  except they have a @litchar{<map> ... </map>} associated with them and
+  when clicking on them (in the map) they will cause their init arg text
+  to follow the corresponding link.
 
-        @defconstructor[([html-text (is-a?/c html-text<%>)])]{
-        }
+  @defconstructor[([html-text (is-a?/c html-text<%>)])]{
+  }
 
-        @defmethod[(set-key [key string?]) void?]{
-                Sets the key for the image map (eg, "#key").
-        }
+  @defmethod[(set-key [key string?]) void?]{
+    Sets the key for the image map (eg, @scheme["#key"]).
+  }
 
-        @defmethod[(get-key) string?]{
-                Returns the current key.
-        }
+  @defmethod[(get-key) string?]{
+    Returns the current key.
+  }
 
-        @defmethod[(add-area [shape string?] 
-                             [region (listof number?)]
-                             [href string?])
-                   void?]{
-                Registers the shape named by @scheme[shape] whose
-                coordinates are specified by @scheme[region] to go to
-                @scheme[href] when that region of the image
-                is clicked on.
-        }
+  @defmethod[(add-area [shape string?]
+                       [region (listof number?)]
+                       [href string?])
+             void?]{
+    Registers the shape named by @scheme[shape] whose coordinates are
+    specified by @scheme[region] to go to @scheme[href] when that region
+    of the image is clicked on.
+  }
 }
 
 @; ----------------------------------------------------------------------
@@ -460,9 +449,9 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a
 @defmodule[browser/browser-unit]
 
 @defthing[browser@ unit?]{
-
-Imports @scheme[mred^], @scheme[tcp^], and @scheme[url^], and exports
-@scheme[browser^].}
+  Imports @scheme[mred^], @scheme[tcp^], and @scheme[url^], and exports
+  @scheme[browser^].
+}
 
 @; ----------------------------------------------------------------------
 
@@ -471,9 +460,8 @@ Imports @scheme[mred^], @scheme[tcp^], and @scheme[url^], and exports
 @defmodule[browser/browser-sig]
 
 @defsignature[browser^ ()]{
-
-Includes all of the bindings of the @schememodname[browser]
-library.}
+  Includes all of the bindings of the @schememodname[browser] library.
+}
 
 @; ----------------------------------------------------------------------
 
@@ -483,75 +471,73 @@ library.}
 
 @definterface[html-text<%> (text%)]{
 
-        @defmethod[(get-url) (or/c url? string? false/c)]{
-        Returns a base URL used for building
-        relative URLs, or @scheme[#f] if no base is available.
-        }
+  @defmethod[(get-url) (or/c url? string? false/c)]{
+    Returns a base URL used for building relative URLs, or @scheme[#f]
+    if no base is available.
+  }
 
-        @defmethod[(set-title [str string?]) void?]{
-        Registers the title @scheme[str]
-        for the rendered page.
-        }
+  @defmethod[(set-title [str string?]) void?]{
+    Registers the title @scheme[str] for the rendered page.
+  }
 
-        @defmethod[(add-link [start exact-nonnegative-integer?] 
-                             [end exact-nonnegative-integer?]
-                             [url (or/c url? string?)])
-                   void?]{
-        Registers a hyperlink for the given region in rendered page.
-        }
+  @defmethod[(add-link [start exact-nonnegative-integer?]
+                       [end exact-nonnegative-integer?]
+                       [url (or/c url? string?)])
+             void?]{
+    Registers a hyperlink for the given region in rendered page.
+  }
 
-        @defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{
-                Installs a tag.
-        }
+  @defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{
+    Installs a tag.
+  }
 
-        @defmethod[(make-link-style [start exact-nonnegative-integer?]
-                                    [end exact-nonnegative-integer?])
-                   void?]{
-                Changes the style for the given range to the link style.
-        }
+  @defmethod[(make-link-style [start exact-nonnegative-integer?]
+                              [end exact-nonnegative-integer?])
+             void?]{
+    Changes the style for the given range to the link style.
+  }
 
-        @defmethod[(add-scheme-callback [start exact-nonnegative-integer?] 
-                                        [end exact-nonnegative-integer?]
-                                        [scheme-expr string?])
-                   void?]{
-                Installs a Scheme evaluation hyperlink.
-        }
+  @defmethod[(add-scheme-callback [start exact-nonnegative-integer?]
+                                  [end exact-nonnegative-integer?]
+                                  [scheme-expr string?])
+             void?]{
+    Installs a Scheme evaluation hyperlink.
+  }
 
-        @defmethod[(add-thunk-callback [start exact-nonnegative-integer?] 
-                                       [end exact-nonnegative-integer?]
-                                       [thunk (-> any)])
-                   void?]{
-                Installs a thunk-based hyperlink.
-        }
+  @defmethod[(add-thunk-callback [start exact-nonnegative-integer?]
+                                 [end exact-nonnegative-integer?]
+                                 [thunk (-> any)])
+             void?]{
+    Installs a thunk-based hyperlink.
+  }
 
-        @defmethod[(post-url [url (or/c string? url?)]  
-                             [post-data-bytes (or/c bytes? false/c) #f]) void?]{
-                Follows the link, optionally with the given post data.
-        }
+  @defmethod[(post-url [url (or/c string? url?)]
+                       [post-data-bytes (or/c bytes? false/c) #f]) void?]{
+    Follows the link, optionally with the given post data.
+  }
 }
 
 
 @defmixin[html-text-mixin (text%) ()]{
-        Extends the given @scheme[text%] class with implementations of the 
-        @scheme[html-text<%>] methods. Hyperlinks are attached to clickbacks 
-        that use @net-send-url from @schememodname[net/sendurl].
+  Extends the given @scheme[text%] class with implementations of the
+  @scheme[html-text<%>] methods.  Hyperlinks are attached to clickbacks
+  that use @net-send-url from @schememodname[net/sendurl].
 }
 
-@defproc[(render-html-to-text [in input-port?] 
+@defproc[(render-html-to-text [in input-port?]
                               [dest (is-a? html-text<%>)]
-                              [load-img? any/c]  
+                              [load-img? any/c]
                               [eval-mz? any/c])
          void?]{
+  Reads HTML from @scheme[in] and renders it to @scheme[dest].  If
+  @scheme[load-img?] is @scheme[#f], then images are rendered as Xed-out
+  boxes.  If @scheme[eval-mz?] is @scheme[#f], then @litchar{MZSCHEME}
+  hyperlink expressions and comments are not evaluated.
 
-        Reads HTML from @scheme[in] and renders it to @scheme[dest].
-        If @scheme[load-img?] is @scheme[#f], then images are rendered
-        as Xed-out boxes. If @scheme[eval-mz?] is @scheme[#f], then
-        @litchar{MZSCHEME} hyperlink expressions and comments are not
-        evaluated.
-
-        Uses the style named @scheme["Html Standard"] in the editor's
-        style-list (if it exists) for all of the inserted text's
-        default style.}
+  Uses the style named @scheme["Html Standard"] in the editor's
+  style-list (if it exists) for all of the inserted text's default
+  style.
+}
 
 @; ----------------------------------------------------------------------
 
@@ -560,32 +546,33 @@ library.}
 @defmodule[browser/external]
 
 @defproc[(send-url [str null] [separate-window? void #t]) null]{
-        Like @net-send-url from @scheme[net/sendurl] , but under Unix,
-        the user is prompted for a browser to use if none is recorded
-        in the preferences file.
+  Like @net-send-url from @scheme[net/sendurl], but under Unix, the user
+  is prompted for a browser to use if none is recorded in the
+  preferences file.
 }
 
 @defproc[(browser-preference? [v any/c]) boolean?]{
-        Returns @scheme[#t] if @scheme[v] is a valid browser preference.
+  Returns @scheme[#t] if @scheme[v] is a valid browser preference.
 }
 
 @defproc[(update-browser-preference [url (or/c string? false/c)]) void?]{
-        Under Unix, prompts the user for a browser preference and records
-        the user choice as a framework preference (even if one is already
-        recorded). If @scheme[url] is not @scheme[#f], it is used in the 
-        dialog to explain which URL is to be opened; if it is @scheme[#f], 
-        the @scheme['internal] will be one of the options for the user.
+  Under Unix, prompts the user for a browser preference and records the
+  user choice as a framework preference (even if one is already
+  recorded).  If @scheme[url] is not @scheme[#f], it is used in the
+  dialog to explain which URL is to be opened; if it is @scheme[#f], the
+  @scheme['internal] will be one of the options for the user.
 }
 
 @defproc[(install-help-browser-preference-panel) void?]{
-        Installs a framework preference panel for ``Browser'' options.
+  Installs a framework preference panel for ``Browser'' options.
 }
 
-@defproc[(add-to-browser-prefs-panel [proc ((is-a?/c panel%) . -> . any)]) void?]{
-        The @scheme[proc] is called when the ``Browser'' panel is constructed for
-        preferences. The supplied argument is the panel, so @scheme[proc] can add
-        additional option controls. If the panel is already created, @scheme[proc]
-        is called immediately.
+@defproc[(add-to-browser-prefs-panel [proc ((is-a?/c panel%) . -> . any)])
+         void?]{
+  The @scheme[proc] is called when the ``Browser'' panel is constructed
+  for preferences.  The supplied argument is the panel, so @scheme[proc]
+  can add additional option controls.  If the panel is already created,
+  @scheme[proc] is called immediately.
 }
 
 @; ----------------------------------------------------------------------
@@ -595,7 +582,6 @@ library.}
 @defmodule[browser/tool]
 
 @defthing[tool@ unit?]{
-
   A unit that implements a DrScheme tool to add the ``Browser''
   preference panel.
 }

From 1b5ab0b46a758a35aeb27fbf0f1da0bdf1e21c87 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sun, 6 Dec 2009 00:15:21 +0000
Subject: [PATCH 112/136] several typos in the vectors docs (PR10642), also
 some in list docs

svn: r17218
---
 collects/scribblings/reference/pairs.scrbl   |  6 +++---
 collects/scribblings/reference/vectors.scrbl | 22 ++++++++++----------
 2 files changed, 14 insertions(+), 14 deletions(-)

diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl
index 0d20c1df32..4faa8f7c55 100644
--- a/collects/scribblings/reference/pairs.scrbl
+++ b/collects/scribblings/reference/pairs.scrbl
@@ -880,10 +880,10 @@ without building the intermediate list.
 ]}
 
 @defproc[(count [proc procedure?] [lst list?] ...+)
-         list?]{
+         exact-nonnegative-integer?]{
 
-Returns @scheme[(length (filter proc lst ...))], but
-without building the intermediate list.
+Returns @scheme[(length (filter proc lst ...))], but without building
+the intermediate list.
 
 @mz-examples[#:eval list-eval
 (count positive? '(1 -1 2 3 -2 5))
diff --git a/collects/scribblings/reference/vectors.scrbl b/collects/scribblings/reference/vectors.scrbl
index b13d48a30c..fd90298fb3 100644
--- a/collects/scribblings/reference/vectors.scrbl
+++ b/collects/scribblings/reference/vectors.scrbl
@@ -184,7 +184,7 @@ Applies @scheme[proc] to the elements of the @scheme[vec]s from the
 v
 ]}
 
-@defproc[(vector-append [lst list?] ...) list?]{
+@defproc[(vector-append [vec vector?] ...) vector?]{
 
 Creates a fresh vector that contains all
 of the elements of the given vectors in order. 
@@ -194,19 +194,19 @@ of the elements of the given vectors in order.
 }
 
 
-@defproc[(vector-take [vec vector?] [pos exact-nonnegative-integer?]) list?]{
+@defproc[(vector-take [vec vector?] [pos exact-nonnegative-integer?]) vector?]{
 Returns a fresh vector whose elements are the first @scheme[pos] elements of
 @scheme[vec].  If @scheme[vec] has fewer than
-@scheme[pos] elements, the @exnraise[exn:fail:contract].
+@scheme[pos] elements, then the @exnraise[exn:fail:contract].
 
 @mz-examples[#:eval vec-eval
  (vector-take #(1 2 3 4) 2)
 ]}
 
-@defproc[(vector-take-right [vec vector?] [pos exact-nonnegative-integer?]) list?]{
+@defproc[(vector-take-right [vec vector?] [pos exact-nonnegative-integer?]) vector?]{
 Returns a fresh vector whose elements are the last @scheme[pos] elements of
 @scheme[vec].  If @scheme[vec] has fewer than
-@scheme[pos] elements, the @exnraise[exn:fail:contract].
+@scheme[pos] elements, then the @exnraise[exn:fail:contract].
 
 @mz-examples[#:eval vec-eval
  (vector-take-right #(1 2 3 4) 2)
@@ -215,7 +215,7 @@ Returns a fresh vector whose elements are the last @scheme[pos] elements of
 @defproc[(vector-drop [vec vector?] [pos exact-nonnegative-integer?]) vector?]{
 Returns a fresh vector whose elements are the elements of @scheme[vec]
  after the first @scheme[pos] elements.  If @scheme[vec] has fewer
- than @scheme[pos] elements, the @exnraise[exn:fail:contract].
+ than @scheme[pos] elements, then the @exnraise[exn:fail:contract].
 
 @mz-examples[#:eval vec-eval
  (vector-drop #(1 2 3 4) 2)
@@ -224,7 +224,7 @@ Returns a fresh vector whose elements are the elements of @scheme[vec]
 @defproc[(vector-drop-right [vec vector?] [pos exact-nonnegative-integer?]) vector?]{
 Returns a fresh vector whose elements are the elements of @scheme[vec]
  before the first @scheme[pos] elements.  If @scheme[vec] has fewer
- than @scheme[pos] elements, the @exnraise[exn:fail:contract].
+ than @scheme[pos] elements, then the @exnraise[exn:fail:contract].
 
 @mz-examples[#:eval vec-eval
  (vector-drop-right #(1 2 3 4) 2)
@@ -288,11 +288,11 @@ returns @scheme[#f].
 ]}
 
 
-@defproc[(vector-count [proc procedure?] [lst list?] ...+)
-         list?]{
+@defproc[(vector-count [proc procedure?] [vec vector?] ...+)
+         exact-nonnegative-integer?]{
 
-Returns @scheme[(vector-length (vector-filter proc lst ...))], but
-without building the intermediate list.
+Returns the number of elements of the @scheme[vec ...] (taken in
+parallel) on which @scheme[proc] does not evaluate to @scheme[#f].
 
 @mz-examples[#:eval vec-eval
 (vector-count even? #(1 2 3 4 5))

From eb95fbfda3f48fc9a86c4b8eaf192688b546b6d5 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sun, 6 Dec 2009 00:17:23 +0000
Subject: [PATCH 113/136] two more typos like the ones ryan fixed earlier

svn: r17219
---
 collects/scribblings/reference/stx-trans.scrbl | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl
index 003a7a4eaa..9af0edf601 100644
--- a/collects/scribblings/reference/stx-trans.scrbl
+++ b/collects/scribblings/reference/stx-trans.scrbl
@@ -63,7 +63,7 @@ is identified by the @scheme[prop:set!-transformer] property of
 
 @defthing[prop:set!-transformer struct-type-property?]{
 
-A @tech{structure type property} to indentify structure types that act
+A @tech{structure type property} to identify structure types that act
 as @tech{assignment transformers} like the ones created by
 @scheme[make-set!-transformer].
 
@@ -133,7 +133,7 @@ create @scheme[transformer] or as indicated by a
 
 @defthing[prop:rename-transformer struct-type-property?]{
 
-A @tech{structure type property} to indentify structure types that act
+A @tech{structure type property} to identify structure types that act
 as @tech{rename transformers} like the ones created by
 @scheme[make-rename-transformer].
 

From 259350a7e1ec665b1773e448a3e3e16347dea73b Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sun, 6 Dec 2009 05:06:40 +0000
Subject: [PATCH 114/136] untabity and minor formatting

svn: r17222
---
 collects/tests/mzscheme/stx.ss | 642 +++++++++++++++++----------------
 1 file changed, 328 insertions(+), 314 deletions(-)

diff --git a/collects/tests/mzscheme/stx.ss b/collects/tests/mzscheme/stx.ss
index 61f836f999..79b0312bce 100644
--- a/collects/tests/mzscheme/stx.ss
+++ b/collects/tests/mzscheme/stx.ss
@@ -72,41 +72,46 @@
 (test 'yes 'dot-literal (syntax-case #'(1 . #t) () [(_ . #t) 'yes] [_ 'no]))
 
 (test '(((x 3) (y 3) (z 3)) ;; each line should be x y z, not x x x...
-	((x 4) (y 4) (z 4))
-	((x 5) (y 5) (z 5)))
+        ((x 4) (y 4) (z 4))
+        ((x 5) (y 5) (z 5)))
       'ellipses
-      (syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) () 
-			      [(_ x (a ...) ((b ...) ...)) #'(((a b) ...) ...)])))
+      (syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) ()
+                       [(_ x (a ...) ((b ...) ...)) #'(((a b) ...) ...)])))
 
 (test '(((x y z 3) (x y z 3) (x y z 3))
-	((x y z 4) (x y z 4) (x y z 4))
-	((x y z 5) (x y z 5) (x y z 5)))
+        ((x y z 4) (x y z 4) (x y z 4))
+        ((x y z 5) (x y z 5) (x y z 5)))
       'ellipses
-      (syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) () 
-			      [(_ x (a ...) ((b ...) ...)) #'(((a ... b) ...) ...)])))
+      (syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) ()
+                       [(_ x (a ...) ((b ...) ...)) #'(((a ... b) ...) ...)])))
 
 
 (test '((1 z) (2 w) (x z) (y w))
       'ellipses
-      (syntax->datum (syntax-case '(((1 2) (x y)) (z w)) () 
-			      [(((a ...) ...) (b ...)) #'((a b) ... ...)])))
+      (syntax->datum (syntax-case '(((1 2) (x y)) (z w)) ()
+                       [(((a ...) ...) (b ...)) #'((a b) ... ...)])))
 
 (test '(#(1) #(2 3))
       'ellipses+vector
-      (syntax->datum 
-       (syntax-case '((1) (2 3)) () [((a ...) ...) #'(#(a ...) ...)])))
+      (syntax->datum
+       (syntax-case '((1) (2 3)) ()
+         [((a ...) ...) #'(#(a ...) ...)])))
 
 (test '(1 2 3 6 8 9 0 1 2 3)
-      syntax->datum 
-      (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () [(((a ...) ...) ...) #'(a ... ... ...)]))
+      syntax->datum
+      (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) ()
+        [(((a ...) ...) ...) #'(a ... ... ...)]))
 (test '((1 2 3) (6) (8 9 0 1 2 3))
-      syntax->datum 
-      (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () [(((a ...) ...) ...) #'((a ... ...) ...)]))
+      syntax->datum
+      (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) ()
+        [(((a ...) ...) ...) #'((a ... ...) ...)]))
 (test '((1) (2 3) (6) (8 9 0) (1 2 3))
-      syntax->datum 
-      (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () [(((a ...) ...) ...) #'((a ...) ... ...)]))
+      syntax->datum
+      (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) ()
+        [(((a ...) ...) ...) #'((a ...) ... ...)]))
 
-(test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20])) (([nn -1] [mm -2]) ([pp -10] [qq -20]))) ()
+(test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20]))
+                      (([nn -1] [mm -2]) ([pp -10] [qq -20]))) ()
         [((([x y] ...) ...) ...)
          (syntax->datum #'(ell ((ull (+ x ...)
                                      ((- x ... y ...) ...))
@@ -118,7 +123,8 @@
             ((ull (+ nn mm) ((- n m 1 2) (- p q 10 20)))
              (ull (+ pp qq) ((- nn mm -1 -2) (- pp qq -10 -20))))))
 
-(test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20])) (([nn -1] [mm -2]) ([pp -10] [qq -20]))) ()
+(test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20]))
+                      (([nn -1] [mm -2]) ([pp -10] [qq -20]))) ()
         [((([x y] ...) ...) ...)
          (syntax->datum #'(ell ((ull (+ x ...)
                                      ((- x ...) ...))
@@ -137,11 +143,11 @@
 (define (tree-map f)
   (lambda (l)
     (if (pair? l)
-	(cons ((tree-map f) (car l))
-	      ((tree-map f) (cdr l)))
-	(if (null? l)
-	    null
-	    (f l)))))
+        (cons ((tree-map f) (car l))
+              ((tree-map f) (cdr l)))
+        (if (null? l)
+            null
+            (f l)))))
 
 (define-syntax mcr
   (lambda (stx)
@@ -154,7 +160,7 @@
 (syntax-case se ()
   [(bg five)
    (let ([bg (syntax bg)]
-	 [five (syntax five)])
+         [five (syntax five)])
      (test 'begin syntax-e bg)
      (test 5 syntax-e five)
 
@@ -203,11 +209,11 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Constructed s, se is part of s, part of s tagged
 
-(define s (syntax-property (with-syntax ([five (syntax-property (quote-syntax 5)
-								'testing
-								12)])
-			     (syntax (mcr2 five)))
-			   'testing 10))
+(define s
+  (syntax-property
+   (with-syntax ([five (syntax-property (quote-syntax 5) 'testing 12)])
+     (syntax (mcr2 five)))
+   'testing 10))
 (define se (expand-once s))
 
 (test (syntax-e (cadr (syntax-e s))) syntax-e se)
@@ -223,14 +229,14 @@
 ;; paren-shape:
 
 (let ([s (with-syntax ([a (quote-syntax [x y])])
-	   #'[a 10])])
+           #'[a 10])])
   (test #f syntax-property #'(x) 'paren-shape)
   (test #\[ syntax-property #'[x] 'paren-shape)
   (test #\[ syntax-property s 'paren-shape)
   (test #\[ syntax-property (syntax-case s () [(b _) #'b]) 'paren-shape))
 
 (let ([s (with-syntax ([(a ...) '(1 2 3)])
-	   #'[a ...])])
+           #'[a ...])])
   (test #\[ syntax-property s 'paren-shape))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -317,16 +323,17 @@
 ;; Symbol Keys
 (test null syntax-property-symbol-keys #'a)
 (let ([ssort (lambda (l)
-	       (if (equal? l '(yep aha))
-		   '(aha yep)
-		   l))])
+               (if (equal? l '(yep aha))
+                   '(aha yep)
+                   l))])
   (test '(aha) syntax-property-symbol-keys (syntax-property #'a 'aha 1))
   (test '(aha yep) ssort (syntax-property-symbol-keys (syntax-property (syntax-property #'a 'aha 1) 'yep 2)))
-  (test '(aha yep) ssort (syntax-property-symbol-keys (syntax-property 
-						       (syntax-property 
-							(syntax-property #'a 'aha 1) 
-							'yep 2)
-						       'aha 3))))
+  (test '(aha yep) ssort (syntax-property-symbol-keys
+                          (syntax-property
+                           (syntax-property
+                            (syntax-property #'a 'aha 1)
+                            'yep 2)
+                           'aha 3))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Test free-identifier=? on different phases via syntax-case*
@@ -349,15 +356,15 @@
   (define-syntax ck
     (lambda (stx)
       (syntax-case stx ()
-	[(_ id et?)
-	 (with-syntax ([cmp (if (syntax-e (syntax et?))
-				(syntax free-transformer-identifier=?)
-				(syntax free-identifier=?))])
-	   (syntax
-	    (lambda (x)
-	      (syntax-case* x (id) cmp
-	        [(_ id) #t]
-		[else #f]))))])))
+        [(_ id et?)
+         (with-syntax ([cmp (if (syntax-e (syntax et?))
+                                (syntax free-transformer-identifier=?)
+                                (syntax free-identifier=?))])
+           (syntax
+            (lambda (x)
+              (syntax-case* x (id) cmp
+                [(_ id) #t]
+                [else #f]))))])))
 
   (define has-lam? (ck case-lambda #f))
   (define has-mz:lam? (ck mz:case-lambda #f))
@@ -370,7 +377,7 @@
   (define has-et-mtby? (ck b:mtby #t))
 
   (provide has-lam? has-mz:lam? has-mtax? has-mtby?
-	   has-et-lam? has-et-mz:lam? has-et-mtax? has-et-mtby?))
+           has-et-lam? has-et-mz:lam? has-et-mtax? has-et-mtby?))
 
 (require 'mt1)
 (require (for-syntax 'mtb))
@@ -410,13 +417,13 @@
       (datum->syntax
        stx
        (cons
-	(quote-syntax quote-syntax)
-	(cdr (syntax-e stx)))
+        (quote-syntax quote-syntax)
+        (cdr (syntax-e stx)))
        stx)))
 
   (define-values (run-mt2-test)
     (lambda (test)
-      
+
       (test #t has-lam? #'(any case-lambda))
       (test #f has-lam? #'(any case-lambada))
 
@@ -469,34 +476,40 @@
                (cdddr b))
         b)))
 
-(test '('#%kernel case-lambda (lib "scheme/init") case-lambda 0 0 0)  identifier-binding* #'case-lambda)
-(test '(scheme/promise delay* (lib "scheme/init") delay 0 0 0)  identifier-binding* #'delay)
-(test '('#%kernel #%module-begin (lib "scheme/init") #%plain-module-begin 0 0 0)  identifier-binding* #'#%plain-module-begin)
+(test '('#%kernel case-lambda (lib "scheme/init") case-lambda 0 0 0)
+      identifier-binding* #'case-lambda)
+(test '(scheme/promise delay* (lib "scheme/init") delay 0 0 0)
+      identifier-binding* #'delay)
+(test '('#%kernel #%module-begin (lib "scheme/init") #%plain-module-begin 0 0 0)
+      identifier-binding* #'#%plain-module-begin)
 (require (only-in scheme/base [#%plain-module-begin #%pmb]))
-(test '('#%kernel #%module-begin scheme/base #%plain-module-begin 0 0 0)  identifier-binding* #'#%pmb)
+(test '('#%kernel #%module-begin scheme/base #%plain-module-begin 0 0 0)
+      identifier-binding* #'#%pmb)
 
-(let ([b (identifier-binding (syntax-case (expand #'(module m scheme/base
-						      (require (only-in (lib "lang/htdp-intermediate.ss") [cons bcons]))
-						      bcons)) ()
-			       [(mod m mz (#%mod-beg req (app call-with-values (lambda () cons) print)))
-				(let ([s (syntax cons)])
-				  (test 'bcons syntax-e s)
-				  s)]))])
+(let ([b (identifier-binding
+          (syntax-case (expand #'(module m scheme/base
+                                   (require (only-in (lib "lang/htdp-intermediate.ss") [cons bcons]))
+                                   bcons)) ()
+            [(mod m mz (#%mod-beg req (app call-with-values (lambda () cons) print)))
+             (let ([s (syntax cons)])
+               (test 'bcons syntax-e s)
+               s)]))])
   (let-values ([(real real-base) (module-path-index-split (car b))]
-	       [(nominal nominal-base) (module-path-index-split (caddr b))])
+               [(nominal nominal-base) (module-path-index-split (caddr b))])
     (test '"teachprims.ss" values real)
     (test 'beginner-cons cadr b)
     (test '(lib "lang/htdp-intermediate.ss") values nominal)
     (test 'cons cadddr b)))
 
-(let ([b (identifier-binding (syntax-case (expand #'(module m (lib "lang/htdp-intermediate.ss")
-						      cons)) ()
-			       [(mod m beg (#%mod-beg (app call-w-vals (lam () cons) prnt)))
-				(let ([s (syntax cons)])
-				  (test 'cons syntax-e s)
-				  s)]))])
+(let ([b (identifier-binding
+          (syntax-case (expand #'(module m (lib "lang/htdp-intermediate.ss")
+                                   cons)) ()
+            [(mod m beg (#%mod-beg (app call-w-vals (lam () cons) prnt)))
+             (let ([s (syntax cons)])
+               (test 'cons syntax-e s)
+               s)]))])
   (let-values ([(real real-base) (module-path-index-split (car b))]
-	       [(nominal nominal-base) (module-path-index-split (caddr b))])
+               [(nominal nominal-base) (module-path-index-split (caddr b))])
     (test '"teachprims.ss" values real)
     (test 'beginner-cons cadr b)
     (test '(lib "lang/htdp-intermediate.ss") values nominal)
@@ -516,18 +529,18 @@
   (err/rt-test (eval-syntax 'eval))
   (err/rt-test (eval-syntax eval))
   (test eval eval-syntax #'eval)
-  (test #t 
-	'eval-syntax
-	(with-handlers ([exn:fail:syntax? (lambda (x) #t)])
-	  (eval-syntax (datum->syntax #f 'eval))))
+  (test #t
+        'eval-syntax
+        (with-handlers ([exn:fail:syntax? (lambda (x) #t)])
+          (eval-syntax (datum->syntax #f 'eval))))
 
   (test eval (current-eval) 'eval)
   (test eval (current-eval) eval)
   (test eval (current-eval) #'eval)
-  (test #t 
-	'current-eval-syntax
-	(with-handlers ([exn:fail:syntax? (lambda (x) #t)])
-	  ((current-eval) (datum->syntax #f 'eval))))
+  (test #t
+        'current-eval-syntax
+        (with-handlers ([exn:fail:syntax? (lambda (x) #t)])
+          ((current-eval) (datum->syntax #f 'eval))))
 
   (test eval 'compile (eval (compile 'eval)))
   (test eval 'compile (eval (compile eval)))
@@ -537,10 +550,10 @@
   (err/rt-test (compile-syntax 'eval))
   (err/rt-test (compile-syntax eval))
   (test eval 'compile (eval (compile-syntax #'eval)))
-  (test #t 
-	'compile-syntax
-	(with-handlers ([exn:fail:syntax? (lambda (x) #t)])
-	  (compile-syntax (datum->syntax #f 'eval))))
+  (test #t
+        'compile-syntax
+        (with-handlers ([exn:fail:syntax? (lambda (x) #t)])
+          (compile-syntax (datum->syntax #f 'eval))))
 
   (test eval 'expand (eval (expand 'eval)))
   (test eval 'expand (eval (expand eval)))
@@ -550,10 +563,10 @@
   (err/rt-test (expand-syntax 'eval))
   (err/rt-test (expand-syntax eval))
   (test eval 'expand (eval (expand-syntax #'eval)))
-  (test #t 
-	'expand-syntax
-	(with-handlers ([exn:fail:syntax? (lambda (x) #t)])
-	  (expand-syntax (datum->syntax #f 'eval))))
+  (test #t
+        'expand-syntax
+        (with-handlers ([exn:fail:syntax? (lambda (x) #t)])
+          (expand-syntax (datum->syntax #f 'eval))))
 
   (test eval 'expand-once (eval (expand-once 'eval)))
   (test eval 'expand-once (eval (expand-once eval)))
@@ -563,10 +576,10 @@
   (err/rt-test (expand-syntax-once 'eval))
   (err/rt-test (expand-syntax-once eval))
   (test eval 'expand-once (eval (expand-syntax-once #'eval)))
-  (test #t 
-	'expand-syntax-once
-	(with-handlers ([exn:fail:syntax? (lambda (x) #t)])
-	  (expand-syntax-once (datum->syntax #f 'eval))))
+  (test #t
+        'expand-syntax-once
+        (with-handlers ([exn:fail:syntax? (lambda (x) #t)])
+          (expand-syntax-once (datum->syntax #f 'eval))))
 
   (test eval 'expand-to-top-form (eval (expand-to-top-form 'eval)))
   (test eval 'expand-to-top-form (eval (expand-to-top-form eval)))
@@ -591,58 +604,58 @@
   (define (has-p? stx)
     (let ([p (syntax-property stx prop)])
       (and p
-	   (let loop ([p p])
-	     (cond
-	      [(pair? p) (or (loop (car p))
-			     (loop (cdr p)))]
-	      [else (and (identifier? p)
+           (let loop ([p p])
+             (cond
+              [(pair? p) (or (loop (car p))
+                             (loop (cdr p)))]
+              [else (and (identifier? p)
                          (eq? what (syntax-e p)))])))))
-  
+
   (let loop ([stx stx])
     (or (and (has-p? stx)
-	     (or (eq? #t where)
-		 (eq? (syntax-e stx) where)
-		 (and (pair? (syntax-e stx))
-		      (eq? (syntax-e (car (syntax-e stx)))
-			   where))))
-	(syntax-case stx (#%plain-lambda case-lambda begin begin0
+             (or (eq? #t where)
+                 (eq? (syntax-e stx) where)
+                 (and (pair? (syntax-e stx))
+                      (eq? (syntax-e (car (syntax-e stx)))
+                           where))))
+        (syntax-case stx (#%plain-lambda case-lambda begin begin0
                                          set! with-continuation-mark
                                          if #%plain-app module #%plain-module-begin
                                          define-values)
-	  [(#%plain-lambda formals expr ...)
-	   (ormap loop (syntax->list #'(expr ...)))]
-	  [(case-lambda [formals expr ...] ...)
-	   (ormap (lambda (l)
-		    (ormap loop (syntax->list l)))
-		  (syntax->list #'((expr ...) ...)))]
-	  [(let ([(id ...) rhs] ...) expr ...)
-	   (or (free-identifier=? #'let #'let-values)
-	       (free-identifier=? #'let #'letrec-values))
-	   (or (and (boolean? where)
-		    (syntax-case stx ()
-		      [(let [clause ...] expr)
-		       (ormap has-p? (syntax->list #'(clause ...)))]))
-	       (ormap loop (syntax->list #'(expr ...)))
-	       (ormap loop (syntax->list #'(rhs ...))))]
-	  [(begin expr ...)
-	   (ormap loop (syntax->list #'(expr ...)))]
-	  [(begin0 expr ...)
-	   (ormap loop (syntax->list #'(expr ...)))]
-	  [(set! id expr)
-	   (loop #'expr)]
-	  [(with-continuation-mark key val expr)
-	   (or (loop #'key) (loop #'val) (loop #'expr))]
-	  [(if test then else)
-	   (or (loop #'test) (loop #'then) (loop #'else))]
-	  [(#%plain-app expr ...)
-	   (ormap loop (syntax->list #'(expr ...)))]
-	  [(module name init body)
-	   (loop #'body)]
-	  [(#%plain-module-begin expr ...)
-	   (ormap loop (syntax->list #'(expr ...)))]
-	  [(define-values (id ...) expr)
-	   (loop #'expr)]
-	  [_ #f]))))
+          [(#%plain-lambda formals expr ...)
+           (ormap loop (syntax->list #'(expr ...)))]
+          [(case-lambda [formals expr ...] ...)
+           (ormap (lambda (l)
+                    (ormap loop (syntax->list l)))
+                  (syntax->list #'((expr ...) ...)))]
+          [(let ([(id ...) rhs] ...) expr ...)
+           (or (free-identifier=? #'let #'let-values)
+               (free-identifier=? #'let #'letrec-values))
+           (or (and (boolean? where)
+                    (syntax-case stx ()
+                      [(let [clause ...] expr)
+                       (ormap has-p? (syntax->list #'(clause ...)))]))
+               (ormap loop (syntax->list #'(expr ...)))
+               (ormap loop (syntax->list #'(rhs ...))))]
+          [(begin expr ...)
+           (ormap loop (syntax->list #'(expr ...)))]
+          [(begin0 expr ...)
+           (ormap loop (syntax->list #'(expr ...)))]
+          [(set! id expr)
+           (loop #'expr)]
+          [(with-continuation-mark key val expr)
+           (or (loop #'key) (loop #'val) (loop #'expr))]
+          [(if test then else)
+           (or (loop #'test) (loop #'then) (loop #'else))]
+          [(#%plain-app expr ...)
+           (ormap loop (syntax->list #'(expr ...)))]
+          [(module name init body)
+           (loop #'body)]
+          [(#%plain-module-begin expr ...)
+           (ormap loop (syntax->list #'(expr ...)))]
+          [(define-values (id ...) expr)
+           (loop #'expr)]
+          [_ #f]))))
 
 (test #t has-stx-property? (expand #'(let ([x 1]) 2)) 'let-values 'let 'origin)
 
@@ -652,7 +665,7 @@
 (test #t has-stx-property? (expand #'(module m scheme/base (define-struct x (a)))) 'define-syntaxes 'define-struct 'origin)
 
 ;; The s macro also expands to begin:
-(test #t has-stx-property? (expand #'(module m scheme/base 
+(test #t has-stx-property? (expand #'(module m scheme/base
                                        (require (for-syntax scheme/base))
                                        (define-syntax (s stx)
                                          #'(begin
@@ -660,7 +673,7 @@
                                              14))
                                        s))
       '#%app 's 'origin)
-(test #t has-stx-property? (expand #'(module m scheme/base 
+(test #t has-stx-property? (expand #'(module m scheme/base
                                        (require (for-syntax scheme/base))
                                        (define-syntax (s stx)
                                          #'(begin
@@ -688,10 +701,10 @@
 (test #t has-stx-property? (expand #'(let () (define-syntax (x stx) #'(quote y)) x)) 'quote 'x 'origin)
 (let ([check-expr
        (lambda (expr)
-	 (let ([e (expand expr)])
-	   (syntax-case e ()
-	     [(lv (bind ...) beg)
-	      (let ([db (syntax-property #'beg 'disappeared-binding)])
+         (let ([e (expand expr)])
+           (syntax-case e ()
+             [(lv (bind ...) beg)
+              (let ([db (syntax-property #'beg 'disappeared-binding)])
                 (let-values ([(bg e)
                               (syntax-case #'beg (#%plain-app list)
                                 [(bg () (#%plain-app list e))
@@ -731,12 +744,12 @@
 (module ++q scheme/base
   (require (for-syntax '++p
                        scheme/base))
-  (define ++d 11) 
+  (define ++d 11)
   (define-syntax (++o stx) #'++d)
   (define-syntax (++s stx)
     (syntax-case stx ()
-      [(_ id) #'(define-syntax (id stx) 
-		  (datum->syntax #'here (++goo)))]))
+      [(_ id) #'(define-syntax (id stx)
+                  (datum->syntax #'here (++goo)))]))
   (define-syntax (++t stx) (syntax-case stx () [(_ id) #'(define-values (id) ++d)]))
   (define-syntax (++t2 stx) #'(begin ++d))
   (define-syntax (++t3 stx) (syntax-property #'(begin0 ++d) 'certify-mode 'transparent))
@@ -749,14 +762,14 @@
     (syntax-case stx ()
       [(_ id) (datum->syntax #'here (add1 (syntax-local-value #'id)))]))
   (define-syntax (++o2 stx) #'(++check-val ++ds))
-  (define-syntax (++apply-to-ds stx) 
+  (define-syntax (++apply-to-ds stx)
     (syntax-case stx ()
       [(_ id) #'(id ++ds)]))
-  (define-syntax (++apply-to-d stx) 
+  (define-syntax (++apply-to-d stx)
     (syntax-case stx ()
       [(_ id) #'(id ++d)]))
   (provide ++o ++o2 ++s ++t ++t2 ++t3 ++t4 ++v ++v2 ++v3
-	   ++apply-to-d ++apply-to-ds))
+           ++apply-to-d ++apply-to-ds))
 
 (require '++q)
 (++s ++ack)
@@ -767,31 +780,31 @@
 (test 13 values (let () (++t id) 13))
 
 (let-syntax ([goo (lambda (stx)
-		    (syntax-case stx ()
-		      [(_ id) (datum->syntax #'here (sub1 (syntax-local-value #'id)))]))])
+                    (syntax-case stx ()
+                      [(_ id) (datum->syntax #'here (sub1 (syntax-local-value #'id)))]))])
   (test 16 'goo (++apply-to-ds goo)))
 
 (unless building-flat-tests?
   (test 11 eval-syntax (expand-syntax #'++o))
 
   (test 11 eval-syntax (syntax-case (expand-syntax #'++t2) ()
-			 [(_ x) #'x]))
+                         [(_ x) #'x]))
   (test 11 eval-syntax (syntax-case (expand #'(++t z)) ()
-			 [(d-v (_) x) #'x]))
+                         [(d-v (_) x) #'x]))
   (test 11 eval-syntax (syntax-case (expand-syntax #'++t3) ()
-			 [(_ x) #'x]))
+                         [(_ x) #'x]))
   (test 11 eval-syntax (syntax-case (expand #'(++t4 z)) ()
-			 [(d-v (_) x) #'x]))
+                         [(d-v (_) x) #'x]))
 
   (err/rt-test (teval (syntax-case (expand #'++v) ()
-			[(_ x) #'x]))
-	       exn:fail:syntax?)
+                        [(_ x) #'x]))
+               exn:fail:syntax?)
   (err/rt-test (teval (syntax-case (expand #'++v2) ()
-			[(_ x) #'x]))
-	       exn:fail:syntax?)
+                        [(_ x) #'x]))
+               exn:fail:syntax?)
   (err/rt-test (teval (syntax-case (expand #'++v3) ()
-			[(_ x) #'x]))
-	       exn:fail:syntax?))
+                        [(_ x) #'x]))
+               exn:fail:syntax?))
 
 (let ([expr (expand-syntax #'++v)])
   (test expr syntax-recertify expr expr (current-inspector) #f)
@@ -799,50 +812,50 @@
       (test #t syntax? new)
       (test 'no-marks syntax-e new))
     (test #t syntax? (syntax-recertify (syntax-case expr ()
-					 [(beg id) #'beg])
-				       expr (current-inspector) #f))
+                                         [(beg id) #'beg])
+                                       expr (current-inspector) #f))
     ;; we'd prefer this to fail, but it's defined to succeed:
     (test #t syntax? (syntax-recertify (syntax-case expr ()
-					 [(beg id) #'id])
-				       expr (current-inspector) #f))
+                                         [(beg id) #'id])
+                                       expr (current-inspector) #f))
     (test #t syntax? (syntax-recertify (datum->syntax expr (syntax-e expr))
-				       expr (current-inspector) #f))
+                                       expr (current-inspector) #f))
     ;; we'd prefer this to fail, but it's defined to succeed:
     (test #t syntax? (syntax-recertify (syntax-case expr ()
-					 [(beg id) #'(ack id)])
-				       expr (current-inspector) #f)))
+                                         [(beg id) #'(ack id)])
+                                       expr (current-inspector) #f)))
 
 (let ([expr (expand-syntax #'(++apply-to-d ack))])
   (test '(#%app (#%top . ack) ++d) syntax->datum expr)
   (let ([try (lambda (cvt? other)
-	       (syntax-recertify (datum->syntax 
-				  expr
-				  (cons (car (syntax-e expr))
-					((if cvt?
-					     (lambda (x) (datum->syntax
-							  (cdr (syntax-e expr))
-							  x))
-					     values)
-					 (cons
-					  other
-					  (cdr (syntax-e (cdr (syntax-e expr))))))))
-				 expr
-				 (current-inspector)
-				 #f))])
+               (syntax-recertify (datum->syntax
+                                  expr
+                                  (cons (car (syntax-e expr))
+                                        ((if cvt?
+                                             (lambda (x) (datum->syntax
+                                                          (cdr (syntax-e expr))
+                                                          x))
+                                             values)
+                                         (cons
+                                          other
+                                          (cdr (syntax-e (cdr (syntax-e expr))))))))
+                                 expr
+                                 (current-inspector)
+                                 #f))])
     (test #t syntax? (try #f #'other!))
     (let ([new (try #t #'other!)])
       (test #t syntax? new)
       (test '(#%app other! ++d) syntax->datum new))
     ;; we'd prefer this to fail, but it's defined to succeed:
     (test #t syntax? (try #t (syntax-case expr ()
-			       [(ap _ d) #'d])))))
+                               [(ap _ d) #'d])))))
+
 
-    
 ;; ----------------------------------------
 
 (module ++m scheme/base
   (require (for-syntax scheme/base))
-  (define ++x 10) 
+  (define ++x 10)
   (define-syntax (++xm stx) #'100)
   (provide (protect-out ++x ++xm)))
 (module ++n scheme/base
@@ -878,7 +891,7 @@
     (namespace-attach-module n ''++n))
 
   (parameterize ([current-code-inspector i]
-		 [current-namespace n2])
+                 [current-namespace n2])
     (namespace-require 'scheme/base)
     (teval '(require '++n))
 
@@ -895,22 +908,22 @@
     (err/rt-test (teval '++x) exn:fail:syntax?)
     (err/rt-test (teval '++xm) exn:fail:syntax?)
     (err/rt-test (teval '++y-macro2) exn:fail:syntax?)
-    
+
     (teval '(module zrt scheme/base
-	      (require '++n)
-	      (define (vy) ++y)
-	      (define (vy2) ++y-macro)
-	      (define (vu) ++u-macro)
-	      (define (vu2) ++u2)
-	      (provide vy vy2 vu vu2)))
+              (require '++n)
+              (define (vy) ++y)
+              (define (vy2) ++y-macro)
+              (define (vu) ++u-macro)
+              (define (vu2) ++u2)
+              (provide vy vy2 vu vu2)))
     (teval '(module zct scheme/base
               (require (for-syntax scheme/base
                                    '++n))
-	      (define-syntax (wy stx) (datum->syntax #'here ++y))
-	      (let-syntax ([goo ++y-macro]) 10)
-	      (define-syntax (wy2 stx) (datum->syntax #'here ++y-macro))
-	      (define-syntax (wu stx) (datum->syntax #'here ++u-macro))
-	      (provide wy wy2 wu)))
+              (define-syntax (wy stx) (datum->syntax #'here ++y))
+              (let-syntax ([goo ++y-macro]) 10)
+              (define-syntax (wy2 stx) (datum->syntax #'here ++y-macro))
+              (define-syntax (wu stx) (datum->syntax #'here ++u-macro))
+              (provide wy wy2 wu)))
 
     (teval '(require 'zct))
 
@@ -924,14 +937,14 @@
     (test 10 teval '(vy2))
     (test 8 teval '(vu))
     (test 8 teval '(vu2)))
-  
+
   (let ([old-insp (current-code-inspector)])
     (parameterize ([current-code-inspector i]
-		   [current-namespace n2])
+                   [current-namespace n2])
       (namespace-unprotect-module old-insp ''++m)))
 
   (parameterize ([current-code-inspector i]
-		 [current-namespace n2])
+                 [current-namespace n2])
     (test 10 teval '++y-macro)
     (test 10 teval '++y-macro2)))
 
@@ -953,7 +966,7 @@
     (syntax-rules ()
       [(_ get-foo)
        (define-syntax (get-foo stx)
-	 (syntax-local-value #'foo))])))
+         (syntax-local-value #'foo))])))
 (require '++//n)
 (++//def ++//get-foo)
 (test 17 values ++//get-foo)
@@ -966,12 +979,12 @@
   (syntax-case stx ()
     [(_ n)
      (if (zero? (syntax-e #'n))
-	 #'(list #f 0)
-	 (with-syntax ([m (sub1 (syntax-e #'n))])
+         #'(list #f 0)
+         (with-syntax ([m (sub1 (syntax-e #'n))])
            #`(list '#,(syntax-local-lift-context)
                    #,(syntax-local-lift-expression #'(add1 (cadr (@@foo m)))))))]))
 
-(define lifted-output #f) 
+(define lifted-output #f)
 
 (define-syntax (@@goo stx)
   (syntax-case stx ()
@@ -999,9 +1012,9 @@
     (syntax-case stx ()
       [(_ n)
        (if (zero? (syntax-e #'n))
-	   #'0
-	   (with-syntax ([m (sub1 (syntax-e #'n))])
-	     (syntax-local-lift-expression #'(add1 (@@foo m)))))]))
+           #'0
+           (with-syntax ([m (sub1 (syntax-e #'n))])
+             (syntax-local-lift-expression #'(add1 (@@foo m)))))]))
   (define-syntax (@@foox stx)
     (syntax-case stx ()
       [(_ n)
@@ -1024,7 +1037,7 @@
 (test 3
       'ls-foo
       (let-syntax ([z (lambda (stx) #`#,(@@foo 3))])
-	z))
+        z))
 
 (test (void) eval (expand #'(begin-for-syntax (define @@zoo (@@foo 2)))))
 (define-syntax (@@x stx) #`#, @@zoo)
@@ -1052,8 +1065,8 @@
     (syntax-case stx ()
       [(_ n)
        (if (zero? (syntax-e #'n))
-	   #'(list #f 0)
-	   (with-syntax ([m (sub1 (syntax-e #'n))])
+           #'(list #f 0)
+           (with-syntax ([m (sub1 (syntax-e #'n))])
              (let ([prev prev-ctx])
                (if prev
                    (unless (eq? prev (syntax-local-lift-context))
@@ -1107,45 +1120,45 @@
 
 (let ([go-once
        (lambda (eval)
-	 (parameterize ([current-namespace (make-base-namespace)])
-	   (eval '(module mm scheme/base
+         (parameterize ([current-namespace (make-base-namespace)])
+           (eval '(module mm scheme/base
                     (require (for-syntax scheme/base))
-		    (define-syntax (define$ stx)
-		      (syntax-case stx ()
-			[(_ id val)
-			 (with-syntax ([x (datum->syntax #f 'x)])
-			   #'(begin
-			       (define x val)
-			       (define-syntax (id stx) #'x)))]))
-		    (define$ a 1)
-		    (define$ b 2)
-		    (printf "~a ~a~n" a b)))
-	   (eval '(require 'mm))
-	   (eval '(current-namespace (module->namespace ''mm)))
+                    (define-syntax (define$ stx)
+                      (syntax-case stx ()
+                        [(_ id val)
+                         (with-syntax ([x (datum->syntax #f 'x)])
+                           #'(begin
+                               (define x val)
+                               (define-syntax (id stx) #'x)))]))
+                    (define$ a 1)
+                    (define$ b 2)
+                    (printf "~a ~a~n" a b)))
+           (eval '(require 'mm))
+           (eval '(current-namespace (module->namespace ''mm)))
 
-	   (eval '(define$ c 7))
-	   (test '(1 2 7) eval '(list a b c))
-	   (eval '(define$ d 8))
-	   (test '(1 2 7 8) eval '(list a b c d)))
+           (eval '(define$ c 7))
+           (test '(1 2 7) eval '(list a b c))
+           (eval '(define$ d 8))
+           (test '(1 2 7 8) eval '(list a b c d)))
 
-	 (parameterize ([current-namespace (make-base-namespace)])
-	   (eval '(module mm scheme/base
+         (parameterize ([current-namespace (make-base-namespace)])
+           (eval '(module mm scheme/base
                     (require (for-syntax scheme/base))
-		    (define-syntax (define$ stx)
-		      (syntax-case stx ()
-			[(_ id val)
-			 (with-syntax ([x (syntax-local-lift-expression #'val)])
-			   #'(define-syntax (id stx) #'x))]))
-		    (define$ a 1)
-		    (define$ b 2)
-		    (printf "~a ~a~n" a b)))
-	   (eval '(require 'mm))
-	   (eval '(current-namespace (module->namespace ''mm)))
+                    (define-syntax (define$ stx)
+                      (syntax-case stx ()
+                        [(_ id val)
+                         (with-syntax ([x (syntax-local-lift-expression #'val)])
+                           #'(define-syntax (id stx) #'x))]))
+                    (define$ a 1)
+                    (define$ b 2)
+                    (printf "~a ~a~n" a b)))
+           (eval '(require 'mm))
+           (eval '(current-namespace (module->namespace ''mm)))
 
-	   (eval '(define$ c 7))
-	   (test '(1 2 7) eval '(list a b c))
-	   (eval '(define$ d 8))
-	   (test '(1 2 7 8) eval '(list a b c d))))])
+           (eval '(define$ c 7))
+           (test '(1 2 7) eval '(list a b c))
+           (eval '(define$ d 8))
+           (test '(1 2 7 8) eval '(list a b c d))))])
   (go-once eval)
   (go-once (lambda (e) (eval (expand e)))))
 
@@ -1154,14 +1167,14 @@
 
 (test '(1 2) 'macro-nested-lexical
       (let ()
-	(define-syntax (m stx)
-	  (with-syntax ([x1 (let ([x 0]) #'x)]
-			[x2 (let ([x 0]) #'x)])
-	    #'(begin
-		(define x1 1)	
-		(define x2 2)
-		(list x1 x2))))
-	(m)))
+        (define-syntax (m stx)
+          (with-syntax ([x1 (let ([x 0]) #'x)]
+                        [x2 (let ([x 0]) #'x)])
+            #'(begin
+                (define x1 1)
+                (define x2 2)
+                (list x1 x2))))
+        (m)))
 
 (module @!$m scheme/base
   (require (for-syntax scheme/base))
@@ -1169,12 +1182,12 @@
     (syntax-case stx ()
       [(_ id)
        (with-syntax ([x1 (let ([x 0]) #'x)]
-		     [x2 (let ([x 0]) #'x)])
-	 #'(begin
-	     (define x1 10)
-	     (define x2 20)
-	     (define id (list x1 x2
-			      (list? (identifier-binding (quote-syntax x1)))))))]))
+                     [x2 (let ([x 0]) #'x)])
+         #'(begin
+             (define x1 10)
+             (define x2 20)
+             (define id (list x1 x2
+                              (list? (identifier-binding (quote-syntax x1)))))))]))
   (d @!$get)
   (provide @!$get))
 (require '@!$m)
@@ -1191,21 +1204,21 @@
                                      (define z (list b))
                                      z))])
                (goo))))))
-  
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Test lazy unmarshaling of renamings and module-name resolution
 
 (let ([load-ok? #t]
       [old (current-module-name-resolver)])
   (parameterize ([current-namespace (make-base-namespace)]
-		 [current-module-name-resolver
-		  (case-lambda 
-		   [(name)
+                 [current-module-name-resolver
+                  (case-lambda
+                   [(name)
                     (if (equal? name "a")
                         (void)
                         (old name))]
-		   [(name _ __) (make-resolved-module-path 'huh?)]
-		   [(name base stx load?)
+                   [(name _ __) (make-resolved-module-path 'huh?)]
+                   [(name base stx load?)
                     (if (equal? name "a")
                         (begin
                           (unless load-ok?
@@ -1213,43 +1226,43 @@
                           (make-resolved-module-path 'a))
                         (old name base stx load?))])])
     (let ([a-code '(module a scheme/base
-		     (provide x y)
-		     (define x 1)
-		     (define y #'x))])
+                     (provide x y)
+                     (define x 1)
+                     (define y #'x))])
       (eval a-code)
       (let ([b-code (let ([p (open-output-bytes)])
-		      (write (compile
-			      '(module b scheme/base
-				 (require "a")
-				 (provide f)
-				 (define (f) #'x)))
-			     p)
-		      (lambda ()
-			(parameterize ([read-accept-compiled #t])
-			  (read (open-input-bytes (get-output-bytes p))))))]
-	    [x-id (parameterize ([current-namespace (make-base-namespace)])
+                      (write (compile
+                              '(module b scheme/base
+                                 (require "a")
+                                 (provide f)
+                                 (define (f) #'x)))
+                             p)
+                      (lambda ()
+                        (parameterize ([read-accept-compiled #t])
+                          (read (open-input-bytes (get-output-bytes p))))))]
+            [x-id (parameterize ([current-namespace (make-base-namespace)])
                     (printf "here\n")
-		    (eval a-code)
-		    (eval '(require 'a))
-		    (eval '#'x))])
-	(eval (b-code))
-	(eval '(require 'b))
-	(set! load-ok? #f)
-	(test #f eval '(free-identifier=? (f) #'x))
-	(test #t eval `(free-identifier=? (f) (quote-syntax ,x-id)))
-	(eval '(require 'a))
-	(test #t eval '(free-identifier=? (f) #'x))
-	(test #t eval `(free-identifier=? (f) (quote-syntax ,x-id)))
-	(parameterize ([current-namespace (make-base-namespace)])
-	  (eval '(module a scheme/base
-		   (provide y)
-		   (define y 3)))
-	  (set! load-ok? #t)
-	  (eval (b-code))
-	  (eval '(require 'b))
-	  (set! load-ok? #f)
-	  (test #t eval '(free-identifier=? (f) #'x))
-	  (test #f eval `(free-identifier=? (f) (quote-syntax ,x-id))))))))
+                    (eval a-code)
+                    (eval '(require 'a))
+                    (eval '#'x))])
+        (eval (b-code))
+        (eval '(require 'b))
+        (set! load-ok? #f)
+        (test #f eval '(free-identifier=? (f) #'x))
+        (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id)))
+        (eval '(require 'a))
+        (test #t eval '(free-identifier=? (f) #'x))
+        (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id)))
+        (parameterize ([current-namespace (make-base-namespace)])
+          (eval '(module a scheme/base
+                   (provide y)
+                   (define y 3)))
+          (set! load-ok? #t)
+          (eval (b-code))
+          (eval '(require 'b))
+          (set! load-ok? #f)
+          (test #t eval '(free-identifier=? (f) #'x))
+          (test #f eval `(free-identifier=? (f) (quote-syntax ,x-id))))))))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;  certification example from the manual
@@ -1257,7 +1270,7 @@
 (module @-m scheme/base
   (require (for-syntax scheme/base))
   (provide def-go)
-  (define (unchecked-go n x) 
+  (define (unchecked-go n x)
     (+ n 17))
   (define-syntax (def-go stx)
    (syntax-case stx ()
@@ -1275,19 +1288,20 @@
 (require '@-n)
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Propagating inactive certificates through a transparent macro-expansion result:
+;; Propagating inactive certificates through a transparent macro-expansion
+;; result:
 
 (module @!m scheme/base
   (require (for-syntax scheme/base))
   (provide define-x)
-  
+
   (define-syntax (define-x stx)
     (syntax-case stx ()
       [(_ x)
        #'(define-syntax (x stx)
            #'(begin
                (define-y y 10)))]))
-  
+
   (define-syntax define-y
     (syntax-rules ()
       [(_ id v)
@@ -1305,25 +1319,25 @@
 
 (module @w@ scheme/base
   (define add '+)
-  
+
   (provide (rename-out [add plus])))
 
 (module @q@ scheme/base
   (require (for-syntax scheme/base))
   (provide result)
-  
+
   (define-for-syntax a #'plus)
   (define-for-syntax b #'plus)
 
   (define-for-syntax accum null)
-  
-  (begin-for-syntax 
+
+  (begin-for-syntax
    (set! accum (cons (free-identifier=? a #'plus)
                      accum)))
 
   (require '@w@)
 
-  (begin-for-syntax 
+  (begin-for-syntax
    (set! accum (list*
                 (free-identifier=? a #'plus)
                 (free-identifier=? b #'plus)
@@ -1370,8 +1384,8 @@
     (let-syntax ([ref-x (lambda (stx)
                           #`(quote-syntax #,(get-x)))])
       (ref-x)))
-  
-  (with-output-to-file tmp10 
+
+  (with-output-to-file tmp10
     #:exists 'append
     (lambda ()
       (printf "~s\n" (foo)))))
@@ -1405,7 +1419,7 @@
 (module @simp@ scheme/base
 
   (require (for-syntax scheme/base))
-  
+
   (define-syntax-rule (foo)
     (begin
       (define-for-syntax goo #'intro)
@@ -1414,7 +1428,7 @@
         #`(quote #,(identifier-binding goo)))
       (define @simp@tst (extract))
       (provide @simp@tst)))
-  
+
   (foo))
 (require '@simp@)
 

From 6a88daecd860dcf4a4faabec32472e4e70185fc4 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sun, 6 Dec 2009 05:15:20 +0000
Subject: [PATCH 115/136] fixed test for binding of delay that moved again

svn: r17223
---
 collects/tests/mzscheme/stx.ss | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/collects/tests/mzscheme/stx.ss b/collects/tests/mzscheme/stx.ss
index 79b0312bce..468401b84d 100644
--- a/collects/tests/mzscheme/stx.ss
+++ b/collects/tests/mzscheme/stx.ss
@@ -469,6 +469,7 @@
   (let ([b (identifier-binding s)])
     (if (list? b)
         (list* (let-values ([(name base) (module-path-index-split (car b))])
+                 (fprintf (current-error-port) ">>>>base = ~s\n" base)
                  name)
                (cadr b)
                (let-values ([(name base) (module-path-index-split (caddr b))])
@@ -478,7 +479,7 @@
 
 (test '('#%kernel case-lambda (lib "scheme/init") case-lambda 0 0 0)
       identifier-binding* #'case-lambda)
-(test '(scheme/promise delay* (lib "scheme/init") delay 0 0 0)
+(test '("private/promise.ss" delay* (lib "scheme/init") delay 0 0 0)
       identifier-binding* #'delay)
 (test '('#%kernel #%module-begin (lib "scheme/init") #%plain-module-begin 0 0 0)
       identifier-binding* #'#%plain-module-begin)

From 24fff3e4ccbcaf3110132a6e22442adf93a7d11e Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sun, 6 Dec 2009 08:50:37 +0000
Subject: [PATCH 116/136] Welcome to a new PLT day.

svn: r17226
---
 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 5fdefe8006..1a30fe8279 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "5dec2009")
+#lang scheme/base (provide stamp) (define stamp "6dec2009")

From 1a12497bc11471641ba15a1de7b794fa9b5c423c Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sun, 6 Dec 2009 09:11:47 +0000
Subject: [PATCH 117/136] optimize insertionsort: one less loop variable, one
 more addition, unconditional first step

svn: r17227
---
 collects/scheme/private/sort.ss | 18 ++++++++++--------
 1 file changed, 10 insertions(+), 8 deletions(-)

diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss
index 387560366c..a528b57ce9 100644
--- a/collects/scheme/private/sort.ss
+++ b/collects/scheme/private/sort.ss
@@ -76,14 +76,16 @@ doing these checks.
                          (loop a1 b1 c1)))))))))
 
     (define-syntax-rule (copying-insertionsort Alo Blo n)
-      (let iloop ([i 0] [A Alo])
-        (when (i< i n)
-          (let ([ref-i (ref A)])
-            (let jloop ([j (i+ Blo i)])
-              (let ([ref-j-1 (ref (i- j 1))])
-                (if (and (i< Blo j) (<? ref-i ref-j-1))
-                  (begin (set! j ref-j-1) (jloop (i- j 1)))
-                  (begin (set! j ref-i) (iloop (i+ i 1) (i+ A 1))))))))))
+      ;; n is never 0
+      (begin (set! Blo (ref Alo))
+             (let iloop ([i 1])
+               (when (i< i n)
+                 (let ([ref-i (ref (i+ Alo i))])
+                   (let jloop ([j (i+ Blo i)])
+                     (let ([ref-j-1 (ref (i- j 1))])
+                       (if (and (i< Blo j) (<? ref-i ref-j-1))
+                         (begin (set! j ref-j-1) (jloop (i- j 1)))
+                         (begin (set! j ref-i) (iloop (i+ i 1)))))))))))
 
     (define (copying-mergesort Alo Blo n)
       (cond

From f83bf42796dc277d8337ea3f695ec6da03e9d8bc Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sun, 6 Dec 2009 10:46:05 +0000
Subject: [PATCH 118/136] use "anonymous-module" for modules without a source
 file

svn: r17228
---
 collects/syntax/module-reader.ss         |  2 +-
 collects/tests/mzscheme/module-reader.ss | 21 +++++++++++++--------
 2 files changed, 14 insertions(+), 9 deletions(-)

diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss
index 316f1137e5..555d574068 100644
--- a/collects/syntax/module-reader.ss
+++ b/collects/syntax/module-reader.ss
@@ -190,7 +190,7 @@
                    (let-values ([(base name dir?) (split-path p-name)])
                      (string->symbol
                       (path->string (path-replace-suffix name #""))))
-                   'page)]
+                   'anonymous-module)]
            [tag-src (lambda (v)
                       (if stx?
                         (datum->syntax
diff --git a/collects/tests/mzscheme/module-reader.ss b/collects/tests/mzscheme/module-reader.ss
index 826f9c5adf..198d66f723 100644
--- a/collects/tests/mzscheme/module-reader.ss
+++ b/collects/tests/mzscheme/module-reader.ss
@@ -20,7 +20,8 @@
 ;; plain version
 (module r0 syntax/module-reader scheme/base)
 (test-both '(r0) "#reader '~s (define FoO #:bAr)"
-           '(module page scheme/base (#%module-begin (define FoO #:bAr))))
+           '(module anonymous-module scheme/base
+              (#%module-begin (define FoO #:bAr))))
 
 ;; using a simple wrapper to get a case-insensitive reader
 (module r1 syntax/module-reader scheme/base
@@ -35,7 +36,8 @@
     (parameterize ([read-case-sensitive #f]) (apply reader args))))
 ;;
 (test-both '(r1 r2 r3) "#reader '~s (define FoO #:bAr)"
-           '(module page scheme/base (#%module-begin (define foo #:bar))))
+           '(module anonymous-module scheme/base
+              (#%module-begin (define foo #:bar))))
 
 ;; add something to the result
 (module r4 syntax/module-reader zzz
@@ -45,7 +47,8 @@
   #:wrapper1 (lambda (t stx?) (cons (if stx? #'foo 'foo) (t))))
 ;;
 (test-both '(r4 r5) "#reader '~s (define foo #:bar)"
-           '(module page zzz (#%module-begin foo (define foo #:bar))))
+           '(module anonymous-module zzz
+              (#%module-begin foo (define foo #:bar))))
 
 ;; make an empty module, after reading the contents
 (module r6 syntax/module-reader zzz
@@ -57,15 +60,15 @@
 (module r8 syntax/module-reader whatever
   #:wrapper2 (lambda (in rd)
                (if (syntax? (rd in))
-                 #'(module page zzz (#%module-begin))
-                 '(module page zzz (#%module-begin)))))
+                 #'(module anonymous-module zzz (#%module-begin))
+                 '(module anonymous-module zzz (#%module-begin)))))
 ;; the same, the easy way
 (module r9 syntax/module-reader
   #:language (lambda () 'zzz)
   #:wrapper1 (lambda (t) '()))
 ;;
 (test-both '(r6 r7 r8 r9) "#reader '~s (define foo #:bar)"
-           '(module page zzz (#%module-begin)))
+           '(module anonymous-module zzz (#%module-begin)))
 
 ;; a module that uses the scribble syntax with a specified language
 (module r10 syntax/module-reader -ignored-
@@ -91,9 +94,11 @@
   (require scribble/reader))
 ;;
 (test-both '(r10 r11) "#reader '~s scheme/base (define foo 1)"
-           '(module page scheme/base (#%module-begin (define foo 1))))
+           '(module anonymous-module scheme/base
+              (#%module-begin (define foo 1))))
 (test-both '(r10 r11) "#reader '~s scheme/base @define[foo]{one}"
-           '(module page scheme/base (#%module-begin (define foo "one"))))
+           '(module anonymous-module scheme/base
+              (#%module-begin (define foo "one"))))
 
 ;; ----------------------------------------
 

From aaaa4754de4ddf52b8560620045900cad808d69d Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sun, 6 Dec 2009 11:10:53 +0000
Subject: [PATCH 119/136] document new name

svn: r17229
---
 collects/syntax/scribblings/module-reader.scrbl | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl
index 695cc879f8..e44ac24d1b 100644
--- a/collects/syntax/scribblings/module-reader.scrbl
+++ b/collects/syntax/scribblings/module-reader.scrbl
@@ -51,7 +51,7 @@ creates a reader that converts @scheme[#,(hash-lang)_something] into
 ]
 
 where @scheme[_name-id] is derived from the name of the port used by
-the reader.
+the reader, or @scheme[anonymous-module] if the port has no name.
 
 For example, @scheme[scheme/base/lang/reader] is implemented as
 

From 4b7b51b8de8eec06c67cc735ed1cc735731cd210 Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Sun, 6 Dec 2009 17:26:53 +0000
Subject: [PATCH 120/136] PR 10550

svn: r17230
---
 collects/redex/redex.scrbl | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl
index 1988cd8f2e..f53615be1c 100644
--- a/collects/redex/redex.scrbl
+++ b/collects/redex/redex.scrbl
@@ -128,7 +128,7 @@ in the grammar are terminals.
 
 @itemize[
 
-@item{The @defpattech[any] @pattern matches any sepxression.
+@item{The @defpattech[any] @pattern matches any sexpression.
 This @pattern may also be suffixed with an underscore and another
 identifier, in which case they bind the full name (as if it
 were an implicit @pattech[name] @pattern) and match the portion
@@ -192,9 +192,9 @@ symbol except those that are used as literals elsewhere in
 the language.
 }
 
-@item{The @defpattech[hole] @pattern matches anything when inside a matching
+@item{The @defpattech[hole] @pattern matches anything when inside
 the first argument to an @pattech[in-hole] @|pattern|. Otherwise, 
-it matches only the hole.
+it matches only a hole.
 }
 
 @item{The @defpattech[symbol] @pattern stands for a literal symbol that must

From b4ec71329f78dcb0fa6b39286042be156d623eab Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Sun, 6 Dec 2009 20:58:17 +0000
Subject: [PATCH 121/136] fix scribble references -- I have no idea how they
 worked before, since they weren't requiring it anyway.

svn: r17231
---
 collects/eopl/eopl.scrbl | 2 +-
 collects/lazy/lazy.scrbl | 3 ++-
 2 files changed, 3 insertions(+), 2 deletions(-)

diff --git a/collects/eopl/eopl.scrbl b/collects/eopl/eopl.scrbl
index 1296467202..4dc194df97 100644
--- a/collects/eopl/eopl.scrbl
+++ b/collects/eopl/eopl.scrbl
@@ -4,7 +4,7 @@
           scheme/list
           (for-label eopl/eopl
                      scheme/contract
-                     (only-in scheme printf pretty-print)))
+                     (only-in scheme printf pretty-print delay force)))
 
 @(define-syntax-rule (def-mz id)
    (begin
diff --git a/collects/lazy/lazy.scrbl b/collects/lazy/lazy.scrbl
index e5d13c248e..b27d8056ec 100644
--- a/collects/lazy/lazy.scrbl
+++ b/collects/lazy/lazy.scrbl
@@ -1,7 +1,8 @@
 #lang scribble/doc
 @(require (for-label (except-in lazy delay force)
                      (only-in lazy/force ! !! !list !!list)
-                     scheme/contract))
+                     scheme/contract
+                     (only-in scheme/promise promise?)))
 
 @(define-syntax-rule (deflazy mod def id)
    (begin

From 2f4d146ee8482f7462b682c1e44154159b0d41c1 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 7 Dec 2009 05:21:09 +0000
Subject: [PATCH 122/136] half the size of the previous version

svn: r17233
---
 collects/framework/private/decode.ss | 53 ++++++++--------------------
 1 file changed, 15 insertions(+), 38 deletions(-)

diff --git a/collects/framework/private/decode.ss b/collects/framework/private/decode.ss
index da5f086199..8639bb05d9 100644
--- a/collects/framework/private/decode.ss
+++ b/collects/framework/private/decode.ss
@@ -1,43 +1,20 @@
 #lang scheme/base
-(require (for-syntax mzlib/inflate
-                     scheme/base))
-
+(require (for-syntax file/gunzip scheme/base))
 (provide decode)
 
 (define-syntax (decode stx)
+  (define (decode stxs)
+    (define str
+      (apply string-append (map (λ (x) (symbol->string (syntax-e x))) stxs)))
+    (define loc
+      (if (even? (string-length str))
+        (for/list ([i (in-range 0 (string-length str) 2)])
+          (string->number (substring str i (+ i 2)) 16))
+        (error 'decode "missing digit somewhere")))
+    (define-values (p-in p-out) (make-pipe))
+    (inflate (open-input-bytes (apply bytes loc)) p-out)
+    (read p-in))
   (syntax-case stx ()
-    [(_ arg ...)
-     (andmap identifier? (syntax->list (syntax (arg ...))))
-     (let ()
-       (define (decode-sexp str)
-         (let* ([loc 
-                 (let loop ([chars (string->list str)])
-                   (cond
-                     [(null? chars) '()]
-                     [(null? (cdr chars)) (error 'to-sexp "missing digit somewhere")]
-                     [else (let ([fst (to-digit (car chars))]
-                                 [snd (to-digit (cadr chars))])
-                             (cons
-                              (+ (* fst 16) snd)
-                              (loop (cddr chars))))]))])
-           (let-values ([(p-in p-out) (make-pipe)])
-             (inflate (open-input-bytes (apply bytes loc)) p-out)
-             (read p-in))))
-       
-       (define (to-digit char)
-         (cond
-           [(char<=? #\0 char #\9) 
-            (- (char->integer char)
-               (char->integer #\0))]
-           [(char<=? #\a char #\f) 
-            (+ 10 (- (char->integer char)
-                     (char->integer #\a)))]))
-       
-       (define decoded
-         (decode-sexp 
-          (apply 
-           string-append
-           (map (λ (x) (symbol->string (syntax-e x)))
-                (syntax->list (syntax (arg ...)))))))
-       
-       (datum->syntax stx decoded stx))]))
+    [(_ x ...)
+     (andmap identifier? (syntax->list #'(x ...)))
+     (datum->syntax stx (decode (syntax->list #'(x ...))) stx)]))

From 4b68ad9e608b12d54e42290f807f03a76958bd03 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 7 Dec 2009 08:50:40 +0000
Subject: [PATCH 123/136] Welcome to a new PLT day.

svn: r17234
---
 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 1a30fe8279..8a800e301a 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "6dec2009")
+#lang scheme/base (provide stamp) (define stamp "7dec2009")

From 70f085713dd47992f73e44cf088d71837bc818f0 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 7 Dec 2009 13:55:36 +0000
Subject: [PATCH 124/136] PR 10647

svn: r17235
---
 collects/tests/typed-scheme/unit-tests/parse-type-tests.ss | 1 +
 collects/typed-scheme/private/parse-type.ss                | 2 +-
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss
index f88298c97c..e503bb15c9 100644
--- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss
+++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss
@@ -96,6 +96,7 @@
    [#t (-val #t)]
    [#f (-val #f)]
    ["foo" (-val "foo")]
+   ['(1 2 3) (-val '(1 2 3))]
    
    [(Listof Number) (make-Listof  N)]
    
diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss
index 098596766b..a136d9982b 100644
--- a/collects/typed-scheme/private/parse-type.ss
+++ b/collects/typed-scheme/private/parse-type.ss
@@ -215,7 +215,7 @@
       (apply Un (map parse-type (syntax->list #'(ts ...))))]
      [((~and kw quote) t)
       (add-type-name-reference #'kw)
-      (-val (syntax-e #'t))]
+      (-val (syntax->datum #'t))]
      #;
      [(All-kw . rest)
       #:fail-unless (eq? 'All (syntax-e #'All-kw)) #f

From eae4c140fae6f31fec65a9296a0d3e17d13172d7 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 7 Dec 2009 15:34:54 +0000
Subject: [PATCH 125/136] conversion to contracts for optional keywords

svn: r17236
---
 .../typed-scheme/private/type-contract.ss     | 24 ++++++++++++-------
 collects/typed-scheme/rep/type-rep.ss         |  2 +-
 2 files changed, 17 insertions(+), 9 deletions(-)

diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss
index 21276de570..79d76095ff 100644
--- a/collects/typed-scheme/private/type-contract.ss
+++ b/collects/typed-scheme/private/type-contract.ss
@@ -70,26 +70,34 @@
         [(Function: arrs)
          (let ()           
            (define (f a)
-             (define-values (dom* rngs* rst)
+             (define-values (dom* opt-dom* rngs* rst)
                (match a
-                 [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f (list (Keyword: kws ktys #t) ...))
-                  (values (append (map t->c/neg dom) (append-map (lambda (kw kty) (list kw (t->c/neg kty))) kws ktys))
-                          (map t->c rngs) (and rst (t->c/neg rst)))]
+                 [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f kws)
+                  (let-values ([(mand-kws opt-kws) (partition (match-lambda [(Keyword: _ _ mand?) mand?]) kws)]
+                               [(conv) (match-lambda [(Keyword: kw kty _) (list kw (t->c/neg kty))])])
+                    (values (append (map t->c/neg dom) (append-map conv mand-kws))
+                            (append-map conv opt-kws)
+                            (map t->c rngs) 
+                            (and rst (t->c/neg rst))))]
                  [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '())
                   (if (and out? pos?)
-                      (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))
+                      (values (map t->c/neg dom)
+                              null
+                              (map t->c rngs)
+                              (and rst (t->c/neg rst)))
                       (exit (fail)))]
                  [_ (exit (fail))]))
              (trace f)
              (with-syntax 
                  ([(dom* ...) dom*]
+                  [(opt-dom* ...) opt-dom*]
                   [rng* (match rngs*
                           [(list r) r]
                           [_ #`(values #,@rngs*)])]
                   [rst* rst])
-               (if rst
-                   #'((dom* ...) () #:rest (listof rst*) . ->* . rng*)
-                   #'(dom* ...  . -> . rng*))))
+               (if (or rst (pair? (syntax-e #'(opt-dom* ...))))
+                   #'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*)
+                   #'(dom* ... . -> . rng*))))
            (unless (no-duplicates (for/list ([t arrs])
                                     (match t [(arr: dom _ _ _ _) (length dom)])))
              (exit (fail)))
diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss
index d0685d2c95..1c0784fd0f 100644
--- a/collects/typed-scheme/rep/type-rep.ss
+++ b/collects/typed-scheme/rep/type-rep.ss
@@ -272,7 +272,7 @@
 ;; pos-flds  : (Listof Type)
 ;; name-flds : (Listof (Tuple Symbol Type Boolean))
 ;; methods   : (Listof (Tuple Symbol Function))
-(dt Class ([pos-flds (listof Type/c)] 
+(dt Class ([pos-flds (listof Type/c)]
            [name-flds (listof (list/c symbol? Type/c boolean?))]
            [methods (listof (list/c symbol? Function?))])
     [#:frees (combine-frees

From be77cee733f3dbe42bb9581710bbe8d94bfdd906 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 7 Dec 2009 15:50:51 +0000
Subject: [PATCH 126/136] Fix parsing of quoted lists in types to produce list
 types.

svn: r17237
---
 collects/tests/typed-scheme/unit-tests/parse-type-tests.ss | 2 +-
 collects/typed-scheme/private/parse-type.ss                | 3 +++
 2 files changed, 4 insertions(+), 1 deletion(-)

diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss
index e503bb15c9..82f6f91f19 100644
--- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss
+++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss
@@ -96,7 +96,7 @@
    [#t (-val #t)]
    [#f (-val #f)]
    ["foo" (-val "foo")]
-   ['(1 2 3) (-val '(1 2 3))]
+   ['(1 2 3) (-Tuple (map -val '(1 2 3)))]
    
    [(Listof Number) (make-Listof  N)]
    
diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss
index a136d9982b..ffc9a56c25 100644
--- a/collects/typed-scheme/private/parse-type.ss
+++ b/collects/typed-scheme/private/parse-type.ss
@@ -213,6 +213,9 @@
      [((~and kw t:U) ts ...)
       (add-type-name-reference #'kw)
       (apply Un (map parse-type (syntax->list #'(ts ...))))]
+     [((~and kw quote) (t1 . t2))
+      (add-type-name-reference #'kw)
+      (-pair (parse-type #'(quote t1)) (parse-type #'(quote t2)))]
      [((~and kw quote) t)
       (add-type-name-reference #'kw)
       (-val (syntax->datum #'t))]

From ce7b698956435fd6338da0aa50b1b6ae4153ad53 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 7 Dec 2009 18:38:46 +0000
Subject: [PATCH 127/136] more detail on which primitives block

svn: r17238
---
 collects/scribblings/futures/futures.scrbl | 23 ++++++++++++++++------
 1 file changed, 17 insertions(+), 6 deletions(-)

diff --git a/collects/scribblings/futures/futures.scrbl b/collects/scribblings/futures/futures.scrbl
index 42c937708c..a8e4e7f030 100644
--- a/collects/scribblings/futures/futures.scrbl
+++ b/collects/scribblings/futures/futures.scrbl
@@ -103,12 +103,20 @@ subsequent add) will not be performed until the @scheme[touch] call.
 
 @section[#:tag "logging"]{How Do I Keep Those Cores Busy?}
 
-Because it is not always obvious when or where unsafe operations may
-be causing unacceptable performance degradation in parallel programs,
-futures can be configured to generate trace output using the standard
-logging command-line switches.  This output can tell us which
-operations a given future is waiting on at a particular point during
-the program run.  For example, running the code in the previous
+It is not always obvious when or where unsafe operations may
+be causing unacceptable performance degradation in parallel programs.
+A a general guideline, any primitive that is inlined will run in parallel.
+For example, fixnum and flonum addition do run in parallel,
+but not bignum or rational addition. Similarly, vector operations are
+generally safe, but not continuation operations. Also, allocation can run
+in parallel, as long as only a little bit of allocation happens. Once a significant
+amount of allocation happens, a parallel thread has to rendez-vous with the
+runtime thread to get new, local memory.
+
+To help tell what is happening in your program, the parallel threads
+logs all of the points at which it has to syncronize
+with the runtime thread.
+For example, running the code in the previous
 example in the debug log level produces the following output:
 
 @verbatim|{
@@ -118,6 +126,9 @@ example in the debug log level produces the following output:
   12
 }|
 
+The message indicates which future blocked, the time it blocked and
+the primitive operation that caused it to block.
+
 To be sure we are not merely seeing the effects of a race condition in
 this example, we can force the main thread to @scheme[sleep] for an
 unreasonable amount of time:

From 7f47018c47c50e42bf81f9fbecbf285daed0a126 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 7 Dec 2009 19:00:56 +0000
Subject: [PATCH 128/136] typo

svn: r17239
---
 collects/scribblings/futures/futures.scrbl | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/scribblings/futures/futures.scrbl b/collects/scribblings/futures/futures.scrbl
index a8e4e7f030..4241496097 100644
--- a/collects/scribblings/futures/futures.scrbl
+++ b/collects/scribblings/futures/futures.scrbl
@@ -114,7 +114,7 @@ amount of allocation happens, a parallel thread has to rendez-vous with the
 runtime thread to get new, local memory.
 
 To help tell what is happening in your program, the parallel threads
-logs all of the points at which it has to syncronize
+logs all of the points at which it has to synchronize
 with the runtime thread.
 For example, running the code in the previous
 example in the debug log level produces the following output:

From 539519bdad75e2fc8522526017bbec91237403db Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Tue, 8 Dec 2009 07:02:22 +0000
Subject: [PATCH 129/136] Using a language makes this much cuter.  Also use
 base64.

svn: r17240
---
 collects/algol60/bd-tool.ss          |  47 ++++---------
 collects/framework/private/bday.ss   |  70 +++++++++----------
 collects/framework/private/decode.ss |  31 ++++-----
 collects/framework/private/encode.ss | 100 ++++++++++-----------------
 collects/htdp/show-queen.ss          |  23 +++++-
 5 files changed, 118 insertions(+), 153 deletions(-)

diff --git a/collects/algol60/bd-tool.ss b/collects/algol60/bd-tool.ss
index 2e95304066..5d04df0aed 100644
--- a/collects/algol60/bd-tool.ss
+++ b/collects/algol60/bd-tool.ss
@@ -1,35 +1,12 @@
-(module bd-tool mzscheme
-  (require framework/private/decode)
-  (decode 05c1dd6edc460c06d057f9226301b2e86c5c23690103a9835c
-          e53a0f50602852d2ecce8f324379adb7ef3924b6a60aeaf6fb
-          48dd403909a6d24daf634c984a379d189493609a731ce33ac6
-          c4a09c04d351935fc79818949360f2d6f2758c0993f6316f56
-          6c6206a92da91a7a133983683cdf40d91c440a1a36b7aa23fc
-          abd10d341fbd5bf5306c6e550733332856057d0369740ba555
-          dfa08c7f18f40da4d12d683ca18c17666690da92aa41d21aa4
-          806255f4267206d178be814abc5b6872b3d921c94bdc2f2039
-          52d6b047df4073cbd9664fad863dfa8629e6b5e5bf9f27c624
-          7abdedebc4cc0c525b5235e4e49e2d4801c5aae84de40ca2f1
-          7c0365f33f40240554e2dd42939bcd0e495ee27e017d060dab
-          0a496b9082d53c3c92fac6f8c2a0cfa0615521690d52b09a87
-          cdd2ba39e30b338374069578b7d0e466b3439297b8079d2f90
-          c2cca06155a13386791873cc86e7ebcb573c5f5fbe32685855
-          e80cedf1112479893b24ad410a9ef1cca06155a133867990e4
-          25ee785a18529819b4f7f69ed4e0ade5ef0c525b52b570d4e4
-          f0d6f277502a7beb0eed63deacd8abb796ff63907decad3bb4
-          8f79b362afde5a0ef6b1b7eee33f06a92da91af62d0efb0bef
-          2d2983d496540dfb1687bde0bd256590da92aa814abc5ba8f6
-          08474d1e961e8b5d308eddfa8541738e63601cbbf50b28d5cd
-          7a72ace6410ef756c31eab65068d63b71e521d1eaba7e80662
-          06a92da91ae4706f1594eaf0583d4537c8e1deea0594937bb6
-          2005b49a0739dc5b0d7bac96199463118d2039dc5b85bd3b83
-          b239881454e2dd42939bcd0e4d31b7f582e967dcf7133f52f7
-          4de3f9277e3591f3d384a785994125de2d34b9d9ec2836465c
-          ed02496b9002655089770b4d6e363be4706ff582e967dcf713
-          3f52f74de3895f4de4fc3441413916d108121883865585626c
-          ed81a78519f4fb686e20695dad333368585528c6d61e787266
-          66d0f0331be8f7d1dc406ad9dc94999941c3aa8256f320877b
-          ab618fd53263de625d2dcc5bcadaad82722ca211941934b73a
-          20877babc8cccc0c7a6c56d19bc81944e3f906d23ee6cd8abd
-          aee69fedc3adeaab7db8550d474d1e961e8ba1c4bb856a8f70
-          d4e461e9b1d8054f0b33f3ff))
+#lang s-exp framework/private/decode
+bVTbjtsgEP2VqatIdlWyadSLtFIv6lOf+wErgZkYthi8gJPN33cAO3GyfonjM2fOXDi49vgy
+ao9QGy2g6j3KbQhV+Vc1E9waHkLCZ2C0Oi7fo3Om5EkfWoU9Vg3FJB60RfBOiDMTkp9/Eh8j
+1LWEOmDrrAzsh+SR6rej92gjm+CmSQLcEvE7CRGF9c5GBbKBb80VJNEE7Qt/Kih0x0Rf0m+K
+9/wfMieesY1Eij0fNlCLURvJBk7ideuMoaB2tgAVN50zX3c0aSXk9nnoqptKRsdocL0YTfqB
+Rk2x1boPaQeUNHXbYWQnLaNq4HOzGlWoOxVTOHfQruky2W5A9JmR84kWKDe03CDstvsv+WcR
+lZ6fWEmei+1gd5c+xd8fmll88O6oJUI6+l+XhbDkjIJBrfvB+QizJR4T/ERUfH2LswKGp+tu
+B8UDfoKj0/IO3N+BZQ8WT7k8O3je4wbCOKDfECvbd3qlrqxCT02mjYoxxnzUFk2aOFGYtiFy
+G3W25dJVmZwErvGCbdI1uBhhRdjwnkyRrJYl8BibxU1YnqLU3LhuA9UfPgxn+K19VGSnj/A3
+WetdlY4g9bTM6TEE3tHE0/HJu/jc5J3mRVIuGgS8nDwE5U65HtQvo0vbEM5L9AtzTZxYLkWI
+ZzLZTJZIE6Jsmit/ZTet4rZD1iq6hPQBuLaS9kafgjDv3UxCJ0Wsm4t2MRKpP+BrpEqP5bHw
+A6x6JG/zPw==
diff --git a/collects/framework/private/bday.ss b/collects/framework/private/bday.ss
index 72b3d33c00..42dabb813e 100644
--- a/collects/framework/private/bday.ss
+++ b/collects/framework/private/bday.ss
@@ -1,40 +1,32 @@
-#lang scheme/base
-(require "decode.ss")
-(decode
-                 \5d8f4
-              \10ec22010
-             \45aff297b02
-             \0    \69d544
-                   \5da867
-                    \299da9
-                     \360a3
-                     \5404db
-                     \cbde0b
-                     \4b571f
-                      \7798f6
-                      \13ecaf
-                      \2b5f75
-                      \0cf30bc
-                     \7a62b8d0
-                     \194bcdfb
-                     \023787789
-                    \f02\5b091a
-                    \8ab \8eb3d4
-                   \3a9  \02e040
-                   \3ac   \307a74
-                  \ca8    \495944
-                  \6e0     \74fd1
-                 \9ce5     \d88e21
-                 \b04      \f66c25
-                \a97f       \b8d27a
-                \813        \be13c6
-               \0d3e         \dd50a2
-              \86d3          \3f5ede
-              \174a          \3235ad9
-             \ecb40           \2aecb1
-             \ad56            \76292fb
-            \6aeb0            \39ae75f
-           \8f335              \ea955
-            \e7e               \2c7
+#lang s-exp framework/private/decode
 
-  ||\6||\8||\7||\4||\3||\d||\e||\f||\c||\0||\1)
+      XY9BD
+      sIgEEWv
+      8pfMgqRV
+          E3Whn
+           qXtT
+            GOjg
+            AE08
+            fYWp
+             62Nu
+             897D
+            PMxjx
+            heAwtc
+           7G3Lzfs
+           CN4 d0m
+          4K0G giGp
+          R+8w JgC4
+         MA0w  rvkk
+         XCTR   5GkC
+         56T    Peux
+        e8Yo    PtsJ
+        E5X7     jWeY
+       E74T      1gWf
+       ryiR      4OjH
+      y/tK        Waem
+      1XMZ        aIU9
+     ttXK         LuXV
+     1hU2          x7WO
+     f75G          vdLLj
+    9Xuc            CD6A
+    \\\\             A==
diff --git a/collects/framework/private/decode.ss b/collects/framework/private/decode.ss
index 8639bb05d9..47fdae061a 100644
--- a/collects/framework/private/decode.ss
+++ b/collects/framework/private/decode.ss
@@ -1,20 +1,19 @@
 #lang scheme/base
-(require (for-syntax file/gunzip scheme/base))
-(provide decode)
+(require (for-syntax scheme/base file/gunzip net/base64))
+(provide (except-out (all-from-out scheme/base) #%module-begin)
+         (rename-out [module-begin #%module-begin]))
 
-(define-syntax (decode stx)
-  (define (decode stxs)
-    (define str
-      (apply string-append (map (λ (x) (symbol->string (syntax-e x))) stxs)))
-    (define loc
-      (if (even? (string-length str))
-        (for/list ([i (in-range 0 (string-length str) 2)])
-          (string->number (substring str i (+ i 2)) 16))
-        (error 'decode "missing digit somewhere")))
-    (define-values (p-in p-out) (make-pipe))
-    (inflate (open-input-bytes (apply bytes loc)) p-out)
-    (read p-in))
+(define-syntax (module-begin stx)
   (syntax-case stx ()
     [(_ x ...)
-     (andmap identifier? (syntax->list #'(x ...)))
-     (datum->syntax stx (decode (syntax->list #'(x ...))) stx)]))
+     (andmap (lambda (x) (or identifier? (integer? (syntax-e x))))
+             (syntax->list #'(x ...)))
+     (let* ([data  (format "~a" (syntax->datum #'(x ...)))]
+            [data  (substring data 1 (sub1 (string-length data)))]
+            [data  (string->bytes/utf-8 data)]
+            [in    (open-input-bytes (base64-decode data))]
+            [out   (open-output-string)]
+            [out   (begin (inflate in out) (get-output-string out))]
+            [exprs (read (open-input-string (string-append "(" out ")")))]
+            [exprs (datum->syntax stx exprs stx)])
+       #`(#%module-begin #,@exprs))]))
diff --git a/collects/framework/private/encode.ss b/collects/framework/private/encode.ss
index 45084ac28c..4e3c455c02 100644
--- a/collects/framework/private/encode.ss
+++ b/collects/framework/private/encode.ss
@@ -1,67 +1,43 @@
 #lang scheme/base
-(require mzlib/deflate
-         mzlib/match
-         mzlib/pretty)
-(require (for-syntax mzlib/inflate
-                     mzlib/string))
+(require scheme/cmdline scheme/string scheme/match scheme/pretty
+         file/gzip file/gunzip net/base64)
 
-(provide encode-sexp
-         encode-module)
+(define (encode-exprs exprs)
+  (define in
+    (open-input-string
+     (string-join (map (lambda (x) (format "~s" x)) exprs) " ")))
+  (define out (open-output-bytes))
+  (deflate in out)
+  (base64-encode (get-output-bytes out)))
 
-(define (encode-module in-filename out-filename)
-  (call-with-input-file in-filename
-    (λ (port)
-      (let ([mod (read port)])
-        (unless (eof-object? (read port))
-          (error 'encode-module "found an extra expression"))
-        (match mod 
-          [`(module ,m mzscheme ,@(bodies ...))
-           (call-with-output-file out-filename
-             (λ (oport)
-               (let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))])
-                 (fprintf oport "(module ~a mzscheme\n" m)
-                 (fprintf oport "  (require framework/private/decode)\n")
-                 (fprintf oport "  (decode ~a" (car chopped))
-                 (for-each (lambda (chopped)
-                             (fprintf oport "\n          ~a" chopped))
-                           (cdr chopped))
-                 (fprintf oport "))\n")))
-             'truncate 'text)]
-          [else (error 'encode-module "cannot parse module")])))))
+(define (encode-module)
+  (define mod (parameterize ([read-accept-reader #t]) (read)))
+  (when (eof-object? mod) (error 'encode-module "missing module"))
+  (match mod
+    [(list 'module m 'scheme/base (list '#%module-begin exprs ...))
+     (write-bytes #"#lang s-exp framework/private/decode\n")
+     (write-bytes (regexp-replace* #rx"\r\n" (encode-exprs exprs) #"\n"))]
+    [else (error 'encode-module "cannot parse module, must use scheme/base")]))
 
-(define (chop-up sym)
-  (let ([chopping-point 50])
-    (let loop ([str (symbol->string sym)])
-      (cond
-        [(<= (string-length str) chopping-point)
-         (list (string->symbol str))]
-        [else
-         (cons (string->symbol (substring str 0 chopping-point))
-               (loop (substring str chopping-point (string-length str))))]))))
+(define (decode-module)
+  (define mod (parameterize ([read-accept-reader #t]) (read)))
+  (when (eof-object? mod) (error 'encode-module "missing module"))
+  (match mod
+    [(list 'module m 'framework/private/decode
+           (list '#%module-begin exprs ...))
+     (write-bytes #"#lang scheme/base\n")
+     (let* ([data  (format "~a" exprs)]
+            [data  (substring data 1 (sub1 (string-length data)))]
+            [data  (string->bytes/utf-8 data)]
+            [in    (open-input-bytes (base64-decode data))]
+            [out   (open-output-string)]
+            [out   (begin (inflate in out) (get-output-string out))]
+            [exprs (read (open-input-string (string-append "(" out ")")))])
+       (for ([expr (in-list exprs)])
+         (pretty-print expr)))]
+    [else (error 'decode-module "cannot parse module, must use scheme/base")]))
 
-(define (encode-sexp sexp)
-  (define (str->sym string)
-    (string->symbol
-     (apply 
-      string-append
-      (map
-       (λ (x) 
-         (to-hex x))
-       (bytes->list string)))))
-  
-  (define (to-hex n)
-    (let ([digit->hex
-           (λ (d)
-             (cond
-               [(<= d 9) d]
-               [else (integer->char (+ d -10 (char->integer #\a)))]))])
-      (cond
-        [(< n 16) (format "0~a" (digit->hex n))]
-        [else (format "~a~a" 
-                      (digit->hex (quotient n 16))
-                      (digit->hex (modulo n 16)))])))
-  
-  (let ([in (open-input-string (format "~s" sexp))]
-        [out (open-output-bytes)])
-    (deflate in out)
-    (str->sym (get-output-bytes out))))
+(command-line #:once-any
+              ["-e" "encode" (encode-module) (exit)]
+              ["-d" "decode" (decode-module) (exit)])
+(printf "Use `-h' for help\n")
diff --git a/collects/htdp/show-queen.ss b/collects/htdp/show-queen.ss
index c1df747447..bde960a47f 100644
--- a/collects/htdp/show-queen.ss
+++ b/collects/htdp/show-queen.ss
@@ -1 +1,22 @@
-(module show-queen mzscheme (require framework/private/decode) (decode ad56db8ee3360cfd15368b05eca6eecc60fbb05834cd1f14e81714b2cd444a65c923cbb9ec43bfbda464d97226b3e8167db2c5cb21451d512c6a3c2a0385c3d751398442ab1a369dc3f6e761d8c4bf4d39891b2d8681e525497a67cfaa4518a4bd54af23a221618b0765107a876765c7a13a38d1217c382caae6231401071a61ce62a0e541a16ea13857b515ae850fcf05e30fea2bc273397b3ef563ad55038532ca4330652bf43f40f2a42c075ffd76c6c65b0745277a5849a25399dc428422ea2a8de6e86582621b6baa5e28e3f3149c3a0b4f4e47f4a0e054ceee0e0fabff94922ac9aae4a4253aca9b1cab462b34be0ae179dd36e55c844ec56a7527fe2e91ed199de372735a78267fc0b3277d630db915bcdf01e997a4d0d1c998e3becc44e440f159c88749d9170589af99056772652d2d6e77f21bcb0f76346d650deea7d40eb457148dac06dab7b2c4222dbaba15b45b38c1156ee0a51aaa4bfc48f2b848242bc119ffba238b98c296fea225a392e20631876d8290cba1e559f0fe47a391c8144189c442efe9643a55ceab1374a7d99deaabe6ff5338c1e59c439409308bb38e61ac8ff0e167851c4e2e4187c51df652558d229d512c0a1d202174a7ef817bc48da84f67dc3681ab4cb1ff766203f3d56aeb0620ac4dad45f317b505ad8ed21f9db86d12c948db3a7121f2375e98a3c66f1060b93d8a6e8d970ee952196cabfab68f5598d4ef449f7ad23b5aeb283e6ecafbcc506bd50f18f9563ca5dc3eb321332d896414fd980c3e3dfdb22c6558962b2ec78c8b5de2dd2ea7dca30c8f8ebae59bcafdaff9ad0832b7ad37e77f884ca9ce428f480c2f8a0bf039ddb5a972e91a976af0d843f13a5acf7ab840b48042deab24ac9cb5b5a425aa3d93e04a1df740809d6d476d33946b6cfae9ce7155832a2530ed3a50e72b3abb870855424a6d9bfe5ecafbd8a710fbb68e2de7d8b7fbd8a707b1651efb36c596736cb98a7d80f76e56cc684bda97f211e23314d5b460b0bb6e586608ea0ee19a235c57084ba34d1419c61e5d65f09211e69eb87df8853a7c32dab255cfb72008bc445e55fce402c150f7745513ee76b09a505e22416870b05aa5d778c1abdd38c80c31ac1f6246cb98d43d66b6956fb497ecf232c42ebd0ebbf434ecb882d1b69ada73946e27e93649f3900f869e30eaac44c53237cdc3cca4fa934a348d65ab97878bb09f8d49c403cedcc1afe5caecba98d4d6d27363584659cef30d3d1a59e1b2296e83d79efa03b620c2fc04f6307f27ac01683bcaf4a3ff098ed67f81bf71b320c7d66846ad9774df8f46a71ca1a01b29488d14360e4f17451399088f2547e7425293dc64cd48f17ee3e4b60c7759d1de546807b94f56907f550f4e7572a55af0ca8e3457c5ea780b9df08d04eeb049cfd6d20f69a98c99cc87b785cbbaac41a26b1874c3981118b5bc3a9936ce448170e47489bf1f79cf356ad8fc0e7ff01e067e6c68e394f7a767ee8012f9010f8b798099481a60784aef85e3269e62a77b3a99ada6f0b7599161cc8a0bc9931afb9f6db89cff00))
+#lang s-exp framework/private/decode
+rVbbjqQ2EP2VSq9WgnTIzGjzsFql038QKV8QGSja7oDNGNOXfci3p8rGYJieVTbKE7gup8rl
+43JlFl9HZRGyVpWw6yzWPw/DLvzt8klctWIYWJ6TpLfmomqEQZpr8ToiahLW2CiN0Fu8KDMO
+RWNFh/ChWVTVR8g8DlRCX8RAy0ZhW0N2KUojbA0fMoYf1FeE53x2fOrHslUVZEorB96SrdD9
+ANGRkhxc8dsFK2csZJ3oYSUJTnl08xGyoCta1CcnIxTbGF30QmmXpmDVRThyOqEDBed8drfY
+rP5jSionq5yTlmgpb3IsqlahdoUPz+u6yucadCoUqzvzd4lsLmgtV5vTwgv5A14c6SujyS3j
+/Q5IvySFjg5Gn455IiIHis9CPkvKPstIfEssOJMba2lx38jvLG/MqOvCaDxOqTW0VxSVLAba
+tzKagEVX1oJ2C2e4wR2cVENxDR9JHleJZCU4418PZBFS2NNfsGRUUtwh5LCPEHI5tDQL3v+o
+WyQuBVDisGiPdDKdyufVGbrz7E71VfP/2Z/gcs4+ygSYxFnH0MYFeP+zQvYnF6H9YoO9VLVF
+Ec8oFIUOkBC68/fAPeJG0MczrivPVabYfzuxgflqWmMHIKxd2YrqL+oKrTpJd7LivoskI21t
+xZXIXzmhTy1+gwDL7VF0a5y0SJdKY12U92OowqR+J/rUkt7RGkvxcZdvM8O2Vf2AgW/ZU8zt
+Mxsy06JIBtGP0eDT0y/LUvplvuJyyDg7RN4dUso9yvBkqVm+qdz/mt+KIHPbenP+TWBKcRHt
+iMTwLLsCn9OmTeVL17gWg8MestfRONbDFYIFZHKrkrBybo0hLVHtmQQ36rgNAXamHluToNxC
+0493jqvqVTGBadeeOl/RmiMEqBxiavv495JvY5997Ps6tpxj37exzw9iyzT2fYot59hyFbuB
+925WyGhP2pf8EeIzZMW0YLBNN8wTBLVBuKUItxXC0mgjRYaxR1tovCaE2RK3979Q+k9CW7bq
++RZ4gZPIq4KfXCAY6p62qPzd9lYTyksgCM0NplXxNV7wSjsOMkH064eYwTIktcVMtvKN9pJc
+XoY4xNfhEJ+GA1cw2BZTew7S/STdR2ka8sHM4yedlShbxqZ5mJlUf1KJSjwpvXl5uAjH2ZhE
+PODMHfyWr8xui0lpDD03mmWU5Tzf0KORFC4Z4nZ466k/YA3Cz09gmvk7YQ1A21G6H91PcDLu
+C/yNuwU5tEY9tu2S7vvR6JQDFHQjBSmRwobh6apoIhP+seToXEhqkrukGSneb5jcluEuKdqb
+Ch0g9UkK8q/qwalOrlQLXpmR5qpQHWegE66SwB026tlauiEuldaT+fC2cEmX1Uh09YOuHzM8
+o5ZXJ9GGmcgTjpyu4fcj77nEFna/wx+8h4EfG9o45f3pmTugRH7A/WIeYCaSehge0nthuYnH
+2PGeTmarKfxtVmQYsuJC8qTG/hfDl/Mf

From 9d4e34e7cddbc511cbe09a4de18ff3bb3e99eca1 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Tue, 8 Dec 2009 08:50:46 +0000
Subject: [PATCH 130/136] Welcome to a new PLT day.

svn: r17241
---
 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 8a800e301a..1b4c6ab1f8 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "7dec2009")
+#lang scheme/base (provide stamp) (define stamp "8dec2009")

From 48ad997f5ba1c7052c0d0966c913d4b0c317be5a Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Tue, 8 Dec 2009 20:55:37 +0000
Subject: [PATCH 131/136] switch #reader to a #lang at-exp

svn: r17242
---
 collects/framework/gui-utils.ss | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/collects/framework/gui-utils.ss b/collects/framework/gui-utils.ss
index 81d883acf1..c50be8fb68 100644
--- a/collects/framework/gui-utils.ss
+++ b/collects/framework/gui-utils.ss
@@ -1,5 +1,4 @@
-#reader scribble/reader
-#lang scheme/base
+#lang at-exp scheme/base
 
 (require string-constants scheme/gui/base
          scheme/contract scheme/class)

From a429c3ff8de7a4e167704ae89d5f9808f8ac6577 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 8 Dec 2009 22:24:38 +0000
Subject: [PATCH 132/136] first attempt at randomly clicking on drscheme into
 drdr

svn: r17243
---
 .../randomly-click-language-dialog.ss         |   3 +
 .../drscheme/randomly-click-preferences.ss    |   3 +
 collects/tests/drscheme/randomly-click.ss     | 172 ++++++++++++++++++
 3 files changed, 178 insertions(+)
 create mode 100644 collects/tests/drscheme/randomly-click-language-dialog.ss
 create mode 100644 collects/tests/drscheme/randomly-click-preferences.ss
 create mode 100644 collects/tests/drscheme/randomly-click.ss

diff --git a/collects/tests/drscheme/randomly-click-language-dialog.ss b/collects/tests/drscheme/randomly-click-language-dialog.ss
new file mode 100644
index 0000000000..d63009c9e1
--- /dev/null
+++ b/collects/tests/drscheme/randomly-click-language-dialog.ss
@@ -0,0 +1,3 @@
+#lang scheme
+(require "randomly-click.ss")
+(go 'language-dialog)
diff --git a/collects/tests/drscheme/randomly-click-preferences.ss b/collects/tests/drscheme/randomly-click-preferences.ss
new file mode 100644
index 0000000000..ae40c20e8c
--- /dev/null
+++ b/collects/tests/drscheme/randomly-click-preferences.ss
@@ -0,0 +1,3 @@
+#lang scheme
+(require "randomly-click.ss")
+(go 'preferences-dialog)
diff --git a/collects/tests/drscheme/randomly-click.ss b/collects/tests/drscheme/randomly-click.ss
new file mode 100644
index 0000000000..720a5f7774
--- /dev/null
+++ b/collects/tests/drscheme/randomly-click.ss
@@ -0,0 +1,172 @@
+#lang scheme/gui
+(require framework)
+(provide go)
+
+(define numButtonsToPush 200)
+
+;;find-all-actions: area -> (listof (-> void))
+(define (find-all-actions area)
+  (cond
+    [(is-a? area area-container<%>)
+     (apply append (map find-all-actions (send area get-children)))]
+    [(and (is-a? area button%)
+          (send area is-enabled?)
+          (send area is-shown?))
+     (list (case-lambda
+             [(x) (format "button ~s" (send area get-label))]
+             [() (test:button-push area)]))]
+    [(and (is-a? area check-box%)
+          (send area is-enabled?))
+     (let ([func
+            (λ (which-way)
+              (case-lambda 
+                [(x) (format "checkbox ~s" (send area get-label))]
+                [() (test:set-check-box! area which-way)]))])
+       (list (func #t) (func #f)))]
+    [(and (is-a? area radio-box%)
+          (send area is-enabled?))
+     (for/list ([i (in-range 0 (send area get-number))])
+       (case-lambda
+         [(x) (format "radiobox, item ~s" (send area get-item-label i))]
+         [() (test:set-radio-box! area i)]))]
+    [else '()]))
+
+;;find-random-button: area -> random element of the buttons in area
+;;return #f if there is no buttons in area
+(define (find-random-action area)
+  (define buttons (find-all-actions area))
+  (cond
+    ;;Area with no buttons
+    [(null? buttons) #f]
+    [else (list-ref buttons (random (length buttons)))]))
+
+;; Trace the path to the area back to a base-frame
+(define (trace-area area base-frame)
+  (cond
+    [(eq? area base-frame)
+     (list base-frame)]
+    [else
+     (append (trace-area (send area get-parent) base-frame) (list area))]
+    ))
+
+;;toy print-label function
+(define (print-label area)
+  (cond
+    [(is-a? area tab-panel%)
+     ;(send area get-item-label (send area get-selection))]
+     (send area get-item-label 0)]
+    [(is-a? area vertical-panel%)
+     "Vert-Panel"]
+    [(is-a? area horizontal-panel%)
+     "Hort-Panel"]
+    [(is-a? area vertical-pane%)
+     "Vert-Pane"]
+    [(is-a? area horizontal-pane%)
+     "Hort-Pane"]
+    [else
+     (send area get-label)]))
+
+(define (g open-dialog)
+  (thread
+   (λ ()
+     (let ((base-window (get-top-level-focus-window)))
+       (open-dialog)
+       (wait-for-different-frame base-window)
+       (let loop ([n numButtonsToPush]
+                  [actions '()])
+         (cond
+           [(zero? n) 
+            (printf "\n")
+            (exit 0)]
+           [else
+            
+            (printf "~a " n)
+            (when (= 1 (modulo n 10)) (printf "\n"))
+            (flush-output)
+         
+            (let ((window (get-top-level-focus-window)))
+              (cond
+                ;; Back to base-window is not interesting, Reopen
+                [(eq? base-window window)
+                 (open-dialog)
+                 (wait-for-different-frame base-window)
+                 (loop (- n 1) actions)]
+                
+                ;; get-top-level-focus-window returns #f may imply window not in current eventspace
+                ;; but it also might just mean we didn't look into subeventspaces(?)
+                ;; or that we need to wait for something to happen in the GUI(?)
+                [(eq? window #f)
+                 (sleep .1)
+                 (loop (- n 1) actions)]
+                
+                [else
+                 ;; print out the button before the button is pushed
+                 ;; Using the toy print-label function
+                 ;; because some of the parents may not be sent with get-label e.g. vertical-pane%
+                 ;(print (map print-label (trace-area button window)))
+                 (let ([action (find-random-action window)])
+                   (cond
+                     [action
+                      (with-handlers ((exn:fail? (λ (x) 
+                                                   (fprintf (current-error-port)
+                                                            "\nExecution fail: Bug? transcript of ~a clicking follows\n"
+                                                            (send window get-label))
+                                                   (apply show-log (cons action actions))
+                                                   (raise x))))
+                        (action))
+                      (loop (- n 1) (cons action actions))]
+                     [else
+                      (fprintf (current-error-port) "\nExists/Meets window with no button: Bug? -> Reopen Dialog")
+                      (open-dialog)
+                      (loop n actions)]))]))]))))))
+
+(define (show-log . actions)
+  (for ((action (in-list actions)))
+    (fprintf (current-error-port) 
+             "   ~a\n" 
+             (action 'ignored))))
+
+;; the splash screen is in a separate eventspace so wont' show up.
+(define (wait-for-first-frame)
+  (let loop ()
+    (let ([tlws (get-top-level-windows)])
+      (cond
+        [(null? tlws)
+         (sleep 1/10)
+         (loop)]
+        [else (car tlws)]))))
+
+
+(define (wait-for-different-frame win)
+  (let loop ([n 1000])
+    (cond
+      [(zero? n)
+       (error 'wait-for-different-frame "never got that new window, only this one: ~s" win)]
+      [else
+       (let ([tlw (get-top-level-focus-window)])
+         (when (eq? win tlw)
+           (sleep 1/10)
+           (loop (- n 1))))])))
+
+(define orig-display-handler (error-display-handler))
+
+(define (go which-dialog)
+  (dynamic-require 'drscheme #f)
+  
+  ;; reset the uncaught exception handler to be sure we kill everything (drscheme sets it)
+  (uncaught-exception-handler
+   (λ (x)
+     (if (exn? x)
+         (orig-display-handler (exn-message x) x)
+         (fprintf (current-error-port) "uncaught exception ~s\n" x))
+     (exit 1)))
+  
+  (void
+   (thread
+    (λ ()
+      (define drs (wait-for-first-frame))
+      (case which-dialog
+        [(language-dialog)
+         (g (λ () (test:menu-select "Language" "Choose Language...")))]
+        [(preferences-dialog)
+         (g (λ () (preferences:show-dialog)))])))))

From b26bdba77d46013f647b0adf1523a4cc7163a139 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Tue, 8 Dec 2009 22:50:43 +0000
Subject: [PATCH 133/136] Found a small error in in-port's handling of default
 arguments

svn: r17244
---
 collects/scheme/private/for.ss | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/collects/scheme/private/for.ss b/collects/scheme/private/for.ss
index f34104146e..4041239658 100644
--- a/collects/scheme/private/for.ss
+++ b/collects/scheme/private/for.ss
@@ -469,8 +469,8 @@
 
   (define in-port
     (case-lambda
-      [()  (in-port (current-input-port) read)]
-      [(r) (in-port (current-input-port) r)]
+      [()  (in-port read (current-input-port))]
+      [(r) (in-port r (current-input-port))]
       [(r p)
        (unless (and (procedure? r) (procedure-arity-includes? r 1))
          (raise-type-error 'in-port "procedure (arity 1)" r))

From d18403a303c63cd26d113d06cca0e11db6d05ce0 Mon Sep 17 00:00:00 2001
From: John Clements <clements@racket-lang.org>
Date: Wed, 9 Dec 2009 00:06:13 +0000
Subject: [PATCH 134/136] added simple example of _fun

svn: r17245
---
 collects/scribblings/foreign/types.scrbl | 9 +++++++++
 1 file changed, 9 insertions(+)

diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl
index c249299881..654c61aea2 100644
--- a/collects/scribblings/foreign/types.scrbl
+++ b/collects/scribblings/foreign/types.scrbl
@@ -470,6 +470,15 @@ form, only the input @scheme[type-expr]s and the output @scheme[type-expr] are
 specified, and each types is a simple expression, which creates a
 straightforward function type.
 
+For instance,
+
+@schemeblock[
+(_fun _int _string -> _int)
+]
+
+specifies a function that receives an integer and a
+string, and returns an integer.
+
 In its full form, the @scheme[_fun] syntax provides an IDL-like
 language that can be used to create a wrapper function around the
 primitive foreign function.  These wrappers can implement complex

From 357b8cb90b89c3142f8e57733787292ae1cc195e Mon Sep 17 00:00:00 2001
From: John Clements <clements@racket-lang.org>
Date: Wed, 9 Dec 2009 06:06:56 +0000
Subject: [PATCH 135/136] changed error message to include sizes

svn: r17246
---
 collects/scheme/foreign.ss | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/collects/scheme/foreign.ss b/collects/scheme/foreign.ss
index 34a1674e99..7045d05b36 100644
--- a/collects/scheme/foreign.ss
+++ b/collects/scheme/foreign.ss
@@ -1271,9 +1271,9 @@
   (unless (= (ctype-sizeof to-type)
              (ctype-sizeof from-type))
     (raise-mismatch-error 'cast
-                          (format "representation sizes of types differ: ~e to "
-                                  from-type)
-                          to-type))
+                          (format "representation sizes of from and to types differ: ~e and "
+                                  (ctype-sizeof from-type))
+                          (ctype-sizeof to-type)))
   (let ([p2 (malloc from-type)])
     (ptr-set! p2 from-type p)
     (ptr-ref p2 to-type)))

From 4e6117b9d83a50fb04c3d5395b0ce47bba9d0998 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Wed, 9 Dec 2009 08:50:37 +0000
Subject: [PATCH 136/136] Welcome to a new PLT day.

svn: r17247
---
 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 1b4c6ab1f8..f041ff174f 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "8dec2009")
+#lang scheme/base (provide stamp) (define stamp "9dec2009")