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

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

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

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

@ -278,7 +278,8 @@
;; ------------------------------------------------------------------------- ;; -------------------------------------------------------------------------
;; initialize the world and run ;; initialize the world and run
(super-new) (super-new)
(start!))))) (start!)
(when (stop-when world) (stop! world))))))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
(define-runtime-path break-btn:path '(lib "icons/break.png")) (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-field world0 tick key mouse rec draw rate width height)
(inherit show callback-stop!) (inherit show callback-stop!)
;; Frame Custodian -> (-> Void) ;; Frame Custodian ->* (-> Void) (-> Void)
;; adds the stop animation and image creation button, ;; adds the stop animation and image creation button,
;; whose callbacks runs as a thread in the custodian ;; 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/augment (create-frame frm play-back-custodian)
(define p (new horizontal-pane% [parent frm][alignment '(center center)])) (define p (new horizontal-pane% [parent frm][alignment '(center center)]))
(define (switch) (define (switch)
(send stop-button enable #f) (send stop-button enable #f)
(send image-button enable #t)) (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 ...) (define-syntax-rule (btn l a y ...)
(new button% [parent p] [label l] [style '(border)] (new button% [parent p] [label l] [style '(border)]
[callback (lambda a y ...)])) [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 ;; type World
world? ;; Any -> Boolean world? ;; Any -> Boolean
world=? ;; World World -> Boolean world=? ;; World World -> Boolean
world-name ;; World -> Symbol
world1 ;; sample worlds world1 ;; sample worlds
world2 world2
world3 world3
;; type Bundle = (make-bundle Universe [Listof Mail]) ;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail])
;; type Mail = (make-mail World S-expression) ;; 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? bundle? ;; is this a bundle?
make-mail ;; World S-expression -> Mail make-mail ;; World S-expression -> Mail
mail? ;; is this a real mail? mail? ;; is this a real mail?
@ -254,10 +255,10 @@
;; in the console ;; in the console
(define-keywords UniSpec (define-keywords UniSpec
[on-new (function-with-arity 2)] [on-new (function-with-arity 3)]
[on-msg (function-with-arity 3)] [on-msg (function-with-arity 4)]
[on-disconnect (function-with-arity 2)] [on-disconnect (function-with-arity 3)]
[to-string (function-with-arity 1)]) [to-string (function-with-arity 2)])
(define-syntax (universe stx) (define-syntax (universe stx)
(syntax-case stx () (syntax-case stx ()
@ -297,15 +298,15 @@
;; (World World -> U) (U World Msg) -> U ;; (World World -> U) (U World Msg) -> U
(define (universe2 create process) (define (universe2 create process)
;; UniState = '() | (list World) | Universe ;; UniState = '() | (list World) | Universe
;; UniState World -> (cons UniState [Listof (list World S-expression)]) ;; [Listof World] UniState World -> (cons UniState [Listof (list World S-expression)])
(define (nu s p) (define (nu s x p)
(cond (cond
[(null? s) (make-bundle (list p) '())] [(null? s) (make-bundle (list p) '* '())]
[(not (pair? s)) (make-bundle s '())] [(not (pair? s)) (make-bundle s '* '())]
[(null? (rest s)) (create (first s) p)] [(null? (rest s)) (create (first s) p)]
[else (error 'create "a third world is signing up!")])) [else (error 'create "a third world is signing up!")]))
(universe '() (universe '()
(on-new nu) (on-new nu)
(on-msg process) (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 ;; by dynamically linking to code supplied by the MzLib, dynext, and
;; compiler collections. ;; 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 #lang scheme/base
(require scheme/unit (require scheme/unit

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

@ -9,34 +9,68 @@
(provide print-syntax-to-editor (provide print-syntax-to-editor
code-style) 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 ;; 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% ;; display%
(define display% (define display%
(class* object% (display<%>) (class* object% (display<%>)
(init ((stx syntax)))
(init-field text) (init-field text)
(init-field controller) (init-field controller)
(init-field config) (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)) (define extra-styles (make-hasheq))
;; render-syntax : syntax -> void ;; initialize : -> void
(define/public (render-syntax stx) (define/public (initialize)
(with-unlock text (apply-primary-partition-styles)
(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))
(refresh)) (refresh))
;; refresh : -> void ;; refresh : -> void
@ -45,7 +79,7 @@
(with-unlock text (with-unlock text
(send* text (send* text
(begin-edit-sequence) (begin-edit-sequence)
(change-style unhighlight-d (get-start-position) (get-end-position))) (change-style unhighlight-d start-position end-position))
(apply-extra-styles) (apply-extra-styles)
(let ([selected-syntax (send controller get-selected-syntax)]) (let ([selected-syntax (send controller get-selected-syntax)])
(apply-secondary-partition-styles selected-syntax) (apply-secondary-partition-styles selected-syntax)
@ -53,29 +87,15 @@
(send* text (send* text
(end-edit-sequence)))) (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<%> ;; get-range : -> range<%>
(define/public (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 ;; highlight-syntaxes : (list-of syntax) string -> void
(define/public (highlight-syntaxes stxs hi-color) (define/public (highlight-syntaxes stxs hi-color)
(let ([style-delta (highlight-style-delta hi-color #f)]) (let ([style-delta (highlight-style-delta hi-color #f)])
@ -89,11 +109,50 @@
(add-extra-styles stx (list underline-style-delta))) (add-extra-styles stx (list underline-style-delta)))
(refresh)) (refresh))
;; add-extra-styles : syntax (listof style) -> void
(define/public (add-extra-styles stx styles) (define/public (add-extra-styles stx styles)
(hash-set! extra-styles stx (hash-set! extra-styles stx
(append (hash-ref extra-styles stx null) (append (hash-ref extra-styles stx null)
styles))) 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 ;; apply-extra-styles : -> void
;; Applies externally-added styles (such as highlighting) ;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles) (define/private (apply-extra-styles)
@ -131,101 +190,35 @@
(relative->text-position (car r)) (relative->text-position (car r))
(relative->text-position (cdr r)))) (relative->text-position (cdr r))))
;; Primary styles ;; relative->text-position : number -> number
(define/private (relative->text-position pos)
;; apply-primary-partition-styles : -> void (+ pos start-position))
;; 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])))
;; Initialize ;; Initialize
(super-new) (super-new)
(send text insert start-anchor)
(send text insert end-anchor)
(render-syntax stx)
(send controller add-syntax-display this))) (send controller add-syntax-display this)))
;; print-syntax : syntax text% controller config (-> number) (-> number) ;; fixup-parentheses : string range -> void
;; -> range% (define (fixup-parentheses string 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)
(define (fixup r) (define (fixup r)
(let ([stx (range-obj r)] (let ([stx (range-obj r)]
[start (+ offset (range-start r))] [start (range-start r)]
[end (+ offset (range-end r))]) [end (range-end r)])
(when (and (syntax? stx) (pair? (syntax-e stx))) (when (and (syntax? stx) (pair? (syntax-e stx)))
(case (syntax-property stx 'paren-shape) (case (syntax-property stx 'paren-shape)
((#\[) ((#\[)
(replace start #\[) (string-set! string start #\[)
(replace (sub1 end) #\])) (string-set! string (sub1 end) #\]))
((#\{) ((#\{)
(replace start #\{) (string-set! string start #\{)
(replace (sub1 end) #\})))))) (string-set! string (sub1 end) #\}))))))
(define (replace pos char)
(send text insert char pos (add1 pos)))
(for-each fixup (send range all-ranges))) (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<%> ;; code-style : text<%> number/#f -> style<%>
(define (code-style text font-size) (define (code-style text font-size)
(let* ([style-list (send text get-style-list)] (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% (define prefs-base%
(class object% (class object%
;; columns : number
(field/notify columns (new notify-box% (value 60)))
;; suffix-option : SuffixOption ;; suffix-option : SuffixOption
(field/notify suffix-option (new notify-box% (value 'over-limit))) (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 ([binder-r (send range get-ranges binder)])
(for ([id-r (send range get-ranges id)]) (for ([id-r (send range get-ranges id)])
(add-binding-arrow start binder-r id-r definite?))))))) (add-binding-arrow start binder-r id-r definite?)))))))
display)) (void)))
(define/private (add-binding-arrow start binder-r id-r definite?) (define/private (add-binding-arrow start binder-r id-r definite?)
(if definite? (if definite?
@ -189,14 +189,17 @@
;; internal-add-syntax : syntax -> display ;; internal-add-syntax : syntax -> display
(define/private (internal-add-syntax stx) (define/private (internal-add-syntax stx)
(with-unlock -text (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 (send* -text
(insert "\n") (insert "\n")
;;(scroll-to-position current-position) ;;(scroll-to-position current-position)
) )
display))) display)))
(define/public (calculate-columns) (define/private (calculate-columns)
(define style (code-style -text (send config get-syntax-font-size))) (define style (code-style -text (send config get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc))) (define char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) (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) (define/override (on-size w h)
(send config set-width w) (send config set-width w)
(send config set-height h) (send config set-height h)
(send config set-columns (send (send widget get-view) calculate-columns))
(send widget update/preserve-view)) (send widget update/preserve-view))
(define warning-panel (define warning-panel

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

@ -341,24 +341,25 @@
((void) after-edit-sequence)) ((void) after-edit-sequence))
(private* (private*
[sp (lambda (x y z f b?) [sp (lambda (x y z f b? eps?)
;; let super method report z errors: ;; let super method report z errors:
(let ([zok? (memq z '(standard postscript))]) (let ([zok? (memq z '(standard postscript))])
(when zok? (when zok?
(check-top-level-parent/false '(method editor<%> print) f)) (check-top-level-parent/false '(method editor<%> print) f))
(let ([p (and zok? f (mred->wx 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* (override*
[print [print
(entry-point (entry-point
(case-lambda (case-lambda
[() (sp #t #t 'standard #f #t)] [() (sp #t #t 'standard #f #t #f)]
[(x) (sp x #t 'standard #f #t)] [(x) (sp x #t 'standard #f #t #f)]
[(x y) (sp x y 'standard #f #t)] [(x y) (sp x y 'standard #f #t #f)]
[(x y z) (sp x y z #f #t)] [(x y z) (sp x y z #f #t #f)]
[(x y z f) (sp x y z f #t)] [(x y z f) (sp x y z f #t #f)]
[(x y z f b?) (sp x y z f b?)]))] [(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 [on-new-box
(entry-point (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 tracing to metafunctions (see current-traced-metafunctions)
- added caching-enabled? parameter (changed how set-cache-size! - added caching-enabled? parameter (changed how set-cache-size!

38
collects/redex/gui.ss
View File

@ -33,8 +33,21 @@
#:pred (or/c (any/c . -> . any) #:pred (or/c (any/c . -> . any)
(any/c term-node? . -> . any)) (any/c term-node? . -> . any))
#:pp pp-contract #:pp pp-contract
#:colors (listof any/c)) #:colors (listof (list/c string? string?))
#:scheme-colors? boolean?
#:layout (-> any/c any/c))
any)] 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?)] [term-node? (-> any/c boolean?)]
[term-node-parents (-> term-node? (listof term-node?))] [term-node-parents (-> term-node? (listof term-node?))]
@ -45,6 +58,11 @@
(or/c string? (is-a?/c color%) false/c) (or/c string? (is-a?/c color%) false/c)
void?)] void?)]
[term-node-expr (-> term-node? any)] [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 [stepper
(->* (reduction-relation? (->* (reduction-relation?
@ -55,10 +73,16 @@
(->* (reduction-relation? (->* (reduction-relation?
(cons/c any/c (listof any/c))) (cons/c any/c (listof any/c)))
(pp-contract) (pp-contract)
void?)]) void?)]
[dark-pen-color (parameter/c (or/c string? (is-a?/c color%)))]
(provide reduction-steps-cutoff initial-font-size initial-char-width [light-pen-color (parameter/c (or/c string? (is-a?/c color%)))]
dark-pen-color light-pen-color dark-brush-color light-brush-color [dark-brush-color (parameter/c (or/c string? (is-a?/c color%)))]
dark-text-color light-text-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
default-pretty-printer) default-pretty-printer)

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

@ -753,22 +753,32 @@
acc)))])) acc)))]))
other-matches))))) other-matches)))))
(rewrite-proc-name child-make-proc) (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 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) (define (covered-cases cov)
(struct-copy covered-case c [apps (add1 (covered-case-apps c))])) (hash-map (coverage-unwrap cov) (λ (k v) v)))
(define (cover-case id name relation-coverage) (define-struct coverage (unwrap))
(hash-update! relation-coverage id apply-case (make-covered-case name 0)))
(define (covered-cases relation-coverage) (define (fresh-coverage relation)
(hash-map relation-coverage (λ (k v) v))) (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) (define (do-leaf-match name pat w/extras proc)
(let ([case-id (gensym)]) (let ([case-id (gensym)])
@ -788,7 +798,8 @@
other-matches) other-matches)
other-matches))))) other-matches)))))
name name
w/extras))) w/extras
case-id)))
(define-syntax (test-match stx) (define-syntax (test-match stx)
(syntax-case stx () (syntax-case stx ()
@ -1835,5 +1846,5 @@
(provide relation-coverage (provide relation-coverage
covered-cases covered-cases
fresh-coverage (rename-out [fresh-coverage make-coverage])
(struct-out covered-case)) coverage?)

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

@ -504,62 +504,62 @@
(get-output-string p) (get-output-string p)
(close-output-port p)))) (close-output-port p))))
;; check ;; redex-check
(let () (let ()
(define-language lang (define-language lang
(d 5) (d 5)
(e e 4) (e e 4)
(n number)) (n number))
(test (current-output (λ () (check lang d #f))) (test (current-output (λ () (redex-check lang d #f)))
"counterexample found after 1 attempts:\n5\n") "counterexample found after 1 attempts:\n5\n")
(test (check lang d #t) #t) (test (redex-check lang d #t) #t)
(test (check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t) (test (redex-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 (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t)
(test (current-output (λ () (check lang (d e) #f))) (test (current-output (λ () (redex-check lang (d e) #f)))
"counterexample found after 1 attempts:\n(5 4)\n") "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") "counterexample found after 1 attempts:\n5\n")
(test (parameterize ([check-randomness (make-random 0 0)]) (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 #:attempts 1
#:source (reduction-relation lang (--> 42 x)))) #:source (reduction-relation lang (--> 42 x))))
#t) #t)
(test (current-output (test (current-output
(λ () (λ ()
(parameterize ([check-randomness (make-random 0 0)]) (parameterize ([check-randomness (make-random 0 0)])
(check lang n (eq? 42 (term n)) (redex-check lang n (eq? 42 (term n))
#:attempts 1 #:attempts 1
#:source (reduction-relation lang (--> 0 x z)))))) #:source (reduction-relation lang (--> 0 x z))))))
"counterexample found (z) after 1 attempts:\n0\n") "counterexample found (z) after 1 attempts:\n0\n")
(test (current-output (test (current-output
(λ () (λ ()
(parameterize ([check-randomness (make-random 1)]) (parameterize ([check-randomness (make-random 1)])
(check lang d (eq? 42 (term n)) (redex-check lang d (eq? 42 (term n))
#:attempts 1 #:attempts 1
#:source (reduction-relation lang (--> 0 x z)))))) #:source (reduction-relation lang (--> 0 x z))))))
"counterexample found after 1 attempts:\n5\n") "counterexample found after 1 attempts:\n5\n")
(test (let ([r (reduction-relation lang (--> 0 x z))]) (test (let ([r (reduction-relation lang (--> 0 x z))])
(check lang n (number? (term n)) (redex-check lang n (number? (term n))
#:attempts 10 #:attempts 10
#:source r)) #:source r))
#t) #t)
(let () (let ()
(define-metafunction lang (define-metafunction lang
[(mf 0) 0] [(mf 0) 0]
[(mf 42) 0]) [(mf 42) 0])
(test (parameterize ([check-randomness (make-random 0 1)]) (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 #:attempts 1
#:source mf)) #:source mf))
#t)) #t))
(let () (let ()
(define-language L) (define-language L)
(test (with-handlers ([exn:fail? exn-message]) (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")) #rx"language for secondary source"))
(let () (let ()
(test (with-handlers ([exn:fail? exn-message]) (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")) #rx"x does not match n"))
(let ([stx-err (λ (stx) (let ([stx-err (λ (stx)
@ -570,15 +570,15 @@
(eval '(require "../reduction-semantics.ss" (eval '(require "../reduction-semantics.ss"
"rg.ss")) "rg.ss"))
(eval '(define-language empty)) (eval '(define-language empty))
(test (stx-err '(check empty any #t #:typo 3)) (test (stx-err '(redex-check empty any #t #:typo 3))
#rx"check: bad keyword syntax") #rx"redex-check: bad keyword syntax")
(test (stx-err '(check empty any #t #:attempts 3 #:attempts 4)) (test (stx-err '(redex-check empty any #t #:attempts 3 #:attempts 4))
#rx"bad keyword syntax") #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") #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") #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")))) #rx"bad keyword syntax"))))
;; check-metafunction-contract ;; 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 check-randomness (make-parameter random))
(define-syntax (check stx) (define-syntax (redex-check stx)
(syntax-case stx () (syntax-case stx ()
[(_ lang pat property . kw-args) [(_ lang pat property . kw-args)
(let-values ([(names names/ellipses) (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) [(attempts-stx source-stx)
(let loop ([args (syntax kw-args)] (let loop ([args (syntax kw-args)]
[attempts #f] [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)]) [attempts (or attempts-stx #'default-check-attempts)])
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([att attempts]) (let ([att attempts])
(assert-nat 'check att) (assert-nat 'redex-check att)
(or (check-property (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))]) (let ([lang-gen (generate lang (random-decisions lang))])
#,(if (not source-stx) #,(if (not source-stx)
#'null #'null
@ -694,16 +695,16 @@ To do a better job of not generating programs with free variables,
[else [else
#`(let ([r #,source-stx]) #`(let ([r #,source-stx])
(unless (reduction-relation? r) (unless (reduction-relation? r)
(raise-type-error 'check "reduction-relation" r)) (raise-type-error 'redex-check "reduction-relation" r))
(values (values
(map rewrite-proc-lhs (reduction-relation-make-procs r)) (map rewrite-proc-lhs (reduction-relation-make-procs r))
(reduction-relation-srcs r) (reduction-relation-srcs r)
(reduction-relation-lang r)))])]) (reduction-relation-lang r)))])])
(unless (eq? src-lang lang) (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))))) (zip (map lang-gen pats) srcs)))))
#,(and source-stx #'(test-match lang pat)) #,(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) (λ (_ bindings)
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...) (term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
property)) property))
@ -842,7 +843,7 @@ To do a better job of not generating programs with free variables,
(define generation-decisions (make-parameter random-decisions)) (define generation-decisions (make-parameter random-decisions))
(provide pick-from-list pick-var min-prods decisions^ pick-sequence-length (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 pick-nt unique-chars pick-any sexp generate-term parse-pattern
class-reassignments reassign-classes unparse-pattern class-reassignments reassign-classes unparse-pattern
(struct-out ellipsis) (struct-out mismatch) (struct-out class) (struct-out ellipsis) (struct-out mismatch) (struct-out class)

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

@ -9,7 +9,7 @@
build-reduction-relation build-reduction-relation
reduction-relation? reduction-relation?
empty-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)) (struct-out rule-pict))
(define-struct rule-pict (arrow lhs rhs label side-conditions fresh-vars pattern-binds)) (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 ;; 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 () (let ()
(define-values (type constructor predicate accessor mutator) (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 (values constructor
predicate predicate
(make-struct-field-accessor accessor 1 'name) (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 ;; lang : compiled-language
;; make-procs = (listof (compiled-lang -> proc)) ;; make-procs = (listof (compiled-lang -> proc))

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

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

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

205
collects/redex/redex.scrbl
View File

@ -47,9 +47,12 @@
#'((tech "term") args ...)] #'((tech "term") args ...)]
[x (identifier? #'x) #'(tech "term")])) [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} @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 PLT Redex consists of a domain-specific language for specifying
reduction semantics, plus a suite of tools for working with the 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. 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} @deftech{Debugging PLT Redex Programs}
It is easy to write grammars and reduction rules that are 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))] [expr (or/c any/c (listof any/c))]
[#:multiple? multiple? boolean? #f] [#:multiple? multiple? boolean? #f]
[#:pred pred [#:pred pred
(or/c (sexp -> any) (sexp term-node? any)) (or/c (-> sexp any)
(-> sexp term-node? any))
(lambda (x) #t)] (lambda (x) #t)]
[#:pp pp [#:pp pp
(or/c (any -> string) (or/c (any -> string)
(any output-port number (is-a?/c text%) -> void)) (any output-port number (is-a?/c text%) -> void))
default-pretty-printer] 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?]{ void?]{
This function opens a new window and inserts each expression 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. characters written to the port go to the end of the editor.
The @scheme[colors] argument, if provided, specifies a list of The @scheme[colors] argument, if provided, specifies a list of
reduction-name/color-string pairs. The traces gui will color reduction-name/color-list pairs. The traces gui will color arrows
arrows drawn because of the given reduction name with the drawn because of the given reduction name with the given color instead
given color instead of using the default color. 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 You can save the contents of the window as a postscript file
from the menus. 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?] @defproc[(stepper [reductions reduction-relation?]
[t any/c] [t any/c]
[pp (or/c (any -> string) [pp (or/c (any -> string)
@ -1146,6 +1321,24 @@ not colored specially.
Returns the expression in this node. 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?]{ @defproc[(term-node? [v any/c]) boolean?]{
Recognizes term nodes. Recognizes term nodes.

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

@ -7,8 +7,6 @@
"private/rg.ss" "private/rg.ss"
"private/error.ss") "private/error.ss")
#;(provide (all-from-out "private/rg.ss"))
(provide exn:fail:redex?) ;; from error.ss (provide exn:fail:redex?) ;; from error.ss
(provide reduction-relation (provide reduction-relation
@ -43,6 +41,11 @@
test-predicate test-predicate
test-results) test-results)
(provide redex-check
generate-term
check-metafunction
check-metafunction-contract)
(provide/contract (provide/contract
[current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))] [current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))]
[reduction-relation->rule-names (-> reduction-relation? (listof symbol?))] [reduction-relation->rule-names (-> reduction-relation? (listof symbol?))]
@ -61,4 +64,10 @@
(-> bindings? symbol? any) (-> bindings? symbol? any)
(-> bindings? symbol? (-> any) any))] (-> bindings? symbol? (-> any) any))]
[variable-not-in (any/c symbol? . -> . symbol?)] [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 normalize-path
filename-extension filename-extension
file-name-from-path file-name-from-path
path-only) path-only
some-system-path->string
string->some-system-path)
(define (simple-form-path p) (define (simple-form-path p)
(unless (path-string? p) (unless (path-string? p)
@ -113,18 +115,19 @@
(let loop ([path orig-path][rest '()]) (let loop ([path orig-path][rest '()])
(let-values ([(base name dir?) (split-path path)]) (let-values ([(base name dir?) (split-path path)])
(when simple? (when simple?
(when (or (and base (not (path? base))) (when (or (and base (not (path-for-some-system? base)))
(not (path? name))) (not (path-for-some-system? name)))
(raise-type-error who (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))) orig-path)))
(if (path? base) (if (path-for-some-system? base)
(loop base (cons name rest)) (loop base (cons name rest))
(cons name rest))))) (cons name rest)))))
(define (explode-path orig-path) (define (explode-path orig-path)
(unless (path-string? orig-path) (unless (or (path-string? orig-path)
(raise-type-error 'explode-path "path or 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)) (do-explode-path 'explode-path orig-path #f))
;; Arguments must be in simple form ;; Arguments must be in simple form
@ -143,20 +146,22 @@
filename))) filename)))
(define (file-name who name) (define (file-name who name)
(unless (path-string? name) (unless (or (path-string? name)
(raise-type-error who "path or 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)]) (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) (define (file-name-from-path name)
(file-name 'file-name-from-path name)) (file-name 'file-name-from-path name))
(define (path-only name) (define (path-only name)
(unless (path-string? name) (unless (or (path-string? name)
(raise-type-error 'path-only "path or 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)]) (let-values ([(base file dir?) (split-path name)])
(cond [dir? name] (cond [dir? (if (string? name) (string->path name) name)]
[(path? base) base] [(path-for-some-system? base) base]
[else #f]))) [else #f])))
;; name can be any string; we just look for a dot ;; name can be any string; we just look for a dot
@ -165,3 +170,18 @@
[name (and name (path->bytes name))]) [name (and name (path->bytes name))])
(cond [(and name (regexp-match #rx#"[.]([^.]+)$" name)) => cadr] (cond [(and name (regexp-match #rx#"[.]([^.]+)$" name)) => cadr]
[else #f]))) [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 [else
(reverse (cons args accum))]))) (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) (define (do-localize orig-id validate-local-member-stx)
(let loop ([id orig-id]) (let loop ([id orig-id])

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

@ -51,7 +51,48 @@ improve method arity mismatch contract violation error messages?
#,(syntax-span id)) #,(syntax-span id))
#,(format "~s" (syntax->datum 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-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) (define-for-syntax (head-expand-all body-stxs)
(for/list ([stx body-stxs]) (for/list ([stx body-stxs])
(local-expand stx (local-expand stx
@ -265,7 +275,7 @@ improve method arity mismatch contract violation error messages?
(values unprotected-id ... protected-id ...)))) (values unprotected-id ... protected-id ...))))
contract-def ... contract-def ...
(define-syntax protected-id (define-syntax protected-id
(make-with-contract-transformer (make-contracted-transformer
(quote-syntax contract) (quote-syntax contract)
(quote-syntax id) (quote-syntax id)
blame-str)) ...)))))] blame-str)) ...)))))]
@ -332,48 +342,6 @@ improve method arity mismatch contract violation error messages?
provide-stx provide-stx
id))))) 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 ...) ;; (provide/contract p/c-ele ...)
;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...) ;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...)
;; provides each `id' with the contract `expr'. ;; provides each `id' with the contract `expr'.
@ -861,9 +829,9 @@ improve method arity mismatch contract violation error messages?
(list) (list)
(list #'(define contract-id (verify-contract 'provide/contract ctrct)))) (list #'(define contract-id (verify-contract 'provide/contract ctrct))))
(define-syntax id-rename (define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id) (make-contracted-transformer (quote-syntax contract-id)
(quote-syntax id) (quote-syntax id)
(quote-syntax pos-module-source))) (quote-syntax pos-module-source)))
(provide (rename-out [id-rename external-name]))))]) (provide (rename-out [id-rename external-name]))))])

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

@ -405,33 +405,70 @@
;; ---------------------------------------- ;; ----------------------------------------
(define copied-srcs (make-hash))
(define copied-dests (make-hash))
(define/public (install-file fn) (define/public (install-file fn)
(if refer-to-existing-files (if refer-to-existing-files
(if (string? fn) (if (string? fn)
(string->path fn) (string->path fn)
fn) fn)
(let ([src-dir (path-only fn)] (let ([normalized (normal-case-path (simplify-path (path->complete-path fn)))])
[dest-dir (get-dest-directory #t)] (or (hash-ref copied-srcs normalized #f)
[fn (file-name-from-path fn)]) (let ([src-dir (path-only fn)]
(let ([src-file (build-path (or src-dir (current-directory)) fn)] [dest-dir (get-dest-directory #t)]
[dest-file (build-path (or dest-dir (current-directory)) fn)]) [fn (file-name-from-path fn)])
(unless (and (file-exists? dest-file) (let ([src-file (build-path (or src-dir (current-directory)) fn)]
(call-with-input-file* [dest-file (build-path (or dest-dir (current-directory)) fn)]
src-file [next-file-name (lambda (dest)
(lambda (src) (let-values ([(base name dir?) (split-path dest)])
(call-with-input-file* (build-path
dest-file base
(lambda (dest) (let ([s (path-element->string (path-replace-suffix name #""))])
(or (equal? (port-file-identity src) (let ([n (regexp-match #rx"^(.*)_([0-9]+)$" s)])
(port-file-identity dest)) (format "~a_~a~a"
(let loop () (if n (cadr n) s)
(let ([s (read-bytes 4096 src)] (if n (add1 (string->number (caddr n))) 2)
[d (read-bytes 4096 dest)]) (let ([ext (filename-extension name)])
(and (equal? s d) (if ext
(or (eof-object? s) (loop))))))))))) (bytes-append #"." ext)
(when (file-exists? dest-file) (delete-file dest-file)) ""))))))))])
(copy-file src-file dest-file)) (let-values ([(dest-file normalized-dest-file)
(path->string fn))))) (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*
dest-file
(lambda (dest)
(or (equal? (port-file-identity src)
(port-file-identity dest))
(let loop ()
(let ([s (read-bytes 4096 src)]
[d (read-bytes 4096 dest)])
(and (equal? s d)
(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))
(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?]{ void?]{
Takes a filter procedure and changes the container's list of 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. object using a color name.
@defconstructor*/make[(([red (integer-in 0 255)] @defconstructor*/make[(()
([red (integer-in 0 255)]
[green (integer-in 0 255)] [green (integer-in 0 255)]
[blue (integer-in 0 255)]) [blue (integer-in 0 255)])
([color-name string?]))]{ ([color-name string?]))]{
Creates a new color with the given RGB values, or matching the given Creates a new color with the given RGB values, or matching the given
color name (using ``black'' if the name is not recognized). See color name (using ``black'' if no color is given or if the name is
@scheme[color-database<%>] for more information on color names. 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)])) [alignment '(center center)]))
(code:comment #, @t{Add @onscreen{Cancel} and @onscreen{Ok} buttons to the horizontal panel}) (code:comment #, @t{Add @onscreen{Cancel} and @onscreen{Ok} buttons to the horizontal panel})
(new button% [parent parent] [label "Cancel"]) (new button% [parent panel] [label "Cancel"])
(new button% [parent parent] [label "Ok"]) (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}) (code:comment #, @t{Show the dialog})
(send dialog #,(:: dialog% show) #t) (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 case @scheme[string->path] can produce the same path for different
@scheme[str]s. See also @scheme[string->path-element], which should be @scheme[str]s. See also @scheme[string->path-element], which should be
used instead of @scheme[string->path] when a string represents a 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?] @defproc[(bytes->path [bstr bytes?]
[type (or/c 'unix 'windows) (system-path-convention-type)]) [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], (such as pathless file names), use @scheme[path-element->string],
instead, to avoid special encodings use to represent some relative instead, to avoid special encodings use to represent some relative
paths. See @secref["windowspaths"] for specific information about 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?]{ @defproc[(path->bytes [path path?]) bytes?]{
@ -494,21 +498,22 @@ to the end.}
@note-lib[scheme/path] @note-lib[scheme/path]
@defproc[(explode-path [path path-string?]) @defproc[(explode-path [path (or/c path-string? path-for-some-system?)])
(listof (or/c path? 'up 'same))]{ (listof (or/c path-for-some-system? 'up 'same))]{
Returns the list of path element that constitute @scheme[path]. If Returns the list of path element that constitute @scheme[path]. If
@scheme[path] is simplified in the sense of @scheme[simple-form-path], @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 then the result is always a list of paths, and the first element of
the list is a root.} 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] Returns the last element of @scheme[path]. If @scheme[path]
syntactically a directory path (see @scheme[split-path]), then then syntactically a directory path (see @scheme[split-path]), then then
result is @scheme[#f].} 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)]{ (or/c bytes? #f)]{
Returns a byte string that is the extension part of the filename in 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 syntactically a directory (see @scheme[split-path]) or if the path has
no extension, @scheme[#f] is returned.} 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 Finds a relative pathname with respect to @scheme[basepath] that names
the same file or directory as @scheme[path]. Both @scheme[basepath] 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, path contains an embedded path for a non-existent directory,
or if an infinite cycle of soft links is detected.} 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 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?]{ @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 ensures that the result is a complete path containing no up- or
same-directory indicators.} 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["unix-paths.scrbl"]
@include-section["windows-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[]} @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)]{ @defproc[(syntax-local-name) (or/c symbol? #f)]{
Returns an inferred name for the expression position being 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.} 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-syntax require-spec ...)]{See @scheme[require] and @scheme[provide].}
@defform[(for-template 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].} @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) (lambda (w e)
(purge-marked/update-headers))) (purge-marked/update-headers)))
(send global-keymap add-function "gc" (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" (send global-keymap add-function "show-memory-graph"
(lambda (w e) (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

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

@ -32,9 +32,9 @@
This @tt{universe.ss} teachpack implements and provides the functionality This @tt{universe.ss} teachpack implements and provides the functionality
for creating interactive, graphical programs that consist of plain 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 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 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 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 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 domain; it is suited for a novice who knows how to design conditional
functions for symbols. The second half of the documentation focuses on 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 programs register with the server, etc. The last two sections show how to
design a simple universe of two communicating worlds. 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"] @image["nuworld.png"]
The @scheme[big-bang] form installs @scheme[World_0] as the initial The @scheme[big-bang] form installs @scheme[World_0] as the initial @tech{WorldState}.
world. The handlers @scheme[tock], @scheme[react], and @scheme[click] transform The handlers @scheme[tock], @scheme[react], and @scheme[click] transform
one world into another one; each time an event is handled, @scheme[done] is 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 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 shut down; and finally, @scheme[draw] renders each world as a scene, which
is then displayed on an external canvas. 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 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 this collection of data, using a capital W to distinguish it from the
program. In principle, there are no constraints on this data program. In principle, there are no constraints on this data
definition though it mustn't be an instance of the @tech{Package} 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 starts a @tech{world} program in the initial state specified with
@scheme[state-expr], which must of course evaluate to an element of @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 designated in the optional @scheme[spec] clauses, especially how the
@tech{world} program deals with clock ticks, with key events, with mouse @tech{world} program deals with clock ticks, with key events, with mouse
events, and eventually with messages from the universe; how it renders 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{ @item{
@defform[(on-tick tick-expr) @defform[(on-tick tick-expr)
#:contracts #: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 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 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{ @item{
@defform/none[(on-tick tick-expr rate-expr) @defform/none[(on-tick tick-expr rate-expr)
#:contracts #:contracts
([tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))] ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))]
[rate-expr natural-number/c])]{ [rate-expr natural-number/c])]{
tell DrScheme to call the @scheme[tick-expr] function on the current 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 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) @defform[(on-key change-expr)
#:contracts #: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 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 @tech{KeyEvent} for every keystroke the user of the computer makes. The result
of the call becomes the current world. of the call becomes the current world.
@ -288,7 +288,7 @@ All @tech{MouseEvent}s are represented via symbols:
@defform[(on-mouse clack-expr) @defform[(on-mouse clack-expr)
#:contracts #:contracts
([clack-expr ([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 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 @scheme[x] and @scheme[y] coordinates of the mouse, and and a
@tech{MouseEvent} for every (noticeable) action of the mouse by the @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) @defform[(on-draw render-expr)
#:contracts #:contracts
([render-expr (-> (unsyntax @tech{World}) scene?)])]{ ([render-expr (-> (unsyntax @tech{WorldState}) scene?)])]{
tell DrScheme to call the function @scheme[render-expr] whenever the 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 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) @defform/none[(on-draw render-expr width-expr height-expr)
#:contracts #:contracts
([render-expr (-> (unsyntax @tech{World}) scene?)] ([render-expr (-> (unsyntax @tech{WorldState}) scene?)]
[width-expr natural-number/c] [width-expr natural-number/c]
[height-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?) @defform[(stop-when last-world?)
#:contracts #: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 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 drawn. If this call produces @scheme[true], the world program is shut
down. Specifically, the clock is stopped; no more 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 Simulating any dynamic behavior via a @tech{world} program demands two
different activities. First, we must tease out those portions of our different activities. First, we must tease out those portions of our
domain that change over time or in reaction to actions, and we must 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 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 information in the real world and vice versa. For all others aspects of
the world, we use global constants, including graphical or visual 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 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, for one aspect, key presses for another, and mouse movements for a third,
we must develop functions that map the current state of the 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 world. Put differently, we have just created a wish list with three
handler functions that have the following general contract and purpose handler functions that have the following general contract and purpose
statements: statements:
@ -455,16 +456,16 @@ Second, we must translate the actions in our domain---the arrows in the
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
;; tick : @tech{D} -> @tech{D} ;; tick : WorldState -> WorldState
;; deal with the passing of time ;; deal with the passing of time
(define (tick w) ...) (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} ;; deal with a mouse click at @emph{(x,y)} of kind @emph{me}
;; in the current world @emph{w} ;; in the current world @emph{w}
(define (click w x y me) ...) (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} ;; deal with a key event (symbol, char) @emph{ke}
;; in the current world @emph{w} ;; in the current world @emph{w}
(define (control w ke) ...) (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 the door is whether it is locked, unlocked but closed, or open. We use
three symbols to represent the three states: three symbols to represent the three states:
@deftech{SD} : state of door
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
;; The state of the door (SD) is one of: ;; WorldState is one of:
;; -- @scheme['locked] ;; -- @scheme['locked]
;; -- @scheme['closed] ;; -- @scheme['closed]
;; -- @scheme['open] ;; -- @scheme['open]
;; interpretation: state of door
)) ))
Symbols are particularly well-suited here because they directly express 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 Let's start with @emph{automatic-closer}. Since @emph{automatic-closer}
@tech{D} and @emph{automatic-closer} for @emph{tick}, we get its contract, acts as the @scheme[on-tick] handler, we get its contract,
and it is easy to refine the purpose statement, too: and it is easy to refine the purpose statement, too:
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
;; automatic-closer : @tech{SD} -> @tech{SD} ;; automatic-closer : WorldState -> WorldState
;; closes an open door over the period of one tick ;; closes an open door over the period of one tick
(define (automatic-closer state-of-door) ...) (define (automatic-closer state-of-door) ...)
)) ))
@ -560,7 +560,7 @@ and it is easy to refine the purpose statement, too:
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
;; automatic-closer : @tech{SD} -> @tech{SD} ;; automatic-closer : WorldState -> WorldState
;; closes an open door over the period of one tick ;; closes an open door over the period of one tick
(check-expect (automatic-closer 'locked) 'locked) (check-expect (automatic-closer 'locked) 'locked)
@ -604,7 +604,7 @@ For the remaining three arrows of the diagram, we design a function that
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
;; door-actions : @tech{SD} @tech{KeyEvent} -> @tech{SD} ;; door-actions : WorldState @tech{KeyEvent} -> WorldState
;; key events simulate actions on the door ;; key events simulate actions on the door
(define (door-actions s k) ...) (define (door-actions s k) ...)
)) ))
@ -644,7 +644,7 @@ purpose:
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
;; render : @tech{SD} -> @tech{scene} ;; render : WorldState -> @tech{scene}
;; translate the current state of the door into a large text ;; translate the current state of the door into a large text
(define (render s) (define (render s)
(text (symbol->string s) 40 'red)) (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 Each world-producing callback in a world program---those for handling clock
tick events, keyboard events, and mouse events---may produce a 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 and a message from a @tech{world} program to the @tech{server}. Because
programs only send messages via @tech{Package}, the teachpack does not programs only send messages via @tech{Package}, the teachpack does not
provide the selectors for the structure, only the constructor and a 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}.} determine whether @scheme[x] is a @tech{Package}.}
@defproc[(make-package [w any/c][m sexp?]) 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: here are the revised specifications:
@defform/none[(on-tick tick-expr) @defform/none[(on-tick tick-expr)
#:contracts #: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) @defform/none[(on-tick tick-expr rate-expr)
#:contracts #: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])]{ [rate-expr natural-number/c])]{
} }
@defform/none[(on-key change-expr) @defform/none[(on-key change-expr)
#:contracts #: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) @defform/none[(on-mouse clack-expr)
#:contracts #:contracts
([clack-expr ([clack-expr
(-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) (-> (unsyntax @tech{WorldState}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent})
(or/c (unsyntax @tech{World}) package?))])]{ (or/c (unsyntax @tech{WorldState}) package?))])]{
} }
If one of these event handlers produces a @tech{Package}, the content of the world 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 field becomes the next world and the message field specifies what the
world sends to the universe. This distinction also explains why the data 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} @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) @defform[(on-receive receive-expr)
#:contracts #: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 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{WorldState} and the received message. The result of the call becomes the current
@tech{World}. @tech{WorldState}.
Because @scheme[receive-expr] is (or evaluates to) a world-transforming Because @scheme[receive-expr] is (or evaluates to) a world-transforming
function, it too can produce a @tech{Package} instead of just a 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}.} sent to the @tech{server}.}
The diagram below summarizes the extensions of this section in graphical form. 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 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 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 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 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 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 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, 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 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. the receiving @tech{server} or @tech{world} program take care of them.
@; ----------------------------------------------------------------------------- @; -----------------------------------------------------------------------------
@section[#:tag "universe-server"]{The Universe Server} @section[#:tag "universe-server"]{The Universe Server}
A @deftech{server} is the central control program of a @tech{universe} and A @deftech{server} is the central control program of a @tech{universe} and
deals with receiving and sending of messages between the world deals with receiving and sending of messages between the world
programs that participate in the @tech{universe}. Like a @tech{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 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} events than @tech{world}s. The two primary kinds of events are the
program joins the @tech{universe} that the server controls and when a appearance of a new @tech{world} program in the @tech{universe}
@tech{world} sends a message. and the receipt of a message from a @tech{world} program.
The teachpack provides a mechanism for designating event handlers for The teachpack provides a mechanism for designating event handlers for
servers that is quite similar to the mechanism for describing @tech{world} 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} @subsection{Worlds and Messages}
Understanding the server's event handling functions demands three Understanding the server's event handling functions demands several data
concepts. representations: that of (a connection to) a @tech{world} program and that
of a response of a handler to an event.
@itemize[ @itemize[
@ -915,6 +915,9 @@ Understanding the server's event handling functions demands three
@defproc[(world=? [u world?][v world?]) boolean?]{ @defproc[(world=? [u world?][v world?]) boolean?]{
compares two @emph{world}s for equality.} 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[world1 world?]{a world for testing your programs}
@defthing[world2 world?]{another world for testing your programs} @defthing[world2 world?]{another world for testing your programs}
@defthing[world3 world?]{and a third one} @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 @item{Each event handler produces a @emph{bundle}, which is a structure
world. The teachpack provides only a predicate and a constructor for these that contains the list of @emph{world}s to keep track of; the
structures: @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?]{ @defproc[(mail? [x any/c]) boolean?]{
determines whether @scheme[x] is a @emph{mail}.} 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}.} 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} @subsection{Universe Descriptions}
A @tech{server} keeps track of information about the @tech{universe} that 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 it manages. One kind of tracked information is obviously the collection of
represented depends on the situation and the programmer, just as with participating world programs, but in general the kind of information that
@tech{world} programs. 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 @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 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 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. according to the design recipe for this data definition.
The @tech{server} itself is created with a description that includes the 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 messages from one world to the rest of the registered worlds, and how it
renders its current state as a string.} 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 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 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 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 especially useful during the integration of the various pieces of a
distributed program. distributed program.
The mandatory clauses of a @scheme[universe] server description are
Now it is possible to explain the clauses in a @scheme[universe] server @scheme[on-new] and @scheme[on-msg]:
description. Two of them are mandatory:
@itemize[ @itemize[
@item{ @item{
@defform[(on-new new-expr) @defform[(on-new new-expr)
#:contracts #:contracts
([new-expr (-> (unsyntax @tech{Universe}) world? ([new-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? bundle?)])]{
(cons (unsyntax @tech{Universe}) [listof mail?]))])]{
tell DrScheme to call the function @scheme[new-expr] every time another world joins the 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{ @item{
@defform[(on-msg msg-expr) @defform[(on-msg msg-expr)
#:contracts #:contracts
([msg-expr (-> (unsyntax @tech{Universe}) world? sexp? ([msg-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? sexp? bundle?)])]{
(cons (unsyntax @tech{Universe}) [listof mail?]))])]{
tell DrScheme to apply @scheme[msg-expr] to the current state of the universe, the world tell DrScheme to apply @scheme[msg-expr] to the list of currently
that sent the message, and the message itself. The handler must produce a state of the participating worlds @scheme[low], the current state of the universe, the world
universe and a list of mails.} @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. 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 In addition to the mandatory handlers, a program may wish to add some
optional handlers: optional handlers:
@ -1039,36 +1055,37 @@ optional handlers:
@item{ @item{
@defform/none[(on-tick tick-expr) @defform/none[(on-tick tick-expr)
#:contracts #:contracts
([tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{ ([tick-expr (-> [listof world?] (unsyntax @tech{UniverseState}) bundle?)])]{
tell DrScheme to apply @scheme[tick-expr] to the current state of the tell DrScheme to apply @scheme[tick-expr] to the current list of
universe. The handler is expected to produce a bundle of the new state of participating worlds and the current state of the
the universe and a list of mails. universe.
} }
@defform/none[(on-tick tick-expr rate-expr) @defform/none[(on-tick tick-expr rate-expr)
#:contracts #:contracts
([tick-expr (-> (unsyntax @tech{Universe}) bundle?)] ([tick-expr (-> [listof world?] (unsyntax @tech{UniverseState}) bundle?)]
[rate-expr natural-number/c])]{ [rate-expr natural-number/c])]{
tell DrScheme to apply @scheme[tick-expr] as above but use the specified tell DrScheme to apply @scheme[tick-expr] as above but use the specified
clock tick rate instead of the default. clock tick rate instead of the default.
} }
} }
@item{ @item{
@defform[(on-disconnect dis-expr) @defform[(on-disconnect dis-expr)
#:contracts #: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 tell DrScheme to invoke @scheme[dis-expr] every time a participating
@tech{world} drops its connection to the server. The first argument is the @tech{world} drops its connection to the server. The first two arguments
current state of the universe; the second one is the world that got are the current list of participating worlds and the state of the
disconnected. universe; the third one is the world that got disconnected.
} }
} }
@item{ @item{
@defform[(to-string render-expr) @defform[(to-string render-expr)
#:contracts #: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 tell DrScheme to render the state of the universe after each event and to
display this string in the universe console. 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 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 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 of computers and networks, however, we may assume little else. Our network
connections ensure that if some @tech{world} sends two messages in some connections ensure that if some @tech{world} or the @tech{server} sends
order, they arrive in the same order at the server. In contrast, it is two messages to the @emph{same} place in some order, they arrive in the
generally impossible to ensure whether one world joins before another or same order (if they arrive at all). In contrast, if two distinct
whether a message from one world gets to the server before another world's @tech{world} programs send one message each, the network does not
message gets there. It is therefore the designer's task to establish a guarantee the order of arrival at the server; similarly, if the
protocol that enforces a certain order onto a universe and this activity @tech{server} is asked to send some messages to several distinct
is called @emph{protocol design}. @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 From the perspective of the @tech{universe}, the design of a protocol is
about the design of data representations for tracking universe information about the design of data representations for tracking universe information
in the server and the participating worlds and the design of a data 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 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 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 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 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[ @itemize[
@item{a data definition for the information about the universe that the @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 @item{a data definition for the world(s) about their current relationship
to the universe;} to the universe;}
@item{data definitions for the messages that are sent from the server to @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 the worlds and vice versa. Let's call them @deftech{S2W} for messages
from the server to the worlds and @deftech{MsgW2S} for the other direction; 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.} 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 state of the world. A good tool for writing down these agreements is an
interaction diagram. 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 The design of the protocol, especially the data definitions, have direct
implications for the design of event handling functions. For example, in 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 @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
;; @tech{Universe} World -> (make-bundle @tech{Universe} [Listof mail?]) ;; Bundle is
;; create new @tech{Universe} when world w is joining the universe, ;; (make-bundle [Listof world?] UniverseState [Listof mail?])
;; which is in state s; also send mails as needed
;; [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) ...) (define (add-world s w) ...)
;; @tech{Universe} World MsgW2U -> (make-bundle @tech{Universe} [Listof mail?]) ;; [Listof world?] UniverseState world? W2U -> Bundle
;; create new @tech{Universe} when world w is sending message m ;; compute next list of worlds and new @tech{UniverseState}
;; to universe in state s; also send mails as needed ;; when world w is sending message m to universe in state s
(define (process s p m) ...) (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 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 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 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 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. 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}, While there are many different useful ways of representing such a
we choose to introduce @tech{Universe} as a list of @tech{world}s, and we @tech{universe}, we just use the list of @emph{worlds} that is handed to
interpret non-empty lists as those where the first @tech{world} is active and the each handler and that handlers return via their bundles. The
remainder are the passive @tech{world}s. As for the two possible events, @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[ @itemize[
@item{it is natural to add new @tech{world}s to the end of the list; and} @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 which it may ignore. When it is done with its turn, it will send a
message. 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} @subsection{Designing the Ball Server}
@ -1249,7 +1321,7 @@ The preceding subsection dictates that our server program starts like this:
[schemeblock [schemeblock
;; teachpack: universe.ss ;; teachpack: universe.ss
;; Universe is [Listof world?] ;; UniverseState is '*
;; StopMessage is 'done. ;; StopMessage is 'done.
;; GoMessage is 'it-is-your-turn. ;; GoMessage is 'it-is-your-turn.
]) ])
@ -1264,24 +1336,23 @@ The preceding subsection dictates that our server program starts like this:
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
[schemeblock [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 ;; add world w to the universe, when server is in state u
(define (add-world u w) ...) (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 ;; world w sent message m when server is in state u
(define (switch u w m) ...) (define (switch u w m) ...)
]) ])
Although we could have re-used the generic contracts from this Although we could have re-used the generic contracts from this
documentation, we also know from our protocol that our server sends a documentation, we also know from our protocol that our server sends a
message to exactly one world. For this reason, both functions return the message to exactly one world. Note how these contracts are just refinements
same kind of result: a bundle that contains the new state of the server of the generic ones. (A type-oriented programmer would say that the
(@tech{Universe}) and a list that contains a single mail. These contracts contracts here are subtypes of the generic ones.)
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: 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 [schemeblock
;; an obvious example for adding a world: ;; an obvious example for adding a world:
(check-expect (check-expect
(add-world '() world1) (add-world '() '* world1)
(make-bundle (list world1) (make-bundle (list world1)
'*
(list (make-mail world1 'it-is-your-turn)))) (list (make-mail world1 'it-is-your-turn))))
;; an example for receiving a message from the active world: ;; an example for receiving a message from the active world:
(check-expect (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) (make-bundle (list world2 world1)
'*
(list (make-mail world2 'it-is-your-turn)))) (list (make-mail world2 'it-is-your-turn))))
]) ])
@ -1310,23 +1383,24 @@ Exercise: Create additional examples for the two functions based on our
protocol. protocol.
The protocol tells us that @emph{add-world} just adds the given The protocol tells us that @emph{add-world} just adds the given
@emph{world} structure---recall that this a data representation of the @emph{world} structure---recall that this a data representation of the
actual @tech{world} program---to the @tech{Universe} and then sends a 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: message to the first world on this list to get things going:
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
[schemeblock [schemeblock
(define (add-world univ wrld) (define (add-world univ state wrld)
(local ((define univ* (append univ (list wrld)))) (local ((define univ* (append univ (list wrld))))
(make-bundle univ* (make-bundle univ*
'*
(list (make-mail (first univ*) 'it-is-your-turn))))) (list (make-mail (first univ*) 'it-is-your-turn)))))
]) ])
Because @emph{univ*} contains at least @emph{wrld}, it is acceptable to Because @emph{univ*} contains at least @emph{wrld}, it is acceptable to
create a mail to @scheme[(first univ*)]. Of course, this same reasoning 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 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 Similarly, the protocol says that when @emph{switch} is invoked because a
@tech{world} program sends a message, the data representation of the @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 @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
[schemeblock [schemeblock
(define (switch univ wrld m) (define (switch univ state wrld m)
(local ((define univ* (append (rest univ) (list (first univ))))) (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 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} that there is at least this one world on this list. It is therefore
(state). It is therefore acceptable to create a mail for this world. acceptable to create a mail for this world.
Exercise: The function definition simply assumes that @emph{wrld} is Exercise: The function definition simply assumes that @emph{wrld} is
@scheme[world=?] to @scheme[(first univ)] and that the received message @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, depends on the context. For now, stop the @tech{universe} at this point,
but consider alternative solutions, too.) 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} @subsection{Designing the Ball World}
@ -1371,31 +1453,35 @@ The final step is to design the ball @tech{world}. Recall that each world
(schemeblock (schemeblock
;; teachpack: universe.ss ;; teachpack: universe.ss
;; World is one of ;; WorldState is one of:
;; -- Number %% representing the @emph{y} coordinate ;; -- Number %% representing the @emph{y} coordinate
;; -- @scheme['resting] ;; -- @scheme['resting]
(define WORLD0 '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 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: imply a number of contract and purpose statements:
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
;; World GoMessage -> World or (make-package World StopMessage) ;; WorldState GoMessage -> WorldResult
;; make sure the ball is moving ;; make sure the ball is moving
(define (receive w n) ...) (define (receive w n) ...)
;; World -> World or (make-package World StopMessage) ;; WorldState -> WorldResult
;; move this ball upwards for each clock tick ;; move this ball upwards for each clock tick
;; or stay @scheme['resting] ;; or stay @scheme['resting]
(define (move w) ...) (define (move w) ...)
;; World -> Scene ;; WorldState -> Scene
;; render the world as a scene ;; render the world as a scene
(define (render w) ...) (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 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 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 create a good set of functional examples, exploiting the structure of the
data organization of @tech{World}: data organization of @tech{WorldState}:
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
@ -1458,7 +1544,7 @@ the scene every time @scheme['it-is-your-turn] is received. Design this function
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
; World -> World or @scheme[(make-package 'resting 'done)] ; WorldState -> WorldState or @scheme[(make-package 'resting 'done)]
; move the ball if it is flying ; move the ball if it is flying
(check-expect (move 'resting) 'resting) (check-expect (move 'resting) 'resting)
@ -1498,7 +1584,7 @@ Finally, here is the third function, which renders the state as a scene:
@(begin @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
; World -> Scene ; WorldState -> Scene
; render the state of the world as a scene ; render the state of the world as a scene
(check-expect (render HEIGHT) (place-image BALL 50 HEIGHT MT)) (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 @(begin
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
; String -> (World -> Scene) ; String -> (WorldState -> Scene)
; render the state of the world as a scene ; render the state of the world as a scene
(check-expect (check-expect
@ -1545,7 +1631,7 @@ Finally, here is the third function, which renders the state as a scene:
#reader scribble/comment-reader #reader scribble/comment-reader
(schemeblock (schemeblock
; String -> World ; String -> WorldState
; create and hook up a world with the @scheme[LOCALHOST] server ; create and hook up a world with the @scheme[LOCALHOST] server
(define (create-world name) (define (create-world name)
(big-bang WORLD0 (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) (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 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 "async-channel.ss")
(load-in-sandbox "restart.ss") (load-in-sandbox "restart.ss")
(load-in-sandbox "string-mzlib.ss") (load-in-sandbox "string-mzlib.ss")
(load-in-sandbox "pathlib.ss")
(load-in-sandbox "filelib.ss") (load-in-sandbox "filelib.ss")
(load-in-sandbox "portlib.ss") (load-in-sandbox "portlib.ss")
(load-in-sandbox "threadlib.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]{ dispatcher/c]{
Returns a dispatcher that prints memory usage on every request. 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?} @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 Refer to @secref["limit.ss"].
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.

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

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

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

@ -321,7 +321,7 @@ void wxMediaLine::Delete(wxMediaLine **root)
else else
x = v->right; x = v->right;
x->parent = v->parent; x->parent = v->parent; /* x could be NIL; fixup at end */
if (PTREQ(v->parent, NIL)) if (PTREQ(v->parent, NIL))
*root = x; *root = x;
@ -448,6 +448,11 @@ void wxMediaLine::Delete(wxMediaLine **root)
SET_BLACK(x); SET_BLACK(x);
} }
if (PTRNE(NIL->parent, NIL)) {
/* fixup: we set NIL's parent above */
NIL->parent = NIL;
}
right = left = NIL; right = left = NIL;
DELETE_OBJ this; DELETE_OBJ this;
} }
@ -594,7 +599,8 @@ wxMediaParagraph *wxMediaLine::GetParagraphStyle(Bool *first)
} else { \ } else { \
node = node->parent; \ node = node->parent; \
} \ } \
} \ }
void wxMediaLine::SetLength(long len) 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_expr(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_context(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_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 *make_introducer(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_make_delta_introduce(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[]); 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-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-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-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; 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, 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_Lift_Capture_Proc *pp;
Scheme_Object *vec; 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 = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc));
*pp = cp; *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)[0] = scheme_null;
SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp; SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp;
SCHEME_VEC_ELS(vec)[2] = data; SCHEME_VEC_ELS(vec)[2] = data;
SCHEME_VEC_ELS(vec)[3] = end_stmts; SCHEME_VEC_ELS(vec)[3] = end_stmts;
SCHEME_VEC_ELS(vec)[4] = context_key; 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; 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) Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env)
{ {
return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0]; 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]; 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) void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env)
{ {
Scheme_Object **ns, **vs; Scheme_Object **ns, **vs;
@ -4748,6 +4784,10 @@ local_lift_expr(int argc, Scheme_Object *argv[])
env = env->next; env = env->next;
} }
if (env)
if (SCHEME_FALSEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0]))
env = NULL;
if (!env) if (!env)
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"syntax-local-lift-expression: no lift target"); "syntax-local-lift-expression: no lift target");
@ -4851,6 +4891,61 @@ local_lift_end_statement(int argc, Scheme_Object *argv[])
return scheme_void; 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 * static Scheme_Object *
make_set_transformer(int argc, Scheme_Object *argv[]) 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); name = scheme_get_proc_name((Scheme_Object *)proc, &namelen, 1);
#endif #endif
} else if (SCHEME_STRUCTP(proc)) {
name = (const char *)proc;
mina = -1;
maxa = 0;
} else { } else {
Scheme_Closure_Data *data; 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; int writeable, for_eval, rename, enforce_consts, comp_flags;
Scheme_Env *genv; Scheme_Env *genv;
Scheme_Compile_Info rec, rec2; Scheme_Compile_Info rec, rec2;
Scheme_Object *o, *tl_queue; Scheme_Object *o, *rl, *tl_queue;
Scheme_Compilation_Top *top; Scheme_Compilation_Top *top;
Resolve_Prefix *rp; Resolve_Prefix *rp;
Resolve_Info *ri; Resolve_Info *ri;
@ -4973,7 +4973,8 @@ static void *compile_k(void)
find one, break it up to eval first expression find one, break it up to eval first expression
before the rest. */ before the rest. */
while (1) { 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, form = scheme_check_immediate_macro(form,
cenv, &rec, 0, cenv, &rec, 0,
0, &gval, NULL, NULL); 0, &gval, NULL, NULL);
@ -4989,10 +4990,13 @@ static void *compile_k(void)
} else } else
break; break;
} else { } else {
rl = scheme_frame_get_require_lifts(cenv);
o = scheme_frame_get_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_make_pair(form, tl_queue);
tl_queue = scheme_append(o, tl_queue); tl_queue = scheme_append(o, tl_queue);
tl_queue = scheme_append(rl, tl_queue);
form = SCHEME_CAR(tl_queue); form = SCHEME_CAR(tl_queue);
tl_queue = SCHEME_CDR(tl_queue); tl_queue = SCHEME_CDR(tl_queue);
} }
@ -5010,7 +5014,8 @@ static void *compile_k(void)
Scheme_Object *l, *prev_o = NULL; Scheme_Object *l, *prev_o = NULL;
while (1) { 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); 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, /* If any definitions were lifted in the process of compiling o,
we need to fold them in. */ we need to fold them in. */
l = scheme_frame_get_lifts(cenv); l = scheme_frame_get_lifts(cenv);
if (!SCHEME_NULLP(l)) { rl = scheme_frame_get_require_lifts(cenv);
l = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0), if (!SCHEME_NULLP(l)
l); || !SCHEME_NULLP(rl)) {
form = scheme_datum_to_syntax(l, scheme_false, scheme_false, 0, 0); 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; prev_o = o;
} else } else
break; break;
@ -6213,7 +6221,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
context_key = scheme_generate_lifts_key(); 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) { if (rec[drec].comp) {
scheme_init_compile_recs(rec, drec, recs, 2); scheme_init_compile_recs(rec, drec, recs, 2);
@ -8877,7 +8885,9 @@ static void *expand_k(void)
erec1.comp_flags = comp_flags; erec1.comp_flags = comp_flags;
if (catch_lifts_key) 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) { if (just_to_top) {
Scheme_Object *gval; Scheme_Object *gval;
@ -8886,9 +8896,12 @@ static void *expand_k(void)
obj = scheme_expand_expr(obj, env, &erec1, 0); obj = scheme_expand_expr(obj, env, &erec1, 0);
if (catch_lifts_key) { if (catch_lifts_key) {
Scheme_Object *l; Scheme_Object *l, *rl;
l = scheme_frame_get_lifts(env); 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); obj = add_lifts_as_begin(obj, l, env);
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj); SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj);
if ((depth >= 0) || as_local) 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) { if (for_stx) {
scheme_prepare_exp_env(env->genv); scheme_prepare_exp_env(env->genv);
env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
scheme_propagate_require_lift_capture(orig_env, env);
} }
if (for_expr) 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) if (catch_lifts_key)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, 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)); memset(drec, 0, sizeof(drec));
drec[0].value_name = scheme_false; /* or scheme_current_thread->current_local_name ? */ drec[0].value_name = scheme_false; /* or scheme_current_thread->current_local_name ? */

133
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); 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) static void flush_definitions(Scheme_Env *genv)
{ {
if (genv->syntax) { 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 *exclude_hint = scheme_false, *lift_data;
Scheme_Object **exis, **et_exis, **exsis; Scheme_Object **exis, **et_exis, **exsis;
Scheme_Object *lift_ctx; Scheme_Object *lift_ctx;
Scheme_Object *lifted_reqs = scheme_null, *req_data;
int exicount, et_exicount, exsicount; int exicount, et_exicount, exsicount;
char *exps, *et_exps; char *exps, *et_exps;
int all_simple_renames = 1; int *all_simple_renames;
int maybe_has_lifts = 0; int maybe_has_lifts = 0;
int reprovide_kernel; int reprovide_kernel;
Scheme_Object *redef_modname; 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; maybe_has_lifts = 0;
lift_ctx = scheme_generate_lifts_key(); 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 */ /* Pass 1 */
/* Partially expand all expressions, and process definitions, requires, /* 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 p = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(xenv) ? scheme_frame_get_end_statement_lifts(xenv)
: scheme_null); : 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; 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); 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); fst = scheme_frame_get_lifts(xenv);
if (!SCHEME_NULLP(fst)) { if (!SCHEME_NULLP(fst)) {
/* Expansion lifted expressions, so add them to /* Expansion lifted expressions, so add them to
the front and try again. */ the front and try again. */
all_simple_renames = 0; *all_simple_renames = 0;
fm = SCHEME_STX_CDR(fm); fm = SCHEME_STX_CDR(fm);
e = scheme_add_rename(e, post_ex_rn_set); e = scheme_add_rename(e, post_ex_rn_set);
fm = scheme_named_map_1(NULL, add_a_rename, fm, 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: */ /* Add a renaming: */
if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { 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); 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 } else
scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); 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); scheme_prepare_exp_env(env->genv);
eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); 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); 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)) { 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, 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); for_stx ? 1 : 0, NULL, NULL, 0);
all_simple_renames = 0; *all_simple_renames = 0;
} else } else
scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name, scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name,
for_stx ? 1 : 0, NULL, NULL, 0); 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); 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 = scheme_optimize_info_create();
oi->context = (Scheme_Object *)env->genv->module; oi->context = (Scheme_Object *)env->genv->module;
if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) 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, check_require_name, tables,
redef_modname, redef_modname,
0, 0, 1, 0, 0, 0, 1, 0,
&all_simple_renames); all_simple_renames);
if (rec[drec].comp) if (rec[drec].comp)
e = NULL; e = NULL;
@ -6361,7 +6447,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
l = (maybe_has_lifts l = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(cenv) ? scheme_frame_get_end_statement_lifts(cenv)
: scheme_null); : 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; maybe_has_lifts = 1;
if (kind == 2) if (kind == 2)
@ -6380,6 +6466,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
erec1.value_name = scheme_false; erec1.value_name = scheme_false;
e = scheme_expand_expr(e, nenv, &erec1, 0); 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); l = scheme_frame_get_lifts(cenv);
if (SCHEME_NULLP(l)) { if (SCHEME_NULLP(l)) {
@ -6389,7 +6477,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
p = SCHEME_CDR(p); p = SCHEME_CDR(p);
} else { } else {
/* Lifts - insert them and try again */ /* 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)); 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 */ e = scheme_make_pair(e, scheme_make_integer(0)); /* don't re-compile/-expand */
SCHEME_CAR(p) = e; 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->indirect_provides = exis;
env->genv->module->num_indirect_provides = exicount; 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->indirect_syntax_provides = exsis;
env->genv->module->num_indirect_syntax_provides = exsicount; env->genv->module->num_indirect_syntax_provides = exsicount;
} else { } 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; env->genv->module->comp_prefix = cenv->prefix;
if (all_simple_renames) { if (*all_simple_renames) {
env->genv->module->rn_stx = scheme_true; 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); 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); return scheme_datum_to_syntax(cons(p, first), form, form, 0, 2);
} }
} }
@ -9045,10 +9140,10 @@ static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env,
0, 0, 0, 0, 0, 0, 0, 0,
NULL); NULL);
if (rec[drec].comp) { if (rec && rec[drec].comp) {
/* Dummy lets us access a top-level environment: */ /* Dummy lets us access a top-level environment: */
dummy = scheme_make_environment_dummy(env); dummy = scheme_make_environment_dummy(env);
scheme_compile_rec_done_local(rec, drec); scheme_compile_rec_done_local(rec, drec);
scheme_default_compile_rec(rec, drec); scheme_default_compile_rec(rec, drec);
return scheme_make_syntax_compiled(REQUIRE_EXPD, return scheme_make_syntax_compiled(REQUIRE_EXPD,
@ -9071,6 +9166,20 @@ require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *er
return do_require(form, env, erec, drec); 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 */ /* 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 EXPECTED_PRIM_COUNT to the new value, and then USE_COMPILED_STARTUP
can be set to 1 again. */ 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 #ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP # 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; extern THREAD_LOCAL mz_proc_thread *proc_thread_self;
#endif #endif
extern int scheme_no_stack_overflow; extern THREAD_LOCAL int scheme_no_stack_overflow;
typedef struct Scheme_Thread_Set { typedef struct Scheme_Thread_Set {
Scheme_Object so; 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 *); 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, 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_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_end_statement_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_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_add_local_syntax(int cnt, Scheme_Comp_Env *env);
void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val, void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val,
Scheme_Comp_Env *env); Scheme_Comp_Env *env);

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "4.1.3.9" #define MZSCHEME_VERSION "4.1.3.10"
#define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 3 #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_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)