Merge branch 'master' of git.racket-lang.org:plt

.mailmap

@@ -11,6 +11,7 @@ Matthew Flatt       <mflatt@racket-lang.org>      <mflatt@debian.cs.utah.edu>
 Matthew Flatt       <mflatt@racket-lang.org>      <mflatt@localhost.(none)>
 Matthew Flatt       <mflatt@racket-lang.org>      <mflatt@mflatt-laptop.(none)>
 Matthew Flatt       <mflatt@racket-lang.org>      <mflatt@mflatt-VirtualBox.(none)>
+Matthew Flatt       <mflatt@racket-lang.org>      <mflatt@ubuntu-12-64.(none)>
 Kathy Gray          <kathyg@racket-lang.org>      <kathryn.gray@cl.cam.ac.uk>
 Kathy Gray          <kathyg@racket-lang.org>      <kathyg@c0133.aw.cl.cam.ac.uk>
 Matthias Felleisen  <matthias@racket-lang.org>    <matthias@ccs.neu.edu>

collects/2htdp/batch-io.rkt

@@ -1,7 +1,12 @@
-#lang racket
+#lang racket/base
 
-(require (for-syntax syntax/parse)
+(require racket/function
-         srfi/13 htdp/error
+         racket/file
+         racket/string
+         racket/local
+         (for-syntax racket/base
+                     syntax/parse)
+         htdp/error
          (rename-in lang/prim (first-order->higher-order f2h))
          "private/csv/csv.rkt")
 
@@ -163,10 +168,13 @@
 ;; split : String [Regexp] -> [Listof String]
 ;; splits a string into a list of substrings using the given delimiter
 ;; (white space by default)
+;;ELI: This shouldn't be needed now, it can use `string-split' as is
+;; (also, the trimming doesn't make sense if the pattern is not a
+;; space--?)
 (define (split str [ptn #rx"[ ]+"])
-  (regexp-split ptn (string-trim-both str)))
+  (regexp-split ptn (string-trim str)))
 
 ;; split-lines : String -> Listof[String]
 ;; splits a string with newlines into a list of lines
 (define (split-lines str)
-  (map string-trim-both (split str "\r*\n")))
+  (map string-trim (split str "\r*\n")))

collects/2htdp/private/check-aux.rkt

@@ -1,6 +1,10 @@
-#lang racket
+#lang racket/base
 
-(require htdp/error)
+(require racket/class
+         racket/list
+         racket/bool
+         racket/match
+         htdp/error)
 
 (provide (all-defined-out))
 

collects/2htdp/private/clauses-spec-and-process.rkt

@@ -1,9 +1,9 @@
-#lang racket
+#lang racket/base
 
 ;; ---------------------------------------------------------------------------------------------------
 ;; provides functions for specifying the shape of big-bang and universe clauses:
 
-(provide function-with-arity expr-with-check except err)
+(provide function-with-arity expr-with-check err)
 
 ;; ... and for checking and processing them 
 
@@ -12,9 +12,13 @@
          ->args
          contains-clause?)
 
-(require 
+(require racket/function
- (for-syntax syntax/parse)
+         racket/list
- (for-template "clauses-spec-aux.rkt" racket (rename-in lang/prim (first-order->higher-order f2h))))
+         racket/bool
+         (for-syntax racket/base syntax/parse)
+         (for-template "clauses-spec-aux.rkt"
+                       racket
+                       (rename-in lang/prim (first-order->higher-order f2h))))
 
 ;; ---------------------------------------------------------------------------------------------------
 ;; specifying the shape of clauses 
@@ -28,15 +32,15 @@
              [(_ x) #`(check> #,tag x)]
              [_ (err tag p msg)])))]))
 
-(define-syntax function-with-arity 
+(define-syntax function-with-arity
-  (syntax-rules (except)
+  (syntax-rules ()
     [(_ arity)
      (lambda (tag)
        (lambda (p)
          (syntax-case p ()
            [(_ x) #`(proc> #,tag (f2h x) arity)]
            [_ (err tag p)])))]
-    [(_ arity except extra ...)
+    [(_ arity #:except extra ...)
      (lambda (tag)
        (lambda (p)
          (syntax-case p ()

collects/2htdp/private/clauses-spec-aux.rkt

@@ -1,4 +1,4 @@
-#lang racket
+#lang racket/base
 
 ;; ---------------------------------------------------------------------------------------------------
 ;; provides constants and functions for specifying the shape of clauses in big-bang and universe 
@@ -6,7 +6,7 @@
 (provide nat> nat? proc> bool> num> ip> string> symbol> string-or-symbol> any> K False True)
 
 (require htdp/error "check-aux.rkt")
-                             
+
 (define (K w . r) w)
 (define (False w) #f)
 (define (True w) #t)

collects/2htdp/private/define-keywords.rkt

@@ -1,4 +1,4 @@
-#lang racket
+#lang racket/base
 
 ;; ---------------------------------------------------------------------------------------------------
 ;; provide a mechanism for defining the shape of big-bang and universe clauses 
@@ -6,7 +6,8 @@
 
 (provide define-keywords DEFAULT)
 
-(require (for-syntax syntax/parse))
+(require racket/class
+         (for-syntax racket/base syntax/parse))
 
 (define-syntax (DEFAULT stx)
   (raise-syntax-error 'DEFAULT "used out of context" stx))

collects/2htdp/private/design.txt

@@ -1,17 +1,15 @@
+Files for constructing universe.rkt:
 
-Files for constructing universe.rkt: 
+ world.rkt              the old world
+                        world%  = (clock-mixin ...) -- the basic world
+                        aworld% = (class world% ...) -- the world with recording
 
- world.rkt              the old world 
+ universe.rkt           the universe server
- 		         world%  = (clock-mixin ...) -- the basic world 
+                        universe% = (clock-mixin ...) -- the basic universe
-		         aworld% = (class world% ...) -- the world with recording
-
- universe.rkt	        the universe server 
- 		        universe% = (clock-mixin ...) -- the basic universe
 
  timer.rkt              the clock-mixin
 
- check-aux.rkt          common primitives 
+ check-aux.rkt          common primitives
- image.rkt              the world image functions 
+ image.rkt              the world image functions
- clauses-spec-and-process.rkt syntactic auxiliaries 
+ clauses-spec-and-process.rkt syntactic auxiliaries
- clauses-spec-aux.rkt        auxiliaries to the syntactic auxiliaries 
+ clauses-spec-aux.rkt        auxiliaries to the syntactic auxiliaries
-

collects/2htdp/private/launch-many-worlds.rkt

@@ -1,6 +1,7 @@
-#lang racket 
+#lang racket/base
 
-(require mred/mred mzlib/etc htdp/error)
+(require racket/list racket/function racket/gui
+         mzlib/etc htdp/error)
 
 (provide
  ;; (launch-many-worlds e1 ... e2)

collects/2htdp/private/utilities.rkt

@@ -1,4 +1,6 @@
-#lang racket
+#lang racket/base
+
+(require racket/contract)
 
 (provide/contract
  ;; like the unix debugging facility

collects/2htdp/uchat/chatter.rkt

@@ -8,15 +8,15 @@
 #|
 
  +------------------------------------------------------------------+
- | from: text text text text text text				    |
+ | from: text text text text text text                              |
- | from*: text text text text text text				    |
+ | from*: text text text text text text                             |
- | ...								    |
+ | ...                                                              |
- | ...								    |
+ | ...                                                              |
  +------------------------------------------------------------------+
- | to: text text text text text text				    |
+ | to: text text text text text text                                |
- | *: text text text text text text				    |
+ | *: text text text text text text                                 |
- | to2: text blah text[]					    |
+ | to2: text blah text[]                                            |
- | ...								    |
+ | ...                                                              |
  +------------------------------------------------------------------+
 
  Convention: the names of participants may not contain ":". 
@@ -88,11 +88,11 @@
 ;; World -> Scene 
 ;; render the world as a scene 
 (define (render w)
-  (local ((define fr (line*-render (world-from w)))
+  (local [(define fr (line*-render (world-from w)))
           (define t1 (line*-render (world-to w)))
           (define last-to-line
-	    (line-render-cursor (world-todraft w) (world-mmdraft w)))
+            (line-render-cursor (world-todraft w) (world-mmdraft w)))
-          (define tt (image-stack t1 last-to-line)))
+          (define tt (image-stack t1 last-to-line))]
     (place-image fr 1 1 (place-image tt 1 MID MT))))
 
 ;; -----------------------------------------------------------------------------
@@ -355,7 +355,7 @@
               [(too-wide? to-new mm) (send to "" from* to*)]
               [else (world-todraft! w to-new)]))]
          ; [(and (boolean? to) (string? mm)) (error 'react "can't happen")]
-         [else				; (and (string? to) (string? mm))
+         [else                          ; (and (string? to) (string? mm))
           ;; the key belongs into the message text 
           (local ((define new-mm (string-append mm key)))
             (cond
@@ -483,7 +483,7 @@
             (on-receive receive)
             (check-with world?)
             (name n)
-	    (state true)
+            (state true)
             (register LOCALHOST)))
 
 (define (run* _)

collects/2htdp/uchat/readme

@@ -1,5 +1,5 @@
-				Chit Chat
+                                Chit Chat
-				---------
+                                ---------
 
 Design and implement a universe program that allows people to chat with
  each other, using short messages.
@@ -11,13 +11,13 @@ A participant uses a chat space, which is a window divided into two spaces:
 
 The two halves display the messages in historical order, with the most
  recent message received/sent at the bottom. When either half is full of
- messages, drop the least recent lines. 
+ messages, drop the least recent lines.
 
 Each message is at most one line of text, which is the width of the
  window. Use 400 pixels for the width of a window, and use 11 point text
- fonts to render lines.  A line consists of two pieces: 
+ fonts to render lines.  A line consists of two pieces:
 
-  -- an address 
+  -- an address
   -- a message
 
  where the address is separated from the message with a ":". The user sends
@@ -28,29 +28,29 @@ Each message is at most one line of text, which is the width of the
 Editing is just entering keys. Ignore all those key strokes that aren't
  one-character strings and of the remaining strings ignore backspace and
  delete. (Of course, if you are ambitious you may wish to assign meaning to
- some of those keys so that chatters can edit a bit.) 
+ some of those keys so that chatters can edit a bit.)
 
 A message whose recipient is "*" is broadcast to every current participant.
  Otherwise a message is sent to the designated recipient, if the string is
  the valid name of a current participant; all other messages disappear in
- the big empty void. 
+ the big empty void.
 
 Each received message is displayed like those that are sent, with an sender
  followed by ":" and the text of the message. If the message went to all
- participants, the sender's name is followed by an asterisk "*". 
+ participants, the sender's name is followed by an asterisk "*".
 
 As you work on this project, you will encounter questions for which this
 problem statement doesn't provide enough information to make decisions. You
-must make the decisions on your own, following this procedure: 
+must make the decisions on your own, following this procedure:
- -- do not opt for answers that render the project trivial 
+ -- do not opt for answers that render the project trivial
- -- document all non-trivial answers and the answer you chose 
+ -- document all non-trivial answers and the answer you chose
- -- provide a reason for your choice 
+ -- provide a reason for your choice
-Be concise. 
+Be concise.
 
 ;; -----------------------------------------------------------------------------
 protocol:
 
-Sending and receiving message occur without any synchronization. 
+Sending and receiving message occur without any synchronization.
 
 Clients send messages of the form (list String String) to the server.  The
  first string designates the recipient of the message, the second string
@@ -63,24 +63,24 @@ The Chat Server swaps the name of the recipient of a message with that of
  current participants.
 
 
-   SERVER   		   CLIENT (name1)       CLIENT (name2)
+   SERVER                  CLIENT (name1)       CLIENT (name2)
-     |			     |	  	     	      	         |
+     |                       |                                   |
-     |	name1		     |  % name by which client is known  |
+     |  name1                |  % name by which client is known  |
-     | <-------------------- |	       	  	       	  	 |
+     | <-------------------- |                                   |
-     |			     |					 |
+     |                       |                                   |
-     |	(list name2 txt)     |					 |
+     |  (list name2 txt)     |                                   |
-     | <-------------------- |					 |
+     | <-------------------- |                                   |
-     |			     |					 |
+     |                       |                                   |
-     |			     |	(list name1 txt)		 |
+     |                       |  (list name1 txt)                 |
      | --------------------------------------------------------> |
-     |			     |					 |
+     |                       |                                   |
-     |			     |					 |
+     |                       |                                   |
 
 ;; Client2ServerMsg = (list String String)
-;; interp. recipient followed by message text 
+;; interp. recipient followed by message text
 
 ;; Server2ClientMsg = (list String String)
-;; interp. sender followed by message text. 
+;; interp. sender followed by message text.
 
 ;; -----------------------------------------------------------------------------
 
@@ -88,14 +88,14 @@ chat server: receive message, swap recipient for sender & send message(s)
 
 ;; -----------------------------------------------------------------------------
 
-chat world: 
+chat world:
 
  +------------------------------------------------------------------+
- | from: text text text text text text				    |
+ | from: text text text text text text                              |
- | from*: text text text text text text				    |
+ | from*: text text text text text text                             |
- | ...								    |
+ | ...                                                              |
  +------------------------------------------------------------------+
- | to: text text text text text text				    |
+ | to: text text text text text text                                |
- | *: text text text text text text				    |
+ | *: text text text text text text                                 |
- | ...								    |
+ | ...                                                              |
  +------------------------------------------------------------------+

collects/2htdp/universe.rkt

@@ -56,15 +56,15 @@
   ;; it may specify a clock-tick rate
   [on-tick DEFAULT #'#f
            (function-with-arity
-            1 
+            1
-            except
+            #:except
-            [(_ f rate) 
+            [(_ f rate)
-             #'(list 
+             #'(list
                 (proc> 'on-tick (f2h f) 1)
                 (num> 'on-tick rate (lambda (x) (and (real? x) (positive? x)))
                       "positive number" "rate"))]
             [(_ f rate limit)
-             #'(list 
+             #'(list
                 (proc> 'on-tick (f2h f) 1)
                 (num> 'on-tick rate (lambda (x) (and (real? x) (positive? x)))
                       "positive number" "rate")
@@ -82,11 +82,11 @@
   ;; on-draw must specify a rendering function; 
   ;;   it may specify dimensions
   [on-draw to-draw DEFAULT #'#f
-           (function-with-arity 
+           (function-with-arity
-            1 
+            1
-            except
+            #:except
             [(_ f width height)
-             #'(list (proc> 'to-draw (f2h f) 1) 
+             #'(list (proc> 'to-draw (f2h f) 1)
                      (nat> 'to-draw width "width")
                      (nat> 'to-draw height "height"))])]
   ;; World Nat Nat MouseEvent -> World 
@@ -107,9 +107,9 @@
   ;; World -> Boolean 
   ;; -- stop-when must specify a predicate; it may specify a rendering function
   [stop-when DEFAULT #'False
-             (function-with-arity 
+             (function-with-arity
               1
-              except
+              #:except
               [(_ stop? last-picture)
                #'(list (proc> 'stop-when (f2h stop?) 1)
                        (proc> 'stop-when (f2h last-picture) 1))])]

collects/browser/private/html.rkt

@@ -529,7 +529,7 @@
       v)))
 
 (define html-convert
-  (lambda (a-port a-text)	    
+  (lambda (a-port a-text)
     (let ([content (parse-html a-port)])
       (with-method ([a-text-insert (a-text insert)]
                     [current-pos (a-text last-position)]

collects/compiler/decompile.rkt

@@ -78,7 +78,20 @@
                                     (let-values ([(n b) (module-path-index-split modidx)])
                                       (and (not n) (not b))))
                                (string->symbol (format "_~a" sym))
-                               (string->symbol (format "_~s@~s~a" sym (mpi->string modidx) 
+                               (string->symbol (format "_~s~a@~s~a" 
+                                                       sym 
+                                                       (match constantness
+                                                         ['constant ":c"]
+                                                         ['fixed ":f"]
+                                                         [(function-shape a pm?) 
+                                                          (if pm? ":P" ":p")]
+                                                         [(struct-type-shape c) ":t"]
+                                                         [(constructor-shape a) ":mk"]
+                                                         [(predicate-shape) ":?"]
+                                                         [(accessor-shape c) ":ref"]
+                                                         [(mutator-shape c) ":set!"]
+                                                         [else ""])
+                                                       (mpi->string modidx) 
                                                        (if (zero? phase)
                                                            ""
                                                            (format "/~a" phase)))))]

collects/compiler/demodularizer/alpha.rkt

@@ -1,5 +1,6 @@
-#lang racket
+#lang racket/base
-(require compiler/zo-parse)
+
+(require racket/match racket/contract compiler/zo-parse)
 
 (define (alpha-vary-ctop top)
   (match top

collects/compiler/demodularizer/batch.rkt

@@ -1,4 +1,5 @@
-#lang racket
+#lang racket/base
+
 #|
 Here's the idea:
 
@@ -40,6 +41,7 @@ Here's the idea:
 
 (require racket/pretty
          racket/system
+         racket/cmdline
          "mpi.rkt"
          "util.rkt"
          "nodep.rkt"

collects/compiler/demodularizer/gc-toplevels.rkt

@@ -1,5 +1,10 @@
-#lang racket
+#lang racket/base
-(require compiler/zo-parse
+
+(require racket/match
+         racket/list
+         racket/dict
+         racket/contract
+         compiler/zo-parse
          "util.rkt")
 
 ; XXX Use efficient set structure
@@ -150,21 +155,20 @@
         (match (dict-ref g n)
           [(struct refs (n-tls n-stxs))
            (hash-set! visited? n #t)
-           (local
+           (define-values (new-tls1 new-stxs1)
-             [(define-values (new-tls1 new-stxs1)
+             (for/fold ([new-tls tls]
-                (for/fold ([new-tls tls]
+                        [new-stxs stxs])
-                           [new-stxs stxs])
+                       ([tl (in-list n-tls)])
-                  ([tl (in-list n-tls)])
+               (visit-tl tl new-tls new-stxs)))
-                  (visit-tl tl new-tls new-stxs)))
+           (define new-stxs2
-              (define new-stxs2
+             (for/fold ([new-stxs new-stxs1])
-                (for/fold ([new-stxs new-stxs1])
+                       ([stx (in-list n-stxs)])
-                  ([stx (in-list n-stxs)])
+               (define this-stx (visit-stx stx))
-                  (define this-stx (visit-stx stx))
+               (if this-stx
-                  (if this-stx
+                   (list* this-stx new-stxs)
-                      (list* this-stx new-stxs)
+                   new-stxs)))
-                      new-stxs)))]          
+           (values (list* n new-tls1)
-             (values (list* n new-tls1)
+                   new-stxs2)])))
-                     new-stxs2))])))
   (define stx-visited? (make-hasheq))
   (define (visit-stx n)
     (if (hash-has-key? stx-visited? n)

collects/compiler/demodularizer/merge.rkt

@@ -1,5 +1,9 @@
-#lang racket
+#lang racket/base
-(require compiler/zo-parse
+
+(require racket/list
+         racket/match
+         racket/contract
+         compiler/zo-parse
          "util.rkt"
          "mpi.rkt"
          "nodep.rkt"
@@ -156,12 +160,12 @@
                     (cond
                       [(mod-lift-start . <= . n)
                        ; This is a lift
-                       (local [(define which-lift (- n mod-lift-start))
+                       (define which-lift (- n mod-lift-start))
-                               (define lift-tl (+ top-lift-start lift-offset which-lift))]
+                       (define lift-tl (+ top-lift-start lift-offset which-lift))
-                         (when (lift-tl . >= . max-toplevel)
+                       (when (lift-tl . >= . max-toplevel)
-                           (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" 
+                         (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" 
-                                  name n which-lift num-mod-toplevels mod-num-lifts lift-tl))
+                                name n which-lift num-mod-toplevels mod-num-lifts lift-tl))
-                         lift-tl)]
+                       lift-tl]
                       [else
                        (list-ref toplevel-remap n)]))
                   (lambda (n)

collects/compiler/demodularizer/module.rkt

@@ -1,5 +1,9 @@
-#lang racket
+#lang racket/base
-(require compiler/zo-parse
+
+(require racket/list
+         racket/match
+         racket/contract
+         compiler/zo-parse
          "util.rkt")
 
 (define (->module-path-index s)

collects/compiler/demodularizer/mpi.rkt

@@ -1,5 +1,7 @@
-#lang racket
+#lang racket/base
-(require syntax/modresolve)
+
+(require racket/contract
+         syntax/modresolve)
 
 (define current-module-path (make-parameter #f))
 

collects/compiler/demodularizer/nodep.rkt

@@ -1,5 +1,9 @@
-#lang racket
+#lang racket/base
-(require compiler/zo-parse
+
+(require racket/list
+         racket/match
+         racket/contract
+         compiler/zo-parse
          "util.rkt"
          "mpi.rkt"
          racket/set)
@@ -92,7 +96,8 @@
 
 (define (nodep-form form phase)
   (if (mod? form)
-      (local [(define-values (modvar-rewrite lang-info mods) (nodep-module form phase))]
+      (let-values ([(modvar-rewrite lang-info mods)
+                    (nodep-module form phase)])
         (values modvar-rewrite lang-info (make-splice mods)))
       (error 'nodep-form "Doesn't support non mod forms")))
 

collects/compiler/demodularizer/replace-modidx.rkt

@@ -1,6 +1,10 @@
-#lang racket
+#lang racket/base
-(require unstable/struct
+
+(require racket/match
+         racket/vector
+         unstable/struct
          "util.rkt")
+
 (provide replace-modidx)
 
 (define (replace-modidx expr self-modidx)

collects/compiler/demodularizer/update-toplevels.rkt

@@ -1,5 +1,8 @@
-#lang racket
+#lang racket/base
-(require compiler/zo-structs
+
+(require racket/match
+         racket/contract
+         compiler/zo-structs
          "util.rkt")
 
 (define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt)

collects/compiler/demodularizer/util.rkt

@@ -1,5 +1,7 @@
-#lang racket
+#lang racket/base
-(require compiler/zo-parse)
+
+(require racket/contract
+         compiler/zo-parse)
 
 (define (prefix-syntax-start pre)
   (length (prefix-toplevels pre)))

collects/compiler/embed.rkt

@@ -36,25 +36,25 @@
                                        (list/c (or/c symbol? #f #t)
                                                (or/c path? module-path?)
                                                (listof symbol?))))
-                         #:configure-via-first-module? any/c	 
+                         #:configure-via-first-module? any/c
-                         #:literal-files (listof path-string?)	 
+                         #:literal-files (listof path-string?)
-                         #:literal-expression any/c	 
+                         #:literal-expression any/c
-                         #:literal-expressions (listof any/c)	 
+                         #:literal-expressions (listof any/c)
                          #:cmdline (listof string?)
                          #:gracket? any/c
-                         #:mred? any/c	 
+                         #:mred? any/c
-                         #:variant (or/c '3m 'cgc)	 
+                         #:variant (or/c '3m 'cgc)
                          #:aux (listof (cons/c symbol? any/c))
                          #:collects-path (or/c #f
                                                path-string?
                                                (listof path-string?))
                          #:collects-dest (or/c #f path-string?)
-                         #:launcher? any/c	 
+                         #:launcher? any/c
-                         #:verbose? any/c	 
+                         #:verbose? any/c
-                         #:compiler (-> any/c compiled-expression?)	 
+                         #:compiler (-> any/c compiled-expression?)
                          #:expand-namespace namespace?
                          #:src-filter (-> path? any)
-                         #:on-extension (or/c #f (-> path-string? boolean? any))	 
+                         #:on-extension (or/c #f (-> path-string? boolean? any))
                          #:get-extra-imports (-> path? compiled-module-expression? (listof module-path?)))
                         void?)])
 
@@ -63,4 +63,3 @@
          embedding-executable-is-actually-directory?
          embedding-executable-put-file-extension+style+filters
          embedding-executable-add-suffix)
-

collects/compiler/zo-marshal.rkt

@@ -604,13 +604,51 @@
        [(? void?)
         (out-byte CPT_VOID out)]
        [(struct module-variable (modidx sym pos phase constantness))
+        (define (to-sym n) (string->symbol (format "struct~a" n)))
         (out-byte CPT_MODULE_VAR out)
         (out-anything modidx out)
         (out-anything sym out)
+        (out-anything (cond
+                       [(function-shape? constantness)
+                        (let ([a (function-shape-arity constantness)])
+                          (cond
+                           [(arity-at-least? a) 
+                            (bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1)
+                                         (if (function-shape-preserves-marks? constantness) 1 0))]
+                           [(list? a)
+                            (string->symbol (apply
+                                             string-append
+                                             (add-between
+                                              (for/list ([a (in-list a)])
+                                                (define n (if (arity-at-least? a)
+                                                              (- (add1 (arity-at-least-value a)))
+                                                              a))
+                                                (number->string n))
+                                              ":")))]
+                           [else 
+                            (bitwise-ior (arithmetic-shift a 1) 
+                                         (if (function-shape-preserves-marks? constantness) 1 0))]))]
+                       [(struct-type-shape? constantness)
+                        (to-sym (arithmetic-shift (struct-type-shape-field-count constantness)
+                                                  4))]
+                       [(constructor-shape? constantness)
+                        (to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness)
+                                                                 4)))]
+                       [(predicate-shape? constantness) (to-sym 2)]
+                       [(accessor-shape? constantness)
+                        (to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness)
+                                                                 4)))]
+                       [(mutator-shape? constantness)
+                        (to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness)
+                                                                 4)))]
+                       [(struct-other-shape? constantness)
+                        (to-sym 5)]
+                       [else #f])
+                      out)
         (case constantness
-          [(constant) (out-number -4 out)]
+          [(#f) (void)]
           [(fixed) (out-number -5 out)]
-          [else (void)])
+          [else (out-number -4 out)])
         (unless (zero? phase)
           (out-number -2 out)
           (out-number phase out))

collects/compiler/zo-parse.rkt

@@ -856,6 +856,7 @@
         [(module-var)
          (let ([mod (read-compact cp)]
                [var (read-compact cp)]
+               [shape (read-compact cp)]
                [pos (read-compact-number cp)])
            (let-values ([(flags mod-phase pos)
                          (let loop ([pos pos])
@@ -869,6 +870,33 @@
                             [else (values 0 0 pos)]))])
              (make-module-variable mod var pos mod-phase
                                    (cond
+                                    [shape
+                                     (cond
+                                      [(number? shape) 
+                                       (define n (arithmetic-shift shape -1))
+                                       (make-function-shape (if (negative? n)
+                                                                (make-arity-at-least (sub1 (- n)))
+                                                                n)
+                                                            (odd? shape))]
+                                      [(and (symbol? shape)
+                                            (regexp-match? #rx"^struct" (symbol->string shape)))
+                                       (define n (string->number (substring (symbol->string shape) 6)))
+                                       (case (bitwise-and n #x7)
+                                         [(0) (make-struct-type-shape (arithmetic-shift n -3))]
+                                         [(1) (make-constructor-shape (arithmetic-shift n -3))]
+                                         [(2) (make-predicate-shape)]
+                                         [(3) (make-accessor-shape (arithmetic-shift n -3))]
+                                         [(4) (make-mutator-shape (arithmetic-shift n -3))]
+                                         [else (make-struct-other-shape)])]
+                                      [else
+                                       ;; parse symbol as ":"-separated sequence of arities
+                                       (make-function-shape
+                                        (for/list ([s (regexp-split #rx":" (symbol->string shape))])
+                                          (define i (string->number s))
+                                          (if (negative? i)
+                                              (make-arity-at-least (sub1 (- i)))
+                                              i))
+                                        #f)])]
                                     [(not (zero? (bitwise-and #x1 flags))) 'constant]
                                     [(not (zero? (bitwise-and #x2 flags))) 'fixed]
                                     [else #f]))))]

collects/compiler/zo-structs.rkt

@@ -38,13 +38,26 @@
     [(_ id . rest)
      (define-form-struct* id (id zo) . rest)]))
 
+(define-form-struct function-shape ([arity procedure-arity?]
+                                    [preserves-marks? boolean?]))
+
+(define-form-struct struct-shape ())
+(define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?]))
+(define-form-struct (predicate-shape struct-shape) ())
+(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?]))
+(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?]))
+(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?]))
+(define-form-struct (struct-other-shape struct-shape) ())
+
 ;; In toplevels of resove prefix:
 (define-form-struct global-bucket ([name symbol?])) ; top-level binding
 (define-form-struct module-variable ([modidx module-path-index?] 
                                      [sym symbol?] 
                                      [pos exact-integer?] 
                                      [phase exact-nonnegative-integer?]
-                                     [constantness (or/c #f 'constant 'fixed)]))
+                                     [constantness (or/c #f 'constant 'fixed 
+                                                         function-shape? 
+                                                         struct-shape?)]))
 
 ;; Syntax object
 (define ((alist/c k? v?) l)

collects/data/heap.rkt

@@ -160,13 +160,14 @@
   (in-heap/consume! (heap-copy h)))
 
 (define (in-heap/consume! h)
-  (lambda ()
+  (make-do-sequence
-    (values (lambda () (heap-min h))
+   (lambda ()
-            (lambda () (heap-remove-min! h) #t)
+     (values (lambda (_) (heap-min h))
-            #t
+             (lambda (_) (heap-remove-min! h) #t)
-            (lambda (_) (> (heap-count h) 0))
+             #t
-            (lambda _ #t)
+             (lambda (_) (> (heap-count h) 0))
-            (lambda _ #t))))
+             (lambda _ #t)
+             (lambda _ #t)))))
 
 ;; --------
 
@@ -204,4 +205,7 @@
  [heap->vector (-> heap? vector?)]
  [heap-copy (-> heap? heap?)]
 
- [heap-sort! (-> procedure? vector? void?)])
+ [heap-sort! (-> procedure? vector? void?)]
+ 
+ [in-heap (-> heap? sequence?)]
+ [in-heap/consume! (-> heap? sequence?)])

collects/data/order.rkt

@@ -16,6 +16,7 @@
 ;;       generated hidden property.
 (define-generics (ordered-dict gen:ordered-dict prop:ordered-dict ordered-dict?
                                #:defined-table dict-def-table
+                               #:defaults ()
                                ;; private version needs all kw args, in order
                                #:prop-defined-already? #f
                                #:define-contract #f)

collects/data/scribblings/gvector.scrbl

@@ -123,3 +123,6 @@ Unlike @racket[for/list], the @racket[body] may return zero or
 multiple values; all returned values are added to the gvector, in
 order, on each iteration.
 }
+
+
+@close-eval[the-eval]

collects/data/scribblings/heap.scrbl

@@ -19,62 +19,176 @@ Binary heaps are a simple implementation of priority queues.
          heap?]{
 
 Makes a new empty heap using @racket[<=?] to order elements.
+
+@examples[#:eval the-eval
+  (define a-heap-of-strings (make-heap string<=?))
+  a-heap-of-strings
+  @code:comment{With structs:}
+  (struct node (name val))
+  (define (node<=? x y)
+    (<= (node-val x) (node-val y)))
+  (define a-heap-of-nodes (make-heap node<=?))
+  a-heap-of-nodes]
 }
 
 @defproc[(heap? [x any/c]) boolean?]{
 
 Returns @racket[#t] if @racket[x] is a heap, @racket[#f] otherwise.
+
+@examples[#:eval the-eval
+  (heap? (make-heap <=))
+  (heap? "I am not a heap")]
 }
 
 @defproc[(heap-count [h heap?]) exact-nonnegative-integer?]{
 
 Returns the number of elements in the heap.
+@examples[#:eval the-eval
+  (define a-heap (make-heap <=))
+  (heap-add-all! a-heap '(7 3 9 1 13 21 15 31))
+  (heap-count a-heap)
+]
 }
 
 @defproc[(heap-add! [h heap?] [v any/c] ...) void?]{
 
 Adds each @racket[v] to the heap.
+
+@examples[#:eval the-eval
+  (define a-heap (make-heap <=))
+  (heap-add! a-heap 2009 1009)]
 }
 
+
 @defproc[(heap-add-all! [h heap?] [v (or/c list? vector? heap?)]) void?]{
 
 Adds each element contained in @racket[v] to the heap, leaving
 @racket[v] unchanged.
+
+@examples[#:eval the-eval
+  (define heap-1 (make-heap <=))
+  (define heap-2 (make-heap <=))
+  (define heap-12 (make-heap <=))
+  (heap-add-all! heap-1 '(3 1 4 1 5 9 2 6))
+  (heap-add-all! heap-2 #(2 7 1 8 2 8 1 8))
+  (heap-add-all! heap-12 heap-1)
+  (heap-add-all! heap-12 heap-2)
+  (heap-count heap-12)]
 }
 
 @defproc[(heap-min [h heap?]) any/c]{
 
 Returns the least element in the heap @racket[h], according to the
 heap's ordering. If the heap is empty, an exception is raised.
+
+@examples[#:eval the-eval
+  (define a-heap (make-heap string<=?))
+  (heap-add! a-heap "sneezy" "sleepy" "dopey" "doc"
+             "happy" "bashful" "grumpy")
+  (heap-min a-heap)
+
+  @code:comment{Taking the min of the empty heap is an error:}
+  (heap-min (make-heap <=))
+]
 }
 
 @defproc[(heap-remove-min! [h heap?]) void?]{
 
 Removes the least element in the heap @racket[h]. If the heap is
 empty, an exception is raised.
+
+@examples[#:eval the-eval
+  (define a-heap (make-heap string<=?))
+  (heap-add! a-heap "fili" "fili" "oin" "gloin" "thorin"
+                    "dwalin" "balin" "bifur" "bofur"
+                    "bombur" "dori" "nori" "ori")
+  (heap-min a-heap)
+  (heap-remove-min! a-heap)
+  (heap-min a-heap)]
 }
 
 @defproc[(vector->heap [<=? (-> any/c any/c any/c)] [items vector?]) heap?]{
 
 Builds a heap with the elements from @racket[items]. The vector is not
 modified.
+@examples[#:eval the-eval
+  (struct item (val frequency))
+  (define (item<=? x y)
+    (<= (item-frequency x) (item-frequency y)))
+  (define some-sample-items 
+    (vector (item #\a 17) (item #\b 12) (item #\c 19)))
+  (define a-heap (vector->heap item<=? some-sample-items))
+]
 }
 
 @defproc[(heap->vector [h heap?]) vector?]{
 
 Returns a vector containing the elements of heap @racket[h] in the
 heap's order. The heap is not modified.
+
+@examples[#:eval the-eval
+  (define word-heap (make-heap string<=?))
+  (heap-add! word-heap "pile" "mound" "agglomerate" "cumulation")
+  (heap->vector word-heap)
+]
 }
 
 @defproc[(heap-copy [h heap?]) heap?]{
 
 Makes a copy of heap @racket[h].
+@examples[#:eval the-eval
+  (define word-heap (make-heap string<=?))
+  (heap-add! word-heap "pile" "mound" "agglomerate" "cumulation")
+  (define a-copy (heap-copy word-heap))
+  (heap-remove-min! a-copy)
+  (heap-count word-heap)
+  (heap-count a-copy)
+]
 }
 
 
 @;{--------}
 
-@defproc[(heap-sort! [<=? (-> any/c any/c any/c)] [v vector?]) void?]{
+@defproc[(heap-sort! [<=? (-> any/c any/c any/c)] [v (and/c vector? (not/c immutable?))]) void?]{
 
 Sorts vector @racket[v] using the comparison function @racket[<=?].
+
+@examples[#:eval the-eval
+  (define terms (vector "batch" "deal" "flock" "good deal" "hatful" "lot"))
+  (heap-sort! string<=? terms)
+  terms
+]
 }
+
+
+@defproc[(in-heap/consume! [heap heap?]) sequence?]{
+Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering. 
+The heap is consumed in the process. Equivalent to repeated calling 
+@racket[heap-min], then @racket[heap-remove-min!].
+
+  @examples[#:eval the-eval
+            (define h (make-heap <=))
+            (heap-add-all! h '(50 40 10 20 30))
+
+            (for ([x (in-heap/consume! h)])
+              (displayln x))
+
+            (heap-count h)]
+}
+
+@defproc[(in-heap [heap heap?]) sequence?]{
+Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering.
+Equivalent to @racket[in-heap/consume!] except the heap is copied first.
+
+  @examples[#:eval the-eval
+            (define h (make-heap <=))
+            (heap-add-all! h '(50 40 10 20 30))
+
+            (for ([x (in-heap h)])
+              (displayln x))
+
+            (heap-count h)]
+}
+
+
+@close-eval[the-eval]

collects/data/scribblings/integer-set.scrbl

@@ -151,3 +151,6 @@ Returns the number of integers in the given integer set.}
 
 Returns true if every integer in @racket[x] is also in
 @racket[y], otherwise @racket[#f].}
+
+
+@close-eval[the-eval]

collects/data/scribblings/interval-map.scrbl

@@ -167,3 +167,6 @@ Implementations of @racket[dict-iterate-first],
 Returns @racket[#t] if @racket[v] represents a position in an
 interval-map, @racket[#f] otherwise.
 }
+
+
+@close-eval[the-eval]

collects/data/scribblings/order.scrbl

@@ -251,3 +251,6 @@ a single execution of a program:
 (datum-order (make-fish 'alewife) (make-fowl 'dodo))
 ]
 }
+
+
+@close-eval[the-eval]

collects/data/scribblings/queue.scrbl

@@ -94,3 +94,6 @@ Returns a sequence whose elements are the elements of
   These contracts recognize queues; the latter requires the queue to
   contain at least one value.
 }
+
+
+@close-eval[qeval]

collects/data/scribblings/skip-list.scrbl

@@ -171,3 +171,6 @@ skip-list, @racket[#f] otherwise.
 Returns an association list with the keys and values of
 @racket[skip-list], in order.
 }
+
+
+@close-eval[the-eval]

collects/data/scribblings/splay-tree.scrbl

@@ -174,3 +174,6 @@ splay-tree, @racket[#f] otherwise.
 Returns an association list with the keys and values of @racket[s], in
 order.
 }
+
+
+@close-eval[the-eval]

collects/db/private/odbc/connection.rkt

@@ -656,7 +656,14 @@
                         #:on-notice add-notice!)))
 
     (super-new)
-    (register-finalizer this (lambda (obj) (send obj disconnect)))))
+    (register-finalizer this
+                        (lambda (obj)
+                          ;; Keep a reference to the class to keep all FFI callout objects
+                          ;; (eg, SQLDisconnect) used by its methods from being finalized.
+                          (let ([dont-gc this%])
+                            (send obj disconnect)
+                            ;; Dummy result to prevent reference from being optimized away
+                            dont-gc)))))
 
 ;; ----------------------------------------
 

collects/db/private/odbc/ffi-constants.rkt

@@ -24,7 +24,7 @@
 
 (define SQL_ATTR_ODBC_VERSION   200)
 (define SQL_OV_ODBC2              2)
-(define	SQL_OV_ODBC3              3)
+(define SQL_OV_ODBC3              3)
 
 (define SQL_SUCCESS               0)
 (define SQL_SUCCESS_WITH_INFO     1)

collects/db/private/sqlite3/connection.rkt

@@ -206,7 +206,7 @@
              (let loop ()
                (let ([stmt (sqlite3_next_stmt db #f)])
                  (when stmt
-                   (HANDLE 'disconnect (sqlite3_finalize stmt))
+                   (sqlite3_finalize stmt)
                    (loop))))
              (HANDLE 'disconnect (sqlite3_close db))
              (void))))))
@@ -225,7 +225,7 @@
          (let ([stmt (send pst get-handle)])
            (send pst set-handle #f)
            (when (and stmt -db)
-             (HANDLE fsym (sqlite3_finalize stmt)))
+             (sqlite3_finalize stmt))
            (void)))))
 
     ;; Internal query
@@ -316,7 +316,14 @@
     ;; ----
 
     (super-new)
-    (register-finalizer this (lambda (obj) (send obj disconnect)))))
+    (register-finalizer this
+                        (lambda (obj)
+                          ;; Keep a reference to the class to keep all FFI callout objects
+                          ;; (eg, sqlite3_close) used by its methods from being finalized.
+                          (let ([dont-gc this%])
+                            (send obj disconnect)
+                            ;; Dummy result to prevent reference from being optimized away
+                            dont-gc)))))
 
 ;; ----------------------------------------
 

collects/db/private/sqlite3/ffi.rkt

@@ -58,7 +58,10 @@
 
 (define-sqlite sqlite3_finalize
   (_fun _sqlite3_statement
-        -> _int))
+        -> _int
+        ;; sqlite3_finalize returns error code of last stmt execution,
+        ;; not of finalization; so just ignore
+        -> (void)))
 
 (define-sqlite sqlite3_bind_parameter_count
   (_fun _sqlite3_statement

collects/deinprogramm/DMdA.rkt

@@ -247,7 +247,7 @@
   ((DMdA-cons cons) (%a (list-of %a) -> (list-of %a))
 	     "erzeuge ein Paar aus Element und Liste")
   (pair? (any -> boolean)
-	 "feststellen, ob ein Wert ein Paar ist")	
+	 "feststellen, ob ein Wert ein Paar ist")
   (cons? (any -> boolean)
 	 "feststellen, ob ein Wert ein Paar ist")
   (empty? (any -> boolean)

collects/deinprogramm/run-dmda-code.rkt

@@ -41,7 +41,7 @@
 		   (close-input-port p)
 		   (open-input-text-editor t 0 'end values filename))]
 		[else p])])
-	(port-count-lines! p)		; in case it's new
+	(port-count-lines! p)           ; in case it's new
 	(values p filename))))
 
   (define (open-input-graphical-file/fixed filename)

collects/deinprogramm/world.rkt

@@ -20,8 +20,8 @@
   (provide (all-from-out "image.rkt"))
   
   (provide      ;; forall(World):
-   big-bang	;; Number Number Number World -> true 
+   big-bang     ;; Number Number Number World -> true
-   end-of-time	;; String u Symbol -> World
+   end-of-time  ;; String u Symbol -> World
    )
   
   (provide-higher-order-primitive

collects/drracket/private/app.rkt

@@ -187,11 +187,6 @@
       (insert ".\n\nBased on:\n  ")
       (insert (banner)))
     
-    (when (or (eq? (system-type) 'macos)
-              (eq? (system-type) 'macosx))
-      (send* e
-        (insert "  The A List (c) 1997-2001 Kyle Hammond\n")))
-    
     (let ([tools (sort (drracket:tools:get-successful-tools)
                        (lambda (a b)
                          (string<? (path->string (drracket:tools:successful-tool-spec a))

collects/drracket/private/colored-errors.rkt

@@ -1,13 +1,18 @@
-#lang racket
+#lang racket/base
 
-(define-syntax (test stx) #'(begin)) ;; TODO: convert my test into DrRacket's test framework
+(require (for-syntax racket/base)
-(require ; gmarceau/test
+         racket/list
- parser-tools/lex
+         racket/string
+         racket/contract
+         racket/match
+         parser-tools/lex
          (prefix-in : parser-tools/lex-sre)
          (rename-in srfi/26 [cut //])
          (only-in srfi/1 break)
          unstable/contract)
 
+(define-syntax (test stx) #'(begin)) ;; TODO: convert my test into DrRacket's test framework
+
 ;; An error message has many fragments. The fragments will be concatenated
 ;; before being presented to the user. Some fragment are simply string.
 (struct msg-fragment:str (str) #:transparent)

collects/drracket/private/drracket-normal.rkt

@@ -15,34 +15,35 @@
 
 (define files-to-open (command-line #:args filenames filenames))
 
-(define the-date (seconds->date
+(define startup-date 
-                  (let ([ssec (getenv "PLTDREASTERSECONDS")])
+  (seconds->date
-                    (if ssec
+   (let ([ssec (getenv "PLTDREASTERSECONDS")])
-                        (string->number ssec)
+     (if ssec
-                        (current-seconds)))))
+         (string->number ssec)
+         (current-seconds)))))
 
 ;; updates the command-line-arguments with only the files
 ;; to open. See also main.rkt.
 (current-command-line-arguments (apply vector files-to-open))
 
-(define (currently-the-weekend?)
+(define (weekend-date? date)
-  (define dow (date-week-day the-date))
+  (define dow (date-week-day date))
   (or (= dow 6) (= dow 0)))
 
-(define (valentines-day?)
+(define (valentines-date? date)
-  (and (= 2 (date-month the-date))
+  (and (= 2 (date-month date))
-       (= 14 (date-day the-date))))
+       (= 14 (date-day date))))
 
-(define (current-icon-state)
+(define (icon-state date)
   (cond
-    [(valentines-day?) 'valentines]
+    [(valentines-date? date) 'valentines]
-    [(currently-the-weekend?) 'weekend]
+    [(weekend-date? date) 'weekend]
     [else 'normal]))
 
 (define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween?)
-  (let* ([month (date-month the-date)]
+  (let* ([month (date-month startup-date)]
-         [day (date-day the-date)]
+         [day (date-day startup-date)]
-         [dow (date-week-day the-date)])
+         [dow (date-week-day startup-date)])
     (values (and (= 3 month) (= 2 day))
             (and (= 3 month) (= 26 day))
             (and (= 6 month) (= 11 day))
@@ -119,7 +120,7 @@
 
 (define the-bitmap-spec
   (cond
-    [(valentines-day?)
+    [(valentines-date? startup-date)
      valentines-days-spec]
     [(or prince-kuhio-day? kamehameha-day?)
      (set-splash-progress-bar?! #f)
@@ -131,7 +132,7 @@
      (collection-file-path "texas-plt-bw.gif" "icons")]
     [halloween?
      (collection-file-path "PLT-pumpkin.png" "icons")]
-    [(currently-the-weekend?)
+    [(weekend-date? startup-date)
      weekend-bitmap-spec]
     [else normal-bitmap-spec]))
 
@@ -139,7 +140,7 @@
 (set-splash-char-observer drracket-splash-char-observer)
 
 (when (eq? (system-type) 'macosx)
-  (define initial-state (current-icon-state))
+  (define initial-state (icon-state startup-date))
   (define weekend-bitmap (if (equal? the-bitmap-spec weekend-bitmap-spec)
                              the-splash-bitmap
                              #f))
@@ -167,7 +168,7 @@
     (λ ()
       (let loop ([last-state initial-state])
         (sleep 10)
-        (define next-state (current-icon-state))
+        (define next-state (icon-state (seconds->date (current-seconds))))
         (unless (equal? last-state next-state)
           (set-icon next-state))
         (loop next-state))))))

collects/drracket/private/get-extend.rkt

@@ -1,7 +1,8 @@
 #lang racket/unit
 
 (require racket/class
-         "drsig.rkt")
+         "drsig.rkt"
+         framework/private/logging-timer)
 
 (import [prefix drracket:unit: drracket:unit^]
         [prefix drracket:frame: drracket:frame^]
@@ -13,7 +14,7 @@
 (export drracket:get/extend^)
 
 (define make-extender
-  (λ (get-base% name)
+  (λ (get-base% name [final-mixin values])
     (let ([extensions (λ (x) x)]
           [built-yet? #f]
           [built #f]
@@ -42,7 +43,7 @@
        (λ ()
          (unless built-yet?
            (set! built-yet? #t)
-           (set! built (extensions (get-base%))))
+           (set! built (final-mixin (extensions (get-base%)))))
          built)))))
 
 (define (get-base-tab%)
@@ -93,4 +94,14 @@
        (drracket:unit:get-definitions-text%)))))))
 
 (define-values (extend-definitions-text get-definitions-text)
-  (make-extender get-base-definitions-text% 'definitions-text%))
+  (make-extender get-base-definitions-text%
+                 'definitions-text%
+                 (let ([add-on-paint-logging
+                        (λ (%)
+                          (class %
+                            (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+                              (log-timeline 
+                               (format "on-paint method of ~a area: ~a" (object-name this) (* (- right left) (- bottom top)))
+                               (super on-paint before? dc left top right bottom dx dy draw-caret)))
+                            (super-new)))])
+                   add-on-paint-logging)))

collects/drracket/private/insert-large-letters.rkt

@@ -7,7 +7,7 @@
 
 
 (define-type-alias Bitmap-Message% (Class () 
-                                          ([parent Any])
+                                          ([parent (Instance Horizontal-Panel%)])
                                           ([set-bm ((Instance Bitmap%) -> Void)])))
 
 
@@ -16,7 +16,7 @@
 
 (provide insert-large-letters)
 
-(: insert-large-letters (String Char (Instance Racket:Text%) Any -> Void))
+(: insert-large-letters (String Char (Instance Text:Basic%) Any -> Void))
 (define (insert-large-letters comment-prefix comment-character edit parent)
   (let ([str (make-large-letters-dialog comment-prefix comment-character #f)])
     (when (and str
@@ -90,7 +90,7 @@
   (: pane2 (Instance Horizontal-Pane%))
   (define pane2 (new horizontal-pane% (parent info-bar)))
                                 
-  (: txt (Instance Racket:Text%))
+  (: txt (Instance Text:Basic%))
   (define txt (new racket:text%))
   (: ec (Instance Editor-Canvas%))
   (define ec (new editor-canvas% [parent dlg] [editor txt]))
@@ -145,7 +145,7 @@
       (format " (~a)" (floor (inexact->exact w))))))
   
 
-(: get-max-line-width ((Instance Racket:Text%) -> Real))
+(: get-max-line-width ((Instance Text:Basic%) -> Real))
 (define (get-max-line-width txt)
   (let loop ([i (+ (send txt last-paragraph) 1)]
              [#{m : Integer} 0])
@@ -156,7 +156,7 @@
                             (send txt paragraph-start-position (- i 1)))))])))
       
 
-(: render-large-letters (String Char (Instance Font%) String (Instance Racket:Text%) -> (Instance Bitmap%)))
+(: render-large-letters (String Char (Instance Font%) String (Instance Text:Basic%) -> (Instance Bitmap%)))
 (define (render-large-letters comment-prefix comment-character the-font str edit)
   (define bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t)))
   (define-values (tw raw-th td ta) (send bdc get-text-extent str the-font))

collects/drracket/private/local-member-names.rkt

@@ -11,11 +11,11 @@
   insert-auto-text)
 
 ;; from module-language-tools.rkt
-(define-local-member-name 
+(define-local-member-name
   when-initialized
-  ;move-to-new-language 
+  ;move-to-new-language
   get-in-module-language?)
-  
+
 ;; for keybindings (otherwise private)
 (define-local-member-name
   jump-to-previous-error-loc
@@ -24,3 +24,8 @@
 ;; defined in module-language.rkt
 (define-local-member-name
   set-lang-wants-big-defs/ints-labels?)
+
+;; used by the test suite to tell when the
+;; online check syntax has finished
+(define-local-member-name
+  get-online-expansion-colors)

collects/drracket/private/main.rkt

@@ -72,6 +72,7 @@
 (preferences:set-default 'drracket:defs/ints-labels #t boolean?)
 
 (drr:set-default 'drracket:language-dialog:hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x)))))
+(preferences:set-default 'drracket:language-dialog:teaching-hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x)))))
 
 (drr:set-default 'drracket:create-executable-gui-type 'stand-alone (λ (x) (memq x '(launcher stand-alone distribution))))
 (drr:set-default 'drracket:create-executable-gui-base 'racket (λ (x) (memq x '(racket gracket))))

collects/drracket/private/module-language-tools.rkt

@@ -8,7 +8,8 @@
          racket/class
          racket/gui/base
          "drsig.rkt"
-         "local-member-names.rkt")
+         "local-member-names.rkt"
+         framework/private/logging-timer)
 
 (define op (current-output-port))
 (define (oprintf . args) (apply fprintf op args))
@@ -136,7 +137,7 @@
                             (<= start hash-lang-last-location))
                     
                     (unless timer
-                      (set! timer (new timer% 
+                      (set! timer (new logging-timer% 
                                        [notify-callback
                                         (λ () 
                                           (when in-module-language?

collects/drracket/private/module-language.rkt

@@ -25,7 +25,9 @@
          "rep.rkt"
          "eval-helpers.rkt"
          "local-member-names.rkt"
-         "rectangle-intersect.rkt")
+         "rectangle-intersect.rkt"
+         
+         framework/private/logging-timer)
 
 (define-runtime-path expanding-place.rkt "expanding-place.rkt")
 
@@ -145,29 +147,31 @@
       
       (inherit get-language-name)
       (define/public (get-users-language-name defs-text)
-        (let* ([defs-port (open-input-text-editor defs-text)]
+        (define defs-port (open-input-text-editor defs-text))
-               [read-successfully?
+        (port-count-lines! defs-port)
-                (with-handlers ((exn:fail? (λ (x) #f)))
+        (define read-successfully?
-                  (read-language defs-port (λ () #f))
+          (with-handlers ((exn:fail? (λ (x) #f)))
-                  #t)])
+            (read-language defs-port (λ () #f))
-          (cond
+            #t))
-            [read-successfully?
+        (cond
-             (let* ([str (send defs-text get-text 0 (file-position defs-port))]
+          [read-successfully?
-                    [pos (regexp-match-positions #rx"#(?:!|lang )" str)])
+           (define-values (_line _col port-pos) (port-next-location defs-port))
-               (cond
+           (define str (send defs-text get-text 0 (- port-pos 1)))
-                 [(not pos)
+           (define pos (regexp-match-positions #rx"#(?:!|lang )" str))
-                  (get-language-name)]
+           (cond
-                 [else
+             [(not pos)
-                  ;; newlines can break things (ie the language text won't 
+              (get-language-name)]
-                  ;; be in the right place in the interactions window, which
+             [else
-                  ;; at least makes the test suites unhappy), so get rid of 
+              ;; newlines can break things (ie the language text won't 
-                  ;; them from the name. Otherwise, if there is some weird formatting,
+              ;; be in the right place in the interactions window, which
-                  ;; so be it.
+              ;; at least makes the test suites unhappy), so get rid of 
-                  (regexp-replace* #rx"[\r\n]+"
+              ;; them from the name. Otherwise, if there is some weird formatting,
-                                   (substring str (cdr (car pos)) (string-length str))
+              ;; so be it.
-                                   " ")]))]
+              (regexp-replace* #rx"[\r\n]+"
-            [else
+                               (substring str (cdr (car pos)) (string-length str))
-             (get-language-name)])))
+                               " ")])]
+          [else
+           (get-language-name)]))
                 
       (define/override (use-namespace-require/copy?) #f)
       
@@ -933,6 +937,7 @@
       ;; colors : (or/c #f (listof string?) 'parens)
       (define colors #f)
       (define tooltip-labels #f)
+      (define/public (get-online-expansion-colors) colors)
       
       (super-new)
       
@@ -1310,11 +1315,12 @@
       (inherit last-position find-first-snip get-top-level-window get-filename
                get-tab get-canvas invalidate-bitmap-cache 
                set-position get-start-position get-end-position
-               highlight-range dc-location-to-editor-location)
+               highlight-range dc-location-to-editor-location
+               begin-edit-sequence end-edit-sequence)
       
       (define compilation-out-of-date? #f)
       
-      (define tmr (new timer% [notify-callback (lambda () (send-off))]))
+      (define tmr (new logging-timer% [notify-callback (lambda () (send-off))]))
       
       (define cb-proc (λ (sym new-val) 
                         (when new-val
@@ -1502,6 +1508,7 @@
         (reset-frame-expand-error #f))
       
       (define/private (show-error-in-margin res)
+        (begin-edit-sequence #f #f)
         (define tlw (send (get-tab) get-frame))
         (send (get-tab) show-bkg-running 'nothing #f)
         (set! error/status-message-str (vector-ref res 1))
@@ -1516,7 +1523,8 @@
         (set-error-ranges-from-online-error-ranges (vector-ref res 2))
         (invalidate-online-error-ranges)
         (set! error/status-message-hidden? #f)
-        (update-frame-expand-error))
+        (update-frame-expand-error)
+        (end-edit-sequence))
       
       (define/private (show-error-as-highlighted-regions res)
         (define tlw (send (get-tab) get-frame))
@@ -1551,6 +1559,7 @@
         (send (send (get-tab) get-ints) set-error-ranges srclocs))
       
       (define/private (clear-old-error)
+        (begin-edit-sequence #f #f)
         (for ([cleanup-thunk (in-list online-highlighted-errors)])
           (cleanup-thunk))
         (for ([an-error-range (in-list online-error-ranges)])
@@ -1558,7 +1567,8 @@
             ((error-range-clear-highlight an-error-range))
             (set-error-range-clear-highlight! an-error-range #f)))
         (invalidate-online-error-ranges)
-        (set-online-error-ranges '()))
+        (set-online-error-ranges '())        
+        (end-edit-sequence))
       
       (define/private (invalidate-online-error-ranges)
         (when (get-admin)
@@ -1781,7 +1791,7 @@
       (define lang-wants-big-defs/ints-labels? #f)
 
       (define recently-typed-timer 
-        (new timer%
+        (new logging-timer%
              [notify-callback
               (λ ()
                 (update-recently-typed #f)
@@ -1809,7 +1819,9 @@
           (update-recently-typed #t)
           (set! fade-amount 0)
           (send recently-typed-timer stop)
-          (send recently-typed-timer start 10000 #t))
+          (when (and lang-wants-big-defs/ints-labels?
+                     (preferences:get 'drracket:defs/ints-labels))
+            (send recently-typed-timer start 10000 #t)))
         (super on-char evt))
       
       (define/private (update-recently-typed nv)
@@ -1824,7 +1836,8 @@
             [else (preferences:get 'drracket:defs/ints-labels)]))
         (unless (equal? new-inside? inside?)
           (set! inside? new-inside?)
-          (invalidate-bitmap-cache 0 0 'display-end 'display-end))
+          (when lang-wants-big-defs/ints-labels?
+            (invalidate-bitmap-cache 0 0 'display-end 'display-end)))
         (cond
           [(and lang-wants-big-defs/ints-labels?
                 (preferences:get 'drracket:defs/ints-labels)

collects/drracket/private/rep.rkt

@@ -434,7 +434,6 @@ TODO
                insert
                insert-before
                insert-between
-               invalidate-bitmap-cache
                is-locked?
                last-position
                line-location
@@ -472,9 +471,9 @@ TODO
       (define/public (get-context) context)
       
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-      ;;;				           ;;;
+      ;;;                                          ;;;
       ;;;            User -> Kernel                ;;;
-      ;;;				           ;;;
+      ;;;                                          ;;;
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
       
       ;; =User= (probably doesn't matter)
@@ -775,8 +774,8 @@ TODO
         (unless inserting-prompt?
           (reset-highlighting))
         (when (and prompt-position 
-		   (ormap (λ (start) (< start prompt-position))
+                   (ormap (λ (start) (< start prompt-position))
-			  starts))
+                          starts))
           (set! prompt-position (get-unread-start-point))
           (reset-regions (append (all-but-last (get-regions))
                                  (list (list prompt-position 'end))))))
@@ -1265,6 +1264,7 @@ TODO
                  
                  (thread
                   (λ ()
+                    (struct gui-event (start? msec name) #:prefab)
                     ;; forward system events the user's logger, and record any
                     ;; events that happen on the user's logger to show in the GUI
                     (let ([sys-evt (make-log-receiver drracket:init:system-logger 'debug)]
@@ -1274,16 +1274,18 @@ TODO
                          (handle-evt
                           sys-evt
                           (λ (logged)
-                            (log-message user-logger 
+                            (unless (gui-event? (vector-ref logged 2))
-                                         (vector-ref logged 0)
+                              (log-message user-logger 
-                                         (vector-ref logged 1)
+                                           (vector-ref logged 0)
-                                         (vector-ref logged 2))
+                                           (vector-ref logged 1)
+                                           (vector-ref logged 2)))
                             (loop)))
                          (handle-evt
                           user-evt
                           (λ (vec)
-                            (parameterize ([current-eventspace drracket:init:system-eventspace])
+                            (unless (gui-event? (vector-ref vec 2))
-                              (queue-callback (λ () (new-log-message vec))))
+                              (parameterize ([current-eventspace drracket:init:system-eventspace])
+                                (queue-callback (λ () (new-log-message vec)))))
                             (loop))))))))
                  
                  (initialize-parameters snip-classes)

collects/drracket/private/syncheck/blueboxes-gui.rkt

@@ -8,7 +8,8 @@
          setup/dirs
          images/icons/misc
          "../rectangle-intersect.rkt"
-         string-constants)
+         string-constants
+         framework/private/logging-timer)
 (provide docs-text-mixin
          docs-editor-canvas-mixin
          syncheck:add-docs-range
@@ -376,7 +377,7 @@
         [else
          (super on-event evt)]))
     
-    (define timer (new timer%
+    (define timer (new logging-timer%
                        [notify-callback
                         (λ () 
                           (set! timer-running? #f)

collects/drracket/private/syncheck/gui.rkt

@@ -48,7 +48,8 @@ If the namespace does not, they are colored the unbound color.
          "traversals.rkt"
          "annotate.rkt"
          "../tooltip.rkt"
-         "blueboxes-gui.rkt")
+         "blueboxes-gui.rkt"
+         framework/private/logging-timer)
 (provide tool@)
 
 (define orig-output-port (current-output-port))
@@ -969,7 +970,7 @@ If the namespace does not, they are colored the unbound color.
             ;; Starts or restarts a one-shot arrow draw timer
             (define/private (start-arrow-draw-timer delay-ms)
               (unless arrow-draw-timer
-                (set! arrow-draw-timer (make-object timer% (λ () (maybe-update-drawn-arrows)))))
+                (set! arrow-draw-timer (make-object logging-timer% (λ () (maybe-update-drawn-arrows)))))
               (send arrow-draw-timer start delay-ms #t))
             
             ;; this will be set to a time in the future if arrows shouldn't be drawn until then
@@ -1581,6 +1582,7 @@ If the namespace does not, they are colored the unbound color.
             (send (send defs-text get-tab) add-bkg-running-color 'syncheck "orchid" cs-syncheck-running)
             (send defs-text syncheck:init-arrows)
             (let loop ([val val]
+                       [start-time (current-inexact-milliseconds)]
                        [i 0])
               (cond
                 [(null? val)
@@ -1588,40 +1590,42 @@ If the namespace does not, they are colored the unbound color.
                  (send defs-text syncheck:update-drawn-arrows)
                  (send (send defs-text get-tab) remove-bkg-running-color 'syncheck)
                  (set-syncheck-running-mode #f)]
-                [(= i 500)
+                [(and (i . > . 0)  ;; check i just in case things are really strange
+                      (20 . <= . (- (current-inexact-milliseconds) start-time)))
                  (queue-callback
                   (λ ()
                     (when (unbox bx)
-                      (loop val 0)))
+                      (log-timeline "continuing replay-compile-comp-trace"
+                                    (loop val (current-inexact-milliseconds) 0))))
                   #f)]
                 [else
                  (process-trace-element defs-text (car val))
-                 (loop (cdr val) (+ i 1))]))))
+                 (loop (cdr val) start-time (+ i 1))]))))
         
         (define/private (process-trace-element defs-text x)
           ;; using 'defs-text' all the time is wrong in the case of embedded editors,
           ;; but they already don't work and we've arranged for them to not appear here ....
           (match x
-            [`(syncheck:add-arrow ,start-text ,start-pos-left ,start-pos-right
+            [`#(syncheck:add-arrow ,start-pos-left ,start-pos-right
-                                  ,end-text ,end-pos-left ,end-pos-right
+                                   ,end-pos-left ,end-pos-right
-                                  ,actual? ,level)
+                                   ,actual? ,level)
              (send defs-text syncheck:add-arrow
                    defs-text start-pos-left start-pos-right
                    defs-text end-pos-left end-pos-right 
                    actual? level)]
-            [`(syncheck:add-tail-arrow ,from-text ,from-pos ,to-text ,to-pos)
+            [`#(syncheck:add-tail-arrow ,from-pos ,to-pos)
              (send defs-text syncheck:add-tail-arrow defs-text from-pos defs-text to-pos)]
-            [`(syncheck:add-mouse-over-status ,text ,pos-left ,pos-right ,str)
+            [`#(syncheck:add-mouse-over-status ,pos-left ,pos-right ,str)
              (send defs-text syncheck:add-mouse-over-status defs-text pos-left pos-right str)]
-            [`(syncheck:add-background-color ,text ,color ,start ,fin)
+            [`#(syncheck:add-background-color ,color ,start ,fin)
              (send defs-text syncheck:add-background-color defs-text color start fin)]
-            [`(syncheck:add-jump-to-definition ,text ,start ,end ,id ,filename)
+            [`#(syncheck:add-jump-to-definition ,start ,end ,id ,filename)
              (send defs-text syncheck:add-jump-to-definition defs-text start end id filename)]
-            [`(syncheck:add-require-open-menu ,text ,start-pos ,end-pos ,file)
+            [`#(syncheck:add-require-open-menu ,start-pos ,end-pos ,file)
              (send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)]
-            [`(syncheck:add-docs-menu ,text ,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag)
+            [`#(syncheck:add-docs-menu,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag)
              (send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path definition-tag tag)]
-            [`(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id)
+            [`#(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id)
              (define other-side-dead? #f)
              (define (name-dup? name) 
                (cond
@@ -1639,7 +1643,7 @@ If the namespace does not, they are colored the unbound color.
                      #f])]))
              (define to-be-renamed/poss/fixed
                (for/list ([lst (in-list to-be-renamed/poss)])
-                 (list defs-text (list-ref lst 1) (list-ref lst 2))))
+                 (list defs-text (list-ref lst 0) (list-ref lst 1))))
              (send defs-text syncheck:add-rename-menu id-as-sym to-be-renamed/poss/fixed 
                    name-dup?)]))
         
@@ -2066,9 +2070,12 @@ If the namespace does not, they are colored the unbound color.
     (drracket:module-language-tools:add-online-expansion-handler
      online-comp.rkt
      'go
-     (λ (defs-text val) (send (send (send defs-text get-canvas) get-top-level-window)
+     (λ (defs-text val) 
-                              replay-compile-comp-trace
+       (log-timeline
-                              defs-text 
+        "replace-compile-comp-trace"
-                              val)))))
+        (send (send (send defs-text get-canvas) get-top-level-window)
+              replay-compile-comp-trace
+              defs-text 
+              val))))))
 
 (define-runtime-path online-comp.rkt "online-comp.rkt")

collects/drracket/private/syncheck/online-comp.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/class
          racket/place
+         (for-syntax racket/base)
          "../../private/eval-helpers.rkt"
          "traversals.rkt"
          "local-member-names.rkt"
@@ -34,26 +35,35 @@
     (define/override (syncheck:find-source-object stx)
       (and (equal? src (syntax-source stx))
            src))
-    (define-syntax-rule
+    
-      (log name)
+    ;; send over the non _ variables in the message to the main drracket place
-      (define/override (name . args)
+    (define-syntax (log stx)
-        (set! trace (cons (cons 'name args) trace))))
+      (syntax-case stx ()
+        [(_ name args ...)
+         (with-syntax ([(wanted-args ...)
+                        (filter (λ (x) (not (regexp-match #rx"^_" (symbol->string (syntax-e x)))))
+                                (syntax->list #'(args ...)))])
+           #'(define/override (name args ...)
+               (add-to-trace (vector 'name wanted-args ...))))]))
 
-    ; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up
+    (log syncheck:add-arrow
-    (log syncheck:add-mouse-over-status)
+         _start-text start-pos-left start-pos-right
-    (log syncheck:add-arrow)
+         _end-text end-pos-left end-pos-right
-    (log syncheck:add-tail-arrow)
+         actual? level)
-    (log syncheck:add-background-color)
+    (log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos)
-    (log syncheck:add-require-open-menu)
+    (log syncheck:add-mouse-over-status _text pos-left pos-right str)
-    (log syncheck:add-docs-menu)
+    (log syncheck:add-background-color _text color start fin)
-    (log syncheck:add-jump-to-definition)
+    (log syncheck:add-jump-to-definition _text start end id filename)
+    (log syncheck:add-require-open-menu _text start-pos end-pos file)
+    (log syncheck:add-docs-menu _text start-pos end-pos key the-label path definition-tag tag)
     (define/override (syncheck:add-rename-menu id-as-sym to-be-renamed/poss dup-name?)
       (define id (hash-count table))
       (hash-set! table id dup-name?)
-      (set! trace (cons (list 'syncheck:add-rename-menu id-as-sym to-be-renamed/poss remote id)
+      (add-to-trace (vector 'syncheck:add-rename-menu id-as-sym (map cdr to-be-renamed/poss) remote id)))
-                        trace)))
     
     (define/public (get-trace) (reverse trace))
+    (define/private (add-to-trace thing) 
+      (set! trace (cons thing trace)))
     (super-new)))
 
 (define (go expanded path the-source orig-cust)

collects/drracket/private/syncheck/traversals.rkt

@@ -1134,10 +1134,22 @@
                                   (for/or ([(level id-set) (in-hash phase-to-map)])
                                     (get-ids id-set new-id))))))))
                       #t))
-               (send defs-text syncheck:add-rename-menu
+               (define max-to-send-at-once 30)
-                     id-as-sym
+               (let loop ([loc-lst loc-lst]
-                     loc-lst
+                          [len (length loc-lst)])
-                     name-dup?)))))))
+                 (cond
+                   [(<= len max-to-send-at-once)
+                    (send defs-text syncheck:add-rename-menu
+                          id-as-sym
+                          loc-lst
+                          name-dup?)]
+                   [else
+                    (send defs-text syncheck:add-rename-menu
+                          id-as-sym
+                          (take loc-lst max-to-send-at-once)
+                          name-dup?)
+                    (loop (drop loc-lst max-to-send-at-once)
+                          (- len max-to-send-at-once))]))))))))
     
     ;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original])
     ;; removes duplicates, based on the source locations of the identifiers

collects/drracket/private/text.rkt

@@ -17,17 +17,17 @@
       (define/public (is-printing-on?) printing?)
       (define/public (printing-on) (set! printing? #t))
       (define/public (printing-off) (set! printing? #f))
-      ;      (rename [super-on-paint on-paint])
+      ; (rename [super-on-paint on-paint])
-      ;      (inherit get-filename)
+      ; (inherit get-filename)
-      ;      (override
+      ; (override
-      ;	[on-paint
+      ;  [on-paint
-      ;	 (λ (before? dc left top right bottom dx dy draw-caret)
+      ;   (λ (before? dc left top right bottom dx dy draw-caret)
-      ;	   (super-on-paint before? dc left top right bottom dx dy draw-caret)
+      ;     (super-on-paint before? dc left top right bottom dx dy draw-caret)
-      ;	   (let ([str (string-append
+      ;     (let ([str (string-append
-      ;			(mzlib:date:date->string (seconds->date (current-seconds)))
+      ;                  (mzlib:date:date->string (seconds->date (current-seconds)))
-      ;			" "
+      ;                  " "
-      ;			(if (string? (get-filename))
+      ;                  (if (string? (get-filename))
-      ;			    (get-filename)
+      ;                      (get-filename)
-      ;			    "Untitled"))])
+      ;                      "Untitled"))])
-      ;	      (send dc draw-text str dx dy)))])
+      ;        (send dc draw-text str dx dy)))])
       (super-new)))

collects/drracket/private/unit.rkt

@@ -44,7 +44,8 @@ module browser threading seems wrong.
          
          mzlib/date
          
-         framework/private/aspell)
+         framework/private/aspell
+         framework/private/logging-timer)
 
 (provide unit@)
 
@@ -4544,7 +4545,7 @@ module browser threading seems wrong.
       (define num-running-frames (vector-length running-frames))
       (define is-running? #f)
       (define frame 0)
-      (define timer (make-object timer% (λ () (refresh) (yield)) #f))
+      (define timer (make-object logging-timer% (λ () (refresh) (yield)) #f))
       
       (define/public (set-running r?)
         (cond [r?    (unless is-running? (set! frame 4))

collects/dynext/link-unit.rkt

@@ -195,7 +195,7 @@
 	(make-parameter
 	 (case (system-type)
 	   [(unix macosx) 
-	    (case (string->symbol (path->string (system-library-subpath #f)))	    
+	    (case (string->symbol (path->string (system-library-subpath #f)))
 	      [(i386-cygwin) win-gcc-link-output-strings]
 	      [else (lambda (s) (list "-o" (path-string->string s)))])]
 	   [(windows) (cond
@@ -239,7 +239,7 @@
 			  (list (wrap-xxxxxxx dllfile (wrap-3m "libracket~a~~a.dll"))
 				(wrap-xxxxxxx dllfile (drop-3m "libmzgc~a.dll"))))
 		      (list
-		       (mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.exp")))		       
+		       (mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.exp")))
 		       (mzdyn-maybe (filethunk (wrap-3m 
 						;; mzdyn.o is for Unix build, mzdynw.o for Windows
 						(format "mzdyn~a~~a.o"

collects/eopl/eopl.rkt

@@ -1,10 +1,12 @@
-#lang racket
+#lang racket/base
 
 (require "datatype.rkt"
          "private/sllgen.rkt"
+         racket/promise
          mzlib/trace
          mzlib/pretty)
-(require (for-syntax "private/slldef.rkt"))
+(require (for-syntax racket/base
+                     "private/slldef.rkt"))
 
 (provide define-datatype
          cases)

collects/ffi/unsafe.rkt

@@ -1702,6 +1702,7 @@
                                        (cweh
                                         (lambda (exn)
                                           (log-message logger
+                                                       'error
                                                        (if (exn? exn)
                                                            (exn-message exn)
                                                            (format "~s" exn))

collects/ffi/unsafe/atomic.rkt

@@ -112,7 +112,7 @@
           break-paramz
           (lambda ()
             (dynamic-wind
-                (lambda ()		
+                (lambda ()
                   (set! monitor-owner #f)
                   (set! extra-atomic-depth 0)
                   (end-breakable-atomic)

collects/ffi/unsafe/com.rkt

@@ -1,12 +1,12 @@
 #lang racket/base
 (require ffi/unsafe
          ffi/unsafe/alloc
-	 ffi/winapi
+         ffi/winapi
          ffi/unsafe/atomic
          ffi/unsafe/custodian
          racket/date
          racket/runtime-path
-	 racket/list
+         racket/list
          (for-syntax racket/base)
          "private/win32.rkt")
 
@@ -126,15 +126,15 @@
 
 (define (_system-string/utf-16 mode)
   (make-ctype _pointer
-	      (lambda (s)
+              (lambda (s)
-		(and s                     
+                (and s
                      (let ([c (string->pointer s)])
                        (register-cleanup! (lambda () (SysFreeString c)))
                        c)))
-	      (lambda (p)
+              (lambda (p)
-		(begin0
+                (begin0
-		 (cast p _pointer _string/utf-16)
+                 (cast p _pointer _string/utf-16)
-		 (when (memq 'out mode) (SysFreeString p))))))
+                 (when (memq 'out mode) (SysFreeString p))))))
 
 (define current-cleanup (make-parameter #f))
 (define current-commit (make-parameter #f))
@@ -464,8 +464,8 @@
 
 (define-com-interface (_IClassFactory _IUnknown)
   ([CreateInstance/factory (_hmfun _IUnknown-pointer/null _REFIID
-				   (p : (_ptr o _ISink-pointer/null))
+                                   (p : (_ptr o _ISink-pointer/null))
-				   -> CreateInstance p)]
+                                   -> CreateInstance p)]
    [LockServer _fpointer]))
 
 
@@ -595,17 +595,17 @@
                            (bitwise-ior CLSCTX_LOCAL_SERVER CLSCTX_INPROC_SERVER)
                            IID_IUnknown)]
         [else
-	 (define cleanup (box null))
+         (define cleanup (box null))
          (define csi (parameterize ([current-cleanup cleanup])
-		       (make-COSERVERINFO 0 machine #f 0)))
+                       (make-COSERVERINFO 0 machine #f 0)))
          (define mqi (make-MULTI_QI IID_IUnknown #f 0))
          (define unknown
-	   (dynamic-wind
+           (dynamic-wind
-	    void
+            void
-	    (lambda ()
+            (lambda ()
-	      (CoCreateInstanceEx clsid #f CLSCTX_REMOTE_SERVER (and machine csi) 1 mqi))
+              (CoCreateInstanceEx clsid #f CLSCTX_REMOTE_SERVER (and machine csi) 1 mqi))
-	    (lambda ()
+            (lambda ()
-	      (for ([proc (in-list (unbox cleanup))]) (proc)))))
+              (for ([proc (in-list (unbox cleanup))]) (proc)))))
          (unless (and (zero? (MULTI_QI-hr mqi))
                       unknown)
            (error who "unable to obtain IUnknown interface for remote server"))
@@ -643,7 +643,7 @@
      (let ([mref (com-impl-mref impl)])
        (when mref
          (set-com-impl-mref! impl #f)
-	 (unregister-custodian-shutdown impl mref)))
+         (unregister-custodian-shutdown impl mref)))
      (release-type-types (com-impl-type-info impl))
      (define (bye! sel st!)
        (when (sel impl)
@@ -669,7 +669,7 @@
       (when (zero? (type-ref-count type))
         (when (positive? (hash-count (type-types type)))
           (for ([td (in-hash-values (type-types type))])
-  	    (release-type-desc td))
+            (release-type-desc td))
           (set-type-types! type (make-hash)))
         (hash-remove! types type-info)))))
 
@@ -736,23 +736,23 @@
         dispatch)))
 
 (struct type (type-info [types #:mutable]
-			scheme-types
+                        scheme-types
-			[ref-count #:mutable]))
+                        [ref-count #:mutable]))
 (define types (make-weak-hash))
 
 (define (intern-type-info type-info)
   ;; called in atomic mode
   (let ([ti-e (hash-ref types type-info #f)])
     (if ti-e
-	(let* ([t (ephemeron-value ti-e)]
+        (let* ([t (ephemeron-value ti-e)]
-	       [ti (type-type-info t)])
+               [ti (type-type-info t)])
-	  (set-type-ref-count! t (add1 (type-ref-count t)))
+          (set-type-ref-count! t (add1 (type-ref-count t)))
-	  (Release type-info)
+          (Release type-info)
-	  (AddRef ti)
+          (AddRef ti)
-	  t)
+          t)
-	(let ([t (type type-info (make-hash) (make-hash) 1)])
+        (let ([t (type type-info (make-hash) (make-hash) 1)])
-	  (hash-set! types type-info (make-ephemeron type-info t))
+          (hash-set! types type-info (make-ephemeron type-info t))
-	  t))))
+          t))))
 
 (define (type-info-type type-info)
   (ephemeron-value (hash-ref types type-info)))
@@ -766,18 +766,18 @@
                 (error "COM object does not expose type information")
                 #f)
             (let ([type-info (GetTypeInfo
-			      dispatch
+                              dispatch
-			      0
+                              0
-			      LOCALE_SYSTEM_DEFAULT)])
+                              LOCALE_SYSTEM_DEFAULT)])
-	      (unless type-info
+              (unless type-info
-		(error "Error getting COM type information"))
+                (error "Error getting COM type information"))
-	      (let* ([type (intern-type-info type-info)]
+              (let* ([type (intern-type-info type-info)]
-		     [type-info (type-type-info type)]
+                     [type-info (type-type-info type)]
-		     [impl (com-object-impl obj)])
+                     [impl (com-object-impl obj)])
-		(set-com-impl-type-info! impl type-info)
+                (set-com-impl-type-info! impl type-info)
-		(set-com-impl-types! impl (type-types type))
+                (set-com-impl-types! impl (type-types type))
-		(set-com-impl-scheme-types! impl (type-scheme-types type))
+                (set-com-impl-scheme-types! impl (type-scheme-types type))
-		type-info))))))
+                type-info))))))
 
 (define (com-object-type obj)
   (check-com-obj 'com-object-type obj)
@@ -1003,7 +1003,7 @@
               var-desc]
              [else
               (ReleaseVarDesc type-info var-desc)
-	      #f])))
+              #f])))
      ;; search in inherited interfaces
      (for/or ([i (in-range (TYPEATTR-cImplTypes type-attr))])
        (define ref-type (GetRefTypeOfImplType type-info i))
@@ -1084,20 +1084,20 @@
                (event-type-info-from-com-object obj)]
               [else
                (type-info-from-com-object obj exn?)])])
-	(and type-info
+        (and type-info
              (let ([mx-type-desc (type-desc-from-type-info name inv-kind type-info)])
                (when mx-type-desc
                  (hash-set! (com-object-types obj) (cons name inv-kind) mx-type-desc))
                mx-type-desc)))))
 
 (define (get-var-type-from-elem-desc elem-desc
-				     #:keep-safe-array? [keep-safe-array? #f])
+                                     #:keep-safe-array? [keep-safe-array? #f])
   ;; hack: allow elem-desc as a TYPEDESC
   (define param-desc (and (ELEMDESC? elem-desc)
-			  (union-ref (ELEMDESC-u elem-desc) 1)))
+                          (union-ref (ELEMDESC-u elem-desc) 1)))
   (define flags (if param-desc
-		    (PARAMDESC-wParamFlags param-desc)
+                    (PARAMDESC-wParamFlags param-desc)
-		    0))
+                    0))
   (define (fixup-vt vt)
     (cond
      [(= vt (bitwise-ior VT_USERDEFINED VT_BYREF))
@@ -1105,12 +1105,12 @@
      [(= vt VT_USERDEFINED)
       VT_INT]
      [(and (= vt VT_SAFEARRAY)
-	   (not keep-safe-array?))
+           (not keep-safe-array?))
       (bitwise-ior VT_ARRAY VT_VARIANT)]
      [else vt]))
   (define type-desc (if (ELEMDESC? elem-desc)
-			(ELEMDESC-tdesc elem-desc)
+                        (ELEMDESC-tdesc elem-desc)
-			elem-desc))
+                        elem-desc))
   (cond
    [(and (bit-and? flags PARAMFLAG_FOPT)
          (bit-and? flags PARAMFLAG_FHASDEFAULT))
@@ -1119,9 +1119,9 @@
    [(= (TYPEDESC-vt type-desc) VT_PTR)
     (fixup-vt
      (bitwise-ior VT_BYREF
-		  (TYPEDESC-vt (cast (union-ref (TYPEDESC-u type-desc) 0) 
+                  (TYPEDESC-vt (cast (union-ref (TYPEDESC-u type-desc) 0) 
-				     _pointer 
+                                     _pointer 
-				     _TYPEDESC-pointer))))]
+                                     _TYPEDESC-pointer))))]
    [else
     (fixup-vt (TYPEDESC-vt type-desc))]))
 
@@ -1145,7 +1145,7 @@
 (define (elem-desc-to-scheme-type elem-desc ignore-by-ref? is-opt? internal?)
   (define vt (let ([vt (get-var-type-from-elem-desc elem-desc #:keep-safe-array? #t)])
                (if (and ignore-by-ref?
-			(not (= vt (bitwise-ior VT_USERDEFINED VT_BYREF))))
+                        (not (= vt (bitwise-ior VT_USERDEFINED VT_BYREF))))
                    (- vt (bitwise-and vt VT_BYREF))
                    vt)))
   (cond
@@ -1171,12 +1171,12 @@
    [else
     (define as-iunk? (= vt (bitwise-ior VT_USERDEFINED VT_BYREF)))
     (define base (vt-to-scheme-type (if as-iunk?
-					vt
+                                        vt
-					(- vt (bitwise-and vt VT_BYREF)))))
+                                        (- vt (bitwise-and vt VT_BYREF)))))
     (define new-base
       (if (and (not as-iunk?)
-	       (bit-and? vt VT_BYREF))
+               (bit-and? vt VT_BYREF))
-	  `(box ,base)
+          `(box ,base)
           base))
     (if is-opt?
         `(opt ,new-base)
@@ -1232,12 +1232,12 @@
    [(type-described? arg)
     (type-described-description arg)]
    [(vector? arg) `(array ,(vector-length arg)
-			  ,(if (zero? (vector-length arg))
+                          ,(if (zero? (vector-length arg))
-			       'int
+                               'int
-			       (for/fold ([t (arg-to-type (vector-ref arg 0))]) ([v (in-vector arg)])
+                               (for/fold ([t (arg-to-type (vector-ref arg 0))]) ([v (in-vector arg)])
-				 (if (equal? t (arg-to-type v))
+                                 (if (equal? t (arg-to-type v))
-				     t
+                                     t
-				     'any))))]
+                                     'any))))]
    [(in-array . > . 1) 'any]
    [(boolean? arg) 'boolean]
    [(signed-int? arg 32) 'int]
@@ -1282,25 +1282,25 @@
   (call-as-atomic
    (lambda ()
      (or (and (com-object? obj)
-	      (hash-ref (com-object-scheme-types obj) (cons name inv-kind) #f))
+              (hash-ref (com-object-scheme-types obj) (cons name inv-kind) #f))
-	 (let ([t (get-uncached-method-type who obj name inv-kind internal?)])
+         (let ([t (get-uncached-method-type who obj name inv-kind internal?)])
-	   (when (com-object? obj)
+           (when (com-object? obj)
-	     (hash-set! (com-object-scheme-types obj) (cons name inv-kind) t))
+             (hash-set! (com-object-scheme-types obj) (cons name inv-kind) t))
-	   t)))))
+           t)))))
 
 (define (get-uncached-method-type who obj name inv-kind internal?)
   (define type-info (extract-type-info who obj (not internal?)))
   (when (and (= inv-kind INVOKE_FUNC)
-	     (is-dispatch-name? name))
+             (is-dispatch-name? name))
-	(error who "IDispatch methods not available"))
+    (error who "IDispatch methods not available"))
   (define mx-type-desc
     (cond
      [(com-object? obj) (get-method-type obj name inv-kind (not internal?))]
      [else (define x-type-info
-	     (if (= inv-kind INVOKE_EVENT)
+             (if (= inv-kind INVOKE_EVENT)
-		 (event-type-info-from-com-type obj)
+                 (event-type-info-from-com-type obj)
-		 type-info))
+                 type-info))
-	   (type-desc-from-type-info name inv-kind x-type-info)]))
+           (type-desc-from-type-info name inv-kind x-type-info)]))
   (cond
    [(not mx-type-desc)
     ;; there is no type info
@@ -1309,60 +1309,60 @@
     (define-values (args ret)
       (cond
        [(function-type-desc? mx-type-desc)
-	(define func-desc (car (mx-com-type-desc-desc mx-type-desc)))
+        (define func-desc (car (mx-com-type-desc-desc mx-type-desc)))
-	(define num-actual-params (FUNCDESC-cParams func-desc))
+        (define num-actual-params (FUNCDESC-cParams func-desc))
-	(cond
+        (cond
-	 [(= -1 (FUNCDESC-cParamsOpt func-desc))
+         [(= -1 (FUNCDESC-cParamsOpt func-desc))
-	  ;; all args > pFuncDesc->cParams - 1 get packaged into SAFEARRAY,
+          ;; all args > pFuncDesc->cParams - 1 get packaged into SAFEARRAY,
-	  ;; but that is handled by COM automation; we just pass "any"s
+          ;; but that is handled by COM automation; we just pass "any"s
-	  (values
+          (values
-	   (append
+           (append
-	    (for/list ([i (in-range (sub1 num-actual-params))])
+            (for/list ([i (in-range (sub1 num-actual-params))])
-		      (elem-desc-to-scheme-type (elem-desc-ref func-desc i)
+                      (elem-desc-to-scheme-type (elem-desc-ref func-desc i)
-						#f
+                                                #f
-						#f
+                                                #f
-						internal?))
+                                                internal?))
-	    '(any ...))
+            '(any ...))
-	   (elem-desc-to-scheme-type (FUNCDESC-elemdescFunc func-desc)
+           (elem-desc-to-scheme-type (FUNCDESC-elemdescFunc func-desc)
-				     #f
+                                     #f
-				     #f
+                                     #f
-				     internal?))]
+                                     internal?))]
-	 [else
+         [else
-	  (define last-is-retval?
+          (define last-is-retval?
-	    (is-last-param-retval? inv-kind func-desc))
+            (is-last-param-retval? inv-kind func-desc))
-	  (define num-params (- num-actual-params (if last-is-retval? 1 0)))
+          (define num-params (- num-actual-params (if last-is-retval? 1 0)))
-	  ;; parameters that are optional with a default value in IDL are not
+          ;; parameters that are optional with a default value in IDL are not
-	  ;; counted in pFuncDesc->cParamsOpt, so look for default bit flag
+          ;; counted in pFuncDesc->cParamsOpt, so look for default bit flag
-	  (define num-opt-params (get-opt-param-count func-desc num-params))
+          (define num-opt-params (get-opt-param-count func-desc num-params))
-	  (define first-opt-arg (- num-params num-opt-params))
+          (define first-opt-arg (- num-params num-opt-params))
-	  (values
+          (values
-	   (for/list ([i (in-range num-params)])
+           (for/list ([i (in-range num-params)])
-		     (elem-desc-to-scheme-type (elem-desc-ref func-desc i)
+                     (elem-desc-to-scheme-type (elem-desc-ref func-desc i)
-					       #f
+                                               #f
-					       (i . >= . first-opt-arg)
+                                               (i . >= . first-opt-arg)
-					       internal?))
+                                               internal?))
-	   (elem-desc-to-scheme-type (if last-is-retval?
+           (elem-desc-to-scheme-type (if last-is-retval?
-					 (elem-desc-ref func-desc num-params)
+                                         (elem-desc-ref func-desc num-params)
-					 (FUNCDESC-elemdescFunc func-desc))
+                                         (FUNCDESC-elemdescFunc func-desc))
-				     #t
+                                     #t
-				     #f
+                                     #f
-				     internal?))])]
+                                     internal?))])]
        [(= inv-kind INVOKE_PROPERTYGET)
-	(define var-desc (mx-com-type-desc-desc mx-type-desc))
+        (define var-desc (mx-com-type-desc-desc mx-type-desc))
-	(values null
+        (values null
-		(elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc)
+                (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc)
-					  #f
+                                          #f
-					  #f
+                                          #f
-					  internal?))]
+                                          internal?))]
        [(= inv-kind INVOKE_PROPERTYPUT)
-	(define var-desc (mx-com-type-desc-desc mx-type-desc))
+        (define var-desc (mx-com-type-desc-desc mx-type-desc))
-	(values (list (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc)
+        (values (list (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc)
-						#f
+                                                #f
-						#f
+                                                #f
-						internal?))
+                                                internal?))
-		'void)]
+                'void)]
        [(= inv-kind INVOKE_EVENT)
-	(values null 'void)]))
+        (values null 'void)]))
     `(-> ,args ,ret)]))
 
 (define (com-method-type obj name)
@@ -1506,8 +1506,8 @@
          (ok-argument? (unbox arg) (cadr type)))]
    [(eq? 'array (car type))
     (and (vector? arg)
-	 (or (eq? (cadr type) '?)
+         (or (eq? (cadr type) '?)
-	     (= (vector-length arg) (cadr type)))
+             (= (vector-length arg) (cadr type)))
          (for/and ([v (in-vector arg)])
            (ok-argument? v (caddr type))))]
    [(eq? 'variant (car type))
@@ -1609,8 +1609,8 @@
     (variant-set! var (to-ctype scheme-type #:mode mode) a)]
    [else
     (define use-scheme-type (if (any-type? scheme-type)
-				(arg-to-type a)
+                                (arg-to-type a)
-				scheme-type))
+                                scheme-type))
     (set-VARIANT-vt! var (to-vt use-scheme-type))
     (variant-set! var (to-ctype use-scheme-type #:mode mode) a)]))
 
@@ -1628,33 +1628,33 @@
 (define (_box/permanent _t)
   (define (extract p)
     (if (eq? _t _VARIANT)
-	(variant-to-scheme (cast p _pointer _VARIANT-pointer) #:mode '(in out))
+        (variant-to-scheme (cast p _pointer _VARIANT-pointer) #:mode '(in out))
-	(ptr-ref p _t)))
+        (ptr-ref p _t)))
   (make-ctype _pointer
               (lambda (v)
                 (define p (malloc 'raw 1 _t))
                 (if (eq? _t _VARIANT)
-		    (let ([p (cast p _pointer _VARIANT-pointer)]
+                    (let ([p (cast p _pointer _VARIANT-pointer)]
-			  [v (unbox v)])
+                          [v (unbox v)])
-		      (VariantInit p)
+                      (VariantInit p)
-		      (scheme-to-variant! p v #f (arg-to-type v) #:mode '(in out)))
+                      (scheme-to-variant! p v #f (arg-to-type v) #:mode '(in out)))
-		    (ptr-set! p _t (unbox v)))
+                    (ptr-set! p _t (unbox v)))
-		(register-cleanup! 
+                (register-cleanup! 
                  (lambda ()
                    (set-box! v (extract p))
                    (free p)))
                 p)
               (lambda (p)
-		;; We box the value, but we don't support reflecting box
+                ;; We box the value, but we don't support reflecting box
-		;; changes back to changes of the original reference:
+                ;; changes back to changes of the original reference:
                 (box (extract p)))))
 
 (define (make-a-VARIANT [mode 'atomic-interior])
   (define var (cast (malloc _VARIANT mode)
-		    _pointer 
+                    _pointer 
-		    (if (eq? mode 'raw)
+                    (if (eq? mode 'raw)
-		    	_VARIANT-pointer
+                        _VARIANT-pointer
-			(_gcable _VARIANT-pointer))))
+                        (_gcable _VARIANT-pointer))))
   (VariantInit var)
   var)
 
@@ -1670,44 +1670,44 @@
 
 (define (_safe-array/vectors given-dims base mode)
   (make-ctype _pointer
-	      (lambda (v)
+              (lambda (v)
-	        (define base-vt (to-vt base))
+                (define base-vt (to-vt base))
-		(define dims (if (equal? given-dims '(?))
+                (define dims (if (equal? given-dims '(?))
-				 (list (vector-length v))
+                                 (list (vector-length v))
-				 given-dims))
+                                 given-dims))
-		(define sa (SafeArrayCreate base-vt
+                (define sa (SafeArrayCreate base-vt
-					    (length dims)
+                                            (length dims)
-					    (for/list ([d (in-list dims)])
+                                            (for/list ([d (in-list dims)])
-					      (make-SAFEARRAYBOUND d 0))))
+                                              (make-SAFEARRAYBOUND d 0))))
-		(register-cleanup!
+                (register-cleanup!
-		 (lambda () (SafeArrayDestroy sa)))
+                 (lambda () (SafeArrayDestroy sa)))
-		(let loop ([v v] [index null] [dims dims])
+                (let loop ([v v] [index null] [dims dims])
-		  (for ([v (in-vector v)]
+                  (for ([v (in-vector v)]
-			[i (in-naturals)])
+                        [i (in-naturals)])
-		    (define idx (cons i index))
+                    (define idx (cons i index))
-		    (if (null? (cdr dims))
+                    (if (null? (cdr dims))
-			(let ([var (make-a-VARIANT)])
+                        (let ([var (make-a-VARIANT)])
-			  (scheme-to-variant! var v #f base #:mode mode)
+                          (scheme-to-variant! var v #f base #:mode mode)
-			  (SafeArrayPutElement sa (reverse idx) 
+                          (SafeArrayPutElement sa (reverse idx) 
-					       (extract-variant-pointer var #f base-vt)))
+                                               (extract-variant-pointer var #f base-vt)))
-			(loop v idx (cdr dims)))))
+                        (loop v idx (cdr dims)))))
-		sa)	      
+                sa)
-	      (lambda (_sa)
+              (lambda (_sa)
-		(define sa (cast _sa _pointer _SAFEARRAY-pointer))
+                (define sa (cast _sa _pointer _SAFEARRAY-pointer))
-		(define dims (for/list ([i (in-range (SafeArrayGetDim sa))])
+                (define dims (for/list ([i (in-range (SafeArrayGetDim sa))])
-			       (- (add1 (SafeArrayGetUBound sa (add1 i)))
+                               (- (add1 (SafeArrayGetUBound sa (add1 i)))
-				  (SafeArrayGetLBound sa (add1 i)))))
+                                  (SafeArrayGetLBound sa (add1 i)))))
-		(define vt (SafeArrayGetVartype sa))
+                (define vt (SafeArrayGetVartype sa))
-		(let loop ([dims dims] [level 1] [index null])
+                (let loop ([dims dims] [level 1] [index null])
-		  (define lb (SafeArrayGetLBound sa level))
+                  (define lb (SafeArrayGetLBound sa level))
-		  (for/vector ([i (in-range (car dims))])
+                  (for/vector ([i (in-range (car dims))])
-		    (if (null? (cdr dims))
+                    (if (null? (cdr dims))
-			(let ([var (make-a-VARIANT)])
+                        (let ([var (make-a-VARIANT)])
-			  (set-VARIANT-vt! var vt)
+                          (set-VARIANT-vt! var vt)
-			  (SafeArrayGetElement sa (reverse (cons i index)) 
+                          (SafeArrayGetElement sa (reverse (cons i index)) 
-					       (extract-variant-pointer var #t))
+                                               (extract-variant-pointer var #t))
-			  (variant-to-scheme var #:mode mode))
+                          (variant-to-scheme var #:mode mode))
-			(loop (cdr dims) (add1 level) (cons i index))))))))
+                        (loop (cdr dims) (add1 level) (cons i index))))))))
 
 (define (_IUnknown-pointer-or-com-object mode)
   (make-ctype 
@@ -1722,12 +1722,12 @@
      p)
    (lambda (p) 
      (if p
-	 (begin
+         (begin
-	   (if (memq 'out mode)
+           (if (memq 'out mode)
-	       (((allocator Release) (lambda () p)))
+               (((allocator Release) (lambda () p)))
-	       (AddRef p))
+               (AddRef p))
-	   (make-com-object p #f))
+           (make-com-object p #f))
-	 p))))
+         p))))
 
 (define (_com-object mode)
   (_IUnknown-pointer-or-com-object mode))
@@ -1766,14 +1766,14 @@
    [(eq? 'array (car type))
     (define-values (dims base)
       (let loop ([t type] [?-ok? #t])
-	(cond
+        (cond
-	 [(and (pair? t) (eq? 'array (car t)) (or ?-ok? (number? (cadr t))))
+         [(and (pair? t) (eq? 'array (car t)) (or ?-ok? (number? (cadr t))))
-	  (define-values (d b) (if (number? (cadr t))
+          (define-values (d b) (if (number? (cadr t))
                                    (loop (caddr t) #f)
                                    (values null (cadr t))))
-	  (values (cons (cadr t) d) b)]
+          (values (cons (cadr t) d) b)]
-	 [else
+         [else
-	  (values null t)])))
+          (values null t)])))
     (_safe-array/vectors dims base mode)]
    [(eq? 'variant (car type))
     (to-ctype (cadr type) #:mode mode)]
@@ -1803,38 +1803,38 @@
     [(com-enumeration) VT_INT]
     [else 
      (case (and (pair? type)
-		(car type))
+                (car type))
        [(array) (bitwise-ior VT_ARRAY (to-vt (caddr type)))]
        [(opt) (to-vt (cadr type))]
        [(variant) VT_VARIANT]
        [(box) (bitwise-ior VT_BYREF (to-vt (cadr type)))]
        [else
-	(error 'to-vt "internal error: unsupported type ~s" type)])]))
+        (error 'to-vt "internal error: unsupported type ~s" type)])]))
 
 (define (build-method-arguments-using-function-desc func-desc scheme-types inv-kind args)
   (define lcid-index (and func-desc (get-lcid-param-index func-desc)))
   (define last-is-retval? (and func-desc (is-last-param-retval? inv-kind func-desc)))
   (define last-is-repeat-any? (and func-desc (= -1 (FUNCDESC-cParamsOpt func-desc))))
   (define base-count (if func-desc
-			 (- (FUNCDESC-cParams func-desc)
+                         (- (FUNCDESC-cParams func-desc)
-			    (if lcid-index 1 0)
+                            (if lcid-index 1 0)
-			    (if last-is-retval? 1 0))
+                            (if last-is-retval? 1 0))
-			 (length scheme-types)))
+                         (length scheme-types)))
   (define count (if last-is-repeat-any?
-		    (if (or lcid-index
+                    (if (or lcid-index
-			    last-is-retval?)
+                            last-is-retval?)
-			(error "cannot handle combination of `any ...' and lcid/retval")
+                        (error "cannot handle combination of `any ...' and lcid/retval")
-			(length scheme-types))
+                        (length scheme-types))
-		    base-count))
+                    base-count))
   (build-method-arguments-from-desc count
-				    (lambda (i)
+                                    (lambda (i)
-				      (and func-desc 
+                                      (and func-desc 
-					   (or (not last-is-repeat-any?)
+                                           (or (not last-is-repeat-any?)
-					       (i . < . (sub1 base-count)))
+                                               (i . < . (sub1 base-count)))
-					   (elem-desc-ref func-desc i)))
+                                           (elem-desc-ref func-desc i)))
-				    scheme-types
+                                    scheme-types
-				    inv-kind
+                                    inv-kind
-				    args))
+                                    args))
 
 (define (build-method-arguments-from-desc count get-elem-desc scheme-types inv-kind args)
   (define vars (if (zero? count)
@@ -1853,12 +1853,12 @@
       (define var (ptr-ref vars _VARIANT (- count i 1))) ; reverse order
       (VariantInit var)
       (scheme-to-variant! var 
-			  a 
+                          a 
-			  (get-elem-desc i)
+                          (get-elem-desc i)
-			  scheme-type)))
+                          scheme-type)))
   (define disp-params (cast (malloc _DISPPARAMS 'raw)
-			    _pointer
+                            _pointer
-			    _DISPPARAMS-pointer))
+                            _DISPPARAMS-pointer))
   (memcpy disp-params
           (make-DISPPARAMS vars 
                            (if (= inv-kind INVOKE_PROPERTYPUT)
@@ -1868,21 +1868,21 @@
                            (if (= inv-kind INVOKE_PROPERTYPUT)
                                count
                                0))
-	  (ctype-sizeof _DISPPARAMS))
+          (ctype-sizeof _DISPPARAMS))
   (values count
-	  disp-params
+          disp-params
           (cons (lambda () (free disp-params)) (unbox cleanup))
           (unbox commit)))
 
 (define (build-method-arguments-using-var-desc var-desc scheme-types inv-kind args)
   (build-method-arguments-from-desc (if (= inv-kind INVOKE_PROPERTYPUT)
-					1
+                                        1
-					0)
+                                        0)
-				    (lambda (i)
+                                    (lambda (i)
-				      (VARDESC-elemdescVar var-desc))
+                                      (VARDESC-elemdescVar var-desc))
-				    scheme-types
+                                    scheme-types
-				    inv-kind
+                                    inv-kind
-				    args))
+                                    args))
 
 (define (variant-to-scheme var #:mode [mode '(out)])
   (define _t (to-ctype (vt-to-scheme-type (VARIANT-vt var)) #:mode mode))
@@ -1902,8 +1902,8 @@
                                                 inv-kind args)]
    [else
     (build-method-arguments-using-var-desc (mx-com-type-desc-desc type-desc)
-					   scheme-types
+                                           scheme-types
-					   inv-kind args)]))
+                                           inv-kind args)]))
 
 (define (find-memid who obj name)
   (define-values (r memid)
@@ -1919,29 +1919,29 @@
   (define ta (cadr t))
   (define len (length ta))
   (if (and (len . >= . 2)
-	   ((length args) . >= . (- len 2))
+           ((length args) . >= . (- len 2))
-	   (eq? '... (list-ref ta (sub1 len)))
+           (eq? '... (list-ref ta (sub1 len)))
-	   (eq? 'any (list-ref ta (- len 2))))
+           (eq? 'any (list-ref ta (- len 2))))
       ;; Replace `any ...' with the right number of `any's
       `(,(car t) ,(append (take ta (- len 2))
-			  (make-list (- (length args) (- len 2)) 'any))
+                          (make-list (- (length args) (- len 2)) 'any))
-	. ,(cddr t))
+        . ,(cddr t))
       t))
 
 (define (do-com-invoke who obj name args inv-kind)
   (check-com-obj who obj)
   (unless (string? name) (raise-type-error who "string" name))
   (let* ([t (or (do-get-method-type who obj name inv-kind #t)
-		;; wing it by inferring types from the arguments:
+                ;; wing it by inferring types from the arguments:
-		`(-> ,(map arg-to-type args) any))]
+                `(-> ,(map arg-to-type args) any))]
-	 [t (adjust-any-... args t)])
+         [t (adjust-any-... args t)])
     (unless (<= (for/fold ([n 0]) ([v (in-list (cadr t))])
-		  (if (and (pair? v) (eq? (car v) 'opt))
+                  (if (and (pair? v) (eq? (car v) 'opt))
-		      (add1 n)
+                      (add1 n)
-		      n))
+                      n))
                 (length args)
                 (length (cadr t)))
-	    (error 'com-invoke "bad argument count for ~s" name))
+            (error 'com-invoke "bad argument count for ~s" name))
     (for ([arg (in-list args)]
           [type (in-list (cadr t))])
       (check-argument 'com-invoke name arg type))
@@ -1968,26 +1968,26 @@
                             (variant-to-scheme (ptr-ref (DISPPARAMS-rgvarg method-arguments) 
                                                         _VARIANT 
                                                         i)
-					       #:mode '())))))
+                                               #:mode '())))))
-	      (define exn-info-ptr (malloc 'atomic-interior _EXCEPINFO))
+              (define exn-info-ptr (malloc 'atomic-interior _EXCEPINFO))
               (define-values (method-result cleanups)
                 (if (= inv-kind INVOKE_PROPERTYPUT)
                     (values #f arg-cleanups)
                     (let ([r (make-a-VARIANT 'raw)])
-		      (values r (cons (lambda () (free r))
+                      (values r (cons (lambda () (free r))
-				      arg-cleanups)))))
+                                      arg-cleanups)))))
               (for ([proc (in-list commits)]) (proc))
               (define hr
-		;; Note that all arguments to `Invoke' should
+                ;; Note that all arguments to `Invoke' should
-		;; not be movable by a GC. A call to `Invoke'
+                ;; not be movable by a GC. A call to `Invoke'
-		;; may use the Windows message queue, and other
+                ;; may use the Windows message queue, and other
-		;; libraries (notably `racket/gui') may have
+                ;; libraries (notably `racket/gui') may have
-		;; callbacks triggered via messages.
+                ;; callbacks triggered via messages.
                 (Invoke (com-object-get-dispatch obj)
                         memid IID_NULL LOCALE_SYSTEM_DEFAULT
                         inv-kind method-arguments
                         method-result
-			exn-info-ptr error-index-ptr))
+                        exn-info-ptr error-index-ptr))
               (cond
                [(zero? hr)
                 (begin0
@@ -1997,7 +1997,7 @@
                  (for ([proc (in-list cleanups)]) (proc)))]
                [(= hr DISP_E_EXCEPTION)
                 (for ([proc (in-list cleanups)]) (proc))
-		(define exn-info (cast exn-info-ptr _pointer _EXCEPINFO-pointer))
+                (define exn-info (cast exn-info-ptr _pointer _EXCEPINFO-pointer))
                 (define has-error-code? (positive? (EXCEPINFO-wCode exn-info)))
                 (define desc (EXCEPINFO-bstrDescription exn-info))
                 (windows-error
@@ -2174,8 +2174,8 @@
         (define sink-factory
           (myssink-DllGetClassObject CLSID_Sink IID_IClassFactory))
         (define sink-unknown
-	  ;; This primitive method doesn't AddRef the object, 
+          ;; This primitive method doesn't AddRef the object, 
-	  ;; so don't Release it:
+          ;; so don't Release it:
           (CreateInstance/factory sink-factory #f CLSID_Sink))
         (define sink (QueryInterface sink-unknown IID_ISink _ISink-pointer))
         (set_myssink_table sink myssink-table)
@@ -2235,10 +2235,10 @@
 ;; Initialize
 
 (define-ole CoInitialize (_wfun (_pointer = #f) -> (r : _HRESULT)
-				-> (cond
+                                -> (cond
-				    [(= r 0) (void)] ; ok
+                                    [(= r 0) (void)] ; ok
-				    [(= r 1) (void)] ; already initialized
+                                    [(= r 1) (void)] ; already initialized
-				    [else (windows-error (format "~a: failed" 'CoInitialize) r)])))
+                                    [else (windows-error (format "~a: failed" 'CoInitialize) r)])))
 
 (define inited? #f)
 (define (init!)

collects/ffi/unsafe/objc.rkt

@@ -93,8 +93,8 @@
    [method_count _int] ; 1
    [method _objc_method]))
 
-(define CLS_CLASS		#x1)
+(define CLS_CLASS               #x1)
-(define CLS_META		#x2)
+(define CLS_META                #x2)
 
 (define (strcpy s)
   (let* ([n (cast s _string _bytes)]

collects/ffi/unsafe/private/win32.rkt

@@ -1,7 +1,7 @@
 #lang racket/base
 (require ffi/unsafe
          ffi/unsafe/define
-	 ffi/winapi)
+         ffi/winapi)
 (provide (protect-out (all-defined-out)))
 
 ;; Win32 type and structure declarations.
@@ -25,14 +25,14 @@
   #:default-make-fail make-not-available)
 
 ;; for functions that use the Windows stdcall ABI:
-(define-syntax-rule (_wfun type ...) 
+(define-syntax-rule (_wfun type ...)
   (_fun #:abi winapi type ...))
 
 ;; for functions that return HRESULTs
 (define-syntax _hfun
   (syntax-rules (->)
     [(_ type ... -> who res)
-     (_wfun type ... 
+     (_wfun type ...
             -> (r : _HRESULT)
             -> (if (positive? r)
                    (windows-error (format "~a: failed" 'who) r)
@@ -108,7 +108,7 @@
 (define _VVAL (_union _double
                       _intptr
                       ;; etc.
-		      (_array _pointer 2)
+                      (_array _pointer 2)
                       ))
 
 (define-cstruct _VARIANT ([vt _VARTYPE]
@@ -179,7 +179,7 @@
                           raw-scode))
         (define len (FormatMessageW FORMAT_MESSAGE_FROM_SYSTEM #f scode 0 buf (quotient size 2)))
         (if (positive? len)
-            (error (format "~a (~x; ~a)" str scode (regexp-replace #rx"[\r\n]+$" 
+            (error (format "~a (~x; ~a)" str scode (regexp-replace #rx"[\r\n]+$"
                                                                    (cast buf _pointer _string/utf-16)
                                                                    "")))
             (error (format "~a (~x)" str scode))))))
@@ -222,18 +222,18 @@
 
 (define FUNC_VIRTUAL 0)
 (define FUNC_PUREVIRTUAL 1)
-(define FUNC_NONVIRTUAL	2)
+(define FUNC_NONVIRTUAL 2)
 (define FUNC_STATIC 3)
 (define FUNC_DISPATCH 4)
 
-(define	PARAMFLAG_NONE 0)
+(define PARAMFLAG_NONE 0)
-(define	PARAMFLAG_FIN #x1)
+(define PARAMFLAG_FIN #x1)
-(define	PARAMFLAG_FOUT #x2)
+(define PARAMFLAG_FOUT #x2)
-(define	PARAMFLAG_FLCID	#x4)
+(define PARAMFLAG_FLCID #x4)
-(define	PARAMFLAG_FRETVAL #x8)
+(define PARAMFLAG_FRETVAL #x8)
-(define	PARAMFLAG_FOPT #x10)
+(define PARAMFLAG_FOPT #x10)
-(define	PARAMFLAG_FHASDEFAULT #x20)
+(define PARAMFLAG_FHASDEFAULT #x20)
-(define	PARAMFLAG_FHASCUSTDATA #x40)
+(define PARAMFLAG_FHASCUSTDATA #x40)
 
 (define VT_EMPTY 0)
 (define VT_NULL 1)
@@ -288,7 +288,7 @@
 (define VT_ILLEGALMASKED #xfff)
 (define VT_TYPEMASK #xfff)
 
-(define	DISPID_PROPERTYPUT -3)
+(define DISPID_PROPERTYPUT -3)
 
 (define DISP_E_PARAMNOTFOUND #x80020004)
 (define DISP_E_EXCEPTION #x80020009)
@@ -307,13 +307,13 @@
              (set-GUID-s2! guid (bitwise-and #xFFFF (arithmetic-shift n (* -8 8))))
              (set-GUID-c! guid (for/list ([i (in-range 8)])
                                  (bitwise-and #xFF (arithmetic-shift n (* (- -7 i)))))))))
- 
+
 (define-ole StringFromIID(_hfun _GUID-pointer (p : (_ptr o _pointer))
                                 -> StringFromIID p))
 
 
 (define (string->guid s [stay-put? #f])
-  (define guid 
+  (define guid
     (if stay-put?
         (cast (malloc _GUID 'atomic-interior) _pointer (_gcable _GUID-pointer))
         (make-GUID 0 0 0 (list 0 0 0 0 0 0 0 0))))
@@ -354,30 +354,30 @@
 
 (define _SAFEARRAY-pointer (_cpointer 'SAFEARRAY))
 
-(define-oleaut SafeArrayCreate (_wfun _VARTYPE 
+(define-oleaut SafeArrayCreate (_wfun _VARTYPE
-				      _UINT
+                                      _UINT
-				      (dims : (_list i _SAFEARRAYBOUND))
+                                      (dims : (_list i _SAFEARRAYBOUND))
-				      -> _SAFEARRAY-pointer))
+                                      -> _SAFEARRAY-pointer))
 (define-oleaut SafeArrayDestroy (_hfun _SAFEARRAY-pointer
-				       -> SafeArrayDestroy (void)))
+                                       -> SafeArrayDestroy (void)))
 (define-oleaut SafeArrayGetVartype (_hfun _SAFEARRAY-pointer
-					  (vt : (_ptr o _VARTYPE))
+                                          (vt : (_ptr o _VARTYPE))
-					  -> SafeArrayGetVartype vt))
+                                          -> SafeArrayGetVartype vt))
 (define-oleaut SafeArrayGetLBound (_hfun _SAFEARRAY-pointer
-					 _UINT
+                                         _UINT
-					 (v : (_ptr o _LONG))
+                                         (v : (_ptr o _LONG))
-					 -> SafeArrayGetLBound v))
+                                         -> SafeArrayGetLBound v))
 (define-oleaut SafeArrayGetUBound (_hfun _SAFEARRAY-pointer
-					 _UINT
+                                         _UINT
-					 (v : (_ptr o _LONG))
+                                         (v : (_ptr o _LONG))
-					 -> SafeArrayGetUBound v))
+                                         -> SafeArrayGetUBound v))
 (define-oleaut SafeArrayPutElement (_hfun _SAFEARRAY-pointer
-					  (_list i _LONG)
+                                          (_list i _LONG)
-					  _pointer
+                                          _pointer
-					  -> SafeArrayPutElement (void)))
+                                          -> SafeArrayPutElement (void)))
 (define-oleaut SafeArrayGetElement (_hfun _SAFEARRAY-pointer
-					  (_list i _LONG)
+                                          (_list i _LONG)
-					  _pointer
+                                          _pointer
-					  -> SafeArrayGetElement (void)))
+                                          -> SafeArrayGetElement (void)))
 (define-oleaut SafeArrayGetDim (_wfun _SAFEARRAY-pointer
-				      -> _UINT))
+                                      -> _UINT))

collects/file/gunzip.rkt

@@ -927,5 +927,5 @@
 	(dynamic-wind
 	 void
 	 (lambda () (do-gunzip in #f name-filter))
-	 (lambda () (close-input-port in))))]))	     
+	 (lambda () (close-input-port in))))]))
 

collects/file/scribblings/md5.scrbl

@@ -20,3 +20,6 @@ that is the MD5 hash of the given input stream or byte string.
 (md5 #"abc")
 (md5 #"abc" #f)
 ]}
+
+
+@close-eval[md5-eval]

collects/file/scribblings/sha1.scrbl

@@ -40,3 +40,6 @@ until an end-of-file.
 Converts the given byte string to a string representation, where each
 byte in @racket[bstr] is converted to its two-digit hexadecimal
 representation in the resulting string.}
+
+
+@close-eval[sha1-eval]

collects/file/sha1.rkt

@@ -269,7 +269,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (define (hash-value->bytes int)
   (let* ((len (vector-length hash-as-bytes-masks))
- 	 (bv (make-bytes len 0)))
+         (bv (make-bytes len 0)))
      (do ((i 0 (+ i 1)))
          ((>= i len) bv)
        (bytes-set!

collects/framework/main.rkt

@@ -72,6 +72,12 @@
     in a GUI, and the color to use. The colors are used to show the nesting
     structure in the parens.})
  
+ (thing-doc
+  color:misspelled-text-color-style-name
+  string?
+  @{The name of the style used to color misspelled words. See also 
+    @method[color:text<%> get-spell-check-strings].})
+ 
  (proc-doc/names
   text:range? (-> any/c boolean?) (arg)
   @{Determines if @racket[arg] is an instance of the @tt{range} struct.})

collects/framework/private/color.rkt

@@ -6,9 +6,8 @@ added reset-regions
 added get-regions
 |#
 
-(require mzlib/class
+(require racket/class
-         mzlib/thread
+         racket/gui/base
-         mred
          syntax-color/token-tree
          syntax-color/paren-tree
          syntax-color/default-lexer
@@ -237,13 +236,11 @@ added get-regions
         (start-colorer token-sym->style get-token pairs)))
     
     ;; ---------------------- Multi-threading ---------------------------
-    ;; A list of (vector style number number) that indicate how to color the buffer
+    ;; The editor revision when the last coloring was started
-    (define colorings null)
+    (define revision-when-started-parsing #f)
-    ;; The coroutine object for tokenizing the buffer
+
-    (define tok-cor #f)
+    ;; The editor revision when after the last edit to the buffer
-    ;; The editor revision when tok-cor was created
+    (define revision-after-last-edit #f)
-    (define rev #f)
-    
     
     (inherit change-style begin-edit-sequence end-edit-sequence highlight-range
              get-style-list in-edit-sequence? get-start-position get-end-position
@@ -275,17 +272,7 @@ added get-regions
       (update-lexer-state-observers)
       (set! restart-callback #f)
       (set! force-recolor-after-freeze #f)
-      (set! colorings null)
+      (set! revision-when-started-parsing #f))
-      (when tok-cor
-        (coroutine-kill tok-cor))
-      (set! tok-cor #f)
-      (set! rev #f))
-    
-    ;; Actually color the buffer.
-    (define/private (color)
-      (for ([clr (in-list colorings)])
-        (change-style (vector-ref clr 0) (vector-ref clr 1) (vector-ref clr 2) #f))
-      (set! colorings '()))
     
     ;; Discard extra tokens at the first of invalid-tokens
     (define/private (sync-invalid ls)
@@ -302,60 +289,83 @@ added get-regions
             (set-lexer-state-invalid-tokens-mode! ls mode))
           (sync-invalid ls))))
     
-    (define/private (re-tokenize ls in in-start-pos in-lexer-mode enable-suspend)
+    (define/private (re-tokenize-move-to-next-ls start-time did-something?)
-      (enable-suspend #f)
+      (cond
-      ;(define-values (_line1 _col1 pos-before) (port-next-location in))
+        [(null? re-tokenize-lses) 
-      (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) 
+         ;; done: return #t
-        (get-token in in-start-pos in-lexer-mode))
+         #t]
-      ;(define-values (_line2 _col2 pos-after) (port-next-location in))
+        [else
-      (enable-suspend #t)
+         (define ls (car re-tokenize-lses))
-      (unless (eq? 'eof type)
+         (set! re-tokenize-lses (cdr re-tokenize-lses))
-        (unless (exact-nonnegative-integer? new-token-start)
+         (define in
-          (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start))
+           (open-input-text-editor this 
-        (unless (exact-nonnegative-integer? new-token-end)
+                                   (lexer-state-current-pos ls)
-          (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end))
+                                   (lexer-state-end-pos ls)
-        (unless (exact-nonnegative-integer? backup-delta)
+                                   (λ (x) #f)))
-          (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta))
+         (port-count-lines! in)
-        (unless (0 . < . (- new-token-end new-token-start))
+         (continue-re-tokenize start-time did-something? ls in
-          (error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end))
+                               (lexer-state-current-pos ls)
-        (enable-suspend #f)
+                               (lexer-state-current-lexer-mode ls))]))
-        #; (printf "~s at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start))
+    
-                   (+ in-start-pos (sub1 new-token-end)))
+    (define re-tokenize-lses #f)
-        (let ((len (- new-token-end new-token-start)))
+    
-          #;
+    (define/private (continue-re-tokenize start-time did-something? ls in in-start-pos lexer-mode)
-          (unless (= len (- pos-after pos-before))
+      (cond
-            ;; this check requires the two calls to port-next-location to be also uncommented
+        [(and did-something? ((+ start-time 20.0) . <= . (current-inexact-milliseconds)))
-            ;; when this check fails, bad things can happen non-deterministically later on
+         #f]
-            (eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n" 
+        [else
-                     len pos-before pos-after lexeme new-lexer-mode))
+         ;(define-values (_line1 _col1 pos-before) (port-next-location in))
-          (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls)))
+         (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) 
-          (set-lexer-state-current-lexer-mode! ls new-lexer-mode)
+           (get-token in in-start-pos lexer-mode))
-          (sync-invalid ls)
+         ;(define-values (_line2 _col2 pos-after) (port-next-location in))
-          (when (and should-color? (should-color-type? type) (not frozen?))
+         (cond
-            (add-colorings type in-start-pos new-token-start new-token-end))
+           [(eq? 'eof type) 
-          ;; Using the non-spec version takes 3 times as long as the spec
+            (re-tokenize-move-to-next-ls start-time #t)]
-          ;; version.  In other words, the new greatly outweighs the tree
+           [else
-          ;; operations.
+            (unless (exact-nonnegative-integer? new-token-start)
-          ;;(insert-last! tokens (new token-tree% (length len) (data type)))
+              (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start))
-          (insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta))
+            (unless (exact-nonnegative-integer? new-token-end)
-          #; (show-tree (lexer-state-tokens ls))
+              (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end))
-          (send (lexer-state-parens ls) add-token data len)
+            (unless (exact-nonnegative-integer? backup-delta)
-          (cond
+              (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta))
-            [(and (not (send (lexer-state-invalid-tokens ls) is-empty?))
+            (unless (new-token-start . < . new-token-end)
-                  (= (lexer-state-invalid-tokens-start ls)
+              (error 'color:text<%>
-                     (lexer-state-current-pos ls))
+                     "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e"
-                  (equal? new-lexer-mode 
+                     new-token-start new-token-end))
-                          (lexer-state-invalid-tokens-mode ls)))
+            (let ((len (- new-token-end new-token-start)))
-             (send (lexer-state-invalid-tokens ls) search-max!)
+              #;
-             (send (lexer-state-parens ls) merge-tree
+              (unless (= len (- pos-after pos-before))
-                   (send (lexer-state-invalid-tokens ls) get-root-end-position))
+                ;; this check requires the two calls to port-next-location to be also uncommented
-             (insert-last! (lexer-state-tokens ls)
+                ;; when this check fails, bad things can happen non-deterministically later on
-                           (lexer-state-invalid-tokens ls))
+                (eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n" 
-             (set-lexer-state-invalid-tokens-start! ls +inf.0)
+                         len pos-before pos-after lexeme new-lexer-mode))
-             (enable-suspend #t)]
+              (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls)))
-            [else
+              (set-lexer-state-current-lexer-mode! ls new-lexer-mode)
-             (enable-suspend #t)
+              (sync-invalid ls)
-             (re-tokenize ls in in-start-pos new-lexer-mode enable-suspend)]))))
+              (when (and should-color? (should-color-type? type) (not frozen?))
+                (add-colorings type in-start-pos new-token-start new-token-end))
+              ;; Using the non-spec version takes 3 times as long as the spec
+              ;; version.  In other words, the new greatly outweighs the tree
+              ;; operations.
+              ;;(insert-last! tokens (new token-tree% (length len) (data type)))
+              (insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta))
+              #; (show-tree (lexer-state-tokens ls))
+              (send (lexer-state-parens ls) add-token data len)
+              (cond
+                [(and (not (send (lexer-state-invalid-tokens ls) is-empty?))
+                      (= (lexer-state-invalid-tokens-start ls)
+                         (lexer-state-current-pos ls))
+                      (equal? new-lexer-mode 
+                              (lexer-state-invalid-tokens-mode ls)))
+                 (send (lexer-state-invalid-tokens ls) search-max!)
+                 (send (lexer-state-parens ls) merge-tree
+                       (send (lexer-state-invalid-tokens ls) get-root-end-position))
+                 (insert-last! (lexer-state-tokens ls)
+                               (lexer-state-invalid-tokens ls))
+                 (set-lexer-state-invalid-tokens-start! ls +inf.0)
+                 (re-tokenize-move-to-next-ls start-time #t)]
+                [else
+                 (continue-re-tokenize start-time #t ls in in-start-pos new-lexer-mode)]))])]))
 
     (define/private (add-colorings type in-start-pos new-token-start new-token-end)
       (define sp (+ in-start-pos (sub1 new-token-start)))
@@ -376,22 +386,23 @@ added get-regions
                            [lp 0])
                   (cond
                     [(null? spellos) 
-                     (set! colorings (cons (vector color (+ sp lp) (+ sp (string-length str)))
+                     (add-coloring color (+ sp lp) (+ sp (string-length str)))]
-                                           colorings))]
                     [else
                      (define err (car spellos))
                      (define err-start (list-ref err 0))
                      (define err-len (list-ref err 1))
-                     (set! colorings (list* (vector color (+ pos lp) (+ pos err-start))
+                     (add-coloring misspelled-color (+ pos err-start) (+ pos err-start err-len))
-                                            (vector misspelled-color (+ pos err-start) (+ pos err-start err-len))
+                     (add-coloring color (+ pos lp) (+ pos err-start))
-                                            colorings))
                      (loop (cdr spellos) (+ err-start err-len))]))
                 (loop (cdr strs)
                       (+ pos (string-length str) 1))))]
            [else
-            (set! colorings (cons (vector color sp ep) colorings))])]
+            (add-coloring color sp ep)])]
         [else
-         (set! colorings (cons (vector color sp ep) colorings))]))
+         (add-coloring color sp ep)]))
+    
+    (define/private (add-coloring color sp ep) 
+      (change-style color sp ep #f))
     
     (define/private (show-tree t)
       (printf "Tree:\n")
@@ -486,52 +497,19 @@ added get-regions
     
     (define/private (colorer-driver)
       (unless (andmap lexer-state-up-to-date? lexer-states)
-        #;(printf "revision ~a\n" (get-revision-number))
-        (unless (and tok-cor (= rev (get-revision-number)))
-          (when tok-cor
-            (coroutine-kill tok-cor))
-          #;(printf "new coroutine\n")
-          (set! tok-cor
-                (coroutine
-                 (λ (enable-suspend)
-                   (parameterize ((port-count-lines-enabled #t))
-                     (for-each
-                      (lambda (ls)
-                        (re-tokenize ls
-                                     (begin
-                                       (enable-suspend #f)
-                                       (begin0
-                                         (open-input-text-editor this 
-                                                                 (lexer-state-current-pos ls)
-                                                                 (lexer-state-end-pos ls)
-                                                                 (λ (x) #f))
-                                         (enable-suspend #t)))
-                                     (lexer-state-current-pos ls)
-                                     (lexer-state-current-lexer-mode ls)
-                                     enable-suspend))
-                      lexer-states)))))
-          (set! rev (get-revision-number)))
-        (with-handlers ((exn:fail?
-                         (λ (exn)
-                           (parameterize ((print-struct #t))
-                             ((error-display-handler) 
-                              (format "exception in colorer thread: ~s" exn)
-                              exn))
-                           (set! tok-cor #f))))
-          #;(printf "begin lexing\n")
-          (when (coroutine-run 10 tok-cor)
-            (for-each (lambda (ls)
-                        (set-lexer-state-up-to-date?! ls #t))
-                      lexer-states)
-            (update-lexer-state-observers)))
-        #;(printf "end lexing\n")
-        #;(printf "begin coloring\n")
-        ;; This edit sequence needs to happen even when colors is null
-        ;; for the paren highlighter.
         (begin-edit-sequence #f #f)
-        (color)
+        (c-log "starting to color")
+        (set! re-tokenize-lses lexer-states)
+        (define finished? (re-tokenize-move-to-next-ls (current-inexact-milliseconds) #f))
+        (c-log (format "coloring stopped ~a" (if finished? "because it finished" "with more to do")))
+        (when finished?
+          (for ([ls (in-list lexer-states)])
+            (set-lexer-state-up-to-date?! ls #t))
+          (update-lexer-state-observers)
+          (c-log "updated observers"))
+        (c-log "starting end-edit-sequence")
         (end-edit-sequence)
-        #;(printf "end coloring\n")))
+        (c-log "finished end-edit-sequence")))
     
     (define/private (colorer-callback)
       (cond
@@ -1148,3 +1126,9 @@ added get-regions
 (define text-mode% (text-mode-mixin mode:surrogate-text%))
 
 (define misspelled-text-color-style-name "Misspelled Text")
+
+(define logger (make-logger 'framework/colorer (current-logger)))
+(define-syntax-rule
+  (c-log exp)
+  (when (log-level? logger 'debug)
+    (log-message logger 'debug exp (current-inexact-milliseconds))))

collects/framework/private/follow-log.rkt

@@ -0,0 +1,225 @@
+#lang racket/base
+
+(require racket/list
+         racket/class
+         racket/match
+         racket/pretty
+         racket/gui/base
+         framework/private/logging-timer)
+
+#|
+
+This file sets up a log receiver and then
+starts up DrRacket. It catches log messages and 
+organizes them on event boundaries, printing
+out the ones that take the longest
+(possibly dropping those where a gc occurs)
+
+The result shows, for each gui event, the
+log messages that occured during its dynamic
+extent as well as the number of milliseconds
+from the start of the gui event before the
+log message was reported.
+
+|#
+
+
+(define lr (make-log-receiver (current-logger)
+                              'debug 'racket/engine
+                              'debug 'GC
+                              'debug 'gui-event
+                              'debug 'framework/colorer
+                              'debug 'timeline))
+
+(define top-n-events 50)
+(define drop-gc? #t)
+(define start-right-away? #f)
+
+(define log-done-chan (make-channel))
+(define bt-done-chan (make-channel))
+
+(define start-log-chan (make-channel))
+(void 
+ (thread
+  (λ ()
+    (let loop () 
+      (sync start-log-chan)
+      (let loop ([events '()])
+        (sync
+         (handle-evt
+          lr
+          (λ (info)
+            (loop (cons info events))))
+         (handle-evt
+          log-done-chan
+          (λ (resp-chan)
+            (channel-put resp-chan events)))))
+      (loop)))))
+
+(define thread-to-watch (current-thread))
+(let ([win (get-top-level-windows)])
+  (unless (null? win)
+    (define fr-thd (eventspace-handler-thread (send (car win) get-eventspace)))
+    (unless (eq? thread-to-watch fr-thd)
+      (eprintf "WARNING: current-thread and eventspace thread aren't the same thread\n"))))
+(define start-bt-chan (make-channel))
+(void 
+ (thread
+  (λ ()
+    (let loop () 
+      (sync start-bt-chan)
+      (let loop ([marks '()])
+        (sync
+         (handle-evt
+          (alarm-evt (+ (current-inexact-milliseconds) 10))
+          (λ (_)
+            (loop (cons (continuation-marks thread-to-watch)
+                        marks))))
+         (handle-evt
+          bt-done-chan
+          (λ (resp-chan)
+            (define stacks (map continuation-mark-set->context marks))
+            (channel-put resp-chan stacks)))))
+      (loop)))))
+
+(define controller-frame-eventspace (make-eventspace))
+(define f (parameterize ([current-eventspace controller-frame-eventspace])
+            (new frame% [label "Log Follower"])))
+(define sb (new button% [label "Start Following Log"] [parent f]
+               [callback
+                (λ (_1 _2)
+                  (sb-callback))]))
+(define sb2 (new button% [label "Start Collecting Backtraces"] [parent f]
+                 [callback
+                  (λ (_1 _2)
+                    (start-bt-callback))]))
+(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f]
+                [callback
+                 (λ (_1 _2)
+                   (cond
+                     [following-log?
+                      (define resp (make-channel))
+                      (channel-put log-done-chan resp)
+                      (show-results (channel-get resp))
+                      (send db enable #f)
+                      (send sb enable #t)
+                      (send sb2 enable #t)
+                      (set! following-log? #f)]
+                     [following-bt?
+                      (define resp (make-channel))
+                      (channel-put bt-done-chan resp)
+                      (define stacks (channel-get resp))
+                      (show-bt-results stacks)
+                      (send db enable #f)
+                      (send sb enable #t)
+                      (send sb2 enable #t)
+                      (set! following-bt? #f)]))]))
+
+(define following-log? #f)
+(define following-bt? #f)
+
+(define (sb-callback)
+  (set! following-log? #t)
+  (send sb enable #f)
+  (send sb2 enable #f)
+  (send db enable #t)
+  (channel-put start-log-chan #t))
+
+(define (start-bt-callback)
+  (set! following-bt? #t)
+  (send sb enable #f)
+  (send sb2 enable #f)
+  (send db enable #t)
+  (channel-put start-bt-chan #t))
+
+(send f show #t)
+
+(define (show-bt-results stacks)
+  (define top-frame (make-hash))
+  (for ([stack (in-list stacks)])
+    (unless (null? stack)
+      (define k (car stack))
+      (hash-set! top-frame k (cons stack (hash-ref top-frame k '())))))
+  (define sorted (sort (hash-map top-frame (λ (x y) y)) > #:key length))
+  (printf "top 10: ~s\n" (map length (take sorted (min (length sorted) 10))))
+  (define most-popular (cadr sorted))
+  (for ([x (in-range 10)])
+    (printf "---- next stack\n")
+    (pretty-print (list-ref most-popular (random (length most-popular))))
+    (printf "\n"))
+  (void))
+
+(struct gui-event (start end name) #:prefab)
+
+(define (show-results evts)
+  (define gui-events (filter (λ (x) 
+                               (define i (vector-ref x 2))
+                               (and (gui-event? i)
+                                    (number? (gui-event-end i))))
+                             evts))
+  (define interesting-gui-events
+    (take (sort gui-events > #:key (λ (x) 
+                                     (define i (vector-ref x 2))
+                                     (- (gui-event-end i)
+                                        (gui-event-start i))))
+          top-n-events))
+    
+  (define with-other-events
+    (for/list ([gui-evt (in-list interesting-gui-events)])
+      (match (vector-ref gui-evt 2)
+        [(gui-event start end name)
+         (define in-the-middle
+           (append (map (λ (x) (list (list 'δ (- (get-start-time x) start)) x))
+                        (sort
+                         (filter (λ (x) (and (not (gui-event? (vector-ref x 2)))
+                                             (<= start (get-start-time x) end)))
+                                 evts)
+                         <
+                         #:key get-start-time))
+                   (list (list (list 'δ (- end start)) 'end-of-gui-event))))
+         (list* (- end start)
+                gui-evt
+                in-the-middle)])))
+  
+  (define (has-a-gc-event? x)
+    (define in-the-middle (cddr x))
+    (ormap (λ (x) 
+             (and (vector? (list-ref x 1))
+                  (gc-info? (vector-ref (list-ref x 1) 2))))
+           in-the-middle))
+  
+  (pretty-print
+   (if drop-gc?
+       (filter (λ (x) (not (has-a-gc-event? x)))
+               with-other-events)
+       with-other-events)))
+
+(struct gc-info (major? pre-amount pre-admin-amount code-amount
+                        post-amount post-admin-amount
+                        start-process-time end-process-time
+                        start-time end-time)
+  #:prefab)
+(struct engine-info (msec name) #:prefab)
+
+(define (get-start-time x)
+  (cond
+    [(gc-info? (vector-ref x 2))
+     (gc-info-start-time (vector-ref x 2))]
+    [(engine-info? (vector-ref x 2))
+     (engine-info-msec (vector-ref x 2))]
+    [(regexp-match #rx"framework" (vector-ref x 1))
+     (vector-ref x 2)]
+    [(timeline-info? (vector-ref x 2))
+     (timeline-info-milliseconds (vector-ref x 2))]         
+    [else
+     (unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1))
+       (eprintf "unk: ~s\n" x))
+     0]))
+
+
+(module+ main
+  (when start-right-away?
+    (parameterize ([current-eventspace controller-frame-eventspace])
+      (queue-callback sb-callback)))
+  (dynamic-require 'drracket #f))
+

collects/framework/private/frame.rkt

@@ -796,9 +796,14 @@
              [ec (new position-canvas%
                       [parent panel]
                       [button-up
-                       (λ ()
+                       (λ (evt)
-                         (collect-garbage)
+                         (cond
-                         (update-memory-text))]
+                           [(or (send evt get-alt-down)
+                                (send evt get-control-down))
+                            (dynamic-require 'framework/private/follow-log #f)]
+                           [else
+                            (collect-garbage)
+                            (update-memory-text)]))]
                       [init-width "99.99 MB"])])
         (set! memory-canvases (cons ec memory-canvases))
         (update-memory-text)
@@ -890,6 +895,7 @@
     (inherit min-client-height min-client-width get-dc get-client-size refresh)
     (init init-width)
     (init-field [button-up #f])
+    (init-field [char-typed void])
     (define str "")
     (define/public (set-str _str)
       (set! str _str)
@@ -913,7 +919,11 @@
           (let-values ([(cw ch) (get-client-size)])
             (when (and (<= (send evt get-x) cw)
                        (<= (send evt get-y) ch))
-              (button-up))))))
+              (if (procedure-arity-includes? button-up 1)
+                  (button-up evt)
+                  (button-up)))))))
+    (define/override (on-char evt)
+      (char-typed evt))
     (super-new (style '(transparent no-focus)))
     (let ([dc (get-dc)])
       (let-values ([(_1 th _2 _3) (send dc get-text-extent str)])

collects/framework/private/keymap.rkt

@@ -337,7 +337,7 @@
            
            [mouse-popup-menu 
             (λ (edit event)
-              (when (send event button-down?)
+              (when (send event button-up?)
                 (let ([a (send edit get-admin)])
                   (when a
                     (let ([m (make-object popup-menu%)])
@@ -739,7 +739,7 @@
                                            (send edit on-char event)
                                            (loop (sub1 n)))))
                                      (λ ()
-                                       (send edit end-edit-sequence)))))))			       
+                                       (send edit end-edit-sequence)))))))
                         #t))
                 (send km set-break-sequence-callback done)
                 #t))]
@@ -823,7 +823,7 @@
             (λ (edit event)
               (when building-macro
                 (set! current-macro (reverse building-macro))
-                (set! build-protect? #f)		    
+                (set! build-protect? #f)
                 (send build-macro-km break-sequence))
               #t)]
            [delete-key

collects/framework/private/logging-timer.rkt

@@ -0,0 +1,66 @@
+#lang racket/base
+
+(require racket/gui/base
+         racket/class
+         (for-syntax racket/base))
+
+(define timeline-logger (make-logger 'timeline (current-logger)))
+
+(provide logging-timer%
+         (struct-out timeline-info)
+         log-timeline)
+
+(define logging-timer%
+  (class timer%
+    (init notify-callback)
+    (define name (object-name notify-callback))
+    (define wrapped-notify-callback
+      (λ ()
+        (log-timeline
+         (format "~a timer fired" name)
+         (notify-callback))))
+    (super-new [notify-callback wrapped-notify-callback])
+    (define/override (start msec [just-once? #f])
+      (log-timeline (format "~a timer started; msec ~s just-once? ~s" name msec just-once?))
+      (super start msec just-once?))))
+
+
+(define-syntax (log-timeline stx)
+  (syntax-case stx ()
+    [(_ info-string expr)
+     #'(log-timeline/proc 
+        (and (log-level? timeline-logger 'debug)
+             info-string)
+        (λ () expr))]
+    [(_ info-string)
+     #'(log-timeline/proc 
+        (and (log-level? timeline-logger 'debug)
+             info-string)
+        #f)]))
+
+(define (log-timeline/proc info expr)
+  (define start-time (current-inexact-milliseconds))
+  (when info
+    (log-message timeline-logger 'debug 
+                 (format "~a start" info)
+                 (timeline-info (if expr 'start 'once)
+                                (current-process-milliseconds)
+                                start-time)))
+  (when expr 
+    (begin0
+      (expr)
+      (when info
+        (define end-time (current-inexact-milliseconds))
+        (log-message timeline-logger 'debug 
+                     (format "~a   end; delta ms ~a" info (- end-time start-time))
+                     (timeline-info start-time
+                                    end-time
+                                    (current-inexact-milliseconds)))))))
+
+
+;; what : (or/c 'start 'once flonum)
+;;    flonum means that this is an 'end' event and there should be
+;;    a start event corresponding to it with that milliseconds 
+;; process-milliseconds : fixnum
+;; milliseconds : flonum -- time of this event
+(struct timeline-info (what process-milliseconds milliseconds) #:transparent)

collects/framework/private/racket.rkt

@@ -538,7 +538,7 @@
                   #f)]
              [last-para (and last
                              (position-paragraph last))])
-        (letrec	
+        (letrec
             ([find-offset
               (λ (start-pos)
                 (define tab-char? #f)

collects/framework/private/text.rkt

@@ -11,7 +11,8 @@
          "autocomplete.rkt"
          mred/mred-sig
          mrlib/interactive-value-port
-         racket/list)
+         racket/list
+         "logging-timer.rkt")
 (require setup/xref
          scribble/xref
          scribble/manual-struct)
@@ -1063,7 +1064,7 @@
       (when searching-str
         (unless timer
           (set! timer 
-                (new timer% 
+                (new logging-timer% 
                      [notify-callback 
                       (λ () 
                         (run-after-edit-sequence
@@ -1536,7 +1537,7 @@
     ;; have not yet been propogated to the delegate
     (define todo '())
     
-    (define timer (new timer% 
+    (define timer (new logging-timer% 
                        [notify-callback
                         (λ ()
                           ;; it should be the case that todo is always '() when the delegate is #f
@@ -3854,7 +3855,9 @@ designates the character that triggers autocompletion
 ;; draws line numbers on the left hand side of a text% object
 (define line-numbers-mixin
   (mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>)
-    (inherit get-visible-line-range
+    (inherit begin-edit-sequence
+             end-edit-sequence
+             get-visible-line-range
              get-visible-position-range
              last-line
              line-location
@@ -4193,6 +4196,7 @@ designates the character that triggers autocompletion
       (when (showing-line-numbers?)
         (define dc (get-dc))
         (when dc
+          (begin-edit-sequence #f #f)
           (define bx (box 0))
           (define by (box 0))
           (define tw (text-width dc (number-space+1)))
@@ -4208,7 +4212,8 @@ designates the character that triggers autocompletion
                                        tw
                                        th)
               (unless (= line (last-line))
-                (loop (+ line 1))))))))
+                (loop (+ line 1)))))
+          (end-edit-sequence))))
     
     (super-new)
     (setup-padding)))

collects/framework/test.rkt

@@ -253,22 +253,26 @@
 
 (define object-tag 'test:find-object)
 
-;; find-object : class (union string (object -> boolean)) -> object
+;; find-object : class (union string regexp (object -> boolean)) -> object
 (define (find-object obj-class b-desc)
   (λ ()
     (cond
       [(or (string? b-desc)
+           (regexp? b-desc)
            (procedure? b-desc))
        (let* ([active-frame (test:get-active-top-level-window)]
               [_ (unless active-frame
                    (error object-tag
-                          "could not find object: ~a, no active frame" 
+                          "could not find object: ~e, no active frame" 
                           b-desc))]
               [child-matches?
                (λ (child)
                  (cond
                    [(string? b-desc)
                     (equal? (send child get-label) b-desc)]
+                   [(regexp? b-desc)
+                    (and (send child get-label)
+                         (regexp-match? b-desc (send child get-label)))]
                    [(procedure? b-desc)
                     (b-desc child)]))]
               [found
@@ -287,13 +291,13 @@
                         (send panel get-children)))])
          (or found
              (error object-tag 
-                    "no object of class ~a named ~e in active frame"
+                    "no object of class ~e named ~e in active frame"
                     obj-class
                     b-desc)))]
       [(is-a? b-desc obj-class) b-desc]
       [else (error 
              object-tag
-             "expected either a string or an object of class ~a as input, received: ~a"
+             "expected either a string or an object of class ~e as input, received: ~e"
              obj-class b-desc)])))
 
 
@@ -317,7 +321,7 @@
            [else
             (update-control ctrl)
             (send ctrl command event)
-            (void)]))))))	     
+            (void)]))))))
 
 ;;
 ;; BUTTON
@@ -936,7 +940,8 @@
  (proc-doc/names
   test:keystroke
   (->* ((or/c char? symbol?))
-       ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift)))
+       ((listof (or/c 'alt 'control 'meta 'shift 
+                      'noalt 'nocontrol 'nometea 'noshift)))
        void?)
   ((key)
    ((modifier-list null)))
@@ -973,10 +978,11 @@
  (proc-doc/names
   test:mouse-click
   (->*
-   ((symbols 'left 'middle 'right)
+   ((or/c 'left 'middle 'right)
     (and/c exact? integer?)
     (and/c exact? integer?))
-   ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift)))
+   ((listof (or/c 'alt 'control 'meta 'shift 'noalt
+                  'nocontrol 'nometa 'noshift)))
    void?)
   ((button x y)
    ((modifiers null)))
@@ -985,7 +991,7 @@
   @method[canvas<%> on-event] method.
   Use @racket[test:button-push] to click on a button.
   
-  On the Macintosh, @racket['right] corresponds to holding down the command
+  Under Mac OS X, @racket['right] corresponds to holding down the command
   modifier key while clicking and @racket['middle] cannot be generated.
   
   Under Windows, @racket['middle] can only be generated if the user has a

collects/frtime/animation/graphics-sig.rkt

@@ -1,4 +1,5 @@
-#lang racket
+#lang racket/base
+
 (require racket/unit)
 
 (provide graphics^ graphics:posn-less^ graphics:posn^)

collects/frtime/animation/graphics-unit.rkt

@@ -1,4 +1,5 @@
-#lang racket
+#lang racket/base
+
 (require racket/unit
          mred/mred-sig
          "graphics-sig.rkt"

collects/frtime/animation/graphics.rkt

@@ -1,4 +1,5 @@
-#lang racket
+#lang racket/base
+
 (require racket/unit
          mred/mred-sig
          mred

collects/frtime/core/contract.rkt

@@ -1,8 +1,9 @@
-#lang racket
+#lang racket/base
+
+#;(require (for-syntax racket/contract))
 
 (define-syntax-rule (provide/contract* [id ctrct] ...)
   #;(provide/contract [id ctrct] ...)
   (provide id ...))
 
-(provide 
+(provide provide/contract*)
- provide/contract*)

collects/frtime/core/dv.rkt

@@ -1,5 +1,7 @@
-#lang racket
+#lang racket/base
-(require "contract.rkt")
+
+(require racket/match
+         "contract.rkt")
 
 (define-struct dv (vec-length next-avail-pos vec) #:mutable)
 

collects/frtime/core/erl.rkt

@@ -1,5 +1,8 @@
-#lang racket
+#lang racket/base
-(require "match.rkt"
+
+(require racket/bool
+         racket/match
+         "match.rkt"
          "contract.rkt"
          #;"sema-mailbox.rkt"
          "mailbox.rkt")

collects/frtime/core/frp.rkt

@@ -1,5 +1,10 @@
-#lang racket
+#lang racket/base
-(require "contract.rkt"
+
+(require racket/function
+         racket/list
+         racket/match
+         racket/contract
+         "contract.rkt"
          "erl.rkt"
          "heap.rkt")
 

collects/frtime/core/heap.rkt

@@ -1,5 +1,9 @@
-#lang racket
+#lang racket/base
-(require "dv.rkt"
+
+(require racket/bool
+         racket/match
+         racket/contract
+         "dv.rkt"
          "contract.rkt")
 
 (define-struct t (sorter equality data))

collects/frtime/core/mailbox.rkt

@@ -1,5 +1,9 @@
-#lang racket
+#lang racket/base
-(require "contract.rkt"
+
+(require racket/bool
+         racket/list
+         racket/match
+         "contract.rkt"
          "match.rkt"
          racket/async-channel)
 

collects/frtime/core/match.rkt

@@ -1,4 +1,4 @@
-#lang racket
+#lang racket/base
 
 (define-struct a-match-fail ())
 (define match-fail (make-a-match-fail))

collects/frtime/core/sema-mailbox.rkt

@@ -1,5 +1,9 @@
-#lang racket
+#lang racket/base
-(require "match.rkt"
+
+(require racket/list
+         racket/bool
+         racket/match
+         "match.rkt"
          "contract.rkt")
 
 (define (call-with-semaphore s thunk)

collects/frtime/develop-frtime.rkt

@@ -1,6 +1,6 @@
-#lang racket
+#lang racket/base
-(require setup/link)
 
+(require setup/link)
 
 #|Update this to point to your racket installation directory|#
 (define install-path "C:/Program Files/Racket/collects/frtime")
@@ -9,20 +9,16 @@
 (define dev-path "C:/Users/user/Documents/GitHub/racket/collects/frtime")
 
 #|Then call one of these functions to begin developing frtime, or to halt development.|#
-(define start-developing-frtime
+(define (start-developing-frtime)
-  (lambda ()
+  (start-developing-collection dev-path install-path))
-    (start-developing-collection dev-path install-path)))
 
 
-(define stop-developing-frtime
+(define (stop-developing-frtime)
-  (lambda ()
+  (stop-developing-collection dev-path install-path))
-    (stop-developing-collection dev-path install-path)))
 
-(define start-developing-collection
+(define (start-developing-collection dev-coll-path install-coll-path)
-  (lambda (dev-coll-path install-coll-path)
+  (links install-coll-path #:remove? #t)
-    (links install-coll-path #:remove? #t)
+  (links dev-coll-path))
-    (links dev-coll-path)))
 
-(define stop-developing-collection
+(define (stop-developing-collection dev-coll-path install-coll-path)
-  (lambda (dev-coll-path install-coll-path)
+  (start-developing-collection install-coll-path dev-coll-path))
-    (start-developing-collection install-coll-path dev-coll-path)))

collects/frtime/frlibs/date.rkt

@@ -1,6 +1,7 @@
-#lang racket
+#lang racket/base
-(require (rename-in (only-in frtime/frtime provide) 
+
-                    [provide frtime:provide]))
+(require racket/promise
+         (only-in frtime/frtime [provide frtime:provide]))
 
 (frtime:provide (lifted date->string
                         date-display-format

collects/frtime/opt/lowered-equivs.rkt

@@ -1,10 +1,10 @@
 ;; This module defines all the logic necessary for working with lowered
 ;; equivalents at the syntactic level.  That is, it treats functions simply 
 ;; as syntactic identifiers.
-#lang racket
+#lang racket/base
+
 (provide (except-out (all-defined-out)
                      module-identifier=?))
-(require (only-in srfi/1 any))
 
 (define module-identifier=? free-identifier=?)
 

collects/future-visualizer/private/graph-drawing.rkt

@@ -1,13 +1,17 @@
-#lang racket
+#lang racket/base
-(require rackunit 
+
+(require racket/list
+         racket/contract
+         ;; rackunit
          "constants.rkt")
-(provide (struct-out point) 
+
-         (struct-out node) 
+(provide (struct-out point)
-         (struct-out drawable-node) 
+         (struct-out node)
-         (struct-out graph-layout) 
+         (struct-out drawable-node)
+         (struct-out graph-layout)
          (struct-out attributed-node)
          draw-tree
-         drawable-node-center 
+         drawable-node-center
          build-attr-tree)
 
 (define-struct/contract point ([x integer?] [y integer?]) #:transparent)

collects/future-visualizer/scribblings/common.rkt

@@ -1,4 +1,4 @@
-#lang racket
+#lang racket/base
 
 (require (for-label racket/base)
          scribble/manual

collects/future-visualizer/scribblings/futures-trace.scrbl

@@ -1,5 +1,7 @@
 #lang scribble/doc 
-@(require "common.rkt" (for-label racket/future future-visualizer/trace)) 
+@(require "common.rkt" 
+          (for-label racket/future 
+                     future-visualizer/trace)) 
 
 @title[#:tag "futures-trace"]{Futures Tracing} 
 
@@ -63,10 +65,11 @@ the execution of parallel programs written using @racket[future].
 }
   
 @defstruct[indexed-future-event ([index exact-nonnegative-integer?] 
-                                 [event (or future-event? gc-info?)])]{
+                                 [event any])]{
   Represents an individual log message in a program trace.  In addition to 
   future events, the tracing code also records garbage collection events; hence 
-  the @racket[event] field may contain either a @racket[future-event] or @racket[gc-info], 
+  the @racket[event] field may contain either a @racket[future-event] or gc-info 
+  @(tech "prefab" #:doc '(lib "scribblings/reference/reference.scrbl")) struct (see @refsecref["garbagecollection"]), 
   where the latter describes a GC operation.  Because multiple 
   @racket[future-event] structures may contain identical timestamps, the 
   @racket[index] field ranks them in the order in which they were recorded 
@@ -82,19 +85,3 @@ the execution of parallel programs written using @racket[future].
                         #:prefab]{
  Represents a future event as logged by the run-time system. See
 @refsecref["future-logging"] for more information.}
-  
-@defstruct[gc-info ([major? boolean?] 
-                    [pre-used integer?] 
-                    [pre-admin integer?] 
-                    [code-page-total integer?] 
-                    [post-used integer?] 
-                    [post-admin integer?] 
-                    [start-time integer?] 
-                    [end-time integer?] 
-                    [start-real-time real?] 
-                    [end-real-time real?]) 
-                   #:prefab]{
-  Represents a garbage collection.  The only fields used by the visualizer 
-  are @racket[start-real-time] and @racket[end-real-time], which are inexact 
-  numbers representing time in the same way as @racket[current-inexact-milliseconds].
-}

collects/games/cards/classes.rkt

@@ -123,8 +123,8 @@
       (public*
         [only-front-selected
          (lambda ()
- 	   (let loop ([s (find-next-selected-snip #f)][ok (find-first-snip)])
+           (let loop ([s (find-next-selected-snip #f)][ok (find-first-snip)])
-	     (when s
+             (when s
                (if (eq? s ok)
                    (loop (find-next-selected-snip s)
                          (send ok next))