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

more reformatting

Browse Source 
svn: r4013
This commit is contained in:
Eli Barzilay 2006-08-09 23:12:00 +00:00
parent d8d91aff0b
commit 64739e89a7
8 changed files with 192 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/stepper/break.ss
View File

@ -1,25 +1,25 @@
(module break mzscheme (module break mzscheme
(require (lib "contract.ss")) (require (lib "contract.ss"))
(provide current-breakpoint-handler) (provide current-breakpoint-handler)
(define (default-current-breakpoint-handler) (define (default-current-breakpoint-handler)
(error 'default-current-breakpoint-handler (error 'default-current-breakpoint-handler
"The current-breakpoint-handler parameter has not yet been set in this thread.")) "The current-breakpoint-handler parameter has not yet been set in this thread."))
(define current-breakpoint-handler (define current-breakpoint-handler
(make-parameter default-current-breakpoint-handler (make-parameter
(lambda (new-handler) default-current-breakpoint-handler
(if (and (procedure? new-handler) (lambda (new-handler)
(procedure-arity-includes? new-handler 0)) (if (and (procedure? new-handler)
new-handler (procedure-arity-includes? new-handler 0))
(error 'current-breakpoint-handler "Bad value for current-breakpoint-handler: ~e" new-handler))))) new-handler
(error 'current-breakpoint-handler
"Bad value for current-breakpoint-handler: ~e"
new-handler)))))
(provide/contract [break (-> any)]) (provide/contract [break (-> any)])
(define (break) (define (break)
((current-breakpoint-handler)))) ((current-breakpoint-handler))))

34
collects/stepper/debugger-doc.txt
View File

@ -12,7 +12,7 @@ be the focus of the next stage of the debugger.
A simple debugger UI is provided as part of the debugger, but A simple debugger UI is provided as part of the debugger, but
users who want to use the debugger will probably also want users who want to use the debugger will probably also want
to supply their own UI. For this reason, we describe the interface to supply their own UI. For this reason, we describe the interface
to the UI first, and then the working of the current skeleton to the UI first, and then the working of the current skeleton
UI. UI.
Debugger Events: Debugger Events:
@ -21,10 +21,10 @@ A debugger-event is either:
> (make-breakpoint-halt), or > (make-breakpoint-halt), or
: (-> debugger-event?) : (-> debugger-event?)
> (make-normal-breakpoint-info mark-list kind returned-value-list) > (make-normal-breakpoint-info mark-list kind returned-value-list)
: (-> (listof mark?) symbol? (listof any?) : (-> (listof mark?) symbol? (listof any?)
debugger-event?) debugger-event?)
> (make-error-breakpoint-info message) > (make-error-breakpoint-info message)
: (-> string? : (-> string?
debugger-event?) debugger-event?)
> (make-expression-finished returned-value-list) > (make-expression-finished returned-value-list)
: (-> (listof any?) : (-> (listof any?)
@ -36,13 +36,13 @@ A debugger-event is either:
NOTE: there is a mistake here, in the sense that the thing made by NOTE: there is a mistake here, in the sense that the thing made by
'make-full-mark' is not actually a mark. It's a piece of syntax 'make-full-mark' is not actually a mark. It's a piece of syntax
that represents a lambda expression which when evaluated turns that represents a lambda expression which when evaluated turns
into a mark. A mark is an opaque data type. Its contents can into a mark. A mark is an opaque data type. Its contents can
be extracted with the expose-mark function: be extracted with the expose-mark function:
expose-mark : (-> mark? expose-mark : (-> mark?
(list/p syntax? (list/p syntax?
symbol? symbol?
(listof (list/p identifier? any?)))) (listof (list/p identifier? any?))))
@ -53,14 +53,14 @@ Debugger UI (view-controller) signatures:
user-custodian user-custodian
set-breakpoint set-breakpoint
restart-program)) restart-program))
(define-signature debugger-vc^ (define-signature debugger-vc^
(receive-result (receive-result
debugger-output-port)) debugger-output-port))
A debugger UI is a unit which imports signature debugger-model^ A debugger UI is a unit which imports signature debugger-model^
(name-change suggestions welcomed) and exports signature (name-change suggestions welcomed) and exports signature
debugger-vc^ (ditto). debugger-vc^ (ditto).
> go-semaphore: when the user's program halts at a breakpoint, > go-semaphore: when the user's program halts at a breakpoint,
it will block on this semaphore. Therefore, the UI can it will block on this semaphore. Therefore, the UI can
@ -74,26 +74,26 @@ set-breakpoint specifies a location at which to set a breakpoint.
For the moment, this breakpoint will be active only after restarting For the moment, this breakpoint will be active only after restarting
the user's program. A location has the following contract: the user's program. A location has the following contract:
(list/p number? ; line number (list/p number? ; line number
(union string? false?) ; filename (union string? false?) ; filename
(union number? false?) ; position (union number? false?) ; position
> (receive-result event) : (event -> void) The user's program > (receive-result event) : (event -> void) The user's program
calls this procedure whenever a debugger event occurs. Note that calls this procedure whenever a debugger event occurs. Note that
a (make-breakpoint-halt) event will occur whenever the user's a (make-breakpoint-halt) event will occur whenever the user's
program blocks at a breakpoint. program blocks at a breakpoint.
> debugger-output-port : output from the user's program goes > debugger-output-port : output from the user's program goes
to this port. to this port.
Existing mini-UI: Existing mini-UI:
The debugger starts a graphical read-eval-print loop, with the The debugger starts a graphical read-eval-print loop, with the
following bindings: following bindings:
> go-semaphore: passed through from the debugger > go-semaphore: passed through from the debugger
> (events): returns a list of all events that have occurred during > (events): returns a list of all events that have occurred during
the execution of the program. the execution of the program.
> user-custodian: passed through from the debugger. > user-custodian: passed through from the debugger.

6
collects/stepper/debugger-sig.ss
View File

@ -1,13 +1,13 @@
(module debugger-sig mzscheme (module debugger-sig mzscheme
(require (lib "unitsig.ss")) (require (lib "unitsig.ss"))
(provide debugger-model^ (provide debugger-model^
debugger-vc^) debugger-vc^)
(define-signature debugger-model^ (define-signature debugger-model^
(go-semaphore (go-semaphore
user-custodian user-custodian
go)) go))
(define-signature debugger-vc^ (define-signature debugger-vc^
(receive-result))) (receive-result)))

162
collects/stepper/debugger-tool.ss
View File

@ -1,7 +1,7 @@
(module debugger-tool mzscheme (module debugger-tool mzscheme
(require (lib "contract.ss") (require (lib "contract.ss")
(lib "tool.ss" "drscheme") (lib "tool.ss" "drscheme")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(prefix frame: (lib "framework.ss" "framework")) (prefix frame: (lib "framework.ss" "framework"))
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
@ -10,20 +10,20 @@
"debugger-sig.ss" "debugger-sig.ss"
"private/debugger-vc.ss" "private/debugger-vc.ss"
"private/debugger-model.ss" "private/debugger-model.ss"
"private/my-macros.ss") "private/my-macros.ss")
(provide tool@) (provide tool@)
(define tool@ (define tool@
(unit/sig drscheme:tool-exports^ (unit/sig drscheme:tool-exports^
(import drscheme:tool^) (import drscheme:tool^)
(define (phase1) (void)) (define (phase1) (void))
(define (phase2) (void)) (define (phase2) (void))
(define debugger-initial-width 500) (define debugger-initial-width 500)
(define debugger-initial-height 500) (define debugger-initial-height 500)
(define debugger-bitmap (define debugger-bitmap
(bitmap-label-maker (bitmap-label-maker
"Debug" "Debug"
@ -32,66 +32,81 @@
(define debugger-unit-frame<%> (define debugger-unit-frame<%>
(interface () (interface ()
on-debugger-close)) on-debugger-close))
(define (debugger-unit-frame-mixin super%) (define (debugger-unit-frame-mixin super%)
(class* super% (debugger-unit-frame<%>) (class* super% (debugger-unit-frame<%>)
(inherit get-button-panel get-interactions-text get-definitions-text get-menu-bar) (inherit get-button-panel get-interactions-text get-definitions-text
get-menu-bar)
(rename [super-on-close on-close]) (rename [super-on-close on-close])
(define debugger-exists #f) (define debugger-exists #f)
(define/public (on-debugger-close) (define/public (on-debugger-close)
(set! debugger-exists #f)) (set! debugger-exists #f))
(define breakpoints null) (define breakpoints null)
(super-instantiate ()) (super-instantiate ())
; DEBUGGER MENU ; DEBUGGER MENU
(define debugger-menu (instantiate menu% () (label "Debugger") (parent (get-menu-bar)))) (define debugger-menu
(new menu% [label "Debugger"] [parent (get-menu-bar)]))
(instantiate menu-item% () (label "Add Breakpoint") (parent debugger-menu)
(callback (lambda (dc-item dc-event) (new menu-item%
(set! breakpoints (append breakpoints [label "Add Breakpoint"] [parent debugger-menu]
(list (send (get-definitions-text) get-start-position))))))) [callback
(lambda (dc-item dc-event)
(set! breakpoints
(append breakpoints
(list (send (get-definitions-text)
get-start-position)))))])
(define (position->line-n-offset pos) (define (position->line-n-offset pos)
(let* ([line (send (get-definitions-text) position-line pos)] (let* ([line (send (get-definitions-text) position-line pos)]
[offset (- pos (send (get-definitions-text) line-start-position line))]) [offset (- pos (send (get-definitions-text)
line-start-position line))])
(values line offset))) (values line offset)))
(instantiate menu-item% () (label "List Breakpoints") (parent debugger-menu) (new menu-item%
(callback (lambda (dc-item dc-event) [label "List Breakpoints"] [parent debugger-menu]
(message-box "Current Breakpoints" [callback
(format "Current breakpoint positions: ~a\n" (apply string-append (lambda (dc-item dc-event)
(map (lambda (pos) (message-box
(let-values ([(line offset) (position->line-n-offset pos)]) "Current Breakpoints"
(format "<~v:~v> (position ~v)\n" line offset pos))) (format
breakpoints))) "Current breakpoint positions: ~a\n"
this (apply string-append
'(ok))))) (map (lambda (pos)
(let-values ([(line offset)
(instantiate menu-item% () (label "Clear All Breakpoints") (parent debugger-menu) (position->line-n-offset pos)])
(callback (lambda (dc-item dc-event) (format "<~v:~v> (position ~v)\n"
(set! breakpoints null)))) line offset pos)))
breakpoints)))
this
'(ok)))])
(new menu-item%
[label "Clear All Breakpoints"] [parent debugger-menu]
[callback (lambda (dc-item dc-event) (set! breakpoints null))])
(define program-expander (define program-expander
(contract (contract
(-> (-> void?) ; init (-> (-> void?) ; init
(-> (union eof-object? syntax? (cons/p string? any/c)) (-> void?) void?) ; iter ((union eof-object? syntax? (cons/p string? any/c)) (-> void?)
. -> . void?) ; iter
void?) void?)
(lambda (init iter) (lambda (init iter)
(let* ([lang-settings (let* ([lang-settings
(frame:preferences:get (frame:preferences:get
(drscheme:language-configuration:get-settings-preferences-symbol))] (drscheme:language-configuration:get-settings-preferences-symbol))]
[lang (drscheme:language-configuration:language-settings-language lang-settings)] [lang (drscheme:language-configuration:language-settings-language lang-settings)]
[settings (drscheme:language-configuration:language-settings-settings lang-settings)]) [settings (drscheme:language-configuration:language-settings-settings lang-settings)])
(drscheme:eval:expand-program (drscheme:eval:expand-program
(drscheme:language:make-text/pos (get-definitions-text) (drscheme:language:make-text/pos
0 (get-definitions-text)
(send (get-definitions-text) 0
last-position)) (send (get-definitions-text) last-position))
lang-settings lang-settings
#f #f
(lambda () (lambda ()
@ -102,60 +117,61 @@
(send lang render-value val settings sp) (send lang render-value val settings sp)
(let ([str (get-output-string sp)]) (let ([str (get-output-string sp)])
(if ((string-length str) . <= . len) (if ((string-length str) . <= . len)
str str
(string-append (substring str 0 (max 0 (- len 3))) "...")))))) (string-append (substring str 0 (max 0 (- len 3)))
(drscheme:teachpack:install-teachpacks "..."))))))
(frame:preferences:get 'drscheme:teachpacks))) ; this belongs in model, but I'd need a unit rewrite (drscheme:teachpack:install-teachpacks
;; this belongs in model, but I'd need a unit rewrite
(frame:preferences:get 'drscheme:teachpacks)))
void ; kill void ; kill
iter))) iter)))
'program-expander 'program-expander
'caller)) 'caller))
(define debugger-button (define debugger-button
(make-object button% (make-object button%
(debugger-bitmap this) (debugger-bitmap this)
(get-button-panel) (get-button-panel)
(lambda (button evt) (lambda (button evt)
(if debugger-exists (if debugger-exists
(message-box/custom "Debugger Exists" (message-box/custom
"There is already a debugger window open for this program." "Debugger Exists"
"OK" "There is already a debugger window open for this program."
#f "OK" #f #f #f '(default=1))
#f (begin
#f (set! debugger-exists #t)
'(default=1)) (start-debugger program-expander this))))))
(begin
(set! debugger-exists #t)
(start-debugger program-expander this))))))
(define breakpoint-origin (get-definitions-text)) (define breakpoint-origin (get-definitions-text))
(define (start-debugger program-expander drs-window) (define (start-debugger program-expander drs-window)
(define-values/invoke-unit/sig (go) (define-values/invoke-unit/sig (go)
(compound-unit/sig (compound-unit/sig
(import [EXPANDER : (program-expander)] (import [EXPANDER : (program-expander)]
[BREAKPOINTS : (breakpoints breakpoint-origin)] [BREAKPOINTS : (breakpoints breakpoint-origin)]
[DRS-WINDOW : (drs-window)]) [DRS-WINDOW : (drs-window)])
(link [MODEL : debugger-model^ (debugger-model@ VIEW-CONTROLLER EXPANDER BREAKPOINTS)] (link [MODEL : debugger-model^
[VIEW-CONTROLLER : debugger-vc^ (debugger-vc@ MODEL DRS-WINDOW)]) (debugger-model@ VIEW-CONTROLLER EXPANDER BREAKPOINTS)]
[VIEW-CONTROLLER : debugger-vc^
(debugger-vc@ MODEL DRS-WINDOW)])
(export (var (MODEL go)))) (export (var (MODEL go))))
#f #f
(program-expander) (program-expander)
(breakpoints breakpoint-origin) (breakpoints breakpoint-origin)
(drs-window)) (drs-window))
(go)) (go))
(rename [super-enable-evaluation enable-evaluation]) (rename [super-enable-evaluation enable-evaluation])
(define/override (enable-evaluation) (define/override (enable-evaluation)
(send debugger-button enable #t) (send debugger-button enable #t)
(super-enable-evaluation)) (super-enable-evaluation))
(rename [super-disable-evaluation disable-evaluation]) (rename [super-disable-evaluation disable-evaluation])
(define/override (disable-evaluation) (define/override (disable-evaluation)
(send debugger-button enable #f) (send debugger-button enable #f)
(super-disable-evaluation)) (super-disable-evaluation))
(send (get-button-panel) change-children (send (get-button-panel) change-children
(lx (cons debugger-button (remq debugger-button _)))))) (lx (cons debugger-button (remq debugger-button _))))))
(drscheme:get/extend:extend-unit-frame debugger-unit-frame-mixin)))) (drscheme:get/extend:extend-unit-frame debugger-unit-frame-mixin))))

26
collects/stepper/info.ss
View File

@ -1,17 +1,19 @@
(module info (lib "infotab.ss" "setup") (module info (lib "infotab.ss" "setup")
(define name "Stepper") (define name "Stepper")
(define doc.txt "doc.txt") (define doc.txt "doc.txt")
(define tools '(("stepper+xml-tool.ss") (define tools '(("stepper+xml-tool.ss")
#;("debugger-tool.ss") ;; ("debugger-tool.ss")
)) ))
(define tool-names (list "The Stepper" (define tool-names (list "The Stepper"
#;"The Debugger" ;; "The Debugger"
)) ))
(define tool-icons (list '("foot-up.png" "icons") (define tool-icons (list '("foot-up.png" "icons")
#;'("foot-up.png" "icons") ;; #f
)) ))
(define compile-omit-files `("private/test-annotate.ss" "debugger-tool.ss"))
) (define compile-omit-files `("debugger-tool.ss"))
)

68
collects/stepper/internal-docs.txt
View File

@ -5,15 +5,15 @@ The Stepper's use of syntax-property:
In order to make macro-unwinding possible, the stepper adds In order to make macro-unwinding possible, the stepper adds
syntax-properties to elaborated code which then informs the syntax-properties to elaborated code which then informs the
reconstruction process about how certain macros were originally reconstruction process about how certain macros were originally
formed. formed.
In fact, the truth is slightly more complicated, because there are In fact, the truth is slightly more complicated, because there are
two rounds of macro-expansion for a program written in a teaching two rounds of macro-expansion for a program written in a teaching
language. First, the program is expanded according to the language. First, the program is expanded according to the
macro definitions contained in the "lang" collection. Then, the macro definitions contained in the "lang" collection. Then, the
code is expanded according to the macro definitions built into code is expanded according to the macro definitions built into
mzscheme. So, for instance, a beginner 'cond' expands into a mzscheme. So, for instance, a beginner 'cond' expands into a
mzscheme 'cond' which expands into a nested series of 'if's. mzscheme 'cond' which expands into a nested series of 'if's.
Correspondingly, the stepper's addition of syntax properties is broken Correspondingly, the stepper's addition of syntax properties is broken
into two parts; those added for the beginner macros, and those added into two parts; those added for the beginner macros, and those added
@ -25,14 +25,14 @@ main annotation. This procedure is called 'top-level-rewrite'.
Therefore, the stepper's syntax-property additions occur in two Therefore, the stepper's syntax-property additions occur in two
textual locations: collects/lang/private/teach.ss, and textual locations: collects/lang/private/teach.ss, and
collects/stepper/private/annotate.ss (with a few stray ones collects/stepper/private/annotate.ss (with a few stray ones
in collects/lang/private/teachhelp.ss). in collects/lang/private/teachhelp.ss).
Also, in order to be visible to the reconstructor, these properties Also, in order to be visible to the reconstructor, these properties
must be explicitly transferred from the annotated source code syntax must be explicitly transferred from the annotated source code syntax
to the reconstructed syntax. This is accomplished by the 'attach-info' to the reconstructed syntax. This is accomplished by the 'attach-info'
procedure in reconstruct.ss. Note that in the process, these properties procedure in reconstruct.ss. Note that in the process, these properties
are given names that have "user-" prepended to them. This now seems are given names that have "user-" prepended to them. This now seems
like a strange decision. like a strange decision.
Finally, the astute reader may wonder why I need to add things like Finally, the astute reader may wonder why I need to add things like
@ -53,21 +53,21 @@ stepper-skip-completely :
just to make sure that other marks get properly obliterated. just to make sure that other marks get properly obliterated.
Note that skipping an expression can turn a sensible expression into Note that skipping an expression can turn a sensible expression into
a nonsensical one. This is where the 'expressions are lists of a nonsensical one. This is where the 'expressions are lists of
subexpressions' abstraction and the 'expressions are one of A...Z' subexpressions' abstraction and the 'expressions are one of A...Z'
abstraction part ways. abstraction part ways.
Uses: Uses:
- applied to the check of the test-variable in the expansion of the - applied to the check of the test-variable in the expansion of the
'or' macro. 'or' macro.
- applied to the expansion of the primitives defined with - applied to the expansion of the primitives defined with
'define-primitive'. 'define-primitive'.
- applied to the 'make-generative-lambda' inserted by teach.ss - applied to the 'make-generative-lambda' inserted by teach.ss
stepper-hint : stepper-hint :
this is the most generally applied syntax property. In general, it this is the most generally applied syntax property. In general, it
informs the reconstructor what macro this source expression came informs the reconstructor what macro this source expression came
from. from.
See notes below about 'being careful with stepper-hint'. See notes below about 'being careful with stepper-hint'.
@ -87,16 +87,16 @@ stepper-hint :
box (inside an xml box) box (inside an xml box)
[ 'comes-from-recur ] : expression was expanded from a 'recur' [ 'comes-from-recur ] : expression was expanded from a 'recur'
stepper-define-type: stepper-define-type:
this is attached to the right-hand sides of defines to indicate what this is attached to the right-hand sides of defines to indicate what
kind of define they came from. kind of define they came from.
[ 'shortened-proc-define ] : this lambda arose from the expansion [ 'shortened-proc-define ] : this lambda arose from the expansion
of (define (id arg ...) body). N.B.: anything tagged with this of (define (id arg ...) body). N.B.: anything tagged with this
property must also have a 'stepper-proc-define-name property must also have a 'stepper-proc-define-name
property. property.
[ 'lambda-define ] : this lambda arose from the expansion of [ 'lambda-define ] : this lambda arose from the expansion of
(define id (lambda ( (define id (lambda (
@ -108,7 +108,7 @@ stepper-define-type:
the define itself evaporates into an internal define which is then the define itself evaporates into an internal define which is then
expanded in a mzscheme-native expansion into a letrec. expanded in a mzscheme-native expansion into a letrec.
Question 2: won't the right-hand side change, losing the mark? Question 2: won't the right-hand side change, losing the mark?
A: yes it will, but not for definitions of lambdas. Since there A: yes it will, but not for definitions of lambdas. Since there
are three cases we need to distinguish, and two of them are are three cases we need to distinguish, and two of them are
definitions of lambdas, we can distinguish the third case definitions of lambdas, we can distinguish the third case
@ -117,12 +117,12 @@ stepper-define-type:
Question 3: what if, through reduction, a different expression Question 3: what if, through reduction, a different expression
than the original one shows up ... which _does_ have one of the than the original one shows up ... which _does_ have one of the
two stepper-define-type marks? two stepper-define-type marks?
A: to prevent this, there's another syntax-property, A: to prevent this, there's another syntax-property,
'stepper-proc-define-name, which indicates the identifier to which 'stepper-proc-define-name, which indicates the identifier to which
this procedure was originally bound. In the absence of set!, this procedure was originally bound. In the absence of set!,
this solves the problem. this solves the problem.
stepper-xml-hint : indicates whether this expression came from an stepper-xml-hint : indicates whether this expression came from an
xml-box. The protocol is as follows: xml-box. The protocol is as follows:
[ 'from-xml-box ] : attached to the outer application that wraps [ 'from-xml-box ] : attached to the outer application that wraps
@ -145,7 +145,7 @@ stepper-xml-value-hint : like the stepper-xml-hint, used to indicate
evaluation get stomped by the stepper-xml-hint values attached to the evaluation get stomped by the stepper-xml-hint values attached to the
source. source.
[ 'from-xml-box ] : this value is the result of evaluating an xml [ 'from-xml-box ] : this value is the result of evaluating an xml
box. box.
stepper-proc-define-name : stores the name to which a procedure stepper-proc-define-name : stores the name to which a procedure
@ -159,12 +159,12 @@ stepper-orig-name: attached to an uninterned symbol used by
(Not transferred.) (Not transferred.)
stepper-prim-name: stepper-prim-name:
this is attached to the expansion of primitives introduced with the this is attached to the expansion of primitives introduced with the
'define-primitive' form. Its value indicates what name to give to 'define-primitive' form. Its value indicates what name to give to
the source term at reconstruction time. the source term at reconstruction time.
stepper-binding-type : stepper-binding-type :
this is actually unrelated to macro expansion. It differentiates this is actually unrelated to macro expansion. It differentiates
between the various kinds of lexical bindings. (Not transferred.) between the various kinds of lexical bindings. (Not transferred.)
@ -172,15 +172,15 @@ stepper-binding-type :
[ 'let-bound ] : this variable's binding was in a let/*/rec [ 'let-bound ] : this variable's binding was in a let/*/rec
[ 'lambda-bound ] : this variable's binding was in a lambda [ 'lambda-bound ] : this variable's binding was in a lambda
stepper-and/or-clauses-consumed : stepper-and/or-clauses-consumed :
indicates the number of clauses to the left of the one associated indicates the number of clauses to the left of the one associated
with a given 'if' in the expansion of an 'and' or 'or'. with a given 'if' in the expansion of an 'and' or 'or'.
This allows the stepper to reconstruct a partially evaluated This allows the stepper to reconstruct a partially evaluated
'and' or 'or' with the right number of 'true's or 'false's 'and' or 'or' with the right number of 'true's or 'false's
in front. in front.
(Transferred.) (Transferred.)
stepper-skipto : stepper-skipto :
this instructs the annotator to look inside the current expression this instructs the annotator to look inside the current expression
along a given path for the expression to be annotated. In along a given path for the expression to be annotated. In
particular, the value bound to stepper-skipto must be a list whose particular, the value bound to stepper-skipto must be a list whose
@ -192,9 +192,9 @@ Some uses:
Where it's used: the stepper-skipto label is used by the 2nd-pass Where it's used: the stepper-skipto label is used by the 2nd-pass
macro-labeler and the annotator. Both are in annotate.ss. In addition macro-labeler and the annotator. Both are in annotate.ss. In addition
to skipping inward, a stepper hint to skipping inward, a stepper hint
stepper-else : stepper-else :
[ #t ] : Initially applied to the 'true' that the cond macro [ #t ] : Initially applied to the 'true' that the cond macro
replaces a beginner's 'else' with, it is later transferred replaces a beginner's 'else' with, it is later transferred
to the 'if' wrapping that 'true'. This is because there is no to the 'if' wrapping that 'true'. This is because there is no
@ -218,8 +218,8 @@ stepper-test-suite-hint :
stepper-highlight : stepper-highlight :
this expression will be highlighted. this expression will be highlighted.
(Not currently tranferred...?) (Not currently tranferred...?)
STEPPER-HINT COLLISIONS STEPPER-HINT COLLISIONS
The major concern with the stepper-hint is that two of them may The major concern with the stepper-hint is that two of them may
@ -230,18 +230,18 @@ STEPPER-HINT COLLISIONS
the result of a macro expansion. (For instance, the 'if' that is the result of a macro expansion. (For instance, the 'if' that is
the result of the expansion of 'and'.) the result of the expansion of 'and'.)
1) except in the circumstances listed below, the expressions with tags 1) except in the circumstances listed below, the expressions with tags
attached to them are not themselves macro invocations. attached to them are not themselves macro invocations.
Q.E.D. Q.E.D.
exceptions: exceptions:
1) the beginner cond expands into the mzscheme cond, which is 1) the beginner cond expands into the mzscheme cond, which is
then annotated by the top-level-rewrite. In this case, the expansion then annotated by the top-level-rewrite. In this case, the expansion
of the beginner cond does not add any stepper-hint properties, so no of the beginner cond does not add any stepper-hint properties, so no
collision can occur. collision can occur.
2) the intermediate let* expands into the beginner let; both add a 2) the intermediate let* expands into the beginner let; both add a
stepper-hint. To resolve this, the expansion of let allows an existing stepper-hint. To resolve this, the expansion of let allows an existing
stepper-hint to stand. stepper-hint to stand.

17
collects/stepper/stepper+xml-tool.ss
View File

@ -5,15 +5,16 @@
"xml-tool.ss") "xml-tool.ss")
(provide tool@) (provide tool@)
;; the xml and stepper tools are combined, so that the stepper can create XML snips. ;; the xml and stepper tools are combined, so that the stepper can create XML
;; note that both of these tools provide 'void' for phase1 and phase2 (which together ;; snips. note that both of these tools provide 'void' for phase1 and phase2
;; make up the tool-exports^), so we can provide either one of these for the compound ;; (which together make up the tool-exports^), so we can provide either one
;; unit. Doesn't matter. ;; of these for the compound unit. Doesn't matter.
(define tool@ (define tool@
(compound-unit/sig (compound-unit/sig
(import (TOOL-IMPORTS : drscheme:tool^)) (import (TOOL-IMPORTS : drscheme:tool^))
(link (XML-TOOL : (xml-snip% scheme-snip%) (xml-tool@ TOOL-IMPORTS)) (link (XML-TOOL : (xml-snip% scheme-snip%) (xml-tool@ TOOL-IMPORTS))
(STEPPER-TOOL : drscheme:tool-exports^ (stepper-tool@ TOOL-IMPORTS XML-TOOL))) (STEPPER-TOOL : drscheme:tool-exports^
(export (open STEPPER-TOOL))))) (stepper-tool@ TOOL-IMPORTS XML-TOOL)))
(export (open STEPPER-TOOL)))))

17
collects/stepper/stepper-tool.ss
View File

@ -269,10 +269,14 @@
[(waiting-for-application) [(waiting-for-application)
(or (eq? step-kind 'user-application) (or (eq? step-kind 'user-application)
(eq? step-kind 'finished-stepping))] (eq? step-kind 'finished-stepping))]
[(#f) (error 'right-kind-of-step "this code should be unreachable with stepper-is-waiting? set to #f")] [(#f) (error 'right-kind-of-step
[else (error 'right-kind-of-step "unknown value for stepper-is-waiting?: ~a" stepper-is-waiting?)])) "this code should be unreachable with stepper-is-waiting? set to #f")]
[else (error 'right-kind-of-step
"unknown value for stepper-is-waiting?: ~a"
stepper-is-waiting?)]))
;; add-view-triple : set the release-semaphore to be the new one, add the view to the list. ;; add-view-triple : set the release-semaphore to be the new one, add
;; the view to the list.
(define (add-view-triple view-triple) (define (add-view-triple view-triple)
(set! release-for-next-step (cadr view-triple)) (set! release-for-next-step (cadr view-triple))
(set! view-history (append view-history (set! view-history (append view-history
@ -308,7 +312,9 @@
(if (< new-view (length view-history)) (if (< new-view (length view-history))
(update-view/existing new-view) (update-view/existing new-view)
(begin (begin
(semaphore-post release-for-next-step) ; each step has its own semaphore, so releasing one twice is no problem. ;; each step has its own semaphore, so releasing one twice is
;; no problem.
(semaphore-post release-for-next-step)
(when stepper-is-waiting? (when stepper-is-waiting?
(error 'try-to-get-view "try-to-get-view should not be reachable when already waiting for new step")) (error 'try-to-get-view "try-to-get-view should not be reachable when already waiting for new step"))
(let ([try-get (async-channel-try-get view-channel)]) (let ([try-get (async-channel-try-get view-channel)])
@ -407,7 +413,8 @@
(send e end-edit-sequence)) (send e end-edit-sequence))
(en/dis-able-buttons)) (en/dis-able-buttons))
;; en/dis-able-buttons : set enable & disable the stepper buttons, based on view-controller state ;; en/dis-able-buttons : set enable & disable the stepper buttons,
;; based on view-controller state
(define (en/dis-able-buttons) (define (en/dis-able-buttons)
(let* ([can-go-back? (> view 0)]) (let* ([can-go-back? (> view 0)])
(send previous-button enable can-go-back?) (send previous-button enable can-go-back?)