suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Syncing on up

Browse Source 
svn: r13084
This commit is contained in:
Stevie Strickland 2009-01-13 01:05:50 +00:00
commit 2537508865
58 changed files with 1826 additions and 826 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/2htdp/private/universe.ss
View File

@ -31,7 +31,8 @@
(last-mixin
(clock-mixin
(class* object% (start-stop<%>) (inspect #f) (super-new)
(init-field ;; type Result = (make-bundle Universe [Listof Mail])
(init-field ;; type Result
; = (make-bundle [Listof World] Universe [Listof Mail])
universe0 ;; the initial state of the universe
on-new ;; Universe World -> Result
on-msg ;; Universe World Message -> Result
@ -56,10 +57,11 @@
(define (pname a ...)
(define (handler e) (stop! e))
(with-handlers ([exn? handler])
(define r (check-state-x-mail 'name (name universe a ...)))
(define r (check-state-x-mail 'name (name worlds universe a ...)))
(define u (bundle-state r))
(set! worlds (bundle-low r))
(set! universe u)
(unless (boolean? to-string) (send gui add (to-string u)))
(unless (boolean? to-string) (send gui add (to-string worlds u)))
(broadcast (bundle-mails r))))))
(def/cback private (pmsg world received) on-msg)
@ -68,9 +70,9 @@
(def/cback private (pnew world) ppnew)
(define/private (ppnew uni p)
(define/private (ppnew low uni p)
(world-send p 'okay)
(on-new uni p))
(on-new low uni p))
(def/cback public (ptock) tick)
@ -80,8 +82,9 @@
(define/private (check-state-x-mail tag r)
(with-handlers ((exn? (lambda (x) (stop! x))))
(define s (format "expected from ~a, given: " tag))
(define f "(make-bundle [Listof World] Universe [Listof Mail]) ~a~e")
(unless (bundle? r)
(error tag (format "(make-bundle Universe [Listof Mail]) ~a~e" s r)))
(error tag (format f s r)))
r))
;; -----------------------------------------------------------------------
@ -109,7 +112,7 @@
(match next
[(cons 'REGISTER info)
(let* ([w (create-world in (second in-out) info)])
(set! worlds (cons w worlds))
; (set! worlds (cons w worlds))
(pnew w)
(send gui add (format "~a signed up" info))
(loop))]
@ -216,6 +219,7 @@
(provide
world? ;; Any -> Boolean
world=? ;; World World -> Boolean
world-name ;; World -> Symbol
world1 ;; sample worlds
world2
world3)
@ -334,24 +338,30 @@
;
(provide
;; type Bundle = (make-bundle Universe [Listof Mail])
;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail])
;; type Mail = (make-mail World S-expression)
make-bundle ;; Universe [Listof Mail] -> Bundle
make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle
bundle? ;; is this a bundle?
make-mail ;; World S-expression -> Mail
mail? ;; is this a real mail?
)
(define-struct bundle (state mails) #:transparent)
(define-struct bundle (low state mails) #:transparent)
(set! make-bundle
(let ([make-bundle make-bundle])
(lambda (state mails)
(check-arg 'make-bundle (list? mails) "list [of mails]" "second" mails)
(lambda (low state mails)
(check-arg-list 'make-bundle low world? "world" "first")
(check-arg-list 'make-bundle mails mail? "mail" "third")
(make-bundle low state mails))))
;; Symbol Any (Any -> Boolean) String String -> Void
;; raise a TP exception if low is not a list of world? elements
(define (check-arg-list tag low world? msg rank)
(check-arg tag (list? low) (format "list [of ~as]" msg) rank low)
(for-each (lambda (c)
(check-arg 'make-bundle (mail? c) "mail" "(elements of) second" c))
mails)
(make-bundle state mails))))
(check-arg tag (world? c) msg (format "(elements of) ~a" rank) c))
low))
(define-struct mail (to content) #:transparent)

10
collects/2htdp/private/world.ss
View File

@ -278,7 +278,8 @@
;; -------------------------------------------------------------------------
;; initialize the world and run
(super-new)
(start!)))))
(start!)
(when (stop-when world) (stop! world))))))
;; -----------------------------------------------------------------------------
(define-runtime-path break-btn:path '(lib "icons/break.png"))
@ -293,16 +294,17 @@
(inherit-field world0 tick key mouse rec draw rate width height)
(inherit show callback-stop!)
;; Frame Custodian -> (-> Void)
;; Frame Custodian ->* (-> Void) (-> Void)
;; adds the stop animation and image creation button,
;; whose callbacks runs as a thread in the custodian
;; provide a function for switching button enabling
(define/augment (create-frame frm play-back-custodian)
(define p (new horizontal-pane% [parent frm][alignment '(center center)]))
(define (switch)
(send stop-button enable #f)
(send image-button enable #t))
(define (stop) (send stop-button enable #f))
(define (stop)
(send image-button enable #f)
(send stop-button enable #f))
(define-syntax-rule (btn l a y ...)
(new button% [parent p] [label l] [style '(border)]
[callback (lambda a y ...)]))

5
collects/2htdp/test/world0-stops.ss Normal file
View File

@ -0,0 +1,5 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ((lib "universe.ss" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp")))))
(big-bang 0 (stop-when zero?) (on-tick add1))

23
collects/2htdp/universe.ss
View File

@ -228,12 +228,13 @@
;; type World
world? ;; Any -> Boolean
world=? ;; World World -> Boolean
world-name ;; World -> Symbol
world1 ;; sample worlds
world2
world3
;; type Bundle = (make-bundle Universe [Listof Mail])
;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail])
;; type Mail = (make-mail World S-expression)
make-bundle ;; Universe [Listof Mail] -> Bundle
make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle
bundle? ;; is this a bundle?
make-mail ;; World S-expression -> Mail
mail? ;; is this a real mail?
@ -254,10 +255,10 @@
;; in the console
(define-keywords UniSpec
[on-new (function-with-arity 2)]
[on-msg (function-with-arity 3)]
[on-disconnect (function-with-arity 2)]
[to-string (function-with-arity 1)])
[on-new (function-with-arity 3)]
[on-msg (function-with-arity 4)]
[on-disconnect (function-with-arity 3)]
[to-string (function-with-arity 2)])
(define-syntax (universe stx)
(syntax-case stx ()
@ -297,15 +298,15 @@
;; (World World -> U) (U World Msg) -> U
(define (universe2 create process)
;; UniState = '() | (list World) | Universe
;; UniState World -> (cons UniState [Listof (list World S-expression)])
(define (nu s p)
;; [Listof World] UniState World -> (cons UniState [Listof (list World S-expression)])
(define (nu s x p)
(cond
[(null? s) (make-bundle (list p) '())]
[(not (pair? s)) (make-bundle s '())]
[(null? s) (make-bundle (list p) '* '())]
[(not (pair? s)) (make-bundle s '* '())]
[(null? (rest s)) (create (first s) p)]
[else (error 'create "a third world is signing up!")]))
(universe '()
(on-new nu)
(on-msg process)
#;
(on-tick (lambda (u) (printf "hello!\n") (list u)) 1)))
(on-tick (lambda (u x) (printf "hello!\n") (list u)) 1)))

3
collects/compiler/compiler-unit.ss
View File

@ -5,9 +5,6 @@
;; by dynamically linking to code supplied by the MzLib, dynext, and
;; compiler collections.
;; The Scheme->C compiler is loaded as either sploadr.ss (link in
;; real MrSpidey) or loadr.ss (link in trivial MrSpidey stubs).
#lang scheme/base
(require scheme/unit

233
collects/macro-debugger/syntax-browser/display.ss
View File

@ -9,34 +9,68 @@
(provide print-syntax-to-editor
code-style)
;; print-syntax-to-editor : syntax text controller<%> -> display<%>
(define (print-syntax-to-editor stx text controller config)
(new display% (syntax stx) (text text) (controller controller) (config config)))
;; FIXME: assumes text never moves
;; print-syntax-to-editor : syntax text controller<%> config number number
;; -> display<%>
(define (print-syntax-to-editor stx text controller config columns insertion-point)
(define output-port (open-output-string/count-lines))
(define range
(pretty-print-syntax stx output-port
(send controller get-primary-partition)
(send config get-colors)
(send config get-suffix-option)
columns))
(define output-string (get-output-string output-port))
(define output-length (sub1 (string-length output-string))) ;; skip final newline
(fixup-parentheses output-string range)
(let ([display
(new display%
(text text)
(controller controller)
(config config)
(range range)
(start-position insertion-point)
(end-position (+ insertion-point output-length)))])
(send text begin-edit-sequence)
(send text insert output-length output-string insertion-point)
(add-clickbacks text range controller insertion-point)
(set-standard-font text config insertion-point (+ insertion-point output-length))
(send display initialize)
(send text end-edit-sequence)
display))
;; add-clickbacks : text% range% controller<%> number -> void
(define (add-clickbacks text range controller insertion-point)
(for ([range (send range all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(send text set-clickback (+ insertion-point start) (+ insertion-point end)
(lambda (_1 _2 _3)
(send controller set-selected-syntax stx))))))
;; set-standard-font : text% config number number -> void
(define (set-standard-font text config start end)
(send text change-style
(code-style text (send config get-syntax-font-size))
start end))
;; display%
(define display%
(class* object% (display<%>)
(init ((stx syntax)))
(init-field text)
(init-field controller)
(init-field config)
(init-field range)
(init-field start-position)
(init-field end-position)
(define start-anchor (new anchor-snip%))
(define end-anchor (new anchor-snip%))
(define range #f)
(define extra-styles (make-hasheq))
;; render-syntax : syntax -> void
(define/public (render-syntax stx)
(with-unlock text
(send text delete (get-start-position) (get-end-position))
(set! range
(print-syntax stx text controller config
(lambda () (get-start-position))
(lambda () (get-end-position))))
(apply-primary-partition-styles))
;; initialize : -> void
(define/public (initialize)
(apply-primary-partition-styles)
(refresh))
;; refresh : -> void
@ -45,7 +79,7 @@
(with-unlock text
(send* text
(begin-edit-sequence)
(change-style unhighlight-d (get-start-position) (get-end-position)))
(change-style unhighlight-d start-position end-position))
(apply-extra-styles)
(let ([selected-syntax (send controller get-selected-syntax)])
(apply-secondary-partition-styles selected-syntax)
@ -53,29 +87,15 @@
(send* text
(end-edit-sequence))))
;; cached-start-position : number
(define cached-start-position #f)
;; get-start-position : -> number
(define/public-final (get-start-position)
(unless cached-start-position
(set! cached-start-position (send text get-snip-position start-anchor)))
cached-start-position)
;; get-end-position : -> number
(define/public-final (get-end-position)
(send text get-snip-position end-anchor))
;; relative->text-position : number -> number
;; FIXME: might be slow to find start every time!
(define/public-final (relative->text-position pos)
(+ pos (get-start-position)))
;; Styling
;; get-range : -> range<%>
(define/public (get-range) range)
;; get-start-position : -> number
(define/public (get-start-position) start-position)
;; get-end-position : -> number
(define/public (get-end-position) end-position)
;; highlight-syntaxes : (list-of syntax) string -> void
(define/public (highlight-syntaxes stxs hi-color)
(let ([style-delta (highlight-style-delta hi-color #f)])
@ -89,11 +109,50 @@
(add-extra-styles stx (list underline-style-delta)))
(refresh))
;; add-extra-styles : syntax (listof style) -> void
(define/public (add-extra-styles stx styles)
(hash-set! extra-styles stx
(append (hash-ref extra-styles stx null)
styles)))
;; Primary styles
;; (Done once on initialization, never repeated)
;; apply-primary-partition-styles : -> void
;; Changes the foreground color according to the primary partition.
;; Only called once, when the syntax is first drawn.
(define/private (apply-primary-partition-styles)
(define (color-style color)
(let ([delta (new style-delta%)])
(send delta set-delta-foreground color)
delta))
(define color-styles (list->vector (map color-style (send config get-colors))))
(define overflow-style (color-style "darkgray"))
(define color-partition (send controller get-primary-partition))
(define offset start-position)
(for-each
(lambda (range)
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(send text change-style
(primary-style stx color-partition color-styles overflow-style)
(+ offset start)
(+ offset end))))
(send range all-ranges)))
;; primary-style : syntax partition (vector-of style-delta%) style-delta%
;; -> style-delta%
(define/private (primary-style stx partition color-vector overflow)
(let ([n (send partition get-partition stx)])
(cond [(< n (vector-length color-vector))
(vector-ref color-vector n)]
[else
overflow])))
;; Secondary Styling
;; May change in response to user actions
;; apply-extra-styles : -> void
;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles)
@ -131,101 +190,35 @@
(relative->text-position (car r))
(relative->text-position (cdr r))))
;; Primary styles
;; apply-primary-partition-styles : -> void
;; Changes the foreground color according to the primary partition.
;; Only called once, when the syntax is first drawn.
(define/private (apply-primary-partition-styles)
(define (color-style color)
(let ([delta (new style-delta%)])
(send delta set-delta-foreground color)
delta))
(define color-styles (list->vector (map color-style (send config get-colors))))
(define overflow-style (color-style "darkgray"))
(define color-partition (send controller get-primary-partition))
(define offset (get-start-position))
(for-each
(lambda (range)
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(send text change-style
(primary-style stx color-partition color-styles overflow-style)
(+ offset start)
(+ offset end))))
(send range all-ranges)))
;; primary-style : syntax partition (vector-of style-delta%) style-delta%
;; -> style-delta%
(define/private (primary-style stx partition color-vector overflow)
(let ([n (send partition get-partition stx)])
(cond [(< n (vector-length color-vector))
(vector-ref color-vector n)]
[else
overflow])))
;; relative->text-position : number -> number
(define/private (relative->text-position pos)
(+ pos start-position))
;; Initialize
(super-new)
(send text insert start-anchor)
(send text insert end-anchor)
(render-syntax stx)
(send controller add-syntax-display this)))
;; print-syntax : syntax text% controller config (-> number) (-> number)
;; -> range%
(define (print-syntax stx text controller config
get-start-position get-end-position)
(define primary-partition (send controller get-primary-partition))
(define real-output-port (make-text-port text get-end-position))
(define output-port (open-output-string))
(define colors (send config get-colors))
(define suffix-option (send config get-suffix-option))
(define columns (send config get-columns))
(port-count-lines! output-port)
(let ([range (pretty-print-syntax stx output-port primary-partition
colors suffix-option columns)])
(write-string (get-output-string output-port) real-output-port)
(let ([end (get-end-position)])
;; Pretty printer always inserts final newline; we remove it here.
(send text delete (sub1 end) end))
(let ([offset (get-start-position)])
(fixup-parentheses text range offset)
(for-each
(lambda (range)
(let* ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(send text set-clickback (+ offset start) (+ offset end)
(lambda (_1 _2 _3)
(send controller set-selected-syntax stx)))))
(send range all-ranges)))
;; Set font to standard
(send text change-style
(code-style text (send config get-syntax-font-size))
(get-start-position)
(get-end-position))
range))
;; fixup-parentheses : text range -> void
(define (fixup-parentheses text range offset)
;; fixup-parentheses : string range -> void
(define (fixup-parentheses string range)
(define (fixup r)
(let ([stx (range-obj r)]
[start (+ offset (range-start r))]
[end (+ offset (range-end r))])
[start (range-start r)]
[end (range-end r)])
(when (and (syntax? stx) (pair? (syntax-e stx)))
(case (syntax-property stx 'paren-shape)
((#\[)
(replace start #\[)
(replace (sub1 end) #\]))
(string-set! string start #\[)
(string-set! string (sub1 end) #\]))
((#\{)
(replace start #\{)
(replace (sub1 end) #\}))))))
(define (replace pos char)
(send text insert char pos (add1 pos)))
(string-set! string start #\{)
(string-set! string (sub1 end) #\}))))))
(for-each fixup (send range all-ranges)))
(define (open-output-string/count-lines)
(let ([os (open-output-string)])
(port-count-lines! os)
os))
;; code-style : text<%> number/#f -> style<%>
(define (code-style text font-size)
(let* ([style-list (send text get-style-list)]

3
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -22,9 +22,6 @@
(define prefs-base%
(class object%
;; columns : number
(field/notify columns (new notify-box% (value 60)))
;; suffix-option : SuffixOption
(field/notify suffix-option (new notify-box% (value 'over-limit)))

9
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -143,7 +143,7 @@
(for ([binder-r (send range get-ranges binder)])
(for ([id-r (send range get-ranges id)])
(add-binding-arrow start binder-r id-r definite?)))))))
display))
(void)))
(define/private (add-binding-arrow start binder-r id-r definite?)
(if definite?
@ -189,14 +189,17 @@
;; internal-add-syntax : syntax -> display
(define/private (internal-add-syntax stx)
(with-unlock -text
(let ([display (print-syntax-to-editor stx -text controller config)])
(let ([display
(print-syntax-to-editor stx -text controller config
(calculate-columns)
(send -text last-position))])
(send* -text
(insert "\n")
;;(scroll-to-position current-position)
)
display)))
(define/public (calculate-columns)
(define/private (calculate-columns)
(define style (code-style -text (send config get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))

1
collects/macro-debugger/view/frame.ss
View File

@ -54,7 +54,6 @@
(define/override (on-size w h)
(send config set-width w)
(send config set-height h)
(send config set-columns (send (send widget get-view) calculate-columns))
(send widget update/preserve-view))
(define warning-panel

17
collects/mred/private/editor.ss
View File

@ -341,24 +341,25 @@
((void) after-edit-sequence))
(private*
[sp (lambda (x y z f b?)
[sp (lambda (x y z f b? eps?)
;; let super method report z errors:
(let ([zok? (memq z '(standard postscript))])
(when zok?
(check-top-level-parent/false '(method editor<%> print) f))
(let ([p (and zok? f (mred->wx f))])
(as-exit (lambda () (super print x y z p b?))))))])
(as-exit (lambda () (super print x y z p b? eps?))))))])
(override*
[print
(entry-point
(case-lambda
[() (sp #t #t 'standard #f #t)]
[(x) (sp x #t 'standard #f #t)]
[(x y) (sp x y 'standard #f #t)]
[(x y z) (sp x y z #f #t)]
[(x y z f) (sp x y z f #t)]
[(x y z f b?) (sp x y z f b?)]))]
[() (sp #t #t 'standard #f #t #f)]
[(x) (sp x #t 'standard #f #t #f)]
[(x y) (sp x y 'standard #f #t #f)]
[(x y z) (sp x y z #f #t #f)]
[(x y z f) (sp x y z f #t #f)]
[(x y z f b?) (sp x y z f b? #f)]
[(x y z f b? eps?) (sp x y z f b? eps?)]))]
[on-new-box
(entry-point

7
collects/redex/HISTORY
View File

@ -1,3 +1,10 @@
- added more coloring arguments to traces: #:scheme-colors?
#:default-arrow-highlight-color, and #:default-arrow-color
- added the #:layout argument to traces
- added term-node-set-position!
- Added tracing to metafunctions (see current-traced-metafunctions)
- added caching-enabled? parameter (changed how set-cache-size!

34
collects/redex/gui.ss
View File

@ -33,7 +33,20 @@
#:pred (or/c (any/c . -> . any)
(any/c term-node? . -> . any))
#:pp pp-contract
#:colors (listof any/c))
#:colors (listof (list/c string? string?))
#:scheme-colors? boolean?
#:layout (-> any/c any/c))
any)]
[traces/ps (->* (reduction-relation?
any/c
(or/c path-string? path?))
(#:multiple?
boolean?
#:pred (or/c (any/c . -> . any)
(any/c term-node? . -> . any))
#:pp pp-contract
#:colors (listof any/c)
#:layout (-> any/c any/c))
any)]
[term-node? (-> any/c boolean?)]
@ -45,6 +58,11 @@
(or/c string? (is-a?/c color%) false/c)
void?)]
[term-node-expr (-> term-node? any)]
[term-node-set-position! (-> term-node? real? real? void?)]
[term-node-x (-> term-node? real?)]
[term-node-y (-> term-node? real?)]
[term-node-width (-> term-node? real?)]
[term-node-height (-> term-node? real?)]
[stepper
(->* (reduction-relation?
@ -55,10 +73,16 @@
(->* (reduction-relation?
(cons/c any/c (listof any/c)))
(pp-contract)
void?)])
void?)]
[dark-pen-color (parameter/c (or/c string? (is-a?/c color%)))]
[light-pen-color (parameter/c (or/c string? (is-a?/c color%)))]
[dark-brush-color (parameter/c (or/c string? (is-a?/c color%)))]
[light-brush-color (parameter/c (or/c string? (is-a?/c color%)))]
[dark-text-color (parameter/c (or/c string? (is-a?/c color%)))]
[light-text-color (parameter/c (or/c string? (is-a?/c color%)))]
[initial-font-size (parameter/c number?)]
[initial-char-width (parameter/c number?)])
(provide reduction-steps-cutoff initial-font-size initial-char-width
dark-pen-color light-pen-color dark-brush-color light-brush-color
dark-text-color light-text-color
(provide reduction-steps-cutoff
default-pretty-printer)

35
collects/redex/private/reduction-semantics.ss
View File

@ -753,22 +753,32 @@
acc)))]))
other-matches)))))
(rewrite-proc-name child-make-proc)
(subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from)))
(subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from)
(rewrite-proc-id child-make-proc)))
(define relation-coverage (make-parameter #f))
(define-struct covered-case (name apps) #:inspector (make-inspector))
(define (cover-case id name cov)
(hash-update! (coverage-unwrap cov) id
(λ (c) (cons (car c) (add1 (cdr c))))
(λ () (raise-user-error
'relation-coverage
"coverage structure not initilized for this relation"))))
(define (apply-case c)
(struct-copy covered-case c [apps (add1 (covered-case-apps c))]))
(define (covered-cases cov)
(hash-map (coverage-unwrap cov) (λ (k v) v)))
(define (cover-case id name relation-coverage)
(hash-update! relation-coverage id apply-case (make-covered-case name 0)))
(define-struct coverage (unwrap))
(define (covered-cases relation-coverage)
(hash-map relation-coverage (λ (k v) v)))
(define (fresh-coverage relation)
(let ([h (make-hasheq)])
(for-each
(λ (rwp)
(hash-set! h (rewrite-proc-id rwp) (cons (or (rewrite-proc-name rwp) "unnamed") 0)))
(reduction-relation-make-procs relation))
(make-coverage h)))
(define fresh-coverage make-hasheq)
;(define fresh-coverage (compose make-coverage make-hasheq))
(define (do-leaf-match name pat w/extras proc)
(let ([case-id (gensym)])
@ -788,7 +798,8 @@
other-matches)
other-matches)))))
name
w/extras)))
w/extras
case-id)))
(define-syntax (test-match stx)
(syntax-case stx ()
@ -1835,5 +1846,5 @@
(provide relation-coverage
covered-cases
fresh-coverage
(struct-out covered-case))
(rename-out [fresh-coverage make-coverage])
coverage?)

40
collects/redex/private/rg-test.ss
View File

@ -504,42 +504,42 @@
(get-output-string p)
(close-output-port p))))
;; check
;; redex-check
(let ()
(define-language lang
(d 5)
(e e 4)
(n number))
(test (current-output (λ () (check lang d #f)))
(test (current-output (λ () (redex-check lang d #f)))
"counterexample found after 1 attempts:\n5\n")
(test (check lang d #t) #t)
(test (check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t)
(test (check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t)
(test (current-output (λ () (check lang (d e) #f)))
(test (redex-check lang d #t) #t)
(test (redex-check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t)
(test (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t)
(test (current-output (λ () (redex-check lang (d e) #f)))
"counterexample found after 1 attempts:\n(5 4)\n")
(test (current-output (λ () (check lang d (error 'pred-raised))))
(test (current-output (λ () (redex-check lang d (error 'pred-raised))))
"counterexample found after 1 attempts:\n5\n")
(test (parameterize ([check-randomness (make-random 0 0)])
(check lang n (eq? 42 (term n))
(redex-check lang n (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 42 x))))
#t)
(test (current-output
(λ ()
(parameterize ([check-randomness (make-random 0 0)])
(check lang n (eq? 42 (term n))
(redex-check lang n (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 0 x z))))))
"counterexample found (z) after 1 attempts:\n0\n")
(test (current-output
(λ ()
(parameterize ([check-randomness (make-random 1)])
(check lang d (eq? 42 (term n))
(redex-check lang d (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 0 x z))))))
"counterexample found after 1 attempts:\n5\n")
(test (let ([r (reduction-relation lang (--> 0 x z))])
(check lang n (number? (term n))
(redex-check lang n (number? (term n))
#:attempts 10
#:source r))
#t)
@ -548,18 +548,18 @@
[(mf 0) 0]
[(mf 42) 0])
(test (parameterize ([check-randomness (make-random 0 1)])
(check lang (n) (eq? 42 (term n))
(redex-check lang (n) (eq? 42 (term n))
#:attempts 1
#:source mf))
#t))
(let ()
(define-language L)
(test (with-handlers ([exn:fail? exn-message])
(check lang any #t #:source (reduction-relation L (--> 1 1))))
(redex-check lang any #t #:source (reduction-relation L (--> 1 1))))
#rx"language for secondary source"))
(let ()
(test (with-handlers ([exn:fail? exn-message])
(check lang n #t #:source (reduction-relation lang (--> x 1))))
(redex-check lang n #t #:source (reduction-relation lang (--> x 1))))
#rx"x does not match n"))
(let ([stx-err (λ (stx)
@ -570,15 +570,15 @@
(eval '(require "../reduction-semantics.ss"
"rg.ss"))
(eval '(define-language empty))
(test (stx-err '(check empty any #t #:typo 3))
#rx"check: bad keyword syntax")
(test (stx-err '(check empty any #t #:attempts 3 #:attempts 4))
(test (stx-err '(redex-check empty any #t #:typo 3))
#rx"redex-check: bad keyword syntax")
(test (stx-err '(redex-check empty any #t #:attempts 3 #:attempts 4))
#rx"bad keyword syntax")
(test (stx-err '(check empty any #t #:attempts))
(test (stx-err '(redex-check empty any #t #:attempts))
#rx"bad keyword syntax")
(test (stx-err '(check empty any #t #:attempts 3 4))
(test (stx-err '(redex-check empty any #t #:attempts 3 4))
#rx"bad keyword syntax")
(test (stx-err '(check empty any #t #:source #:attempts))
(test (stx-err '(redex-check empty any #t #:source #:attempts))
#rx"bad keyword syntax"))))
;; check-metafunction-contract

17
collects/redex/private/rg.ss
View File

@ -655,11 +655,12 @@ To do a better job of not generating programs with free variables,
(define check-randomness (make-parameter random))
(define-syntax (check stx)
(define-syntax (redex-check stx)
(syntax-case stx ()
[(_ lang pat property . kw-args)
(let-values ([(names names/ellipses)
(extract-names (language-id-nts #'lang 'check) 'check #t #'pat)]
(extract-names (language-id-nts #'lang 'redex-check)
'redex-check #t #'pat)]
[(attempts-stx source-stx)
(let loop ([args (syntax kw-args)]
[attempts #f]
@ -678,9 +679,9 @@ To do a better job of not generating programs with free variables,
[attempts (or attempts-stx #'default-check-attempts)])
(quasisyntax/loc stx
(let ([att attempts])
(assert-nat 'check att)
(assert-nat 'redex-check att)
(or (check-property
(cons (list #,(term-generator #'lang #'pat #'random-decisions 'check) #f)
(cons (list #,(term-generator #'lang #'pat #'random-decisions 'redex-check) #f)
(let ([lang-gen (generate lang (random-decisions lang))])
#,(if (not source-stx)
#'null
@ -694,16 +695,16 @@ To do a better job of not generating programs with free variables,
[else
#`(let ([r #,source-stx])
(unless (reduction-relation? r)
(raise-type-error 'check "reduction-relation" r))
(raise-type-error 'redex-check "reduction-relation" r))
(values
(map rewrite-proc-lhs (reduction-relation-make-procs r))
(reduction-relation-srcs r)
(reduction-relation-lang r)))])])
(unless (eq? src-lang lang)
(error 'check "language for secondary source must match primary pattern's language"))
(error 'redex-check "language for secondary source must match primary pattern's language"))
(zip (map lang-gen pats) srcs)))))
#,(and source-stx #'(test-match lang pat))
(λ (generated) (error 'check "~s does not match ~s" generated 'pat))
(λ (generated) (error 'redex-check "~s does not match ~s" generated 'pat))
(λ (_ bindings)
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
property))
@ -842,7 +843,7 @@ To do a better job of not generating programs with free variables,
(define generation-decisions (make-parameter random-decisions))
(provide pick-from-list pick-var min-prods decisions^ pick-sequence-length
is-nt? pick-char random-string pick-string check nt-by-name
is-nt? pick-char random-string pick-string redex-check nt-by-name
pick-nt unique-chars pick-any sexp generate-term parse-pattern
class-reassignments reassign-classes unparse-pattern
(struct-out ellipsis) (struct-out mismatch) (struct-out class)

9
collects/redex/private/struct.ss
View File

@ -9,7 +9,7 @@
build-reduction-relation
reduction-relation?
empty-reduction-relation
make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs
make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs rewrite-proc-id
(struct-out rule-pict))
(define-struct rule-pict (arrow lhs rhs label side-conditions fresh-vars pattern-binds))
@ -20,14 +20,15 @@
;; we want to avoid doing it multiple times, so it is cached in a reduction-relation struct
(define-values (make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs)
(define-values (make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs rewrite-proc-id)
(let ()
(define-values (type constructor predicate accessor mutator)
(make-struct-type 'rewrite-proc #f 3 0 #f '() #f 0))
(make-struct-type 'rewrite-proc #f 4 0 #f '() #f 0))
(values constructor
predicate
(make-struct-field-accessor accessor 1 'name)
(make-struct-field-accessor accessor 2 'lhs))))
(make-struct-field-accessor accessor 2 'lhs)
(make-struct-field-accessor accessor 3 'id))))
;; lang : compiled-language
;; make-procs = (listof (compiled-lang -> proc))

25
collects/redex/private/tl-test.ss
View File

@ -1,8 +1,5 @@
(module tl-test mzscheme
(require "../reduction-semantics.ss"
(only "reduction-semantics.ss"
relation-coverage fresh-coverage covered-cases
make-covered-case covered-case-name)
"test-util.ss"
(only "matcher.ss" make-bindings make-bind)
scheme/match
@ -1226,32 +1223,30 @@
[else #f])
#t))
(let ([R (reduction-relation
(let* ([R (reduction-relation
empty-language
(--> number (q ,(add1 (term number)))
(side-condition (odd? (term number)))
side-condition)
(--> 1 4
one)
(--> 1 4)
(==> 2 t
shortcut)
with
[(--> (q a) b)
(==> a b)])]
[c (fresh-coverage)])
[c (make-coverage R)]
[< (λ (c d) (string<? (car c) (car d)))])
(parameterize ([relation-coverage c])
(apply-reduction-relation R 4)
(test (covered-cases c) null)
(test (sort (covered-cases c) <)
'(("shortcut" . 0) ("side-condition" . 0) ("unnamed" . 0)))
(apply-reduction-relation R 3)
(test (covered-cases c)
(list (make-covered-case "side-condition" 1)))
(test (sort (covered-cases c) <)
'(("shortcut" . 0) ("side-condition" . 1) ("unnamed" . 0)))
(apply-reduction-relation* R 1)
(test (sort (covered-cases c)
(λ (c d) (string<? (covered-case-name c) (covered-case-name d))))
(list (make-covered-case "one" 1)
(make-covered-case "shortcut" 1)
(make-covered-case "side-condition" 2)))))
(test (sort (covered-cases c) <)
'(("shortcut" . 1) ("side-condition" . 2) ("unnamed" . 1)))))
(print-tests-passed 'tl-test.ss))

205
collects/redex/private/traces.ss
View File

@ -30,15 +30,87 @@
(define (term-node-expr term-node) (send (term-node-snip term-node) get-expr))
(define (term-node-labels term-node) (send (term-node-snip term-node) get-one-step-labels))
(define (term-node-set-color! term-node r?)
(let loop ([snip (term-node-snip term-node)])
(parameterize ([current-eventspace (send snip get-my-eventspace)])
(queue-callback
(snip/eventspace
(λ ()
(send (term-node-snip term-node) set-bad r?))))))
(send (term-node-snip term-node) set-bad r?))))
(define (term-node-set-red! term-node r?)
(term-node-set-color! term-node (and r? "pink")))
(define (term-node-set-position! term-node x y)
(snip/eventspace/ed
term-node
(λ (ed)
(when ed
(send ed move-to (term-node-snip term-node) x y)))))
(define (term-node-width term-node)
(snip/eventspace/ed
term-node
(λ (ed)
(let ([lb (box 0)]
[rb (box 0)]
[snip (term-node-snip term-node)])
(if (and (send ed get-snip-location snip lb #f #f)
(send ed get-snip-location snip rb #f #t))
(- (unbox rb) (unbox lb))
0)))))
(define (term-node-height term-node)
(snip/eventspace/ed
term-node
(λ (ed)
(let ([tb (box 0)]
[bb (box 0)]
[snip (term-node-snip term-node)])
(if (and (send ed get-snip-location snip #f tb #f)
(send ed get-snip-location snip #f bb #t))
(- (unbox bb) (unbox tb))
0)))))
(define (term-node-x term-node)
(snip/eventspace/ed
term-node
(λ (ed)
(let ([xb (box 0)]
[snip (term-node-snip term-node)])
(if (send ed get-snip-location snip xb #f #f)
(unbox xb)
0)))))
(define (term-node-y term-node)
(snip/eventspace/ed
term-node
(λ (ed)
(let ([yb (box 0)]
[snip (term-node-snip term-node)])
(if (send ed get-snip-location snip yb #f #f)
(unbox yb)
0)))))
(define (snip/eventspace/ed term-node f)
(snip/eventspace
term-node
(λ ()
(let* ([snip (term-node-snip term-node)]
[admin (send snip get-admin)])
(f (and admin (send admin get-editor)))))))
(define (snip/eventspace term-node thunk)
(let* ([snip (term-node-snip term-node)]
[eventspace (send snip get-my-eventspace)])
(cond
[(eq? (current-eventspace) eventspace)
(thunk)]
[else
(let ([c (make-channel)])
(parameterize ([current-eventspace eventspace])
(queue-callback
(λ ()
(channel-put c (thunk)))))
(channel-get c))])))
(define initial-font-size
(make-parameter
(send (send (send (editor:get-standard-style-list)
@ -51,7 +123,37 @@
(define x-spacing 15)
(define y-spacing 15)
(define (traces reductions pre-exprs #:multiple? [multiple? #f] #:pred [pred (λ (x) #t)] #:pp [pp default-pretty-printer] #:colors [colors '()])
(define (traces/ps reductions pre-exprs filename
#:multiple? [multiple? #f]
#:pred [pred (λ (x) #t)]
#:pp [pp default-pretty-printer]
#:scheme-colors? [scheme-colors? #t]
#:colors [colors '()]
#:layout [layout void])
(let-values ([(graph-pb frame)
(traces reductions pre-exprs
#:no-show-frame? #t
#:multiple? multiple?
#:pred pred
#:pp pp
#:scheme-colors? scheme-colors?
#:colors colors
#:layout layout)])
(let ([ps-setup (make-object ps-setup%)])
(send ps-setup copy-from (current-ps-setup))
(send ps-setup set-file filename)
(send ps-setup set-mode 'file)
(parameterize ([current-ps-setup ps-setup])
(send graph-pb print #f #f 'postscript #f #f #t)))))
(define (traces reductions pre-exprs
#:multiple? [multiple? #f]
#:pred [pred (λ (x) #t)]
#:pp [pp default-pretty-printer]
#:colors [colors '()]
#:scheme-colors? [scheme-colors? #t]
#:layout [layout void]
#: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))
@ -146,14 +248,18 @@
(semaphore-wait s)
ans)))
(define default-colors (list (dark-pen-color) (light-pen-color)
(dark-text-color) (light-text-color)
(dark-brush-color) (light-brush-color)))
;; only changed on the reduction thread
;; frontier : (listof (is-a?/c graph-editor-snip%))
(define frontier
(filter
(λ (x) x)
(map (lambda (expr) (build-snip snip-cache #f expr pred pp
(dark-pen-color) (light-pen-color)
(dark-text-color) (light-text-color) #f))
(map (lambda (expr) (apply build-snip
snip-cache #f expr pred pp #f scheme-colors?
default-colors))
exprs)))
;; set-font-size : number -> void
@ -172,38 +278,29 @@
(send snip shrink-down))
(loop (send snip next))))))
;; color-spec-list->color-scheme : (list (union string? #f)^4) -> (list string?^4)
;; converts a list of user-specified colors (including false) into a list of color strings, filling in
;; falses with the default colors
(define (color-spec-list->color-scheme l)
(map (λ (c d) (or c d))
l
(list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color))))
;; fill-out : (listof X) (listof X) -> (listof X)
;; produces a list whose length matches defaults but
(define (fill-out l defaults)
(let loop ([l l]
[default defaults])
(cond
[(null? l) defaults]
[else
(cons (car l) (loop (cdr l) (cdr defaults)))])))
(define name->color-ht
(let ((ht (make-hash)))
(for-each
(λ (c)
(hash-set! ht (car c)
(color-spec-list->color-scheme
(match (cdr c)
[`(,color)
(list color color (dark-text-color) (light-text-color))]
[`(,dark-arrow-color ,light-arrow-color)
(list dark-arrow-color light-arrow-color (dark-text-color) (light-text-color))]
[`(,dark-arrow-color ,light-arrow-color ,text-color)
(list dark-arrow-color light-arrow-color text-color text-color)]
[`(,_ ,_ ,_ ,_)
(cdr c)]))))
(hash-set! ht (car c) (fill-out (cdr c) default-colors)))
colors)
ht))
;; red->colors : string -> (values string string string string)
;; red->colors : string -> (values string string string string string string)
(define (red->colors reduction-name)
(apply values (hash-ref name->color-ht
reduction-name
(λ () (list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color))))))
default-colors)))
;; reduce-frontier : -> void
;; =reduction thread=
@ -225,11 +322,13 @@
(let-values ([(name sexp) (apply values red+sexp)])
(call-on-eventspace-main-thread
(λ ()
(let-values ([(dark-arrow-color light-arrow-color dark-label-color light-label-color)
(let-values ([(dark-arrow-color light-arrow-color dark-label-color light-label-color
dark-pen-color
light-pen-color)
(red->colors name)])
(build-snip snip-cache snip sexp pred pp
(build-snip snip-cache snip sexp pred pp name scheme-colors?
light-arrow-color dark-arrow-color dark-label-color light-label-color
name))))))
dark-pen-color light-pen-color))))))
(apply-reduction-relation/tag-with-names reductions (send snip get-expr))))]
[new-y
(call-on-eventspace-main-thread
@ -239,6 +338,7 @@
(set! col (+ x-spacing (find-rightmost-x graph-pb))))
(begin0
(insert-into col y graph-pb new-snips)
(layout (hash-map snip-cache (lambda (x y) (send y get-term-node))))
(send graph-pb end-edit-sequence)
(send status-message set-label
(string-append (term-count (count-snips)) "...")))))])
@ -369,9 +469,19 @@
null)))
(out-of-dot-state) ;; make sure the state is initialized right
(insert-into init-rightmost-x 0 graph-pb frontier)
(layout (map (lambda (y) (send y get-term-node)) frontier))
(set-font-size (initial-font-size))
(cond
[no-show-frame?
(let ([s (make-semaphore)])
(thread (λ ()
(do-some-reductions)
(semaphore-post s)))
(yield s))
(values graph-pb f)]
[else
(reduce-button-callback)
(send f show #t))
(send f show #t)]))
(define red-sem-frame%
(class (frame:standard-menus-mixin (frame:basic-mixin frame%))
@ -509,20 +619,22 @@
;; sexp
;; sexp -> boolean
;; (any port number -> void)
;; color
;; (union #f string)
;; color^6
;; -> (union #f (is-a?/c graph-editor-snip%))
;; returns #f if a snip corresponding to the expr has already been created.
;; also adds in the links to the parent snip
;; =eventspace main thread=
(define (build-snip cache parent-snip expr pred pp light-arrow-color dark-arrow-color dark-label-color light-label-color name)
(define (build-snip cache parent-snip expr pred pp name scheme-colors?
light-arrow-color dark-arrow-color dark-label-color light-label-color
dark-brush-color light-brush-color)
(let-values ([(snip new?)
(let/ec k
(values (hash-ref
cache
expr
(lambda ()
(let ([new-snip (make-snip parent-snip expr pred pp)])
(let ([new-snip (make-snip parent-snip expr pred pp scheme-colors?)])
(hash-set! cache expr new-snip)
(k new-snip #t))))
#f))])
@ -532,10 +644,14 @@
(add-links/text-colors parent-snip snip
(send the-pen-list find-or-create-pen dark-arrow-color 0 'solid)
(send the-pen-list find-or-create-pen light-arrow-color 0 'solid)
(send the-brush-list find-or-create-brush (dark-brush-color) 'solid)
(send the-brush-list find-or-create-brush (light-brush-color) 'solid)
(make-object color% dark-label-color)
(make-object color% light-label-color)
(send the-brush-list find-or-create-brush dark-brush-color 'solid)
(send the-brush-list find-or-create-brush light-brush-color 'solid)
(if (is-a? dark-label-color color%)
dark-label-color
(make-object color% dark-label-color))
(if (is-a? light-label-color color%)
light-label-color
(make-object color% light-label-color))
0 0
name)
(update-badness pred parent-snip (send parent-snip get-expr)))
@ -563,7 +679,7 @@
;; -> (is-a?/c graph-editor-snip%)
;; unconditionally creates a new graph-editor-snip
;; =eventspace main thread=
(define (make-snip parent-snip expr pred pp)
(define (make-snip parent-snip expr pred pp scheme-colors?)
(let* ([text (new program-text%)]
[es (instantiate graph-editor-snip% ()
(char-width (initial-char-width))
@ -573,6 +689,7 @@
(expr expr))])
(send text set-autowrap-bitmap #f)
(send text freeze-colorer)
(send text stop-colorer (not scheme-colors?))
(send es format-expr)
es))
@ -605,12 +722,18 @@
(unbox bt))))
(provide traces
traces/ps
term-node?
term-node-parents
term-node-children
term-node-labels
term-node-set-red!
term-node-set-color!
term-node-set-position!
term-node-x
term-node-y
term-node-width
term-node-height
term-node-expr)
(provide reduction-steps-cutoff initial-font-size

205
collects/redex/redex.scrbl
View File

@ -47,9 +47,12 @@
#'((tech "term") args ...)]
[x (identifier? #'x) #'(tech "term")]))
@(define redex-eval (make-base-eval))
@(interaction-eval #:eval redex-eval (require redex/reduction-semantics))
@title{@bold{Redex}: Debugging Operational Semantics}
@author["Robert Bruce Findler"]
@author["Robert Bruce Findler" "Casey Klein"]
PLT Redex consists of a domain-specific language for specifying
reduction semantics, plus a suite of tools for working with the
@ -982,6 +985,128 @@ counters so that next time this function is called, it
prints the test results for the next round of tests.
}
@defproc[(make-coverage [r reduction-relation?]) coverage?]{
Constructs a structure to contain the per-case test coverage of
the relation @scheme[r]. Use with @scheme[relation-coverage]
and @scheme[covered-cases].
}
@defproc[(coverage? [v any/c]) boolean?]{
Returns @scheme[#t] for a value produced by @scheme[make-coverage]
and @scheme[#f] for any other.}
@defparam[relation-coverage c (or/c false/c coverage?)]{
When @scheme[c] is a @scheme[coverage] structure, rather than
@scheme[#f] (the default), procedures such as
@scheme[apply-reduction-relation], @scheme[traces], etc. count
the number applications of each case of the
@scheme[reduction-relation], storing the results in @scheme[c].
}
@defproc[(covered-cases
[c coverage?])
(listof (cons/c string? natural-number/c))]{
Extracts the coverage information recorded in @scheme[c], producing
an association list mapping names to application counts.}
@examples[
#:eval redex-eval
(define-language empty-lang)
(define equals
(reduction-relation
empty-lang
(--> (+) 0 "zero")
(--> (+ number) number)
(--> (+ number_1 number_2 number ...)
(+ ,(+ (term number_1) (term number_2))
number ...)
"add")))
(let ([coverage (make-coverage equals)])
(parameterize ([relation-coverage coverage])
(apply-reduction-relation* equals (term (+ 1 2 3)))
(covered-cases coverage)))]
@defform*[[(generate-term language #, @|ttpattern| size-exp)
(generate-term language #, @|ttpattern| size-exp #:attempt attempt-num-expr)]
#:contracts ([size-expr natural-number/c]
[attempt-num-expr natural-number/c])]{
Generates a random term matching @scheme[pattern] (in the given language).
The argument @scheme[size-expr] bounds the height of the generated term
(measured as the height of the derivation tree used to produce
the term).
The optional keyword argument @scheme[attempt-num-expr]
(default @scheme[1]) provides coarse grained control over the random
decisions made during generation (e.g., the expected length of
@pattech[pattern-sequence]s increases with @scheme[attempt-num-expr]).}
@defform/subs[(redex-check language #, @|ttpattern| property-expr kw-arg ...)
([kw-arg (code:line #:attempts attempts-expr)
(code:line #:source metafunction)
(code:line #:source relation-expr)])
#:contracts ([property-expr any/c]
[attempts-expr natural-number/c]
[relation-expr reduction-relation?])]{
Searches for a counterexample to @scheme[property-expr], interpreted
as a predicate universally quantified over its free
@pattech[term]-variables. @scheme[redex-check] chooses substitutions for
these free @pattech[term]-variables by generating random terms matching
@scheme[pattern] and extracting the sub-terms bound by the
@pattech[names] and non-terminals in @scheme[pattern].
@examples[
#:eval redex-eval
(define-language empty-lang)
(random-seed 0)
(redex-check
empty-lang
((number_1 ...)
(number_2 ...))
(equal? (reverse (append (term (number_1 ...))
(term (number_2 ...))))
(append (reverse (term (number_1 ...)))
(reverse (term (number_2 ...))))))
(redex-check
empty-lang
((number_1 ...)
(number_2 ...))
(equal? (reverse (append (term (number_1 ...))
(term (number_2 ...))))
(append (reverse (term (number_2 ...)))
(reverse (term (number_1 ...)))))
#:attempts 200)]
@scheme[redex-check] generates at most @scheme[attempts-expr] (default @scheme[100])
random terms in its search. The size and complexity of terms it generates
gradually increases with each failed attempt.
When the optional @scheme[#:source] argument is present, @scheme[redex-check]
generates @math{10%} of its terms by randomly choosing a pattern from the
left-hand sides the definition of the supplied metafunction or relation.
@scheme[redex-check] raises an exception if a term generated from an alternate
pattern does not match the @scheme[pattern].}
@defproc[(check-reduction-relation
[relation reduction-relation?]
[property (-> any/c any/c)]
[#:attempts attempts natural-number/c 100])
(or/c true/c void?)]{
Tests a @scheme[relation] as follows: for each case of @scheme[relation],
@scheme[check-reduction-relation] generates @scheme[attempts] random
terms that match that case's left-hand side and applies @scheme[property]
to each random term.}
@defform*[[(check-metafunction metafunction property)
(check-metafunction metafunction property #:attempts attempts)]
#:contracts ([property (-> any/c any/c)]
[attempts natural-number/c])]{
Like @scheme[check-reduction-relation] but for metafunctions.}
@deftech{Debugging PLT Redex Programs}
It is easy to write grammars and reduction rules that are
@ -1017,13 +1142,21 @@ exploring reduction sequences.
[expr (or/c any/c (listof any/c))]
[#:multiple? multiple? boolean? #f]
[#:pred pred
(or/c (sexp -> any) (sexp term-node? any))
(or/c (-> sexp any)
(-> sexp term-node? any))
(lambda (x) #t)]
[#:pp pp
(or/c (any -> string)
(any output-port number (is-a?/c text%) -> void))
default-pretty-printer]
[#:colors colors (listof (list string string)) '()])
[#:colors colors
(listof
(cons/c string
(and/c (listof (or/c string? (is-a?/c color%)))
(lambda (x) (member (length x) '(2 3 4 6))))))]
[#:scheme-colors? scheme-colors? boolean?]
[#:layout layout (-> (listof term-node?) void)])
void?]{
This function opens a new window and inserts each expression
@ -1063,14 +1196,56 @@ final argument is the text where the port is connected --
characters written to the port go to the end of the editor.
The @scheme[colors] argument, if provided, specifies a list of
reduction-name/color-string pairs. The traces gui will color
arrows drawn because of the given reduction name with the
given color instead of using the default color.
reduction-name/color-list pairs. The traces gui will color arrows
drawn because of the given reduction name with the given color instead
of using the default color.
The @scheme[cdr] of each of the elements of @scheme[colors] is a list
of colors, organized in pairs. The first two colors cover the colors
of the line and the border around the arrow head, the first when the
mouse is over a graph node that is connected to that arrow, and the
second for when the mouse is not over that arrow. Similarly, the next
colors are for the text drawn on the arrow and the last two are for
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],
@scheme[traces] just uses black for the color scheme.
The @scheme[layout] argument is called (with all of the terms) each
time a new term is inserted into the window. See also
@scheme[term-node-set-position!].
You can save the contents of the window as a postscript file
from the menus.
}
@defproc[(traces/ps [reductions reduction-relation?]
[expr (or/c any/c (listof any/c))]
[file (or/c path-string? path?)]
[#:multiple? multiple? boolean? #f]
[#:pred pred
(or/c (-> sexp any)
(-> sexp term-node? any))
(lambda (x) #t)]
[#:pp pp
(or/c (any -> string)
(any output-port number (is-a?/c text%) -> void))
default-pretty-printer]
[#:colors colors (listof (list string string)) '()]
[#:layout layout (-> (listof term-node?) void)])
void?]{
The arguments behave just like the function @scheme[traces], but
instead of opening a window to show the reduction graph, it just saves
the reduction graph to the specified @scheme[file].
}
@defproc[(stepper [reductions reduction-relation?]
[t any/c]
[pp (or/c (any -> string)
@ -1146,6 +1321,24 @@ not colored specially.
Returns the expression in this node.
}
@defproc[(term-node-set-position! [tn term-node?] [x (and/c real? positive?)] [y (and/c real? positive?)]) void?]{
Sets the position of @scheme[tn] in the graph to (@scheme[x],@scheme[y]).
}
@defproc[(term-node-x [tn term-node?]) real]{
Returns the @tt{x} coordinate of @scheme[tn] in the window.
}
@defproc[(term-node-y [tn term-node?]) real]{
Returns the @tt{y} coordinate of @scheme[tn] in the window.
}
@defproc[(term-node-width [tn term-node?]) real]{
Returns the width of @scheme[tn] in the window.
}
@defproc[(term-node-height [tn term-node?]) real?]{
Returns the height of @scheme[tn] in the window.
}
@defproc[(term-node? [v any/c]) boolean?]{
Recognizes term nodes.

15
collects/redex/reduction-semantics.ss
View File

@ -7,8 +7,6 @@
"private/rg.ss"
"private/error.ss")
#;(provide (all-from-out "private/rg.ss"))
(provide exn:fail:redex?) ;; from error.ss
(provide reduction-relation
@ -43,6 +41,11 @@
test-predicate
test-results)
(provide redex-check
generate-term
check-metafunction
check-metafunction-contract)
(provide/contract
[current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))]
[reduction-relation->rule-names (-> reduction-relation? (listof symbol?))]
@ -61,4 +64,10 @@
(-> bindings? symbol? any)
(-> bindings? symbol? (-> any) any))]
[variable-not-in (any/c symbol? . -> . symbol?)]
[variables-not-in (any/c (listof symbol?) . -> . (listof symbol?))])
[variables-not-in (any/c (listof symbol?) . -> . (listof symbol?))]
[check-reduction-relation (->* (reduction-relation? (-> any/c any/c))
(#:attempts natural-number/c)
(one-of/c #t (void)))]
[relation-coverage (parameter/c (or/c false/c coverage?))]
[make-coverage (-> reduction-relation? coverage?)]
[covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))])

2
collects/repos-time-stamp/stamp.ss
View File

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

48
collects/scheme/path.ss
View File

@ -6,7 +6,9 @@
normalize-path
filename-extension
file-name-from-path
path-only)
path-only
some-system-path->string
string->some-system-path)
(define (simple-form-path p)
(unless (path-string? p)
@ -113,18 +115,19 @@
(let loop ([path orig-path][rest '()])
(let-values ([(base name dir?) (split-path path)])
(when simple?
(when (or (and base (not (path? base)))
(not (path? name)))
(when (or (and base (not (path-for-some-system? base)))
(not (path-for-some-system? name)))
(raise-type-error who
"path in simple form (absolute, complete, and with no same- or up-directory indicators)"
"path (for ay platform) in simple form (absolute, complete, and with no same- or up-directory indicators)"
orig-path)))
(if (path? base)
(if (path-for-some-system? base)
(loop base (cons name rest))
(cons name rest)))))
(define (explode-path orig-path)
(unless (path-string? orig-path)
(raise-type-error 'explode-path "path or string" orig-path))
(unless (or (path-string? orig-path)
(path-for-some-system? orig-path))
(raise-type-error 'explode-path "path (for any platform) or string" orig-path))
(do-explode-path 'explode-path orig-path #f))
;; Arguments must be in simple form
@ -143,20 +146,22 @@
filename)))
(define (file-name who name)
(unless (path-string? name)
(raise-type-error who "path or string" name))
(unless (or (path-string? name)
(path-for-some-system? name))
(raise-type-error who "path (for any platform) or string" name))
(let-values ([(base file dir?) (split-path name)])
(and (not dir?) (path? file) file)))
(and (not dir?) (path-for-some-system? file) file)))
(define (file-name-from-path name)
(file-name 'file-name-from-path name))
(define (path-only name)
(unless (path-string? name)
(raise-type-error 'path-only "path or string" name))
(unless (or (path-string? name)
(path-for-some-system? name))
(raise-type-error 'path-only "path (for any platform) or string" name))
(let-values ([(base file dir?) (split-path name)])
(cond [dir? name]
[(path? base) base]
(cond [dir? (if (string? name) (string->path name) name)]
[(path-for-some-system? base) base]
[else #f])))
;; name can be any string; we just look for a dot
@ -165,3 +170,18 @@
[name (and name (path->bytes name))])
(cond [(and name (regexp-match #rx#"[.]([^.]+)$" name)) => cadr]
[else #f])))
(define (some-system-path->string path)
(unless (path-for-some-system? path)
(raise-type-error 'some-system-path->string "path (for any platform)" path))
(bytes->string/utf-8 (path->bytes path)))
(define (string->some-system-path path kind)
(unless (string? path)
(raise-type-error 'string->some-system-path "string" path))
(unless (or (eq? kind 'unix)
(eq? kind 'windows))
(raise-type-error 'string->some-system-path "'unix or 'windows" kind))
(bytes->path (string->bytes/utf-8 path) kind))

9
collects/scheme/private/classidmap.ss
View File

@ -291,7 +291,14 @@
[else
(reverse (cons args accum))])))
(define-struct private-name (orig-id gen-id))
(define-struct private-name (orig-id gen-id)
#:property prop:procedure (lambda (self stx)
(if (not (eq? (syntax-local-context) 'expression))
#`(#%expression #,stx)
(raise-syntax-error
#f
"unbound local member name"
stx))))
(define (do-localize orig-id validate-local-member-stx)
(let loop ([id orig-id])

120
collects/scheme/private/contract.ss
View File

@ -51,7 +51,48 @@ improve method arity mismatch contract violation error messages?
#,(syntax-span id))
#,(format "~s" (syntax->datum id))))
(define-for-syntax (make-contracted-transformer contract-id id pos-module-source)
(make-set!-transformer
(let ([saved-id-table (make-hasheq)])
(λ (stx)
(if (eq? 'expression (syntax-local-context))
;; In an expression context:
(let ([key (syntax-local-lift-context)])
;; Already lifted in this lifting context?
(let ([lifted-id
(or (hash-ref saved-id-table key #f)
;; No: lift the contract creation:
(with-syntax ([contract-id contract-id]
[id id]
[neg-blame-id (or (syntax-parameter-value #'current-contract-region)
#'(#%variable-reference))]
[pos-module-source pos-module-source])
(syntax-local-introduce
(syntax-local-lift-expression
#`(-contract contract-id
id
pos-module-source
neg-blame-id
#,(id->contract-src-info #'id))))))])
(when key
(hash-set! saved-id-table key lifted-id))
;; Expand to a use of the lifted expression:
(with-syntax ([saved-id (syntax-local-introduce lifted-id)])
(syntax-case stx (set!)
[name
(identifier? (syntax name))
(syntax saved-id)]
[(set! id arg)
(raise-syntax-error 'provide/contract
"cannot set! a contracted variable"
stx
(syntax id))]
[(name . more)
(with-syntax ([app (datum->syntax stx '#%app)])
(syntax/loc stx (app saved-id . more)))]))))
;; In case of partial expansion for module-level and internal-defn contexts,
;; delay expansion until it's a good time to lift expressions:
(quasisyntax/loc stx (#%expression #,stx)))))))
;
;
@ -136,37 +177,6 @@ improve method arity mismatch contract violation error messages?
(define-syntax-parameter current-contract-region #f)
(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id)
(make-set!-transformer
(lambda (stx)
(with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region)
#'(#%variable-reference))]
[pos-blame-id pos-blame-id]
[contract-id contract-id]
[id id])
(syntax-case stx (set!)
[(set! id arg)
(raise-syntax-error 'with-contract
"cannot set! a with-contract variable"
stx
(syntax id))]
[(f arg ...)
(syntax/loc stx
((-contract contract-id
id
pos-blame-id
neg-blame-id
#'f)
arg ...))]
[ident
(identifier? (syntax ident))
(syntax/loc stx
(-contract contract-id
id
pos-blame-id
neg-blame-id
#'ident))])))))
(define-for-syntax (head-expand-all body-stxs)
(for/list ([stx body-stxs])
(local-expand stx
@ -265,7 +275,7 @@ improve method arity mismatch contract violation error messages?
(values unprotected-id ... protected-id ...))))
contract-def ...
(define-syntax protected-id
(make-with-contract-transformer
(make-contracted-transformer
(quote-syntax contract)
(quote-syntax id)
blame-str)) ...)))))]
@ -332,48 +342,6 @@ improve method arity mismatch contract violation error messages?
provide-stx
id)))))
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
(make-set!-transformer
(let ([saved-id-table (make-hasheq)])
(λ (stx)
(if (eq? 'expression (syntax-local-context))
;; In an expression context:
(let ([key (syntax-local-lift-context)])
;; Already lifted in this lifting context?
(let ([lifted-id
(or (hash-ref saved-id-table key #f)
;; No: lift the contract creation:
(with-syntax ([contract-id contract-id]
[id id]
[pos-module-source pos-module-source])
(syntax-local-introduce
(syntax-local-lift-expression
#`(-contract contract-id
id
pos-module-source
(#%variable-reference)
#,(id->contract-src-info #'id))))))])
(when key
(hash-set! saved-id-table key lifted-id))
;; Expand to a use of the lifted expression:
(with-syntax ([saved-id (syntax-local-introduce lifted-id)])
(syntax-case stx (set!)
[name
(identifier? (syntax name))
(syntax saved-id)]
[(set! id arg)
(raise-syntax-error 'provide/contract
"cannot set! a provide/contract variable"
stx
(syntax id))]
[(name . more)
(with-syntax ([app (datum->syntax stx '#%app)])
(syntax/loc stx (app saved-id . more)))]))))
;; In case of partial expansion for module-level and internal-defn contexts,
;; delay expansion until it's a good time to lift expressions:
(quasisyntax/loc stx (#%expression #,stx)))))))
;; (provide/contract p/c-ele ...)
;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...)
;; provides each `id' with the contract `expr'.
@ -861,7 +829,7 @@ improve method arity mismatch contract violation error messages?
(list)
(list #'(define contract-id (verify-contract 'provide/contract ctrct))))
(define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id)
(make-contracted-transformer (quote-syntax contract-id)
(quote-syntax id)
(quote-syntax pos-module-source)))

49
collects/scribble/base-render.ss
View File

@ -405,18 +405,41 @@
;; ----------------------------------------
(define copied-srcs (make-hash))
(define copied-dests (make-hash))
(define/public (install-file fn)
(if refer-to-existing-files
(if (string? fn)
(string->path fn)
fn)
(let ([normalized (normal-case-path (simplify-path (path->complete-path fn)))])
(or (hash-ref copied-srcs normalized #f)
(let ([src-dir (path-only fn)]
[dest-dir (get-dest-directory #t)]
[fn (file-name-from-path fn)])
(let ([src-file (build-path (or src-dir (current-directory)) fn)]
[dest-file (build-path (or dest-dir (current-directory)) fn)])
(unless (and (file-exists? dest-file)
(call-with-input-file*
[dest-file (build-path (or dest-dir (current-directory)) fn)]
[next-file-name (lambda (dest)
(let-values ([(base name dir?) (split-path dest)])
(build-path
base
(let ([s (path-element->string (path-replace-suffix name #""))])
(let ([n (regexp-match #rx"^(.*)_([0-9]+)$" s)])
(format "~a_~a~a"
(if n (cadr n) s)
(if n (add1 (string->number (caddr n))) 2)
(let ([ext (filename-extension name)])
(if ext
(bytes-append #"." ext)
""))))))))])
(let-values ([(dest-file normalized-dest-file)
(let loop ([dest-file dest-file])
(let ([normalized-dest-file
(normal-case-path (simplify-path (path->complete-path dest-file)))])
(if (file-exists? dest-file)
(cond
[(call-with-input-file*
src-file
(lambda (src)
(call-with-input-file*
@ -428,10 +451,24 @@
(let ([s (read-bytes 4096 src)]
[d (read-bytes 4096 dest)])
(and (equal? s d)
(or (eof-object? s) (loop)))))))))))
(when (file-exists? dest-file) (delete-file dest-file))
(or (eof-object? s) (loop))))))))))
;; same content at that destination
(values dest-file normalized-dest-file)]
[(hash-ref copied-dests normalized-dest-file #f)
;; need a different file
(loop (next-file-name dest-file))]
[else
;; replace the file
(delete-file dest-file)
(values dest-file normalized-dest-file)])
;; new file
(values dest-file normalized-dest-file))))])
(unless (file-exists? dest-file)
(copy-file src-file dest-file))
(path->string fn)))))
(hash-set! copied-dests normalized-dest-file #t)
(let ([result (path->string (file-name-from-path dest-file))])
(hash-set! copied-srcs normalized result)
result))))))))
;; ----------------------------------------

3
collects/scribblings/gui/area-container-intf.scrbl
View File

@ -71,7 +71,8 @@ Gets or sets the border margin for the container in pixels. This
}
@defmethod[(change-children [filter ((listof (is-a?/c subarea<%>)) . -> . (listof (is-a?/c subarea<%>)))])
@defmethod[(change-children [filter ((listof (is-a?/c subarea<%>))
. -> . (listof (is-a?/c subarea<%>)))])
void?]{
Takes a filter procedure and changes the container's list of

8
collects/scribblings/gui/color-class.scrbl
View File

@ -13,14 +13,16 @@ See @scheme[color-database<%>] for information about obtaining a color
object using a color name.
@defconstructor*/make[(([red (integer-in 0 255)]
@defconstructor*/make[(()
([red (integer-in 0 255)]
[green (integer-in 0 255)]
[blue (integer-in 0 255)])
([color-name string?]))]{
Creates a new color with the given RGB values, or matching the given
color name (using ``black'' if the name is not recognized). See
@scheme[color-database<%>] for more information on color names.
color name (using ``black'' if no color is given or if the name is
not recognized). See @scheme[color-database<%>] for more information
on color names.
}

6
collects/scribblings/gui/win-overview.scrbl
View File

@ -355,8 +355,10 @@ with the following program:
[alignment '(center center)]))
(code:comment #, @t{Add @onscreen{Cancel} and @onscreen{Ok} buttons to the horizontal panel})
(new button% [parent parent] [label "Cancel"])
(new button% [parent parent] [label "Ok"])
(new button% [parent panel] [label "Cancel"])
(new button% [parent panel] [label "Ok"])
(when (system-position-ok-before-cancel?)
(send panel #,(:: area-container<%> change-children) reverse))
(code:comment #, @t{Show the dialog})
(send dialog #,(:: dialog% show) #t)

48
collects/scribblings/reference/paths.scrbl
View File

@ -65,7 +65,9 @@ Beware that the current locale might not encode every string, in which
case @scheme[string->path] can produce the same path for different
@scheme[str]s. See also @scheme[string->path-element], which should be
used instead of @scheme[string->path] when a string represents a
single path element.}
single path element.
See also @scheme[string->some-system-path].}
@defproc[(bytes->path [bstr bytes?]
[type (or/c 'unix 'windows) (system-path-convention-type)])
@ -97,7 +99,9 @@ Furthermore, for display and sorting based on individual path elements
(such as pathless file names), use @scheme[path-element->string],
instead, to avoid special encodings use to represent some relative
paths. See @secref["windowspaths"] for specific information about
the conversion of Windows paths.}
the conversion of Windows paths.
See also @scheme[some-system-path->string].}
@defproc[(path->bytes [path path?]) bytes?]{
@ -494,21 +498,22 @@ to the end.}
@note-lib[scheme/path]
@defproc[(explode-path [path path-string?])
(listof (or/c path? 'up 'same))]{
@defproc[(explode-path [path (or/c path-string? path-for-some-system?)])
(listof (or/c path-for-some-system? 'up 'same))]{
Returns the list of path element that constitute @scheme[path]. If
@scheme[path] is simplified in the sense of @scheme[simple-form-path],
then the result is always a list of paths, and the first element of
the list is a root.}
@defproc[(file-name-from-path [path path-string?]) (or/c path? #f)]{
@defproc[(file-name-from-path [path (or/c path-string? path-for-some-system?)])
(or/c path-for-some-system? #f)]{
Returns the last element of @scheme[path]. If @scheme[path]
syntactically a directory path (see @scheme[split-path]), then then
result is @scheme[#f].}
@defproc[(filename-extension [path path-string?])
@defproc[(filename-extension [path (or/c path-string? path-for-some-system?)])
(or/c bytes? #f)]{
Returns a byte string that is the extension part of the filename in
@ -516,7 +521,9 @@ Returns a byte string that is the extension part of the filename in
syntactically a directory (see @scheme[split-path]) or if the path has
no extension, @scheme[#f] is returned.}
@defproc[(find-relative-path [base path-string?][path path-string?]) path?]{
@defproc[(find-relative-path [base (or/c path-string? path-for-some-system?)]
[path (or/c path-string? path-for-some-system?)])
path-for-some-system?]{
Finds a relative pathname with respect to @scheme[basepath] that names
the same file or directory as @scheme[path]. Both @scheme[basepath]
@ -544,10 +551,12 @@ An error is signaled by @scheme[normalize-path] if the input
path contains an embedded path for a non-existent directory,
or if an infinite cycle of soft links is detected.}
@defproc[(path-only [path path-string?]) (or/c path? #f)]{
@defproc[(path-only [path (or/c path-string? path-for-some-system?)])
path-for-some-system?]{
If @scheme[path] is a filename, the file's path is returned. If
@scheme[path] is syntactically a directory, @scheme[#f] is returned.}
@scheme[path] is syntactically a directory, @scheme[path] is returned
(as a path, if it was a string).}
@defproc[(simple-form-path [path path-string?]) path?]{
@ -555,6 +564,27 @@ Returns @scheme[(simplify-path (path->complete-path path))], which
ensures that the result is a complete path containing no up- or
same-directory indicators.}
@defproc[(some-system-path->string [path path-for-some-system?])
string?]{
Converts @scheme[path] to a string using a UTF-8 encoding of the
path's bytes.
Use this function when working with paths for a different system
(whose encoding of pathnames might be unrelated to the current
locale's encoding) and when starting and ending with strings.}
@defproc[(string->some-system-path [str string?]
[kind (or/c 'unix 'windows)])
path-for-some-system?]{
Converts @scheme[str] to a @scheme[kind] path using a UTF-8 encoding
of the path's bytes.
Use this function when working with paths for a different system
(whose encoding of pathnames might be unrelated to the current
locale's encoding) and when starting and ending with strings.}
@;------------------------------------------------------------------------
@include-section["unix-paths.scrbl"]
@include-section["windows-paths.scrbl"]

18
collects/scribblings/reference/stx-trans.scrbl
View File

@ -340,6 +340,24 @@ eventually expanded in an expression context.
@transform-time[]}
@defproc[(syntax-local-lift-require [quoted-raw-require-spec any/c][stx syntax?])
syntax?]{
Lifts a @scheme[#%require] form corresponding to
@scheme[quoted-raw-require-spec] to the top-level or to the top of the
module currently being expanded, wrapping it with @scheme[for-meta] if
the current expansion context is not @tech{phase level} 0.
The resulting syntax object is the same as @scheme[stx], except that a
fresh @tech{syntax mark} is added. The same @tech{syntax mark} is
added to the lifted @scheme[#%require] form, so that the
@scheme[#%require] form can bind uses of imported identifiers in the
resulting syntax object (assuming that the lexical information of
@scheme[stx] includes the binding environment into which the
@scheme[#%require] is lifted).
@transform-time[]}
@defproc[(syntax-local-name) (or/c symbol? #f)]{
Returns an inferred name for the expression position being

2
collects/scribblings/reference/syntax.scrbl
View File

@ -606,7 +606,7 @@ export name, though the same binding can be specified with the
multiple symbolic names.}
@defform[(for-meta require-spec ...)]{See @scheme[require] and @scheme[provide].}
@defform[(for-meta phase-level require-spec ...)]{See @scheme[require] and @scheme[provide].}
@defform[(for-syntax require-spec ...)]{See @scheme[require] and @scheme[provide].}
@defform[(for-template require-spec ...)]{See @scheme[require] and @scheme[provide].}
@defform[(for-label require-spec ...)]{See @scheme[require] and @scheme[provide].}

2
collects/sirmail/readr.ss
View File

@ -1018,7 +1018,7 @@
(lambda (w e)
(purge-marked/update-headers)))
(send global-keymap add-function "gc"
(lambda (w e) (collect-garbage) (collect-garbage)))
(lambda (w e) (collect-garbage) (collect-garbage) (dump-memory-stats)))
(send global-keymap add-function "show-memory-graph"
(lambda (w e) (show-memory-graph)))

181
collects/teachpack/2htdp/scribblings/server2.ss
View File

@ -1,181 +0,0 @@
#lang slideshow
(require slideshow/pict)
(define DELTA 80)
(define FT 12)
(define initialize "register")
(define proc-msg "process")
(define program
(apply vl-append (map (lambda (t) (text t '() (- FT 2)))
(list (format "(universe ~a ~a)" initialize proc-msg)))))
(define Program
(cc-superimpose
(rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program)))
program))
;; String Boolean -> Pict
(define (make-state0 txt b)
;; create the basic state
(define t (text txt '() FT))
(cc-superimpose t (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))))
(define (add-labeled-arrow nx locked lb-find closed lt-find txt)
(define-values (x0 y0) (lb-find nx locked))
(define-values (x1 y1) (lt-find nx closed))
(define lbl (text txt '() (- FT 2)))
(define wlbl (pict-width lbl))
(define hlbl (pict-height lbl))
(define x (- x0 (/ wlbl 2)))
(define y (+ y0 (/ ( - y1 y0 hlbl) 2)))
(pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl))
(define (h-labeled-arrow t)
(define tock (text t '() (- FT 2)))
(define blk (blank (+ DELTA 4) 2))
(vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find)))
(define message (text "Message" '() FT))
(define (make-Message)
(cc-superimpose message (rectangle (+ 20 (pict-width message)) (+ 30 (pict-height message)))))
(define Message (vc-append (make-Message) (arrowhead 4 (* 1/2 pi))))
(define MessageK (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message)))
(define MessageI (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message)))
(define M (rb-superimpose Message (blank DELTA DELTA)))
(define K (rb-superimpose MessageK (blank DELTA DELTA)))
(define I (rb-superimpose MessageI (blank DELTA DELTA)))
(define (make-arrows M lbl)
(define Tock (h-labeled-arrow lbl))
(values Tock (vc-append (blank DELTA (/ DELTA 2)) Tock M)))
(define-values (TockM arrowsR) (make-arrows M proc-msg))
(define-values (TockK arrowsL) (make-arrows K proc-msg))
(define-values (init arrows) (make-arrows I initialize))
(define state0 (make-state0 "Server_0" #f))
(define state2 (make-state0 "Server_N-1" #f))
(define Univrs (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "Universe" '() FT ))))
(define dots (vc-append
(blank (pict-width state2) (quotient (pict-height state2) 1))
(text "..." '() FT)
(blank (pict-width state2) (* (pict-height state2)))
Univrs))
(define states (list arrows
state0
arrowsL
dots
arrowsR
state2
(h-labeled-arrow proc-msg)))
(define bg (blank (+ (apply + (map pict-width states)) DELTA) (pict-height dots)))
(define (center base state x)
(define w (pict-height state))
(define d (quotient (- (pict-height bg) w) 2))
(pin-over base x d state))
(define x (* 1/2 DELTA))
(define xx
(foldl (lambda (f ls s)
(define y (center s f x))
(set! x (+ x ls))
y)
bg
states
(map pict-width states)))
(define zz (ct-superimpose xx Program))
(require mred/mred)
(define the-image
(lt-superimpose
(dc (lambda (dc x y)
(define-values (mx my) (cb-find zz MessageK))
(define-values (tx ty) (ct-find zz MessageK))
(define-values (ix iy) (ct-find zz MessageI))
(define-values (jx jy) (cb-find zz MessageI))
(define-values (sx sy) (lc-find zz Univrs))
(define-values (tockx tocky) (lb-find zz TockK))
(define-values (initx inity) (lb-find zz init))
(define (add-curve rx ry)
(set! dcp (make-object dc-path%))
(set! cx (max rx tx))
(set! cy (min ry ty))
(send dcp move-to tx ty)
(send dcp curve-to tx ty cx cy rx ry)
(send dc draw-path dcp))
(define dcp (make-object dc-path%))
;; --- draw arc from Message to Server
(define cx (min sx mx))
(define cy (max sy my))
(send dc set-smoothing 'aligned)
(send dcp move-to mx my)
(send dcp curve-to mx my cx cy sx sy)
(send dc draw-path dcp)
(set! dcp (make-object dc-path%))
(set! cx (min sx jx))
(set! cy (max sy jy))
(send dc set-smoothing 'aligned)
(send dcp move-to jx jy)
(send dcp curve-to jx jy cx cy sx sy)
(send dc draw-path dcp)
;; --- draw arc from Message to Receiver
(add-curve tockx tocky)
(set! tx ix) (set! ty iy)
(add-curve initx inity)
;; ---
dc)
(pict-width zz) (pict-height zz))
(lt-superimpose
zz
(dc (lambda (dc x y)
(define-values (mx my) (cb-find zz Message))
(define-values (tx ty) (ct-find zz Message))
(define-values (sx sy) (rc-find zz Univrs))
(define-values (tockx tocky) (rb-find zz TockM))
(define (add-curve rx ry)
(set! dcp (make-object dc-path%))
(set! cx (min rx tx))
(set! cy (min ry ty))
(send dcp move-to tx ty)
(send dcp curve-to tx ty cx cy rx ry)
(send dc draw-path dcp))
(define dcp (make-object dc-path%))
;; --- draw arc from Message to Server
(define cx (max sx mx))
(define cy (max sy my))
(send dc set-smoothing 'aligned)
(send dcp move-to mx my)
(send dcp curve-to mx my cx cy sx sy)
(send dc draw-path dcp)
;; --- draw arc from Message to Receiver
(add-curve tockx tocky)
;; ---
dc)
(pict-width zz) (pict-height zz)))))
(define image-bm
(make-object bitmap%
(inexact->exact (round (pict-width the-image)))
(inexact->exact (round (pict-height the-image)))))
(send image-bm ok?)
(define image-dc
(new bitmap-dc% [bitmap image-bm]))
(send image-dc clear)
(draw-pict the-image image-dc 0.0 0.0)
(send image-bm save-file "server2.png" 'png)
the-image

386
collects/teachpack/2htdp/scribblings/universe.scrbl
View File

@ -32,9 +32,9 @@
This @tt{universe.ss} teachpack implements and provides the functionality
for creating interactive, graphical programs that consist of plain
mathematical functions. We refer to such programs as @defterm{world}
mathematical functions. We refer to such programs as @deftech{world}
programs. In addition, world programs can also become a part of a
@defterm{universe}, a collection of worlds that can exchange messages.
@deftech{universe}, a collection of worlds that can exchange messages.
The purpose of this documentation is to give experienced Schemers and HtDP
teachers a concise overview for using the library. The first part of the
@ -42,7 +42,7 @@ The purpose of this documentation is to give experienced Schemers and HtDP
presents an illustration of how to design such programs for a simple
domain; it is suited for a novice who knows how to design conditional
functions for symbols. The second half of the documentation focuses on
@tech{universe} programs: how it is managed via a server, how @tech{world}
"universe" programs: how it is managed via a server, how @tech{world}
programs register with the server, etc. The last two sections show how to
design a simple universe of two communicating worlds.
@ -138,17 +138,17 @@ The following picture provides an intuitive overview of the workings of a
@image["nuworld.png"]
The @scheme[big-bang] form installs @scheme[World_0] as the initial
world. The handlers @scheme[tock], @scheme[react], and @scheme[click] transform
The @scheme[big-bang] form installs @scheme[World_0] as the initial @tech{WorldState}.
The handlers @scheme[tock], @scheme[react], and @scheme[click] transform
one world into another one; each time an event is handled, @scheme[done] is
used to check whether the world is final, in which case the program is
shut down; and finally, @scheme[draw] renders each world as a scene, which
is then displayed on an external canvas.
@deftech{World} : @scheme[any/c]
@deftech{WorldState} : @scheme[any/c]
The design of a world program demands that you come up with a data
definition of all possible states. We use @tech{World} to refer to
definition of all possible states. We use @tech{WorldState} to refer to
this collection of data, using a capital W to distinguish it from the
program. In principle, there are no constraints on this data
definition though it mustn't be an instance of the @tech{Package}
@ -176,7 +176,7 @@ The design of a world program demands that you come up with a data
starts a @tech{world} program in the initial state specified with
@scheme[state-expr], which must of course evaluate to an element of
@tech{World}. Its behavior is specified via the handler functions
@tech{WorldState}. Its behavior is specified via the handler functions
designated in the optional @scheme[spec] clauses, especially how the
@tech{world} program deals with clock ticks, with key events, with mouse
events, and eventually with messages from the universe; how it renders
@ -190,7 +190,7 @@ The design of a world program demands that you come up with a data
@item{
@defform[(on-tick tick-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))])]{
([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))])]{
tell DrScheme to call the @scheme[tick-expr] function on the current
world every time the clock ticks. The result of the call becomes the
@ -199,7 +199,7 @@ current world. The clock ticks at the rate of 28 times per second.}}
@item{
@defform/none[(on-tick tick-expr rate-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))]
([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))]
[rate-expr natural-number/c])]{
tell DrScheme to call the @scheme[tick-expr] function on the current
world every time the clock ticks. The result of the call becomes the
@ -234,7 +234,7 @@ A character is used to signal that the user has hit an alphanumeric
@defform[(on-key change-expr)
#:contracts
([change-expr (-> (unsyntax @tech{World}) key-event? (unsyntax @tech{World}))])]{
([change-expr (-> (unsyntax @tech{WorldState}) key-event? (unsyntax @tech{WorldState}))])]{
tell DrScheme to call @scheme[change-expr] function on the current world and a
@tech{KeyEvent} for every keystroke the user of the computer makes. The result
of the call becomes the current world.
@ -288,7 +288,7 @@ All @tech{MouseEvent}s are represented via symbols:
@defform[(on-mouse clack-expr)
#:contracts
([clack-expr
(-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) (unsyntax @tech{World}))])]{
(-> (unsyntax @tech{WorldState}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) (unsyntax @tech{WorldState}))])]{
tell DrScheme to call @scheme[clack-expr] on the current world, the current
@scheme[x] and @scheme[y] coordinates of the mouse, and and a
@tech{MouseEvent} for every (noticeable) action of the mouse by the
@ -303,7 +303,7 @@ All @tech{MouseEvent}s are represented via symbols:
@defform[(on-draw render-expr)
#:contracts
([render-expr (-> (unsyntax @tech{World}) scene?)])]{
([render-expr (-> (unsyntax @tech{WorldState}) scene?)])]{
tell DrScheme to call the function @scheme[render-expr] whenever the
canvas must be drawn. The external canvas is usually re-drawn after DrScheme has
@ -312,7 +312,7 @@ All @tech{MouseEvent}s are represented via symbols:
@defform/none[(on-draw render-expr width-expr height-expr)
#:contracts
([render-expr (-> (unsyntax @tech{World}) scene?)]
([render-expr (-> (unsyntax @tech{WorldState}) scene?)]
[width-expr natural-number/c]
[height-expr natural-number/c])]{
@ -325,7 +325,7 @@ All @tech{MouseEvent}s are represented via symbols:
@defform[(stop-when last-world?)
#:contracts
([last-world? (-> (unsyntax @tech{World}) boolean?)])]{
([last-world? (-> (unsyntax @tech{WorldState}) boolean?)])]{
tell DrScheme to call the @scheme[last-world?] function whenever the canvas is
drawn. If this call produces @scheme[true], the world program is shut
down. Specifically, the clock is stopped; no more
@ -436,7 +436,8 @@ it to the locked position; and}
Simulating any dynamic behavior via a @tech{world} program demands two
different activities. First, we must tease out those portions of our
domain that change over time or in reaction to actions, and we must
develop a data representation @deftech{D} for this information. Keep in
develop a data representation for this information. This is what we call
@tech{WorldState}. Keep in
mind that a good data definition makes it easy for readers to map data to
information in the real world and vice versa. For all others aspects of
the world, we use global constants, including graphical or visual
@ -447,7 +448,7 @@ Second, we must translate the actions in our domain---the arrows in the
teachpack can deal with. Once we have decided to use the passing of time
for one aspect, key presses for another, and mouse movements for a third,
we must develop functions that map the current state of the
world---represented as data from @tech{D}---into the next state of the
world---represented as data from @tech{WorldState}---into the next state of the
world. Put differently, we have just created a wish list with three
handler functions that have the following general contract and purpose
statements:
@ -455,16 +456,16 @@ Second, we must translate the actions in our domain---the arrows in the
@(begin
#reader scribble/comment-reader
(schemeblock
;; tick : @tech{D} -> @tech{D}
;; tick : WorldState -> WorldState
;; deal with the passing of time
(define (tick w) ...)
;; click : @tech{D} @emph{Number} @emph{Number} @tech{MouseEvent} -> @tech{D}
;; click : WorldState @emph{Number} @emph{Number} @tech{MouseEvent} -> WorldState
;; deal with a mouse click at @emph{(x,y)} of kind @emph{me}
;; in the current world @emph{w}
(define (click w x y me) ...)
;; control : @tech{D} @tech{KeyEvent} -> @tech{D}
;; control : WorldState @tech{KeyEvent} -> WorldState
;; deal with a key event (symbol, char) @emph{ke}
;; in the current world @emph{w}
(define (control w ke) ...)
@ -487,15 +488,14 @@ Our first and immediate goal is to represent the world as data. In this
the door is whether it is locked, unlocked but closed, or open. We use
three symbols to represent the three states:
@deftech{SD} : state of door
@(begin
#reader scribble/comment-reader
(schemeblock
;; The state of the door (SD) is one of:
;; WorldState is one of:
;; -- @scheme['locked]
;; -- @scheme['closed]
;; -- @scheme['open]
;; interpretation: state of door
))
Symbols are particularly well-suited here because they directly express
@ -535,14 +535,14 @@ a visible scene.}
]
Let's start with @emph{automatic-closer}. Substituting @tech{SD} for
@tech{D} and @emph{automatic-closer} for @emph{tick}, we get its contract,
Let's start with @emph{automatic-closer}. Since @emph{automatic-closer}
acts as the @scheme[on-tick] handler, we get its contract,
and it is easy to refine the purpose statement, too:
@(begin
#reader scribble/comment-reader
(schemeblock
;; automatic-closer : @tech{SD} -> @tech{SD}
;; automatic-closer : WorldState -> WorldState
;; closes an open door over the period of one tick
(define (automatic-closer state-of-door) ...)
))
@ -560,7 +560,7 @@ and it is easy to refine the purpose statement, too:
@(begin
#reader scribble/comment-reader
(schemeblock
;; automatic-closer : @tech{SD} -> @tech{SD}
;; automatic-closer : WorldState -> WorldState
;; closes an open door over the period of one tick
(check-expect (automatic-closer 'locked) 'locked)
@ -604,7 +604,7 @@ For the remaining three arrows of the diagram, we design a function that
@(begin
#reader scribble/comment-reader
(schemeblock
;; door-actions : @tech{SD} @tech{KeyEvent} -> @tech{SD}
;; door-actions : WorldState @tech{KeyEvent} -> WorldState
;; key events simulate actions on the door
(define (door-actions s k) ...)
))
@ -644,7 +644,7 @@ purpose:
@(begin
#reader scribble/comment-reader
(schemeblock
;; render : @tech{SD} -> @tech{scene}
;; render : WorldState -> @tech{scene}
;; translate the current state of the door into a large text
(define (render s)
(text (symbol->string s) 40 'red))
@ -719,9 +719,9 @@ Note the last clause includes @scheme[empty] of course.
Each world-producing callback in a world program---those for handling clock
tick events, keyboard events, and mouse events---may produce a
@tech{Package} in addition to just a @tech{World}.
@tech{Package} in addition to just a @tech{WorldState}.
@deftech{Package} represents a pair consisting of a @tech{World} (state)
@deftech{Package} represents a pair consisting of a @tech{WorldState}
and a message from a @tech{world} program to the @tech{server}. Because
programs only send messages via @tech{Package}, the teachpack does not
provide the selectors for the structure, only the constructor and a
@ -731,38 +731,38 @@ Each world-producing callback in a world program---those for handling clock
determine whether @scheme[x] is a @tech{Package}.}
@defproc[(make-package [w any/c][m sexp?]) package?]{
create a @tech{Package} from a @tech{World} and an @tech{S-expression}.}
create a @tech{Package} from a @tech{WorldState} and an @tech{S-expression}.}
As mentioned, all event handlers may return @tech{World}s or @tech{Package}s;
As mentioned, all event handlers may return @tech{WorldState}s or @tech{Package}s;
here are the revised specifications:
@defform/none[(on-tick tick-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{
([tick-expr (-> (unsyntax @tech{WorldState}) (or/c (unsyntax @tech{WorldState}) package?))])]{
}
@defform/none[(on-tick tick-expr rate-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))]
([tick-expr (-> (unsyntax @tech{WorldState}) (or/c (unsyntax @tech{WorldState}) package?))]
[rate-expr natural-number/c])]{
}
@defform/none[(on-key change-expr)
#:contracts
([change-expr (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{
([change-expr (-> (unsyntax @tech{WorldState}) key-event? (or/c (unsyntax @tech{WorldState}) package?))])]{
}
@defform/none[(on-mouse clack-expr)
#:contracts
([clack-expr
(-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent})
(or/c (unsyntax @tech{World}) package?))])]{
(-> (unsyntax @tech{WorldState}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent})
(or/c (unsyntax @tech{WorldState}) package?))])]{
}
If one of these event handlers produces a @tech{Package}, the content of the world
field becomes the next world and the message field specifies what the
world sends to the universe. This distinction also explains why the data
definition for @tech{World} may not include a @tech{Package}.
definition for @tech{WorldState} may not include a @tech{Package}.
@subsection{Connecting with the Universe}
@ -823,28 +823,28 @@ The @scheme[on-receive] clause of a @scheme[big-bang] specifies the event handle
@defform[(on-receive receive-expr)
#:contracts
([receive-expr (-> (unsyntax @tech{World}) sexp? (or/c (unsyntax @tech{World}) package?))])]{
([receive-expr (-> (unsyntax @tech{WorldState}) sexp? (or/c (unsyntax @tech{WorldState}) package?))])]{
tell DrScheme to call @scheme[receive-expr] for every message receipt, on the current
@tech{World} and the received message. The result of the call becomes the current
@tech{World}.
@tech{WorldState} and the received message. The result of the call becomes the current
@tech{WorldState}.
Because @scheme[receive-expr] is (or evaluates to) a world-transforming
function, it too can produce a @tech{Package} instead of just a
@tech{World}. If the result is a @tech{Package}, its message content is
@tech{WorldState}. If the result is a @tech{Package}, its message content is
sent to the @tech{server}.}
The diagram below summarizes the extensions of this section in graphical form.
@image["universe.png"]
@image["world.png"]
A registered world program may send a message to the universe server
at any time by returning a @tech{Package} from an event handler. The
message is transmitted to the server, which may forward it to some
other world program as given or in some massaged form. The arrival of a
message is just another event that a world program must deal with. Like
all other event handlers @emph{receive} accepts a @tech{World} and some
all other event handlers @emph{receive} accepts a @tech{WorldState} and some
auxiliary arguments (a message in this case) and produces a
@tech{World} or a @tech{Package}.
@tech{WorldState} or a @tech{Package}.
When messages are sent from any of the worlds to the universe or vice versa,
there is no need for the sender and receiver to synchronize. Indeed, a sender
@ -853,16 +853,15 @@ When messages are sent from any of the worlds to the universe or vice versa,
the receiving @tech{server} or @tech{world} program take care of them.
@; -----------------------------------------------------------------------------
@section[#:tag "universe-server"]{The Universe Server}
A @deftech{server} is the central control program of a @tech{universe} and
deals with receiving and sending of messages between the world
programs that participate in the @tech{universe}. Like a @tech{world}
program, a server is a program that reacts to events, though to different
events. There are two primary kinds of events: when a new @tech{world}
program joins the @tech{universe} that the server controls and when a
@tech{world} sends a message.
events than @tech{world}s. The two primary kinds of events are the
appearance of a new @tech{world} program in the @tech{universe}
and the receipt of a message from a @tech{world} program.
The teachpack provides a mechanism for designating event handlers for
servers that is quite similar to the mechanism for describing @tech{world}
@ -897,8 +896,9 @@ This section first introduces some basic forms of data that the
@; -----------------------------------------------------------------------------
@subsection{Worlds and Messages}
Understanding the server's event handling functions demands three
concepts.
Understanding the server's event handling functions demands several data
representations: that of (a connection to) a @tech{world} program and that
of a response of a handler to an event.
@itemize[
@ -915,6 +915,9 @@ Understanding the server's event handling functions demands three
@defproc[(world=? [u world?][v world?]) boolean?]{
compares two @emph{world}s for equality.}
@defproc[(world-name [w world?]) symbol?]{
extracts the name from a @emph{world} structure.}
@defthing[world1 world?]{a world for testing your programs}
@defthing[world2 world?]{another world for testing your programs}
@defthing[world3 world?]{and a third one}
@ -928,9 +931,20 @@ for universe programs. For example:
]
}
@item{A @emph{mail} represents a message from an event handler to a
world. The teachpack provides only a predicate and a constructor for these
structures:
@item{Each event handler produces a @emph{bundle}, which is a structure
that contains the list of @emph{world}s to keep track of; the
@tech{server}'s remaining state; and a list of mails to other
worlds:
@defproc[(bundle? [x any/c]) boolean?]{
determines whether @scheme[x] is a @emph{bundle}.}
@defproc[(make-bundle [low (listof world?)] [state any/c] [mails (listof mail?)]) bundle?]{
creates a @emph{bundle} from a list of worlds, a piece of data that represents a server
state, and a list of mails.}
A @emph{mail} represents a message from an event handler to a world. The
teachpack provides only a predicate and a constructor for these structures:
@defproc[(mail? [x any/c]) boolean?]{
determines whether @scheme[x] is a @emph{mail}.}
@ -939,33 +953,22 @@ structures:
creates a @emph{mail} from a @emph{world} and an @tech{S-expression}.}
}
@item{Each event handler produces a @emph{bundle}, which is a structure
that contains the @tech{server}'s state and a list of mails to other
worlds. Again, the teachpack provides only the predicate and a constructor:
@defproc[(bundle? [x any/c]) boolean?]{
determines whether @scheme[x] is a @emph{bundle}.}
@defproc[(make-bundle [state any/c] [mails (listof mail?)]) bundle?]{
creates a @emph{bundle} from a piece of data that represents a server
state and a list of mails.}
}
]
@; -----------------------------------------------------------------------------
@subsection{Universe Descriptions}
A @tech{server} keeps track of information about the @tech{universe} that
it manages. Of course, what kind of information it tracks and how it is
represented depends on the situation and the programmer, just as with
@tech{world} programs.
it manages. One kind of tracked information is obviously the collection of
participating world programs, but in general the kind of information that
a server tracks and how the information is represented depends on the
situation and the programmer, just as with @tech{world} programs.
@deftech{Universe} @scheme[any/c] represent the server's state For running
@deftech{UniverseState} @scheme[any/c] represents the server's state For running
@tech{universe}s, the teachpack demands that you come up with a data
definition for (your state of the) @tech{server}. Any piece of data can
represent the state. We just assume that you introduce a data definition
for the possible states and that your transformation functions are designed
for the possible states and that your event handlers are designed
according to the design recipe for this data definition.
The @tech{server} itself is created with a description that includes the
@ -993,7 +996,7 @@ registration of new worlds, how it disconnects worlds, how it sends
messages from one world to the rest of the registered worlds, and how it
renders its current state as a string.}
A @scheme[universe] expression starts a server. Visually it opens
Evaluating a @scheme[universe] expression starts a server. Visually it opens
a console window on which you can see that worlds join, which messages are
received from which world, and which messages are sent to which world. For
convenience, the console also has two buttons: one for shutting down a
@ -1001,35 +1004,48 @@ A @scheme[universe] expression starts a server. Visually it opens
especially useful during the integration of the various pieces of a
distributed program.
Now it is possible to explain the clauses in a @scheme[universe] server
description. Two of them are mandatory:
The mandatory clauses of a @scheme[universe] server description are
@scheme[on-new] and @scheme[on-msg]:
@itemize[
@item{
@defform[(on-new new-expr)
#:contracts
([new-expr (-> (unsyntax @tech{Universe}) world?
(cons (unsyntax @tech{Universe}) [listof mail?]))])]{
([new-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? bundle?)])]{
tell DrScheme to call the function @scheme[new-expr] every time another world joins the
universe.}}
universe. The event handler is called on the current list of worlds and the
joining world, which isn't on the list yet. In particular, the handler may
reject a @tech{world} program from participating in a @tech{universe},
simply by not including it in the resulting @scheme[bundle] structure. The
handler may still send one message to the world that attempts to join. }
}
@item{
@defform[(on-msg msg-expr)
#:contracts
([msg-expr (-> (unsyntax @tech{Universe}) world? sexp?
(cons (unsyntax @tech{Universe}) [listof mail?]))])]{
([msg-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? sexp? bundle?)])]{
tell DrScheme to apply @scheme[msg-expr] to the current state of the universe, the world
that sent the message, and the message itself. The handler must produce a state of the
universe and a list of mails.}
tell DrScheme to apply @scheme[msg-expr] to the list of currently
participating worlds @scheme[low], the current state of the universe, the world
@scheme[w] that sent the message, and the message itself. Note that
@scheme[w] is guaranteed to be on the list @scheme[low].
}
]
}]
All proper event handlers produce a @emph{bundle}. The list of worlds in
this @emph{bundle} becomes the server's list of worlds, meaning that only
the server listens only to messages from "approved" worlds. The state in
the bundle is safe-guarded by the server until the next event, and the
mails are broadcast as specified.
The following picture provides a graphical overview of the server's workings.
@image["server2.png"]
@; -----------------------------------------------------------------------------
@;; THE PICTURE IS WRONG
@; -----------------------------------------------------------------------------
@image["server.png"]
In addition to the mandatory handlers, a program may wish to add some
optional handlers:
@ -1039,36 +1055,37 @@ optional handlers:
@item{
@defform/none[(on-tick tick-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{
tell DrScheme to apply @scheme[tick-expr] to the current state of the
universe. The handler is expected to produce a bundle of the new state of
the universe and a list of mails.
([tick-expr (-> [listof world?] (unsyntax @tech{UniverseState}) bundle?)])]{
tell DrScheme to apply @scheme[tick-expr] to the current list of
participating worlds and the current state of the
universe.
}
@defform/none[(on-tick tick-expr rate-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{Universe}) bundle?)]
([tick-expr (-> [listof world?] (unsyntax @tech{UniverseState}) bundle?)]
[rate-expr natural-number/c])]{
tell DrScheme to apply @scheme[tick-expr] as above but use the specified
clock tick rate instead of the default.
}
}
@item{
@defform[(on-disconnect dis-expr)
#:contracts
([dis-expr (-> (unsyntax @tech{Universe}) world? bundle?)])]{
([dis-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? bundle?)])]{
tell DrScheme to invoke @scheme[dis-expr] every time a participating
@tech{world} drops its connection to the server. The first argument is the
current state of the universe; the second one is the world that got
disconnected.
@tech{world} drops its connection to the server. The first two arguments
are the current list of participating worlds and the state of the
universe; the third one is the world that got disconnected.
}
}
@item{
@defform[(to-string render-expr)
#:contracts
([render-expr (-> (unsyntax @tech{Universe}) string?)])]{
([render-expr (-> [listof world?] (unsyntax @tech{UniverseState}) string?)])]{
tell DrScheme to render the state of the universe after each event and to
display this string in the universe console.
}
@ -1110,19 +1127,26 @@ The first step in designing a @tech{universe} is to understand the
throughout a system. We know that the @tech{universe} doesn't exist until
the server starts and the @tech{world}s are joining. Because of the nature
of computers and networks, however, we may assume little else. Our network
connections ensure that if some @tech{world} sends two messages in some
order, they arrive in the same order at the server. In contrast, it is
generally impossible to ensure whether one world joins before another or
whether a message from one world gets to the server before another world's
message gets there. It is therefore the designer's task to establish a
protocol that enforces a certain order onto a universe and this activity
is called @emph{protocol design}.
connections ensure that if some @tech{world} or the @tech{server} sends
two messages to the @emph{same} place in some order, they arrive in the
same order (if they arrive at all). In contrast, if two distinct
@tech{world} programs send one message each, the network does not
guarantee the order of arrival at the server; similarly, if the
@tech{server} is asked to send some messages to several distinct
@tech{world} programs, they may arrive at those worlds in the order sent
or in the some other order. In the same vein, it is impossible to ensure
that one world joins before another. Worst, when someone removes the
connection (cable, wireless) between a computer that runs a @tech{world}
program and the rest of the network or if some network cable is cut,
messages don't go anywhere. Due to this vagaries, it is therefore the
designer's task to establish a protocol that enforces a certain order onto
a universe and this activity is called @emph{protocol design}.
From the perspective of the @tech{universe}, the design of a protocol is
about the design of data representations for tracking universe information
in the server and the participating worlds and the design of a data
representation for messages. As for the latter, we know that they must be
@tech{S-expression}s, but of course @tech{world} programs don't send all
@tech{S-expression}s, but usually @tech{world} programs don't send all
kinds of @tech{S-expression}s. The data definitions for messages must
therefore select a subset of suitable @tech{S-expression}s. As for the
state of the server and the worlds, they must reflect how they currently
@ -1134,14 +1158,14 @@ In summary, the first step of a protocol design is to introduce:
@itemize[
@item{a data definition for the information about the universe that the
server tracks, call it @tech{Universe};}
server tracks, call it @tech{UniverseState};}
@item{a data definition for the world(s) about their current relationship
to the universe;}
@item{data definitions for the messages that are sent from the server to
the worlds and vice versa. Let's call them @deftech{MsgS2W} for messages
from the server to the worlds and @deftech{MsgW2S} for the other direction;
the worlds and vice versa. Let's call them @deftech{S2W} for messages
from the server to the worlds and @deftech{W2S} for the other direction;
in the most general case you may need one pair per world.}
]
@ -1161,7 +1185,22 @@ The second step of a protocol design is to figure out which major
state of the world. A good tool for writing down these agreements is an
interaction diagram.
(interaction diagrams: tbd)
@verbatim{
Server World1 World2
| | |
| 'go | |
|<------------------| |
| 'go | |
|------------------------------------------>|
| | |
| | |
}
Each vertical line is the life line of a @tech{world} program or the
@tech{server}. Each horizontal arrow denotes a message sent from one
@tech{universe} participant to another.
The design of the protocol, especially the data definitions, have direct
implications for the design of event handling functions. For example, in
@ -1172,19 +1211,20 @@ translates into the design of two functions with the following headers,
@(begin
#reader scribble/comment-reader
(schemeblock
;; @tech{Universe} World -> (make-bundle @tech{Universe} [Listof mail?])
;; create new @tech{Universe} when world w is joining the universe,
;; which is in state s; also send mails as needed
;; Bundle is
;; (make-bundle [Listof world?] UniverseState [Listof mail?])
;; [Listof world?] UniverseState world? -> Bundle
;; compute next list of worlds and new @tech{UniverseState}
;; when world w is joining the universe, which is in state s;
(define (add-world s w) ...)
;; @tech{Universe} World MsgW2U -> (make-bundle @tech{Universe} [Listof mail?])
;; create new @tech{Universe} when world w is sending message m
;; to universe in state s; also send mails as needed
;; [Listof world?] UniverseState world? W2U -> Bundle
;; compute next list of worlds and new @tech{UniverseState}
;; when world w is sending message m to universe in state s
(define (process s p m) ...)
))
Note how both functions return a bundle.
Finally, we must also decide how the messages affect the states of the
worlds; which of their callback may send messages and when; and what to do
with the messages a world receives. Because this step is difficult to
@ -1204,10 +1244,14 @@ As for the server's state, it must obviously keep track of all @tech{world}s tha
are passive. Of course, initially the @tech{universe} is empty, i.e., there are
no @tech{world}s and, at that point, the server has nothing to track.
While there are many different useful ways of representing such a @tech{universe},
we choose to introduce @tech{Universe} as a list of @tech{world}s, and we
interpret non-empty lists as those where the first @tech{world} is active and the
remainder are the passive @tech{world}s. As for the two possible events,
While there are many different useful ways of representing such a
@tech{universe}, we just use the list of @emph{worlds} that is handed to
each handler and that handlers return via their bundles. The
@tech{UniverseState} itself is useless for this trivial example. We
interpret non-empty lists as those where the first @tech{world} is active
and the remainder are the passive @tech{world}s. As for the two possible
events,
@itemize[
@item{it is natural to add new @tech{world}s to the end of the list; and}
@ -1239,6 +1283,34 @@ for this part of a @tech{world}'s state until we design its ``local'' behavior.}
which it may ignore. When it is done with its turn, it will send a
message.
@verbatim{
Server
| World1
|<==================|
| 'it-is-your-turn |
|------------------>|
| | World2
|<==========================================|
| 'done | |
|<------------------| |
| 'it-is-your-turn | |
|------------------------------------------>|
| | |
| | |
| 'done | |
|<------------------------------------------|
| 'it-is-your-turn | |
|------------------>| |
| | |
| | |
}
Here the double-lines (horizontal) denote the registration step, the others
are message exchanges. The diagram thus shows how the @tech{server}
decides to make the first registered world the active one and to enlist
all others as they join.
@; -----------------------------------------------------------------------------
@subsection{Designing the Ball Server}
@ -1249,7 +1321,7 @@ The preceding subsection dictates that our server program starts like this:
[schemeblock
;; teachpack: universe.ss
;; Universe is [Listof world?]
;; UniverseState is '*
;; StopMessage is 'done.
;; GoMessage is 'it-is-your-turn.
])
@ -1264,24 +1336,23 @@ The preceding subsection dictates that our server program starts like this:
@(begin
#reader scribble/comment-reader
[schemeblock
;; Result is (make-bundle Universe (list (make-mail world? GoMessage)))
;; Result is
;; (make-bundle [Listof world?] '* (list (make-mail world? GoMessage)))
;; Universe world? -> Result
;; [Listof world?] UniverseState world? -> Result
;; add world w to the universe, when server is in state u
(define (add-world u w) ...)
;; Universe world? StopMessage -> Result
;; [Listof world?] UniverseState world? StopMessage -> Result
;; world w sent message m when server is in state u
(define (switch u w m) ...)
])
Although we could have re-used the generic contracts from this
documentation, we also know from our protocol that our server sends a
message to exactly one world. For this reason, both functions return the
same kind of result: a bundle that contains the new state of the server
(@tech{Universe}) and a list that contains a single mail. These contracts
are just refinements of the generic ones. (A type-oriented programmer would
say that the contracts here are subtypes of the generic ones.)
message to exactly one world. Note how these contracts are just refinements
of the generic ones. (A type-oriented programmer would say that the
contracts here are subtypes of the generic ones.)
The second step of the design recipe calls for functional examples:
@ -1290,14 +1361,16 @@ The second step of the design recipe calls for functional examples:
[schemeblock
;; an obvious example for adding a world:
(check-expect
(add-world '() world1)
(add-world '() '* world1)
(make-bundle (list world1)
'*
(list (make-mail world1 'it-is-your-turn))))
;; an example for receiving a message from the active world:
(check-expect
(switch (list world1 world2) world1 'it-is-your-turn)
(switch (list world1 world2) '* world1 'it-is-your-turn)
(make-bundle (list world2 world1)
'*
(list (make-mail world2 'it-is-your-turn))))
])
@ -1310,23 +1383,24 @@ Exercise: Create additional examples for the two functions based on our
protocol.
The protocol tells us that @emph{add-world} just adds the given
@emph{world} structure---recall that this a data representation of the
actual @tech{world} program---to the @tech{Universe} and then sends a
message to the first world on this list to get things going:
@emph{world} structure---recall that this a data representation of the
actual @tech{world} program---to the given list of worlds. It then sends a
message to the first world on this list to get things going:
@(begin
#reader scribble/comment-reader
[schemeblock
(define (add-world univ wrld)
(define (add-world univ state wrld)
(local ((define univ* (append univ (list wrld))))
(make-bundle univ*
'*
(list (make-mail (first univ*) 'it-is-your-turn)))))
])
Because @emph{univ*} contains at least @emph{wrld}, it is acceptable to
create a mail to @scheme[(first univ*)]. Of course, this same reasoning
also implies that if @emph{univ} isn't empty, its first element is an
active world and has already received such a message.
active world and is about to receive a second @scheme['it-is-your-turn] message.
Similarly, the protocol says that when @emph{switch} is invoked because a
@tech{world} program sends a message, the data representation of the
@ -1336,14 +1410,16 @@ Similarly, the protocol says that when @emph{switch} is invoked because a
@(begin
#reader scribble/comment-reader
[schemeblock
(define (switch univ wrld m)
(define (switch univ state wrld m)
(local ((define univ* (append (rest univ) (list (first univ)))))
(make-bundle univ* (list (make-mail (first univ*) 'it-is-your-turn)))))
(make-bundle univ*
'*
(list (make-mail (first univ*) 'it-is-your-turn)))))
])
As before, appending the first world to the end of the list guarantees
that there is at least this one world on the next @tech{Universe}
(state). It is therefore acceptable to create a mail for this world.
that there is at least this one world on this list. It is therefore
acceptable to create a mail for this world.
Exercise: The function definition simply assumes that @emph{wrld} is
@scheme[world=?] to @scheme[(first univ)] and that the received message
@ -1356,6 +1432,12 @@ Exercise: The function definition simply assumes that @emph{wrld} is
depends on the context. For now, stop the @tech{universe} at this point,
but consider alternative solutions, too.)
Exercise: An alternative state representation would equate
@tech{UniverseState} with @emph{world} structures, keeping track of the
active world. The list of world in the server would track the passive
worlds only. Design appropriate @scheme[add-world] and @scheme[switch]
functions.
@; -----------------------------------------------------------------------------
@subsection{Designing the Ball World}
@ -1371,31 +1453,35 @@ The final step is to design the ball @tech{world}. Recall that each world
(schemeblock
;; teachpack: universe.ss
;; World is one of
;; WorldState is one of:
;; -- Number %% representing the @emph{y} coordinate
;; -- @scheme['resting]
(define WORLD0 'resting)
;; A WorldResult is one of:
;; -- WorldState
;; -- (make-package WorldState StopMessage)
))
The definition says that initially a @tech{world} is passive.
The communication protocol and the refined data definition of @tech{World}
The communication protocol and the refined data definition of @tech{WorldState}
imply a number of contract and purpose statements:
@(begin
#reader scribble/comment-reader
(schemeblock
;; World GoMessage -> World or (make-package World StopMessage)
;; WorldState GoMessage -> WorldResult
;; make sure the ball is moving
(define (receive w n) ...)
;; World -> World or (make-package World StopMessage)
;; WorldState -> WorldResult
;; move this ball upwards for each clock tick
;; or stay @scheme['resting]
(define (move w) ...)
;; World -> Scene
;; WorldState -> Scene
;; render the world as a scene
(define (render w) ...)
))
@ -1403,7 +1489,7 @@ The communication protocol and the refined data definition of @tech{World}
Let's design one function at a time, starting with @emph{receive}. Since
the protocol doesn't spell out what @emph{receive} is to compute, let's
create a good set of functional examples, exploiting the structure of the
data organization of @tech{World}:
data organization of @tech{WorldState}:
@(begin
#reader scribble/comment-reader
@ -1458,7 +1544,7 @@ the scene every time @scheme['it-is-your-turn] is received. Design this function
@(begin
#reader scribble/comment-reader
(schemeblock
; World -> World or @scheme[(make-package 'resting 'done)]
; WorldState -> WorldState or @scheme[(make-package 'resting 'done)]
; move the ball if it is flying
(check-expect (move 'resting) 'resting)
@ -1498,7 +1584,7 @@ Finally, here is the third function, which renders the state as a scene:
@(begin
#reader scribble/comment-reader
(schemeblock
; World -> Scene
; WorldState -> Scene
; render the state of the world as a scene
(check-expect (render HEIGHT) (place-image BALL 50 HEIGHT MT))
@ -1520,7 +1606,7 @@ Finally, here is the third function, which renders the state as a scene:
@(begin
#reader scribble/comment-reader
(schemeblock
; String -> (World -> Scene)
; String -> (WorldState -> Scene)
; render the state of the world as a scene
(check-expect
@ -1545,7 +1631,7 @@ Finally, here is the third function, which renders the state as a scene:
#reader scribble/comment-reader
(schemeblock
; String -> World
; String -> WorldState
; create and hook up a world with the @scheme[LOCALHOST] server
(define (create-world name)
(big-bang WORLD0

0
collects/teachpack/2htdp/scribblings/balls.ss → collects/teachpack/balls.ss
View File

0
collects/teachpack/2htdp/scribblings/fsa.ss → collects/teachpack/door.ss
View File

2
collects/teachpack/2htdp/scribblings/nuworld.ss → collects/teachpack/nuworld.ss
View File

@ -114,6 +114,6 @@
(draw-pict the-image image-dc 0.0 0.0)
(send image-bm save-file "nuworld.png" 'png)
(send image-bm save-file "world.png" 'png)
the-image

BIN
collects/teachpack/server.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 28 KiB

228
collects/teachpack/server.ss Normal file
View File

@ -0,0 +1,228 @@
#lang slideshow
(require slideshow/pict)
(define DELTA 80)
(define FT 12)
(define prgm
'("(universe UniState_0"
" (on-new register)"
" (on-msg process)"
" (on-dis disconnect)"
" (on-tick tock)"
" (to-string render))"))
(define program
(apply vl-append (map (lambda (t) (text t '() (- FT 2))) prgm)))
(define Program
(cc-superimpose
(rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program)))
program))
(define (make-state txt)
(define t (text txt '() FT))
(define e (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t))))
(cc-superimpose t e))
(define False (text "FALSE" '() FT))
(define True (text "TRUE" '() FT))
(define BOOL (rectangle (+ 5 (pict-width False)) (+ 5 (pict-height False))))
;; String Boolean -> Pict
(define (make-state0 txt b)
;; create the basic state
(define t (text txt '() FT))
(define s (if b
(cc-superimpose
(rounded-rectangle (+ 5 (pict-width t)) (+ (- DELTA 5) (pict-height t)))
t)
t))
(define w
(cc-superimpose
s
(rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))))
;; add the boolean
(define bb (cc-superimpose (if b True False) BOOL))
(define ar0 (add-labeled-arrow (vc-append DELTA bb w) w ct-find bb cb-find "done"))
;; HIDE the arrow and done
(define ar (cb-superimpose w (blank (pict-width ar0) (pict-height ar0))))
(define scene (text "string" '() FT))
(define sc (cc-superimpose scene (rectangle (+ 20 (pict-width scene)) (+ 30 (pict-height scene)))))
(define br (add-labeled-arrow (vc-append DELTA ar sc) ar cb-find sc ct-find "render"))
br)
(define (add-labeled-arrow nx locked lb-find closed lt-find txt)
(define-values (x0 y0) (lb-find nx locked))
(define-values (x1 y1) (lt-find nx closed))
(define lbl (text txt '() (- FT 2)))
(define wlbl (pict-width lbl))
(define hlbl (pict-height lbl))
(define x (- x0 (/ wlbl 2)))
(define y (+ y0 (/ ( - y1 y0 hlbl) 2)))
(pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl))
(define (h-labeled-arrow t)
(define tock (text t '() (- FT 2)))
(define blk (blank (+ DELTA 4) 2))
(vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find)))
(define message (text "Message" '() FT))
(define (make-Message)
(cc-superimpose message (rectangle (+ 20 (pict-width message)) (+ 30 (pict-height message)))))
(define Message (vc-append (make-Message) (arrowhead 4 (* 1/2 pi))))
(define MessageK (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message)))
(define M (rb-superimpose Message (blank DELTA DELTA)))
(define K (rb-superimpose MessageK (blank DELTA DELTA)))
(define (make-arrows M)
(define Tock (h-labeled-arrow "register"))
(define Click (h-labeled-arrow "tock"))
(define Clack (h-labeled-arrow "disconnect"))
(define Receive (h-labeled-arrow "process"))
(values Tock Click Clack Receive (vc-append (blank DELTA (/ DELTA 2)) Tock Click Clack Receive M)))
(define-values (TockM ClickM ClackM ReceiveM arrowsR) (make-arrows M))
(define-values (TockK ClickK ClackK ReceiveK arrowsL) (make-arrows K))
(define state0 (make-state0 "UniState_0" #f))
(define state1 (make-state0 "UniState_1" #f))
(define Server (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "UNIVERSE" '() FT ))))
(define world (cc-superimpose (cloud 80 40) (text "world" '() FT )))
(define dots (vc-append
(cc-superimpose (blank (pict-width state1) (pict-height state1)) (text "..." '() FT))
world
Server))
(define state2 (make-state0 "UniState_N-1" #f))
(define stateN (make-state0 "UniState_N" #t))
(define states (list state1 arrowsL dots arrowsR state2))
(define bg (blank (+ (apply + (map pict-width states)) DELTA)
(+ (pict-height state0) DELTA)))
(define (center base state x)
(define w (pict-height state))
(define d (quotient (- width w) 2))
(pin-over base x d state))
(define width (pict-height bg))
(define x (* 1/2 DELTA))
(define xx
(foldl (lambda (f ls s)
(define y (center s f x))
(set! x (+ x ls))
y)
bg
states
(map (lambda (x) (+ (pict-width x) #;(* 1/1 DELTA))) states)))
(define zz xx)
(require mred/mred)
(define the-image
(ct-superimpose Program
(lt-superimpose
(dc (lambda (dc x y)
(define-values (mx my) (cb-find zz MessageK))
(define-values (tx ty) (ct-find zz MessageK))
(define-values (sx sy) (lc-find zz Server))
(define-values (tockx tocky) (lb-find zz TockK))
(define-values (clickx clicky) (lb-find zz ClickK))
(define-values (clackx clacky) (lb-find zz ClackK))
(define-values (rx ry) (lb-find zz ReceiveK))
(define (add-curve rx ry)
(set! dcp (make-object dc-path%))
(set! cx (max rx tx))
(set! cy (min ry ty))
(send dcp move-to tx ty)
(send dcp curve-to tx ty cx cy rx ry)
(send dc draw-path dcp))
(define dcp (make-object dc-path%))
;; --- draw arc from Message to Server
(define cx (min sx mx))
(define cy (max sy my))
(send dc set-smoothing 'aligned)
(send dcp move-to mx my)
(send dcp curve-to mx my cx cy sx sy)
(send dc draw-path dcp)
;; --- draw arc from Message to Receiver
(add-curve tockx tocky)
(add-curve clickx clicky)
(add-curve clackx clacky)
(add-curve rx ry)
;; ---
dc)
(pict-width zz) (pict-height zz))
(lt-superimpose
(lt-superimpose
zz
(dc (lambda (dc x y)
(define-values (mx my) (cb-find zz world))
(define-values (tx ty) (ct-find zz world))
(define-values (sx sy) (rc-find zz Server))
(define-values (rx ry) (rb-find zz ReceiveM))
(define dcp (make-object dc-path%))
;; --- draw arc from Message to Server
(define cx (max sx mx))
(define cy (max sy my))
#|
(send dc set-smoothing 'aligned)
(send dcp move-to mx my)
(send dcp curve-to mx my cx cy sx sy)
(send dc draw-path dcp)
|#
;; --- draw arc from Message to Receiver
(set! dcp (make-object dc-path%))
(set! cx (min rx tx))
(set! cy (min ry ty))
(send dcp move-to tx ty)
(send dcp curve-to tx ty cx cy rx ry)
(send dc draw-path dcp)
;; ---
dc)
(pict-width zz) (pict-height zz)))
(dc (lambda (dc x y)
(define-values (mx my) (cb-find zz Message))
(define-values (tx ty) (ct-find zz Message))
(define-values (sx sy) (rc-find zz Server))
(define-values (rx ry) (rb-find zz ReceiveM))
(define dcp (make-object dc-path%))
;; --- draw arc from Message to Server
(define cx (max sx mx))
(define cy (max sy my))
(send dc set-smoothing 'aligned)
(send dcp move-to mx my)
(send dcp curve-to mx my cx cy sx sy)
(send dc draw-path dcp)
;; --- draw arc from Message to Receiver
(set! dcp (make-object dc-path%))
(set! cx (min rx tx))
(set! cy (min ry ty))
(send dcp move-to tx ty)
(send dcp curve-to tx ty cx cy rx ry)
(send dc draw-path dcp)
;; ---
dc)
(pict-width zz) (pict-height zz))))))
(define image-bm
(make-object bitmap%
(inexact->exact (round (pict-width the-image)))
(inexact->exact (round (pict-height the-image)))))
(send image-bm ok?)
(define image-dc
(new bitmap-dc% [bitmap image-bm]))
(send image-dc clear)
(draw-pict the-image image-dc 0.0 0.0)
(send image-bm save-file "server.png" 'png)
the-image

BIN
collects/teachpack/server2.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 17 KiB

BIN
collects/teachpack/universe.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 28 KiB

BIN
collects/teachpack/universe2.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 19 KiB

BIN
collects/teachpack/world.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 20 KiB

After

Width:  |  Height:  |  Size: 15 KiB

0
collects/teachpack/2htdp/scribblings/universe.ss → collects/teachpack/world.ss
View File

1
collects/tests/mzscheme/mzlib-tests.ss
View File

@ -10,6 +10,7 @@
(load-in-sandbox "async-channel.ss")
(load-in-sandbox "restart.ss")
(load-in-sandbox "string-mzlib.ss")
(load-in-sandbox "pathlib.ss")
(load-in-sandbox "filelib.ss")
(load-in-sandbox "portlib.ss")
(load-in-sandbox "threadlib.ss")

79
collects/tests/mzscheme/pathlib.ss Normal file
View File

@ -0,0 +1,79 @@
(load-relative "loadtest.ss")
(Section 'path)
(require scheme/path)
(define (rtest f args result)
(test result f args))
;; ----------------------------------------
(rtest explode-path "a/b" (list (string->path "a")
(string->path "b")))
(rtest explode-path "a/../b" (list (string->path "a")
'up
(string->path "b")))
(rtest explode-path "./a/b" (list 'same
(string->path "a")
(string->path "b")))
(rtest explode-path (bytes->path #"./a/b" 'unix) (list 'same
(bytes->path #"a" 'unix)
(bytes->path #"b" 'unix)))
(rtest explode-path (bytes->path #"./a\\b" 'windows) (list 'same
(bytes->path #"a" 'windows)
(bytes->path #"b" 'windows)))
;; ----------------------------------------
(rtest file-name-from-path "a/" #f)
(rtest file-name-from-path "a/b" (string->path "b"))
(rtest file-name-from-path (bytes->path #"a/b" 'unix) (bytes->path #"b" 'unix))
(rtest file-name-from-path (bytes->path #"a\\b" 'windows) (bytes->path #"b" 'windows))
;; ----------------------------------------
(rtest filename-extension "a" #f)
(rtest filename-extension "a.sls" #"sls")
(rtest filename-extension (bytes->path #"b/a.sls" 'unix) #"sls")
(rtest filename-extension (bytes->path #"b\\a.sls" 'windows) #"sls")
;; ----------------------------------------
(test (string->path "a") find-relative-path (path->complete-path "b") (path->complete-path "b/a"))
(test (string->path "../../b/a") find-relative-path (path->complete-path "c/b") (path->complete-path "b/a"))
(test (bytes->path #"a" 'unix) find-relative-path (bytes->path #"/r/b" 'unix) (bytes->path #"/r/b/a" 'unix))
(test (bytes->path #"a" 'windows) find-relative-path (bytes->path #"c:/r/b" 'windows) (bytes->path #"c:/r/b/a" 'windows))
;; ----------------------------------------
;; normalize-path needs tests
;; ----------------------------------------
(rtest path-only "a/b" (string->path "a/"))
(rtest path-only "a/b/" (string->path "a/b/"))
(rtest path-only "a/.." (string->path "a/.."))
(rtest path-only (bytes->path #"a/z" 'unix) (bytes->path #"a/" 'unix))
(rtest path-only (bytes->path #"a/z/" 'unix) (bytes->path #"a/z/" 'unix))
(rtest path-only (bytes->path #"a/z" 'windows) (bytes->path #"a/" 'windows))
(rtest path-only (bytes->path #"a/z/" 'windows) (bytes->path #"a/z/" 'windows))
;; ----------------------------------------
;; simple-form-path needs tests
;; ----------------------------------------
(test "a" some-system-path->string (string->path "a"))
(test "a" some-system-path->string (bytes->path #"a" 'unix))
(test "a" some-system-path->string (bytes->path #"a" 'windows))
(test #t path-for-some-system? (string->some-system-path "a" 'unix))
(test #t path-for-some-system? (string->some-system-path "a" 'windows))
(test "a" some-system-path->string (string->some-system-path "a" 'unix))
(test "a" some-system-path->string (string->some-system-path "a" 'windows))
;; ----------------------------------------
(report-errs)

46
collects/web-server/dispatchers/limit.ss Normal file
View File

@ -0,0 +1,46 @@
#lang scheme
(require "dispatch.ss")
(provide/contract
[interface-version dispatcher-interface-version/c]
[make (number? dispatcher/c . -> . dispatcher/c)])
(define interface-version 'v1)
(define (make num inner)
(define-struct in-req (partner reply-ch))
(define in-ch (make-channel))
(define-struct out-req (partner))
(define out-ch (make-channel))
(define limit-manager
(thread
(lambda ()
(let loop ([i 0]
[partners empty])
(apply sync
(if (< i num)
(handle-evt in-ch
(lambda (req)
(channel-put (in-req-reply-ch req) #t)
(loop (add1 i)
(list* (in-req-partner req) partners))))
never-evt)
(handle-evt out-ch
(lambda (req)
(loop (sub1 i)
(remq (out-req-partner req) partners))))
(map (lambda (p)
(handle-evt (thread-dead-evt p)
(lambda _
(loop (sub1 i) (remq p partners)))))
partners))))))
(define (in)
(define reply (make-channel))
(channel-put in-ch (make-in-req (current-thread) reply))
(channel-get reply))
(define (out)
(channel-put out-ch (make-out-req (current-thread))))
(lambda (conn req)
(dynamic-wind
in
(lambda ()
(inner conn req))
out)))

59
collects/web-server/scribblings/dispatchers.scrbl
View File

@ -388,3 +388,62 @@ a URL that refreshes the password file, servlet cache, etc.}
dispatcher/c]{
Returns a dispatcher that prints memory usage on every request.
}}
@; ------------------------------------------------------------
@section[#:tag "limit.ss"]{Limiting Requests}
@a-dispatcher[web-server/dispatchers/limit
@elem{provides a wrapper dispatcher that limits how many requests are serviced at once.}]{
@defproc[(make [limit number?]
[inner dispatcher/c])
dispatcher/c]{
Returns a dispatcher that defers to @scheme[inner] for work, but will forward a maximum of @scheme[limit] requests concurrently.
}}
@(require (for-label
web-server/web-server
web-server/http
(prefix-in limit: web-server/dispatchers/limit)
(prefix-in filter: web-server/dispatchers/dispatch-filter)
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)))
Consider this example:
@schememod[
scheme
(require web-server/web-server
web-server/http
web-server/http/response
(prefix-in limit: web-server/dispatchers/limit)
(prefix-in filter: web-server/dispatchers/dispatch-filter)
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer))
(serve #:dispatch
(sequencer:make
(filter:make
#rx"/limited"
(limit:make
5
(lambda (conn req)
(output-response/method
conn
(make-response/full
200 "Okay"
(current-seconds) TEXT/HTML-MIME-TYPE
empty
(list (format "hello world ~a"
(sort (build-list 100000 (λ x (random 1000)))
<))))
(request-method req)))))
(lambda (conn req)
(output-response/method
conn
(make-response/full 200 "Okay"
(current-seconds) TEXT/HTML-MIME-TYPE
empty
(list "<html><body>Unlimited</body></html>"))
(request-method req))))
#:port 8080)
(do-not-return)
]

16
collects/web-server/scribblings/faq.scrbl
View File

@ -104,18 +104,4 @@ The Web Server will start on port 443 (which can be overridden with the @exec{-p
@section{How do I limit the number of requests serviced at once by the Web Server?}
There is no built-in option for this, but you can easily accomplish it if you assemble your own dispatcher
by wrapping it in @scheme[call-with-semaphore]:
@schemeblock[
(define (make-limit-dispatcher num inner)
(let ([sem (make-semaphore num)])
(lambda (conn req)
(call-with-semaphore sem
(lambda () (inner conn req))))))
]
Once this function is available, rather than providing @scheme[james-gordon] as your dispatcher, you provide:
@scheme[(make-limit-dispatch 50 james-gordon)] (if you only want 50 concurrent requests.) One interesting
application of this pattern is to have a limit on certain kinds of requests. For example, you could have a
limit of 50 servlet requests, but no limit on filesystem requests.
Refer to @secref["limit.ss"].

6
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,6 +1,5 @@
Somewhere in there:
function contracts now preserve tail recursion in many cases; the
'any' contract is no longer special.
Version 4.1.3.10
Added syntax-local-lift-require
Version 4.1.3.8
Added procedure-rename
@ -15,6 +14,7 @@ Version 4.1.3.6
Memory accounting changed to bias charges to parent instead of children
Version 4.1.3.3
Function contracts preserve tail recursion in many cases
Added compile-context-preservation-enabled
Added exception-backtrace support for x86_84+JIT
Added scheme/package, scheme/splicing

10
src/mred/wxme/wx_mline.cxx
View File

@ -321,7 +321,7 @@ void wxMediaLine::Delete(wxMediaLine **root)
else
x = v->right;
x->parent = v->parent;
x->parent = v->parent; /* x could be NIL; fixup at end */
if (PTREQ(v->parent, NIL))
*root = x;
@ -448,6 +448,11 @@ void wxMediaLine::Delete(wxMediaLine **root)
SET_BLACK(x);
}
if (PTRNE(NIL->parent, NIL)) {
/* fixup: we set NIL's parent above */
NIL->parent = NIL;
}
right = left = NIL;
DELETE_OBJ this;
}
@ -594,7 +599,8 @@ wxMediaParagraph *wxMediaLine::GetParagraphStyle(Bool *first)
} else { \
node = node->parent; \
} \
} \
}
void wxMediaLine::SetLength(long len)
{

99
src/mzscheme/src/env.c
View File

@ -110,6 +110,7 @@ static Scheme_Object *local_module_expanding_provides(int argc, Scheme_Object *a
static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]);
@ -550,6 +551,7 @@ static void make_kernel_env(void)
GLOBAL_PRIM_W_ARITY("syntax-local-lift-expression", local_lift_expr, 1, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-context", local_lift_context, 0, 0, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-module-end-declaration", local_lift_end_statement, 1, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-require", local_lift_require, 2, 2, env);
{
Scheme_Object *sym;
@ -1366,7 +1368,7 @@ scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *f
}
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data,
Scheme_Object *end_stmts, Scheme_Object *context_key)
Scheme_Object *end_stmts, Scheme_Object *context_key, Scheme_Object *requires)
{
Scheme_Lift_Capture_Proc *pp;
Scheme_Object *vec;
@ -1374,16 +1376,45 @@ void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc
pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc));
*pp = cp;
vec = scheme_make_vector(5, NULL);
vec = scheme_make_vector(7, NULL);
SCHEME_VEC_ELS(vec)[0] = scheme_null;
SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp;
SCHEME_VEC_ELS(vec)[2] = data;
SCHEME_VEC_ELS(vec)[3] = end_stmts;
SCHEME_VEC_ELS(vec)[4] = context_key;
SCHEME_VEC_ELS(vec)[5] = (requires ? requires : scheme_false);
SCHEME_VEC_ELS(vec)[6] = scheme_null; /* accumulated requires */
COMPILE_DATA(env)->lifts = vec;
}
void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env)
{
while (orig_env) {
if ((COMPILE_DATA(orig_env)->lifts)
&& SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(orig_env)->lifts)[5]))
break;
orig_env = orig_env->next;
}
if (orig_env) {
Scheme_Object *vec, *p;
p = scheme_make_raw_pair(NULL, (Scheme_Object *)orig_env);
vec = scheme_make_vector(7, NULL);
SCHEME_VEC_ELS(vec)[0] = scheme_false;
SCHEME_VEC_ELS(vec)[1] = scheme_void;
SCHEME_VEC_ELS(vec)[2] = scheme_void;
SCHEME_VEC_ELS(vec)[3] = scheme_false;
SCHEME_VEC_ELS(vec)[4] = scheme_false;
SCHEME_VEC_ELS(vec)[5] = p; /* (rcons NULL env) => continue with env */
SCHEME_VEC_ELS(vec)[6] = scheme_null;
COMPILE_DATA(env)->lifts = vec;
}
}
Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env)
{
return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0];
@ -1394,6 +1425,11 @@ Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env)
return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3];
}
Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env)
{
return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6];
}
void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env)
{
Scheme_Object **ns, **vs;
@ -4748,6 +4784,10 @@ local_lift_expr(int argc, Scheme_Object *argv[])
env = env->next;
}
if (env)
if (SCHEME_FALSEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0]))
env = NULL;
if (!env)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"syntax-local-lift-expression: no lift target");
@ -4851,6 +4891,61 @@ local_lift_end_statement(int argc, Scheme_Object *argv[])
return scheme_void;
}
static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[])
{
Scheme_Comp_Env *env;
Scheme_Object *local_mark, *mark, *data, *pr, *form;
long phase;
if (!SCHEME_STXP(argv[1]))
scheme_wrong_type("syntax-local-lift-require", "syntax", 1, argc, argv);
env = scheme_current_thread->current_local_env;
local_mark = scheme_current_thread->current_local_mark;
phase = env->genv->phase;
if (!env)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"syntax-local-lift-require: not currently transforming");
data = NULL;
while (env) {
if (COMPILE_DATA(env)->lifts
&& SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5])) {
data = SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5];
if (SCHEME_RPAIRP(data)
&& !SCHEME_CAR(data)) {
env = (Scheme_Comp_Env *)SCHEME_CDR(data);
} else
break;
} else
env = env->next;
}
if (!env)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"syntax-local-lift-requires: could not find target context");
mark = scheme_new_mark();
if (SCHEME_RPAIRP(data))
form = scheme_parse_lifted_require(argv[0], phase, mark, SCHEME_CAR(data));
else
form = scheme_toplevel_require_for_expand(argv[0], phase, env, mark);
pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6]);
SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6] = pr;
form = argv[1];
form = scheme_add_remove_mark(form, local_mark);
form = scheme_add_remove_mark(form, mark);
form = scheme_add_remove_mark(form, local_mark);
return form;
}
static Scheme_Object *
make_set_transformer(int argc, Scheme_Object *argv[])
{

4
src/mzscheme/src/error.c
View File

@ -1217,6 +1217,10 @@ char *scheme_make_arity_expect_string(Scheme_Object *proc,
}
name = scheme_get_proc_name((Scheme_Object *)proc, &namelen, 1);
#endif
} else if (SCHEME_STRUCTP(proc)) {
name = (const char *)proc;
mina = -1;
maxa = 0;
} else {
Scheme_Closure_Data *data;

40
src/mzscheme/src/eval.c
View File

@ -4911,7 +4911,7 @@ static void *compile_k(void)
int writeable, for_eval, rename, enforce_consts, comp_flags;
Scheme_Env *genv;
Scheme_Compile_Info rec, rec2;
Scheme_Object *o, *tl_queue;
Scheme_Object *o, *rl, *tl_queue;
Scheme_Compilation_Top *top;
Resolve_Prefix *rp;
Resolve_Info *ri;
@ -4973,7 +4973,8 @@ static void *compile_k(void)
find one, break it up to eval first expression
before the rest. */
while (1) {
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false, scheme_false);
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv),
scheme_false, scheme_false, scheme_null);
form = scheme_check_immediate_macro(form,
cenv, &rec, 0,
0, &gval, NULL, NULL);
@ -4989,10 +4990,13 @@ static void *compile_k(void)
} else
break;
} else {
rl = scheme_frame_get_require_lifts(cenv);
o = scheme_frame_get_lifts(cenv);
if (!SCHEME_NULLP(o)) {
if (!SCHEME_NULLP(o)
|| !SCHEME_NULLP(rl)) {
tl_queue = scheme_make_pair(form, tl_queue);
tl_queue = scheme_append(o, tl_queue);
tl_queue = scheme_append(rl, tl_queue);
form = SCHEME_CAR(tl_queue);
tl_queue = SCHEME_CDR(tl_queue);
}
@ -5010,7 +5014,8 @@ static void *compile_k(void)
Scheme_Object *l, *prev_o = NULL;
while (1) {
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false, scheme_false);
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv),
scheme_false, scheme_false, scheme_null);
scheme_init_compile_recs(&rec, 0, &rec2, 1);
@ -5031,10 +5036,13 @@ static void *compile_k(void)
/* If any definitions were lifted in the process of compiling o,
we need to fold them in. */
l = scheme_frame_get_lifts(cenv);
if (!SCHEME_NULLP(l)) {
l = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0),
l);
form = scheme_datum_to_syntax(l, scheme_false, scheme_false, 0, 0);
rl = scheme_frame_get_require_lifts(cenv);
if (!SCHEME_NULLP(l)
|| !SCHEME_NULLP(rl)) {
rl = scheme_append(rl, l);
rl = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0),
rl);
form = scheme_datum_to_syntax(rl, scheme_false, scheme_false, 0, 0);
prev_o = o;
} else
break;
@ -6213,7 +6221,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
context_key = scheme_generate_lifts_key();
scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false, context_key);
scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false, context_key, NULL);
if (rec[drec].comp) {
scheme_init_compile_recs(rec, drec, recs, 2);
@ -8877,7 +8885,9 @@ static void *expand_k(void)
erec1.comp_flags = comp_flags;
if (catch_lifts_key)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, catch_lifts_key);
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env),
scheme_false, catch_lifts_key,
(!as_local && catch_lifts_key) ? scheme_null : NULL);
if (just_to_top) {
Scheme_Object *gval;
@ -8886,9 +8896,12 @@ static void *expand_k(void)
obj = scheme_expand_expr(obj, env, &erec1, 0);
if (catch_lifts_key) {
Scheme_Object *l;
Scheme_Object *l, *rl;
l = scheme_frame_get_lifts(env);
if (SCHEME_PAIRP(l)) {
rl = scheme_frame_get_require_lifts(env);
if (SCHEME_PAIRP(l)
|| SCHEME_PAIRP(rl)) {
l = scheme_append(rl, l);
obj = add_lifts_as_begin(obj, l, env);
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj);
if ((depth >= 0) || as_local)
@ -9189,6 +9202,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
if (for_stx) {
scheme_prepare_exp_env(env->genv);
env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
scheme_propagate_require_lift_capture(orig_env, env);
}
if (for_expr)
@ -9322,7 +9336,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
if (catch_lifts_key)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false,
catch_lifts_key);
catch_lifts_key, NULL);
memset(drec, 0, sizeof(drec));
drec[0].value_name = scheme_false; /* or scheme_current_thread->current_local_name ? */

131
src/mzscheme/src/module.c
View File

@ -5749,6 +5749,76 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id,
return scheme_make_lifted_defn(scheme_sys_wraps(env), _id, expr, _env);
}
static Scheme_Object *make_require_form(Scheme_Object *module_path, long phase, Scheme_Object *mark)
{
Scheme_Object *e = module_path;
if (phase != 0) {
e = scheme_make_pair(for_meta_symbol,
scheme_make_pair(scheme_make_integer(phase),
scheme_make_pair(e,
scheme_null)));
}
e = scheme_make_pair(require_stx, scheme_make_pair(e, scheme_null));
e = scheme_datum_to_syntax(e, scheme_false, scheme_false, 0, 0);
e = scheme_add_remove_mark(e, mark);
return e;
}
Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path,
long phase,
Scheme_Object *mark,
void *data)
{
Scheme_Object *e;
Scheme_Object *base_modidx = (Scheme_Object *)((void **)data)[1];
Scheme_Env *env = (Scheme_Env *)((void **)data)[2];
Scheme_Module *for_m = (Scheme_Module *)((void **)data)[3];
Scheme_Object *rns = (Scheme_Object *)((void **)data)[4];
Scheme_Object *post_ex_rns = (Scheme_Object *)((void **)data)[5];
void *tables = ((void **)data)[6];
Scheme_Object *redef_modname = (Scheme_Object *)((void **)data)[7];
int *all_simple = (int *)((void **)data)[8];
e = make_require_form(module_path, phase, mark);
parse_requires(e, base_modidx, env, for_m,
rns, post_ex_rns,
check_require_name, tables,
redef_modname,
0, 0, 1, 0,
all_simple);
return e;
}
static Scheme_Object *package_require_data(Scheme_Object *base_modidx,
Scheme_Env *env,
Scheme_Module *for_m,
Scheme_Object *rns, Scheme_Object *post_ex_rns,
void *data,
Scheme_Object *redef_modname,
int *all_simple)
{
void **vals;
vals = MALLOC_N(void*, 9);
vals[0] = NULL; /* this slot is available */
vals[1] = base_modidx;
vals[2] = env;
vals[3] = for_m;
vals[4] = rns;
vals[5] = post_ex_rns;
vals[6] = data;
vals[7] = redef_modname;
vals[8] = all_simple;
return scheme_make_raw_pair((Scheme_Object *)vals, NULL);
}
static void flush_definitions(Scheme_Env *genv)
{
if (genv->syntax) {
@ -5786,9 +5856,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Object *exclude_hint = scheme_false, *lift_data;
Scheme_Object **exis, **et_exis, **exsis;
Scheme_Object *lift_ctx;
Scheme_Object *lifted_reqs = scheme_null, *req_data;
int exicount, et_exicount, exsicount;
char *exps, *et_exps;
int all_simple_renames = 1;
int *all_simple_renames;
int maybe_has_lifts = 0;
int reprovide_kernel;
Scheme_Object *redef_modname;
@ -5931,6 +6002,15 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
maybe_has_lifts = 0;
lift_ctx = scheme_generate_lifts_key();
all_simple_renames = (int *)scheme_malloc_atomic(sizeof(int));
*all_simple_renames = 1;
req_data = package_require_data(self_modidx, env->genv, env->genv->module,
rn_set, post_ex_rn_set,
tables,
redef_modname,
all_simple_renames);
/* Pass 1 */
/* Partially expand all expressions, and process definitions, requires,
@ -5949,7 +6029,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
p = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(xenv)
: scheme_null);
scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), p, lift_ctx);
scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv),
p, lift_ctx, req_data);
maybe_has_lifts = 1;
{
@ -5966,11 +6047,13 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
e = scheme_expand_expr(e, xenv, &erec1, 0);
}
lifted_reqs = scheme_append(scheme_frame_get_require_lifts(xenv), lifted_reqs);
fst = scheme_frame_get_lifts(xenv);
if (!SCHEME_NULLP(fst)) {
/* Expansion lifted expressions, so add them to
the front and try again. */
all_simple_renames = 0;
*all_simple_renames = 0;
fm = SCHEME_STX_CDR(fm);
e = scheme_add_rename(e, post_ex_rn_set);
fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_rn_set);
@ -6066,7 +6149,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Add a renaming: */
if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) {
scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0);
all_simple_renames = 0;
*all_simple_renames = 0;
} else
scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0);
@ -6102,6 +6185,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_prepare_exp_env(env->genv);
eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, req_data);
oenv = (for_stx ? eenv : env);
@ -6148,7 +6232,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) {
scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name,
for_stx ? 1 : 0, NULL, NULL, 0);
all_simple_renames = 0;
*all_simple_renames = 0;
} else
scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name,
for_stx ? 1 : 0, NULL, NULL, 0);
@ -6186,6 +6270,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
}
m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0);
lifted_reqs = scheme_append(scheme_frame_get_require_lifts(eenv), lifted_reqs);
oi = scheme_optimize_info_create();
oi->context = (Scheme_Object *)env->genv->module;
if (!(rec[drec].comp_flags & COMP_CAN_INLINE))
@ -6243,7 +6329,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
check_require_name, tables,
redef_modname,
0, 0, 1, 0,
&all_simple_renames);
all_simple_renames);
if (rec[drec].comp)
e = NULL;
@ -6361,7 +6447,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
l = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(cenv)
: scheme_null);
scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx);
scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data);
maybe_has_lifts = 1;
if (kind == 2)
@ -6381,6 +6467,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
e = scheme_expand_expr(e, nenv, &erec1, 0);
}
lifted_reqs = scheme_append(scheme_frame_get_require_lifts(xenv), lifted_reqs);
l = scheme_frame_get_lifts(cenv);
if (SCHEME_NULLP(l)) {
/* No lifts - continue normally */
@ -6389,7 +6477,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
p = SCHEME_CDR(p);
} else {
/* Lifts - insert them and try again */
all_simple_renames = 0;
*all_simple_renames = 0;
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l));
e = scheme_make_pair(e, scheme_make_integer(0)); /* don't re-compile/-expand */
SCHEME_CAR(p) = e;
@ -6632,7 +6720,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
env->genv->module->indirect_provides = exis;
env->genv->module->num_indirect_provides = exicount;
if (all_simple_renames) {
if (*all_simple_renames) {
env->genv->module->indirect_syntax_provides = exsis;
env->genv->module->num_indirect_syntax_provides = exsicount;
} else {
@ -6645,7 +6733,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
env->genv->module->comp_prefix = cenv->prefix;
if (all_simple_renames) {
if (*all_simple_renames) {
env->genv->module->rn_stx = scheme_true;
}
@ -6659,6 +6747,13 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
}
p = SCHEME_STX_CAR(form);
/* Add lifted requires */
if (!SCHEME_NULLP(lifted_reqs)) {
lifted_reqs = scheme_reverse(lifted_reqs);
first = scheme_append(lifted_reqs, first);
}
return scheme_datum_to_syntax(cons(p, first), form, form, 0, 2);
}
}
@ -9045,7 +9140,7 @@ static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env,
0, 0, 0, 0,
NULL);
if (rec[drec].comp) {
if (rec && rec[drec].comp) {
/* Dummy lets us access a top-level environment: */
dummy = scheme_make_environment_dummy(env);
@ -9071,6 +9166,20 @@ require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *er
return do_require(form, env, erec, drec);
}
Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path,
long phase,
Scheme_Comp_Env *cenv,
Scheme_Object *mark)
{
Scheme_Object *form;
form = make_require_form(module_path, phase, mark);
do_require(form, cenv, NULL, 0);
return form;
}
/**********************************************************************/
/* dummy forms */
/**********************************************************************/

4
src/mzscheme/src/schminc.h
View File

@ -11,9 +11,9 @@
EXPECTED_PRIM_COUNT to the new value, and then USE_COMPILED_STARTUP
can be set to 1 again. */
#define USE_COMPILED_STARTUP 1
#define USE_COMPILED_STARTUP 0
#define EXPECTED_PRIM_COUNT 945
#define EXPECTED_PRIM_COUNT 946
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

15
src/mzscheme/src/schpriv.h
View File

@ -362,7 +362,7 @@ extern mz_proc_thread *scheme_master_proc_thread;
extern THREAD_LOCAL mz_proc_thread *proc_thread_self;
#endif
extern int scheme_no_stack_overflow;
extern THREAD_LOCAL int scheme_no_stack_overflow;
typedef struct Scheme_Thread_Set {
Scheme_Object so;
@ -2065,11 +2065,22 @@ Scheme_Object *scheme_env_frame_uid(Scheme_Comp_Env *env);
typedef Scheme_Object *(*Scheme_Lift_Capture_Proc)(Scheme_Object *, Scheme_Object **, Scheme_Object *, Scheme_Comp_Env *);
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data,
Scheme_Object *end_stmts, Scheme_Object *context_key);
Scheme_Object *end_stmts, Scheme_Object *context_key, Scheme_Object *require_lifts);
void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_generate_lifts_key(void);
Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path,
long phase,
Scheme_Comp_Env *cenv,
Scheme_Object *mark);
Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path,
long phase,
Scheme_Object *mark,
void *data);
void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env);
void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val,
Scheme_Comp_Env *env);

4
src/mzscheme/src/schvers.h
View File

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