more reformatting
svn: r4013
This commit is contained in:
Eli Barzilay
parent
d8d91aff0b
commit
64739e89a7
|
|
@ -9,17 +9,17 @@
|
|||
"The current-breakpoint-handler parameter has not yet been set in this thread."))
|
||||
|
||||
(define current-breakpoint-handler
|
||||
(make-parameter default-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)))))
|
||||
|
||||
(error 'current-breakpoint-handler
|
||||
"Bad value for current-breakpoint-handler: ~e"
|
||||
new-handler)))))
|
||||
|
||||
(provide/contract [break (-> any)])
|
||||
|
||||
(define (break)
|
||||
((current-breakpoint-handler))))
|
||||
|
||||
|
||||
|
|
@ -36,7 +36,8 @@
|
|||
(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)
|
||||
|
|
@ -49,37 +50,51 @@
|
|||
|
||||
; 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)
|
||||
(set! breakpoints (append breakpoints
|
||||
(list (send (get-definitions-text) get-start-position)))))))
|
||||
(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
|
||||
(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)))
|
||||
(let-values ([(line offset)
|
||||
(position->line-n-offset pos)])
|
||||
(format "<~v:~v> (position ~v)\n"
|
||||
line offset pos)))
|
||||
breakpoints)))
|
||||
this
|
||||
'(ok)))))
|
||||
'(ok)))])
|
||||
|
||||
(instantiate menu-item% () (label "Clear All Breakpoints") (parent debugger-menu)
|
||||
(callback (lambda (dc-item dc-event)
|
||||
(set! breakpoints null))))
|
||||
(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
|
||||
|
|
@ -88,10 +103,10 @@
|
|||
[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)
|
||||
(drscheme:language:make-text/pos
|
||||
(get-definitions-text)
|
||||
0
|
||||
(send (get-definitions-text)
|
||||
last-position))
|
||||
(send (get-definitions-text) last-position))
|
||||
lang-settings
|
||||
#f
|
||||
(lambda ()
|
||||
|
|
@ -103,9 +118,11 @@
|
|||
(let ([str (get-output-string sp)])
|
||||
(if ((string-length str) . <= . len)
|
||||
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
|
||||
;; this belongs in model, but I'd need a unit rewrite
|
||||
(frame:preferences:get 'drscheme:teachpacks)))
|
||||
void ; kill
|
||||
iter)))
|
||||
'program-expander
|
||||
|
|
@ -117,13 +134,10 @@
|
|||
(get-button-panel)
|
||||
(lambda (button evt)
|
||||
(if debugger-exists
|
||||
(message-box/custom "Debugger Exists"
|
||||
(message-box/custom
|
||||
"Debugger Exists"
|
||||
"There is already a debugger window open for this program."
|
||||
"OK"
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
'(default=1))
|
||||
"OK" #f #f #f '(default=1))
|
||||
(begin
|
||||
(set! debugger-exists #t)
|
||||
(start-debugger program-expander this))))))
|
||||
|
|
@ -136,8 +150,10 @@
|
|||
(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)
|
||||
|
|
|
|||
|
|
@ -3,15 +3,17 @@
|
|||
(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"
|
||||
;; "The Debugger"
|
||||
))
|
||||
|
||||
(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"))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -6,14 +6,15 @@
|
|||
|
||||
(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)))
|
||||
(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