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)
-         srfi/13 htdp/error
+(require racket/function
+         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 
- (for-syntax syntax/parse)
- (for-template "clauses-spec-aux.rkt" racket (rename-in lang/prim (first-order->higher-order f2h))))
+(require racket/function
+         racket/list
+         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 
@@ -29,14 +33,14 @@
              [_ (err tag p msg)])))]))
 
 (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 

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,4 +1,3 @@
-
 Files for constructing universe.rkt:
 
  world.rkt              the old world
@@ -14,4 +13,3 @@ Files for constructing universe.rkt:
  image.rkt              the world image functions
  clauses-spec-and-process.rkt 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

@@ -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)))
-          (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))))
 
 ;; -----------------------------------------------------------------------------

collects/2htdp/universe.rkt

@@ -57,7 +57,7 @@
   [on-tick DEFAULT #'#f
            (function-with-arity
             1
-            except
+            #:except
             [(_ f rate)
              #'(list
                 (proc> 'on-tick (f2h f) 1)
@@ -84,7 +84,7 @@
   [on-draw to-draw DEFAULT #'#f
            (function-with-arity
             1
-            except
+            #:except
             [(_ f width height)
              #'(list (proc> 'to-draw (f2h f) 1)
                      (nat> 'to-draw width "width")
@@ -109,7 +109,7 @@
   [stop-when DEFAULT #'False
              (function-with-arity
               1
-              except
+              #:except
               [(_ stop? last-picture)
                #'(list (proc> 'stop-when (f2h stop?) 1)
                        (proc> 'stop-when (f2h last-picture) 1))])]

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
-(require compiler/zo-parse)
+#lang racket/base
+
+(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
-(require compiler/zo-parse
+#lang racket/base
+
+(require racket/match
+         racket/list
+         racket/dict
+         racket/contract
+         compiler/zo-parse
          "util.rkt")
 
 ; XXX Use efficient set structure
@@ -150,8 +155,7 @@
         (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]
                         [new-stxs stxs])
                        ([tl (in-list n-tls)])
@@ -162,9 +166,9 @@
                (define this-stx (visit-stx stx))
                (if this-stx
                    (list* this-stx new-stxs)
-                      new-stxs)))]          
+                   new-stxs)))
            (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
-(require compiler/zo-parse
+#lang racket/base
+
+(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 lift-tl (+ top-lift-start lift-offset which-lift))]
+                       (define which-lift (- n mod-lift-start))
+                       (define lift-tl (+ top-lift-start lift-offset which-lift))
                        (when (lift-tl . >= . max-toplevel)
                          (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))
-                         lift-tl)]
+                       lift-tl]
                       [else
                        (list-ref toplevel-remap n)]))
                   (lambda (n)

collects/compiler/demodularizer/module.rkt

@@ -1,5 +1,9 @@
-#lang racket
-(require compiler/zo-parse
+#lang racket/base
+
+(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
-(require syntax/modresolve)
+#lang racket/base
+
+(require racket/contract
+         syntax/modresolve)
 
 (define current-module-path (make-parameter #f))
 

collects/compiler/demodularizer/nodep.rkt

@@ -1,5 +1,9 @@
-#lang racket
-(require compiler/zo-parse
+#lang racket/base
+
+(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
-(require unstable/struct
+#lang racket/base
+
+(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
-(require compiler/zo-structs
+#lang racket/base
+
+(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
-(require compiler/zo-parse)
+#lang racket/base
+
+(require racket/contract
+         compiler/zo-parse)
 
 (define (prefix-syntax-start pre)
   (length (prefix-toplevels pre)))

collects/compiler/embed.rkt

@@ -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)
+  (make-do-sequence
    (lambda ()
-    (values (lambda () (heap-min h))
-            (lambda () (heap-remove-min! h) #t)
+     (values (lambda (_) (heap-min h))
+             (lambda (_) (heap-remove-min! h) #t)
              #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/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/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 ; gmarceau/test
+(require (for-syntax racket/base)
+         racket/list
+         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,7 +15,8 @@
 
 (define files-to-open (command-line #:args filenames filenames))
 
-(define the-date (seconds->date
+(define startup-date 
+  (seconds->date
    (let ([ssec (getenv "PLTDREASTERSECONDS")])
      (if ssec
          (string->number ssec)
@@ -25,24 +26,24 @@
 ;; to open. See also main.rkt.
 (current-command-line-arguments (apply vector files-to-open))
 
-(define (currently-the-weekend?)
-  (define dow (date-week-day the-date))
+(define (weekend-date? date)
+  (define dow (date-week-day date))
   (or (= dow 6) (= dow 0)))
 
-(define (valentines-day?)
-  (and (= 2 (date-month the-date))
-       (= 14 (date-day the-date))))
+(define (valentines-date? date)
+  (and (= 2 (date-month date))
+       (= 14 (date-day date))))
 
-(define (current-icon-state)
+(define (icon-state date)
   (cond
-    [(valentines-day?) 'valentines]
-    [(currently-the-weekend?) 'weekend]
+    [(valentines-date? date) 'valentines]
+    [(weekend-date? date) 'weekend]
     [else 'normal]))
 
 (define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween?)
-  (let* ([month (date-month the-date)]
-         [day (date-day the-date)]
-         [dow (date-week-day the-date)])
+  (let* ([month (date-month startup-date)]
+         [day (date-day startup-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/language-configuration.rkt

@@ -11,13 +11,17 @@
            string-constants
            framework
            setup/getinfo
+           setup/xref
+           scribble/xref
+           net/url
            syntax/toplevel
+           browser/external
            (only-in mzlib/struct make-->vector))
   
   (define original-output (current-output-port))
   (define (oprintf . args) (apply fprintf original-output args))
   
-  (define-values (sc-use-language-in-source sc-choose-a-language mouse-event-uses-shortcut-prefix?)
+  (define-values (sc-use-language-in-source sc-use-teaching-language sc-choose-a-language mouse-event-uses-shortcut-prefix?)
     (let* ([shortcut-prefix (get-default-shortcut-prefix)]
            [menukey-string 
             (apply string-append
@@ -38,14 +42,14 @@
                     [(shift) (send evt get-shiftdown)]
                     [(option) (send evt get-alt-down)]))
                 shortcut-prefix))
-    (values (string-append (string-constant use-language-in-source)
-                           (format " (~aU)" menukey-string))
-            (string-append (string-constant choose-a-language)
-                           (format " (~aC)" menukey-string))
+    (values (string-append (string-constant the-racket-language)
+                           (format " (~aR)" menukey-string))
+            (string-append (string-constant teaching-languages)
+                           (format " (~aT)" menukey-string))
+            (string-append (string-constant other-languages)
+                           (format " (~aO)" menukey-string))
             mouse-event-uses-shortcut-prefix?)))
   
-  (define sc-lang-in-source-discussion (string-constant lang-in-source-discussion))
-
   (provide language-configuration@)
   
   (define-unit language-configuration@
@@ -56,7 +60,8 @@
             [prefix drracket:app: drracket:app^]
             [prefix drracket:tools: drracket:tools^]
             [prefix drracket:help-desk: drracket:help-desk^]
-            [prefix drracket:module-language: drracket:module-language/int^])
+            [prefix drracket:module-language: drracket:module-language/int^]
+            [prefix drracket: drracket:interface^])
     (export drracket:language-configuration/internal^)
     
     ;; settings-preferences-symbol : symbol
@@ -242,7 +247,9 @@
                                 button-panel
                                 language-settings-to-show
                                 #f
-                                ok-handler))
+                                ok-handler
+                                (and (is-a? parent drracket:unit:frame<%>)
+                                     (send parent get-definitions-text))))
         
         ;; create ok/cancel buttons
         (make-object horizontal-pane% button-panel)
@@ -257,7 +264,7 @@
           (add-welcome dialog welcome-before-panel welcome-after-panel))
         
         (send dialog stretchable-width #f)
-        (send dialog stretchable-height #t)
+        (send dialog stretchable-height #f)
         
         (unless parent
           (send dialog center 'both))
@@ -277,7 +284,8 @@
     (define fill-language-dialog
       (λ (parent show-details-parent language-settings-to-show
                  [re-center #f]
-                          [ok-handler void]) ; en/disable button, execute it
+                 [ok-handler void]
+                 [definitions-text #f]) ; en/disable button, execute it
         
         (define-values (language-to-show settings-to-show)
           (let ([request-lang-to-show (language-settings-language language-settings-to-show)])
@@ -376,9 +384,13 @@
               (cond
                 [(and i (is-a? i hieritem-language<%>))
                  (define pos (send (send i get-language) get-language-position))
-                 (preferences:set 'drracket:language-dialog:hierlist-default pos)
-                 (set! most-recent-languages-hier-list-selection pos)
-                 (something-selected i)]
+                 (if (eq? this teaching-languages-hier-list)
+                     (preferences:set 'drracket:language-dialog:teaching-hierlist-default pos)
+                     (preferences:set 'drracket:language-dialog:hierlist-default pos))
+                 (if (eq? this teaching-languages-hier-list)
+                     (set! most-recent-teaching-languages-hier-list-selection pos)
+                     (set! most-recent-languages-hier-list-selection pos))
+                 (something-selected this i)]
                 [else
                  (non-language-selected)]))
             ;; this is used only because we set `on-click-always'
@@ -388,7 +400,7 @@
             ;; double-click selects a language
             (define/override (on-double-select i)
               (when (and i (is-a? i hieritem-language<%>))
-                (something-selected i)
+                (something-selected this i)
                 (ok-handler 'execute)))
             (super-new [parent parent])
             ;; do this so we can expand/collapse languages on a single click
@@ -396,9 +408,12 @@
             (on-click-always #t)
             (allow-deselect #t)))
         
-        (define outermost-panel (new horizontal-pane% [parent parent]))
+        (define outermost-panel (new horizontal-panel% 
+                                     [parent parent]
+                                     [alignment '(left top)]))
         (define languages-choice-panel (new vertical-panel%
                                             [parent outermost-panel]
+                                            [stretchable-height #f]
                                             [alignment '(left top)]))
         
         (define use-language-in-source-rb
@@ -411,7 +426,8 @@
                   (use-language-in-source-rb-callback))]))
         (define (use-language-in-source-rb-callback)
           (module-language-selected)
-          (send use-chosen-language-rb set-selection #f))
+          (send use-chosen-language-rb set-selection #f)
+          (send use-teaching-language-rb set-selection #f))
         (define in-source-discussion-panel (new horizontal-panel% 
                                                 [parent languages-choice-panel]
                                                 [stretchable-height #f]))
@@ -419,8 +435,41 @@
                                                  [parent in-source-discussion-panel]
                                                  [stretchable-width #f]
                                                  [min-width 32]))
-        (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel))
+        (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel definitions-text use-language-in-source-rb-callback))
         (define most-recent-languages-hier-list-selection (preferences:get 'drracket:language-dialog:hierlist-default))
+        (define most-recent-teaching-languages-hier-list-selection (preferences:get 'drracket:language-dialog:teaching-hierlist-default))
+        
+        (define use-teaching-language-rb
+          (new radio-box% 
+               [label #f]
+               [choices (list sc-use-teaching-language)]
+               [parent languages-choice-panel]
+               [callback
+                (λ (rb evt)
+                  (use-teaching-language-rb-callback))]))
+        (define (use-teaching-language-rb-callback)
+          (when most-recent-teaching-languages-hier-list-selection
+            (select-a-language-in-hierlist teaching-languages-hier-list
+                                           (cdr most-recent-teaching-languages-hier-list-selection)))
+          (send use-chosen-language-rb set-selection #f)
+          (send use-language-in-source-rb set-selection #f)
+          (send use-teaching-language-rb set-selection 0)
+          (send other-languages-hier-list select #f)
+          (send teaching-languages-hier-list focus))
+        
+        (define teaching-languages-hier-list-panel
+          (new horizontal-panel% [parent languages-choice-panel] [stretchable-height #f]))
+        (define teaching-languages-hier-list-spacer
+          (new horizontal-panel% 
+               [parent teaching-languages-hier-list-panel]
+               [stretchable-width #f]
+               [min-width 16]))
+        
+        (define teaching-languages-hier-list 
+          (new selectable-hierlist% 
+               [parent teaching-languages-hier-list-panel]
+               [style '(no-border no-hscroll auto-vscroll transparent)]))
+        
         (define use-chosen-language-rb
           (new radio-box%
                [label #f]
@@ -430,17 +479,52 @@
                 (λ (this-rb evt)
                   (use-chosen-language-rb-callback))]))
         (define (use-chosen-language-rb-callback)
+          (show-other-languages)
           (when most-recent-languages-hier-list-selection
-            (select-a-language-in-hierlist most-recent-languages-hier-list-selection))
+            (select-a-language-in-hierlist other-languages-hier-list
+                                           most-recent-languages-hier-list-selection))
           (send use-language-in-source-rb set-selection #f)
-          (send languages-hier-list focus))
-        (define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel]))
+          (send use-teaching-language-rb set-selection #f)
+          (send teaching-languages-hier-list select #f)
+          (send other-languages-hier-list focus))
+        (define (show-other-languages)
+          (when (member ellipsis-spacer-panel (send languages-hier-list-panel get-children))
+            (send languages-hier-list-panel change-children
+                  (λ (l)
+                    (list languages-hier-list-spacer other-languages-hier-list)))))
+        
+        (define languages-hier-list-panel (new horizontal-panel% 
+                                               [parent languages-choice-panel] 
+                                               [stretchable-height #f]))
+        (define ellipsis-spacer-panel (new horizontal-panel% 
+                                           [parent languages-hier-list-panel]
+                                           [stretchable-width #f]
+                                           [min-width 32]))
+        (define ellipsis-message (new (class canvas%
+                                        (define/override (on-paint)
+                                          (define dc (get-dc))
+                                          (send dc set-font normal-control-font)
+                                          (send dc draw-text "..." 0 0))
+                                        (define/override (on-event evt)
+                                          (when (send evt button-up?)
+                                            (show-other-languages)))
+                                        (inherit get-dc min-width min-height)
+                                        (super-new [style '(transparent)]
+                                                   [parent languages-hier-list-panel]
+                                                   [stretchable-width #f]
+                                                   [stretchable-height #t])
+                                        (let ()
+                                          (define dc (get-dc))
+                                          (define-values (w h _1 _2) (send dc get-text-extent "..." normal-control-font))
+                                          (min-width (inexact->exact (ceiling w)))
+                                          (min-height (inexact->exact (ceiling h)))))))
+        
         (define languages-hier-list-spacer (new horizontal-panel% 
                                                 [parent languages-hier-list-panel]
                                                 [stretchable-width #f]
                                                 [min-width 16]))
         
-        (define languages-hier-list (new selectable-hierlist% 
+        (define other-languages-hier-list (new selectable-hierlist% 
                                                [parent languages-hier-list-panel]
                                                [style '(no-border no-hscroll auto-vscroll transparent)]))
         (define details-outer-panel (make-object vertical-pane% outermost-panel))
@@ -493,9 +577,11 @@
         
         (define (module-language-selected)
           ;; need to deselect things in the languages-hier-list at this point.
-          (send languages-hier-list select #f)
-          (send use-chosen-language-rb set-selection #f)
+          (send other-languages-hier-list select #f)
+          (send teaching-languages-hier-list select #f)
           (send use-language-in-source-rb set-selection 0)
+          (send use-chosen-language-rb set-selection #f)
+          (send use-teaching-language-rb set-selection #f)
           (ok-handler 'enable)
           (send details-button enable #t)
           (update-gui-based-on-selected-language module-language*language
@@ -504,12 +590,14 @@
         
         ;; no-language-selected : -> void
         ;; updates the GUI for the situation where no language at all selected, and
-        ;; and thus neither of the radio buttons should be selected. 
+        ;; and thus none of the radio buttons should be selected. 
         ;; this generally happens when there is no preference setting for the language
         ;; (ie the user has just started drracket for the first time)
         (define (no-language-selected)
           (non-language-selected)
-          (send use-chosen-language-rb set-selection #f))
+          (send use-language-in-source-rb set-selection #f)
+          (send use-chosen-language-rb set-selection #f)
+          (send use-teaching-language-rb set-selection #f))
         
         (define module-language*language 'module-language*-not-yet-set)
         (define module-language*get-language-details-panel 'module-language*-not-yet-set)
@@ -519,8 +607,6 @@
         ;; updates the GUI and selected-language and get/set-selected-language-settings
         ;; for when some non-language is selected in the hierlist
         (define (non-language-selected)
-          (send use-chosen-language-rb set-selection 0)
-          (send use-language-in-source-rb set-selection #f)
           (send revert-to-defaults-button enable #f)
           (send details-panel active-child no-details-panel)
           (send one-line-summary-message set-label "")
@@ -530,9 +616,17 @@
           (send details-button enable #f))
         
         ;; something-selected : item -> void
-        (define (something-selected item)
-          (send use-chosen-language-rb set-selection 0)
+        (define (something-selected hierlist item)
           (send use-language-in-source-rb set-selection #f)
+          (cond
+            [(eq? hierlist other-languages-hier-list)
+             (send use-teaching-language-rb set-selection #f)
+             (send use-chosen-language-rb set-selection 0)
+             (send teaching-languages-hier-list select #f)]
+            [else 
+             (send use-teaching-language-rb set-selection 0)
+             (send use-chosen-language-rb set-selection #f)
+             (send other-languages-hier-list select #f)])
           (ok-handler 'enable)
           (send details-button enable #t)
           (send item selected))
@@ -546,8 +640,11 @@
         ;; when `language' matches language-to-show, update the settings
         ;;   panel to match language-to-show, otherwise set to defaults.
         (define (add-language-to-dialog language)
-          (let ([positions (send language get-language-position)]
-                [numbers (send language get-language-numbers)])
+          (define positions (send language get-language-position))
+          (define numbers (send language get-language-numbers))
+          (define teaching-language? (and (pair? positions)
+                                          (equal? (car positions)
+                                                  (string-constant teaching-languages))))
           
           ;; don't show the initial language ...
           (unless (equal? positions initial-language-position)
@@ -571,7 +668,8 @@
                 (error 'drracket:language
                        "Only the module language may be at the top level. Other languages must have at least two levels")))
             
-              (send languages-hier-list clear-fringe-cache)
+            (send other-languages-hier-list clear-fringe-cache)
+            (send teaching-languages-hier-list clear-fringe-cache)
             
             #|
               
@@ -581,11 +679,16 @@
               what the sorting number is for its level above (in the second-number mixin)
               
               |#
-              
             (let add-sub-language ([ht languages-table]
-                                     [hier-list languages-hier-list]
-                                     [positions positions]
-                                     [numbers numbers]
+                                   [hier-list (if teaching-language?
+                                                  teaching-languages-hier-list
+                                                  other-languages-hier-list)]
+                                   [positions (if teaching-language?
+                                                  (cdr positions)
+                                                  positions)]
+                                   [numbers (if teaching-language?
+                                                (cdr numbers)
+                                                numbers)]
                                    [first? #t]
                                    [second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number
               (cond
@@ -671,7 +774,8 @@
                                    (send language get-style-delta)
                                    0
                                    (send text last-position))])))]))]
-                  [else (let* ([position (car positions)]
+                [else
+                 (let* ([position (car positions)]
                         [number (car numbers)]
                         [sub-ht/sub-hier-list
                          (hash-ref
@@ -725,7 +829,7 @@
                                      (cdr positions)
                                      (cdr numbers)
                                      #f
-                                            (if first? number #f)))])))))
+                                     (if first? number #f)))]))))
         
         (define number<%>
           (interface ()
@@ -779,35 +883,59 @@
                (send item close)
                (close-children item)]
               [else (void)]))
-          (close-children languages-hier-list))
+          (close-children other-languages-hier-list)
+          (close-children teaching-languages-hier-list))
         
         ;; open-current-language : -> void
         ;; opens the tabs that lead to the current language
         ;; and selects the current language
         (define (open-current-language)
+          
+          ;; set the initial selection in the hierlists
+          (let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)])
+            (when hier-default
+              (select-a-language-in-hierlist other-languages-hier-list hier-default)))
+          (let ([hier-default (preferences:get 'drracket:language-dialog:teaching-hierlist-default)])
+            (when hier-default
+              (select-a-language-in-hierlist teaching-languages-hier-list (cdr hier-default))))
+          
+          (send languages-hier-list-panel change-children
+              (λ (l)
+                (list ellipsis-spacer-panel ellipsis-message)))
+          
           (cond
             [(not (and language-to-show settings-to-show))
              (no-language-selected)]
             [(is-a? language-to-show drracket:module-language:module-language<%>)
-             (let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)])
-               (when hier-default
-                 (select-a-language-in-hierlist hier-default)))
              ;; the above changes the radio button selections, so do it before calling module-language-selected
              (module-language-selected)]
             [else
-             (send languages-hier-list focus) ;; only focus when the module language isn't selected
+             (define position (send language-to-show get-language-position))
+             (cond
+               [(and (pair? position)
+                     (equal? (car position) 
+                             (string-constant teaching-languages)))
+                (select-a-language-in-hierlist teaching-languages-hier-list (cdr position))
+                (send use-teaching-language-rb set-selection 0)
+                (send use-chosen-language-rb set-selection #f)
+                (send teaching-languages-hier-list focus)]
+               [else
+                (send languages-hier-list-panel change-children
+                      (λ (l)
+                        (list languages-hier-list-spacer other-languages-hier-list)))
+                (select-a-language-in-hierlist other-languages-hier-list position)
+                (send use-teaching-language-rb set-selection #f)
                 (send use-chosen-language-rb set-selection 0)
-             (send use-language-in-source-rb set-selection #f)
-             (select-a-language-in-hierlist (send language-to-show get-language-position))]))
+                (send other-languages-hier-list focus)])
+             (send use-language-in-source-rb set-selection #f)]))
         
-        (define (select-a-language-in-hierlist language-position)
+        (define (select-a-language-in-hierlist hier-list language-position)
           (cond
             [(null? (cdr language-position))
              ;; nothing to open here
-             (send (car (send languages-hier-list get-items)) select #t)
-             (void)]
+             (send (car (send hier-list get-items)) select #t)]
             [else
-             (let loop ([hi languages-hier-list]
+             (let loop ([hi hier-list]
                         
                         ;; skip the first position, since it is flattened into the dialog
                         [first-pos (cadr language-position)]
@@ -819,8 +947,6 @@
                               (send hi get-items))])
                  (cond
                    [(null? matching-children) 
-                    ;; just give up here. probably this means that a bad preference was saved 
-                    ;; and we're being called from the module-language case in 'open-current-language'
                     (void)]
                    [else
                     (let ([child (car matching-children)])
@@ -828,8 +954,9 @@
                         [(null? position)
                          (send child select #t)]
                         [else
+                         (when (is-a? child hierarchical-list-compound-item<%>) ;; test can fail when prefs are bad
                            (send child open)
-                         (loop child (car position) (cdr position))]))])))]))
+                           (loop child (car position) (cdr position)))]))])))]))
         
         ;; docs-callback : -> void
         (define (docs-callback)
@@ -901,11 +1028,9 @@
         
         (send revert-to-defaults-outer-panel stretchable-width #f)
         (send revert-to-defaults-outer-panel stretchable-height #f)
-        (send outermost-panel set-alignment 'center 'center)
         
         (for-each add-language-to-dialog languages)
-        (send languages-hier-list sort 
-              (λ (x y)
+        (define (hier-list-sort-predicate x y)
           (cond
             [(and (x . is-a? . second-number<%>)
                   (y . is-a? . second-number<%>))
@@ -936,11 +1061,14 @@
             [(and (x . is-a? . number<%>)
                   (y . is-a? . number<%>))
              (< (send x get-number) (send y get-number))]
-                  [else #f])))
+            [else #f]))
+        (send other-languages-hier-list sort hier-list-sort-predicate)
+        (send teaching-languages-hier-list sort hier-list-sort-predicate)
         
         ;; remove the newline at the front of the first inlined category (if there)
         ;; it won't be there if the module language is at the top.
-        (let ([t (send (car (send languages-hier-list get-items)) get-editor)])
+        (for ([hier-list (in-list (list other-languages-hier-list teaching-languages-hier-list))])
+          (define t (send (car (send hier-list get-items)) get-editor))
           (when (equal? "\n" (send t get-text 0 1))
             (send t delete 0 1)))
         
@@ -949,15 +1077,21 @@
               (λ (l)
                 (list details-panel)))
         
-        (send languages-hier-list stretchable-width #t)
-        (send languages-hier-list stretchable-height #t)
-        (send languages-hier-list accept-tab-focus #t)
-        (send languages-hier-list allow-tab-exit #t)
+        (define (config-hier-list hier-list) 
+          (send hier-list stretchable-width #t)
+          (send hier-list stretchable-height #t)
+          (send hier-list accept-tab-focus #t)
+          (send hier-list allow-tab-exit #t))
+        (config-hier-list other-languages-hier-list)
+        (config-hier-list teaching-languages-hier-list)
         (send parent reflow-container)
         (close-all-languages)
         (open-current-language)
-        (send languages-hier-list min-client-width (text-width (send languages-hier-list get-editor)))
-        (send languages-hier-list min-client-height (text-height (send languages-hier-list get-editor)))
+        (define (set-min-sizes hier-list)
+          (send hier-list min-client-width (text-width (send hier-list get-editor)))
+          (send hier-list min-client-height (text-height (send hier-list get-editor))))
+        (set-min-sizes other-languages-hier-list)
+        (set-min-sizes teaching-languages-hier-list)
         (when details-shown?
           (do-construct-details))
         (update-show/hide-details)
@@ -979,7 +1113,14 @@
                          (use-language-in-source-rb-callback)
                          #t)
                   #f)]
-             [(#\c)
+             [(#\t)
+              (if (mouse-event-uses-shortcut-prefix? evt)
+                  (begin 
+                    (send use-teaching-language-rb set-selection 0)
+                    (use-teaching-language-rb-callback)
+                    #t)
+                  #f)]
+             [(#\o)
               (if (mouse-event-uses-shortcut-prefix? evt)
                   (begin 
                     (send use-chosen-language-rb set-selection 0)
@@ -988,21 +1129,20 @@
                   #f)]
              [else #f])))))
     
-    (define (add-discussion p)
-      (let* ([t (new text:standard-style-list%)]
-             [c (new editor-canvas%
+    (define (add-discussion p definitions-text use-language-in-source-rb-callback)
+      (define t (new (text:hide-caret/selection-mixin text:standard-style-list%)))
+      (define c (new editor-canvas%
                      [stretchable-width #t]
                      [horizontal-inset 0]
                      [vertical-inset 0]
                      [parent p]
                      [style '(no-border no-vscroll no-hscroll transparent)]
-                     [editor t])])
+                     [editor t]))
       (send t set-styles-sticky #f)
       (send t set-autowrap-bitmap #f)
-        (let* ([size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))]
-               [do-insert
-                (λ (str tt-style?)
-                  (let ([before (send t last-position)])
+      (define size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size)))
+      (define (do-insert str tt-style?)
+        (define before (send t last-position))
         (send t insert str before before)
         (cond
           [tt-style?
@@ -1013,31 +1153,175 @@
            (send t change-style 
                  (send (send t get-style-list) basic-style)
                  before (send t last-position))])
-                    (send t change-style size-sd before (send t last-position))))])
+        (send t change-style size-sd before (send t last-position)))
       (when (send normal-control-font get-size-in-pixels)
         (send size-sd set-size-in-pixels-on #t))
-          (let loop ([strs (regexp-split #rx"#lang" sc-lang-in-source-discussion)])
+      (let loop ([strs (regexp-split #rx"#lang" (string-constant racket-language-discussion))])
         (do-insert (car strs) #f)
         (unless (null? (cdr strs))
           (do-insert "#lang" #t)
-              (loop (cdr strs)))))
-        (send t hide-caret #t)
+          (loop (cdr strs))))
       
+      (define xref-chan (make-channel))
+      (thread
+       (λ ()
+         (define xref (load-collections-xref))
+         (let loop ()
+           (channel-put xref-chan xref)
+           (loop))))
+      
+      (define spacer-snips '())
+      (define spacer-poses '())
+      
+      (for ([lang (in-list '(racket racket/base typed/racket scribble/base))])
+        (define the-lang-line (format "#lang ~a" lang))
+        (do-insert "  " #t)
+        (define before-lang (send t last-position))
+        (do-insert the-lang-line #t)
+        (define after-lang (send t last-position))
+        (define spacer (new spacer-snip%))
+        (define spacer-pos (send t last-position))
+        (set! spacer-snips (cons spacer spacer-snips))
+        (set! spacer-poses (cons spacer-pos spacer-poses))
+        (send t insert spacer spacer-pos spacer-pos)
+        (do-insert "  [" #f)
+        (define before-docs (send t last-position))
+        (do-insert "docs" #f)
+        (define after-docs (send t last-position))
+        (do-insert "]\n" #f)
+        (send t set-clickback before-lang after-lang
+              (λ (t start end)
+                (use-language-in-source-rb-callback)
+                (define-values (current-line-start current-line-end) 
+                  (if definitions-text
+                      (find-language-position definitions-text)
+                      (values #f #f)))
+                (define existing-lang-line (and current-line-start
+                                                (send definitions-text get-text current-line-start current-line-end)))
+                (case (message-box/custom
+                       (string-constant drscheme)
+                       (string-append
+                        (string-constant racket-dialect-in-buffer-message)
+                        "\n\n"
+                        (cond
+                          [(and existing-lang-line
+                                (equal? existing-lang-line the-lang-line))
+                           (format (string-constant racket-dialect-already-same-#lang-line) 
+                                   existing-lang-line)]
+                          [existing-lang-line
+                           (format (string-constant racket-dialect-replace-#lang-line) 
+                                   existing-lang-line
+                                   the-lang-line)]
+                          [else
+                           (format (string-constant racket-dialect-add-new-#lang-line) the-lang-line)]))
+                       (cond
+                         [(and existing-lang-line
+                               (equal? existing-lang-line the-lang-line))
+                          (string-constant ok)]
+                         [existing-lang-line
+                          (string-constant replace-#lang-line)]
+                         [else
+                          (string-constant add-#lang-line)])
+                       (and (not (equal? existing-lang-line the-lang-line))
+                            (string-constant cancel))
+                       #f #f
+                       '(default=1))
+                  [(1) 
+                   (cond
+                     [current-line-start
+                      (send definitions-text begin-edit-sequence)
+                      (send definitions-text delete current-line-start current-line-end)
+                      (send definitions-text insert the-lang-line current-line-start current-line-start)
+                      (send definitions-text end-edit-sequence)]
+                     [else
+                      (send definitions-text begin-edit-sequence)
+                      (send definitions-text insert "\n" 0 0)
+                      (send definitions-text insert the-lang-line 0 0)
+                      (send definitions-text end-edit-sequence)])]
+                  [else (void)])))
+        (send t set-clickback before-docs after-docs 
+              (λ (t start end)
+                (define-values (path tag) (xref-tag->path+anchor (channel-get xref-chan) `(mod-path ,(symbol->string lang))))
+                (define url (path->url path))
+                (define url2 (if tag
+                                 (make-url (url-scheme url)
+                                           (url-user url)
+                                           (url-host url)
+                                           (url-port url)
+                                           (url-path-absolute? url)
+                                           (url-path url)
+                                           (url-query url)
+                                           tag)
+                                 url))
+                (send-url (url->string url2)))))
+      
+      (do-insert (string-constant racket-language-discussion-end) #f)
+      
+      (define kmp (send t set-keymap (keymap:get-editor)))
+      
+      (send (send c get-parent) reflow-container)
+      
+      (define xb (box 0))
+      (define max-spacer-pos
+        (for/fold ([m 0]) ([spacer-pos (in-list spacer-poses)])
+          (send t position-location spacer-pos xb #f)
+          (max m (unbox xb))))
+      (for ([spacer-pos (in-list spacer-poses)]
+            [spacer-snip (in-list spacer-snips)])
+        (send t position-location spacer-pos xb #f)
+        (send spacer-snip set-width (- max-spacer-pos (unbox xb))))
+      
+      (send t hide-caret #t)
       (send t auto-wrap #t)
       (send t lock #t)
       (send c accept-tab-focus #f)
       (send c allow-tab-exit #t)
-        c))
+
+      c)
+    
+    (define (find-language-position definitions-text)
+      (define prt (open-input-text-editor definitions-text))
+      (port-count-lines! prt)
+      (define l (with-handlers ((exn:fail? (λ (x) #f)))
+                  (read-language prt)))
+      (cond
+        [l
+         (define-values (line col pos) (port-next-location prt))
+         (define hash-lang-start (send definitions-text find-string "#lang" 'backward pos 0 #f))
+         (if hash-lang-start
+             (values hash-lang-start (- pos 1))
+             (values #f #f))]
+        [else
+         (values #f #f)]))
+    
+    (define spacer-snip%
+      (class snip%
+        (inherit get-admin)
+        (define width 0)
+        (define/public (set-width w) 
+          (set! width w)
+          (define admin (get-admin))
+          (when admin 
+            (send admin resized this #t)))
+        (define/override (get-text [start 0] [end 'eof] [flattened? #f] [force-cr? #f])
+          "")
+        (define/override (get-extent dc x y wb hb db ab lb sp)
+          (super get-extent dc x y wb hb db ab lb sp)
+          (when (box? wb) (set-box! wb width)))
+        (super-new)))
+    (define spacer-sc (new snip-class%))
+    (send spacer-sc set-classname "drracket:spacer-snipclass")
+    (send spacer-sc set-version 0)
+    (send (get-the-snip-class-list) add spacer-sc)
     
     (define (size-discussion-canvas canvas)
-      (let ([t (send canvas get-editor)])
-        
-        (let ([by (box 0)])
+      (define t (send canvas get-editor))
+      (define by (box 0))
       (send t position-location 
             (send t line-end-position (send t last-line))
             #f
             by)
-          (send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24)))))
+      (send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24)))
     
     (define section-style-delta (make-object style-delta% 'change-bold))
     (send section-style-delta set-delta-foreground "medium blue")
@@ -1178,7 +1462,7 @@
               #f
               #f
               #t)
-        (+ 10 ;; upper bound on some platform specific space I don't know how to get.
+        (+ 16 ;; upper bound on some space I don't know how to get.
            (floor (inexact->exact (unbox y-box))))))
     
 

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

@@ -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,15 +147,17 @@
       
       (inherit get-language-name)
       (define/public (get-users-language-name defs-text)
-        (let* ([defs-port (open-input-text-editor defs-text)]
-               [read-successfully?
+        (define defs-port (open-input-text-editor defs-text))
+        (port-count-lines! defs-port)
+        (define read-successfully?
           (with-handlers ((exn:fail? (λ (x) #f)))
             (read-language defs-port (λ () #f))
-                  #t)])
+            #t))
         (cond
           [read-successfully?
-             (let* ([str (send defs-text get-text 0 (file-position defs-port))]
-                    [pos (regexp-match-positions #rx"#(?:!|lang )" str)])
+           (define-values (_line _col port-pos) (port-next-location defs-port))
+           (define str (send defs-text get-text 0 (- port-pos 1)))
+           (define pos (regexp-match-positions #rx"#(?:!|lang )" str))
            (cond
              [(not pos)
               (get-language-name)]
@@ -165,9 +169,9 @@
               ;; so be it.
               (regexp-replace* #rx"[\r\n]+"
                                (substring str (cdr (car pos)) (string-length str))
-                                   " ")]))]
+                               " ")])]
           [else
-             (get-language-name)])))
+           (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
@@ -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)
+                            (unless (gui-event? (vector-ref logged 2))
                               (log-message user-logger 
                                            (vector-ref logged 0)
                                            (vector-ref logged 1)
-                                         (vector-ref logged 2))
+                                           (vector-ref logged 2)))
                             (loop)))
                          (handle-evt
                           user-evt
                           (λ (vec)
+                            (unless (gui-event? (vector-ref vec 2))
                               (parameterize ([current-eventspace drracket:init:system-eventspace])
-                              (queue-callback (λ () (new-log-message vec))))
+                                (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
-                                  ,end-text ,end-pos-left ,end-pos-right
+            [`#(syncheck:add-arrow ,start-pos-left ,start-pos-right
+                                   ,end-pos-left ,end-pos-right
                                    ,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) 
+       (log-timeline
+        "replace-compile-comp-trace"
+        (send (send (send defs-text get-canvas) get-top-level-window)
               replay-compile-comp-trace
               defs-text 
-                              val)))))
+              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)
-      (define/override (name . args)
-        (set! trace (cons (cons 'name args) trace))))
     
-    ; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up
-    (log syncheck:add-mouse-over-status)
-    (log syncheck:add-arrow)
-    (log syncheck:add-tail-arrow)
-    (log syncheck:add-background-color)
-    (log syncheck:add-require-open-menu)
-    (log syncheck:add-docs-menu)
-    (log syncheck:add-jump-to-definition)
+    ;; send over the non _ variables in the message to the main drracket place
+    (define-syntax (log stx)
+      (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:add-arrow
+         _start-text start-pos-left start-pos-right
+         _end-text end-pos-left end-pos-right
+         actual? level)
+    (log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos)
+    (log syncheck:add-mouse-over-status _text pos-left pos-right str)
+    (log syncheck:add-background-color _text color start fin)
+    (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)
-                        trace)))
+      (add-to-trace (vector 'syncheck:add-rename-menu id-as-sym (map cdr to-be-renamed/poss) remote id)))
     
     (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))
+               (define max-to-send-at-once 30)
+               (let loop ([loc-lst loc-lst]
+                          [len (length loc-lst)])
+                 (cond
+                   [(<= len max-to-send-at-once)
                     (send defs-text syncheck:add-rename-menu
                           id-as-sym
                           loc-lst
-                     name-dup?)))))))
+                          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/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/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/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/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
-         mzlib/thread
-         mred
+(require racket/class
+         racket/gui/base
          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
-    (define colorings null)
-    ;; The coroutine object for tokenizing the buffer
-    (define tok-cor #f)
-    ;; The editor revision when tok-cor was created
-    (define rev #f)
+    ;; The editor revision when the last coloring was started
+    (define revision-when-started-parsing #f)
 
+    ;; The editor revision when after the last edit to the buffer
+    (define revision-after-last-edit #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)
-      (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 '()))
+      (set! revision-when-started-parsing #f))
     
     ;; Discard extra tokens at the first of invalid-tokens
     (define/private (sync-invalid ls)
@@ -302,25 +289,49 @@ 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)
-      (enable-suspend #f)
+    (define/private (re-tokenize-move-to-next-ls start-time did-something?)
+      (cond
+        [(null? re-tokenize-lses) 
+         ;; done: return #t
+         #t]
+        [else
+         (define ls (car re-tokenize-lses))
+         (set! re-tokenize-lses (cdr re-tokenize-lses))
+         (define in
+           (open-input-text-editor this 
+                                   (lexer-state-current-pos ls)
+                                   (lexer-state-end-pos ls)
+                                   (λ (x) #f)))
+         (port-count-lines! in)
+         (continue-re-tokenize start-time did-something? ls in
+                               (lexer-state-current-pos ls)
+                               (lexer-state-current-lexer-mode ls))]))
+    
+    (define re-tokenize-lses #f)
+    
+    (define/private (continue-re-tokenize start-time did-something? ls in in-start-pos lexer-mode)
+      (cond
+        [(and did-something? ((+ start-time 20.0) . <= . (current-inexact-milliseconds)))
+         #f]
+        [else
          ;(define-values (_line1 _col1 pos-before) (port-next-location in))
          (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) 
-        (get-token in in-start-pos in-lexer-mode))
+           (get-token in in-start-pos lexer-mode))
          ;(define-values (_line2 _col2 pos-after) (port-next-location in))
-      (enable-suspend #t)
-      (unless (eq? 'eof type)
+         (cond
+           [(eq? 'eof type) 
+            (re-tokenize-move-to-next-ls start-time #t)]
+           [else
             (unless (exact-nonnegative-integer? new-token-start)
               (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start))
             (unless (exact-nonnegative-integer? new-token-end)
               (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end))
             (unless (exact-nonnegative-integer? backup-delta)
               (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta))
-        (unless (0 . < . (- new-token-end new-token-start))
-          (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))
-        (enable-suspend #f)
-        #; (printf "~s at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start))
-                   (+ in-start-pos (sub1 new-token-end)))
+            (unless (new-token-start . < . new-token-end)
+              (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))
             (let ((len (- new-token-end new-token-start)))
               #;
               (unless (= len (- pos-after pos-before))
@@ -352,10 +363,9 @@ added get-regions
                  (insert-last! (lexer-state-tokens ls)
                                (lexer-state-invalid-tokens ls))
                  (set-lexer-state-invalid-tokens-start! ls +inf.0)
-             (enable-suspend #t)]
+                 (re-tokenize-move-to-next-ls start-time #t)]
                 [else
-             (enable-suspend #t)
-             (re-tokenize ls in in-start-pos new-lexer-mode enable-suspend)]))))
+                 (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)))
-                                           colorings))]
+                     (add-coloring color (+ sp lp) (+ sp (string-length str)))]
                     [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))
-                                            (vector misspelled-color (+ pos err-start) (+ pos err-start err-len))
-                                            colorings))
+                     (add-coloring misspelled-color (+ pos err-start) (+ pos err-start err-len))
+                     (add-coloring color (+ pos lp) (+ pos err-start))
                      (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)
+                         (cond
+                           [(or (send evt get-alt-down)
+                                (send evt get-control-down))
+                            (dynamic-require 'framework/private/follow-log #f)]
+                           [else
                             (collect-garbage)
-                         (update-memory-text))]
+                            (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%)])

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/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)])))
 
 
@@ -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/contract*)
+(provide provide/contract*)

collects/frtime/core/dv.rkt

@@ -1,5 +1,7 @@
-#lang racket
-(require "contract.rkt")
+#lang racket/base
+
+(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
-(require "match.rkt"
+#lang racket/base
+
+(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
-(require "contract.rkt"
+#lang racket/base
+
+(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
-(require "dv.rkt"
+#lang racket/base
+
+(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
-(require "contract.rkt"
+#lang racket/base
+
+(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
-(require "match.rkt"
+#lang racket/base
+
+(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
-(require setup/link)
+#lang racket/base
 
+(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
-  (lambda ()
-    (start-developing-collection dev-path install-path)))
+(define (start-developing-frtime)
+  (start-developing-collection dev-path install-path))
 
 
-(define stop-developing-frtime
-  (lambda ()
-    (stop-developing-collection dev-path install-path)))
+(define (stop-developing-frtime)
+  (stop-developing-collection dev-path install-path))
 
-(define start-developing-collection
-  (lambda (dev-coll-path install-coll-path)
+(define (start-developing-collection dev-coll-path install-coll-path)
   (links install-coll-path #:remove? #t)
-    (links dev-coll-path)))
+  (links dev-coll-path))
 
-(define stop-developing-collection
-  (lambda (dev-coll-path install-coll-path)
-    (start-developing-collection install-coll-path dev-coll-path)))
+(define (stop-developing-collection dev-coll-path install-coll-path)
+  (start-developing-collection install-coll-path dev-coll-path))

collects/frtime/frlibs/date.rkt

@@ -1,6 +1,7 @@
-#lang racket
-(require (rename-in (only-in frtime/frtime provide) 
-                    [provide frtime:provide]))
+#lang racket/base
+
+(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,6 +1,10 @@
-#lang racket
-(require rackunit 
+#lang racket/base
+
+(require racket/list
+         racket/contract
+         ;; rackunit
          "constants.rkt")
+
 (provide (struct-out point)
          (struct-out node)
          (struct-out drawable-node)

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/paint-by-numbers/solve.rkt

@@ -1,5 +1,3 @@
-
-
 (module solve mzscheme
   
   (require mzlib/list
@@ -14,7 +12,7 @@
                                void)])
   
   (define (solve row-info col-info set-entry setup-progress)
-    (local (
+    (local [
             (define (pause) '(sleep 1/16))
             
             ; all test cases are commented out.
@@ -668,7 +666,7 @@
                                   (outer-loop board (next-threshold skip-threshold) row-tries col-tries)
                                   (outer-loop board skip-threshold row-tries col-tries)))))))))
 
-	    )
+            ]
       (local-solve row-info col-info)
       )))
 

collects/gui-debugger/debug-tool.rkt

@@ -1,14 +1,14 @@
-#lang racket
+#lang racket/base
 
 ;; DrRacket's debugging tool
 
-(require mzlib/etc
-         mzlib/list
-         mzlib/class
-         mzlib/unit
-         mzlib/contract
-         mred
-         mzlib/match
+(require racket/function
+         racket/list
+         racket/class
+         racket/unit
+         racket/contract
+         racket/match
+         racket/gui
          drscheme/tool
          "marks.rkt"
          mrlib/switchable-button
@@ -20,7 +20,8 @@
          string-constants
          lang/debugger-language-interface
          images/compile-time
-         (for-syntax racket/class
+         (for-syntax racket/base
+                     racket/class
                      racket/draw
                      images/icons/arrow
                      images/icons/control
@@ -112,7 +113,7 @@
     ;; (<form>)                   => (<form>)
     ;; (<form> <arg1> ... <argn>) => (<form> ...)
     (define trim-expr-str
-      (opt-lambda (str [len 10])
+      (lambda (str [len 10])
         (let* ([strlen (string-length str)]
                [starts-with-paren (and (> strlen 0)
                                        (char=? (string-ref str 0) #\())]
@@ -157,7 +158,7 @@
         [else v]))
     
     (define filename->defs
-      (opt-lambda (source [default #f])
+      (lambda (source [default #f])
         (let/ec k
           (cond
             [(is-a? source editor<%>) source]
@@ -985,7 +986,7 @@
                           (rest frames))))))
 
         (define/public suspend-gui
-          (opt-lambda (frames status [switch-tabs? #f] [already-stopped? #f])
+          (lambda (frames status [switch-tabs? #f] [already-stopped? #f])
             (let ([top-of-stack? (zero? (get-frame-num))]
                   [status-message (send (get-frame) get-status-message)])
               (set! want-suspend-on-break? #f)
@@ -1052,7 +1053,7 @@
         
         (define/public suspend
           ;; ==called from user thread==
-          (opt-lambda (break-handler frames [status #f])
+          (lambda (break-handler frames [status #f])
             ;; suspend-sema ensures that we allow only one suspended thread
             ;;  at a time
             (cond

collects/honu/core/api.rkt

@@ -5,10 +5,12 @@
 (require "private/syntax.rkt"
          "private/literals.rkt"
          (for-syntax "private/compile.rkt"
+                     "private/syntax.rkt"
                      "private/parse2.rkt"))
 (provide define-honu-syntax
          define-literal
          (for-syntax racket-syntax
                      honu-expression
+                     honu-syntax
                      honu-body
                      parse-all))

collects/honu/core/main.rkt

@@ -9,6 +9,7 @@
                        "private/macro2.rkt"
                        "private/class.rkt"
                        "private/operator.rkt"
+                       "private/syntax.rkt"
                        (prefix-in literal: "private/literals.rkt")
                        (prefix-in syntax-parse: syntax/parse)
                        (prefix-in racket: racket/base)
@@ -35,6 +36,7 @@
                                    [honu-while while]
                                    [honu-macro macro]
                                    [honu-phase phase]
+                                   [honu-racket racket]
                                    [honu-primitive-macro primitive_macro]
                                    [honu-pattern pattern]
                                    [racket:read-line readLine]

collects/honu/core/private/macro2.rkt

@@ -7,11 +7,11 @@
                      racket/syntax
                      "template.rkt"
                      "literals.rkt"
+                     "syntax.rkt"
                      (prefix-in phase1: "parse2.rkt")
                      "debug.rkt"
                      (prefix-in phase1: "compile.rkt")
                      "util.rkt"
-                     (prefix-in syntax: syntax/parse/private/residual-ct)
                      racket/base)
          (for-meta 2 syntax/parse
                      racket/base
@@ -28,6 +28,9 @@
          "literals.rkt"
          "syntax.rkt"
          "debug.rkt"
+
+         (for-meta 0 "template.rkt" syntax/stx)
+
          (for-meta -1 "literals.rkt" "compile.rkt" "parse2.rkt" "parse-helper.rkt")
          #;
          (for-syntax "honu-typed-scheme.rkt")
@@ -37,14 +40,30 @@
   (require syntax/parse
            "literals.rkt"
            "debug.rkt"
+           "util.rkt"
+           (prefix-in syntax: syntax/parse/private/residual-ct)
            racket/syntax
            racket/set
+           racket/match
+           (for-syntax syntax/parse
+                       racket/base
+                       racket/syntax)
            (for-template racket/base
                          syntax/parse))
 
     (provide (all-defined-out))
     (struct pattern-variable [name original depth class] #:transparent)
 
+    ;; given the name of an object and some fields this macro defines
+    ;; name.field for each of the fields
+    (define-syntax (define-struct-fields stx)
+      (syntax-parse stx
+        [(_ name type (field ...))
+         (with-syntax ([(field* ...)
+                        (for/list ([field (syntax->list #'(field ...))])
+                          (format-id field "~a.~a" (syntax-e #'name) (syntax-e field)))])
+           #'(match-define (struct type (field* ...)) name))]))
+
     ;; makes a syntax object with the right number of nested ellipses patterns
     (define (pattern-variable->syntax variable)
       (debug 2 "Convert pattern variable to syntax ~a location ~a\n" variable (pattern-variable-original variable))
@@ -126,6 +145,83 @@
     (define variables (find (reverse-syntax original-pattern)))
     (debug 2 "Found variables ~a\n" variables)
     (for/list ([x variables]) x))
+
+  ;; variable is the original pattern variable, like 'foo'
+  ;; and new-name is the new generated name, 'temp1'
+  ;; we want to bind all the attributes from temp1 to foo, so if temp1 has
+  ;;   temp1_a
+  ;;   temp1_b ...
+  ;;
+  ;; we want to bind
+  ;;   foo_a temp_a
+  ;;   (foo_b ...) (temp_b ...)
+  (define (bind-attributes variable new-name)
+    (debug "Syntax class of ~a is ~a at ~a\n"
+           (pattern-variable-class variable)
+           (syntax-local-value (pattern-variable-class variable) (lambda () #f))
+           (syntax-local-phase-level))
+    (define attributes
+      (let ([syntax-class (syntax-local-value (pattern-variable-class variable))])
+        (for/list ([attribute (syntax:stxclass-attrs syntax-class)])
+          (pattern-variable (syntax:attr-name attribute)
+                            (pattern-variable-original variable)
+                            (+ (pattern-variable-depth variable)
+                               (syntax:attr-depth attribute))
+                            #f))))
+
+    (define (mirror-attribute attribute)
+      (debug "Mirror attribute ~a\n" attribute)
+      (define-struct-fields attribute pattern-variable
+                            (name original depth class))
+      ;; create a new pattern variable with a syntax object that uses
+      ;; the given lexical context and whose name is prefix_suffix
+      (define (create lexical prefix suffix)
+        (pattern-variable->syntax
+          (pattern-variable (format-id lexical "~a_~a" prefix suffix)
+                            attribute.original attribute.depth attribute.class)))
+      (define-struct-fields variable pattern-variable
+                            (name original depth class))
+      (debug "Bind attributes ~a ~a\n" variable.name attribute.name)
+      (with-syntax ([bind-attribute
+                      #;
+                      (create name (syntax-e name) name)
+                      (pattern-variable->syntax
+                        (pattern-variable (format-id variable.name "~a_~a"
+                                                     (syntax-e variable.name)
+                                                     attribute.name)
+                                          attribute.original
+                                          attribute.depth
+                                          attribute.class))]
+                    [new-attribute 
+                      #;
+                      (create new-name new-name name)
+                      (pattern-variable->syntax
+                        (pattern-variable
+                          (format-id new-name "~a_~a"
+                                     new-name
+                                     attribute.name)
+                          attribute.original attribute.depth #f))])
+        (debug "Bind ~a to ~a\n" #'bind-attribute #'new-attribute)
+        #'(#:with bind-attribute #'new-attribute)))
+
+    (for/set ([attribute attributes])
+             (mirror-attribute attribute)))
+
+  ;; returns a set of #:with clauses for syntax-parse that
+  ;; bind all the old variables and their attributes to some new names
+  ;; taking care of ellipses depth
+  (define (pattern-variables+attributes variables use)
+    (for/union ([old variables]
+                [new use])
+               (define-struct-fields old pattern-variable (name original depth class))
+               (with-syntax ([old-syntax (pattern-variable->syntax old)]
+                             [new.result (pattern-variable->syntax
+                                           (pattern-variable (format-id new "~a_result" new)
+                                                             old.original
+                                                             old.depth
+                                                             old.class))])
+                 (set-union (set #'(#:with old-syntax #'new.result))
+                            (bind-attributes old new)))))
   )
 
 (require (for-meta 2 (submod "." analysis)))
@@ -238,34 +334,6 @@
          (syntax #'stuff*))])))
 |#
 
-(provide honu-syntax)
-;; Do any honu-specific expansion here
-(define-honu-syntax honu-syntax
-  (lambda (code)
-    (syntax-parse code #:literal-sets (cruft)
-      #;
-      [(_ (#%parens single) . rest)
-       (define context #'single)
-       (define compressed (compress-dollars #'single))
-       (values
-         (with-syntax ([stuff* (datum->syntax context compressed context context)])
-           (phase1:racket-syntax #'stuff*))
-         #'rest
-         #f)]
-      [(_ (#%parens stuff ...) . rest)
-       (define context (stx-car #'(stuff ...)))
-       (define compressed (compress-dollars #'(stuff ...)))
-       (values
-         (with-syntax ([stuff* (datum->syntax context
-                                              (syntax->list compressed)
-                                              context context)])
-           ;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*))
-           ;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*))
-           (with-syntax ([(out ...) #'stuff*])
-             (phase1:racket-syntax #'stuff*)))
-         #; #'(%racket-expression (parse-stuff stuff ...))
-         #'rest
-         #f)])))
 
 ;; combine syntax objects
 ;; #'(a b) + #'(c d) = #'(a b c d)
@@ -301,20 +369,11 @@
 
 (begin-for-syntax
   (define-syntax (generate-pattern stx)
-
-    ;; given the name of an object and some fields this macro defines
-    ;; name.field for each of the fields
-    (define-syntax (define-struct-fields stx)
     (syntax-parse stx
-        [(_ name type (field ...))
-         (with-syntax ([(field* ...)
-                        (for/list ([field (syntax->list #'(field ...))])
-                          (format-id field "~a.~a" (syntax-e #'name) (syntax-e field)))])
-           #'(match-define (struct type (field* ...)) name))]))
+      [(_ name literals (pattern-stx out-stx) ...)
 
-    (syntax-parse stx
-      [(_ name literals original-pattern maybe-out)
-      (define variables (find-pattern-variables #'original-pattern))
+      (define (make-syntax-class-pattern honu-pattern maybe-out)
+        (define variables (find-pattern-variables honu-pattern))
         (define use (generate-temporaries variables))
         (define mapping (make-hash))
         (for ([old variables]
@@ -327,98 +386,43 @@
                                        (pattern-variable-depth old)
                                        (pattern-variable-class old))))
 
-      ;; variable is the original pattern variable, like 'foo'
-      ;; and new-name is the new generated name, 'temp1'
-      ;; we want to bind all the attributes from temp1 to foo, so if temp1 has
-      ;;   temp1_a
-      ;;   temp1_b ...
-      ;;
-      ;; we want to bind
-      ;;   foo_a temp_a
-      ;;   (foo_b ...) (temp_b ...)
-      (define (bind-attributes variable new-name)
-        (debug "Syntax class of ~a is ~a at ~a\n"
-               (pattern-variable-class variable)
-               (syntax-local-value (pattern-variable-class variable) (lambda () #f))
-               (syntax-local-phase-level))
-        (define attributes
-          (let ([syntax-class (syntax-local-value (pattern-variable-class variable))])
-            (for/list ([attribute (syntax:stxclass-attrs syntax-class)])
-              (pattern-variable (syntax:attr-name attribute)
-                                (pattern-variable-original variable)
-                                (+ (pattern-variable-depth variable)
-                                   (syntax:attr-depth attribute))
-                                #f))))
+        (define withs (pattern-variables+attributes variables use))
+
+        (with-syntax ([(new-pattern ...) (convert-pattern honu-pattern mapping)]
+                      [((withs ...) ...) (set->list withs)]
+                      [(result-with ...) (if (syntax-e maybe-out)
+                                           (with-syntax ([(out ...) maybe-out])
+                                             #'(#:with result (parse-stuff honu-syntax (#%parens out ...))))
+                                           #'(#:with result #'()))])
+          (syntax/loc honu-pattern
+                      [pattern (~seq new-pattern ...)
+                               withs ... ...
+                               result-with ...
+                               ])))
+
+      (define pattern-stuff
+        (for/list ([pattern (syntax->list #'(pattern-stx ...))]
+                   [out (syntax->list #'(out-stx ...))])
+          (make-syntax-class-pattern pattern out)))
 
-        (define (mirror-attribute attribute)
-          (debug "Mirror attribute ~a\n" attribute)
-          ;; create a new pattern variable with a syntax object that uses
-          ;; the given lexical context and whose name is prefix_suffix
-          (define-struct-fields attribute pattern-variable
-                                (name original depth class))
-          (define (create lexical prefix suffix)
-            (pattern-variable->syntax
-              (pattern-variable (format-id lexical "~a_~a" prefix suffix)
-                                attribute.original attribute.depth attribute.class)))
-          (define-struct-fields variable pattern-variable
-                                (name original depth class))
-          (debug "Bind attributes ~a ~a\n" variable.name attribute.name)
-          (with-syntax ([bind-attribute
       #;
-                          (create name (syntax-e name) name)
-                          (pattern-variable->syntax
-                              (pattern-variable (format-id variable.name "~a_~a"
-                                                           (syntax-e variable.name)
-                                                           attribute.name)
-                                                attribute.original
-                                                attribute.depth
-                                                attribute.class))]
-                        [new-attribute 
-                          #;
-                          (create new-name new-name name)
-                          (pattern-variable->syntax
-                                         (pattern-variable
-                                           (format-id new-name "~a_~a"
-                                                      new-name
-                                                      attribute.name)
-                                           attribute.original attribute.depth #f))])
-            (debug "Bind ~a to ~a\n" #'bind-attribute #'new-attribute)
-            #'(#:with bind-attribute #'new-attribute)))
-
-        (for/set ([attribute attributes])
-          (mirror-attribute attribute)))
-
-      (define withs
-        (for/union ([old variables]
-                    [new use])
-          (define-struct-fields old pattern-variable (name original depth class))
-          (with-syntax ([old-syntax (pattern-variable->syntax old)]
-                        [new.result (pattern-variable->syntax
-                                      (pattern-variable (format-id new "~a_result" new)
-                                                        old.original
-                                                        old.depth
-                                                        old.class))])
-            (set-union (set #'(#:with old-syntax #'new.result))
-                       (bind-attributes old new)))))
-
       (debug "With bindings ~a\n" withs)
       (with-syntax ([(literal ...) #'literals]
-                    [(new-pattern ...) (convert-pattern #'original-pattern mapping)]
-                    [((withs ...) ...) (set->list withs)]
-                    [(result-with ...) (if (syntax-e #'maybe-out)
-                                         (with-syntax ([(out ...) #'maybe-out])
-                                           #'(#:with result (out ...)))
-                                         #'(#:with result #'()))])
+                    [(new-pattern ...) pattern-stuff])
+        #;
         (debug "Result with ~a\n" (syntax->datum #'(quote-syntax (result-with ...))))
         (define output
           #'(quote-syntax
               (begin
-                ;; define at phase1 so we can use it
+                ;; define at phase1 so we can use it in a macro
                 (begin-for-syntax
                   (define-literal-set local-literals (literal ...))
                   (define-splicing-syntax-class name
                       #:literal-sets ([cruft #:at name]
                                       [local-literals #:at name])
+                      new-pattern ...
+
+                      #;
                       [pattern (~seq new-pattern ...)
                                withs ... ...
                                result-with ...
@@ -432,10 +436,12 @@
   (lambda (code)
     (syntax-parse code #:literal-sets (cruft)
       [(_ name (#%parens literal ...)
-          (#%braces pattern ...)
-          (~optional (#%braces out ...))
+          (~seq (#%braces original-pattern ...)
+                (~optional (~seq honu-comma maybe-out)
+                           #:defaults ([maybe-out #'#f])))
+          ...
           . rest)
-       (values (with-syntax ([out* (attribute out)])
+       (values
          (phase1:racket-syntax
            (splicing-let-syntax
              ([make (lambda (stx)
@@ -444,9 +450,9 @@
                          (syntax-local-introduce
                            (generate-pattern name
                                              (literal ...)
-                                                   (pattern ...)
-                                                   out*))]))])
-                     (make name))))
+                                             ((original-pattern ...) maybe-out)
+                                             ...))]))])
+             (make name)))
                #'rest
                #f)])))
 
@@ -459,3 +465,30 @@
        (define out
          (phase1:racket-syntax (begin-for-syntax (parse-stuff body ...))))
        (values out #'rest #t)])))
+
+;; not sure this is useful but it lets you write racket syntax expressions
+;; from inside honu. the main issue is all the bindings available
+;; are honu bindings so things like (+ 1 x) wont work.
+(provide honu-racket)
+(define-honu-syntax honu-racket
+  (lambda (code)
+    (define (remove-cruft stx)
+      (syntax-parse stx #:literal-sets (cruft)
+        [(#%parens inside ...)
+         (remove-cruft #'(inside ...))]
+        [(#%braces inside ...)
+         (remove-cruft #'(inside ...))]
+        [(#%brackets inside ...)
+         (remove-cruft #'(inside ...))]
+        [(head rest ...)
+         (with-syntax ([head* (remove-cruft #'head)]
+                       [(rest* ...) (remove-cruft #'(rest ...))])
+           #'(head* rest* ...))]
+        [x #'x]))
+
+    (syntax-parse code #:literal-sets (cruft)
+      [(_ (#%parens stx ...) . rest)
+       (define out
+         (with-syntax ([(stx* ...) (remove-cruft #'(stx ...))])
+           (phase1:racket-syntax (phase0:racket-syntax (stx* ...)))))
+       (values out #'rest #t)])))

collects/honu/core/private/parse2.rkt

@@ -316,7 +316,10 @@
             (do-parse #'(parsed ... rest ...)
                       precedence left current)
             ;; (debug "Remove repeats from ~a\n" #'parsed)
-            (define re-parse (remove-repeats #'parsed)
+            (define re-parse
+              #'parsed
+              #;
+              (remove-repeats #'parsed)
               #;
               (with-syntax ([(x ...) #'parsed])
                 (debug "Properties on parsed ~a\n" (syntax-property-symbol-keys #'parsed))

collects/honu/core/private/syntax.rkt

@@ -1,8 +1,9 @@
-#lang racket
+#lang racket/base
 
 (provide (all-defined-out))
 
-(require (for-syntax syntax/define
+(require (for-syntax racket/base
+                     syntax/define
                      "transformer.rkt"))
 
 #|
@@ -22,3 +23,47 @@
                   [rhs rhs])
       (syntax/loc stx
                  (define-syntax id (make-honu-transformer rhs))))))
+
+;; Do any honu-specific expansion here
+(require (for-syntax
+           "template.rkt" ;; for compress-dollars at phase 1
+           "compile.rkt"
+           "literals.rkt"
+           syntax/stx
+           syntax/parse)
+         "template.rkt") ;; for remove-repeats at phase 0
+(define-honu-syntax honu-syntax
+  (lambda (code)
+    (syntax-parse code #:literal-sets (cruft)
+      #;
+      [(_ (#%parens single) . rest)
+       (define context #'single)
+       (define compressed (compress-dollars #'single))
+       (values
+         (with-syntax ([stuff* (datum->syntax context compressed context context)])
+           (phase1:racket-syntax #'stuff*))
+         #'rest
+         #f)]
+      [(_ (#%parens stuff ...) . rest)
+       (define context (stx-car #'(stuff ...)))
+       (define compressed (compress-dollars #'(stuff ...)))
+       (values
+         (with-syntax ([stuff* (datum->syntax context
+                                              (syntax->list compressed)
+                                              context context)])
+           ;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*))
+           ;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*))
+
+           ;; stuff* will be expanded when this syntax is returned because
+           ;; the whole thing will be
+           ;;   (remove-repeats #'((repeat$ 1) (repeat$ 2)))
+           ;; so remove-repeats will be executed later
+           (racket-syntax
+             (remove-repeats #'stuff*))
+
+           #;
+           (with-syntax ([(out ...) #'stuff*])
+             (phase1:racket-syntax #'stuff*)))
+         #; #'(%racket-expression (parse-stuff stuff ...))
+         #'rest
+         #f)])))

collects/honu/syntax.rkt

@@ -0,0 +1,10 @@
+#lang honu
+
+/* Standard syntax-rules but as a macro-defining form */
+
+provide macro_rules;
+macro macro_rules(){
+  name:identifier (literal ...){ pattern ... }{ template ... }
+} {
+  syntax(macro name (literal ...){ pattern ... }{ syntax(template ...) })
+}

collects/htdp/convert.rkt

@@ -1,4 +1,4 @@
-#lang racket
+#lang racket/base
 
 (require racket/gui)
 

collects/htdp/dir.rkt

@@ -1,4 +1,4 @@
-#lang racket
+#lang racket/base
 
 (provide
  ;; map the directory tree at the given path into a data representation according to model 3 of 

collects/images/icons/style.rkt

@@ -1,10 +1,10 @@
-#lang racket
+#lang racket/base
 
-(require racket/draw unstable/parameter-group
+(require racket/class racket/draw unstable/parameter-group
          racket/contract unstable/latent-contract unstable/latent-contract/defthing
          "../private/flomap.rkt"
          "../private/deep-flomap.rkt"
-         (for-syntax syntax/parse))
+         (for-syntax racket/base syntax/parse))
 
 (provide light-metal-icon-color
          metal-icon-color

collects/images/scribblings/icons.scrbl

@@ -475,3 +475,6 @@ Icons for the Debugger. The @racket[small-debugger-icon] is used when the toolba
 @doc-apply[small-macro-stepper-hash-color]{
 Constants used within @racketmodname[images/icons/tool].
 }
+
+
+@close-eval[icons-eval]

collects/images/scribblings/logos.scrbl

@@ -38,3 +38,6 @@ Returns the algebraic stepper logo.
 Returns the macro stepper logo.
 @examples[#:eval logos-eval (macro-stepper-logo)]
 }
+
+
+@close-eval[logos-eval]

collects/lang/private/intermediate-funs.rkt

@@ -173,7 +173,7 @@
 		  (apply max a-list)
 		  ]
     }
-    @defproc[(compose [f (X -> Y)] [g (Y -> Z)]) (X -> Z)]{
+    @defproc[(compose [f (Y -> Z)] [g (X -> Y)]) (X -> Z)]{
     Composes a sequence of procedures into a single procedure:
     @codeblock{(compose f g) = (lambda (x) (f (g x)))}
     @interaction[#:eval (isl)

collects/lang/private/sl-eval.rkt

@@ -1,6 +1,7 @@
-#lang racket
+#lang racket/base
 
 (require teachpack/2htdp/scribblings/img-eval
+         racket/pretty
          racket/sandbox
          mzlib/pconvert
          file/convertible

collects/lazy/lazy-tool.rkt

@@ -1,6 +1,8 @@
-#lang racket
+#lang racket/base
 
-(require string-constants
+(require racket/unit
+         racket/class
+         string-constants
          drracket/tool
          lang/stepper-language-interface)
 
@@ -11,7 +13,6 @@
     (import drracket:tool^)
     (export drracket:tool-exports^)
 
-
     (define (stepper-settings-language %)
       (if (implementation? % stepper-language<%>)
           (class* % (stepper-language<%>)
@@ -51,7 +52,6 @@
 ;              (drracket:language:simple-settings->vector (default-settings))))
         (super-new)))
 
-      
     (define (phase1) (void))
 
     ;; phase2 : -> void