From 64739e89a70ec9ea701ab8d79b9f0ae041cdf858 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 9 Aug 2006 23:12:00 +0000 Subject: [PATCH] more reformatting svn: r4013 --- collects/stepper/break.ss | 28 ++--- collects/stepper/debugger-doc.txt | 34 +++--- collects/stepper/debugger-sig.ss | 6 +- collects/stepper/debugger-tool.ss | 162 +++++++++++++++------------ collects/stepper/info.ss | 26 +++-- collects/stepper/internal-docs.txt | 68 +++++------ collects/stepper/stepper+xml-tool.ss | 17 +-- collects/stepper/stepper-tool.ss | 17 ++- 8 files changed, 192 insertions(+), 166 deletions(-) diff --git a/collects/stepper/break.ss b/collects/stepper/break.ss index 1f39d6c8fc..826dc66381 100644 --- a/collects/stepper/break.ss +++ b/collects/stepper/break.ss @@ -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)))) - - \ No newline at end of file diff --git a/collects/stepper/debugger-doc.txt b/collects/stepper/debugger-doc.txt index d09afc817a..7c5dcbe661 100644 --- a/collects/stepper/debugger-doc.txt +++ b/collects/stepper/debugger-doc.txt @@ -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. diff --git a/collects/stepper/debugger-sig.ss b/collects/stepper/debugger-sig.ss index 0d085cd651..32213bcc46 100644 --- a/collects/stepper/debugger-sig.ss +++ b/collects/stepper/debugger-sig.ss @@ -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))) diff --git a/collects/stepper/debugger-tool.ss b/collects/stepper/debugger-tool.ss index 8d49213360..f33cbcbed2 100644 --- a/collects/stepper/debugger-tool.ss +++ b/collects/stepper/debugger-tool.ss @@ -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)))) diff --git a/collects/stepper/info.ss b/collects/stepper/info.ss index 68db9016ea..56961f9c33 100644 --- a/collects/stepper/info.ss +++ b/collects/stepper/info.ss @@ -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")) + + ) diff --git a/collects/stepper/internal-docs.txt b/collects/stepper/internal-docs.txt index 2090349fde..449353e213 100644 --- a/collects/stepper/internal-docs.txt +++ b/collects/stepper/internal-docs.txt @@ -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. diff --git a/collects/stepper/stepper+xml-tool.ss b/collects/stepper/stepper+xml-tool.ss index 0af55b5513..b97b1d3802 100644 --- a/collects/stepper/stepper+xml-tool.ss +++ b/collects/stepper/stepper+xml-tool.ss @@ -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))))) \ No newline at end of file + (STEPPER-TOOL : drscheme:tool-exports^ + (stepper-tool@ TOOL-IMPORTS XML-TOOL))) + (export (open STEPPER-TOOL))))) diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index 1810de534c..e49f3f350e 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -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?)