Sync to trunk in preparation of merging.
svn: r13170
This commit is contained in:
Stevie Strickland
commit
c04baf6d83
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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.}
|
||||
|
|
|
|||
|
|
@ -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?)]
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
from the menus.
|
||||
The @scheme[edge-label-font] argument is used as the font on the edge
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
#lang scheme/base (provide stamp) (define stamp "15jan2009")
|
||||
#lang scheme/base (provide stamp) (define stamp "16jan2009")
|
||||
|
|
|
|||
|
|
@ -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!~a>" "#<promise!~s>")
|
||||
(fprintf port (if write? "#<promise!exn!~s>" "#<promise!exn!~a>")
|
||||
(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,17 +59,10 @@
|
|||
;; 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
|
||||
(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))))
|
||||
[(_ expr)
|
||||
(with-syntax ([proc (syntax-property (syntax/loc stx (lambda () expr))
|
||||
'inferred-name (syntax-local-name))])
|
||||
(syntax/loc stx (make-promise proc)))]))
|
||||
|
||||
;; Creates a promise that does not compose
|
||||
;; X = (force (delay X)) = (force (lazy (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)
|
||||
(set-promise-val! promise (running p))
|
||||
;; mark the root as running: avoids cycles, and no need to keep
|
||||
;; 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)))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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.)}
|
||||
|
|
|
|||
|
|
@ -49,40 +49,46 @@
|
|||
;; (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)
|
||||
(with-syntax ([bogus-name (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)]
|
||||
[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))))])
|
||||
(quasisyntax/loc stx
|
||||
(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]
|
||||
['stepper-hide-reduction #t]
|
||||
['stepper-use-val-as-final #t])
|
||||
(quasisyntax/loc stx
|
||||
(#,checker-proc-stx
|
||||
#,@embedded-stxes
|
||||
src-info
|
||||
#,(with-stepper-syntax-properties (['stepper-no-lifting-info #t]
|
||||
['stepper-hide-reduction #t])
|
||||
#'test-info))))))))
|
||||
'stepper-skipto
|
||||
(append skipto/third ;; let
|
||||
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-expect-maker
|
||||
stx checker-proc-stx test-expr embedded-stxes hint-tag)
|
||||
(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)))))
|
||||
(quasisyntax/loc test-expr
|
||||
(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]
|
||||
['stepper-hide-reduction #t]
|
||||
['stepper-use-val-as-final #t])
|
||||
(quasisyntax/loc stx
|
||||
(#,checker-proc-stx
|
||||
(lambda () #,test-expr)
|
||||
#,@embedded-stxes
|
||||
#,src-info
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-no-lifting-info #t]
|
||||
['stepper-hide-reduction #t])
|
||||
#'test-info))))))))
|
||||
'stepper-skipto
|
||||
(append skipto/third ;; let
|
||||
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 (list #`(lambda () test) #`actual) 'comes-from-check-expect)]
|
||||
[(_ test)
|
||||
(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-expect-maker stx #'check-values-expected #`test (list #`actual)
|
||||
'comes-from-check-expect)]
|
||||
[_ (raise-syntax-error 'check-expect CHECK-EXPECT-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 (list #`(lambda () test) #`actual #`within) 'comes-from-check-within)]
|
||||
[(_ test actual)
|
||||
(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)]))
|
||||
(check-expect-maker stx #'check-values-within #`test (list #`actual #`within)
|
||||
'comes-from-check-within)]
|
||||
[_ (raise-syntax-error 'check-within CHECK-WITHIN-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 (list #'(lambda () test) #`error) 'comes-from-check-error)]
|
||||
[(_ test)
|
||||
(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)]))
|
||||
(check-expect-maker stx #'check-values-error #`test (list #`error)
|
||||
'comes-from-check-error)]
|
||||
[_ (raise-syntax-error 'check-error CHECK-ERROR-STR stx)]))
|
||||
|
||||
(define (check-values-error test error src test-info)
|
||||
(error-check string? error CHECK-ERROR-STR-FMT)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang scheme/base
|
||||
(require scheme/contract
|
||||
scheme/match
|
||||
scheme/promise)
|
||||
scheme/match)
|
||||
(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])))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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_W 10
|
||||
#define MZSCHEME_VERSION_Z 4
|
||||
#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)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -20,8 +20,8 @@ APPLICATION ICON DISCARDABLE "mred.ico"
|
|||
//
|
||||
|
||||
VS_VERSION_INFO VERSIONINFO
|
||||
FILEVERSION 4,1,3,10
|
||||
PRODUCTVERSION 4,1,3,10
|
||||
FILEVERSION 4,1,4,1
|
||||
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"
|
||||
|
|
|
|||
|
|
@ -53,8 +53,8 @@ END
|
|||
//
|
||||
|
||||
VS_VERSION_INFO VERSIONINFO
|
||||
FILEVERSION 4,1,3,10
|
||||
PRODUCTVERSION 4,1,3,10
|
||||
FILEVERSION 4,1,4,1
|
||||
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"
|
||||
|
|
|
|||
|
|
@ -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%'
|
||||
|
|
|
|||
|
|
@ -29,8 +29,8 @@ APPLICATION ICON DISCARDABLE "mzscheme.ico"
|
|||
//
|
||||
|
||||
VS_VERSION_INFO VERSIONINFO
|
||||
FILEVERSION 4,1,3,10
|
||||
PRODUCTVERSION 4,1,3,10
|
||||
FILEVERSION 4,1,4,1
|
||||
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"
|
||||
|
|
|
|||
|
|
@ -22,8 +22,8 @@ APPLICATION ICON DISCARDABLE "mzstart.ico"
|
|||
//
|
||||
|
||||
VS_VERSION_INFO VERSIONINFO
|
||||
FILEVERSION 4,1,3,10
|
||||
PRODUCTVERSION 4,1,3,10
|
||||
FILEVERSION 4,1,4,1
|
||||
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"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user