Sync to trunk in preparation of merging.

svn: r13170

collects/mrlib/graph.ss

@@ -231,6 +231,8 @@
     (mixin ((class->interface pasteboard%)) (graph-pasteboard<%>)
       (inherit find-first-snip find-next-selected-snip)
       
+      (init-field [edge-label-font #f])
+      
       (define draw-arrow-heads? #t)
       (inherit refresh get-admin)
       (define/public (set-draw-arrow-heads? x)
@@ -248,6 +250,8 @@
                     (unbox wb)
                     (unbox hb))))))
       
+      
+      
       (define arrowhead-angle-width (* 1/4 pi))
       (define arrowhead-short-side 8)
       (define arrowhead-long-side 12)
@@ -484,7 +488,12 @@
       
       (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
         (when before?
-          (draw-edges dc left top right bottom dx dy))
+          (let ([old-font (send dc get-font)])
+            (when edge-label-font
+              (send dc set-font edge-label-font))
+            (draw-edges dc left top right bottom dx dy)
+            (when edge-label-font
+              (send dc set-font old-font))))
         (super on-paint before? dc left top right bottom dx dy draw-caret))
       
       (define/public (draw-edges dc left top right bottom dx dy)

collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl

@@ -3,5 +3,13 @@
 
 @defmixin/title[graph-pasteboard-mixin (pasteboard%) (graph-pasteboard<%>)]{
 
+@defconstructor/auto-super[([edge-label-font (or/c #f (is-a?/c font%)) #f])]{
+
+If @scheme[edge-label-font] is supplied, it is used when drawing the
+labels on the edges. Otherwise, the font is not set before drawing
+the labels, defaulting to the @scheme[dc<%>] object's font.
+
+}
+
 This mixin overrides many methods to draw lines between
 @scheme[graph-snip<%>] that it contains.}

collects/redex/gui.ss

@@ -35,7 +35,8 @@
                #:pp pp-contract
                #:colors (listof (list/c string? string?))
                #:scheme-colors? boolean?
-               #:layout (-> any/c any/c))
+               #:layout (-> any/c any/c)
+               #:edge-label-font (or/c #f (is-a?/c font%)))
               any)]
  [traces/ps (->* (reduction-relation?
                   any/c
@@ -46,7 +47,8 @@
                                (any/c term-node? . -> . any))
                   #:pp pp-contract
                   #:colors (listof any/c)
-                  #:layout (-> any/c any/c))
+                  #:layout (-> any/c any/c)
+                  #:edge-label-font (or/c #f (is-a?/c font%)))
                  any)]
  
  [term-node? (-> any/c boolean?)]

collects/redex/private/traces.ss

@@ -131,7 +131,9 @@
                    #:pp [pp default-pretty-printer] 
                    #:scheme-colors? [scheme-colors? #t]
                    #:colors [colors '()]
-                   #:layout [layout void])
+                   #:layout [layout void]
+                   #:edge-label-font [edge-label-font #f]
+                   )
   (let-values ([(graph-pb canvas)
                 (traces reductions pre-exprs
                         #:no-show-frame? #t
@@ -140,7 +142,8 @@
                         #:pp pp
                         #:scheme-colors? scheme-colors?
                         #:colors colors
-                        #:layout layout)])
+                        #:layout layout
+                        #:edge-label-font edge-label-font)])
     (print-to-ps graph-pb canvas filename)))
 
 (define (print-to-ps graph-pb canvas filename)
@@ -227,11 +230,12 @@
                 #:colors [colors '()]
                 #:scheme-colors? [scheme-colors? #t]
                 #:layout [layout void]
+                #:edge-label-font [edge-label-font #f]
                 #:no-show-frame? [no-show-frame? #f])
   (define exprs (if multiple? pre-exprs (list pre-exprs)))
   (define main-eventspace (current-eventspace))
   (define saved-parameterization (current-parameterization))
-  (define graph-pb (new graph-pasteboard% [layout layout]))
+  (define graph-pb (new graph-pasteboard% [layout layout] [edge-label-font edge-label-font]))
   (define f (instantiate red-sem-frame% ()
               (label "PLT Redex Reduction Graph")
               (style '(toolbar-button))

collects/redex/redex.scrbl

@@ -1157,7 +1157,8 @@ exploring reduction sequences.
                                   (lambda (x) (member (length x) '(2 3 4 6))))))]
 
 	         [#:scheme-colors? scheme-colors? boolean?]
-                 [#:layout layout (-> (listof term-node?) void)])
+                 [#:layout layout (-> (listof term-node?) void)]
+                 [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f])
          void?]{
 
 This function opens a new window and inserts each expression
@@ -1169,7 +1170,7 @@ found, or no more reductions can occur. It inserts each new
 term into the gui. Clicking the @onscreen{reduce} button reduces
 until reduction-steps-cutoff more terms are found.
 
-The pred function indicates if a term has a particular
+The @scheme[pred] function indicates if a term has a particular
 property. If it returns @scheme[#f], the term is displayed with a
 pink background. If it returns a string or a @scheme[color%] object,
 the term is displayed with a background of that color (using
@@ -1211,8 +1212,6 @@ the color that fills the arrow head.  If fewer than six colors are
 specified, the colors specified colors are used and then defaults are
 filled in for the remaining colors.
 
-
-
 The @scheme[scheme-colors?] argument, if @scheme[#t] causes
 @scheme[traces] to color the contents of each of the windows according
 to DrScheme's Scheme mode color Scheme. If it is @scheme[#f],
@@ -1224,8 +1223,10 @@ after new terms are inserted in response to the user clicking on the
 reduce button, and after the initial set of terms is inserted.
 See also @scheme[term-node-set-position!].
 
-You can save the contents of the window as a postscript file
+The @scheme[edge-label-font] argument is used as the font on the edge
-from the menus.
+labels. If nothign is suppled, the @scheme[dc<%>] object's default
+font is used.
+
 }
 
 @defproc[(traces/ps [reductions reduction-relation?] 
@@ -1241,7 +1242,8 @@ from the menus.
                                 (any output-port number (is-a?/c text%) -> void))
                           default-pretty-printer]
                     [#:colors colors (listof (list string string)) '()]
-                    [#:layout layout (-> (listof term-node?) void)])
+                    [#:layout layout (-> (listof term-node?) void)]
+                    [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f])
          void?]{
 
 The arguments behave just like the function @scheme[traces], but

collects/repos-time-stamp/stamp.ss

@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "15jan2009")
+#lang scheme/base (provide stamp) (define stamp "16jan2009")

collects/scheme/promise.ss

@@ -2,7 +2,7 @@
 (#%require "private/small-scheme.ss" "private/more-scheme.ss" "private/define.ss"
            (rename "private/define-struct.ss" define-struct define-struct*)
            (for-syntax '#%kernel "private/stxcase-scheme.ss"))
-(#%provide lazy delay force promise?)
+(#%provide lazy delay force promise? promise-forced? promise-running?)
 
 ;; This module implements "lazy" (composable) promises and a `force'
 ;; that is iterated through them.
@@ -20,9 +20,15 @@
     (cond [(reraise? p)
            (let ([v (reraise-val p)])
              (if (exn? v)
-               (fprintf port "#<promise!exn!~a>" (exn-message v))
+               (fprintf port (if write? "#<promise!exn!~s>" "#<promise!exn!~a>")
-               (fprintf port (if write? "#<promise!~a>" "#<promise!~s>")
+                        (exn-message v))
+               (fprintf port (if write? "#<promise!~s>" "#<promise!~a>")
                         `(raise ,v))))]
+          [(running? p)
+           (let ([n (running-name p)])
+             (if n
+               (fprintf port "#<promise:!running!~a>" n)
+               (fprintf port "#<promise:!running>")))]
           [(procedure? p)
            (cond [(object-name p)
                   => (lambda (n) (fprintf port "#<promise:~a>" n))]
@@ -53,18 +59,11 @@
 ;;   X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X))
 (define-syntax (lazy stx)
   (syntax-case stx ()
-    [(lazy expr) (with-syntax ([proc (syntax-property
+    [(_ expr)
-                                      (syntax/loc stx (lambda () expr))
+     (with-syntax ([proc (syntax-property (syntax/loc stx (lambda () expr))
                                           'inferred-name (syntax-local-name))])
        (syntax/loc stx (make-promise proc)))]))
 
-;; use this to create a value to be raised, make it a procedure so no other
-;; code need to change (we could just use the exceptions -- but any value can
-;; be raised); also make it have a proper printer so we can show such promises
-;; properly.
-(define-struct reraise (val)
-  #:property prop:procedure (lambda (this) (raise (reraise-val this))))
-
 ;; Creates a promise that does not compose
 ;;   X = (force (delay X)) = (force (lazy (delay X)))
 ;;                         = (force (lazy^n (delay X)))
@@ -75,10 +74,26 @@
 ;; but provided for regular delay/force uses.)
 (define-syntax (delay stx)
   (syntax-case stx ()
-    [(delay expr)
+    [(_ expr)
      (syntax/loc stx
        (lazy (make-promise (call-with-values (lambda () expr) list))))]))
 
+;; For simplicity and efficiency this code uses thunks in promise values for
+;; exceptions: this way, we don't need to tag exception values in some special
+;; way and test for them -- we just use a thunk that will raise the exception.
+;; But it's still useful to refer to the exception value, so use an applicable
+;; struct for them.  The same goes for a promise that is being forced: we use a
+;; thunk that will throw a "reentrant promise" error -- and use an applicable
+;; struct so it is identifiable.
+(define-struct reraise (val)
+  #:property prop:procedure (lambda (this) (raise (reraise-val this))))
+(define-struct running (name)
+  #:property prop:procedure (lambda (this)
+                              (let ([name (running-name this)])
+                                (if name
+                                  (error 'force "reentrant promise ~v" name)
+                                  (error 'force "reentrant promise")))))
+
 ;; force iterates on lazy promises (forbids dependency cycles)
 ;; * (force X) = X for non promises
 ;; * does not deal with multiple values, except for `delay' promises at the
@@ -100,21 +115,17 @@
         (set-promise-val! root (list v))
         v))))
 
-;; this is used during computation to avoid reentrant loops (which makes it
-;; non-r5rs, but there's no good uses for allowing that)
-(define (running proc)
-  ;; important: be careful not to close over the thunk!
-  (let ([name (object-name proc)])
-    (if name
-      (lambda () (error 'force "reentrant promise ~v" name))
-      (lambda () (error 'force "reentrant promise")))))
-
 (define (force promise)
   (if (promise? promise)
     (let loop ([p (promise-val promise)])
       (cond [(procedure? p)
-             ;; "mark" root as running (avoids cycles)
+             ;; mark the root as running: avoids cycles, and no need to keep
-             (set-promise-val! promise (running p))
+             ;; banging the root promise value; it makes this non-r5rs, but
+             ;; only practical uses of these things could be ones that use
+             ;; state.
+             ;; (careful: avoid holding a reference to the thunk, to allow
+             ;; safe-for-space loops)
+             (set-promise-val! promise (make-running (object-name p)))
              (call-with-exception-handler
                (lambda (e) (set-promise-val! promise (make-reraise e)) e)
                (lambda () (force-proc p promise)))]
@@ -125,4 +136,15 @@
     ;; different from srfi-45: identity for non-promises
     promise))
 
+(define (promise-forced? promise)
+  (if (promise? promise)
+    (let ([p (promise-val promise)])
+      (or (not (procedure? p)) (reraise? p))) ; #f when running
+    (raise-type-error 'promise-forced? "promise" promise)))
+
+(define (promise-running? promise)
+  (if (promise? promise)
+    (running? (promise-val promise))
+    (raise-type-error 'promise-running? "promise" promise)))
+
 )

collects/scribblings/reference/promise.scrbl

@@ -22,6 +22,7 @@ otherwise.}
 Creates a promise that, when @scheme[force]d, evaluates @scheme[expr]
 to produce its value.}
 
+
 @defform[(lazy expr)]{
 
 Like @scheme[delay], except that if @scheme[expr] produces a promise,
@@ -31,6 +32,7 @@ mostly useful for implementing lazy libraries and languages.  Also
 note that the @scheme[expr] in this case is restricted to one that
 produces a single value.}
 
+
 @defproc[(force [v any/c]) any]{
 
 If @scheme[v] is a promise, then the promise is forced to obtain a
@@ -44,3 +46,14 @@ If @scheme[v] is @scheme[force]d again before the original call to
 @scheme[force] returns, then the @exnraise[exn:fail].
 
 If @scheme[v] is not a promise, then it is returned as the result.}
+
+
+@defproc[(promise-forced? [promise promise?]) boolean?]{
+
+Returns @scheme[#t] if @scheme[promise] has been forced.}
+
+
+@defproc[(promise-running? [promise promise?]) boolean?]{
+
+Returns @scheme[#t] if @scheme[promise] is currently being forced.
+(Note that a promise can be either running or forced but not both.)}

collects/test-engine/scheme-tests.ss

@@ -49,32 +49,38 @@
 ;; (make-expected-error src string scheme-val)
 (define-struct (expected-error check-fail) (message value))
 
-;; check-expect-maker : syntax? syntax? (listof syntax?) -> syntax?
+;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax?
 ;; the common part of all three test forms.
-(define-for-syntax (check-expect-maker stx checker-proc-stx embedded-stxes hint-tag)
+(define-for-syntax (check-expect-maker
-  (with-syntax ([bogus-name (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)]
+                    stx checker-proc-stx test-expr embedded-stxes hint-tag)
-                [src-info (with-stepper-syntax-properties (['stepper-skip-completely #t])
+  (define bogus-name
+    (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t))
+  (define src-info
+    (with-stepper-syntax-properties (['stepper-skip-completely #t])
       #`(list #,@(list #`(quote #,(syntax-source stx))
                        (syntax-line stx)
                        (syntax-column stx)
                        (syntax-position stx)
-                                             (syntax-span stx))))])
+                       (syntax-span stx)))))
-    (quasisyntax/loc stx
+  (quasisyntax/loc test-expr
-      (define bogus-name
+    (define #,bogus-name
       #,(stepper-syntax-property
          #`(let ([test-info (namespace-variable-value
                              'test~object #f builder (current-namespace))])
              (when test-info
                (insert-test test-info
                             (lambda ()
-                                #,(with-stepper-syntax-properties (['stepper-hint hint-tag]
+                              #,(with-stepper-syntax-properties
+                                    (['stepper-hint hint-tag]
                                      ['stepper-hide-reduction #t]
                                      ['stepper-use-val-as-final #t])
                                   (quasisyntax/loc stx
                                     (#,checker-proc-stx
+                                     (lambda () #,test-expr)
                                      #,@embedded-stxes
-                                       src-info
+                                     #,src-info
-                                       #,(with-stepper-syntax-properties (['stepper-no-lifting-info #t]
+                                     #,(with-stepper-syntax-properties
+                                           (['stepper-no-lifting-info #t]
                                             ['stepper-hide-reduction #t])
                                          #'test-info))))))))
          'stepper-skipto
@@ -82,7 +88,7 @@
                  skipto/third skipto/second ;; unless (it expands into a begin)
                  skipto/cdr skipto/third ;; application of insert-test
                  '(syntax-e cdr cdr syntax-e car) ;; lambda
-                   ))))))
+                 )))))
 
 (define-for-syntax (check-context?)
   (let ([c (syntax-local-context)])
@@ -90,19 +96,13 @@
 
 ;; check-expect
 (define-syntax (check-expect stx)
+  (unless (check-context?)
+    (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx))
   (syntax-case stx ()
     [(_ test actual)
-     (check-context?)
+     (check-expect-maker stx #'check-values-expected #`test (list #`actual)
-     (check-expect-maker stx #'check-values-expected (list #`(lambda () test) #`actual) 'comes-from-check-expect)]
+                         'comes-from-check-expect)]
-    [(_ test)
+    [_ (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]))
-     (check-context?)
-     (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]
-    [(_ test actual extra ...)
-     (check-context?)
-     (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]
-    [(_ test ...)
-     (not (check-context?))
-     (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)]))
 
 ;; check-values-expected: (-> scheme-val) scheme-val src -> void
 (define (check-values-expected test actual src test-info)
@@ -113,23 +113,15 @@
                  (lambda (src v1 v2 _) (make-unequal src v1 v2))
                  test actual #f src test-info 'check-expect))
 
+
 (define-syntax (check-within stx)
+  (unless (check-context?)
+    (raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx))
   (syntax-case stx ()
     [(_ test actual within)
-     (check-context?)
+     (check-expect-maker stx #'check-values-within #`test (list #`actual #`within)
-     (check-expect-maker stx #'check-values-within (list #`(lambda () test) #`actual #`within) 'comes-from-check-within)]
+                         'comes-from-check-within)]
-    [(_ test actual)
+    [_ (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]))
-     (check-context?)
-     (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
-    [(_ test)
-     (check-context?)
-     (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
-    [(_ test actual within extra ...)
-     (check-context?)
-     (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
-    [(_ test ...)
-     (not (check-context?))
-     (raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)]))
 
 (define (check-values-within test actual within src test-info)
   (error-check number? within CHECK-WITHIN-INEXACT-FMT)
@@ -140,16 +132,13 @@
 
 
 (define-syntax (check-error stx)
+  (unless (check-context?)
+    (raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx))
   (syntax-case stx ()
     [(_ test error)
-     (check-context?)
+     (check-expect-maker stx #'check-values-error #`test (list #`error)
-     (check-expect-maker stx #'check-values-error (list #'(lambda () test) #`error) 'comes-from-check-error)]
+                         'comes-from-check-error)]
-    [(_ test)
+    [_ (raise-syntax-error 'check-error CHECK-ERROR-STR stx)]))
-     (check-context?)
-     (raise-syntax-error 'check-error CHECK-ERROR-STR stx)]
-    [(_ test ...)
-     (not (check-context?))
-     (raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx)]))
 
 (define (check-values-error test error src test-info)
   (error-check string? error CHECK-ERROR-STR-FMT)

collects/tests/mzscheme/promise.ss

@@ -70,4 +70,25 @@
   (t (force (lazy  (lazy  (lazy  (force (delay (delay _))))))))
   (t (force (lazy  (lazy  (delay (force (lazy (delay _)))))))))
 
+;; more tests
+(let ()
+  (define (force+catch p)
+    (with-handlers ([void (lambda (x) (cons 'catch x))]) (force p)))
+  (define (forced+running? p) (list (promise-forced? p) (promise-running? p)))
+  ;; results are cached
+  (let ([p (delay (random 10000))])
+    (test #t equal? (force p) (force p)))
+  ;; errors are cached
+  (let ([p (delay (error 'foo "blah"))])
+    (test #t equal? (force+catch p) (force+catch p)))
+  ;; other raised values are cached
+  (let ([p (delay (raise (random 10000)))])
+    (test #t equal? (force+catch p) (force+catch p)))
+  ;; test the predicates
+  (letrec ([p (delay (forced+running? p))])
+    (test '(#f #f) forced+running? p)
+    (test '(#f #t) force p)
+    (test '(#t #f) forced+running? p))
+  )
+
 (report-errs)

collects/web-server/dispatchers/limit.ss

@@ -2,10 +2,10 @@
 (require "dispatch.ss")
 (provide/contract
  [interface-version dispatcher-interface-version/c]
- [make (number? dispatcher/c . -> . dispatcher/c)])
+ [make ((number? dispatcher/c) (#:over-limit (symbols 'block 'kill-new 'kill-old)) . ->* . dispatcher/c)])
 
 (define interface-version 'v1)
-(define (make num inner)
+(define (make num inner #:over-limit [over-limit 'block])
   (define-struct in-req (partner reply-ch))
   (define in-ch (make-channel))
   (define-struct out-req (partner))
@@ -16,17 +16,50 @@
        (let loop ([i 0]
                   [partners empty])
          (apply sync 
+                ; Do we have room for another...
                 (if (< i num)
+                    ; If so, allow them in
                     (handle-evt in-ch
                                 (lambda (req)
-                                  (channel-put (in-req-reply-ch req) #t)
+                                  ; Reply asynchronously
+                                  (thread 
+                                   (lambda ()
+                                     (channel-put (in-req-reply-ch req) #t)))
                                   (loop (add1 i)
                                         (list* (in-req-partner req) partners))))
-                    never-evt)
+                    ; Otherwise, decide what to do with new requests
+                    (case over-limit
+                      ; Make them block...
+                      [(block)
+                       never-evt]
+                      ; Instruct the new request to die
+                      [(kill-new)
+                       (handle-evt in-ch
+                                   (lambda (req)
+                                     ; Reply asynchronously
+                                     (thread
+                                      (lambda ()
+                                        (channel-put (in-req-reply-ch req) #f)))
+                                     (loop i partners)))]
+                      ; Kill an old request handler and allow this one
+                      [(kill-old)
+                       (handle-evt in-ch
+                                   (lambda (req)
+                                     (define oldest (last partners))
+                                     (define remaining (take partners (sub1 (length partners))))
+                                     ; Kill the oldest thread
+                                     (kill-thread oldest)
+                                     ; Reply asynchronously
+                                     (thread 
+                                      (lambda ()
+                                        (channel-put (in-req-reply-ch req) #t)))
+                                     (loop i (list* (in-req-partner req) remaining))))]))
+                ; Wait for partners to complete
                 (handle-evt out-ch
                             (lambda (req)
                               (loop (sub1 i)
                                     (remq (out-req-partner req) partners))))
+                ; Check if partners are dead
                 (map (lambda (p)
                        (handle-evt (thread-dead-evt p)
                                    (lambda _
@@ -35,7 +68,8 @@
   (define (in)
     (define reply (make-channel))
     (channel-put in-ch (make-in-req (current-thread) reply))
-    (channel-get reply))
+    (unless (channel-get reply)
+      (error 'limit "limit-manager requested load shedding")))
   (define (out)
     (channel-put out-ch (make-out-req (current-thread))))
   (lambda (conn req)

collects/web-server/private/mime-types.ss

@@ -1,7 +1,6 @@
 #lang scheme/base
 (require scheme/contract
-         scheme/match
+         scheme/match)
-         scheme/promise)
 (require "util.ss"
          web-server/http)
 (provide/contract
@@ -32,11 +31,21 @@
 ;; 1. Can we determine the mime type based on file contents?
 ;; 2. Assuming that 7-bit ASCII is correct for mime-type
 (define (make-path->mime-type a-path)
-  (define MIME-TYPE-TABLE (delay (read-mime-types a-path)))
+  ;; it would be nice to just use delay/force -- but this can be called by
+  ;; multiple threads at the same time, causing a "reentrant promise" error.
+  (define sema (make-semaphore 1))
+  (define MIME-TYPE-TABLE #f)
   (lambda (path)
     (match (path->bytes path)
       [(regexp #rx#".*\\.([^\\.]*$)" (list _ sffx))
-       (hash-ref (force MIME-TYPE-TABLE)
+       (hash-ref (or MIME-TYPE-TABLE
+                     (dynamic-wind
+                       (lambda () (semaphore-wait sema))
+                       (lambda () (or MIME-TYPE-TABLE ; maybe already read
+                                      (begin (set! MIME-TYPE-TABLE
+                                                   (read-mime-types a-path))
+                                             MIME-TYPE-TABLE)))
+                       (lambda () (semaphore-post sema))))
                  (lowercase-symbol! sffx)
                  TEXT/HTML-MIME-TYPE)]
       [_ TEXT/HTML-MIME-TYPE])))

collects/web-server/scribblings/dispatchers.scrbl

@@ -395,9 +395,16 @@ a URL that refreshes the password file, servlet cache, etc.}
               @elem{provides a wrapper dispatcher that limits how many requests are serviced at once.}]{
 
 @defproc[(make [limit number?]
-               [inner dispatcher/c])
+               [inner dispatcher/c]
+               [#:over-limit over-limit (symbols 'block 'kill-new 'kill-old) 'block])
          dispatcher/c]{
  Returns a dispatcher that defers to @scheme[inner] for work, but will forward a maximum of @scheme[limit] requests concurrently.
+         
+ If there are no additional spaces inside the limit and a new request is received, the @scheme[over-limit] option determines what is done.
+ The default (@scheme['block]) causes the new request to block until an old request is finished being handled.
+ If @scheme[over-limit] is @scheme['kill-new], then the new request handler is killed---a form of load-shedding.
+ If @scheme[over-limit] is @scheme['kill-old], then the oldest request handler is killed---prioritizing new connections over old.
+ (This setting is a little dangerous because requests might never finish if there is constant load.)
 }}
                       
 @(require (for-label
@@ -434,7 +441,8 @@ Consider this example:
               (list (format "hello world ~a"
                             (sort (build-list 100000 (λ x (random 1000)))
                                   <))))
-             (request-method req)))))
+             (request-method req)))
+          #:over-limit 'block))
         (lambda (conn req)          
           (output-response/method
            conn

src/mzscheme/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.1.3.10"
+#define MZSCHEME_VERSION "4.1.4.1"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 1
-#define MZSCHEME_VERSION_Z 3
+#define MZSCHEME_VERSION_Z 4
-#define MZSCHEME_VERSION_W 10
+#define MZSCHEME_VERSION_W 1
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/worksp/mred/mred.manifest

@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8" standalone="yes"?> 
 <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> 
 <assemblyIdentity 
-version="4.1.3.10" 
+version="4.1.4.1" 
 processorArchitecture="X86" 
 name="Org.PLT-Scheme.MrEd" 
 type="win32" 

src/worksp/mred/mred.rc

@@ -20,8 +20,8 @@ APPLICATION             ICON    DISCARDABLE     "mred.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,10
+ FILEVERSION 4,1,4,1
- PRODUCTVERSION 4,1,3,10
+ PRODUCTVERSION 4,1,4,1
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -39,11 +39,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme GUI application\0"
             VALUE "InternalName", "MrEd\0"
-            VALUE "FileVersion", "4, 1, 3, 10\0"
+            VALUE "FileVersion", "4, 1, 4, 1\0"
             VALUE "LegalCopyright", "Copyright © 1995-2009\0"
             VALUE "OriginalFilename", "MrEd.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 3, 10\0"
+            VALUE "ProductVersion", "4, 1, 4, 1\0"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/mzcom/mzcom.rc

@@ -53,8 +53,8 @@ END
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,10
+ FILEVERSION 4,1,4,1
- PRODUCTVERSION 4,1,3,10
+ PRODUCTVERSION 4,1,4,1
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -70,12 +70,12 @@ BEGIN
         BLOCK "040904b0"
         BEGIN
             VALUE "FileDescription", "MzCOM Module"
-            VALUE "FileVersion", "4, 1, 3, 10"
+            VALUE "FileVersion", "4, 1, 4, 1"
             VALUE "InternalName", "MzCOM"
             VALUE "LegalCopyright", "Copyright 2000-2009 PLT (Paul Steckler)"
             VALUE "OriginalFilename", "MzCOM.EXE"
             VALUE "ProductName", "MzCOM Module"
-            VALUE "ProductVersion", "4, 1, 3, 10"
+            VALUE "ProductVersion", "4, 1, 4, 1"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/mzcom/mzobj.rgs

@@ -1,19 +1,19 @@
 HKCR
 {
-	MzCOM.MzObj.4.1.3.10 = s 'MzObj Class'
+	MzCOM.MzObj.4.1.4.1 = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
 	}
 	MzCOM.MzObj = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
-		CurVer = s 'MzCOM.MzObj.4.1.3.10'
+		CurVer = s 'MzCOM.MzObj.4.1.4.1'
 	}
 	NoRemove CLSID
 	{
 		ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
 		{
-			ProgID = s 'MzCOM.MzObj.4.1.3.10'
+			ProgID = s 'MzCOM.MzObj.4.1.4.1'
 			VersionIndependentProgID = s 'MzCOM.MzObj'
 			ForceRemove 'Programmable'
 			LocalServer32 = s '%MODULE%'

src/worksp/mzscheme/mzscheme.rc

@@ -29,8 +29,8 @@ APPLICATION             ICON    DISCARDABLE     "mzscheme.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,10
+ FILEVERSION 4,1,4,1
- PRODUCTVERSION 4,1,3,10
+ PRODUCTVERSION 4,1,4,1
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -48,11 +48,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme application\0"
             VALUE "InternalName", "MzScheme\0"
-            VALUE "FileVersion", "4, 1, 3, 10\0"
+            VALUE "FileVersion", "4, 1, 4, 1\0"
             VALUE "LegalCopyright", "Copyright <20>© 1995-2009\0"
             VALUE "OriginalFilename", "mzscheme.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 3, 10\0"
+            VALUE "ProductVersion", "4, 1, 4, 1\0"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/starters/start.rc

@@ -22,8 +22,8 @@ APPLICATION             ICON    DISCARDABLE     "mzstart.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,10
+ FILEVERSION 4,1,4,1
- PRODUCTVERSION 4,1,3,10
+ PRODUCTVERSION 4,1,4,1
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -45,7 +45,7 @@ BEGIN
 #ifdef MZSTART
             VALUE "FileDescription", "PLT Scheme Launcher\0"
 #endif
-            VALUE "FileVersion", "4, 1, 3, 10\0"
+            VALUE "FileVersion", "4, 1, 4, 1\0"
 #ifdef MRSTART
             VALUE "InternalName", "mrstart\0"
 #endif
@@ -60,7 +60,7 @@ BEGIN
             VALUE "OriginalFilename", "MzStart.exe\0"
 #endif
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 3, 10\0"
+            VALUE "ProductVersion", "4, 1, 4, 1\0"
         END
     END
     BLOCK "VarFileInfo"