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

10
collects/stepper/break.ss
View File

@ -9,17 +9,17 @@
"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
default-current-breakpoint-handler
(lambda (new-handler) (lambda (new-handler)
(if (and (procedure? new-handler) (if (and (procedure? new-handler)
(procedure-arity-includes? new-handler 0)) (procedure-arity-includes? new-handler 0))
new-handler 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)]) (provide/contract [break (-> any)])
(define (break) (define (break)
((current-breakpoint-handler)))) ((current-breakpoint-handler))))

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

@ -36,7 +36,8 @@
(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)
@ -49,37 +50,51 @@
; 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) (new menu-item%
(callback (lambda (dc-item dc-event) [label "Add Breakpoint"] [parent debugger-menu]
(set! breakpoints (append breakpoints [callback
(list (send (get-definitions-text) get-start-position))))))) (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)
(message-box
"Current Breakpoints"
(format
"Current breakpoint positions: ~a\n"
(apply string-append
(map (lambda (pos) (map (lambda (pos)
(let-values ([(line offset) (position->line-n-offset pos)]) (let-values ([(line offset)
(format "<~v:~v> (position ~v)\n" line offset pos))) (position->line-n-offset pos)])
(format "<~v:~v> (position ~v)\n"
line offset pos)))
breakpoints))) breakpoints)))
this this
'(ok))))) '(ok)))])
(instantiate menu-item% () (label "Clear All Breakpoints") (parent debugger-menu) (new menu-item%
(callback (lambda (dc-item dc-event) [label "Clear All Breakpoints"] [parent debugger-menu]
(set! breakpoints null)))) [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
@ -88,10 +103,10 @@
[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
(get-definitions-text)
0 0
(send (get-definitions-text) (send (get-definitions-text) last-position))
last-position))
lang-settings lang-settings
#f #f
(lambda () (lambda ()
@ -103,9 +118,11 @@
(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 (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 void ; kill
iter))) iter)))
'program-expander 'program-expander
@ -117,13 +134,10 @@
(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
"Debugger Exists"
"There is already a debugger window open for this program." "There is already a debugger window open for this program."
"OK" "OK" #f #f #f '(default=1))
#f
#f
#f
'(default=1))
(begin (begin
(set! debugger-exists #t) (set! debugger-exists #t)
(start-debugger program-expander this)))))) (start-debugger program-expander this))))))
@ -136,8 +150,10 @@
(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)

12
collects/stepper/info.ss
View File

@ -3,15 +3,17 @@
(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"))
)

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

@ -6,14 +6,15 @@
(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^
(stepper-tool@ TOOL-IMPORTS XML-TOOL)))
(export (open STEPPER-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?)