Merge branch 'master' of pltgit:plt

collects/2htdp/private/checked-cell.rkt

@@ -68,9 +68,14 @@
           (tp-error 'check-with "the test function ~a is expected to return a boolean, but it returned ~v" 
                     (object-name ok?) b))
         (unless b
+          (define check-with-name 
+            (let ([n (symbol->string (object-name ok?))])
+              (if (regexp-match "check-with" n)
+                  "handler"
+                  n)))
           (tp-error 'check-with "~a ~a ~v, which fails to pass check-with's ~a test"
                     tag (if say-evaluated-to "evaluated to" "returned") 
-                    nw (object-name ok?)))
+                    nw check-with-name))
         nw))
     
     ;; Symbol Any -> Void 

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

@@ -86,7 +86,10 @@
                [(null? spec) #false]
                [(or (free-identifier=? (caar spec) kw)
                     (free-identifier=? (caar spec) kw-alt))
-                (syntax->list (cdar spec))]
+                ; (syntax->list (cdar spec))
+                (for/list ([i (syntax->list (cdar spec))])
+                  (define n  (string->symbol (format "~a handler" (syntax-e (caar spec)))))
+                  (syntax-property  i 'inferred-name n))]
                [else (loop (cdr spec))])))
          (if r ((third s) r) (fourth s)))
        Spec))

collects/2htdp/tests/key-error.rkt

@@ -18,3 +18,18 @@
                              (unless (and hdl (cons? (regexp-match "on-tick" (second hdl))))
                                (error 'test "expected: \"on-tick\", actual: ~e" (second hdl))))))
   (main))
+
+
+(define (my-fun x) "hi")
+
+(with-handlers ((exn:fail? 
+                 (lambda (x) 
+                   (define msg (exn-message x))
+                   (define hdl (regexp-match "check-with's handler test" msg))
+                   (unless hdl
+                     (error 'test "expected: \"check-with's handler test, error says: ~e" msg)))))
+  (big-bang 0 
+            [to-draw (lambda (x) (circle 1 'solid 'red))]
+            [on-tick (lambda (x) (my-fun x))]
+            [check-with (lambda (x) (number? x))])
+  (raise `(bad "must fail")))

collects/2htdp/xtest

@@ -10,6 +10,7 @@ run() {
 
 cd tests 
 
+run key-error.rkt
 run bad-draw.rkt
 run error-in-tick.rkt
 run error-in-draw.rkt
@@ -34,3 +35,4 @@ run record-stop-when.rkt
 run stop-when-crash.rkt
 run on-tick-universe-with-limit.rkt
 run on-tick-with-limit.rkt
+

collects/compiler/cm.rkt

@@ -675,43 +675,128 @@
 
 (define (make-compile-lock)
   (define-values (manager-side-chan build-side-chan) (place-channel))
-  (struct pending (response-chan bytes))
+  (struct pending (response-chan zo-path died-chan-manager-side) #:transparent)
+  (struct running (zo-path died-chan-manager-side) #:transparent)
   
   (define currently-locked-files (make-hash))
   (define pending-requests '())
+  (define running-compiles '())
   
   (thread
    (λ ()
      (let loop ()
-       (define req (place-channel-get manager-side-chan))
-       (define command (list-ref req 0))
-       (define bytes (list-ref req 1))
-       (define response-manager-side (list-ref req 2))
-       (cond
-         [(eq? command 'lock)
-          (cond
-            [(hash-ref currently-locked-files bytes #f)
-             (set! pending-requests (cons (pending response-manager-side bytes)
-                                          pending-requests))
-             (loop)]
-            [else
-             (hash-set! currently-locked-files bytes #t)
-             (place-channel-put response-manager-side #t)
-             (loop)])]
-         [(eq? command 'unlock)
-          (define (same-bytes? pending) (equal? (pending-bytes pending) bytes))
-          (define to-unlock (filter same-bytes? pending-requests))
-          (set! pending-requests (filter (compose not same-bytes?) pending-requests))
-          (for ([pending (in-list to-unlock)])
-            (place-channel-put (pending-response-chan pending) #f))
-          (hash-remove! currently-locked-files bytes)
-          (loop)]))))
+       (apply
+        sync
+        (handle-evt
+         manager-side-chan
+         (λ (req)
+           (define command (list-ref req 0))
+           (define zo-path (list-ref req 1))
+           (define response-manager-side (list-ref req 2))
+           (define died-chan-manager-side (list-ref req 3))
+           (define compilation-thread-id (list-ref req 4))
+           (case command
+             [(lock)
+              (cond
+                [(hash-ref currently-locked-files zo-path #f)
+                 (log-info (format "compile-lock: ~s ~a already locked" zo-path compilation-thread-id))
+                 (set! pending-requests (cons (pending response-manager-side zo-path died-chan-manager-side)
+                                              pending-requests))
+                 (loop)]
+                [else
+                 (log-info (format "compile-lock: ~s ~a obtained lock" zo-path compilation-thread-id))
+                 (hash-set! currently-locked-files zo-path #t)
+                 (place-channel-put response-manager-side #t)
+                 (set! running-compiles (cons (running zo-path died-chan-manager-side) running-compiles))
+                 (loop)])]
+             [(unlock)
+              (log-info (format "compile-lock: ~s ~a unlocked" zo-path compilation-thread-id))
+              (define (same-pending-zo-path? pending) (equal? (pending-zo-path pending) zo-path))
+              (define to-unlock (filter same-pending-zo-path? pending-requests))
+              (set! pending-requests (filter (compose not same-pending-zo-path?) pending-requests))
+              (for ([pending (in-list to-unlock)])
+                (place-channel-put (pending-response-chan pending) #f))
+              (hash-remove! currently-locked-files zo-path)
+              (set! running-compiles (filter (λ (a-running) (not (equal? (running-zo-path a-running) zo-path)))
+                                             running-compiles))
+              (loop)])))
+        (for/list ([running-compile (in-list running-compiles)])
+          (handle-evt
+           (running-died-chan-manager-side running-compile)
+           (λ (compilation-thread-id)
+             (define zo-path (running-zo-path running-compile))
+             (set! running-compiles (remove running-compile running-compiles))
+             (define same-zo-pending 
+               (filter (λ (pending) (equal? zo-path (pending-zo-path pending)))
+                       pending-requests))
+             (cond
+               [(null? same-zo-pending)
+                (log-info (format "compile-lock: ~s ~a died; no else waiting" zo-path compilation-thread-id))
+                (hash-remove! currently-locked-files zo-path)
+                (loop)]
+               [else
+                (log-info (format "compile-lock: ~s ~a died; someone else waiting" zo-path compilation-thread-id))
+                (define to-be-running (car same-zo-pending))
+                (set! pending-requests (remq to-be-running pending-requests))
+                (place-channel-put (pending-response-chan to-be-running) #t)
+                (set! running-compiles 
+                      (cons (running zo-path (pending-died-chan-manager-side to-be-running))
+                            running-compiles))
+                (loop)]))))))))
   
   build-side-chan)
 
-(define (compile-lock->parallel-lock-client build-side-chan)
+(define (compile-lock->parallel-lock-client build-side-chan [custodian #f])
+  (define monitor-threads (make-hash))
+  (define add-monitor-chan (make-channel))
+  (define kill-monitor-chan (make-channel))
+  
+  (when custodian
+    (parameterize ([current-custodian custodian])
+      (thread
+       (λ () 
+         (let loop ()
+           (sync
+            (handle-evt add-monitor-chan
+                        (λ (arg)
+                          (define-values (zo-path monitor-thread) (apply values arg))
+                          (hash-set! monitor-threads zo-path monitor-thread)
+                          (loop)))
+            (handle-evt kill-monitor-chan
+                        (λ (zo-path)
+                          (define thd/f (hash-ref monitor-threads zo-path #f))
+                          (when thd/f (kill-thread thd/f))
+                          (hash-remove! monitor-threads zo-path)
+                          (loop)))))))))
+  
   (λ (command zo-path)
+    (define compiling-thread (current-thread))
     (define-values (response-builder-side response-manager-side) (place-channel))
-    (place-channel-put build-side-chan (list command zo-path response-manager-side))
-    (when (eq? command 'lock)
-      (place-channel-get response-builder-side))))
+    (define-values (died-chan-compiling-side died-chan-manager-side) (place-channel))
+    (place-channel-put build-side-chan (list command 
+                                             zo-path
+                                             response-manager-side
+                                             died-chan-manager-side 
+                                             (eq-hash-code compiling-thread)))
+    (cond
+      [(eq? command 'lock)
+       (define monitor-thread
+        (and custodian
+             (parameterize ([current-custodian custodian])
+               (thread
+                (λ ()
+                  (thread-wait compiling-thread)
+                  ;; compiling thread died; alert the server
+                  ;; & remove this thread from the table
+                  (place-channel-put died-chan-compiling-side (eq-hash-code compiling-thread))
+                  (channel-put kill-monitor-chan zo-path))))))
+       (when monitor-thread (channel-put add-monitor-chan (list zo-path monitor-thread)))
+       (define res (place-channel-get response-builder-side))
+       (when monitor-thread
+         (unless res ;; someone else finished compilation for us; kill the monitor
+           (channel-put kill-monitor-chan zo-path)))
+       res]
+      [(eq? command 'unlock)
+       (when custodian 
+         ;; we finished the compilation; kill the monitor
+         (channel-put kill-monitor-chan zo-path))])))

collects/compiler/commands/make.rkt

@@ -66,7 +66,7 @@
                       (lambda (p)
                         (set! did-one? #t)
                         (when (verbose)
-                          (printf "  making ~s\n" (path->string p))))])
+                          (printf "  making ~s\n" p)))])
         (for ([file source-files])
           (unless (file-exists? file)
             (error mzc-symbol "file does not exist: ~a" file))

collects/compiler/decompile.rkt

@@ -164,16 +164,20 @@
 
 (define (decompile-module mod-form stack stx-ht)
   (match mod-form
-    [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported 
+    [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported 
                        max-let-depth dummy lang-info internal-context))
      (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]
                   [(stack) (append '(#%modvars) stack)]
                   [(closed) (make-hasheq)])
        `(module ,name ....
           ,@defns
-          ,@(map (lambda (form)
-                   (decompile-form form globs stack closed stx-ht))
-                 syntax-body)
+          ,@(for/list ([b (in-list syntax-bodies)])
+              (let loop ([n (sub1 (car b))])
+                (if (zero? n)
+                    (cons 'begin
+                          (for/list ([form (in-list (cdr b))])
+                            (decompile-form form globs stack closed stx-ht)))
+                    (list 'begin-for-syntax (loop (sub1 n))))))
           ,@(map (lambda (form)
                    (decompile-form form globs stack closed stx-ht))
                  body)))]
@@ -190,18 +194,19 @@
                                 (list-ref/protect (glob-desc-vars globs) pos 'def-vals)]))
                            ids)
         ,(decompile-expr rhs globs stack closed))]
-    [(struct def-syntaxes (ids rhs prefix max-let-depth))
+    [(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
      `(define-syntaxes ,ids
         ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
            `(let ()
               ,@defns
               ,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
-    [(struct def-for-syntax (ids rhs prefix max-let-depth))
-     `(define-values-for-syntax ,ids
-        ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
-           `(let ()
+    [(struct seq-for-syntax (exprs prefix max-let-depth dummy))
+     `(begin-for-syntax
+       ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
+          `(let ()
              ,@defns
-             ,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
+             ,@(for/list ([rhs (in-list exprs)])
+                 (decompile-form rhs globs '(#%globals) closed stx-ht)))))]
     [(struct seq (forms))
      `(begin ,@(map (lambda (form)
                       (decompile-form form globs stack closed stx-ht))

collects/compiler/demodularizer/gc-toplevels.rkt

@@ -64,7 +64,7 @@
        (build-graph! new-lhs rhs)]
       [(? def-syntaxes?)
        (error 'build-graph "Doesn't handle syntax")]
-      [(? def-for-syntax?)
+      [(? seq-for-syntax?)
        (error 'build-graph "Doesn't handle syntax")]
       [(struct req (reqs dummy))
        (build-graph! lhs dummy)]
@@ -197,7 +197,7 @@
            #f)]
       [(? def-syntaxes?)
        (error 'gc-tls "Doesn't handle syntax")]
-      [(? def-for-syntax?)
+      [(? seq-for-syntax?)
        (error 'gc-tls "Doesn't handle syntax")]
       [(struct req (reqs dummy))
        (make-req reqs (update dummy))]

collects/compiler/demodularizer/merge.rkt

@@ -108,7 +108,8 @@
 
 (define (merge-module max-let-depth top-prefix mod-form)
   (match mod-form
-    [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-body unexported mod-max-let-depth dummy lang-info internal-context))
+    [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies
+                       unexported mod-max-let-depth dummy lang-info internal-context))
      (define toplevel-offset (length (prefix-toplevels top-prefix)))
      (define topsyntax-offset (length (prefix-stxs top-prefix)))
      (define lift-offset (prefix-num-lifts top-prefix))

collects/compiler/demodularizer/module.rkt

@@ -24,7 +24,7 @@
                 (list (cons 0 requires))
                 new-forms
                 empty ; syntax-body
-                (list empty empty empty) ; unexported
+                (list) ; unexported
                 max-let-depth
                 (make-toplevel 0 0 #f #f) ; dummy
                 lang-info

collects/compiler/demodularizer/nodep.rkt

@@ -112,7 +112,8 @@
 
 (define (nodep-module mod-form phase)
   (match mod-form
-    [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context))
+    [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies
+                       unexported max-let-depth dummy lang-info internal-context))
      (define new-prefix prefix)
      ; Cache all the mpi paths
      (for-each (match-lambda

collects/compiler/demodularizer/update-toplevels.rkt

@@ -10,7 +10,7 @@
                         (update rhs))]
       [(? def-syntaxes?)
        (error 'increment "Doesn't handle syntax")]
-      [(? def-for-syntax?)
+      [(? seq-for-syntax?)
        (error 'increment "Doesn't handle syntax")]
       [(struct req (reqs dummy))
        (make-req reqs (update dummy))]

collects/compiler/main.rkt

@@ -510,7 +510,7 @@
    (parameterize ([compile-notify-handler 
                    (lambda (path)
                      (when (compiler:option:somewhat-verbose)
-                       (printf "  making ~s\n" (path->string path))))])
+                       (printf "  making ~s\n" path)))])
      (apply compile-collection-zos source-files))]
   [(cc)
    (for ([file source-files])

collects/compiler/private/mach-o.rkt

@@ -56,6 +56,7 @@
                  [link-edit-addr 0]
                  [link-edit-offset 0]
                  [link-edit-len 0]
+                 [link-edit-vmlen 0]
                  [dyld-info-pos #f]
                  [dyld-info-offs #f])
             ;; (printf "~a cmds, length 0x~x\n" cnt cmdssz)
@@ -82,6 +83,7 @@
                            (set! link-edit-64? 64?)
                            (set! link-edit-pos pos)
                            (set! link-edit-addr vmaddr)
+                           (set! link-edit-vmlen vmlen)
                            (set! link-edit-offset offset)
                            (set! link-edit-len len)
                            (when (link-edit-len . < . 0)
@@ -145,7 +147,7 @@
                   [out-offset (if move-link-edit?
                                   link-edit-offset
                                   (+ link-edit-offset (round-up-page link-edit-len)))]
-                  [out-addr (+ link-edit-addr (round-up-page link-edit-len))])
+                  [out-addr (+ link-edit-addr (round-up-page link-edit-vmlen))])
               (unless ((+ end-cmd new-cmd-sz) . < . min-used)
                 (error 'check-header 
                        "no room for a new section load command (current end is ~a; min used is ~a)"

collects/compiler/zo-marshal.rkt

@@ -158,7 +158,7 @@
 (define quote-syntax-type-num 14)
 (define define-values-type-num 15)
 (define define-syntaxes-type-num 16)
-(define define-for-syntax-type-num 17)
+(define begin-for-syntax-type-num 17)
 (define set-bang-type-num 18)
 (define boxenv-type-num 19)
 (define begin0-sequence-type-num 20)
@@ -256,8 +256,6 @@
 
 (define BITS_PER_MZSHORT 32)
 
-(define *dummy* #f)
-
 (define (int->bytes x)
   (integer->integer-bytes x
                           4
@@ -522,21 +520,20 @@
         (out-marshaled define-values-type-num
                        (list->vector (cons (protect-quote rhs) ids))
                        out)]
-       [(struct def-syntaxes (ids rhs prefix max-let-depth))
+       [(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
         (out-marshaled define-syntaxes-type-num
                        (list->vector (list* (protect-quote rhs)
                                             prefix
                                             max-let-depth
-                                            *dummy*
+                                            dummy
                                             ids))
                        out)]
-       [(struct def-for-syntax (ids rhs prefix max-let-depth))
-        (out-marshaled define-for-syntax-type-num
-                       (list->vector (list* (protect-quote rhs)
-                                            prefix
-                                            max-let-depth
-                                            *dummy*
-                                            ids))
+       [(struct seq-for-syntax (rhs prefix max-let-depth dummy))
+        (out-marshaled begin-for-syntax-type-num
+                       (vector (map protect-quote rhs)
+                               prefix
+                               max-let-depth
+                               dummy)
                        out)]
        [(struct beg0 (forms))
         (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)]
@@ -825,7 +822,7 @@
 
 (define (out-module mod-form out)
   (match mod-form
-    [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported 
+    [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported 
                        max-let-depth dummy lang-info internal-context))
      (let* ([lookup-req (lambda (phase)
                           (let ([a (assq phase requires)])
@@ -844,6 +841,11 @@
                         (if (ormap values p)
                             (list->vector p)
                             #f)))))]
+            [extract-unexported
+             (lambda (phase)
+               (let ([a (assq phase unexported)])
+                 (and a
+                      (cdr a))))]
             [list->vector/#f (lambda (default l)
                                (if (andmap (lambda (x) (equal? x default)) l)
                                    #f
@@ -861,45 +863,54 @@
             [l (cons (lookup-req 1) l)] ; et-requires
             [l (cons (lookup-req 0) l)] ; requires
             [l (cons (list->vector body) l)]
-            [l (cons (list->vector
-                      (for/list ([i (in-list syntax-body)])
-                        (define (maybe-one l) ;; a single symbol is ok
-                          (if (and (pair? l) (null? (cdr l)))
-                              (car l)
-                              l))
-                        (match i
-                          [(struct def-syntaxes (ids rhs prefix max-let-depth))
-                           (vector (maybe-one ids) rhs max-let-depth prefix #f)]
-                          [(struct def-for-syntax (ids rhs prefix max-let-depth))
-                           (vector (maybe-one ids) rhs max-let-depth prefix #t)])))
-                     l)]
+            [l (append (reverse
+                        (for/list ([b (in-list syntax-bodies)])
+                          (for/vector ([i (in-list (cdr b))])
+                            (define (maybe-one l) ;; a single symbol is ok
+                              (if (and (pair? l) (null? (cdr l)))
+                                  (car l)
+                                  l))
+                            (match i
+                              [(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
+                               (vector (maybe-one ids) rhs max-let-depth prefix #f)]
+                              [(struct seq-for-syntax ((list rhs) prefix max-let-depth dummy))
+                               (vector #f rhs max-let-depth prefix #t)]))))
+                       l)]
             [l (append (apply
                         append
                         (map (lambda (l)
-                               (let ([phase (car l)]
-                                     [all (append (cadr l) (caddr l))])
-                                 (list phase
-                                       (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) 
-                                                               all))
-                                       (list->vector/#f #f (map (lambda (p)
-                                                                  (if (eq? (provided-nom-src p)
-                                                                           (provided-src p))
-                                                                      #f ; #f means "same as src"
-                                                                      (provided-nom-src p)))
-                                                                all))
-                                       (list->vector (map provided-src-name all))
-                                       (list->vector (map provided-src all))
-                                       (list->vector (map provided-name all))
-                                       (length (cadr l))
-                                       (length all))))
+                               (let* ([phase (car l)]
+                                      [all (append (cadr l) (caddr l))]
+                                      [protects (extract-protects phase)]
+                                      [unexported (extract-unexported phase)])
+                                 (append
+                                  (list phase)
+                                  (if (and (not protects) 
+                                           (not unexported))
+                                      (list (void))
+                                      (let ([unexported (or unexported
+                                                            '(() ()))])
+                                        (list (list->vector (cadr unexported))
+                                              (length (cadr unexported))
+                                              (list->vector (car unexported))
+                                              (length (car unexported))
+                                              protects)))
+                                  (list (list->vector/#f 0 (map provided-src-phase all))
+                                        (list->vector/#f #f (map (lambda (p)
+                                                                   (if (eq? (provided-nom-src p)
+                                                                            (provided-src p))
+                                                                       #f ; #f means "same as src"
+                                                                       (provided-nom-src p)))
+                                                                 all))
+                                        (list->vector (map provided-src-name all))
+                                        (list->vector (map provided-src all))
+                                        (list->vector (map provided-name all))
+                                        (length (cadr l))
+                                        (length all)))))
                              provides))
                        l)]
             [l (cons (length provides) l)] ; number of provide sets
-            [l (cons (extract-protects 0) l)] ; protects
-            [l (cons (extract-protects 1) l)] ; et protects
-            [l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides
-            [l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides
-            [l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides
+            [l (cons (add1 (length syntax-bodies)) l)]
             [l (cons prefix l)]
             [l (cons dummy l)]
             [l (cons max-let-depth l)]

collects/compiler/zo-parse.rkt

@@ -181,19 +181,19 @@
    (cdr (vector->list v))
    (vector-ref v 0)))
 
-; XXX Allocates unnessary list
-(define (read-define-syntaxes mk v)
-  (mk (list-tail (vector->list v) 4)
-      (vector-ref v 0)
-      (vector-ref v 1)
-      (vector-ref v 2)
-      #;(vector-ref v 3)))
-
 (define (read-define-syntax v)
-  (read-define-syntaxes make-def-syntaxes v))
+  (make-def-syntaxes (list-tail (vector->list v) 4)
+                     (vector-ref v 0)
+                     (vector-ref v 1)
+                     (vector-ref v 2)
+                     (vector-ref v 3)))
 
-(define (read-define-for-syntax v)
-  (read-define-syntaxes make-def-for-syntax v))
+(define (read-begin-for-syntax v)
+  (make-seq-for-syntax 
+   (vector-ref v 0)
+   (vector-ref v 1)
+   (vector-ref v 2)
+   (vector-ref v 3)))
 
 (define (read-set! v)
   (make-assign (cadr v) (cddr v) (car v)))
@@ -225,50 +225,65 @@
              (lambda _ #t)
              (lambda _ #t)))))
 
+(define (split-phase-data rest n)
+  (let loop ([n n] [rest rest] [phase-accum null])
+    (cond
+     [(zero? n)
+      (values (reverse phase-accum) rest)]
+     [else
+      (let ([maybe-indirect (list-ref rest 1)])
+        (if (void? maybe-indirect) 
+            ;; no indirect or protect info:
+            (loop (sub1 n)
+                  (list-tail rest 9)
+                  (cons (take rest 9) phase-accum))
+            ;; has indirect or protect info:
+            (loop (sub1 n)
+                  (list-tail rest (+ 5 8))
+                  (cons (take rest (+ 5 8)) phase-accum))))])))
+      
 (define (read-module v)
   (match v
     [`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional?
              ,rename ,max-let-depth ,dummy
-             ,prefix
-             ,indirect-et-provides ,num-indirect-et-provides 
-             ,indirect-syntax-provides ,num-indirect-syntax-provides 
-             ,indirect-provides ,num-indirect-provides 
-             ,protects ,et-protects
+             ,prefix ,num-phases
              ,provide-phase-count . ,rest)
-     (let ([phase-data (take rest (* 8 provide-phase-count))])
-       (match (list-tail rest (* 8 provide-phase-count))
-         [`(,syntax-body ,body
-                         ,requires ,syntax-requires ,template-requires ,label-requires
-                         ,more-requires-count . ,more-requires)
+     (let*-values ([(phase-data rest-module) (split-phase-data rest provide-phase-count)]
+                   [(bodies rest-module) (values (take rest-module num-phases)
+                                                 (drop rest-module num-phases))])
+       (match rest-module
+         [`(,requires ,syntax-requires ,template-requires ,label-requires
+                      ,more-requires-count . ,more-requires)
           (make-mod name srcname self-modidx
-                    prefix (let loop ([l phase-data])
-                             (if (null? l)
-                                 null
-                                 (let ([num-vars (list-ref l 6)]
-                                       [ps (for/list ([name (in-vector (list-ref l 5))]
-                                                      [src (in-vector (list-ref l 4))]
-                                                      [src-name (in-vector (list-ref l 3))]
-                                                      [nom-src (or (list-ref l 2)
-                                                                   (in-cycle (in-value #f)))]
-                                                      [src-phase (or (list-ref l 1)
-                                                                     (in-cycle (in-value #f)))]
-                                                      [protected? (or (case (car l)
-                                                                        [(0) protects]
-                                                                        [(1) et-protects]
-                                                                        [else #f])
-                                                                      (in-cycle (in-value #f)))])
-                                             (make-provided name src src-name 
-                                                            (or nom-src src)
-                                                            (if src-phase 1 0)
-                                                            protected?))])
-                                   (if (null? ps)
-                                       (loop (list-tail l 8))
-                                       (cons
-                                        (list
-                                         (car l)
-                                         (take ps num-vars)
-                                         (drop ps num-vars))
-                                        (loop (list-tail l 8)))))))
+                    prefix
+                    ;; provides:
+                    (for/list ([l (in-list phase-data)])
+                      (let* ([phase (list-ref l 0)]
+                             [has-info? (not (void? (list-ref l 1)))]
+                             [delta (if has-info? 5 1)]
+                             [num-vars (list-ref l (+ delta 6))]
+                             [num-all (list-ref l (+ delta 7))]
+                             [ps (for/list ([name (in-vector (list-ref l (+ delta 5)))]
+                                            [src (in-vector (list-ref l (+ delta 4)))]
+                                            [src-name (in-vector (list-ref l (+ delta 3)))]
+                                            [nom-src (or (list-ref l (+ delta 2))
+                                                         (in-cycle (in-value #f)))]
+                                            [src-phase (or (list-ref l (+ delta 1))
+                                                           (in-cycle (in-value 0)))]
+                                            [protected? (cond
+                                                         [(or (not has-info?)
+                                                              (not (list-ref l 5)))
+                                                          (in-cycle (in-value #f))]
+                                                         [else (list-ref l 5)])])
+                                   (make-provided name src src-name 
+                                                  (or nom-src src)
+                                                  src-phase
+                                                  protected?))])
+                        (list
+                         phase
+                         (take ps num-vars)
+                         (drop ps num-vars))))
+                    ;; requires:
                     (list*
                      (cons 0 requires)
                      (cons 1 syntax-requires)
@@ -276,20 +291,34 @@
                      (cons #f label-requires)
                      (for/list ([(phase reqs) (in-list* more-requires 2)])
                        (cons phase reqs)))
-                    (vector->list body)
-                    (map (lambda (sb)
-                           (match sb
-                             [(? def-syntaxes?) sb]
-                             [(? def-for-syntax?) sb]
-                             [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
-                              ((if for-stx?
-                                   make-def-for-syntax
-                                   make-def-syntaxes)
-                               (if (list? ids) ids (list ids)) expr prefix max-let-depth)]))
-                         (vector->list syntax-body))
-                    (list (vector->list indirect-provides)
-                          (vector->list indirect-syntax-provides)
-                          (vector->list indirect-et-provides))
+                    ;; body:
+                    (vector->list (last bodies))
+                    ;; syntax-bodies: add phase to each list, break apart
+                    (for/list ([b (cdr (reverse bodies))]
+                               [i (in-naturals 1)])
+                      (cons i
+                            (for/list ([sb (in-vector b)])
+                              (match sb
+                                [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
+                                 (if for-stx?
+                                     (make-seq-for-syntax (list expr) prefix max-let-depth #f)
+                                     (make-def-syntaxes
+                                      (if (list? ids) ids (list ids)) expr prefix max-let-depth #f))]
+                                [else (error 'zo-parse "bad phase ~a body element: ~e" i sb)]))))
+                    ;; unexported:
+                    (for/list ([l (in-list phase-data)]
+                               #:when (not (void? (list-ref l 1))))
+                      (let* ([phase (list-ref l 0)]
+                             [indirect-syntax 
+                              ;; could check: (list-ref l 2) should be size of vector:
+                              (list-ref l 1)]
+                             [indirect 
+                              ;; could check: (list-ref l 4) should be size of vector:
+                              (list-ref l 3)])
+                        (list
+                         phase
+                         (vector->list indirect)
+                         (vector->list indirect-syntax))))
                     max-let-depth
                     dummy
                     lang-info
@@ -313,7 +342,7 @@
     [(14) 'quote-syntax-type]
     [(15) 'define-values-type]
     [(16) 'define-syntaxes-type]
-    [(17) 'define-for-syntax-type]
+    [(17) 'begin-for-syntax-type]
     [(18) 'set-bang-type]
     [(19) 'boxenv-type]
     [(20) 'begin0-sequence-type]
@@ -350,7 +379,7 @@
     (cons 'free-id-info-type read-free-id-info)
     (cons 'define-values-type read-define-values)
     (cons 'define-syntaxes-type read-define-syntax)
-    (cons 'define-for-syntax-type read-define-for-syntax)
+    (cons 'begin-for-syntax-type read-begin-for-syntax)
     (cons 'set-bang-type read-set!)
     (cons 'boxenv-type read-boxenv)
     (cons 'require-form-type read-require)

collects/compiler/zo-structs.rkt

@@ -80,7 +80,7 @@
                               [src (or/c module-path-index? #f)] 
                               [src-name symbol?] 
                               [nom-src any/c] ; should be (or/c module-path-index? #f)
-                              [src-phase (or/c 0 1)] 
+                              [src-phase exact-nonnegative-integer?] 
                               [protected? boolean?]))
 
 (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] 
@@ -89,18 +89,19 @@
                                      [ready? boolean?]))  ; access binding via prefix array (which is on stack)
 
 (define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin'
+(define-form-struct (seq-for-syntax form) ([forms (listof (or/c form? any/c))] ; `begin-for-syntax'
+                                           [prefix prefix?] 
+                                           [max-let-depth exact-nonnegative-integer?]
+                                           [dummy (or/c toplevel? #f)]))
 
 ;; Definitions (top level or within module):
-(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?
+(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))]
                                        [rhs (or/c expr? seq? any/c)])) 
-(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?                                        
+(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))]
                                          [rhs (or/c expr? seq? any/c)] 
                                          [prefix prefix?] 
-                                         [max-let-depth exact-nonnegative-integer?])) 
-(define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?
-                                           [rhs (or/c expr? seq? any/c)] 
-                                           [prefix prefix?] 
-                                           [max-let-depth exact-nonnegative-integer?])) 
+                                         [max-let-depth exact-nonnegative-integer?]
+                                         [dummy (or/c toplevel? #f)]))
 
 (define-form-struct (mod form) ([name symbol?] 
                                 [srcname symbol?]
@@ -112,9 +113,11 @@
                                 [requires (listof (cons/c (or/c exact-integer? #f)
                                                           (listof module-path-index?)))]
                                 [body (listof (or/c form? any/c))]
-                                [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] 
-                                [unexported (list/c (listof symbol?) (listof symbol?)
-                                                    (listof symbol?))] 
+                                [syntax-bodies (listof (cons/c exact-positive-integer?
+                                                               (listof (or/c def-syntaxes? seq-for-syntax?))))]
+                                [unexported (listof (list/c exact-nonnegative-integer?
+                                                            (listof symbol?)
+                                                            (listof symbol?)))]
                                 [max-let-depth exact-nonnegative-integer?]
                                 [dummy toplevel?]
                                 [lang-info (or/c #f (vector/c module-path? symbol? any/c))]

collects/db/TODO

@@ -1,4 +1,3 @@
-internal docs
 ----
 
 Testing
@@ -31,11 +30,11 @@ Types
 
 Misc
 
+- internal docs
+
 - use ffi/unsafe/alloc to simplify odbc handle allocation
 
 - add ODBC-like functions for inspecting schemas (list-tables, etc)
-  - util/schema (?), util/info (for information_schema) (?)
-  - at least, table-exists? : string [...] -> boolean?
 
 - for wrapped/managed connections, detect if underlying connection gets
   disconnected by server (eg, times out after 10 minutes of inactivity)
@@ -67,10 +66,15 @@ Misc
   - how do people want to use cursors?
   - how about implicit support only in 'in-query'?
 
-- ODBC: use async execution to avoid blocking all Racket threads
-
 - add evt versions of functions
   - for query functions (?)
   - connection-pool-lease-evt
   - when is it useful in practice?
     - would make it easier to handle timeouts...
+
+- on insert, return last inserted id
+  - postgresql: parse CommandComplete msg tag
+  - mysql: in ok-packet (what conditions, though?)
+  - sqlite3: sqlite3_last_insert_rowid(), use sqlite3_changes() to see if insert succeeded,
+    but still need to tell if stmt was even insert (parse sql?)
+  - odbc: ???

collects/db/base.rkt

@@ -1,9 +1,250 @@
 #lang racket/base
 (require racket/contract
-         "private/generic/main.rkt"
-         "private/generic/connect-util.rkt"
-         "private/generic/dsn.rkt")
+         unstable/prop-contract)
 
-(provide (all-from-out "private/generic/main.rkt")
-         (all-from-out "private/generic/dsn.rkt")
-         (all-from-out "private/generic/connect-util.rkt"))
+;; ============================================================
+
+(require "private/generic/interfaces.rkt"
+         "private/generic/sql-data.rkt")
+
+(provide (struct-out simple-result)
+         (struct-out rows-result)
+         statement-binding?)
+
+(provide sql-null
+         sql-null?
+         sql-null->false
+         false->sql-null)
+
+(provide/contract
+ [struct sql-date ([year exact-integer?]
+                   [month (integer-in 0 12)]
+                   [day (integer-in 0 31)])]
+ [struct sql-time ([hour (integer-in 0 23)]
+                   [minute (integer-in 0 59)]
+                   [second (integer-in 0 61)] ;; leap seconds
+                   [nanosecond (integer-in 0 (sub1 #e1e9))]
+                   [tz (or/c #f exact-integer?)])]
+ [struct sql-timestamp ([year exact-integer?]
+                        [month (integer-in 0 12)]
+                        [day (integer-in 0 31)]
+                        [hour (integer-in 0 23)]
+                        [minute (integer-in 0 59)]
+                        [second (integer-in 0 61)]
+                        [nanosecond (integer-in 0 (sub1 #e1e9))]
+                        [tz (or/c #f exact-integer?)])]
+ [struct sql-interval ([years exact-integer?]
+                       [months exact-integer?]
+                       [days exact-integer?]
+                       [hours exact-integer?]
+                       [minutes exact-integer?]
+                       [seconds exact-integer?]
+                       [nanoseconds exact-integer?])]
+
+ [sql-day-time-interval?
+  (-> any/c boolean?)]
+ [sql-year-month-interval?
+  (-> any/c boolean?)]
+ [sql-interval->sql-time
+  (->* (sql-interval?) (any/c)
+       any)]
+ [sql-time->sql-interval
+  (-> sql-time? sql-day-time-interval?)]
+
+ [make-sql-bits
+  (-> exact-nonnegative-integer? sql-bits?)]
+ [sql-bits?
+  (-> any/c boolean?)]
+ [sql-bits-length
+  (-> sql-bits? exact-nonnegative-integer?)]
+ [sql-bits-ref
+  (-> sql-bits? exact-nonnegative-integer? boolean?)]
+ [sql-bits-set!
+  (-> sql-bits? exact-nonnegative-integer? boolean? void?)]
+ [sql-bits->list
+  (-> sql-bits? (listof boolean?))]
+ [list->sql-bits
+  (-> (listof boolean?) sql-bits?)]
+ [sql-bits->string
+  (-> sql-bits? string?)]
+ [string->sql-bits
+  (-> string? sql-bits?)])
+
+;; ============================================================
+
+(require "private/generic/functions.rkt")
+
+(provide (rename-out [in-query* in-query]))
+
+(provide/contract
+ [connection?
+  (-> any/c any)]
+ [disconnect
+  (-> connection? any)]
+ [connected?
+  (-> connection? any)]
+ [connection-dbsystem
+  (-> connection? dbsystem?)]
+ [dbsystem?
+  (-> any/c any)]
+ [dbsystem-name
+  (-> dbsystem? symbol?)]
+ [dbsystem-supported-types
+  (-> dbsystem? (listof symbol?))]
+
+ [statement?
+  (-> any/c any)]
+ [prepared-statement?
+  (-> any/c any)]
+ [prepared-statement-parameter-types
+  (-> prepared-statement? (or/c list? #f))]
+ [prepared-statement-result-types
+  (-> prepared-statement? (or/c list? #f))]
+
+ [query-exec
+  (->* (connection? statement?) () #:rest list? any)]
+ [query-rows
+  (->* (connection? statement?)
+       (#:group (or/c (vectorof string?) (listof (vectorof string?))))
+       #:rest list? (listof vector?))]
+ [query-list
+  (->* (connection? statement?) () #:rest list? list?)]
+ [query-row
+  (->* (connection? statement?) () #:rest list? vector?)]
+ [query-maybe-row
+  (->* (connection? statement?) () #:rest list? (or/c #f vector?))]
+ [query-value
+  (->* (connection? statement?) () #:rest list? any)]
+ [query-maybe-value
+  (->* (connection? statement?) () #:rest list? any)]
+ [query
+  (->* (connection? statement?) () #:rest list? any)]
+
+ [prepare
+  (-> connection? (or/c string? virtual-statement?) any)]
+ [bind-prepared-statement
+  (-> prepared-statement? list? any)]
+
+ [rename virtual-statement* virtual-statement
+  (-> (or/c string? (-> dbsystem? string?))
+      virtual-statement?)]
+ [virtual-statement?
+  (-> any/c boolean?)]
+
+ [start-transaction
+  (->* (connection?)
+       (#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f))
+       void?)]
+ [commit-transaction
+  (-> connection? void?)]
+ [rollback-transaction
+  (-> connection? void?)]
+ [in-transaction?
+  (-> connection? boolean?)]
+ [needs-rollback?
+  (-> connection? boolean?)]
+ [call-with-transaction
+  (->* (connection? (-> any))
+       (#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f))
+       void?)]
+
+ [prop:statement
+  (struct-type-property/c
+   (-> any/c connection?
+       statement?))]
+
+ [list-tables
+  (->* (connection?)
+       (#:schema (or/c 'search-or-current 'search 'current))
+       (listof string?))]
+ [table-exists?
+  (->* (connection? string?)
+       (#:schema (or/c 'search-or-current 'search 'current)
+        #:case-sensitive? any/c)
+       boolean?)]
+
+ [group-rows
+  (->* (rows-result?
+        #:group (or/c (vectorof string?) (listof (vectorof string?))))
+       (#:group-mode (listof (or/c 'preserve-null-rows 'list)))
+       rows-result?)])
+
+;; ============================================================
+
+(require "private/generic/connect-util.rkt")
+
+(provide/contract
+ [kill-safe-connection
+  (-> connection? connection?)]
+ [virtual-connection
+  (->* ((or/c (-> connection?) connection-pool?))
+       ()
+       connection?)]
+ [connection-pool
+  (->* ((-> connection?))
+       (#:max-connections (or/c (integer-in 1 10000) +inf.0)
+        #:max-idle-connections (or/c (integer-in 1 10000) +inf.0))
+       connection-pool?)]
+ [connection-pool?
+  (-> any/c boolean?)]
+ [connection-pool-lease
+  (->* (connection-pool?)
+       ((or/c custodian? evt?))
+       connection?)])
+
+;; ============================================================
+
+(require "private/generic/dsn.rkt")
+
+(provide dsn-connect)   ;; can't express "or any kw at all" w/ ->* contract
+(provide/contract
+ [struct data-source
+         ([connector connector?]
+          [args arglist?]
+          [extensions (listof (list/c symbol? writable-datum?))])]
+ [current-dsn-file (parameter/c path-string?)]
+ [get-dsn
+  (->* (symbol?) (any/c #:dsn-file path-string?) any)]
+ [put-dsn
+  (->* (symbol? (or/c data-source? #f)) (#:dsn-file path-string?) void?)]
+ [postgresql-data-source
+  (->* ()
+       (#:user string?
+        #:database string?
+        #:server string?
+        #:port exact-positive-integer?
+        #:socket (or/c string? 'guess)
+        #:password (or/c string? #f)
+        #:allow-cleartext-password? boolean?
+        #:ssl (or/c 'yes 'optional 'no)
+        #:notice-handler (or/c 'output 'error)
+        #:notification-handler (or/c 'output 'error))
+       data-source?)]
+ [mysql-data-source
+  (->* ()
+       (#:user string?
+        #:database string?
+        #:server string?
+        #:port exact-positive-integer?
+        #:socket (or/c string? 'guess)
+        #:password (or/c string? #f)
+        #:notice-handler (or/c 'output 'error))
+       data-source?)]
+ [sqlite3-data-source
+  (->* ()
+       (#:database (or/c string? 'memory 'temporary)
+        #:mode (or/c 'read-only 'read/write 'create)
+        #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0)
+        #:busy-retry-delay (and/c rational? (not/c negative?))
+        #:use-place boolean?)
+       data-source?)]
+ [odbc-data-source
+  (->* ()
+       (#:dsn string?
+        #:user string?
+        #:password string?
+        #:notice-handler (or/c 'output 'error)
+        #:strict-parameter-types? boolean?
+        #:character-mode (or/c 'wchar 'utf-8 'latin-1)
+        #:use-place boolean?)
+       data-source?)])

collects/db/main.rkt

@@ -1,39 +1,28 @@
 #lang racket/base
 (require (for-syntax racket/base)
-         "private/generic/lazy-require.rkt"
-         racket/runtime-path
-         racket/promise
+         unstable/lazy-require
          racket/contract
          "base.rkt")
 (provide (all-from-out "base.rkt"))
 
-(define-lazy-require-definer define-postgresql "private/postgresql/main.rkt")
-(define-lazy-require-definer define-mysql "private/mysql/main.rkt")
-(define-lazy-require-definer define-sqlite3 "private/sqlite3/main.rkt")
-(define-lazy-require-definer define-odbc "private/odbc/main.rkt")
-(define-lazy-require-definer define-openssl 'openssl)
-
-(define-postgresql
-  postgresql-connect
-  postgresql-guess-socket-path
-  postgresql-password-hash)
-
-(define-mysql
-  mysql-connect
-  mysql-guess-socket-path
-  mysql-password-hash)
-
-(define-sqlite3
-  sqlite3-connect)
-
-(define-odbc
-  odbc-connect
-  odbc-driver-connect
-  odbc-data-sources
-  odbc-drivers)
-
-(define-openssl
-  ssl-client-context?)
+(lazy-require
+ ["private/postgresql/main.rkt"
+  (postgresql-connect
+   postgresql-guess-socket-path
+   postgresql-password-hash)]
+ ["private/mysql/main.rkt"
+  (mysql-connect
+   mysql-guess-socket-path
+   mysql-password-hash)]
+ ["private/sqlite3/main.rkt"
+  (sqlite3-connect)]
+ ["private/odbc/main.rkt"
+  (odbc-connect
+   odbc-driver-connect
+   odbc-data-sources
+   odbc-drivers)]
+ ['openssl
+  (ssl-client-context?)])
 
 (provide/contract
  ;; Duplicates contracts at postgresql.rkt
@@ -49,7 +38,7 @@
         #:ssl-context ssl-client-context?
         #:notice-handler (or/c 'output 'error output-port? procedure?)
         #:notification-handler (or/c 'output 'error output-port? procedure?))
-       any/c)]
+       connection?)]
  [postgresql-guess-socket-path
   (-> path-string?)]
  [postgresql-password-hash
@@ -64,7 +53,7 @@
         #:port (or/c exact-positive-integer? #f)
         #:socket (or/c path-string? 'guess #f)
         #:notice-handler (or/c 'output 'error output-port? procedure?))
-       any/c)]
+       connection?)]
  [mysql-guess-socket-path
   (-> path-string?)]
  [mysql-password-hash
@@ -75,8 +64,9 @@
   (->* (#:database (or/c path-string? 'memory 'temporary))
        (#:mode (or/c 'read-only 'read/write 'create)
         #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0)
-        #:busy-retry-delay (and/c rational? (not/c negative?)))
-       any/c)]
+        #:busy-retry-delay (and/c rational? (not/c negative?))
+        #:use-place boolean?)
+       connection?)]
 
  ;; Duplicates contracts at odbc.rkt
  [odbc-connect
@@ -85,13 +75,15 @@
         #:password (or/c string? #f)
         #:notice-handler (or/c 'output 'error output-port? procedure?)
         #:strict-parameter-types? boolean?
-        #:character-mode (or/c 'wchar 'utf-8 'latin-1))
+        #:character-mode (or/c 'wchar 'utf-8 'latin-1)
+        #:use-place boolean?)
        connection?)]
  [odbc-driver-connect
   (->* (string?)
        (#:notice-handler (or/c 'output 'error output-port? procedure?)
         #:strict-parameter-types? boolean?
-        #:character-mode (or/c 'wchar 'utf-8 'latin-1))
+        #:character-mode (or/c 'wchar 'utf-8 'latin-1)
+        #:use-place boolean?)
        connection?)]
  [odbc-data-sources
   (-> (listof (list/c string? string?)))]

collects/db/mysql.rkt

@@ -13,7 +13,7 @@
         #:port (or/c exact-positive-integer? #f)
         #:socket (or/c path-string? 'guess #f)
         #:notice-handler (or/c 'output 'error output-port? procedure?))
-       any/c)]
+       connection?)]
  [mysql-guess-socket-path
   (-> path-string?)]
  [mysql-password-hash

collects/db/odbc.rkt

@@ -11,13 +11,15 @@
         #:password (or/c string? #f)
         #:notice-handler (or/c 'output 'error output-port? procedure?)
         #:strict-parameter-types? boolean?
-        #:character-mode (or/c 'wchar 'utf-8 'latin-1))
+        #:character-mode (or/c 'wchar 'utf-8 'latin-1)
+        #:use-place boolean?)
        connection?)]
  [odbc-driver-connect
   (->* (string?)
        (#:notice-handler (or/c 'output 'error output-port? procedure?)
         #:strict-parameter-types? boolean?
-        #:character-mode (or/c 'wchar 'utf-8 'latin-1))
+        #:character-mode (or/c 'wchar 'utf-8 'latin-1)
+        #:use-place boolean?)
        connection?)]
  [odbc-data-sources
   (-> (listof (list/c string? string?)))]

collects/db/postgresql.rkt

@@ -18,7 +18,7 @@
         #:ssl-context ssl-client-context?
         #:notice-handler (or/c 'output 'error output-port? procedure?)
         #:notification-handler (or/c 'output 'error output-port? procedure?))
-       any/c)]
+       connection?)]
  [postgresql-guess-socket-path
   (-> path-string?)]
  [postgresql-password-hash

collects/db/private/generic/connect-util.rkt

@@ -1,8 +1,11 @@
 #lang racket/base
-(require racket/contract
-         racket/class
-         "interfaces.rkt"
-         (only-in "functions.rkt" connection?))
+(require racket/class
+         "interfaces.rkt")
+(provide kill-safe-connection
+         virtual-connection
+         connection-pool
+         connection-pool?
+         connection-pool-lease)
 
 ;; manager% implements kill-safe manager thread w/ request channel
 (define manager%
@@ -22,7 +25,7 @@
            (loop)))))
 
     (define/public (call proc)
-      (thread-resume mthread)
+      (thread-resume mthread (current-thread))
       (let ([result #f]
             [sema (make-semaphore 0)])
         (channel-put req-channel
@@ -61,6 +64,7 @@
       (get-dbsystem)
       (query fsym stmt)
       (prepare fsym stmt close-on-exec?)
+      (get-base)
       (free-statement stmt)
       (transaction-status fsym)
       (start-transaction fsym isolation)
@@ -80,7 +84,7 @@
 ;; Virtual connection
 
 (define virtual-connection%
-  (class* object% (connection<%> no-cache-prepare<%>)
+  (class* object% (connection<%>)
     (init-private connector     ;; called from client thread
                   get-key       ;; called from client thread
                   timeout)
@@ -178,6 +182,9 @@
       (#f #f     (transaction-status fsym))
       (#t '_     (list-tables fsym schema)))
 
+    (define/public (get-base)
+      (get-connection #t))
+
     (define/public (disconnect)
       (let ([c (get-connection #f)]
             [key (get-key)])
@@ -187,7 +194,8 @@
       (void))
 
     (define/public (prepare fsym stmt close-on-exec?)
-      (unless close-on-exec?
+      ;; FIXME: hacky way of supporting virtual-statement
+      (unless (or close-on-exec? (eq? fsym 'virtual-statement))
         (error fsym "cannot prepare statement with virtual connection"))
       (send (get-connection #t) prepare fsym stmt close-on-exec?))
 
@@ -329,6 +337,7 @@
       (get-dbsystem)
       (query fsym stmt)
       (prepare fsym stmt close-on-exec?)
+      (get-base)
       (free-statement stmt)
       (transaction-status fsym)
       (start-transaction fsym isolation)
@@ -370,24 +379,3 @@
       (uerror 'connection-pool-lease
               "cannot obtain connection; connection pool limit reached"))
     result))
-
-;; ========================================
-
-(provide/contract
- [kill-safe-connection
-  (-> connection? connection?)]
- [virtual-connection
-  (->* ((or/c (-> connection?) connection-pool?))
-       ()
-       connection?)]
- [connection-pool
-  (->* ((-> connection?))
-       (#:max-connections (or/c (integer-in 1 10000) +inf.0)
-        #:max-idle-connections (or/c (integer-in 1 10000) +inf.0))
-       connection-pool?)]
- [connection-pool?
-  (-> any/c boolean?)]
- [connection-pool-lease
-  (->* (connection-pool?)
-       ((or/c custodian? evt?))
-       connection?)])

collects/db/private/generic/dsn.rkt

@@ -1,20 +1,26 @@
 #lang racket/base
-(require "lazy-require.rkt"
-         racket/contract
+(require unstable/lazy-require
          racket/match
          racket/file
-         racket/list
-         racket/runtime-path
-         racket/promise
-         "main.rkt")
+         racket/list)
+(provide dsn-connect
+         (struct-out data-source)
+         connector?
+         arglist?
+         writable-datum?
+         current-dsn-file
+         get-dsn
+         put-dsn
+         postgresql-data-source
+         mysql-data-source
+         sqlite3-data-source
+         odbc-data-source)
 
-(define-lazy-require-definer define-main "../../main.rkt")
-
-(define-main
-  postgresql-connect
-  mysql-connect
-  sqlite3-connect
-  odbc-connect)
+(lazy-require
+ ["../../main.rkt" (postgresql-connect
+                    mysql-connect
+                    sqlite3-connect
+                    odbc-connect)])
 
 #|
 DSN v0.1 format
@@ -47,15 +53,15 @@ considered important.
 
 (define none (gensym 'none))
 
-(define (datum? x)
+(define (writable-datum? x)
   (or (symbol? x)
       (string? x)
       (number? x)
       (boolean? x)
       (null? x)
       (and (pair? x)
-           (datum? (car x))
-           (datum? (cdr x)))))
+           (writable-datum? (car x))
+           (writable-datum? (cdr x)))))
 
 (define (connector? x)
   (memq x '(postgresql mysql sqlite3 odbc)))
@@ -72,11 +78,11 @@ considered important.
                      (reverse kwargs))]
               [(keyword? (car x))
                (cond [(null? (cdr x)) (fail "keyword without argument: ~a" (car x))]
-                     [(datum? (cadr x))
+                     [(writable-datum? (cadr x))
                       (loop (cddr x) pargs (cons (list (car x) (cadr x)) kwargs))]
                      [else
                       (fail "expected readable datum: ~e" (cadr x))])]
-              [(datum? (car x))
+              [(writable-datum? (car x))
                (loop (cdr x) (cons (car x) pargs) kwargs)]
               [else (fail "expected readable datum: ~e" (car x))]))
       (fail "expected list")))
@@ -93,7 +99,7 @@ considered important.
     (if (list? x)
         (map (lambda (x)
                (match x
-                 [(list (? symbol? key) (? datum? value))
+                 [(list (? symbol? key) (? writable-datum? value))
                   x]
                  [else (fail "expected extension entry: ~e" x)]))
              x)
@@ -189,60 +195,9 @@ considered important.
 
 (define sqlite3-data-source
   (mk-specialized 'sqlite3-data-source 'sqlite3 0
-                  '(#:database #:mode #:busy-retry-limit #:busy-retry-delay)))
+                  '(#:database #:mode #:busy-retry-limit #:busy-retry-delay #:use-place)))
 
 (define odbc-data-source
   (mk-specialized 'odbc-data-source 'odbc 0
                   '(#:dsn #:user #:password #:notice-handler
-                    #:strict-parameter-types? #:character-mode)))
-
-(provide/contract
- [struct data-source
-         ([connector connector?]
-          [args arglist?]
-          [extensions (listof (list/c symbol? datum?))])]
- [dsn-connect procedure?] ;; Can't express "or any kw at all" w/ ->* contract.
- [current-dsn-file (parameter/c path-string?)]
- [get-dsn
-  (->* (symbol?) (any/c #:dsn-file path-string?) any)]
- [put-dsn
-  (->* (symbol? (or/c data-source? #f)) (#:dsn-file path-string?) void?)]
- [postgresql-data-source
-  (->* ()
-       (#:user string?
-        #:database string?
-        #:server string?
-        #:port exact-positive-integer?
-        #:socket (or/c string? 'guess)
-        #:password (or/c string? #f)
-        #:allow-cleartext-password? boolean?
-        #:ssl (or/c 'yes 'optional 'no)
-        #:notice-handler (or/c 'output 'error)
-        #:notification-handler (or/c 'output 'error))
-       data-source?)]
- [mysql-data-source
-  (->* ()
-       (#:user string?
-        #:database string?
-        #:server string?
-        #:port exact-positive-integer?
-        #:socket (or/c string? 'guess)
-        #:password (or/c string? #f)
-        #:notice-handler (or/c 'output 'error))
-       data-source?)]
- [sqlite3-data-source
-  (->* ()
-       (#:database (or/c string? 'memory 'temporary)
-        #:mode (or/c 'read-only 'read/write 'create)
-        #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0)
-        #:busy-retry-delay (and/c rational? (not/c negative?)))
-       data-source?)]
- [odbc-data-source
-  (->* ()
-       (#:dsn string?
-        #:user string?
-        #:password string?
-        #:notice-handler (or/c 'output 'error)
-        #:strict-parameter-types? boolean?
-        #:character-mode (or/c 'wchar 'utf-8 'latin-1))
-       data-source?)])
+                    #:strict-parameter-types? #:character-mode #:use-place)))

collects/db/private/generic/functions.rkt

@@ -1,9 +1,10 @@
 #lang racket/base
 (require (for-syntax racket/base)
-         racket/contract
-         unstable/prop-contract
+         racket/vector
          racket/class
-         "interfaces.rkt")
+         "interfaces.rkt"
+         (only-in "sql-data.rkt" sql-null sql-null?))
+(provide (all-defined-out))
 
 ;; == Administrative procedures
 
@@ -40,9 +41,6 @@
       (statement-binding? x)
       (prop:statement? x)))
 
-(define complete-statement?
-  (or/c string? statement-binding?))
-
 (define (bind-prepared-statement pst params)
   (send pst bind 'bind-prepared-statement params))
 
@@ -61,14 +59,16 @@
 (struct virtual-statement (table gen)
         #:property prop:statement
         (lambda (stmt c)
-          (let ([table (virtual-statement-table stmt)]
-                [gen (virtual-statement-gen stmt)]
-                [cache? (not (is-a? c no-cache-prepare<%>))])
-            (let ([table-pst (hash-ref table c #f)])
+          (let* ([table (virtual-statement-table stmt)]
+                 [gen (virtual-statement-gen stmt)]
+                 [base-c (send c get-base)])
+            (let ([table-pst (and base-c (hash-ref table base-c #f))])
               (or table-pst
                   (let* ([sql-string (gen (send c get-dbsystem))]
-                         [pst (prepare1 'virtual-statement c sql-string (not cache?))])
-                    (when cache? (hash-set! table c pst))
+                         ;; FIXME: virtual-connection:prepare1 handles
+                         ;; fsym = 'virtual-statement case specially
+                         [pst (prepare1 'virtual-statement c sql-string #f)])
+                    (hash-set! table base-c pst)
                     pst))))))
 
 (define virtual-statement*
@@ -84,7 +84,7 @@
 (define (query1 c fsym stmt)
   (send c query fsym stmt))
 
-;; query/rows : connection symbol Statement nat/#f -> void
+;; query/rows : connection symbol Statement nat/#f -> rows-result
 (define (query/rows c fsym sql want-columns)
   (let [(result (query1 c fsym sql))]
     (unless (rows-result? result)
@@ -135,9 +135,19 @@
 ;; Query API procedures
 
 ;; query-rows : connection Statement arg ... -> (listof (vectorof 'a))
-(define (query-rows c sql . args)
-  (let ([sql (compose-statement 'query-rows c sql args 'rows)])
-    (rows-result-rows (query/rows c 'query-rows sql #f))))
+(define (query-rows c sql
+                    #:group [group-fields-list null]
+                    #:group-mode [group-mode null]
+                    . args)
+  (let* ([sql (compose-statement 'query-rows c sql args 'rows)]
+         [result (query/rows c 'query-rows sql #f)]
+         [result
+          (cond [(not (null? group-fields-list))
+                 (group-rows-result* 'query-rows result group-fields-list
+                                     (not (memq 'preserve-null-rows group-mode))
+                                     (memq 'list group-mode))]
+                [else result])])
+    (rows-result-rows result)))
 
 ;; query-list : connection Statement arg ... -> (listof 'a)
 ;; Expects to get back a rows-result with one field per row.
@@ -292,103 +302,146 @@
 
 ;; ========================================
 
-(define preparable/c (or/c string? virtual-statement?))
+(define (group-rows result
+                    #:group key-fields-list
+                    #:group-mode [group-mode null])
+  (when (null? key-fields-list)
+    (error 'group-rows "expected at least one grouping field set"))
+  (group-rows-result* 'group-rows
+                      result
+                      key-fields-list
+                      (not (memq 'preserve-null-rows group-mode))
+                      (memq 'list group-mode)))
 
-(provide (rename-out [in-query* in-query]))
+(define (group-rows-result* fsym result key-fields-list invert-outer? as-list?)
+  (let* ([key-fields-list
+          (if (list? key-fields-list) key-fields-list (list key-fields-list))]
+         [total-fields (length (rows-result-headers result))]
+         [name-map
+          (for/hash ([header (in-list (rows-result-headers result))]
+                     [i (in-naturals)]
+                     #:when (assq 'name header))
+            (values (cdr (assq 'name header)) i))]
+         [fields-used (make-vector total-fields #f)]
+         [key-indexes-list
+          (for/list ([key-fields (in-list key-fields-list)])
+            (for/vector ([key-field (in-vector key-fields)])
+              (let ([key-index
+                     (cond [(string? key-field)
+                            (hash-ref name-map key-field #f)]
+                           [else key-field])])
+                (when (string? key-field)
+                  (unless key-index
+                    (error fsym "grouping field ~s not found" key-field)))
+                (when (exact-integer? key-field)
+                  (unless (< key-index total-fields)
+                    (error fsym "grouping index ~s out of range [0, ~a]"
+                           key-index (sub1 total-fields))))
+                (when (vector-ref fields-used key-index)
+                  (error fsym "grouping field ~s~a used multiple times"
+                         key-field
+                         (if (string? key-field)
+                             (format " (index ~a)" key-index)
+                             "")))
+                (vector-set! fields-used key-index #t)
+                key-index)))]
+         [residual-length
+          (for/sum ([x (in-vector fields-used)])
+            (if x 0 1))])
+    (when (= residual-length 0)
+      (error fsym "cannot group by all fields"))
+    (when (and (> residual-length 1) as-list?)
+      (error fsym
+             "exactly one residual field expected for #:group-mode 'list, got ~a"
+             residual-length))
+    (let* ([initial-projection
+            (for/vector #:length total-fields ([i (in-range total-fields)]) i)]
+           [headers
+            (group-headers (list->vector (rows-result-headers result))
+                           initial-projection
+                           key-indexes-list)]
+           [rows
+            (group-rows* fsym
+                         (rows-result-rows result)
+                         initial-projection
+                         key-indexes-list
+                         invert-outer?
+                         as-list?)])
+      (rows-result headers rows))))
 
-(provide/contract
- [connection?
-  (-> any/c any)]
- [disconnect
-  (-> connection? any)]
- [connected?
-  (-> connection? any)]
- [connection-dbsystem
-  (-> connection? dbsystem?)]
- [dbsystem?
-  (-> any/c any)]
- [dbsystem-name
-  (-> dbsystem? symbol?)]
- [dbsystem-supported-types
-  (-> dbsystem? (listof symbol?))]
+(define (group-headers headers projection key-indexes-list)
+  (define (get-headers vec)
+    (for/list ([index (in-vector vec)])
+      (vector-ref headers index)))
+  (cond [(null? key-indexes-list)
+         (get-headers projection)]
+        [else
+         (let* ([key-indexes (car key-indexes-list)]
+                [residual-projection
+                 (vector-filter-not (lambda (index) (vector-member index key-indexes))
+                                    projection)]
+                [residual-headers
+                 (group-headers headers residual-projection (cdr key-indexes-list))])
+           (append (get-headers key-indexes)
+                   (list `((grouped . ,residual-headers)))))]))
 
- [statement?
-  (-> any/c any)]
- [prepared-statement?
-  (-> any/c any)]
- [prepared-statement-parameter-types
-  (-> prepared-statement? (or/c list? #f))]
- [prepared-statement-result-types
-  (-> prepared-statement? (or/c list? #f))]
+(define (group-rows* fsym rows projection key-indexes-list invert-outer? as-list?)
+  ;; projection is vector of indexes (actually projection and permutation)
+  ;; invert-outer? => residual rows with all NULL fields are dropped.
+  (cond [(null? key-indexes-list)
+         ;; Apply projection to each row
+         (cond [as-list?
+                (unless (= (vector-length projection) 1)
+                  (error/internal
+                   fsym 
+                   "list mode requires a single residual column, got ~s"
+                   (vector-length projection)))
+                (let ([index (vector-ref projection 0)])
+                  (for/list ([row (in-list rows)])
+                    (vector-ref row index)))]
+               [else
+                (let ([plen (vector-length projection)])
+                  (for/list ([row (in-list rows)])
+                    (let ([v (make-vector plen)])
+                      (for ([i (in-range plen)])
+                        (vector-set! v i (vector-ref row (vector-ref projection i))))
+                      v)))])]
+        [else
+         (let ()
+           (define key-indexes (car key-indexes-list))
+           (define residual-projection
+             (vector-filter-not (lambda (index) (vector-member index key-indexes))
+                                projection))
 
- [query-exec
-  (->* (connection? statement?) () #:rest list? any)]
- [query-rows
-  (->* (connection? statement?) () #:rest list? (listof vector?))]
- [query-list
-  (->* (connection? statement?) () #:rest list? list?)]
- [query-row
-  (->* (connection? statement?) () #:rest list? vector?)]
- [query-maybe-row
-  (->* (connection? statement?) () #:rest list? (or/c #f vector?))]
- [query-value
-  (->* (connection? statement?) () #:rest list? any)]
- [query-maybe-value
-  (->* (connection? statement?) () #:rest list? any)]
- [query
-  (->* (connection? statement?) () #:rest list? any)]
+           (define key-row-length (vector-length key-indexes))
+           (define (row->key-row row)
+             (for/vector #:length key-row-length
+                         ([i (in-vector key-indexes)])
+                         (vector-ref row i)))
 
- #|
- [in-query
-  (->* (connection? statement?) () #:rest list? sequence?)]
- |#
+           (define (residual-all-null? row)
+             (for/and ([i (in-vector residual-projection)])
+                      (sql-null? (vector-ref row i))))
 
- [prepare
-  (-> connection? preparable/c any)]
- [bind-prepared-statement
-  (-> prepared-statement? list? any)]
-
- [rename virtual-statement* virtual-statement
-  (-> (or/c string? (-> dbsystem? string?))
-      virtual-statement?)]
- [virtual-statement?
-  (-> any/c boolean?)]
-
- [start-transaction
-  (->* (connection?)
-       (#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f))
-       void?)]
- [commit-transaction
-  (-> connection? void?)]
- [rollback-transaction
-  (-> connection? void?)]
- [in-transaction?
-  (-> connection? boolean?)]
- [needs-rollback?
-  (-> connection? boolean?)]
- [call-with-transaction
-  (->* (connection? (-> any))
-       (#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f))
-       void?)]
-
- [prop:statement
-  (struct-type-property/c
-   (-> any/c connection?
-       statement?))]
-
- [list-tables
-  (->* (connection?)
-       (#:schema (or/c 'search-or-current 'search 'current))
-       (listof string?))]
- [table-exists?
-  (->* (connection? string?)
-       (#:schema (or/c 'search-or-current 'search 'current)
-        #:case-sensitive? any/c)
-       boolean?)]
-
-#|
- [get-schemas
-  (-> connection? (listof vector?))]
- [get-tables
-  (-> connection? (listof vector?))]
-|#)
+           (let* ([key-table (make-hash)]
+                  [r-keys
+                   (for/fold ([r-keys null])
+                       ([row (in-list rows)])
+                     (let* ([key-row (row->key-row row)]
+                            [already-seen? (and (hash-ref key-table key-row #f) #t)])
+                       (unless already-seen?
+                         (hash-set! key-table key-row null))
+                       (unless (and invert-outer? (residual-all-null? row))
+                         (hash-set! key-table key-row (cons row (hash-ref key-table key-row))))
+                       (if already-seen?
+                           r-keys
+                           (cons key-row r-keys))))])
+             (for/list ([key (in-list (reverse r-keys))])
+               (let ([residuals
+                      (group-rows* fsym
+                                   (reverse (hash-ref key-table key))
+                                   residual-projection
+                                   (cdr key-indexes-list)
+                                   invert-outer?
+                                   as-list?)])
+                 (vector-append key (vector residuals))))))]))

collects/db/private/generic/interfaces.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require racket/class)
+(require racket/class
+         ffi/unsafe/atomic)
 (provide connection<%>
          dbsystem<%>
          prepared-statement<%>
@@ -13,9 +14,6 @@
 
          define-type-table
 
-         no-cache-prepare<%>
-         connector<%>
-
          locking%
          transactions%
 
@@ -42,21 +40,12 @@
     get-dbsystem  ;; -> dbsystem<%>
     query         ;; symbol statement -> QueryResult
     prepare       ;; symbol preparable boolean -> prepared-statement<%>
-
+    get-base      ;; -> connection<%> or #f (#f means base isn't fixed)
+    list-tables   ;; symbol symbol -> (listof string)
     start-transaction  ;; symbol (U 'serializable ...) -> void
     end-transaction    ;; symbol (U 'commit 'rollback) -> void
     transaction-status ;; symbol -> (U boolean 'invalid)
-
-    list-tables ;; symbol symbol -> (listof string)
-
-    free-statement)) ;; prepared-statement<%> -> void
-
-;; no-cache-prepare<%>
-;; Interface to identify connections such as connection-generators:
-;; prepare method must be called with close-on-exec? = #t and result must
-;; not be cached.
-(define no-cache-prepare<%>
-  (interface ()))
+    free-statement))   ;; prepared-statement<%> -> void
 
 ;; ==== DBSystem
 
@@ -102,7 +91,6 @@
 
     ;; extension hooks: usually shouldn't need to override
     finalize           ;; -> void
-    register-finalizer ;; -> void
 
     ;; inspection only
     get-param-types    ;; -> (listof TypeDesc)
@@ -176,16 +164,6 @@
         (list ok? t x)))))
 
 
-;; == Internal staging interfaces
-
-;; connector<%>
-;; Manages making connections
-(define connector<%>
-  (interface ()
-    attach-to-ports            ;; input-port output-port -> void
-    start-connection-protocol  ;; string string string/#f -> void
-    ))
-
 ;; == Notice/notification handler maker
 
 ;; make-handler : output-port/symbol string -> string string -> void
@@ -211,27 +189,33 @@
 
 ;; Connection base class (locking)
 
-;; Disabled for now, because this is an 80% solution. Unfortunately, I
-;; think a 100% solution would require an auxiliary kill-safe thread
-;; with multiple thread switches *per lock acquisition*. At that
-;; point, might as well just use kill-safe connection.
-(define USE-LOCK-HOLDER? #f)
-
 (define locking%
   (class object%
 
     ;; == Communication locking
 
-    (define lock (make-semaphore 1))
-
-    ;; Ideally, we would like to be able to detect if a thread has
+    ;; Goal: we would like to be able to detect if a thread has
     ;; acquired the lock and then died, leaving the connection
-    ;; permanently locked. Roughly, we would like this: if lock is
-    ;; held by thread th, then lock-holder = (thread-dead-evt th), 
-    ;; and if lock is not held, then lock-holder = never-evt.
-    ;; Unfortunately, there are intervals when this is not true.
-    ;; Also, since lock-holder changes, reference might be stale, so
-    ;; need to double-check.
+    ;; permanently locked.
+    ;;
+    ;; lock-holder=(thread-dead-evt thd) iff thd has acquired inner-lock
+    ;;  - lock-holder, inner-lock always modified together within
+    ;;    atomic block
+    ;;
+    ;; Thus if (thread-dead-evt thd) is ready, thd died holding
+    ;; inner-lock, so hopelessly locked.
+    ;;
+    ;; outer-sema = inner-lock
+    ;;  - outer-sema, inner-lock always modified together within atomic
+    ;;
+    ;; The outer-lock just prevents threads from spinning polling
+    ;; inner-lock. If a thread gets past outer-lock and dies before
+    ;; acquiring inner-lock, ok, because outer-lock still open at that
+    ;; point, so other threads can enter outer-lock and acquire inner-lock.
+
+    (define outer-sema (make-semaphore 1))
+    (define outer-lock (semaphore-peek-evt outer-sema))
+    (define inner-lock (make-semaphore 1))
     (define lock-holder never-evt)
 
     ;; Delay async calls (eg, notice handler) until unlock
@@ -243,21 +227,32 @@
       (call-with-lock* who proc #f #t))
 
     (define/public-final (call-with-lock* who proc hopeless require-connected?)
-      (let* ([me (thread-dead-evt (current-thread))]
-             [result (sync lock lock-holder)])
-        (cond [(eq? result lock)
-               ;; Acquired lock
-               (when USE-LOCK-HOLDER? (set! lock-holder me))
-               (when (and require-connected? (not (connected?)))
-                 (semaphore-post lock)
-                 (error/not-connected who))
-               (with-handlers ([values (lambda (e) (unlock) (raise e))])
-                 (begin0 (proc) (unlock)))]
+      (let ([me (thread-dead-evt (current-thread))]
+            [result (sync outer-lock lock-holder)])
+        (cond [(eq? result outer-lock)
+               ;; Got past outer stage
+               (let ([proceed?
+                      (begin (start-atomic)
+                             (let ([proceed? (semaphore-try-wait? inner-lock)])
+                               (when proceed?
+                                 (set! lock-holder me)
+                                 (semaphore-wait outer-sema))
+                               (end-atomic)
+                               proceed?))])
+                 (cond [proceed?
+                        ;; Acquired lock
+                        ;;  - lock-holder = me, and outer-lock is closed again
+                        (when (and require-connected? (not (connected?)))
+                          (unlock)
+                          (error/not-connected who))
+                        (with-handlers ([values (lambda (e) (unlock) (raise e))])
+                          (begin0 (proc) (unlock)))]
+                       [else
+                        ;; Didn't acquire lock; retry
+                        (call-with-lock* who proc hopeless require-connected?)]))]
               [(eq? result lock-holder)
                ;; Thread holding lock is dead
-               (if hopeless
-                   (hopeless)
-                   (error/hopeless who))]
+               (if hopeless (hopeless) (error/hopeless who))]
               [else
                ;; lock-holder was stale; retry
                (call-with-lock* who proc hopeless require-connected?)])))
@@ -265,8 +260,11 @@
     (define/private (unlock)
       (let ([async-calls (reverse delayed-async-calls)])
         (set! delayed-async-calls null)
-        (when USE-LOCK-HOLDER? (set! lock-holder never-evt))
-        (semaphore-post lock)
+        (start-atomic)
+        (set! lock-holder never-evt)
+        (semaphore-post inner-lock)
+        (semaphore-post outer-sema)
+        (end-atomic)
         (for-each call-with-continuation-barrier async-calls)))
 
     ;; needs overriding

collects/db/private/generic/lazy-require.rkt

@@ -1,38 +0,0 @@
-#lang racket/base
-(require (for-syntax racket/base)
-         racket/runtime-path
-         racket/promise)
-(provide define-lazy-require-definer)
-
-(define-syntax (define-lazy-require-definer stx)
-  (syntax-case stx ()
-    [(_ name modpath)
-     (begin
-       (unless (identifier? #'name)
-         (raise-syntax-error #f "expected identifier" stx #'name))
-       #'(begin (define-runtime-module-path-index mpi-var modpath)
-                (define-syntax name (make-lazy-require-definer #'mpi-var))))]))
-
-(define-for-syntax (make-lazy-require-definer mpi-var)
-  (lambda (stx)
-    (syntax-case stx ()
-      [(_ fun ...)
-       (begin
-         (for ([fun (in-list (syntax->list #'(fun ...)))])
-           (unless (identifier? fun)
-             (raise-syntax-error #f "expected identifier for function name" stx fun)))
-         (with-syntax ([(fun-p ...) (generate-temporaries #'(fun ...))]
-                       [mpi-var mpi-var])
-           ;; Use 'delay/sync' because 'delay' promise is not reentrant.
-           ;; FIXME: OTOH, 'delay/sync' promise is not kill-safe.
-           #'(begin (define fun-p (delay/sync (dynamic-require mpi-var 'fun)))
-                    ...
-                    (define fun (make-delayed-function 'fun fun-p))
-                    ...)))])))
-
-(define (make-delayed-function name fun-p)
-  (procedure-rename
-   (make-keyword-procedure
-    (lambda (kws kwargs . args)
-      (keyword-apply (force fun-p) kws kwargs args)))
-   name))

collects/db/private/generic/main.rkt

@@ -1,68 +0,0 @@
-#lang racket/base
-(require racket/contract
-         "interfaces.rkt"
-         "sql-data.rkt"
-         "functions.rkt")
-(provide (struct-out simple-result)
-         (struct-out rows-result)
-         statement-binding?
-         (all-from-out "functions.rkt"))
-
-(provide sql-null
-         sql-null?
-         sql-null->false
-         false->sql-null)
-
-(provide/contract
- [struct sql-date ([year exact-integer?]
-                   [month (integer-in 0 12)]
-                   [day (integer-in 0 31)])]
- [struct sql-time ([hour (integer-in 0 23)]
-                   [minute (integer-in 0 59)]
-                   [second (integer-in 0 61)] ;; leap seconds
-                   [nanosecond (integer-in 0 (sub1 #e1e9))]
-                   [tz (or/c #f exact-integer?)])]
- [struct sql-timestamp ([year exact-integer?]
-                        [month (integer-in 0 12)]
-                        [day (integer-in 0 31)]
-                        [hour (integer-in 0 23)]
-                        [minute (integer-in 0 59)]
-                        [second (integer-in 0 61)]
-                        [nanosecond (integer-in 0 (sub1 #e1e9))]
-                        [tz (or/c #f exact-integer?)])]
- [struct sql-interval ([years exact-integer?]
-                       [months exact-integer?]
-                       [days exact-integer?]
-                       [hours exact-integer?]
-                       [minutes exact-integer?]
-                       [seconds exact-integer?]
-                       [nanoseconds exact-integer?])]
-
- [sql-day-time-interval?
-  (-> any/c boolean?)]
- [sql-year-month-interval?
-  (-> any/c boolean?)]
- [sql-interval->sql-time
-  (->* (sql-interval?) (any/c)
-       any)]
- [sql-time->sql-interval
-  (-> sql-time? sql-day-time-interval?)]
-
- [make-sql-bits
-  (-> exact-nonnegative-integer? sql-bits?)]
- [sql-bits?
-  (-> any/c boolean?)]
- [sql-bits-length
-  (-> sql-bits? exact-nonnegative-integer?)]
- [sql-bits-ref
-  (-> sql-bits? exact-nonnegative-integer? boolean?)]
- [sql-bits-set!
-  (-> sql-bits? exact-nonnegative-integer? boolean? void?)]
- [sql-bits->list
-  (-> sql-bits? (listof boolean?))]
- [list->sql-bits
-  (-> (listof boolean?) sql-bits?)]
- [sql-bits->string
-  (-> sql-bits? string?)]
- [string->sql-bits
-  (-> string? sql-bits?)])

collects/db/private/generic/place-client.rkt

@@ -0,0 +1,107 @@
+#lang racket/base
+(require racket/class
+         racket/match
+         racket/place
+         racket/promise
+         racket/vector
+         racket/serialize
+         ffi/unsafe/atomic
+         "interfaces.rkt"
+         "prepared.rkt"
+         "sql-data.rkt")
+(provide place-connect
+         place-proxy-connection%)
+
+(define (pchan-put chan datum)
+  (place-channel-put chan (serialize datum)))
+(define (pchan-get chan)
+  (deserialize (place-channel-get chan)))
+
+(define connection-server-channel
+  (delay/sync
+   (dynamic-place 'db/private/generic/place-server 'connection-server)))
+
+(define (place-connect connection-spec proxy%)
+  (let-values ([(channel other-channel) (place-channel)])
+    (place-channel-put (force connection-server-channel)
+                       (list 'connect other-channel connection-spec))
+    (match (pchan-get channel)
+      [(list 'ok)
+       (new proxy% (channel channel))]
+      [(list 'error message)
+       (raise (make-exn:fail message (current-continuation-marks)))])))
+
+(define place-proxy-connection%
+  (class* locking% (connection<%>)
+    (init-field channel)
+    (inherit call-with-lock
+             call-with-lock*)
+    (super-new)
+
+    (define/private (call method-name . args)
+      (call-with-lock method-name (lambda () (call* method-name args #t))))
+    (define/private (call/d method-name . args)
+      (call-with-lock* method-name (lambda () (call* method-name args #f)) #f #f))
+    (define/private (call* method-name args need-connected?)
+      (cond [channel
+             (pchan-put channel (cons method-name args))
+             (match (pchan-get channel)
+               [(cons 'values vals)
+                (apply values (for/list ([val (in-list vals)]) (sexpr->result val)))]
+               [(list 'error message)
+                (raise (make-exn:fail message (current-continuation-marks)))])]
+            [need-connected?
+             (unless channel
+               (error/not-connected method-name))]
+            [else (void)]))
+
+    (define/override (connected?)
+      ;; FIXME: can underlying connection disconnect w/o us knowing?
+      (and channel #t))
+
+    (define/public (disconnect)
+      (call/d 'disconnect)
+      (set! channel #f))
+
+    (define/public (get-dbsystem) (error 'get-dbsystem "not implemented"))
+    (define/public (get-base) this)
+
+    (define/public (query fsym stmt)
+      (call 'query fsym
+            (match stmt
+              [(? string?) (list 'string stmt)]
+              [(statement-binding pst meta params)
+               (list 'statement-binding (send pst get-handle) meta params)])))
+    (define/public (prepare fsym stmt close-on-exec?)
+      (call 'prepare fsym stmt close-on-exec?))
+    (define/public (transaction-status fsym)
+      (call 'transaction-status fsym))
+    (define/public (start-transaction fsym iso)
+      (call 'start-transaction fsym iso))
+    (define/public (end-transaction fsym mode)
+      (call 'end-transaction fsym mode))
+    (define/public (list-tables fsym schema)
+      (call 'list-tables fsym schema))
+
+    (define/public (free-statement pst)
+      (start-atomic)
+      (let ([handle (send pst get-handle)])
+        (send pst set-handle #f)
+        (end-atomic)
+        (when channel
+          (call/d 'free-statement handle))))
+
+    (define/private (sexpr->result x)
+      (match x
+        [(list 'simple-result y)
+         (simple-result y)]
+        [(list 'rows-result h rows)
+         (rows-result h rows)]
+        [(list 'prepared-statement handle close-on-exec? param-typeids result-dvecs)
+         (new prepared-statement%
+              (handle handle)
+              (close-on-exec? close-on-exec?)
+              (param-typeids param-typeids)
+              (result-dvecs result-dvecs)
+              (owner this))]
+        [_ x]))))

collects/db/private/generic/place-server.rkt

@@ -0,0 +1,142 @@
+#lang racket/base
+(require (for-syntax racket/base)
+         racket/class
+         racket/match
+         racket/place
+         racket/serialize
+         unstable/lazy-require
+         "interfaces.rkt"
+         "prepared.rkt"
+         "sql-data.rkt"
+         "place-client.rkt")
+(provide connection-server)
+
+(define (pchan-put chan datum)
+  (place-channel-put chan (serialize datum)))
+(define (pchan-get chan)
+  (deserialize (place-channel-get chan)))
+
+#|
+Connection creation protocol
+
+client -> server on client-chan: (list 'connect conn-chan <connect-options>)
+server -> client on conn-chan:   (or (list 'ok)
+                                     (list 'error string))
+
+where <connect-spec> ::= (list 'sqlite3 path/sym mode-sym delay-num limit-num)
+                      |  (list 'odbc string string/#f string/#f boolean symbol)
+|#
+(define (connection-server client-chan)
+  (let loop ()
+    (serve client-chan)
+    (loop)))
+
+(lazy-require
+ ["../../main.rkt" (sqlite3-connect
+                    odbc-connect
+                    odbc-driver-connect)])
+
+(define (serve client-chan)
+  (match (place-channel-get client-chan)
+    [(list 'connect conn-chan connect-spec)
+     (with-handlers ([exn:fail?
+                      (lambda (e)
+                        (pchan-put conn-chan (list 'error (exn-message e))))])
+       (let* ([c
+               (match connect-spec
+                 [(list 'sqlite3 db mode busy-retry-delay busy-retry-limit)
+                  (sqlite3-connect #:database db
+                                   #:mode mode
+                                   #:busy-retry-delay busy-retry-delay
+                                   #:busy-retry-limit busy-retry-limit
+                                   #:use-place #f)]
+                 [(list 'odbc dsn user password strict-param? char-mode)
+                  (odbc-connect #:dsn dsn
+                                #:user user
+                                #:password password
+                                #:strict-parameter-types? strict-param?
+                                #:character-mode char-mode
+                                #:use-place #f)]
+                 [(list 'odbc-driver connection-string strict-param? char-mode)
+                  (odbc-driver-connect connection-string
+                                       #:strict-parameter-types? strict-param?
+                                       #:character-mode char-mode
+                                       #:use-place #f)])]
+              [p (new proxy-server% (connection c) (channel conn-chan))])
+         (pchan-put conn-chan (list 'ok))
+         (thread (lambda () (send p serve)))))]))
+
+#|
+Connection methods protocol
+
+client -> server: (list '<method-name> arg ...)
+server -> client: (or (list 'values result ...)
+                      (list 'error string))
+|#
+
+(define proxy-server%
+  (class object%
+    (init-field connection
+                channel)
+    (super-new)
+
+    (define pstmt-table (make-hash)) ;; int => prepared-statement
+    (define pstmt-counter 0)
+
+    (define/public (serve)
+      (serve1)
+      (when connection (serve)))
+
+    (define/private (serve1)
+      (with-handlers ([exn?
+                       (lambda (e)
+                         (pchan-put channel (list 'error (exn-message e))))])
+        (call-with-values
+            (lambda ()
+              (match (pchan-get channel)
+                [(list 'disconnect)
+                 (send connection disconnect)
+                 (set! connection #f)]
+                [(list 'free-statement pstmt-index)
+                 (send connection free-statement (hash-ref pstmt-table pstmt-index))
+                 (hash-remove! pstmt-table pstmt-index)]
+                [(list 'query fsym stmt)
+                 (send connection query fsym (sexpr->statement stmt))]
+                [msg
+                 (define-syntax-rule (forward-methods (method arg ...) ...)
+                   (match msg
+                     [(list 'method arg ...)
+                      (send connection method arg ...)]
+                     ...))
+                 (forward-methods (connected?)
+                                  (prepare w s m)
+                                  (list-tables w s)
+                                  (start-transaction w m)
+                                  (end-transaction w m)
+                                  (transaction-status w))]))
+          (lambda results
+            (let ([results (for/list ([result (in-list results)]) (result->sexpr result))])
+              (pchan-put channel (cons 'values results)))))))
+
+    (define/private (sexpr->statement x)
+      (match x
+        [(list 'string s) s]
+        [(list 'statement-binding pstmt-index meta args)
+         (statement-binding (hash-ref pstmt-table pstmt-index) meta args)]))
+
+    (define/private (result->sexpr x)
+      (match x
+        [(simple-result y)
+         (list 'simple-result y)]
+        [(rows-result h rows)
+         (list 'rows-result h rows)]
+        ;; FIXME: Assumes prepared-statement is concrete class, not interface.
+        [(? (lambda (x) (is-a? x prepared-statement%)))
+         (let ([pstmt-index (begin (set! pstmt-counter (add1 pstmt-counter)) pstmt-counter)])
+           (hash-set! pstmt-table pstmt-index x)
+           (list 'prepared-statement
+                 pstmt-index
+                 (get-field close-on-exec? x)
+                 (get-field param-typeids x)
+                 (get-field result-dvecs x)))]
+        [_ x]))))

collects/db/private/generic/prepared.rkt

@@ -8,10 +8,10 @@
 ;; prepared-statement%
 (define prepared-statement%
   (class* object% (prepared-statement<%>)
-    (init-private handle            ;; handle, determined by database system, #f means closed
-                  close-on-exec?    ;; boolean
-                  param-typeids     ;; (listof typeid)
-                  result-dvecs)     ;; (listof vector), layout depends on dbsys
+    (init-field handle            ;; handle, determined by database system, #f means closed
+                close-on-exec?    ;; boolean
+                param-typeids     ;; (listof typeid)
+                result-dvecs)     ;; (listof vector), layout depends on dbsys
     (init ([-owner owner]))
 
     (define owner (make-weak-box -owner))
@@ -81,7 +81,7 @@
           (send owner free-statement this))))
 
     (define/public (register-finalizer)
-      (thread-resume finalizer-thread)
+      (thread-resume finalizer-thread (current-thread))
       (will-register will-executor this (lambda (pst) (send pst finalize))))
 
     (super-new)

collects/db/private/generic/sql-convert.rkt

@@ -1,5 +1,4 @@
 #lang racket/base
-(require "sql-data.rkt")
 
 ;; ========================================
 

collects/db/private/generic/sql-data.rkt

@@ -1,4 +1,5 @@
 #lang racket/base
+(require racket/serialize)
 (provide (all-defined-out))
 
 ;; SQL Data
@@ -10,8 +11,15 @@
 
 (define sql-null
   (let ()
-    (define-struct sql-null ())
-    (make-sql-null)))
+    (struct sql-null ()
+            ;; must deserialize to singleton, so can't just use serializable-struct
+            #:property prop:serializable
+            (make-serialize-info (lambda _ '#())
+                                 #'deserialize-info:sql-null-v0
+                                 #f
+                                 (or (current-load-relative-directory)
+                                     (current-directory))))
+    (sql-null)))
 
 (define (sql-null? x)
   (eq? x sql-null))
@@ -26,6 +34,11 @@
       sql-null
       x))
 
+(define deserialize-info:sql-null-v0
+  (make-deserialize-info
+   (lambda _ sql-null)
+   (lambda () (error 'deserialize-sql-null "cannot have cycles"))))
+
 ;; ----------------------------------------
 
 ;; Dates and times
@@ -44,15 +57,15 @@
  - timezone offset too limited
 |#
 
-(define-struct sql-date (year month day) #:transparent)
-(define-struct sql-time (hour minute second nanosecond tz) #:transparent)
-(define-struct sql-timestamp
+(define-serializable-struct sql-date (year month day) #:transparent)
+(define-serializable-struct sql-time (hour minute second nanosecond tz) #:transparent)
+(define-serializable-struct sql-timestamp
   (year month day hour minute second nanosecond tz) 
   #:transparent)
 
 ;; Intervals must be "pre-multiplied" rather than carry extra sign field.
 ;; Rationale: postgresql, at least, allows mixture of signs, eg "1 month - 30 days"
-(define-struct sql-interval
+(define-serializable-struct sql-interval
   (years months days hours minutes seconds nanoseconds)
   #:transparent
   #:guard (lambda (years months days hours minutes seconds nanoseconds _name)
@@ -131,7 +144,7 @@ byte. (Because that's PostgreSQL's binary format.) For example:
 
   (bytes 128 3) represents 1000000 0000011
 |#
-(struct sql-bits (length bv offset))
+(serializable-struct sql-bits (length bv offset))
 
 (define (make-sql-bits len)
   (sql-bits len (make-bytes (/ceiling len 8) 0) 0))

collects/db/private/mysql/connection.rkt

@@ -356,6 +356,8 @@
           [(? field-packet?)
            (cons (parse-field-dvec r) (prepare1:get-field-descriptions fsym))])))
 
+    (define/public (get-base) this)
+
     (define/public (free-statement pst)
       (call-with-lock* 'free-statement
         (lambda ()

collects/db/private/mysql/main.rkt

@@ -1,16 +1,13 @@
 #lang racket/base
-(require racket/contract
-         racket/class
+(require racket/class
          racket/tcp
          file/sha1
          "../generic/interfaces.rkt"
          "../generic/socket.rkt"
-         "connection.rkt"
-         "dbsystem.rkt")
+         "connection.rkt")
 (provide mysql-connect
          mysql-guess-socket-path
-         mysql-password-hash
-         (rename-out [dbsystem mysql-dbsystem]))
+         mysql-password-hash)
 
 (define (mysql-connect #:user user
                        #:database database

collects/db/private/odbc/connection.rkt

@@ -3,6 +3,7 @@
          racket/list
          racket/math
          ffi/unsafe
+         ffi/unsafe/atomic
          "../generic/interfaces.rkt"
          "../generic/prepared.rkt"
          "../generic/sql-data.rkt"
@@ -24,7 +25,7 @@
                   char-mode)
     (init strict-parameter-types?)
 
-    (define statement-table (make-weak-hasheq))
+    (define statement-table (make-hasheq))
     (define lock (make-semaphore 1))
 
     (define use-describe-param?
@@ -437,13 +438,14 @@
 
     (define/public (disconnect)
       (define (go)
+        (start-atomic)
         (let ([db* db]
               [env* env])
+          (set! db #f)
+          (set! env #f)
+          (end-atomic)
           (when db*
             (let ([statements (hash-map statement-table (lambda (k v) k))])
-              (set! db #f)
-              (set! env #f)
-              (set! statement-table #f)
               (for ([pst (in-list statements)])
                 (free-statement* 'disconnect pst))
               (handle-status 'disconnect (SQLDisconnect db*) db*)
@@ -452,16 +454,21 @@
               (void)))))
       (call-with-lock* 'disconnect go go #f))
 
+    (define/public (get-base) this)
+
     (define/public (free-statement pst)
       (define (go) (free-statement* 'free-statement pst))
       (call-with-lock* 'free-statement go go #f))
 
     (define/private (free-statement* fsym pst)
+      (start-atomic)
       (let ([stmt (send pst get-handle)])
+        (send pst set-handle #f)
+        (end-atomic)
         (when stmt
-          (send pst set-handle #f)
           (handle-status 'free-statement (SQLFreeStmt stmt SQL_CLOSE) stmt)
           (handle-status 'free-statement (SQLFreeHandle SQL_HANDLE_STMT stmt) stmt)
+          (hash-remove! statement-table pst)
           (void))))
 
     ;; Transactions
@@ -654,3 +661,19 @@
 
 (define (field-dvec->typeid dvec)
   (vector-ref dvec 1))
+
+#|
+Historical note: I tried using ODBC async execution to avoid blocking
+all Racket threads for a long time.
+
+1) The postgresql, mysql, and oracle drivers don't even support async
+execution. Only DB2 (and probably SQL Server, but I didn't try it).
+
+2) Tests using the DB2 driver gave bafflind HY010 (function sequence
+error). My best theory so far is that DB2 (or maybe unixodbc) requires
+poll call arguments to be identical to original call arguments, which
+means that I would have to replace all uses of (_ptr o X) with
+something stable across invocations.
+
+All in all, not worth it, especially given #:use-place solution.
+|#

collects/db/private/odbc/dbsystem.rkt

@@ -1,11 +1,8 @@
 #lang racket/base
 (require racket/class
-         ffi/unsafe
-         ffi/unsafe/atomic
          "../generic/interfaces.rkt"
          "../generic/sql-data.rkt"
-         "../generic/sql-convert.rkt"
-         "ffi.rkt")
+         "../generic/sql-convert.rkt")
 (provide dbsystem
          supported-typeid?)
 

collects/db/private/odbc/ffi.rkt

@@ -1,6 +1,5 @@
 #lang racket/base
-(require (rename-in racket/contract [-> c->])
-         ffi/unsafe
+(require ffi/unsafe
          ffi/unsafe/define
          "ffi-constants.rkt")
 (provide (all-from-out "ffi-constants.rkt"))
@@ -21,11 +20,6 @@
 (define _sqluinteger _uint)
 (define _sqlreturn _sqlsmallint)
 
-;; Windows ODBC defines wchar_t, thus WCHAR, as 16-bit
-;; unixodbc defines WCHAR as 16-bit for compat w/ Windows
-;; (even though Linux wchar_t is 32-bit)
-(define WCHAR-SIZE 2)
-
 (define-ffi-definer define-mz #f)
 
 (define-mz scheme_utf16_to_ucs4
@@ -119,10 +113,28 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
 (define odbc-lib
   (case (system-type)
     ((windows) (ffi-lib "odbc32.dll"))
-    (else (ffi-lib "libodbc" '("1" #f)))))
+    ((macosx)  (ffi-lib "libiodbc" '("2" #f)))
+    ((unix)    (ffi-lib "libodbc" '("1" #f)))))
+
+(define WCHAR-SIZE
+  (case (system-type)
+    ((windows)
+     ;; Windows ODBC defines wchar_t, thus WCHAR, thus SQLWCHAR, as 16-bit
+     2)
+    ((macosx)
+     ;; MacOSX uses iodbc, which defines SQLWCHAR as wchar_t, as 32-bit
+     4)
+    ((unix)
+     ;; unixodbc defines WCHAR as 16-bit for compat w/ Windows
+     ;; (even though Linux wchar_t is 32-bit)
+     2)))
 
 (define-ffi-definer define-odbc odbc-lib)
 
+(define (ok-status? n)
+  (or (= n SQL_SUCCESS)
+      (= n SQL_SUCCESS_WITH_INFO)))
+
 (define-odbc SQLAllocHandle
   (_fun (type : _sqlsmallint)
         (parent : _sqlhandle/null)
@@ -168,7 +180,8 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
                      (len : (_ptr o _sqlsmallint))
                      -> (status : _sqlreturn)
                      -> (values status
-                                (bytes->string/utf-8 value #f 0 len)))))
+                                (and (ok-status? status)
+                                     (bytes->string/utf-8 value #f 0 len))))))
 
 (define-odbc SQLGetFunctions
   (_fun (handle : _sqlhdbc)
@@ -211,7 +224,7 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
         (out-len : (_ptr o _sqlsmallint))
         -> (status : _sqlreturn)
         -> (values status
-                   (and (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO))
+                   (and (ok-status? status)
                         (bytes->string/utf-8 out-buf #f 0 out-len)))))
 
 (define-odbc SQLDataSources
@@ -226,9 +239,9 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
         (descr-length : (_ptr o _sqlsmallint))
         -> (status : _sqlreturn)
         -> (values status
-                   (and (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO))
+                   (and (ok-status? status)
                         (bytes->string/utf-8 server-buf #f 0 server-length))
-                   (and (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO))
+                   (and (ok-status? status)
                         (bytes->string/utf-8 descr-buf #f 0 descr-length)))))
 
 (define-odbc SQLDrivers
@@ -242,7 +255,7 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
         ((if attrs-buf (bytes-length attrs-buf) 0) : _sqlsmallint)
         (attrs-length : (_ptr o _sqlsmallint))
         -> (status : _sqlreturn)
-        -> (if (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO))
+        -> (if (ok-status? status)
                (values status
                        (bytes->string/utf-8 driver-buf #f 0 driver-length)
                        attrs-length)
@@ -308,7 +321,8 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
         (nullable : (_ptr o _sqlsmallint))
         -> (status : _sqlreturn)
         -> (values status
-                   (bytes->string/utf-8 column-buf #f 0 column-len)
+                   (and (ok-status? status)
+                        (bytes->string/utf-8 column-buf #f 0 column-len))
                    data-type size digits nullable)))
 
 (define-odbc SQLFetch
@@ -356,9 +370,11 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
         (message-len : (_ptr o _sqlsmallint))
         -> (status : _sqlreturn)
         -> (values status
-                   (bytes->string/utf-8 sql-state-buf #\? 0 5)
+                   (and (ok-status? status)
+                        (bytes->string/utf-8 sql-state-buf #\? 0 5))
                    native-errcode
-                   (bytes->string/utf-8 message-buf #\? 0 message-len))))
+                   (and (ok-status? status)
+                        (bytes->string/utf-8 message-buf #\? 0 message-len)))))
 
 (define-odbc SQLEndTran
   (_fun (handle completion-type) ::

collects/db/private/odbc/main.rkt

@@ -1,53 +1,62 @@
 #lang racket/base
 (require racket/class
-         racket/contract
          "../generic/interfaces.rkt"
+         "../generic/place-client.rkt"
          "connection.rkt"
          "dbsystem.rkt"
          "ffi.rkt")
 (provide odbc-connect
          odbc-driver-connect
          odbc-data-sources
-         odbc-drivers
-         (rename-out [dbsystem odbc-dbsystem]))
+         odbc-drivers)
 
 (define (odbc-connect #:dsn dsn
                       #:user [user #f]
                       #:password [auth #f]
                       #:notice-handler [notice-handler void]
                       #:strict-parameter-types? [strict-parameter-types? #f]
-                      #:character-mode [char-mode 'wchar])
-  (let ([notice-handler (make-handler notice-handler "notice")])
-    (call-with-env 'odbc-connect
-      (lambda (env)
-        (call-with-db 'odbc-connect env
-          (lambda (db)
-            (let ([status (SQLConnect db dsn user auth)])
-              (handle-status* 'odbc-connect status db)
-              (new connection%
-                   (env env)
-                   (db db)
-                   (notice-handler notice-handler)
-                   (strict-parameter-types? strict-parameter-types?)
-                   (char-mode char-mode)))))))))
+                      #:character-mode [char-mode 'wchar]
+                      #:use-place [use-place #f])
+  (cond [use-place
+         (place-connect (list 'odbc dsn user auth strict-parameter-types? char-mode)
+                        odbc-proxy%)]
+        [else
+         (let ([notice-handler (make-handler notice-handler "notice")])
+           (call-with-env 'odbc-connect
+             (lambda (env)
+               (call-with-db 'odbc-connect env
+                 (lambda (db)
+                   (let ([status (SQLConnect db dsn user auth)])
+                     (handle-status* 'odbc-connect status db)
+                     (new connection%
+                          (env env)
+                          (db db)
+                          (notice-handler notice-handler)
+                          (strict-parameter-types? strict-parameter-types?)
+                          (char-mode char-mode))))))))]))
 
 (define (odbc-driver-connect connection-string
                              #:notice-handler [notice-handler void]
                              #:strict-parameter-types? [strict-parameter-types? #f]
-                             #:character-mode [char-mode 'wchar])
-  (let ([notice-handler (make-handler notice-handler "notice")])
-    (call-with-env 'odbc-driver-connect
-      (lambda (env)
-        (call-with-db 'odbc-driver-connect env
-          (lambda (db)
-            (let ([status (SQLDriverConnect db connection-string SQL_DRIVER_NOPROMPT)])
-              (handle-status* 'odbc-driver-connect status db)
-              (new connection%
-                   (env env)
-                   (db db)
-                   (notice-handler notice-handler)
-                   (strict-parameter-types? strict-parameter-types?)
-                   (char-mode char-mode)))))))))
+                             #:character-mode [char-mode 'wchar]
+                             #:use-place [use-place #f])
+  (cond [use-place
+         (place-connect (list 'odbc-driver connection-string strict-parameter-types? char-mode)
+                        odbc-proxy%)]
+        [else
+         (let ([notice-handler (make-handler notice-handler "notice")])
+           (call-with-env 'odbc-driver-connect
+             (lambda (env)
+               (call-with-db 'odbc-driver-connect env
+                 (lambda (db)
+                   (let ([status (SQLDriverConnect db connection-string SQL_DRIVER_NOPROMPT)])
+                     (handle-status* 'odbc-driver-connect status db)
+                     (new connection%
+                          (env env)
+                          (db db)
+                          (notice-handler notice-handler)
+                          (strict-parameter-types? strict-parameter-types?)
+                          (char-mode char-mode))))))))]))
 
 (define (odbc-data-sources)
   (define server-buf (make-bytes 1024))
@@ -97,6 +106,12 @@
         (let ([=-pos (caar m)])
           (cons (substring s 0 =-pos) (substring s (+ 1 =-pos))))))))
 
+
+(define odbc-proxy%
+  (class place-proxy-connection%
+    (super-new)
+    (define/override (get-dbsystem) dbsystem)))
+
 ;; ----
 
 ;; Aux functions to free handles on error.

collects/db/private/postgresql/connection.rkt

@@ -14,6 +14,13 @@
 
 ;; ========================================
 
+;; connector<%>
+;; Manages making connections
+(define connector<%>
+  (interface ()
+    attach-to-ports              ;; input-port output-port -> void
+    start-connection-protocol))  ;; string string string/#f -> void
+
 (define connection-base%
   (class* transactions% (connection<%> connector<%>)
     (init-private notice-handler
@@ -396,6 +403,8 @@
         (set! name-counter (add1 name-counter))
         (format "λmz_~a_~a" process-id n)))
 
+    (define/public (get-base) this)
+
     ;; free-statement : prepared-statement -> void
     (define/public (free-statement pst)
       (call-with-lock* 'free-statement

collects/db/private/postgresql/main.rkt

@@ -1,16 +1,13 @@
 #lang racket/base
 (require racket/class
-         racket/contract
          racket/tcp
          openssl
          "../generic/interfaces.rkt"
          "../generic/socket.rkt"
-         "connection.rkt"
-         "dbsystem.rkt")
+         "connection.rkt")
 (provide postgresql-connect
          postgresql-guess-socket-path
-         postgresql-password-hash
-         (rename-out [dbsystem postgresql-dbsystem]))
+         postgresql-password-hash)
 
 (define (postgresql-connect #:user user
                             #:database database

collects/db/private/sqlite3/connection.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/class
          ffi/unsafe
+         ffi/unsafe/atomic
          "../generic/interfaces.rkt"
          "../generic/prepared.rkt"
          "../generic/sql-data.rkt"
@@ -18,7 +19,7 @@
                   busy-retry-delay)
 
     (define -db db)
-    (define statement-table (make-weak-hasheq))
+    (define statement-table (make-hasheq))
     (define saved-tx-status #f) ;; set by with-lock, only valid while locked
 
     (inherit call-with-lock*
@@ -36,14 +37,13 @@
     (define/override (connected?) (and -db #t))
 
     (define/public (query fsym stmt)
-      (let-values ([(stmt* info rows)
+      (let-values ([(stmt* result)
                     (call-with-lock fsym
                       (lambda ()
                         (check-valid-tx-status fsym)
                         (query1 fsym stmt)))])
         (statement:after-exec stmt)
-        (cond [(pair? info) (rows-result info rows)]
-              [else (simple-result '())])))
+        result))
 
     (define/private (query1 fsym stmt)
       (let* ([stmt (cond [(string? stmt)
@@ -63,12 +63,23 @@
             (load-param fsym db stmt i param))
           (let* ([info
                   (for/list ([i (in-range (sqlite3_column_count stmt))])
-                    `((name ,(sqlite3_column_name stmt i))
-                      (decltype ,(sqlite3_column_decltype stmt i))))]
+                    `((name . ,(sqlite3_column_name stmt i))
+                      (decltype . ,(sqlite3_column_decltype stmt i))))]
                  [rows (step* fsym db stmt)])
             (HANDLE fsym (sqlite3_reset stmt))
             (HANDLE fsym (sqlite3_clear_bindings stmt))
-            (values stmt info rows)))))
+            (values stmt
+                    (cond [(pair? info)
+                           (rows-result info rows)]
+                          [else
+                           (let ([changes (sqlite3_changes db)])
+                             (cond [(and (positive? changes)
+                                         #f ;; Note: currently disabled
+                                         #| FIXME: statement was INSERT stmt |#)
+                                    (simple-result
+                                     (list (cons 'last-insert-rowid
+                                                 (sqlite3_last_insert_rowid db))))]
+                                   [else (simple-result '())]))]))))))
 
     (define/private (load-param fsym db stmt i param)
       (HANDLE fsym
@@ -149,31 +160,35 @@
           pst)))
 
     (define/public (disconnect)
-      ;; FIXME: Reorder effects to be more robust if thread killed within disconnect (?)
       (define (go)
-        (when -db
-          (let ([db -db]
-                [statements (hash-map statement-table (lambda (k v) k))])
-            (set! -db #f)
-            (set! statement-table #f)
-            (for ([pst (in-list statements)])
-              (let ([stmt (send pst get-handle)])
-                (when stmt
-                  (send pst set-handle #f)
-                  (HANDLE 'disconnect (sqlite3_finalize stmt)))))
-            (HANDLE 'disconnect (sqlite3_close db))
-            (void))))
+        (start-atomic)
+        (let ([db -db])
+          (set! -db #f)
+          (end-atomic)
+          (when db
+            (let ([statements (hash-map statement-table (lambda (k v) k))])
+              (for ([pst (in-list statements)])
+                (do-free-statement 'disconnect pst))
+              (HANDLE 'disconnect2 (sqlite3_close db))
+              (void)))))
       (call-with-lock* 'disconnect go go #f))
 
+    (define/public (get-base) this)
+
     (define/public (free-statement pst)
-      (define (go)
-        (let ([stmt (send pst get-handle)])
-          (when stmt
-            (send pst set-handle #f)
-            (HANDLE 'free-statement (sqlite3_finalize stmt))
-            (void))))
+      (define (go) (do-free-statement 'free-statement pst))
       (call-with-lock* 'free-statement go go #f))
 
+    (define/private (do-free-statement fsym pst)
+      (start-atomic)
+      (let ([stmt (send pst get-handle)])
+        (send pst set-handle #f)
+        (end-atomic)
+        (hash-remove! statement-table pst)
+        (when stmt
+          (HANDLE fsym (sqlite3_finalize stmt))
+          (void))))
+
 
     ;; == Transactions
 
@@ -198,7 +213,7 @@
                  (let ([db (get-db fsym)])
                    (when (get-tx-status db)
                      (error/already-in-tx fsym))
-                   (let-values ([(stmt* _info _rows)
+                   (let-values ([(stmt* _result)
                                  (query1 fsym "BEGIN TRANSACTION")])
                      stmt*))))])
         (statement:after-exec stmt)
@@ -212,7 +227,7 @@
                    (unless (eq? mode 'rollback)
                      (check-valid-tx-status fsym))
                    (when (get-tx-status db)
-                     (let-values ([(stmt* _info _rows)
+                     (let-values ([(stmt* _result)
                                    (case mode
                                      ((commit)
                                       (query1 fsym "COMMIT TRANSACTION"))
@@ -230,14 +245,11 @@
              ;; schema ignored, because sqlite doesn't support
              (string-append "SELECT tbl_name from sqlite_master "
                             "WHERE type = 'table' or type = 'view'")])
-        (let-values ([(stmt rows)
+        (let-values ([(stmt result)
                       (call-with-lock fsym
-                        (lambda ()
-                          (let-values ([(stmt _info rows)
-                                        (query1 fsym stmt)])
-                            (values stmt rows))))])
+                        (lambda () (query1 fsym stmt)))])
           (statement:after-exec stmt)
-          (for/list ([row (in-list rows)])
+          (for/list ([row (in-list (rows-result-rows result))])
             (vector-ref row 0)))))
 
     ;; ----
@@ -260,7 +272,7 @@
     ;; Can't figure out how to test...
     (define/private (handle-status who s)
       (when (memv s maybe-rollback-status-list)
-        (when (and saved-tx-status (not (get-tx-status -db))) ;; was in trans, now not
+        (when (and saved-tx-status -db (not (get-tx-status -db))) ;; was in trans, now not
           (set! tx-status 'invalid)))
       (handle-status* who s -db))
 

collects/db/private/sqlite3/dbsystem.rkt

@@ -1,8 +1,6 @@
 #lang racket/base
 (require racket/class
-         "../generic/interfaces.rkt"
-         "../generic/sql-data.rkt"
-         "ffi-constants.rkt")
+         "../generic/interfaces.rkt")
 (provide dbsystem)
 
 (define sqlite3-dbsystem%

collects/db/private/sqlite3/ffi.rkt

@@ -132,6 +132,22 @@
   (_fun _sqlite3_database
         -> _bool))
 
+(define-sqlite sqlite3_next_stmt
+  (_fun _sqlite3_database _sqlite3_statement/null
+        -> _sqlite3_statement/null))
+
+(define-sqlite sqlite3_sql
+  (_fun _sqlite3_statement
+        -> _string))
+
+(define-sqlite sqlite3_changes
+  (_fun _sqlite3_database
+        -> _int))
+
+(define-sqlite sqlite3_last_insert_rowid
+  (_fun _sqlite3_database
+        -> _int))
+
 ;; ----------------------------------------
 
 #|

collects/db/private/sqlite3/main.rkt

@@ -1,41 +1,51 @@
 #lang racket/base
 (require racket/class
-         racket/contract
          ffi/file
+         "../generic/place-client.rkt"
          "connection.rkt"
          "dbsystem.rkt"
          "ffi.rkt")
-(provide sqlite3-connect
-         (rename-out [dbsystem sqlite3-dbsystem]))
+(provide sqlite3-connect)
 
-(define (sqlite3-connect #:database path-or-sym
+(define (sqlite3-connect #:database path
                          #:mode [mode 'read/write]
                          #:busy-retry-delay [busy-retry-delay 0.1]
-                         #:busy-retry-limit [busy-retry-limit 10])
+                         #:busy-retry-limit [busy-retry-limit 10]
+                         #:use-place [use-place #f])
   (let ([path
-         (cond [(symbol? path-or-sym)
-                (case path-or-sym
-                  ;; Private, temporary in-memory
-                  [(memory) #":memory:"]
-                  ;; Private, temporary on-disk
-                  [(temporary) #""])]
-               [(or (path? path-or-sym) (string? path-or-sym))
-                (let ([path (cleanse-path (path->complete-path path-or-sym))])
-                  (security-guard-check-file 'sqlite3-connect
-                                             path
-                                             (case mode
-                                               ((read-only) '(read))
-                                               (else '(read write))))
-                  (path->bytes path))])])
-    (let-values ([(db open-status)
-                  (sqlite3_open_v2 path
-                                   (case mode
-                                     ((read-only) SQLITE_OPEN_READONLY)
-                                     ((read/write) SQLITE_OPEN_READWRITE)
-                                     ((create)
-                                      (+ SQLITE_OPEN_READWRITE SQLITE_OPEN_CREATE))))])
-      (handle-status* 'sqlite3-connect open-status db)
-      (new connection%
-           (db db)
-           (busy-retry-limit busy-retry-limit)
-           (busy-retry-delay busy-retry-delay)))))
+         (case path
+           ((memory temporary) path)
+           (else
+            (let ([path (cleanse-path (path->complete-path path))])
+              (security-guard-check-file 'sqlite3-connect
+                                         path
+                                         (case mode
+                                           ((read-only) '(read))
+                                           (else '(read write))))
+              path)))])
+    (cond [use-place
+           (place-connect (list 'sqlite3 path mode busy-retry-delay busy-retry-limit)
+                          sqlite-place-proxy%)]
+          [else
+           (let ([path-bytes
+                  (case path
+                    ((memory) #":memory:")
+                    ((temporary) #"")
+                    (else (path->bytes path)))])
+             (let-values ([(db open-status)
+                           (sqlite3_open_v2 path-bytes
+                                            (case mode
+                                              ((read-only) SQLITE_OPEN_READONLY)
+                                              ((read/write) SQLITE_OPEN_READWRITE)
+                                              ((create)
+                                               (+ SQLITE_OPEN_READWRITE SQLITE_OPEN_CREATE))))])
+               (handle-status* 'sqlite3-connect open-status db)
+               (new connection%
+                    (db db)
+                    (busy-retry-limit busy-retry-limit)
+                    (busy-retry-delay busy-retry-delay))))])))
+
+(define sqlite-place-proxy%
+  (class place-proxy-connection%
+    (super-new)
+    (define/override (get-dbsystem) dbsystem)))

collects/db/scribblings/config.rkt

@@ -1,21 +1,26 @@
 #lang racket/base
 (require scribble/manual
          scribble/eval
-         racket/sandbox
          (for-label racket/base
                     racket/contract))
 (provide (all-defined-out)
          (for-label (all-from-out racket/base)
                     (all-from-out racket/contract)))
 
+(define (tech/reference . pre-flows)
+  (apply tech #:doc '(lib "scribblings/reference/reference.scrbl") pre-flows))
+
 ;; ----
 
 (define the-eval (make-base-eval))
 (void
  (interaction-eval #:eval the-eval
                    (require racket/class
-                            db
+                            racket/pretty
+                            db/base
                             db/util/datetime))
+ (interaction-eval #:eval the-eval
+                   (current-print pretty-print-handler))
  (interaction-eval #:eval the-eval
                    (define connection% (class object% (super-new))))
  (interaction-eval #:eval the-eval

collects/db/scribblings/connect.scrbl

@@ -16,6 +16,22 @@ administrative functions for managing connections.
 
 @declare-exporting[db]
 
+There are four kinds of base connection, and they are divided into two
+groups: @deftech{wire-based connections} and @deftech{FFI-based
+connections}. PostgreSQL and MySQL connections are wire-based, and
+SQLite and ODBC connections are FFI-based.
+
+Wire-based connections communicate using @tech/reference{ports}, which
+do not cause other Racket threads to block. In contrast, all Racket
+threads are blocked during an FFI call, so FFI-based connections can
+seriously degrade the interactivity of a Racket program, particularly
+if long-running queries are performed using the connection. This
+problem can be avoided by creating the FFI-based connection in a
+separate @tech/reference{place} using the @racket[#:use-place]
+keyword argument. Such a connection will not block all Racket threads
+during queries; the disadvantage is the cost of creating and
+communicating with a separate @tech/reference{place}.
+
 Base connections are made using the following functions.
 
 @defproc[(postgresql-connect [#:user user string?]
@@ -188,7 +204,8 @@ Base connections are made using the following functions.
                 [#:busy-retry-limit busy-retry-limit 
                  (or/c exact-nonnegative-integer? +inf.0) 10]
                 [#:busy-retry-delay busy-retry-delay
-                 (and/c rational? (not/c negative?)) 0.1])
+                 (and/c rational? (not/c negative?)) 0.1]
+                [#:use-place use-place boolean? #f])
          connection?]{
 
   Opens the SQLite database at the file named by @racket[database], if
@@ -214,6 +231,10 @@ Base connections are made using the following functions.
   attempted once. If after @racket[busy-retry-limit] retries the
   operation still does not succeed, an exception is raised.
 
+  If @racket[use-place] is true, the actual connection is created in
+  a distinct @tech/reference{place} for database connections and a
+  proxy is returned.
+
   If the connection cannot be made, an exception is raised.
 
   @(examples/results
@@ -234,7 +255,8 @@ Base connections are made using the following functions.
                        [#:strict-parameter-types? strict-parameter-types? boolean? #f]
                        [#:character-mode character-mode
                         (or/c 'wchar 'utf-8 'latin-1)
-                        'wchar])
+                        'wchar]
+                       [#:use-place use-place boolean? #f])
          connection?]{
 
   Creates a connection to the ODBC Data Source named @racket[dsn]. The
@@ -258,6 +280,10 @@ Base connections are made using the following functions.
   See @secref["odbc-status"] for notes on specific ODBC drivers and
   recommendations for connection options.
 
+  If @racket[use-place] is true, the actual connection is created in
+  a distinct @tech/reference{place} for database connections and a
+  proxy is returned.
+
   If the connection cannot be made, an exception is raised.
 }
 
@@ -269,7 +295,8 @@ Base connections are made using the following functions.
                               [#:strict-parameter-types? strict-parameter-types? boolean? #f]
                               [#:character-mode character-mode
                                (or/c 'wchar 'utf-8 'latin-1)
-                               'wchar])
+                               'wchar]
+                              [#:use-place use-place boolean? #f])
          connection?]{
 
   Creates a connection using an ODBC connection string containing a
@@ -606,7 +633,8 @@ ODBC's DSNs.
            [#:busy-retry-limit busy-retry-limit 
             (or/c exact-nonnegative-integer? +inf.0) @#,absent]
            [#:busy-retry-delay busy-retry-delay
-            (and/c rational? (not/c negative?)) @#,absent])
+            (and/c rational? (not/c negative?)) @#,absent]
+           [#:use-place use-place boolean? @#,absent])
          data-source?]
 @defproc[(odbc-data-source
            [#:dsn dsn (or/c string? #f) @#,absent]

collects/db/scribblings/db.scrbl

@@ -26,17 +26,15 @@ native client library is required.}
 
 @item{@bold{@as-index{@hyperlink["http://www.sqlite.org"]{SQLite}} version
 3.} The SQLite native client library is required; see
-@secref["sqlite3-native-libs"].}
+@secref["sqlite3-requirements"].}
 
 @item{@bold{@as-index{ODBC}.} An ODBC Driver Manager and appropriate
-ODBC drivers are required; see @secref["odbc-native-libs"]. The
-following additional database systems are known to work with this
-library's ODBC support (see @secref["odbc-status"] for details):
-@itemlist[
-@item{@bold{@as-index{@hyperlink["http://www.oracle.com"]{Oracle}}}}
-@item{@bold{@as-index{@hyperlink["http://www.ibm.com/software/data/db2/"]{DB2}}}}
-@item{@bold{@as-index{@hyperlink["http://www.microsoft.com/sqlserver/"]{SQL Server}}}}
-]}
+ODBC drivers are required; see @secref["odbc-requirements"]. The
+following database systems are known to work with this library via
+ODBC (see @secref["odbc-status"] for details):
+@bold{@as-index{@hyperlink["http://www.ibm.com/software/data/db2/"]{DB2}}},
+@bold{@as-index{@hyperlink["http://www.oracle.com"]{Oracle}}}, and
+@bold{@as-index{@hyperlink["http://www.microsoft.com/sqlserver/"]{SQL Server}}}.}
 ]
 
 The query operations are functional in spirit: queries return results

collects/db/scribblings/introduction.scrbl

@@ -202,15 +202,18 @@ web-server
 ]
 
 The main problem with using one connection for all requests is that
-while all connection functions are thread-safe, two threads accessing
-a connection concurrently may still interfere. For example, if two
-threads both attempt to start a new transaction, the second one will
-fail, because the first thread has already put the connection into an
-``in transaction'' state. And if one thread is accessing the
-connection within a transaction and another thread issues a query, the
-second thread may see invalid data or even disrupt the work of the
-first thread (see
-@hyperlink["http://en.wikipedia.org/wiki/Isolation_%28database_systems%29"]{isolation}).
+multiple threads accessing the same connection are not properly
+@hyperlink["http://en.wikipedia.org/wiki/Isolation_%28database_systems%29"]{isolated}. For
+example, if two threads both attempt to start a new transaction, the
+second one will fail, because the first thread has already put the
+connection into an ``in transaction'' state. And if one thread is
+accessing the connection within a transaction and another thread
+issues a query, the second thread may see invalid data or even disrupt
+the work of the first thread.
+
+A secondary problem is performance. A connection can only perform a
+single query at a time, whereas most database systems are capable of
+concurrent query processing.
 
 The proper way to use database connections in a servlet is to create a
 connection for each request and disconnect it when the request

collects/db/scribblings/notes.scrbl

@@ -4,25 +4,27 @@
           scribble/struct
           racket/sandbox
           "config.rkt"
-          (for-label db))
+          (for-label db
+                     setup/dirs))
 
 @title[#:tag "notes"]{Notes}
 
-This section describes miscellaneous issues.
+This section discusses issues related to specific database systems.
+
 
 @section[#:tag "connecting-to-server"]{Local Sockets for PostgreSQL and MySQL Servers}
 
 PostgreSQL and MySQL servers are sometimes configured by default to
 listen only on local sockets (also called ``unix domain
 sockets''). This library provides support for communication over local
-sockets, but only on Linux (x86 and x86-64) and Mac OS X. If local
-socket communication is not available, the server must be reconfigured
-to listen on a TCP port.
+sockets on Linux (x86 and x86-64) and Mac OS X. If local socket
+communication is not available, the server must be reconfigured to
+listen on a TCP port.
 
 The socket file for a PostgreSQL server is located in the directory
 specified by the @tt{unix_socket_directory} variable in the
 @tt{postgresql.conf} server configuration file.  For example, on
-Ubuntu 10.10 running PostgreSQL 8.4, the socket directory is
+Ubuntu 11.04 running PostgreSQL 8.4, the socket directory is
 @tt{/var/run/postgresql} and the socket file is
 @tt{/var/run/postgresql/.s.PGSQL.5432}. Common socket paths may be
 searched automatically using the @racket[postgresql-guess-socket-path]
@@ -30,20 +32,19 @@ function.
 
 The socket file for a MySQL server is located at the path specified by
 the @tt{socket} variable in the @tt{my.cnf} configuration file. For
-example, on Ubuntu 10.10 running MySQL 5.1, the socket is located at
+example, on Ubuntu 11.04 running MySQL 5.1, the socket is located at
 @tt{/var/run/mysqld/mysqld.sock}. Common socket paths for MySQL can be
 searched using the @racket[mysql-guess-socket-path] function.
 
 
-@section{Database Character Encodings}
+@section{PostgreSQL Database Character Encoding}
 
-In most cases, a PostgreSQL or MySQL database's character encoding is
-irrelevant, since the connect function always requests translation to
-Unicode (UTF-8) when creating a connection. If a PostgreSQL database's
-character encoding is @tt{SQL_ASCII}, however, PostgreSQL will not
-honor the connection encoding; it will instead send untranslated
-octets, which will cause corrupt data or internal errors in the client
-connection.
+In most cases, a database's character encoding is irrelevant, since
+the connect function always requests translation to Unicode (UTF-8)
+when creating a connection. If a PostgreSQL database's character
+encoding is @tt{SQL_ASCII}, however, PostgreSQL will not honor the
+connection encoding; it will instead send untranslated octets, which
+will cause corrupt data or internal errors in the client connection.
 
 To convert a PostgreSQL database from @tt{SQL_ASCII} to something
 sensible, @tt{pg_dump} the database, recode the dump file (using a
@@ -51,31 +52,17 @@ utility such as @tt{iconv}), create a new database with the desired
 encoding, and @tt{pg_restore} from the recoded dump file.
 
 
-@section{Prepared Query Parameter Types}
-
-Different database systems vary in their handling of query parameter
-types. For example, consider the following parameterized SQL
-statement:
-
-@tt{SELECT 1 + ?;}
-
-PostgreSQL reports an expected type of @tt{integer} for the parameter and
-will not accept other types. MySQL and SQLite, in contrast, report no
-useful parameter type information, and ODBC connections vary in
-behavior based on the driver, the data source configuration, and the
-connection parameters (see @secref["odbc-status"] for specific notes).
-
-
 @section{PostgreSQL Authentication}
 
-PostgreSQL supports a large variety of authentication mechanisms,
-controlled by the @tt{pg_hba.conf} server configuration file. This
-library currently supports only cleartext and md5-hashed passwords,
-and it does not send cleartext passwords unless explicitly ordered to
-(see @racket[postgresql-connect]). These correspond to the @tt{md5}
-and @tt{password} authentication methods in the parlance of
+PostgreSQL supports a large variety of
+@hyperlink["http://www.postgresql.org/docs/8.4/static/auth-pg-hba-conf.html"]{authentication
+mechanisms}, controlled by the @tt{pg_hba.conf} server configuration
+file. This library currently supports only cleartext and md5-hashed
+passwords, and it does not send cleartext passwords unless explicitly
+ordered to (see @racket[postgresql-connect]). These correspond to the
+@tt{md5} and @tt{password} authentication methods in the parlance of
 @tt{pg_hba.conf}, respectively. On Linux, @tt{ident} authentication is
-automatically supported for unix domain sockets (but not TCP). The
+automatically supported for local sockets, but not TCP sockets. The
 @tt{gss}, @tt{sspi}, @tt{krb5}, @tt{pam}, and @tt{ldap} methods are
 not supported.
 
@@ -89,36 +76,69 @@ plugins}. The only plugin currently supported by this library is
 password authentication mechanism used since version 4.1.
 
 
-@section[#:tag "sqlite3-native-libs"]{SQLite Native Library}
+@section[#:tag "sqlite3-requirements"]{SQLite Requirements}
 
-SQLite support requires the appropriate native library, specifically
-@tt{libsqlite3.so.0} on Unix or @tt{sqlite3.dll} on Windows.
+SQLite support requires the appropriate native library.
+
+@itemlist[
+
+@item{On Windows, the library is @tt{sqlite3.dll}. It can be obtained
+from @hyperlink["http://www.sqlite.org/download.html"]{the SQLite
+download page}; the DLL file should be extracted and placed into one
+of the directories produced by
+@racketblock[(begin (require setup/dirs) (get-lib-search-dirs))]}
+
+@item{On Mac OS X, the library is @tt{libsqlite3.0.dylib}, which is
+included (in @tt{/usr/lib}) in Mac OS X version 10.4 onwards.}
+
+@item{On Linux, the library is @tt{libsqlite3.so.0}. It is included in
+the @tt{libsqlite3-0} package in Debian/Ubuntu and in the @tt{sqlite}
+package in Red Hat.}
+]
 
 
-@section[#:tag "odbc-native-libs"]{ODBC Native Libraries}
+@section[#:tag "odbc-requirements"]{ODBC Requirements}
 
-ODBC support requires the appropriate native library, specifically
-@tt{libodbc.so.1} (from unixODBC; iODBC is not supported) on Unix or
-@tt{odbc32.dll} on Windows. In addition, the appropriate ODBC Drivers
-must be installed and any Data Sources configured.
+ODBC requires the appropriate driver manager native library as well as
+driver native libraries for each database system you want use ODBC to
+connect to.
+
+@itemlist[
+
+@item{On Windows, the driver manager is @tt{odbc32.dll}, which is
+included automatically with Windows.}
+
+@item{On Mac OS X, the driver manager is @tt{libiodbc.2.dylib}
+(@hyperlink["http://www.iodbc.org"]{iODBC}), which is included (in
+@tt{/usr/lib}) in Mac OS X version 10.2 onwards.}
+
+@item{On Linux, the driver manager is @tt{libodbc.so.1}
+(@hyperlink["http://www.unixodbc.org"]{unixODBC}---iODBC is not
+supported). It is available from the @tt{unixodbc} package in
+Debian/Ubuntu and in the @tt{unixODBC} package in Red Hat.}
+]
+
+In addition, you must install the appropriate ODBC Drivers and
+configure Data Sources. Refer to the ODBC documentation for the
+specific database system for more information.
 
 
-@section[#:tag "odbc-status"]{ODBC Support Status}
+@section[#:tag "odbc-status"]{ODBC Status}
 
-ODBC support is experimental. This library is compatible only with
-ODBC 3.x Driver Managers. The behavior of ODBC connections can vary
-widely depending on the driver in use and even the configuration of a
-particular data source.
+ODBC support is experimental. The behavior of ODBC connections can
+vary widely depending on the driver in use and even the configuration
+of a particular data source.
 
 The following sections describe the configurations that this library
-has been tested with. The platform @bold{win32} means Windows Vista on
-a 32-bit processor and @bold{linux} means Ubuntu 11.04 and unixODBC on
-both x86 (32-bit) and x86-64 processors, unless otherwise
-specified. The iODBC Driver Manager is not supported.
+has been tested with.
 
 Reports of success or failure on other platforms or with other drivers
 would be appreciated.
 
+@;{
+** There's no reason to actually use the following drivers. They're just
+** useful for testing ODBC support.
+
 @subsection{PostgreSQL ODBC Driver}
 
 The PostgreSQL ODBC driver version 09.00.0300 has been tested on
@@ -149,15 +169,18 @@ Furthermore, this driver interprets the declared types of columns
 strictly, replacing nonconforming values in query results with
 @tt{NULL}. All computed columns, even those with explicit @tt{CAST}s,
 seem to be returned as @tt{text}.
+}
 
 @subsection{DB2 ODBC Driver}
 
-The driver from IBM DB2 Express-C v9.7 has been tested on @bold{linux}
+The driver from IBM DB2 Express-C v9.7 has been tested on Ubuntu 11.04
 (32-bit only).
 
 For a typical installation where the instance resides at
 @tt{/home/db2inst1}, set the following option in the Driver
-configuration: @tt{Driver = /home/db2inst1/sqllib/lib32/libdb2.so}.
+configuration: @tt{Driver =
+/home/db2inst1/sqllib/lib32/libdb2.so}. (The path would presumably be
+different for a 64-bit installation.)
 
 The DB2 driver does not seem to accept a separate argument for the
 database to connect to; it must be the same as the Data Source name.
@@ -165,7 +188,7 @@ database to connect to; it must be the same as the Data Source name.
 @subsection{Oracle ODBC Driver}
 
 The driver from Oracle Database 10g Release 2 Express Edition has been
-tested on @bold{linux} (32-bit only).
+tested on Ubuntu 11.04 (32-bit only).
 
 It seems the @tt{ORACLE_HOME} and @tt{LD_LIBRARY_PATH} environment
 variables must be set according to the @tt{oracle_env.{csh,sh}} script
@@ -185,5 +208,5 @@ Maybe Oracle bug? See:
 
 @subsection{SQL Server ODBC Driver}
 
-Basic SQL Server support has been verified on @bold{win32}, but the
-automated test suite has not yet been adapted and run.
+Basic SQL Server support has been verified on Windows (32-bit only),
+but the automated test suite has not yet been adapted and run.

collects/db/scribblings/query.scrbl

@@ -68,8 +68,7 @@ way to make kill-safe connections.
 All query functions require both a connection and a
 @deftech{statement}, which is one of the following:
 @itemlist[
-@item{a string containing a single SQL statement, possibly with
-  parameters}
+@item{a string containing a single SQL statement}
 @item{a @tech{prepared statement} produced by @racket[prepare]}
 @item{a @tech{virtual statement} produced by
   @racket[virtual-statement]}
@@ -78,6 +77,29 @@ All query functions require both a connection and a
 @item{an instance of a struct type that implements @racket[prop:statement]}
 ]
 
+A SQL statement may contain parameter placeholders that stand for SQL
+scalar values. The parameter values must be supplied when the
+statement is executed; the parameterized statement and parameter
+values are sent to the database back end, which combines them
+correctly and safely.
+
+Use parameters instead of Racket string interpolation (eg,
+@racket[format] or @racket[string-append]) to avoid
+@hyperlink["http://xkcd.com/327/"]{SQL injection}, where a string
+intended to represent a SQL scalar value is interpreted as---possibly
+malicious---SQL code instead.
+
+The syntax of placeholders varies depending on the database
+system. For example:
+
+@centered{
+@tabbing{
+PostgreSQL:   @&  @tt{select * from the_numbers where n > $1;} @//
+MySQL, ODBC:  @&  @tt{select * from the_numbers where n > ?;} @//
+SQLite:       @&  supports both syntaxes (plus others)
+}
+}
+
 @defproc[(statement? [x any/c]) boolean?]{
 
   Returns @racket[#t] if @racket[x] is a @tech{statement}, @racket[#f]
@@ -118,7 +140,13 @@ The types of parameters and returned fields are described in
 
 @defproc[(query-rows [connection connection?]
                      [stmt statement?]
-                     [arg any/c] ...)
+                     [arg any/c] ...
+                     [#:group grouping-fields
+                      (or/c (vectorof string?) (listof (vectorof string?)))
+                      null]
+                     [#:group-mode group-mode
+                      (listof (or/c 'preserve-null-rows 'list))
+                      null])
          (listof vector?)]{
 
   Executes a SQL query, which must produce rows, and returns the list
@@ -130,6 +158,9 @@ The types of parameters and returned fields are described in
 [(query-rows c "select 17")
  (list (vector 17))]
 ]
+
+  If @racket[grouping-fields] is not empty, the result is the same as if
+  @racket[group-rows] had been called on the result rows.
 }
 
 @defproc[(query-list [connection connection?]
@@ -286,23 +317,56 @@ future version of this library (even new minor versions).
   supports both rows-returning and effect-only queries.
 }
 
+@defproc[(group-rows [result rows-result?]
+                     [#:group grouping-fields
+                      (or/c (vectorof string?) (listof (vectorof string?)))]
+                     [#:group-mode group-mode
+                      (listof (or/c 'preserve-null-rows 'list))
+                      null])
+         rows-result?]{
+
+If @racket[grouping-fields] is a vector, the elements must be names of
+fields in @racket[result], and @racket[result]'s rows are regrouped
+using the given fields. Each grouped row contains N+1 fields; the
+first N fields are the @racket[grouping-fields], and the final field
+is a list of ``residual rows'' over the rest of the fields. A residual
+row of all NULLs is dropped (for convenient processing of @tt{OUTER
+JOIN} results) unless @racket[group-mode] includes
+@racket['preserve-null-rows]. If @racket[group-mode] contains
+@racket['list], there must be exactly one residual field, and its
+values are included without a vector wrapper (similar to
+@racket[query-list]).
+
+@examples[#:eval the-eval
+(define vehicles-result
+  (rows-result
+   '(((name . "type")) ((name . "maker")) ((name . "model")))
+   `(#("car"  "honda"   "civic")
+     #("car"  "ford"    "focus")
+     #("car"  "ford"    "pinto")
+     #("bike" "giant"   "boulder")
+     #("bike" "schwinn" ,sql-null))))
+(group-rows vehicles-result
+            #:group '(#("type")))
+]
+
+The @racket[grouping-fields] argument may also be a list of vectors;
+in that case, the grouping process is repeated for each set of
+grouping fields. The grouping fields must be distinct.
+
+@examples[#:eval the-eval
+(group-rows vehicles-result
+            #:group '(#("type") #("maker"))
+            #:group-mode '(list))
+]
+}
+
 
 @section{Prepared Statements}
 
 A @deftech{prepared statement} is the result of a call to
 @racket[prepare].
 
-The syntax of parameterized queries varies depending on the database
-system. For example:
-
-@centered{
-@tabbing{
-PostgreSQL:   @&  @tt{select * from the_numbers where n > $1;} @//
-MySQL, ODBC:  @&  @tt{select * from the_numbers where n > ?;} @//
-SQLite:       @&  supports both syntaxes (plus others)
-}
-}
-
 Any server-side or native-library resources associated with a prepared
 statement are released when the prepared statement is
 garbage-collected or when the connection that owns it is closed;

collects/db/scribblings/sql-types.scrbl

@@ -2,7 +2,7 @@
 @(require scribble/manual
           scribble/eval
           scribble/struct
-          scheme/sandbox
+          racket/sandbox
           "config.rkt"
           "tabbing.rkt"
           (for-label (prefix-in srfi: srfi/19)
@@ -57,33 +57,33 @@ along with their corresponding Racket representations.
 @centered{
 @tabbing{
   @bold{PostgreSQL type}  @& @bold{pg_type.typname}  @& @bold{Racket type} @//
-  @racket['boolean]       @& @tt{bool}               @& @scheme[boolean?] @//
-  @racket['char1]         @& @tt{char}               @& @scheme[char?] @//
-  @racket['smallint]      @& @tt{int2}               @& @scheme[exact-integer?] @//
-  @racket['integer]       @& @tt{int4}               @& @scheme[exact-integer?] @//
-  @racket['bigint]        @& @tt{int8}               @& @scheme[exact-integer?] @//
-  @racket['real]          @& @tt{float4}             @& @scheme[real?] @//
-  @racket['double]        @& @tt{float8}             @& @scheme[real?] @//
-  @racket['decimal]       @& @tt{numeric}            @& @scheme[number?] @//
-  @racket['character]     @& @tt{bpchar}             @& @scheme[string?] @//
-  @racket['varchar]       @& @tt{varchar}            @& @scheme[string?] @//
-  @racket['text]          @& @tt{text}               @& @scheme[string?] @//
-  @racket['bytea]         @& @tt{bytea}              @& @scheme[bytes?] @//
-  @racket['date]          @& @tt{date}               @& @scheme[sql-date?] @//
-  @racket['time]          @& @tt{time}               @& @scheme[sql-time?] @//
-  @racket['timetz]        @& @tt{timetz}             @& @scheme[sql-time?] @//
-  @racket['timestamp]     @& @tt{timestamp}          @& @scheme[sql-timestamp?] @//
-  @racket['timestamptz]   @& @tt{timestamptz}        @& @scheme[sql-timestamp?] @//
-  @racket['interval]      @& @tt{interval}           @& @scheme[sql-interval?] @//
-  @racket['bit]           @& @tt{bit}                @& @scheme[sql-bits?] @//
-  @racket['varbit]        @& @tt{varbit}             @& @scheme[sql-bits?] @//
+  @racket['boolean]       @& @tt{bool}               @& @racket[boolean?] @//
+  @racket['char1]         @& @tt{char}               @& @racket[char?] @//
+  @racket['smallint]      @& @tt{int2}               @& @racket[exact-integer?] @//
+  @racket['integer]       @& @tt{int4}               @& @racket[exact-integer?] @//
+  @racket['bigint]        @& @tt{int8}               @& @racket[exact-integer?] @//
+  @racket['real]          @& @tt{float4}             @& @racket[real?] @//
+  @racket['double]        @& @tt{float8}             @& @racket[real?] @//
+  @racket['decimal]       @& @tt{numeric}            @& @racket[number?] @//
+  @racket['character]     @& @tt{bpchar}             @& @racket[string?] @//
+  @racket['varchar]       @& @tt{varchar}            @& @racket[string?] @//
+  @racket['text]          @& @tt{text}               @& @racket[string?] @//
+  @racket['bytea]         @& @tt{bytea}              @& @racket[bytes?] @//
+  @racket['date]          @& @tt{date}               @& @racket[sql-date?] @//
+  @racket['time]          @& @tt{time}               @& @racket[sql-time?] @//
+  @racket['timetz]        @& @tt{timetz}             @& @racket[sql-time?] @//
+  @racket['timestamp]     @& @tt{timestamp}          @& @racket[sql-timestamp?] @//
+  @racket['timestamptz]   @& @tt{timestamptz}        @& @racket[sql-timestamp?] @//
+  @racket['interval]      @& @tt{interval}           @& @racket[sql-interval?] @//
+  @racket['bit]           @& @tt{bit}                @& @racket[sql-bits?] @//
+  @racket['varbit]        @& @tt{varbit}             @& @racket[sql-bits?] @//
 
-  @racket['point]         @& @tt{point}              @& @scheme[point?] @//
-  @racket['lseg]          @& @tt{lseg}               @& @scheme[line?] @//
-  @racket['path]          @& @tt{path}               @& @scheme[pg-path?] @//
-  @racket['box]           @& @tt{box}                @& @scheme[pg-box?] @//
-  @racket['polygon]       @& @tt{polygon}            @& @scheme[polygon?] @//
-  @racket['circle]        @& @tt{circle}             @& @scheme[pg-circle?]
+  @racket['point]         @& @tt{point}              @& @racket[point?] @//
+  @racket['lseg]          @& @tt{lseg}               @& @racket[line?] @//
+  @racket['path]          @& @tt{path}               @& @racket[pg-path?] @//
+  @racket['box]           @& @tt{box}                @& @racket[pg-box?] @//
+  @racket['polygon]       @& @tt{polygon}            @& @racket[polygon?] @//
+  @racket['circle]        @& @tt{circle}             @& @racket[pg-circle?]
 }
 }
 
@@ -92,7 +92,7 @@ syntax (the quotation marks are significant), is one byte, essentially
 a tiny integer written as a character.
 
 A SQL value of type @tt{decimal} is converted to either an exact
-rational or @scheme[+nan.0]. When converting Racket values to SQL
+rational or @racket[+nan.0]. When converting Racket values to SQL
 @tt{decimal}, exact rational values representable by finite decimal
 strings are converted without loss of precision. (Precision may be
 lost, of course, if the value is then stored in a database field of
@@ -136,19 +136,19 @@ with their corresponding Racket representations.
 @centered{
 @tabbing[#:spacing 8]{
   @bold{MySQL type}            @& @bold{Racket type} @//
-  @racket['integer]            @& @scheme[exact-integer?] @//
-  @racket['tinyint]            @& @scheme[exact-integer?] @//
-  @racket['smallint]           @& @scheme[exact-integer?] @//
-  @racket['mediumint]          @& @scheme[exact-integer?] @//
-  @racket['bigint]             @& @scheme[exact-integer?] @//
-  @racket['real]               @& @scheme[real?] @//
-  @racket['double]             @& @scheme[real?] @//
-  @racket['decimal]            @& @scheme[exact?] @//
-  @racket['varchar]            @& @scheme[string?] @//
-  @racket['var-string]         @& @scheme[string?] or @scheme[bytes?], but see below @//
-  @racket['date]               @& @scheme[sql-date?] @//
-  @racket['time]               @& @scheme[sql-time?] or @racket[sql-day-time-interval?] @//
-  @racket['datetime]           @& @scheme[sql-timestamp?] @//
+  @racket['integer]            @& @racket[exact-integer?] @//
+  @racket['tinyint]            @& @racket[exact-integer?] @//
+  @racket['smallint]           @& @racket[exact-integer?] @//
+  @racket['mediumint]          @& @racket[exact-integer?] @//
+  @racket['bigint]             @& @racket[exact-integer?] @//
+  @racket['real]               @& @racket[real?] @//
+  @racket['double]             @& @racket[real?] @//
+  @racket['decimal]            @& @racket[exact?] @//
+  @racket['varchar]            @& @racket[string?] @//
+  @racket['var-string]         @& @racket[string?] or @racket[bytes?], but see below @//
+  @racket['date]               @& @racket[sql-date?] @//
+  @racket['time]               @& @racket[sql-time?] or @racket[sql-day-time-interval?] @//
+  @racket['datetime]           @& @racket[sql-timestamp?] @//
 
   @racket['blob]               @& @racket[bytes?] @//
   @racket['tinyblob]           @& @racket[bytes?] @//
@@ -195,10 +195,10 @@ constraints (with the exception of @tt{integer primary key}) on
 @centered{
 @tabbing{
   @bold{SQLite storage class}  @& @bold{Racket type} @//
-  @tt{integer}                 @& @scheme[exact-integer?] @//
-  @tt{real}                    @& @scheme[real?] @//
-  @tt{text}                    @& @scheme[string?] @//
-  @tt{blob}                    @& @scheme[bytes?]
+  @tt{integer}                 @& @racket[exact-integer?] @//
+  @tt{real}                    @& @racket[real?] @//
+  @tt{text}                    @& @racket[string?] @//
+  @tt{blob}                    @& @racket[bytes?]
 }
 }
 
@@ -229,26 +229,26 @@ along with their corresponding Racket representations.
 @centered{
 @tabbing[#:spacing 8]{
   @bold{ODBC type}        @& @bold{Racket type} @//
-  @racket['character]     @& @scheme[string?] @//
-  @racket['varchar]       @& @scheme[string?] @//
-  @racket['longvarchar]   @& @scheme[string?] @//
-  @racket['numeric]       @& @scheme[rational?] @//
-  @racket['decimal]       @& @scheme[rational?] @//
-  @racket['integer]       @& @scheme[exact-integer?] @//
-  @racket['tinyint]       @& @scheme[exact-integer?] @//
-  @racket['smallint]      @& @scheme[exact-integer?] @//
-  @racket['bigint]        @& @scheme[exact-integer?] @//
-  @racket['float]         @& @scheme[real?] @//
-  @racket['real]          @& @scheme[real?] @//
-  @racket['double]        @& @scheme[real?] @//
-  @racket['date]          @& @scheme[sql-date?] @//
-  @racket['time]          @& @scheme[sql-time?] @//
-  @racket['datetime]      @& @scheme[sql-timestamp?] @//
-  @racket['timestamp]     @& @scheme[sql-timestamp?] @//
-  @racket['binary]        @& @scheme[bytes?] @//
-  @racket['varbinary]     @& @scheme[bytes?] @//
-  @racket['longvarbinary] @& @scheme[bytes?] @//
-  @racket['bit1]          @& @scheme[boolean?]
+  @racket['character]     @& @racket[string?] @//
+  @racket['varchar]       @& @racket[string?] @//
+  @racket['longvarchar]   @& @racket[string?] @//
+  @racket['numeric]       @& @racket[rational?] @//
+  @racket['decimal]       @& @racket[rational?] @//
+  @racket['integer]       @& @racket[exact-integer?] @//
+  @racket['tinyint]       @& @racket[exact-integer?] @//
+  @racket['smallint]      @& @racket[exact-integer?] @//
+  @racket['bigint]        @& @racket[exact-integer?] @//
+  @racket['float]         @& @racket[real?] @//
+  @racket['real]          @& @racket[real?] @//
+  @racket['double]        @& @racket[real?] @//
+  @racket['date]          @& @racket[sql-date?] @//
+  @racket['time]          @& @racket[sql-time?] @//
+  @racket['datetime]      @& @racket[sql-timestamp?] @//
+  @racket['timestamp]     @& @racket[sql-timestamp?] @//
+  @racket['binary]        @& @racket[bytes?] @//
+  @racket['varbinary]     @& @racket[bytes?] @//
+  @racket['longvarbinary] @& @racket[bytes?] @//
+  @racket['bit1]          @& @racket[boolean?]
 }
 }
 
@@ -281,13 +281,13 @@ that have no existing appropriate counterpart in Racket.
 
 @subsection{SQL NULL}
 
-SQL @tt{NULL} is translated into the unique @scheme[sql-null] value.
+SQL @tt{NULL} is translated into the unique @racket[sql-null] value.
 
 @defthing[sql-null sql-null?]{
 
   A special value used to represent @tt{NULL} values in query
-  results. The @scheme[sql-null] value may be recognized using
-  @scheme[eq?].
+  results. The @racket[sql-null] value may be recognized using
+  @racket[eq?].
 
 @(examples/results
   [(query-value c "select NULL")
@@ -362,12 +362,12 @@ values.
 
   Represents SQL times and timestamps.
 
-  The @scheme[tz] field indicates the time zone offset as the number
+  The @racket[tz] field indicates the time zone offset as the number
   of seconds east of GMT (as in SRFI 19). If @racket[tz] is
   @racket[#f], the time or timestamp does not carry time zone
   information.
 
-  The @scheme[sql-time] and @scheme[sql-timestamp] structures store
+  The @racket[sql-time] and @racket[sql-timestamp] structures store
   fractional seconds to nanosecond precision for compatibility with
   SRFI 19. Note, however, that database systems generally do not
   support nanosecond precision; PostgreSQL, for example, only supports

collects/db/scribblings/util.scrbl

@@ -2,7 +2,7 @@
 @(require scribble/manual
           scribble/eval
           scribble/struct
-          scheme/sandbox
+          racket/sandbox
           "config.rkt"
           (for-label db db/util/datetime db/util/geometry db/util/postgresql))
 

collects/db/sqlite3.rkt

@@ -9,5 +9,6 @@
   (->* (#:database (or/c path-string? 'memory 'temporary))
        (#:mode (or/c 'read-only 'read/write 'create)
         #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0)
-        #:busy-retry-delay (and/c rational? (not/c negative?)))
-       any/c)])
+        #:busy-retry-delay (and/c rational? (not/c negative?))
+        #:use-place any/c)
+       connection?)])

collects/db/util/private/geometry.rkt

@@ -1,6 +1,5 @@
 #lang racket/base
-(require racket/contract
-         racket/list)
+(require racket/list)
 (provide (all-defined-out))
 
 #|

collects/deinprogramm/signature/module-begin.rkt

@@ -174,7 +174,7 @@
 		 ;; Lift out certain forms to make them visible to the module
 		 ;;  expander:
 		 (syntax-case e2 (#%require #%provide
-				  define-syntaxes define-values-for-syntax define-values begin
+				  define-syntaxes begin-for-syntax define-values begin
 				  define-record-procedures define-record-procedures-2
 				  define-record-procedures-parametric define-record-procedures-parametric-2
 				  define-contract :)
@@ -184,7 +184,7 @@
 		    #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
 		   ((define-syntaxes (id ...) . _)
 		    #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids))))
-		   ((define-values-for-syntax . _)
+		   ((begin-for-syntax . _)
 		    #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
 		   ((begin b1 ...)
 		    (syntax-track-origin 

collects/drracket/private/auto-language.rkt

@@ -1,4 +1,4 @@
-#lang typed-scheme
+#lang typed/racket/base
 
 (require typed/framework/framework 
 	 typed/mred/mred
@@ -6,9 +6,6 @@
 
 (provide pick-new-language looks-like-module?)
 
-(: reader-tag String)
-(define reader-tag "#reader")
-
 (define-type-alias (Language:Language% Settings)
   (Class () () ([get-reader-module (-> Sexp)]
                 [get-metadata-lines (-> Number)]

collects/drracket/private/debug.rkt

@@ -900,7 +900,8 @@ profile todo:
               (message-box (string-constant drscheme)
                            (string-constant editor-changed-since-srcloc-recorded)
                            frame
-                           '(ok caution))))
+                           '(ok caution)
+                           #:dialog-mixin frame:focus-table-mixin)))
           (when (and rep editor)
             (when (is-a? editor text:basic<%>)
               (send rep highlight-errors same-src-srclocs '())
@@ -1007,7 +1008,8 @@ profile todo:
                     (string-constant test-coverage-clear-and-do-not-ask-again)
                     (send (get-canvas) get-top-level-window)
                     '(default=1)
-                    2)])
+                    2
+                    #:dialog-mixin frame:focus-table-mixin)])
               (case msg-box-result
                 [(1) #t]
                 [(2) #f]
@@ -1419,7 +1421,8 @@ profile todo:
                     (eq? (message-box (string-constant drscheme)
                                       (string-constant profiling-clear?)
                                       frame
-                                      '(yes-no))
+                                      '(yes-no)
+                                      #:dialog-mixin frame:focus-table-mixin)
                          'yes))))))
       
       (define/private (do-reset-profile)
@@ -1561,7 +1564,8 @@ profile todo:
            (send (get-current-tab) refresh-profile)]
           [else
            (message-box (string-constant drscheme)
-                        (string-constant profiling-no-information-available))]))
+                        (string-constant profiling-no-information-available)
+                        #:dialog-mixin frame:focus-table-mixin)]))
       
       (define/public (hide-profile-gui)
         (when profile-gui-constructed?

collects/drracket/private/expanding-place.rkt

@@ -17,7 +17,8 @@
   ;; get the module-language-compile-lock in the initial message
   (set! module-language-parallel-lock-client
         (compile-lock->parallel-lock-client
-         (place-channel-get p)))
+         (place-channel-get p)
+         (current-custodian)))
   
   ;; get the handlers in a second message
   (set! handlers (for/list ([lst (place-channel-get p)])
@@ -43,6 +44,7 @@
 
 (define (abort-job job)
   (custodian-shutdown-all (job-cust job))
+  (log-info "expanding-place.rkt: kill")
   (place-channel-put (job-response-pc job) #f))
 
 (struct exn:access exn:fail ())

collects/drracket/private/frame.rkt

@@ -295,7 +295,8 @@
                              [else
                               (message-box (string-constant drscheme)
                                            (format (string-constant keybindings-planet-malformed-spec)
-                                                   planet-spec))]))))))
+                                                   planet-spec)
+                                           #:dialog-mixin frame:focus-table-mixin)]))))))
                (let ([ud (preferences:get 'drracket:user-defined-keybindings)])
                  (unless (null? ud)
                    (new separator-menu-item% (parent keybindings-menu))
@@ -343,7 +344,8 @@
                                                  (if (path? item)
                                                      (path->string item)
                                                      (format "~s" item))
-                                                 (exn-message x)))
+                                                 (exn-message x))
+                                         #:dialog-mixin frame:focus-table-mixin)
                             #f)])
       (keymap:add-user-keybindings-file item)
       #t))
@@ -459,7 +461,8 @@
                        (message-box (string-constant drscheme)
                                     (if (exn? exn)
                                         (format "~a" (exn-message exn))
-                                        (format "~s" exn))))])
+                                        (format "~s" exn))
+                                    #:dialog-mixin frame:focus-table-mixin))])
       (let* ([url (string->url s-url)]
              [tmp-filename (make-temporary-file "tmp~a.plt")]
              [port (get-impure-port url)]

collects/drracket/private/init.rkt

@@ -1,7 +1,8 @@
 #lang racket/unit
   (require string-constants
            "drsig.rkt"
-           racket/gui/base)
+           racket/gui/base
+           framework)
   
   
   (import)
@@ -50,4 +51,4 @@
          
          (parameterize ([current-custodian system-custodian])
            (parameterize ([current-eventspace error-display-eventspace])
-             (message-box title text #f '(stop ok))))))))
+             (message-box title text #f '(stop ok) #:dialog-mixin frame:focus-table-mixin)))))))

collects/drracket/private/language-configuration.rkt

@@ -162,7 +162,7 @@
     (define language-dialog
       (λ (show-welcome? language-settings-to-show [parent #f])
         (define ret-dialog%
-          (class dialog%
+          (class (frame:focus-table-mixin dialog%)
             (define/override (on-subwindow-char receiver evt)
               (case (send evt get-key-code)
                 [(escape) (cancel-callback)]
@@ -170,7 +170,7 @@
                 [else
                  (or (key-pressed receiver evt)
                      (super on-subwindow-char receiver evt))]))
-            (super-instantiate ())))
+            (super-new)))
         
         (define dialog (instantiate ret-dialog% ()
                          (label (if show-welcome?
@@ -214,7 +214,8 @@
         (define (ok-callback)
           (unless (enter-callback)
             (message-box (string-constant drscheme)
-                         (string-constant please-select-a-language))))
+                         (string-constant please-select-a-language)
+                         #:dialog-mixin frame:focus-table-mixin)))
         
         ;; cancel-callback : -> void
         (define (cancel-callback)
@@ -1285,7 +1286,8 @@
                                                 (message-box (string-constant drscheme)
                                                              (if (exn? x)
                                                                  (exn-message x)
-                                                                 (format "uncaught exception: ~s" x)))
+                                                                 (format "uncaught exception: ~s" x))
+                                                             #:dialog-mixin frame:focus-table-mixin)
                                                 read-syntax/namespace-introduce)])
                                (contract
                                 (->* ()
@@ -1335,7 +1337,8 @@
                  numberss
                  summaries
                  urls
-                 reader-specs))])))))
+                 reader-specs)
+                #:dialog-mixin frame:focus-table-mixin)])))))
     
     (define (platform-independent-string->path str)
       (apply

collects/drracket/private/language.rkt

@@ -783,7 +783,8 @@
             [(string=? "" filename-str)
              (message-box (string-constant drscheme)
                           (string-constant please-specify-a-filename)
-                          dlg)
+                          dlg
+                          #:dialog-mixin frame:focus-table-mixin)
              #f]
             [(not (users-name-ok? mode extension dlg (string->path filename-str)))
              #f]
@@ -797,7 +798,8 @@
       (eq? (message-box (string-constant drscheme)
                         (format (string-constant are-you-sure-delete?) filename)
                         dlg
-                        '(yes-no))
+                        '(yes-no)
+                        #:dialog-mixin frame:focus-table-mixin)
            'yes))
     
     (define cancelled? #t)
@@ -904,7 +906,8 @@
                                [(distribution) (string-constant distribution)])
                              name
                              extension)
-                            parent)
+                            parent
+                            #:dialog-mixin frame:focus-table-mixin)
                #f)))))
   
   ;; default-executable-filename : path symbol boolean -> path
@@ -940,7 +943,8 @@
                      (λ (x)
                        (message-box 
                         (string-constant drscheme)
-                        (format "~a" (exn-message x)))
+                        (format "~a" (exn-message x))
+                        #:dialog-mixin frame:focus-table-mixin)
                        (void))])
       (define init-code-tmp-filename (make-temporary-file "drs-standalone-exectable-init~a"))
       (define bootstrap-tmp-filename (make-temporary-file "drs-standalone-exectable-bootstrap~a"))
@@ -1163,7 +1167,8 @@
                      (λ (x)
                        (message-box 
                         (string-constant drscheme)
-                        (format "~a" (exn-message x)))
+                        (format "~a" (exn-message x))
+                        #:dialog-mixin frame:focus-table-mixin)
                        (void))])
       
       ((if gui? make-mred-launcher make-mzscheme-launcher)

collects/drracket/private/main.rkt

@@ -116,7 +116,7 @@
                                  ll))))
 
 (drr:set-default 'drracket:module-language-first-line-special? #t boolean?)
-
+(drr:set-default 'drracket:use-old-style-keybindings #f boolean?)
 (drr:set-default 'drracket:defns-popup-sort-by-name? #f boolean?)
 (drr:set-default 'drracket:show-line-numbers? #f boolean?)
 
@@ -329,6 +329,10 @@
 
      (make-check-box 'drracket:module-language-first-line-special?
                      (string-constant ml-always-show-#lang-line)
+                     editor-panel)
+     
+     (make-check-box 'drracket:use-old-style-keybindings
+                     (string-constant old-style-keybindings)
                      editor-panel)))
   
   (preferences:add-to-editor-checkbox-panel

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

@@ -89,7 +89,7 @@
   
   (define definitions-text-mixin
     (mixin (text:basic<%> drracket:unit:definitions-text<%>) (drracket:module-language-tools:definitions-text<%>)
-      (inherit get-next-settings)
+      (inherit get-next-settings get-filename)
       (define in-module-language? #f)      ;; true when we are in the module language
       (define hash-lang-last-location #f)  ;; non-false when we know where the hash-lang line ended
       (define hash-lang-language #f)       ;; non-false is the string that was parsed for the language
@@ -101,13 +101,26 @@
         (inner (void) after-delete start len)
         (modification-at start))
       
+      (define last-filename #f)
+      (define/augment (after-save-file success?)
+        (inner (void) after-save-file success?)
+        (define this-filename (get-filename))
+        (unless (equal? last-filename this-filename)
+          (set! last-filename this-filename)
+          (modification-at #f)))
+      
       (define timer #f)
       
+      ;; modification-at : (or/c #f number) -> void
+      ;; checks to see if the lang line has changed when start
+      ;; is in the region of the lang line, or when start is #f, or
+      ;; when there is no #lang line known.
       (define/private (modification-at start)
         (send (send (get-tab) get-frame) when-initialized
               (λ ()
                 (when in-module-language?
-                  (when (or (not hash-lang-last-location)
+                  (when (or (not start)
+                            (not hash-lang-last-location)
                             (<= start hash-lang-last-location))
                     
                     (unless timer

collects/drracket/private/module-language.rkt

@@ -9,7 +9,7 @@
          racket/sandbox
          racket/runtime-path
          racket/math
-         mred
+         racket/gui/base
          compiler/embed
          compiler/cm
          launcher
@@ -18,6 +18,7 @@
          planet/config
          setup/dirs
          racket/place
+         "tooltip.rkt"
          "drsig.rkt"
          "rep.rkt"
          "eval-helpers.rkt"
@@ -532,7 +533,9 @@
        new-parent
        #:case-sensitive #t
        
-       #:get-debugging-radio-box (λ (rb-l rb-r) (set! left-debugging-radio-box rb-l) (set! right-debugging-radio-box rb-r))
+       #:get-debugging-radio-box (λ (rb-l rb-r) 
+                                   (set! left-debugging-radio-box rb-l)
+                                   (set! right-debugging-radio-box rb-r))
        
        #:debugging-radio-box-callback
        (λ (debugging-radio-box evt)
@@ -658,7 +661,8 @@
     
     (define (get-lb-vector)
       (list->vector (for/list ([n (in-range (send collection-paths-lb get-number))])
-                              (cons (send collection-paths-lb get-string n) (send collection-paths-lb get-data n)))))
+                              (cons (send collection-paths-lb get-string n)
+                                    (send collection-paths-lb get-data n)))))
     
     (define (set-lb-vector vec)
       (send collection-paths-lb clear)
@@ -829,7 +833,9 @@
                    [stretchable-height #f]
                    [parent expand-error-parent-panel]))
         
-        (set! expand-error-message (new error-message% [parent expand-error-panel] [stretchable-width #t] [msg "hi"]))
+        (set! expand-error-message (new error-message% [parent expand-error-panel]
+                                        [stretchable-width #t]
+                                        [msg "hi"]))
         (set! expand-error-button-parent-panel
               (new vertical-panel% 
                    [stretchable-width #f]
@@ -909,24 +915,11 @@
         (cond
           [tooltip-labels
            (unless tooltip-frame
-             (set! tooltip-frame 
-                   (new (class frame%
-                          (define/override (on-subwindow-event r evt)
-                            (cond
-                              [(send evt button-down?)
-                               (hide-tooltip)
-                               #t]
-                              [else #f]))
-                          (super-new [style '(no-resize-border no-caption float)]
-                                     [label ""]
-                                     [stretchable-width #f]
-                                     [stretchable-height #f] ))))
-             (new yellow-message% [parent tooltip-frame]))
-           (send (car (send tooltip-frame get-children)) set-lab tooltip-labels)
-           (send tooltip-frame reflow-container)
+             (set! tooltip-frame (new tooltip-frame%)))
+           (send tooltip-frame set-tooltip tooltip-labels)
            (define-values (rx ry) (send running-canvas client->screen 0 0))
-           (send tooltip-frame move (- rx (send tooltip-frame get-width)) (- ry (send tooltip-frame get-height)))
-           (send tooltip-frame show #t)]
+           (define-values (cw ch) (send running-canvas get-client-size))
+           (send tooltip-frame show-over rx ry cw ch #:prefer-upper-left? #t)]
           [else
            (when tooltip-frame
              (send tooltip-frame show #f))]))
@@ -1098,10 +1091,11 @@
       (unless place-initialized?
         (set! place-initialized? #t)
         (place-channel-put expanding-place module-language-compile-lock)
-        (place-channel-put expanding-place 
-                           (for/list ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))])
-                             (list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h)
-                                   (drracket:module-language-tools:online-expansion-handler-id o-e-h)))))
+        (place-channel-put
+         expanding-place 
+         (for/list ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))])
+           (list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h)
+                 (drracket:module-language-tools:online-expansion-handler-id o-e-h)))))
       (set! pending-thread
             (thread (λ () 
                       (define-values (pc-in pc-out) (place-channel))
@@ -1131,7 +1125,7 @@
             drracket:unit:definitions-text<%>
             drracket:module-language-tools:definitions-text<%>) ()
       (inherit last-position find-first-snip get-top-level-window get-filename
-               get-tab highlight-range get-canvas 
+               get-tab get-canvas invalidate-bitmap-cache 
                set-position get-start-position get-end-position)
       
       (define compilation-out-of-date? #f)
@@ -1145,7 +1139,6 @@
       
       (define/private (buffer-modified)
         (clear-old-error)
-        (set! clear-old-error void)
         (reset-frame-expand-error)
         (let ([tlw (get-top-level-window)])
           (when expanding-place
@@ -1178,7 +1171,6 @@
                              (λ (res) (show-results res)))
               (when status-line-open?
                 (clear-old-error)
-                (set! clear-old-error void)
                 (reset-frame-expand-error))
               (send (get-tab) show-bkg-running 'running sc-online-expansion-running)))))
       
@@ -1203,7 +1195,6 @@
           (values str fn)))
       
       (define status-line-open? #f)
-      (define clear-old-error void) 
       
       (define error-message-str #f)
       (define error-message-srclocs '())
@@ -1255,40 +1246,35 @@
           [(exn)
            (define tlw (send (get-tab) get-frame))
            (send (get-tab) show-bkg-running 'nothing #f)
-           (clear-old-error)
            (set! error-message-str (vector-ref res 1))
            (set! error-message-srclocs (vector-ref res 2))
-           (set! clear-old-error
-                 (for/fold ([clear void])
-                           ([range (in-list (vector-ref res 2))])
+           (set! error-ranges 
+                 (for/list ([range (in-list (vector-ref res 2))])
                    (define pos (vector-ref range 0))
                    (define span (vector-ref range 1))
-                   (define clear-next (highlight-range (- pos 1) (+ pos span -1) "Gold" #f 'high))
-                   (lambda () (clear) (clear-next))))
+                   (list (- pos 1) (+ pos span -1))))
+           ;; should really only invalidate the appropriate region here (and in clear-error-ranges)
+           (invalidate-bitmap-cache 0 0 'display-end 'display-end)
            (update-frame-expand-error)]
           [(access-violation)
            (send (get-tab) show-bkg-running 'failed (gui-utils:format-literal-label "~a" (vector-ref res 1)))
            (clear-old-error)
-           (set! clear-old-error void)
            (reset-frame-expand-error)]
           [(reader-in-defs-error)
-           (send (get-tab) show-bkg-running 'reader-in-defs-error (gui-utils:format-literal-label "~a" (vector-ref res 1)))
+           (send (get-tab) show-bkg-running 'reader-in-defs-error
+                 (gui-utils:format-literal-label "~a" (vector-ref res 1)))
            (clear-old-error)
-           (set! clear-old-error void)
            (reset-frame-expand-error)]
           [(abnormal-termination)
            (send (get-tab) show-bkg-running 'failed sc-abnormal-termination)
            (clear-old-error)
-           (set! clear-old-error void)
            (reset-frame-expand-error)]
           [(no-errors)
            (send (get-tab) show-bkg-running 'nothing #f)
            (clear-old-error)
-           (set! clear-old-error void)
            (reset-frame-expand-error)]
           [(handler-results)
            (clear-old-error)
-           (set! clear-old-error void)
            (reset-frame-expand-error)
            ;; inform the installed handlers that something has come back
            (for ([key-val (in-list (vector-ref res 1))])
@@ -1303,6 +1289,68 @@
           [else
            (error 'module-language.rkt "unknown response from the expanding place: ~s\n" res)]))
       
+      
+      (define error-ranges '())
+      (define/private (clear-old-error)
+        (set! error-ranges '())
+        (invalidate-bitmap-cache 0 0 'display-end 'display-end))
+      
+      (define byt (box 0.0))
+      (define byb (box 0.0))
+      (define vbx (box 0.0))
+      (define vby (box 0.0))
+      (define vbw (box 0.0))
+      (define vbh (box 0.0))
+    
+      (inherit position-location get-admin)
+      (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+        (super on-paint before? dc left top right bottom dx dy draw-caret)
+        (unless before?
+          (define pen-width 8)
+          (define saved-brush (send dc get-brush))
+          (define saved-pen (send dc get-pen))
+          (define smoothing (send dc get-smoothing))
+          (send dc set-smoothing 'smoothed)
+          
+          (define path (new dc-path%))
+          (send dc set-brush "black" 'transparent)
+          (send dc set-pen (send the-pen-list find-or-create-pen "red" pen-width 'solid 'butt 'miter))
+          (send dc set-alpha .4)
+          
+          (for ([error-range (in-list error-ranges)])
+            (define start-pos (list-ref error-range 0))
+            (define end-pos (list-ref error-range 1))
+            (position-location start-pos #f byt)
+            (position-location end-pos #f byb #f)
+            (send (get-admin) get-view vbx vby vbw vbh)
+            
+            (define x2 (+ dx (unbox vbx) (unbox vbw) (- (/ pen-width 2)) (- (/ pen-width 1))))
+            (define y2 (+ dy (unbox byt)))
+            
+            (define x1 (+ x2 (- (/ pen-width 1))))
+            (define y1 y2)
+            
+            (define x3 x2)
+            (define y3 (+ dy (unbox byb)))
+            
+            (define x4 x1)
+            (define y4 y3)
+            
+            (send path move-to x1 y1)
+            (send path line-to x2 y2)
+            (send path line-to x3 y3)
+            (send path line-to x4 y4)
+            (send path line-to x3 y3)
+            (send path line-to x2 y2)
+            (send path move-to x1 y1)
+            (send path close))
+          
+          (send dc draw-path path)
+          (send dc set-alpha 1)
+          (send dc set-brush saved-brush)
+          (send dc set-pen saved-pen)
+          (send dc set-smoothing smoothing)))
+      
       (define/override (move-to-new-language)
         ;; this is here to get things running for the initital tab in a new frame
         (super move-to-new-language)
@@ -1396,7 +1444,8 @@
   
   (define module-language-parallel-lock-client
     (compile-lock->parallel-lock-client
-     module-language-compile-lock))
+     module-language-compile-lock
+     (current-custodian)))
 
   ;; in-module-language : top-level-window<%> -> module-language-settings or #f
   (define (in-module-language tlw)

collects/drracket/private/rep.rkt

@@ -903,7 +903,7 @@ TODO
                                   (floor (/ new-limit 1024 1024))))
                      frame
                      '(default=1 stop)
-                     )])
+                     #:dialog-mixin frame:focus-table-mixin)])
           (when (equal? ans 3)
             (set-custodian-limit new-limit)
             (preferences:set 'drracket:child-only-memory-limit new-limit))
@@ -1369,7 +1369,8 @@ TODO
                          #f
                          (or (get-top-level-window) (get-can-close-parent))
                          '(default=1 caution)
-                         2)
+                         2
+                         #:dialog-mixin frame:focus-table-mixin)
                         1)]
                [(let ([user-eventspace (get-user-eventspace)])
                   (and user-eventspace
@@ -1383,7 +1384,8 @@ TODO
                          #f
                          (or (get-top-level-window) (get-can-close-parent))
                          '(default=1 caution)
-                         2)
+                         2
+                         #:dialog-mixin frame:focus-table-mixin)
                         1)]
                [else #t])
              (inner #t can-close?)))

collects/drracket/private/syncheck/contract-traversal.rkt

@@ -109,7 +109,7 @@
             (call-give-up)]
            [(define-syntaxes (id ...) expr)
             (call-give-up)]
-           [(define-values-for-syntax (id ...) expr)
+           [(begin-for-syntax (id ...) expr)
             (call-give-up)]
            [(#%require rspec ...)
             (call-give-up)]

collects/drracket/private/syncheck/gui.rkt

@@ -50,7 +50,8 @@ If the namespace does not, they are colored the unbound color.
          "intf.rkt"
          "colors.rkt"
          "traversals.rkt"
-         "annotate.rkt")
+         "annotate.rkt"
+         "../tooltip.rkt")
 (provide tool@)
 
 (define orig-output-port (current-output-port))
@@ -198,6 +199,8 @@ If the namespace does not, they are colored the unbound color.
       #:transparent)
     (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos) #:transparent)
     
+    (define-struct tooltip-info (text pos-left pos-right msg) #:transparent)
+    
     ;; color : string
     ;; text: text:basic<%>
     ;; start, fin: number
@@ -470,10 +473,7 @@ If the namespace does not, they are colored the unbound color.
               (set! arrow-records (make-hasheq))
               (set! bindings-table (make-hash))
               (set! cleanup-texts '())
-              (set! style-mapping (make-hash))
-              (let ([f (get-top-level-window)])
-                (when f
-                  (send f open-status-line 'drracket:check-syntax:mouse-over))))
+              (set! style-mapping (make-hash)))
             
             (define/public (syncheck:arrows-visible?)
               (or arrow-records cursor-location cursor-text))
@@ -493,9 +493,7 @@ If the namespace does not, they are colored the unbound color.
                 (set! style-mapping #f)
                 (invalidate-bitmap-cache)
                 (update-docs-background #f)
-                (let ([f (get-top-level-window)])
-                  (when f
-                    (send f close-status-line 'drracket:check-syntax:mouse-over)))))
+                (clear-tooltips)))
             
             ;; syncheck:apply-style/remember : (is-a?/c text%) number number style% symbol -> void
             (define/public (syncheck:apply-style/remember txt start finish style mode)
@@ -538,14 +536,13 @@ If the namespace does not, they are colored the unbound color.
                 [else #f]))
             
             (define/public (syncheck:add-require-open-menu text start-pos end-pos file)
-              (define (make-require-open-menu file)
-                (λ (menu)
-                  (let-values ([(base name dir?) (split-path file)])
-                    (instantiate menu-item% ()
-                      (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name)))
-                      (parent menu)
-                      (callback (λ (x y) (fw:handler:edit-file file))))
-                    (void))))
+              (define ((make-require-open-menu file) menu)
+                (define-values (base name dir?) (split-path file))
+                (new menu-item%
+                     (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name)))
+                     (parent menu)
+                     (callback (λ (x y) (fw:handler:edit-file file))))
+                (void))
               (syncheck:add-menu text start-pos end-pos #f (make-require-open-menu file)))
             
             (define/public (syncheck:add-docs-menu text start-pos end-pos id the-label path tag)
@@ -573,14 +570,14 @@ If the namespace does not, they are colored the unbound color.
             (define/public (syncheck:add-rename-menu id-as-sym to-be-renamed/poss name-dup?)
               (define (make-menu menu)
                 (let ([name-to-offer (format "~a" id-as-sym)])
-                  (instantiate menu-item% ()
-                    (parent menu)
-                    (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer))
-                    (callback
-                     (λ (x y)
-                       (let ([frame-parent (find-menu-parent menu)])
-                         (rename-callback name-to-offer
-                                          frame-parent)))))))
+                  (new menu-item%
+                       [parent menu]
+                       [label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)]
+                       [callback
+                        (λ (x y)
+                          (let ([frame-parent (find-menu-parent menu)])
+                            (rename-callback name-to-offer
+                                             frame-parent)))])))
               
               ;; rename-callback : string 
               ;;                   (and/c syncheck-text<%> definitions-text<%>)
@@ -597,7 +594,8 @@ If the namespace does not, they are colored the unbound color.
                            (string-constant cs-rename-id)
                            (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer)
                            parent
-                           name-to-offer)))])
+                           name-to-offer
+                           #:dialog-mixin frame:focus-table-mixin)))])
                   (when new-str
                     (define new-sym (format "~s" (string->symbol new-str)))
                     (define dup-name? (name-dup? new-sym))
@@ -613,7 +611,8 @@ If the namespace does not, they are colored the unbound color.
                             (string-constant cancel)
                             #f
                             parent
-                            '(stop default=2))
+                            '(stop default=2)
+                            #:dialog-mixin frame:focus-table-mixin)
                            1)))
                     
                     (when do-renaming?
@@ -666,7 +665,7 @@ If the namespace does not, they are colored the unbound color.
               
             (define/private (syncheck:add-menu text start-pos end-pos key make-menu)
               (when arrow-records
-                (when (and (<= 0 start-pos end-pos (last-position)))
+                (when (<= 0 start-pos end-pos (last-position))
                   (add-to-range/key text start-pos end-pos make-menu key (and key #t)))))
             
             (define/public (syncheck:add-background-color text start fin color)
@@ -704,9 +703,10 @@ If the namespace does not, they are colored the unbound color.
             
             ;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void
             (define/public (syncheck:add-mouse-over-status text pos-left pos-right str)
-              (let ([str (gui-utils:format-literal-label "~a" str)])
-                (when arrow-records
-                  (add-to-range/key text pos-left pos-right str #f #f))))
+              (when arrow-records
+                (add-to-range/key text pos-left pos-right 
+                                  (make-tooltip-info text pos-left pos-right str)
+                                  #f #f)))
             
             ;; add-to-range/key : text number number any any boolean -> void
             ;; adds `key' to the range `start' - `end' in the editor
@@ -880,7 +880,6 @@ If the namespace does not, they are colored the unbound color.
             (define last-known-mouse-x #f)
             (define last-known-mouse-y #f)
             (define/override (on-event event)
-              
               (cond
                 [(send event leaving?)
                  (set! last-known-mouse-x #f)
@@ -897,9 +896,6 @@ If the namespace does not, they are colored the unbound color.
                        (set! cursor-location #f)
                        (set! cursor-text #f)
                        (set! cursor-eles #f)
-                       (let ([f (get-top-level-window)])
-                         (when f
-                           (send f update-status-line 'drracket:check-syntax:mouse-over #f)))
                        (invalidate-bitmap-cache))
                      (super on-event event)]
                     [(or (send event moving?)
@@ -938,20 +934,18 @@ If the namespace does not, they are colored the unbound color.
                          (set! cursor-eles eles)
                          (update-docs-background eles)
                          (when eles
-                           (update-status-line eles)
+                           (update-tooltips eles)
                            (for ([ele (in-list eles)])
                              (cond [(arrow? ele)
                                     (update-arrow-poss ele)]))
                            (invalidate-bitmap-cache)))))]
                   [else
                    (update-docs-background #f)
-                   (let ([f (get-top-level-window)])
-                     (when f
-                       (send f update-status-line 'drracket:check-syntax:mouse-over #f)))
                    (when (or cursor-location cursor-text)
                      (set! cursor-location #f)
                      (set! cursor-text #f)
                      (set! cursor-eles #f)
+                     (clear-tooltips)
                      (invalidate-bitmap-cache))])))
 
             (define/public (syncheck:build-popup-menu pos text)
@@ -970,7 +964,8 @@ If the namespace does not, they are colored the unbound color.
                                       [arrows (filter arrow? vec-ents)]
                                       [def-links (filter def-link? vec-ents)]
                                       [var-arrows (filter var-arrow? arrows)]
-                                      [add-menus (map cdr (filter pair? vec-ents))])
+                                      [add-menus (append (map cdr (filter pair? vec-ents))
+                                                         (filter procedure? vec-ents))])
                                  (unless (null? arrows)
                                    (make-object menu-item%
                                      (string-constant cs-tack/untack-arrow)
@@ -1035,22 +1030,70 @@ If the namespace does not, they are colored the unbound color.
                                
                                  menu)]))))))
             
-            (define/private (update-status-line eles)
-              (let ([has-txt? #f])
-                (for-each (λ (ele)
-                            (cond
-                              [(string? ele)
-                               (set! has-txt? #t)
-                               (let ([f (get-top-level-window)])
-                                 (when f
-                                   (send f update-status-line 
-                                         'drracket:check-syntax:mouse-over 
-                                         ele)))]))
-                          eles)
-                (unless has-txt?
-                  (let ([f (get-top-level-window)])
-                    (when f
-                      (send f update-status-line 'drracket:check-syntax:mouse-over #f))))))
+            (define tooltip-frame #f)
+            (define/private (update-tooltips eles)
+              (unless tooltip-frame (set! tooltip-frame (new tooltip-frame%)))
+              (define tooltip-infos (filter tooltip-info? eles))
+              (cond
+                [(null? tooltip-infos)
+                 (send tooltip-frame show #f)]
+                [else
+                 (send tooltip-frame set-tooltip (map tooltip-info-msg tooltip-infos))
+                 (let loop ([tooltip-infos tooltip-infos]
+                            [l #f]
+                            [t #f]
+                            [r #f]
+                            [b #f])
+                   (cond
+                     [(null? tooltip-infos)
+                      (if (and l t r b)
+                          (send tooltip-frame show-over l t (- r l) (- b t))
+                          (send tooltip-frame show #f))]
+                     [else
+                      (define-values (tl tt tr tb) (tooltip-info->ltrb (car tooltip-infos)))
+                      (define (min/f x y) (cond [(and x y) (min x y)] [x x] [y y] [else #f]))
+                      (define (max/f x y) (cond [(and x y) (max x y)] [x x] [y y] [else #f]))
+                      (loop (cdr tooltip-infos)
+                            (min/f tl l)
+                            (min/f tt t)
+                            (max/f tr r)
+                            (max/f tb b))]))]))
+            
+            (define/private (clear-tooltips)
+              (when tooltip-frame (send tooltip-frame show #f)))
+
+            (define/private (tooltip-info->ltrb tooltip)
+              (define xlb (box 0))
+              (define ylb (box 0))
+              (define xrb (box 0))
+              (define yrb (box 0))
+              (define left-pos (tooltip-info-pos-left tooltip))
+              (define right-pos (tooltip-info-pos-right tooltip))
+              (define text (tooltip-info-text tooltip))
+              (send text position-location left-pos xlb ylb #t)
+              (send text position-location right-pos xrb yrb #f)
+              (define-values (xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb)))
+              (define-values (xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb)))
+              (define window
+                (let loop ([ed text])
+                  (cond
+                    [(send ed get-canvas) => values]
+                    [else
+                     (define admin (send ed get-admin))
+                     (if (is-a? admin editor-snip-editor-admin<%>)
+                         (loop (send (send admin get-snip) get-editor))
+                         #f)])))
+              (cond
+                [window
+                 (define (c n) (inexact->exact (round n)))
+                 (define-values (glx gly) (send window client->screen (c xl-off) (c yl-off)))
+                 (define-values (grx gry) (send window client->screen (c xr-off) (c yr-off)))
+                 (values (min glx grx)
+                         (min gly gry)
+                         (max glx grx)
+                         (max gly gry))]
+                [else
+                 (values #f #f #f #f)]))
             
             (define current-colored-region #f)
             ;; update-docs-background : (or/c false/c (listof any)) -> void
@@ -1711,6 +1754,7 @@ If the namespace does not, they are colored the unbound color.
                (define module-language?
                  (is-a? (drracket:language-configuration:language-settings-language settings)
                         drracket:module-language:module-language<%>))
+               (send definitions-text-copy set-style-list (send definitions-text get-style-list)) ;; speeds up the copy
                (send definitions-text copy-self-to definitions-text-copy)
                (with-lock/edit-sequence
                 definitions-text-copy

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

@@ -31,7 +31,7 @@
         (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) ;; we don't log these as they require space in the window
+    (log syncheck:add-mouse-over-status)
     (log syncheck:add-arrow)
     (log syncheck:add-tail-arrow)
     (log syncheck:add-background-color)

collects/drracket/private/syncheck/traversals.rkt

@@ -185,7 +185,7 @@
             (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set!
                                                quote quote-syntax with-continuation-mark 
                                                #%plain-app #%top #%plain-module-begin
-                                               define-values define-syntaxes define-values-for-syntax module
+                                               define-values define-syntaxes begin-for-syntax module
                                                #%require #%provide #%expression)
               (if high-level? free-transformer-identifier=? free-identifier=?)
               [(#%plain-lambda args bodies ...)
@@ -317,12 +317,10 @@
                  (add-binders (syntax names) binders binding-inits #'exp)
                  (maybe-jump (syntax names))
                  (level-loop (syntax exp) #t))]
-              [(define-values-for-syntax names exp)
+              [(begin-for-syntax exp ...)
                (begin
                  (annotate-raw-keyword sexp varrefs)
-                 (add-binders (syntax names) high-binders binding-inits #'exp)
-                 (maybe-jump (syntax names))
-                 (level-loop (syntax exp) #t))]
+                 (for-each (lambda (e) (level-loop e #t)) (syntax->list (syntax (exp ...)))))]
               [(module m-name lang (#%plain-module-begin bodies ...))
                (begin
                  (annotate-raw-keyword sexp varrefs)

collects/drracket/private/tooltip.rkt

@@ -0,0 +1,87 @@
+#lang racket/base
+(require racket/gui/base
+         racket/class)
+
+(provide tooltip-frame%)
+
+(define tooltip-frame%
+  (class frame%
+    (inherit show reflow-container move get-width get-height)
+    (define/override (on-subwindow-event r evt)
+      (cond
+        [(send evt button-down?)
+         (show #f)
+         #t]
+        [else #f]))
+    (define/public (set-tooltip ls) 
+      (send yellow-message set-lab ls))
+    
+    (define/public (show-over x y w h #:prefer-upper-left? [prefer-upper-left? #f])
+      (reflow-container)
+      (define mw (get-width))
+      (define mh (get-height))
+      (define (upper-left must?) 
+        (define the-x (- x mw))
+        (define the-y (- y mh))
+        (if must?
+            (move the-x the-y)
+            (try-moving-to the-x the-y mw mh)))
+      (define (lower-right must?) 
+        (define the-x (+ x w))
+        (define the-y (+ y h))
+        (if must?
+            (move the-x the-y)
+            (try-moving-to the-x the-y mw mh)))
+      (if prefer-upper-left?
+          (or (upper-left #t) (lower-right #f) (upper-left #t))
+          (or (lower-right #t) (upper-left #f) (lower-right #t)))
+      (show #t))
+    
+    (define/private (try-moving-to x y w h)
+      (and (for/or ([m (in-range 0 (get-display-count))])
+             (define-values (mx my) (get-display-left-top-inset #:monitor m))
+             (define-values (mw mh) (get-display-size #:monitor m))
+             (and (<= (- mx) x (+ x w) (+ (- mx) mw))
+                  (<= (- my) y (+ y h) (+ (- my) mh))))
+           (begin (move x y)
+                  #t)))
+
+    (super-new [style '(no-resize-border no-caption float)]
+               [label ""]
+               [stretchable-width #f]
+               [stretchable-height #f])
+    (define yellow-message (new yellow-message% [parent this]))))
+
+(define yellow-message%
+  (class canvas%
+    (inherit get-dc refresh get-client-size
+             min-width min-height
+             get-parent)
+    (define labels '(""))
+    (define/public (set-lab _ls) 
+      (unless (equal? labels _ls)
+        (set! labels _ls)
+        (update-size)
+        (refresh)))
+    (define/private (update-size)
+      (define dc (get-dc))
+      (send dc set-font small-control-font)
+      (define-values (w h _1 _2) (send dc get-text-extent (car labels)))
+      (send (get-parent) begin-container-sequence)
+      (min-width (+ 5 (inexact->exact (ceiling w))))
+      (min-height (+ 5 (* (length labels) (inexact->exact (ceiling h)))))
+      (send (get-parent) end-container-sequence)
+      (send (get-parent) reflow-container))
+    (define/override (on-paint)
+      (define dc (get-dc))
+      (send dc set-font small-control-font)
+      (define-values (w h) (get-client-size))
+      (define-values (tw th _1 _2) (send dc get-text-extent (car labels)))
+      (send dc set-pen "black" 1 'transparent)
+      (send dc set-brush "LemonChiffon" 'solid)
+      (send dc set-pen "black" 1 'solid)
+      (send dc draw-rectangle 0 0 w h)
+      (for ([label (in-list labels)]
+            [i (in-naturals)])
+        (send dc draw-text label 2 (+ 2 (* i th)))))
+    (super-new [stretchable-width #f] [stretchable-height #f])))

collects/drracket/private/unit.rkt

@@ -150,7 +150,8 @@ module browser threading seems wrong.
                                      [else
                                       (message-box 
                                        (string-constant drscheme)
-                                       "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm")])))))]))))))
+                                       "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm"
+                                       #:dialog-mixin frame:focus-table-mixin)])))))]))))))
            
            (void))))))
   
@@ -338,7 +339,8 @@ module browser threading seems wrong.
                    (message-box
                     (string-constant drscheme)
                     v
-                    dlg)])))]
+                    dlg
+                    #:dialog-mixin frame:focus-table-mixin)])))]
            [cancel-callback 
             (λ () (send dlg show #f))])
       (let-values ([(ok cancel) 
@@ -364,7 +366,8 @@ module browser threading seems wrong.
         [(not program-filename)
          (message-box (string-constant create-executable-title)
                       (string-constant must-save-before-executable)
-                      frame)]
+                      frame
+                      #:dialog-mixin frame:focus-table-mixin)]
         [else
          (when (or (not (send definitions-text is-modified?))
                    (gui-utils:get-choice
@@ -1146,12 +1149,10 @@ module browser threading seems wrong.
       (define/public-final (set-i _i) (set! i _i))
       (define/public (disable-evaluation)
         (set! enabled? #f)
-        (send defs lock #t)
         (send ints lock #t)
         (send frame disable-evaluation-in-tab this))
       (define/public (enable-evaluation)
         (set! enabled? #t)
-        (send defs lock #f)
         (send ints lock #f)
         (send frame enable-evaluation-in-tab this))
       (define/public (get-enabled) enabled?)
@@ -1264,6 +1265,8 @@ module browser threading seems wrong.
       (define/public-final (toggle-log)
         (set! log-visible? (not log-visible?))
         (send frame show/hide-log log-visible?))
+      (define/public-final (hide-log)
+        (when log-visible? (toggle-log)))
       (define/public-final (update-log)
         (send frame show/hide-log log-visible?))
       (define/public-final (update-logger-window command)
@@ -1430,19 +1433,25 @@ module browser threading seems wrong.
                         (remq logger-panel l)])))]
             [else
              (when show? ;; if we want to hide and it isn't built yet, do nothing
+               (define logger-gui-tab-panel-parent (new horizontal-panel% [parent logger-panel] [stretchable-height #f]))
                (set! logger-gui-tab-panel
                      (new tab-panel% 
                           [choices (list (string-constant logging-all)
                                          "fatal" "error" "warning" "info" "debug")]
-                          [parent logger-panel]
+                          [parent logger-gui-tab-panel-parent]
+                          [stretchable-height #f]
+                          [style '(no-border)]
                           [callback
                            (λ (tp evt)
                              (preferences:set 'drracket:logger-gui-tab-panel-level (send logger-gui-tab-panel get-selection))
                              (update-logger-window #f))]))
+               (new button% [label (string-constant hide-log)]
+                    [callback (λ (x y) (send current-tab hide-log))]
+                    [parent logger-gui-tab-panel-parent])
                (send logger-gui-tab-panel set-selection (preferences:get 'drracket:logger-gui-tab-panel-level))
                (new-logger-text)
                (set! logger-gui-canvas 
-                     (new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text]))
+                     (new editor-canvas% [parent logger-panel] [editor logger-gui-text]))
                (send logger-menu-item set-label (string-constant hide-log))
                (update-logger-window #f)
                (send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))])
@@ -1669,7 +1678,8 @@ module browser threading seems wrong.
                             (gui-utils:format-literal-label (string-constant erase-log-directory-contents)
                                                             transcript-directory)
                             this
-                            '(yes-no))])
+                            '(yes-no)
+                            #:dialog-mixin frame:focus-table-mixin)])
                 (cond
                   [(eq? query 'no) 
                    #f]
@@ -1682,7 +1692,8 @@ module browser threading seems wrong.
                                                                        (if (exn? exn)
                                                                            (format "~a" (exn-message exn))
                                                                            (format "~s" exn)))
-                                       this)
+                                       this
+                                       #:dialog-mixin frame:focus-table-mixin)
                                       #f)])
                      (for-each (λ (file) (delete-file (build-path transcript-directory file)))
                                dir-list)
@@ -2647,23 +2658,17 @@ module browser threading seems wrong.
           (send interactions-text reset-console)
           (send interactions-text clear-undos)
           
-          (let ([start 0])
-            (send definitions-text split-snip start)
-            (let* ([name (send definitions-text get-port-name)]
-                   [text-port (open-input-text-editor definitions-text start 'end values name #t)])
-              (port-count-lines! text-port)
-              (let* ([line (send definitions-text position-paragraph start)]
-                     [column (- start (send definitions-text paragraph-start-position line))]
-                     [relocated-port (relocate-input-port text-port 
-                                                          (+ line 1)
-                                                          column
-                                                          (+ start 1))])
-                (port-count-lines! relocated-port)
-                (send interactions-text evaluate-from-port
-                      relocated-port
-                      #t
-                      (λ ()
-                        (send interactions-text clear-undos))))))))
+          (define name (send definitions-text get-port-name))
+          (define defs-copy (new text%))
+          (send defs-copy set-style-list (send definitions-text get-style-list)) ;; speeds up the copy
+          (send definitions-text copy-self-to defs-copy)
+          (define text-port (open-input-text-editor defs-copy 0 'end values name #t))
+          (port-count-lines! text-port)
+          (send interactions-text evaluate-from-port
+                text-port
+                #t
+                (λ ()
+                  (send interactions-text clear-undos)))))
       
       (inherit revert save)
       (define/private (check-if-save-file-up-to-date)
@@ -2677,7 +2682,8 @@ module browser threading seems wrong.
                   #f
                   this
                   '(caution default=2 number-order)
-                  1)])
+                  1
+                  #:dialog-mixin frame:focus-table-mixin)])
             (case user-choice
               [(1) (void)]
               [(2) (revert)]))))
@@ -2983,22 +2989,33 @@ module browser threading seems wrong.
         (update-close-menu-item-shortcut (file-menu:get-close-item)))
       
       (define/private (update-close-tab-menu-item-shortcut item)
-        (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))])
-          (send item set-label (if just-one? 
-                                   (string-constant close-tab)
-                                   (string-constant close-tab-amp)))
-          (when (preferences:get 'framework:menu-bindings)
-            (send item set-shortcut (if just-one? #f #\w)))))
+        (define just-one? (and (pair? tabs) (null? (cdr tabs))))
+        (send item set-label (if just-one? 
+                                 (string-constant close-tab)
+                                 (string-constant close-tab-amp)))
+        (when (preferences:get 'framework:menu-bindings)
+          (send item set-shortcut (if just-one? #f #\w))))
       
       (define/private (update-close-menu-item-shortcut item)
-        (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))])
-          (send item set-label (if just-one? 
-                                   (string-constant close-menu-item)
-                                   (string-constant close)))
-          (when (preferences:get 'framework:menu-bindings)
-            (send item set-shortcut-prefix (if just-one? 
-                                               (get-default-shortcut-prefix) 
-                                               (cons 'shift (get-default-shortcut-prefix)))))))
+        (cond
+          [(eq? (system-type) 'unix)
+           (send item set-label (string-constant close-menu-item))]
+          [else
+           (define just-one? (and (pair? tabs) (null? (cdr tabs))))
+           (send item set-label (if just-one?
+                                    (string-constant close-window-menu-item)
+                                    (string-constant close-window)))
+           (when (preferences:get 'framework:menu-bindings)
+             (send item set-shortcut-prefix (if just-one? 
+                                                (get-default-shortcut-prefix) 
+                                                (cons 'shift (get-default-shortcut-prefix)))))]))
+      
+      (define/override (file-menu:close-callback item control)
+        (define just-one? (and (pair? tabs) (null? (cdr tabs))))
+        (if (and (eq? (system-type) 'unix)
+                   (not just-one?))
+            (close-current-tab)
+            (super file-menu:close-callback item control)))
       
       ;; offer-to-save-file : path -> void
       ;; bring the tab that edits the file named by `path' to the front
@@ -3113,8 +3130,7 @@ module browser threading seems wrong.
                    [label (string-constant show-log)]
                    [parent show-menu]
                    [callback
-                    (λ (x y) (send current-tab toggle-log))]))
-        )
+                    (λ (x y) (send current-tab toggle-log))])))
       
       
       ;                                                                                                       
@@ -3174,7 +3190,8 @@ module browser threading seems wrong.
                            strs))])
           (unless can-browse?
             (message-box (string-constant drscheme)
-                         (string-constant module-browser-only-in-plt-and-module-langs)))
+                         (string-constant module-browser-only-in-plt-and-module-langs)
+                         #:dialog-mixin frame:focus-table-mixin))
           can-browse?))
       
       (define/private (update-module-browser-pane)
@@ -3328,7 +3345,7 @@ module browser threading seems wrong.
         (set! file-menu:create-new-tab-item
               (new menu:can-restore-menu-item%
                    (label (string-constant new-tab))
-                   (shortcut #\=)
+                   (shortcut (if (preferences:get 'drracket:use-old-style-keybindings) #\= #\t))
                    (parent file-menu)
                    (callback
                     (λ (x y)
@@ -3339,16 +3356,17 @@ module browser threading seems wrong.
           (make-object separator-menu-item% file-menu))]
       (define close-tab-menu-item #f)
       (define/override (file-menu:between-close-and-quit file-menu)
-        (set! close-tab-menu-item
-              (new (get-menu-item%)
-                   (label (string-constant close-tab))
-                   (demand-callback
-                    (λ (item)
-                      (send item enable (1 . < . (send tabs-panel get-number)))))
-                   (parent file-menu)
-                   (callback
-                    (λ (x y)
-                      (close-current-tab)))))
+        (unless (eq? (system-type) 'unix)
+          (set! close-tab-menu-item
+                (new (get-menu-item%)
+                     (label (string-constant close-tab))
+                     (demand-callback
+                      (λ (item)
+                        (send item enable (1 . < . (send tabs-panel get-number)))))
+                     (parent file-menu)
+                     (callback
+                      (λ (x y)
+                        (close-current-tab))))))
         (super file-menu:between-close-and-quit file-menu))
       
       (define/override (file-menu:save-string) (string-constant save-definitions))
@@ -3406,8 +3424,13 @@ module browser threading seems wrong.
                         (preferences:get 'framework:print-output-mode)))))
         (super file-menu:between-print-and-close file-menu))
       
+      (inherit edit-menu:get-replace-item)
       (define/override (edit-menu:between-find-and-preferences edit-menu)
         (super edit-menu:between-find-and-preferences edit-menu)
+        (when (preferences:get 'drracket:use-old-style-keybindings)
+          (define item (edit-menu:get-replace-item)) 
+          (send item set-shortcut #\r)
+          (send item set-shortcut-prefix (get-default-shortcut-prefix))) 
         (new menu:can-restore-menu-item%
              [label (string-constant complete-word)]
              [shortcut #\/]
@@ -3573,7 +3596,8 @@ module browser threading seems wrong.
                                                                                     (send l capability-value 'drscheme:teachpack-menu-items)
                                                                                     (format "\n  ~a" (send l get-language-name))))
                                                                                  (drracket:language-configuration:get-languages))))))
-                                         this))])))])))
+                                         this
+                                         #:dialog-mixin frame:focus-table-mixin))])))])))
       
       (define/private (initialize-menus)
         (let* ([mb (get-menu-bar)]
@@ -3609,7 +3633,7 @@ module browser threading seems wrong.
                   (string-constant execute-menu-item-label)
                   language-specific-menu
                   (λ (_1 _2) (execute-callback))
-                  #\t
+                  (if (preferences:get 'drracket:use-old-style-keybindings) #\t #\r)
                   (string-constant execute-menu-item-help-string)))
           (make-object menu:can-restore-menu-item%
             (string-constant ask-quit-menu-item-label)
@@ -4646,8 +4670,9 @@ module browser threading seems wrong.
                  (frame:editor-mixin
                   (frame:standard-menus-mixin
                    (frame:register-group-mixin
-                    (frame:basic-mixin
-                     frame%))))))))))))))))))
+                    (frame:focus-table-mixin
+                     (frame:basic-mixin
+                      frame%)))))))))))))))))))
   
   (define-local-member-name enable-two-way-prefs)
   (define (make-two-way-prefs-dragable-panel% % pref-key)

collects/errortrace/stacktrace.rkt

@@ -377,16 +377,14 @@
              expr
              (rebuild disarmed-expr (list (cons #'rhs marked)))))]
          
-         [(define-values-for-syntax (name ...) rhs)
+         [(begin-for-syntax . exprs)
           top?
-          (let ([marked (with-mark expr
-                                   (annotate-named
-                                    (one-name (syntax (name ...)))
-                                    (syntax rhs)
-                                    (add1 phase)))])
-            (rearm
-             expr
-             (rebuild disarmed-expr (list (cons #'rhs marked)))))]
+          (rearm
+           expr
+           (annotate-seq disarmed-expr
+                         (syntax exprs)
+                         annotate-top 
+                         (add1 phase)))]
 
          [(module name init-import mb)
           (syntax-case (disarm #'mb) ()

collects/framework/main.rkt

@@ -11,6 +11,11 @@
          (for-syntax scheme/base)
          scribble/srcdoc) 
 
+;; these next two lines do a little dance to make the
+;; require/doc setup work out properly
+(require (prefix-in :: framework/private/focus-table))
+(define frame:lookup-focus-table ::frame:lookup-focus-table)
+
 (require framework/preferences
          framework/test
          framework/gui-utils
@@ -710,6 +715,23 @@
     
     Defaults to @racket[#f].})
  
+ (proc-doc/names
+  frame:lookup-focus-table
+  (->* () (eventspace?) (listof (is-a?/c frame:focus-table<%>)))
+  (()
+   ((eventspace (current-eventspace))))
+  @{Returns a list of the frames in @racket[eventspace], where the first element of the list
+    is the frame with the focus.
+    
+    The order and contents of the list are maintained by
+    the methods in @racket[frame:focus-table-mixin], meaning that the
+    OS-level callbacks that track the focus of individual frames is 
+    ignored.
+    
+    See also @racket[test:use-focus-table] and @racket[test:get-active-top-level-window].
+    
+    })
+ 
  (proc-doc/names
   group:get-the-frame-group
   (-> (is-a?/c group:%))

collects/framework/private/color.rkt

@@ -638,7 +638,8 @@ added get-regions
                                    (if (is-a? color color%)
                                        color
                                        (if color mismatch-color (get-match-color)))
-                                   (= caret-pos (+ start-pos start)))])
+                                   (= caret-pos (+ start-pos start))
+                                   'low)])
         (set! clear-old-locations
               (let ([old clear-old-locations])
                 (λ ()

collects/framework/private/finder.rkt

@@ -1,14 +1,15 @@
 #lang scheme/unit
 
   (require string-constants
+           (prefix-in r: racket/gui/base)
            "sig.rkt"
            "../preferences.rkt"
            mred/mred-sig
            scheme/path)
   
-  
   (import mred^
-          [prefix keymap: framework:keymap^])
+          [prefix keymap: framework:keymap^]
+          [prefix frame: framework:frame^])
   
   (export (rename framework:finder^
                   [-put-file put-file]
@@ -44,7 +45,8 @@
              [name (or (and (string? name) (file-name-from-path name))
                        name)]
              [f (put-file prompt parent-win directory name
-                          (default-extension) style (default-filters))])
+                          (default-extension) style (default-filters)
+                          #:dialog-mixin frame:focus-table-mixin)])
         (and f (or (not filter) (filter-match? filter f filter-msg))
              (let* ([f (normal-case-path (simple-form-path f))]
                     [dir (path-only f)]
@@ -60,6 +62,7 @@
                   #f]
                  [else f]))))))
   
+  (define op (current-output-port))
   (define (*get-file style)
     (lambda ([directory #f]
              [prompt (string-constant select-file)]
@@ -67,7 +70,8 @@
              [filter-msg (string-constant file-wrong-form)]
              [parent-win (dialog-parent-parameter)])
       (let ([f (get-file prompt parent-win directory #f
-                         (default-extension) style (default-filters))])
+                         (default-extension) style (default-filters)
+                         #:dialog-mixin frame:focus-table-mixin)])
         (and f (or (not filter) (filter-match? filter f filter-msg))
              (cond [(directory-exists? f)
                     (message-box (string-constant error)

collects/framework/private/focus-table.rkt

@@ -0,0 +1,13 @@
+#lang racket/base
+(require racket/gui/base racket/class)
+(provide frame:lookup-focus-table
+         frame:set-focus-table)
+
+;; focus-table : hash[eventspace -o> (listof frame)]
+(define focus-table (make-hash))
+(define (frame:lookup-focus-table [eventspace (current-eventspace)])
+  (hash-ref focus-table eventspace '()))
+(define (frame:set-focus-table eventspace new)
+  (if (null? new)
+      (hash-remove! focus-table eventspace)
+      (hash-set! focus-table eventspace new)))

collects/framework/private/frame.rkt

@@ -9,6 +9,7 @@
          "../preferences.rkt"
          "../gui-utils.rkt"
          "bday.rkt"
+         framework/private/focus-table
          mrlib/close-icon
          mred/mred-sig
          scheme/path)
@@ -131,6 +132,26 @@
                    editing-this-file?
                    get-filename
                    make-visible))
+
+(define focus-table<%> (interface (top-level-window<%>)))
+(define focus-table-mixin
+  (mixin (top-level-window<%>) (focus-table<%>)
+    (inherit get-eventspace)
+    
+    (define/override (show on?)
+      (define old (remove this (frame:lookup-focus-table (get-eventspace))))
+      (define new (if on? (cons this old) old))
+      (frame:set-focus-table (get-eventspace) new)
+      (super show on?))
+    
+    (define/augment (on-close)
+      (frame:set-focus-table (get-eventspace) (remove this (frame:lookup-focus-table (get-eventspace))))
+      (inner (void) on-close))
+    
+    (super-new)
+    
+    (frame:set-focus-table (get-eventspace) (frame:lookup-focus-table (get-eventspace)))))
+
 (define basic-mixin
   (mixin ((class->interface frame%)) (basic<%>)
     
@@ -190,12 +211,11 @@
       (λ (% parent)
         (make-object % parent)))
     
-    (inherit can-close? on-close)
-    (define/public close
-      (λ ()
-        (when (can-close?)
-          (on-close)
-          (show #f))))
+    (inherit on-close can-close?)
+    (define/public (close)
+      (when (can-close?)
+        (on-close)
+        (show #f)))
     
     (inherit accept-drop-files)
     
@@ -2710,7 +2730,7 @@
     (min-width (+ (inexact->exact (ceiling indicator-width)) 4))
     (min-height (+ (inexact->exact (ceiling indicator-height)) 4))))
 
-(define basic% (register-group-mixin (basic-mixin frame%)))
+(define basic% (focus-table-mixin (register-group-mixin (basic-mixin frame%))))
 (define size-pref% (size-pref-mixin basic%))
 (define info% (info-mixin basic%))
 (define text-info% (text-info-mixin info%))

collects/framework/private/handler.rkt

@@ -120,25 +120,29 @@
 
 ;; add-to-recent : path -> void
 (define (add-to-recent filename)
-  (let* ([old-list (preferences:get 'framework:recently-opened-files/pos)]
-         [old-ents (filter (λ (x) (string=? (path->string (car x))
-                                            (path->string filename)))
-                           old-list)]
-         [old-ent (if (null? old-ents)
-                      #f
-                      (car old-ents))]
-         [new-ent (list filename
-                        (if old-ent (cadr old-ent) 0)
-                        (if old-ent (caddr old-ent) 0))]
-         [added-in (cons new-ent
-                         (remove new-ent old-list compare-recent-list-items))]
-         [new-recent (size-down added-in
-                                (preferences:get 'framework:recent-max-count))])
-    (preferences:set 'framework:recently-opened-files/pos new-recent)))
   
-;; compare-recent-list-items : recent-list-item recent-list-item -> boolean
-(define (compare-recent-list-items l1 l2)
-  (equal? (car l1) (car l2)))
+  (define old-list (preferences:get 'framework:recently-opened-files/pos))
+  (define old-ents (filter (λ (x) (recently-opened-files-same-enough-path? (car x) filename))
+                           old-list))
+  (define new-ent (if (null? old-ents)
+                      (list filename 0 0)
+                      (cons filename (cdr (car old-ents)))))
+  (define added-in (cons new-ent
+                         (remove* (list new-ent)
+                                  old-list 
+                                  (λ (l1 l2) 
+                                    (recently-opened-files-same-enough-path? (car l1) (car l2))))))
+  (define new-recent (size-down added-in
+                                (preferences:get 'framework:recent-max-count)))
+  (preferences:set 'framework:recently-opened-files/pos new-recent))
+
+;; same-enough-path? : path path -> boolean
+;; used to determine if the open-recent-files menu item considers two paths to be the same
+(define (recently-opened-files-same-enough-path? p1 p2)
+  (equal? (simplify-path (normal-case-path p1) #f)
+          (simplify-path (normal-case-path p2) #f)))
+
+
 
 ;; size-down : (listof X) -> (listof X)[< recent-max-count]
 ;; takes a list of stuff and returns the
@@ -167,8 +171,8 @@
           (preferences:get 'framework:recently-opened-files/pos)]
          [new-recent-items
           (map (λ (x)
-                 (if (string=? (path->string (car x))
-                               (path->string filename))
+                 (if (recently-opened-files-same-enough-path? (path->string (car x))
+                                                              (path->string filename))
                      (list* (car x) start end (cdddr x))
                      x))
                (preferences:get 'framework:recently-opened-files/pos))])
@@ -198,9 +202,8 @@
 
 (define (recent-list-item->menu-label recent-list-item)
   (let ([filename (car recent-list-item)])
-    (gui-utils:trim-string
-     (regexp-replace* #rx"&" (path->string filename) "\\&\\&")
-     200)))
+    (gui-utils:quote-literal-label
+     (path->string filename))))
 
 ;; this function must mimic what happens in install-recent-items
 ;; it returns #t if all of the labels of menus are the same, or approximation to
@@ -232,8 +235,12 @@
                (send ed set-position start end)))))]
       [else
        (preferences:set 'framework:recently-opened-files/pos
-                        (remove recent-list-item
-                                (preferences:get 'framework:recently-opened-files/pos)))
+                        (remove* (list recent-list-item)
+                                 (preferences:get 'framework:recently-opened-files/pos)
+                                 (λ (l1 l2)
+                                   (recently-opened-files-same-enough-path?
+                                    (car l1)
+                                    (car l2)))))
        (message-box (string-constant error)
                     (format (string-constant cannot-open-because-dne)
                             filename))])))

collects/framework/private/sig.rkt

@@ -256,6 +256,7 @@
   
   (define-signature frame-class^
     (basic<%>
+     focus-table<%>
      size-pref<%>
      register-group<%>
      status-line<%>
@@ -285,6 +286,7 @@
      delegate%
      pasteboard%
      
+     focus-table-mixin
      basic-mixin
      size-pref-mixin
      register-group-mixin

collects/framework/private/standard-menus-items.rkt

@@ -265,7 +265,9 @@
                       '(λ (item control) (when (can-close?) (on-close) (show #f)) #t)
                       #\w
                       '(get-default-shortcut-prefix)
-                      '(string-constant close-menu-item)
+                      '(if (eq? (system-type) 'unix)
+                           (string-constant close-menu-item)
+                           (string-constant close-window-menu-item))
                       on-demand-do-nothing
                       #t)
         (make-between 'file-menu 'close 'quit 'nothing)
@@ -387,8 +389,8 @@
         (make-an-item 'edit-menu 'replace
                       '(string-constant replace-info)
                       '(λ (item control) (void))
-                      #\r
-                      '(get-default-shortcut-prefix)
+                      #\f
+                      '(cons 'shift (get-default-shortcut-prefix))
                       '(string-constant replace-menu-item)
                       on-demand-do-nothing
                       #f)

collects/framework/private/standard-menus.rkt

@@ -272,7 +272,11 @@
     file-menu:close-callback
     (λ (item control) (when (can-close?) (on-close) (show #f)) #t))
    (define/public (file-menu:get-close-item) file-menu:close-item)
-   (define/public (file-menu:close-string) (string-constant close-menu-item))
+   (define/public
+    (file-menu:close-string)
+    (if (eq? (system-type) 'unix)
+      (string-constant close-menu-item)
+      (string-constant close-window-menu-item)))
    (define/public (file-menu:close-help-string) (string-constant close-info))
    (define/public file-menu:close-on-demand (λ (menu-item) (void)))
    (define/public (file-menu:create-close?) #t)
@@ -911,8 +915,8 @@
             (let ((edit-menu:replace-callback
                    (λ (item evt) (edit-menu:replace-callback item evt))))
               edit-menu:replace-callback))
-           (shortcut #\r)
-           (shortcut-prefix (get-default-shortcut-prefix))
+           (shortcut #\f)
+           (shortcut-prefix (cons 'shift (get-default-shortcut-prefix)))
            (help-string (edit-menu:replace-help-string))
            (demand-callback
             (λ (menu-item) (edit-menu:replace-on-demand menu-item))))))

collects/framework/test.rkt

@@ -1,10 +1,12 @@
 #lang at-exp scheme/gui
 
-(require scribble/srcdoc)
-(require/doc scheme/base scribble/manual)
+(require scribble/srcdoc
+         (prefix-in :: framework/private/focus-table))
+(require/doc scheme/base scribble/manual
+             (for-label framework))
 
 (define (test:top-level-focus-window-has? pred)
-  (let ([tlw (get-top-level-focus-window)])
+  (let ([tlw (test:get-active-top-level-window)])
     (and tlw
          (let loop ([tlw tlw])
            (or (pred tlw)
@@ -165,16 +167,30 @@
 (define current-get-eventspaces
   (make-parameter (λ () (list (current-eventspace)))))
 
-(define (get-active-frame)
+(define test:use-focus-table (make-parameter #f))
+
+(define (test:get-active-top-level-window)
   (ormap (λ (eventspace)
            (parameterize ([current-eventspace eventspace])
-             (get-top-level-focus-window)))
+             (cond
+               [(test:use-focus-table)
+                (define lst (::frame:lookup-focus-table))
+                (define focusd (and (not (null? lst)) (car lst)))
+                (when (eq? (test:use-focus-table) 'debug)
+                  (define f2 (get-top-level-focus-window))
+                  (unless (eq? focusd f2)
+                    (eprintf "found mismatch focus-table: ~s vs get-top-level-focus-window: ~s\n" 
+                             (map (λ (x) (send x get-label)) lst) 
+                             (and f2 (list (send f2 get-label))))))
+                focusd]
+               [else
+                (get-top-level-focus-window)])))
          ((current-get-eventspaces))))
 
 (define (get-focused-window)
-  (let ([f (get-active-frame)])
+  (let ([f (test:get-active-top-level-window)])
     (and f
-         (send f get-focus-window))))
+         (send f get-edit-target-window))))
 
 (define time-stamp current-milliseconds)
 
@@ -200,14 +216,13 @@
 ;; get-parent returns () for no parent.
 ;;
 
-(define in-active-frame?
-  (λ (window)
-    (let ([frame  (get-active-frame)])
-      (let loop ([window  window])
-        (cond [(not window) #f]
-              [(null? window) #f]  ;; is this test needed?
-              [(eq? window frame) #t]
-              [else  (loop (send window get-parent))])))))
+(define (in-active-frame? window)
+  (let ([frame  (test:get-active-top-level-window)])
+    (let loop ([window  window])
+      (cond [(not window) #f]
+            [(null? window) #f]  ;; is this test needed?
+            [(eq? window frame) #t]
+            [else  (loop (send window get-parent))]))))
 
 ;;
 ;; Verify modifier list.
@@ -239,7 +254,7 @@
     (cond
       [(or (string? b-desc)
            (procedure? b-desc))
-       (let* ([active-frame (get-active-frame)]
+       (let* ([active-frame (test:get-active-top-level-window)]
               [_ (unless active-frame
                    (error object-tag
                           "could not find object: ~a, no active frame" 
@@ -516,7 +531,7 @@
              [else 
               (error
                key-tag
-               "focused window is not a text-field% and does not have on-char")])]
+               "focused window is not a text-field% and does not have on-char, ~e" window)])]
           [(send (car l) on-subwindow-char window event) #f]
           [else (loop (cdr l))])))
 
@@ -573,21 +588,20 @@
 
 (define menu-tag 'test:menu-select)
 
-(define menu-select
-  (λ (menu-name . item-names)
-    (cond
-      [(not (string? menu-name))
-       (error menu-tag "expects string, given: ~e" menu-name)]
-      [(not (andmap string? item-names))
-       (error menu-tag "expects strings, given: ~e" item-names)]
-      [else
-       (run-one
-        (λ ()
-          (let* ([frame (get-active-frame)]
-                 [item (get-menu-item frame (cons menu-name item-names))]
-                 [evt (make-object control-event% 'menu)])
-            (send evt set-time-stamp (current-milliseconds))
-            (send item command evt))))])))
+(define (menu-select menu-name . item-names)
+  (cond
+    [(not (string? menu-name))
+     (error menu-tag "expects string, given: ~e" menu-name)]
+    [(not (andmap string? item-names))
+     (error menu-tag "expects strings, given: ~e" item-names)]
+    [else
+     (run-one
+      (λ ()
+        (let* ([frame (test:get-active-top-level-window)]
+               [item (get-menu-item frame (cons menu-name item-names))]
+               [evt (make-object control-event% 'menu)])
+          (send evt set-time-stamp (current-milliseconds))
+          (send item command evt))))]))
 
 (define get-menu-item
   (λ (frame item-names)
@@ -1021,7 +1035,7 @@
   test:top-level-focus-window-has?
   (-> (-> (is-a?/c area<%>) boolean?) boolean?)
   (test)
-  @{Calls @racket[test] for each child of the top-level-focus-frame
+  @{Calls @racket[test] for each child of the @racket[test:get-active-top-level-window]
           and returns @racket[#t] if @racket[test] ever does, otherwise
           returns @racket[#f]. If there
           is no top-level-focus-window, returns @racket[#f].})
@@ -1041,4 +1055,20 @@
   test:run-one
   (-> (-> void?) void?)
   (f)
-  @{Runs the function @racket[f] as if it was a simulated event.}))
+  @{Runs the function @racket[f] as if it was a simulated event.})
+ 
+ (parameter-doc
+  test:use-focus-table
+  (parameter/c (or/c boolean? 'debug))
+  use-focus-table?
+  @{If @racket[#t], then the test framework uses @racket[frame:lookup-focus-table] to determine
+    which is the focused frame. If @racket[#f], then it uses @racket[get-top-level-focus-window].
+    If @racket[test:use-focus-table]'s value is @racket['debug], then it still uses 
+    @racket[frame:lookup-focus-table] but it also prints a message to the @racket[current-error-port]
+    when the two methods would give different results.})
+ 
+ (proc-doc/names
+  test:get-active-top-level-window
+  (-> (or/c (is-a?/c frame%) (is-a?/c dialog%) #f))
+  ()
+  @{Returns the frontmost frame, based on @racket[test:use-focus-table].}))

collects/gui-debugger/annotator.rkt

@@ -203,9 +203,8 @@
           ]
          [(define-syntaxes (var ...) expr)
           stx]
-         [(define-values-for-syntax (var ...) expr)
-          ;; define-values-for-syntax's RHS is compile time, so treat it
-          ;; like define-syntaxes
+         [(begin-for-syntax . exprs)
+          ;; compile time, so treat it like define-syntaxes
           stx]
          [(begin . top-level-exprs)
           (quasisyntax/loc stx (begin #,@(map (lambda (expr)

collects/gui-debugger/debug-tool.rkt

@@ -132,6 +132,10 @@
                                     (> size (vector-length v)))
                                '...
                                (truncate-value (vector-ref v i) size (sub1 depth)))))]
+          [(bytes? v)
+           (if (> (bytes-length v) size)
+               (bytes-append (subbytes v 0 size) #"...")
+               v)]
           [else v]))
       
       (define filename->defs
@@ -1141,7 +1145,7 @@
             (for-each
              (lambda (name/value)
                (let ([name (format "~a" (syntax-e (first name/value)))]
-                     [value (format " => ~s\n" (second name/value))])
+                     [value (format " => ~s\n" (truncate-value (second name/value) 100 5))])
                  (send variables-text insert name)
                  (send variables-text change-style bold-sd
                        (- (send variables-text last-position) (string-length name))

collects/honu/core/language.rkt

@@ -4,8 +4,16 @@
 
 (provide honu-info)
 (define (honu-info key default default-filter)
+  ; (printf "get info for ~a\n" key)
   (case key
     [(color-lexer) (dynamic-require 'honu/core/read
                                     'color-lexer)]
     [else
       (default-filter key default)]))
+
+(provide honu-language-info)
+(define (honu-language-info data)
+  (lambda (key default)
+    (case key
+      [(configure-runtime) '(#(honu/core/runtime configure #f))]
+      [else default])))

collects/honu/core/main.rkt

@@ -2,13 +2,19 @@
 
 (require "private/honu-typed-scheme.rkt"
          "private/honu2.rkt"
+         "private/macro2.rkt"
+         (for-syntax (only-in "private/parse2.rkt" honu-expression))
          (prefix-in literal: "private/literals.rkt"))
 
 (provide #%top
          #%datum
          print printf true false
+         (for-syntax (rename-out [honu-expression expression]))
          (rename-out [#%dynamic-honu-module-begin #%module-begin]
+                     [honu-top-interaction #%top-interaction]
                      [honu-function function]
+                     [honu-macro macro]
+                     [honu-syntax syntax]
                      [honu-var var]
                      [honu-val val]
                      [honu-for for]
@@ -21,6 +27,7 @@
                      [honu-> >] [honu-< <]
                      [honu->= >=] [honu-<= <=]
                      [honu-= =]
+                     [honu-assignment :=]
                      [literal:honu-<- <-]
                      [honu-map map]
                      [honu-flow \|]

collects/honu/core/private/honu-typed-scheme.rkt

@@ -445,21 +445,26 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
          #'rest)])))
 
 (define-for-syntax (honu-expand forms)
-  (parse-all forms))
+  (parse-one forms))
 
 (define-for-syntax (honu-compile forms)
   #'(void))
 
-
 (define-syntax (honu-unparsed-begin stx)
   (emit-remark "Honu unparsed begin!" stx)
   (debug "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level))
   (syntax-parse stx
     [(_) #'(void)]
     [(_ forms ...)
-     (define expanded (honu-expand #'(forms ...)))
-     (debug "expanded ~a\n" (syntax->datum expanded))
-     expanded]))
+     (define-values (parsed unparsed) (honu-expand #'(forms ...)))
+     (debug "expanded ~a unexpanded ~a\n"
+            (syntax->datum parsed)
+            (syntax->datum unparsed))
+     (with-syntax ([parsed parsed]
+                   [(unparsed ...) unparsed])
+       (if (null? (syntax->datum #'(unparsed ...)))
+         #'parsed
+         #'(begin parsed (honu-unparsed-begin unparsed ...))))]))
 
 (define-syntax (#%dynamic-honu-module-begin stx)
   (syntax-case stx ()

collects/honu/core/private/honu2.rkt

@@ -3,6 +3,7 @@
 (require "macro2.rkt"
          "operator.rkt"
          "struct.rkt"
+         "honu-typed-scheme.rkt"
          (only-in "literals.rkt"
                   honu-then
                   semicolon)
@@ -136,6 +137,13 @@
                   [right right])
       #'(right left))))
 
+(provide honu-assignment)
+(define-honu-operator/syntax honu-assignment 0.0001 'left
+  (lambda (left right)
+    (with-syntax ([left left]
+                  [right right])
+      #'(set! left right))))
+
 (define-binary-operator honu-+ 1 'left +)
 (define-binary-operator honu-- 1 'left -)
 (define-binary-operator honu-* 2 'left *)
@@ -152,3 +160,9 @@
 (define-binary-operator honu-map 0.09 'left map)
 
 (define-unary-operator honu-not 0.7 'left not)
+
+(provide honu-top-interaction)
+(define-syntax (honu-top-interaction stx)
+  (syntax-case stx ()
+    [(_ rest ...)
+     #'(#%top-interaction . (honu-unparsed-begin rest ...))]))

collects/honu/core/private/macro2.rkt

@@ -3,6 +3,7 @@
 (require (for-syntax "transformer.rkt"
                      syntax/define
                      syntax/parse
+                     syntax/stx
                      "literals.rkt"
                      "parse2.rkt"
                      "debug.rkt"
@@ -17,30 +18,39 @@
       (syntax/loc stx
                  (define-syntax id (make-honu-transformer rhs))))))
 
-(define-for-syntax (convert-pattern pattern)
-  (syntax-parse pattern
-    [(name semicolon class)
-     #'(~var name class)]))
+(define-for-syntax (convert-pattern original-pattern)
+  (define-splicing-syntax-class pattern-type
+    #:literal-sets (cruft)
+    [pattern (~seq name colon class)
+             #:with result #'(~var name class #:attr-name-separator "_")]
+    [pattern x #:with result #'x])
+  (syntax-parse original-pattern
+    [(thing:pattern-type ...)
+     #'(thing.result ...)]))
 
-(provide macro)
-(define-honu-syntax macro 
+(provide honu-macro)
+(define-honu-syntax honu-macro 
   (lambda (code context)
     (debug "Macroize ~a\n" code)
     (syntax-parse code #:literal-sets (cruft)
       [(_ name literals (#%braces pattern ...) (#%braces action ...) . rest)
        (debug "Pattern is ~a\n" #'(pattern ...))
        (values
-         (with-syntax ([syntax-parse-pattern
+         (with-syntax ([(syntax-parse-pattern ...)
                          (convert-pattern #'(pattern ...))])
            #'(define-honu-syntax name
                (lambda (stx context-name)
                  (syntax-parse stx
-                   [(_ syntax-parse-pattern . more)
+                   [(_ syntax-parse-pattern ... . more)
                     (values #'(let-syntax ([do-parse (lambda (stx)
-                                                       (parse-all stx))])
+                                                       (define what (parse-all (stx-cdr stx)))
+                                                       (debug "Macro parse all ~a\n" what)
+                                                       what)])
                                 (do-parse action ...))
-                            #'more)]))))
-         #'rest)])))
+                            #'more
+                            #t)]))))
+         #'rest
+         #t)])))
 
 (provide (rename-out [honu-with-syntax withSyntax]))
 (define-honu-syntax honu-with-syntax
@@ -49,3 +59,18 @@
       [(_ [#%brackets name:id data]
           (#%braces code ...))
        #'(with-syntax ([name data]) code ...)])))
+
+(define-syntax (parse-stuff stx)
+  (syntax-parse stx
+    [(_ stuff ...)
+     (parse-all #'(stuff ...))]))
+
+(provide honu-syntax)
+(define-honu-syntax honu-syntax
+  (lambda (code context)
+    (syntax-parse code #:literal-sets (cruft)
+      [(_ (#%parens stuff ...) . rest)
+       (values
+         #'(parse-stuff stuff ...)
+         #'rest
+         #f)])))

collects/honu/core/private/parse2.rkt

@@ -120,6 +120,13 @@
           (loop (cons parsed used)
                 unparsed))))))
 
+(define parsed-property (gensym 'honu-parsed))
+(define (parsed-syntax syntax)
+  (syntax-property syntax parsed-property #t))
+
+(define (parsed-syntax? syntax)
+  (syntax-property syntax parsed-property))
+
 (define (stopper? what)
   (define-literal-set check (honu-comma semicolon colon))
   (define is (and (identifier? what)
@@ -178,6 +185,8 @@
                           #'rest)
                   (do-parse #'rest precedence
                             left #'parsed)))))]
+         [(parsed-syntax? #'head)
+          (do-parse #'(rest ...) precedence left #'head)]
          [(honu-operator? #'head)
           (define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0))
           (define association (transformer:honu-operator-ref (syntax-local-value #'head) 1))
@@ -283,13 +292,20 @@
                       (error 'parse "function call")]
                      [else (error 'what "dont know how to parse ~a" #'head)])])])]))
 
-  (do-parse input 0 (lambda (x) x) #f))
+  (define-values (parsed unparsed)
+                 (do-parse input 0 (lambda (x) x) #f))
+  (values (parsed-syntax parsed)
+          unparsed))
 
 (define (empty-syntax? what)
   (syntax-parse what
     [() #t]
     [else #f]))
 
+(provide parse-one)
+(define (parse-one code)
+  (parse (strip-stops code)))
+
 (define (parse-all code)
   (let loop ([all '()]
              [code code])

collects/honu/core/private/util.rkt

@@ -2,7 +2,6 @@
 
 (provide (except-out (all-defined-out) test-delimiter))
 (require "debug.rkt"
-         tests/eli-tester
          racket/match
          (for-syntax racket/base)
          syntax/stx

collects/honu/core/read.rkt

@@ -34,7 +34,7 @@
                                          (:~ #\")))
 (define-lex-abbrev string (:: #\" (:* string-character) #\"))
 (define-lex-abbrev operator (:or "+" "=" "*" "/" "-" "^" "||" "|" "&&" "<="
-                                 ">=" "<-" "<" ">" "!" "::"))
+                                 ">=" "<-" "<" ">" "!" "::" ":="))
 (define-lex-abbrev block-comment (:: "/*"
                                      (complement (:: any-string "*/" any-string))
                                      "*/"))
@@ -42,7 +42,7 @@
 (define-lex-abbrev line-comment (:: (:or "#" "//")
                                     (:* (:~ "\n"))
                                     ;; we might hit eof before a \n
-                                    (:? "\n")))
+                                    (:? "\n" "\r")))
 
 (define (replace-escapes string)
   (define replacements '([#px"\\\\n" "\n"]
@@ -60,7 +60,7 @@
     #;
     [line-comment (token-whitespace)]
     [(:or "#" "//") (token-end-of-line-comment)]
-    ["\n" (token-whitespace)]
+    [(:? "\n" "\r") (token-whitespace)]
     [number (token-number (string->number lexeme))]
     #;
     [block-comment (token-whitespace)]

collects/honu/core/runtime.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+
+(require "read.rkt")
+
+(provide configure)
+(define (configure . args)
+  (current-read-interaction honu-read-syntax))

collects/honu/lang/reader.rkt

@@ -6,6 +6,7 @@ honu
 #:read-syntax honu-read-syntax
 #:whole-body-readers? #t
 #:info honu-info
+#:language-info #(honu/core/language honu-language-info #f)
 
 (require "../core/read.rkt"
          "../core/language.rkt")

collects/honu/main.rkt

@@ -1,4 +1,4 @@
-#lang racket/base
+#lang honu/private
 
 (require (prefix-in racket: (combine-in racket/base racket/list)))
 

collects/honu/private/lang/reader.rkt

@@ -0,0 +1,12 @@
+#lang s-exp syntax/module-reader
+
+honu/private/main
+
+;;#:read honu-read
+;;#:read-syntax honu-read-syntax
+;;#:whole-body-readers? #t
+#:language-info #(honu/core/language honu-language-info #f)
+; #:language-info #(honu/core/runtime configure 'dont-care)
+
+(require honu/core/read
+         honu/core/language)

collects/honu/private/main.rkt

@@ -0,0 +1,4 @@
+#lang racket/base
+
+(require racket/base)
+(provide (all-from-out racket/base))