more reformatting
svn: r4013
This commit is contained in:
Eli Barzilay
parent
d8d91aff0b
commit
64739e89a7
|
|
@ -1,25 +1,25 @@
|
|||
(module break mzscheme
|
||||
|
||||
(require (lib "contract.ss"))
|
||||
|
||||
|
||||
(provide current-breakpoint-handler)
|
||||
|
||||
|
||||
(define (default-current-breakpoint-handler)
|
||||
(error 'default-current-breakpoint-handler
|
||||
"The current-breakpoint-handler parameter has not yet been set in this thread."))
|
||||
|
||||
|
||||
(define current-breakpoint-handler
|
||||
(make-parameter default-current-breakpoint-handler
|
||||
(lambda (new-handler)
|
||||
(if (and (procedure? new-handler)
|
||||
(procedure-arity-includes? new-handler 0))
|
||||
new-handler
|
||||
(error 'current-breakpoint-handler "Bad value for current-breakpoint-handler: ~e" new-handler)))))
|
||||
|
||||
|
||||
(make-parameter
|
||||
default-current-breakpoint-handler
|
||||
(lambda (new-handler)
|
||||
(if (and (procedure? new-handler)
|
||||
(procedure-arity-includes? new-handler 0))
|
||||
new-handler
|
||||
(error 'current-breakpoint-handler
|
||||
"Bad value for current-breakpoint-handler: ~e"
|
||||
new-handler)))))
|
||||
|
||||
(provide/contract [break (-> any)])
|
||||
|
||||
|
||||
(define (break)
|
||||
((current-breakpoint-handler))))
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
users who want to use the debugger will probably also want
|
||||
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.
|
||||
|
||||
Debugger Events:
|
||||
|
|
@ -21,10 +21,10 @@ A debugger-event is either:
|
|||
> (make-breakpoint-halt), or
|
||||
: (-> debugger-event?)
|
||||
> (make-normal-breakpoint-info mark-list kind returned-value-list)
|
||||
: (-> (listof mark?) symbol? (listof any?)
|
||||
: (-> (listof mark?) symbol? (listof any?)
|
||||
debugger-event?)
|
||||
> (make-error-breakpoint-info message)
|
||||
: (-> string?
|
||||
: (-> string?
|
||||
debugger-event?)
|
||||
> (make-expression-finished returned-value-list)
|
||||
: (-> (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
|
||||
'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
|
||||
be extracted with the expose-mark function:
|
||||
|
||||
expose-mark : (-> mark?
|
||||
(list/p syntax?
|
||||
symbol?
|
||||
(list/p syntax?
|
||||
symbol?
|
||||
(listof (list/p identifier? any?))))
|
||||
|
||||
|
||||
|
|
@ -53,14 +53,14 @@ Debugger UI (view-controller) signatures:
|
|||
user-custodian
|
||||
set-breakpoint
|
||||
restart-program))
|
||||
|
||||
|
||||
(define-signature debugger-vc^
|
||||
(receive-result
|
||||
debugger-output-port))
|
||||
|
||||
A debugger UI is a unit which imports signature debugger-model^
|
||||
(name-change suggestions welcomed) and exports signature
|
||||
debugger-vc^ (ditto).
|
||||
debugger-vc^ (ditto).
|
||||
|
||||
> go-semaphore: when the user's program halts at a breakpoint,
|
||||
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
|
||||
the user's program. A location has the following contract:
|
||||
(list/p number? ; line number
|
||||
(union string? false?) ; filename
|
||||
(union number? false?) ; position
|
||||
(union string? false?) ; filename
|
||||
(union number? false?) ; position
|
||||
|
||||
> (receive-result event) : (event -> void) The user's program
|
||||
calls this procedure whenever a debugger event occurs. Note that
|
||||
a (make-breakpoint-halt) event will occur whenever the user's
|
||||
> (receive-result event) : (event -> void) The user's program
|
||||
calls this procedure whenever a debugger event occurs. Note that
|
||||
a (make-breakpoint-halt) event will occur whenever the user's
|
||||
program blocks at a breakpoint.
|
||||
|
||||
> debugger-output-port : output from the user's program goes
|
||||
to this port.
|
||||
> debugger-output-port : output from the user's program goes
|
||||
to this port.
|
||||
|
||||
|
||||
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:
|
||||
|
||||
> 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.
|
||||
|
||||
> user-custodian: passed through from the debugger.
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
(module debugger-sig mzscheme
|
||||
(require (lib "unitsig.ss"))
|
||||
|
||||
|
||||
(provide debugger-model^
|
||||
debugger-vc^)
|
||||
|
||||
|
||||
(define-signature debugger-model^
|
||||
(go-semaphore
|
||||
user-custodian
|
||||
go))
|
||||
|
||||
|
||||
(define-signature debugger-vc^
|
||||
(receive-result)))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(module debugger-tool mzscheme
|
||||
(require (lib "contract.ss")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "mred.ss" "mred")
|
||||
(prefix frame: (lib "framework.ss" "framework"))
|
||||
(lib "unitsig.ss")
|
||||
(lib "class.ss")
|
||||
|
|
@ -10,20 +10,20 @@
|
|||
"debugger-sig.ss"
|
||||
"private/debugger-vc.ss"
|
||||
"private/debugger-model.ss"
|
||||
"private/my-macros.ss")
|
||||
|
||||
"private/my-macros.ss")
|
||||
|
||||
(provide tool@)
|
||||
|
||||
|
||||
(define tool@
|
||||
(unit/sig drscheme:tool-exports^
|
||||
(import drscheme:tool^)
|
||||
|
||||
(define (phase1) (void))
|
||||
(define (phase2) (void))
|
||||
|
||||
|
||||
(define debugger-initial-width 500)
|
||||
(define debugger-initial-height 500)
|
||||
|
||||
|
||||
(define debugger-bitmap
|
||||
(bitmap-label-maker
|
||||
"Debug"
|
||||
|
|
@ -32,66 +32,81 @@
|
|||
(define debugger-unit-frame<%>
|
||||
(interface ()
|
||||
on-debugger-close))
|
||||
|
||||
|
||||
(define (debugger-unit-frame-mixin super%)
|
||||
(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])
|
||||
|
||||
|
||||
(define debugger-exists #f)
|
||||
(define/public (on-debugger-close)
|
||||
(set! debugger-exists #f))
|
||||
|
||||
|
||||
(define breakpoints null)
|
||||
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
|
||||
; DEBUGGER MENU
|
||||
|
||||
(define debugger-menu (instantiate menu% () (label "Debugger") (parent (get-menu-bar))))
|
||||
|
||||
(instantiate menu-item% () (label "Add Breakpoint") (parent debugger-menu)
|
||||
(callback (lambda (dc-item dc-event)
|
||||
(set! breakpoints (append breakpoints
|
||||
(list (send (get-definitions-text) get-start-position)))))))
|
||||
|
||||
|
||||
(define debugger-menu
|
||||
(new menu% [label "Debugger"] [parent (get-menu-bar)]))
|
||||
|
||||
(new menu-item%
|
||||
[label "Add Breakpoint"] [parent debugger-menu]
|
||||
[callback
|
||||
(lambda (dc-item dc-event)
|
||||
(set! breakpoints
|
||||
(append breakpoints
|
||||
(list (send (get-definitions-text)
|
||||
get-start-position)))))])
|
||||
|
||||
(define (position->line-n-offset 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)))
|
||||
|
||||
(instantiate menu-item% () (label "List Breakpoints") (parent debugger-menu)
|
||||
(callback (lambda (dc-item dc-event)
|
||||
(message-box "Current Breakpoints"
|
||||
(format "Current breakpoint positions: ~a\n" (apply string-append
|
||||
(map (lambda (pos)
|
||||
(let-values ([(line offset) (position->line-n-offset pos)])
|
||||
(format "<~v:~v> (position ~v)\n" line offset pos)))
|
||||
breakpoints)))
|
||||
this
|
||||
'(ok)))))
|
||||
|
||||
(instantiate menu-item% () (label "Clear All Breakpoints") (parent debugger-menu)
|
||||
(callback (lambda (dc-item dc-event)
|
||||
(set! breakpoints null))))
|
||||
|
||||
|
||||
(new menu-item%
|
||||
[label "List Breakpoints"] [parent debugger-menu]
|
||||
[callback
|
||||
(lambda (dc-item dc-event)
|
||||
(message-box
|
||||
"Current Breakpoints"
|
||||
(format
|
||||
"Current breakpoint positions: ~a\n"
|
||||
(apply string-append
|
||||
(map (lambda (pos)
|
||||
(let-values ([(line offset)
|
||||
(position->line-n-offset pos)])
|
||||
(format "<~v:~v> (position ~v)\n"
|
||||
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
|
||||
(contract
|
||||
(-> (-> 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?)
|
||||
(lambda (init iter)
|
||||
(let* ([lang-settings
|
||||
(let* ([lang-settings
|
||||
(frame:preferences:get
|
||||
(drscheme:language-configuration:get-settings-preferences-symbol))]
|
||||
[lang (drscheme:language-configuration:language-settings-language lang-settings)]
|
||||
[settings (drscheme:language-configuration:language-settings-settings lang-settings)])
|
||||
(drscheme:eval:expand-program
|
||||
(drscheme:language:make-text/pos (get-definitions-text)
|
||||
0
|
||||
(send (get-definitions-text)
|
||||
last-position))
|
||||
(drscheme:language:make-text/pos
|
||||
(get-definitions-text)
|
||||
0
|
||||
(send (get-definitions-text) last-position))
|
||||
lang-settings
|
||||
#f
|
||||
(lambda ()
|
||||
|
|
@ -102,60 +117,61 @@
|
|||
(send lang render-value val settings sp)
|
||||
(let ([str (get-output-string sp)])
|
||||
(if ((string-length str) . <= . len)
|
||||
str
|
||||
(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
|
||||
str
|
||||
(string-append (substring str 0 (max 0 (- len 3)))
|
||||
"..."))))))
|
||||
(drscheme:teachpack:install-teachpacks
|
||||
;; this belongs in model, but I'd need a unit rewrite
|
||||
(frame:preferences:get 'drscheme:teachpacks)))
|
||||
void ; kill
|
||||
iter)))
|
||||
'program-expander
|
||||
'caller))
|
||||
|
||||
(define debugger-button
|
||||
|
||||
(define debugger-button
|
||||
(make-object button%
|
||||
(debugger-bitmap this)
|
||||
(get-button-panel)
|
||||
(lambda (button evt)
|
||||
(if debugger-exists
|
||||
(message-box/custom "Debugger Exists"
|
||||
"There is already a debugger window open for this program."
|
||||
"OK"
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
'(default=1))
|
||||
(begin
|
||||
(set! debugger-exists #t)
|
||||
(start-debugger program-expander this))))))
|
||||
|
||||
(message-box/custom
|
||||
"Debugger Exists"
|
||||
"There is already a debugger window open for this program."
|
||||
"OK" #f #f #f '(default=1))
|
||||
(begin
|
||||
(set! debugger-exists #t)
|
||||
(start-debugger program-expander this))))))
|
||||
|
||||
(define breakpoint-origin (get-definitions-text))
|
||||
|
||||
|
||||
(define (start-debugger program-expander drs-window)
|
||||
(define-values/invoke-unit/sig (go)
|
||||
(compound-unit/sig
|
||||
(compound-unit/sig
|
||||
(import [EXPANDER : (program-expander)]
|
||||
[BREAKPOINTS : (breakpoints breakpoint-origin)]
|
||||
[DRS-WINDOW : (drs-window)])
|
||||
(link [MODEL : debugger-model^ (debugger-model@ VIEW-CONTROLLER EXPANDER BREAKPOINTS)]
|
||||
[VIEW-CONTROLLER : debugger-vc^ (debugger-vc@ MODEL DRS-WINDOW)])
|
||||
(link [MODEL : debugger-model^
|
||||
(debugger-model@ VIEW-CONTROLLER EXPANDER BREAKPOINTS)]
|
||||
[VIEW-CONTROLLER : debugger-vc^
|
||||
(debugger-vc@ MODEL DRS-WINDOW)])
|
||||
(export (var (MODEL go))))
|
||||
#f
|
||||
(program-expander)
|
||||
(breakpoints breakpoint-origin)
|
||||
(drs-window))
|
||||
#f
|
||||
(program-expander)
|
||||
(breakpoints breakpoint-origin)
|
||||
(drs-window))
|
||||
(go))
|
||||
|
||||
|
||||
(rename [super-enable-evaluation enable-evaluation])
|
||||
(define/override (enable-evaluation)
|
||||
(send debugger-button enable #t)
|
||||
(super-enable-evaluation))
|
||||
|
||||
|
||||
(rename [super-disable-evaluation disable-evaluation])
|
||||
(define/override (disable-evaluation)
|
||||
(send debugger-button enable #f)
|
||||
(super-disable-evaluation))
|
||||
|
||||
|
||||
(send (get-button-panel) change-children
|
||||
(lx (cons debugger-button (remq debugger-button _))))))
|
||||
|
||||
|
||||
(drscheme:get/extend:extend-unit-frame debugger-unit-frame-mixin))))
|
||||
|
|
|
|||
|
|
@ -1,17 +1,19 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(define name "Stepper")
|
||||
(define doc.txt "doc.txt")
|
||||
|
||||
|
||||
(define tools '(("stepper+xml-tool.ss")
|
||||
#;("debugger-tool.ss")
|
||||
;; ("debugger-tool.ss")
|
||||
))
|
||||
|
||||
(define tool-names (list "The Stepper"
|
||||
#;"The Debugger"
|
||||
))
|
||||
|
||||
(define tool-icons (list '("foot-up.png" "icons")
|
||||
#;'("foot-up.png" "icons")
|
||||
))
|
||||
(define compile-omit-files `("private/test-annotate.ss" "debugger-tool.ss"))
|
||||
)
|
||||
|
||||
(define tool-names (list "The Stepper"
|
||||
;; "The Debugger"
|
||||
))
|
||||
|
||||
(define tool-icons (list '("foot-up.png" "icons")
|
||||
;; #f
|
||||
))
|
||||
|
||||
(define compile-omit-files `("debugger-tool.ss"))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -5,15 +5,15 @@ The Stepper's use of syntax-property:
|
|||
In order to make macro-unwinding possible, the stepper adds
|
||||
syntax-properties to elaborated code which then informs the
|
||||
reconstruction process about how certain macros were originally
|
||||
formed.
|
||||
formed.
|
||||
|
||||
In fact, the truth is slightly more complicated, because there are
|
||||
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
|
||||
code is expanded according to the macro definitions built into
|
||||
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
|
||||
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
|
||||
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).
|
||||
|
||||
Also, in order to be visible to the reconstructor, these properties
|
||||
must be explicitly transferred from the annotated source code syntax
|
||||
to the reconstructed syntax. This is accomplished by the 'attach-info'
|
||||
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.
|
||||
|
||||
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.
|
||||
|
||||
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'
|
||||
abstraction part ways.
|
||||
abstraction part ways.
|
||||
|
||||
Uses:
|
||||
- applied to the check of the test-variable in the expansion of the
|
||||
'or' macro.
|
||||
- applied to the expansion of the primitives defined with
|
||||
'or' macro.
|
||||
- applied to the expansion of the primitives defined with
|
||||
'define-primitive'.
|
||||
- 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
|
||||
informs the reconstructor what macro this source expression came
|
||||
from.
|
||||
from.
|
||||
|
||||
See notes below about 'being careful with stepper-hint'.
|
||||
|
||||
|
|
@ -87,16 +87,16 @@ stepper-hint :
|
|||
box (inside an xml box)
|
||||
[ '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
|
||||
kind of define they came from.
|
||||
kind of define they came from.
|
||||
|
||||
[ '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.
|
||||
|
||||
[ 'lambda-define ] : this lambda arose from the expansion of
|
||||
[ 'lambda-define ] : this lambda arose from the expansion of
|
||||
(define id (lambda (
|
||||
|
||||
|
||||
|
|
@ -108,7 +108,7 @@ stepper-define-type:
|
|||
the define itself evaporates into an internal define which is then
|
||||
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
|
||||
are three cases we need to distinguish, and two of them are
|
||||
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
|
||||
than the original one shows up ... which _does_ have one of the
|
||||
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
|
||||
this procedure was originally bound. In the absence of set!,
|
||||
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:
|
||||
|
||||
[ '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
|
||||
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.
|
||||
|
||||
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.)
|
||||
|
||||
stepper-prim-name:
|
||||
stepper-prim-name:
|
||||
this is attached to the expansion of primitives introduced with the
|
||||
'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
|
||||
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
|
||||
[ '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
|
||||
with a given 'if' in the expansion of an 'and' or 'or'.
|
||||
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.
|
||||
(Transferred.)
|
||||
|
||||
stepper-skipto :
|
||||
stepper-skipto :
|
||||
this instructs the annotator to look inside the current expression
|
||||
along a given path for the expression to be annotated. In
|
||||
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
|
||||
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
|
||||
replaces a beginner's 'else' with, it is later transferred
|
||||
to the 'if' wrapping that 'true'. This is because there is no
|
||||
|
|
@ -218,8 +218,8 @@ stepper-test-suite-hint :
|
|||
stepper-highlight :
|
||||
this expression will be highlighted.
|
||||
(Not currently tranferred...?)
|
||||
|
||||
|
||||
|
||||
|
||||
STEPPER-HINT COLLISIONS
|
||||
|
||||
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 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.
|
||||
|
||||
Q.E.D.
|
||||
|
||||
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
|
||||
of the beginner cond does not add any stepper-hint properties, so no
|
||||
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 stand.
|
||||
|
|
|
|||
|
|
@ -5,15 +5,16 @@
|
|||
"xml-tool.ss")
|
||||
|
||||
(provide tool@)
|
||||
|
||||
;; the xml and stepper tools are combined, so that the stepper can create XML snips.
|
||||
;; note that both of these tools provide 'void' for phase1 and phase2 (which together
|
||||
;; make up the tool-exports^), so we can provide either one of these for the compound
|
||||
;; unit. Doesn't matter.
|
||||
|
||||
|
||||
;; the xml and stepper tools are combined, so that the stepper can create XML
|
||||
;; snips. note that both of these tools provide 'void' for phase1 and phase2
|
||||
;; (which together make up the tool-exports^), so we can provide either one
|
||||
;; of these for the compound unit. Doesn't matter.
|
||||
|
||||
(define tool@
|
||||
(compound-unit/sig
|
||||
(import (TOOL-IMPORTS : drscheme:tool^))
|
||||
(link (XML-TOOL : (xml-snip% scheme-snip%) (xml-tool@ TOOL-IMPORTS))
|
||||
(STEPPER-TOOL : drscheme:tool-exports^ (stepper-tool@ TOOL-IMPORTS XML-TOOL)))
|
||||
(export (open STEPPER-TOOL)))))
|
||||
(STEPPER-TOOL : drscheme:tool-exports^
|
||||
(stepper-tool@ TOOL-IMPORTS XML-TOOL)))
|
||||
(export (open STEPPER-TOOL)))))
|
||||
|
|
|
|||
|
|
@ -269,10 +269,14 @@
|
|||
[(waiting-for-application)
|
||||
(or (eq? step-kind 'user-application)
|
||||
(eq? step-kind 'finished-stepping))]
|
||||
[(#f) (error 'right-kind-of-step "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?)]))
|
||||
[(#f) (error 'right-kind-of-step
|
||||
"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)
|
||||
(set! release-for-next-step (cadr view-triple))
|
||||
(set! view-history (append view-history
|
||||
|
|
@ -308,7 +312,9 @@
|
|||
(if (< new-view (length view-history))
|
||||
(update-view/existing new-view)
|
||||
(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?
|
||||
(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)])
|
||||
|
|
@ -407,7 +413,8 @@
|
|||
(send e end-edit-sequence))
|
||||
(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)
|
||||
(let* ([can-go-back? (> view 0)])
|
||||
(send previous-button enable can-go-back?)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user