diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss index 6dd12fd170..a1fe495801 100644 --- a/collects/macro-debugger/model/steps.ss +++ b/collects/macro-debugger/model/steps.ss @@ -40,11 +40,13 @@ ;; context-fill : Context Syntax -> Syntax (define (context-fill ctx stx) - (let loop ([ctx ctx] [stx stx]) - (if (null? ctx) - stx - (let ([frame0 (car ctx)]) - (loop (cdr ctx) (frame0 stx)))))) + (datum->syntax + #f + (let loop ([ctx ctx] [stx stx]) + (if (null? ctx) + stx + (let ([frame0 (car ctx)]) + (loop (cdr ctx) (frame0 stx))))))) (define (state-term s) (context-fill (state-ctx s) (state-e s))) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 6d90770437..07d21b917e 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -111,7 +111,8 @@ #:shift-table [shift-table #f] #:definites [definites null] #:hi-colors [hi-colors null] - #:hi-stxss [hi-stxss null]) + #:hi-stxss [hi-stxss null] + #:substitutions [substitutions null]) (define (get-binders id) (define binder (module-identifier-mapping-get alpha-table id (lambda () #f))) @@ -120,11 +121,21 @@ (list binder))) (let ([display (internal-add-syntax stx)] [definite-table (make-hasheq)]) - (for-each (lambda (hi-stxs hi-color) - (send: display display<%> - highlight-syntaxes hi-stxs hi-color)) - hi-stxss - hi-colors) + (let ([range (send: display display<%> get-range)] + [offset (send: display display<%> get-start-position)]) + (for ([subst substitutions]) + (for ([r (send: range range<%> get-ranges (car subst))]) + (with-unlock -text + (send -text insert (cdr subst) + (+ offset (car r)) + (+ offset (cdr r)) + #f) + (send -text change-style + (code-style -text (send: config config<%> get-syntax-font-size)) + (+ offset (car r)) + (+ offset (cdr r))))))) + (for ([hi-stxs hi-stxss] [hi-color hi-colors]) + (send: display display<%> highlight-syntaxes hi-stxs hi-color)) (for ([definite definites]) (hash-set! definite-table definite #t) (when shift-table diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss index 07221aad5d..d57308e1b4 100644 --- a/collects/macro-debugger/view/frame.ss +++ b/collects/macro-debugger/view/frame.ss @@ -183,6 +183,9 @@ 'always 'over-limit)) (send: widget widget<%> update/preserve-view)))) + (menu-option/notify-box extras-menu + "Factor out common context?" + (get-field split-context? config)) (menu-option/notify-box extras-menu "Highlight redex/contractum" (get-field highlight-foci? config)) diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.ss index 7e146436f3..d5d75aad3f 100644 --- a/collects/macro-debugger/view/interfaces.ss +++ b/collects/macro-debugger/view/interfaces.ss @@ -16,7 +16,8 @@ one-by-one? extra-navigation? debug-catch-errors? - force-letrec-transformation?))) + force-letrec-transformation? + split-context?))) (define-interface widget<%> () (get-config diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss index 73eb46d71a..5d9f1b9191 100644 --- a/collects/macro-debugger/view/prefs.ss +++ b/collects/macro-debugger/view/prefs.ss @@ -26,6 +26,7 @@ (preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?) (preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?) (preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?) +(preferences:set-default 'MacroStepper:SplitContext? #f boolean?) (pref:get/set pref:width MacroStepper:Frame:Width) (pref:get/set pref:height MacroStepper:Frame:Height) @@ -42,6 +43,7 @@ (pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?) (pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?) (pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?) +(pref:get/set pref:split-context? MacroStepper:SplitContext?) (define macro-stepper-config-base% (class* syntax-prefs-base% (config<%>) @@ -56,6 +58,7 @@ (notify-methods extra-navigation?) (notify-methods debug-catch-errors?) (notify-methods force-letrec-transformation?) + (notify-methods split-context?) (super-new))) (define macro-stepper-config/prefs% @@ -75,6 +78,7 @@ (connect-to-pref extra-navigation? pref:extra-navigation?) (connect-to-pref debug-catch-errors? pref:debug-catch-errors?) (connect-to-pref force-letrec-transformation? pref:force-letrec-transformation?) + (connect-to-pref split-context? pref:split-context?) (super-new))) (define macro-stepper-config/prefs/readonly% @@ -93,4 +97,5 @@ (connect-to-pref/readonly extra-navigation? pref:extra-navigation?) (connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?) (connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?) + (connect-to-pref/readonly split-context? pref:split-context?) (super-new))) diff --git a/collects/macro-debugger/view/step-display.ss b/collects/macro-debugger/view/step-display.ss index 733e5362de..ad1d941547 100644 --- a/collects/macro-debugger/view/step-display.ss +++ b/collects/macro-debugger/view/step-display.ss @@ -139,13 +139,53 @@ (define/private (separator/small step) (insert-step-separator/small (step-type->string (protostep-type step)))) - + ;; show-step : Step -> void (define/private (show-step step binders shift-table) - (show-state/redex (protostep-s1 step) binders shift-table) - (separator step) - (show-state/contractum (step-s2 step) binders shift-table) - (show-lctx step binders shift-table)) + (let-values ([(common-context state1 state2) + (factor-common-context (protostep-s1 step) + (step-s2 step))]) + (show-state/redex state1 binders shift-table) + (separator step) + (show-state/contractum state2 binders shift-table) + (show-common-context common-context state1 binders shift-table) + (show-lctx step binders shift-table))) + + (define/private (factor-common-context state1 state2) + (if (send: config config<%> get-split-context?) + (factor-common-context* state1 state2) + (values null state1 state2))) + + (define/private (factor-common-context* state1 state2) + (match-define + (struct state (e1 foci1 ctx1 lctx1 binders1 uses1 frontier1 seq1)) state1) + (match-define + (struct state (e2 foci2 ctx2 lctx2 binders2 uses2 frontier2 seq2)) state2) + (define (common xs ys acc) + (if (and (pair? xs) (pair? ys) (eq? (car xs) (car ys))) + (common (cdr xs) (cdr ys) (cons (car xs) acc)) + (values (reverse xs) (reverse ys) acc))) + (define-values (ctx1z ctx2z common-ctx) + (common (reverse ctx1) (reverse ctx2) null)) + (define state1z + (make-state e1 foci1 ctx1z lctx1 binders1 uses1 frontier1 seq1)) + (define state2z + (make-state e2 foci2 ctx2z lctx2 binders2 uses2 frontier2 seq2)) + (values common-ctx state1z state2z)) + + (define/private (show-common-context ctx state1 binders shift-table) + (match-define + (struct state (_ _ _ _ _ uses1 frontier1 _)) state1) + (when (pair? ctx) + (let* ([hole-stx #'~~HOLE~~] + [the-syntax (context-fill ctx hole-stx)]) + (send*: sbview sb:syntax-browser<%> + (add-text "\nin context:\n") + (add-syntax the-syntax + #:binder-table binders + #:shift-table shift-table + #:definites uses1 + #:substitutions (list (cons hole-stx "[ HOLE ]"))))))) (define/private (show-state/redex state binders shift-table) (insert-syntax/redex (state-term state) diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index 8f72e06a8f..28138be6e5 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -153,6 +153,8 @@ (send*: config config<%> (listen-show-hiding-panel? (lambda (show?) (show-macro-hiding-panel show?))) + (listen-split-context? + (lambda (_) (update/preserve-view))) (listen-highlight-foci? (lambda (_) (update/preserve-view))) (listen-highlight-frontier? diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 40d6058f42..5c20816fe8 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "14jan2009") +#lang scheme/base (provide stamp) (define stamp "15jan2009") diff --git a/collects/scheme/help.ss b/collects/scheme/help.ss index a890451d4d..60154ee771 100644 --- a/collects/scheme/help.ss +++ b/collects/scheme/help.ss @@ -36,8 +36,9 @@ [_ (raise-syntax-error #f - (string-append "expects a single identifer, any number of literal" - " strings, or #:search clauses;" + (string-append "expects any number of literal strings, a single" + " identifier, an identifier followed by a #:from clause," + " or a #:search clause;" " try `(help help)' for more information") stx)]))) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index b0f3ec8363..137629680e 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -126,7 +126,7 @@ Your program may deal with such events via the @emph{designation} of installation of three event handlers: @scheme[on-tick], @scheme[on-key], and @scheme[on-mouse]. In addition, a @tech{world} program may specify a @scheme[draw] function, which is called every time your program should - visualize the current world, and a @scheme[_stop?] predicate, which is used + visualize the current world, and a @scheme[done] predicate, which is used to determine when the @tech{world} program should shut down. Each handler function consumes the current state of the @tech{world} and @@ -835,7 +835,7 @@ The @scheme[on-receive] clause of a @scheme[big-bang] specifies the event handle The diagram below summarizes the extensions of this section in graphical form. -@image["world.png"] +@image["universe.png"] A registered world program may send a message to the universe server at any time by returning a @tech{Package} from an event handler. The @@ -964,7 +964,7 @@ A @tech{server} keeps track of information about the @tech{universe} that a server tracks and how the information is represented depends on the situation and the programmer, just as with @tech{world} programs. -@deftech{UniverseState} @scheme[any/c] represents the server's state For running +@deftech{UniverseState} @scheme[any/c] represents the server's state. For running @tech{universe}s, the teachpack demands that you come up with a data definition for (your state of the) @tech{server}. Any piece of data can represent the state. We just assume that you introduce a data definition @@ -1368,7 +1368,7 @@ The second step of the design recipe calls for functional examples: ;; an example for receiving a message from the active world: (check-expect - (switch (list world1 world2) '* world1 'it-is-your-turn) + (switch (list world1 world2) '* world1 'done) (make-bundle (list world2 world1) '* (list (make-mail world2 'it-is-your-turn)))) @@ -1421,16 +1421,20 @@ Similarly, the protocol says that when @emph{switch} is invoked because a that there is at least this one world on this list. It is therefore acceptable to create a mail for this world. +Start the server now. + + @schemeblock[(universe '* (on-new add-world) (on-msg switch))] + Exercise: The function definition simply assumes that @emph{wrld} is @scheme[world=?] to @scheme[(first univ)] and that the received message - @emph{m} is @scheme['it-is-your-turn]. Modify the function definition so that it + @emph{m} is @scheme['done]. Modify the function definition so that it checks these assumptions and raises an error signal if either of them is wrong. Start with functional examples. If stuck, re-read the section on checked functions from HtDP. (Note: in a @tech{universe} it is quite possible that a program registers with a @tech{server} but fails to stick to the agreed-upon protocol. How to deal with such situations properly - depends on the context. For now, stop the @tech{universe} at this point, - but consider alternative solutions, too.) + depends on the context. For now, stop the @tech{universe} at this point by + returning an empty list of worlds. Consider alternative solutions, too.) Exercise: An alternative state representation would equate @tech{UniverseState} with @emph{world} structures, keeping track of the @@ -1533,7 +1537,7 @@ the scene every time @scheme['it-is-your-turn] is received. Design this function (define (receive w m) (cond - [(symbol=? 'resting w) HEIGHT] + [(symbol? w) HEIGHT] ;; meaning: @scheme[(symbol=? w 'resting)] [else w])) )) @@ -1573,7 +1577,7 @@ the scene every time @scheme['it-is-your-turn] is received. Design this function [(number? x) (if (<= x 0) (make-package 'resting 'done) (sub1 x))])) )) - Exercise: what could happen if we had designed @emph{receive} so that it +Exercise: what could happen if we had designed @emph{receive} so that it produces @scheme['resting] when the state of the world is @scheme[0]? Use your answer to explain why you think it is better to leave this kind of state change to the tick event handler instead of the message receipt @@ -1591,7 +1595,7 @@ Finally, here is the third function, which renders the state as a scene: (check-expect (render 'resting) (place-image (text "resting" 11 'red) 10 10 MT)) -(define (render name) +(define (render w) (place-image (text name 11 'black) 5 85 (cond diff --git a/collects/teachpack/nuworld.png b/collects/teachpack/nuworld.png index 2b215663af..4e6d56a352 100644 Binary files a/collects/teachpack/nuworld.png and b/collects/teachpack/nuworld.png differ diff --git a/collects/teachpack/nuworld.ss b/collects/teachpack/nuworld.ss index cbda2823b6..a691d968b1 100644 --- a/collects/teachpack/nuworld.ss +++ b/collects/teachpack/nuworld.ss @@ -10,7 +10,8 @@ " (on-draw render WIDTH HEIGHT)" " (on-tick tock RATE)" " (on-mouse click)" - " (on-key react))" + " (on-key react)" + " (stop-when done))" )) (define program @@ -114,6 +115,6 @@ (draw-pict the-image image-dc 0.0 0.0) -(send image-bm save-file "world.png" 'png) +(send image-bm save-file "nuworld.png" 'png) the-image diff --git a/collects/teachpack/world.ss b/collects/teachpack/world.ss index f9c397e534..80dda08045 100644 --- a/collects/teachpack/world.ss +++ b/collects/teachpack/world.ss @@ -12,6 +12,7 @@ " (on-mouse click)" " (on-key react)" " (on-receive receive)" + " (stop-when done)" " (register LOCALHOST 'jimbob))"))