From b181309703b762f6013de79f54a3c98fcbabccbb Mon Sep 17 00:00:00 2001 From: John Clements Date: Wed, 27 May 2009 23:17:39 +0000 Subject: [PATCH] removed unused debugger files svn: r15000 --- collects/stepper/debugger-doc.txt | 104 ----------- collects/stepper/debugger-sig.ss | 13 -- collects/stepper/debugger-tool.ss | 175 ------------------ collects/stepper/private/debugger-annotate.ss | 171 ----------------- collects/stepper/private/debugger-bindings.ss | 124 ------------- collects/stepper/private/debugger-model.ss | 81 -------- collects/stepper/private/debugger-summary.txt | 16 -- collects/stepper/private/debugger-vc.ss | 102 ---------- collects/stepper/private/model-settings.ss | 2 +- 9 files changed, 1 insertion(+), 787 deletions(-) delete mode 100644 collects/stepper/debugger-doc.txt delete mode 100644 collects/stepper/debugger-sig.ss delete mode 100644 collects/stepper/debugger-tool.ss delete mode 100644 collects/stepper/private/debugger-annotate.ss delete mode 100644 collects/stepper/private/debugger-bindings.ss delete mode 100644 collects/stepper/private/debugger-model.ss delete mode 100644 collects/stepper/private/debugger-summary.txt delete mode 100644 collects/stepper/private/debugger-vc.ss diff --git a/collects/stepper/debugger-doc.txt b/collects/stepper/debugger-doc.txt deleted file mode 100644 index 7c5dcbe661..0000000000 --- a/collects/stepper/debugger-doc.txt +++ /dev/null @@ -1,104 +0,0 @@ ---- - -Preliminary _Debugger_ Documentation - -The debugger is structured as an interaction between the program -being debugged and a debugger UI. The program is annotated to -produce a stream of debugger "events" (as defined below) and to -periodically block on a debugger semaphore. The debugger currently -uses the stepper's annotation; changes to the annotation will -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 -UI. - -Debugger Events: - -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?) - debugger-event?) -> (make-error-breakpoint-info message) - : (-> string? - debugger-event?) -> (make-expression-finished returned-value-list) - : (-> (listof any?) - debugger-event?) - -> (make-full-mark location label bindings) - : (-> syntax? symbol? (listof identifier?) - syntax?) - -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 -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? - (listof (list/p identifier? any?)))) - - -Debugger UI (view-controller) signatures: - - (define-signature debugger-model^ - (go-semaphore - 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). - -> go-semaphore: when the user's program halts at a breakpoint, -it will block on this semaphore. Therefore, the UI can -post to this semaphore to allow computation to proceed. - -> user-custodian: the user-custodian governs the user's program. -Therefore, the UI can shut down this custodian to halt debugging. - -> (set-breakpoint location [name]): (location -> number) -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 - -> (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. - - -Existing mini-UI: - -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 -the execution of the program. - -> user-custodian: passed through from the debugger. - -In addition, the mini-UI prints a message to the grepl whenever -an event occurs (which is cheerfully accepted as input the next -time the user presses return...). - diff --git a/collects/stepper/debugger-sig.ss b/collects/stepper/debugger-sig.ss deleted file mode 100644 index 806c4cd2bd..0000000000 --- a/collects/stepper/debugger-sig.ss +++ /dev/null @@ -1,13 +0,0 @@ -(module debugger-sig mzscheme - (require mzlib/unitsig) - - (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 deleted file mode 100644 index 76df2b6241..0000000000 --- a/collects/stepper/debugger-tool.ss +++ /dev/null @@ -1,175 +0,0 @@ -(module debugger-tool mzscheme - (require mzlib/contract - drscheme/tool - mred - (prefix frame: framework) - mzlib/unitsig - mzlib/class - mzlib/list - mrlib/bitmap-label - "debugger-sig.ss" - "private/debugger-vc.ss" - "private/debugger-model.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" - (build-path (collection-path "icons") "foot.png"))) - - (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) - (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 - (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))]) - (values line offset))) - - (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 - void?) - (lambda (init iter) - (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)) - lang-settings - #f - (lambda () - (init) - (error-value->string-handler - (lambda (val len) - (let ([sp (open-output-string)]) - (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))) - "..."))))))) - void ; kill - iter))) - 'program-expander - 'caller)) - - (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)))))) - - (define breakpoint-origin (get-definitions-text)) - - (define (start-debugger program-expander drs-window) - (define-values/invoke-unit/sig (go) - (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)]) - (export (var (MODEL go)))) - #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/private/debugger-annotate.ss b/collects/stepper/private/debugger-annotate.ss deleted file mode 100644 index b8d803c215..0000000000 --- a/collects/stepper/private/debugger-annotate.ss +++ /dev/null @@ -1,171 +0,0 @@ -(module debugger-annotate scheme/base - - (require (prefix-in kernel: syntax/kerncase) - "shared.ss" - "marks.ss" - mzlib/contract) - - (define count 0) - - (provide annotate) - - (define (arglist-bindings arglist-stx) - (syntax-case arglist-stx () - [var - (identifier? arglist-stx) - (list arglist-stx)] - [(var ...) - (syntax->list arglist-stx)] - [(var . others) - (cons #'var (arglist-bindings #'others))])) - - (define (annotate stx breakpoints breakpoint-origin break) - - (define (top-level-annotate stx) - (kernel:kernel-syntax-case stx #f - [(module identifier name (#%plain-module-begin . module-level-exprs)) - (quasisyntax/loc stx (module identifier name - (#%plain-module-begin - #,@(map module-level-expr-iterator - (syntax->list #'module-level-exprs)))))] - [else-stx - (general-top-level-expr-iterator stx)])) - - (define (module-level-expr-iterator stx) - (kernel:kernel-syntax-case stx #f - [(#%provide . provide-specs) - stx] - [else-stx - (general-top-level-expr-iterator stx)])) - - (define (general-top-level-expr-iterator stx) - (kernel:kernel-syntax-case stx #f - [(define-values (var ...) expr) - #`(define-values (var ...) - #,(annotate #`expr (syntax->list #`(var ...)) #t))] - [(define-syntaxes (var ...) expr) - stx] - [(begin . top-level-exprs) - (quasisyntax/loc stx (begin #,@(map (lambda (expr) - (module-level-expr-iterator expr)) - (syntax->list #'top-level-exprs))))] - [(#%require . require-specs) - stx] - [else - (annotate stx '() #f)])) - - (define (annotate expr bound-vars is-tail?) - - (define (let/rec-values-annotator letrec?) - (kernel:kernel-syntax-case expr #f - [(label (((var ...) rhs) ...) . bodies) - (let* ([new-bindings (apply append (map syntax->list (syntax->list #`((var ...) ...))))] - [new-rhs (if letrec? - (map (lambda (expr) (annotate expr (append new-bindings bound-vars) #f)) - (syntax->list #`(rhs ...))) - (map (lambda (expr) (annotate expr bound-vars #f)) - (syntax->list #`(rhs ...))))] - [last-body (car (reverse (syntax->list #`bodies)))] - [all-but-last-body (reverse (cdr (reverse (syntax->list #`bodies))))] - [bodies (append (map (lambda (expr) (annotate expr (append new-bindings bound-vars) #f)) - all-but-last-body) - (list (annotate last-body (append new-bindings bound-vars) is-tail?)))]) - (with-syntax ([(new-rhs/trans ...) new-rhs]) - (quasisyntax/loc expr - (label (((var ...) new-rhs/trans) ...) - #,@bodies))))])) - - (define (lambda-clause-annotator clause) - (kernel:kernel-syntax-case clause #f - [(arg-list . bodies) - (let* ([new-bound-vars (append (arglist-bindings #`arg-list) bound-vars)] - [new-bodies (let loop ([bodies (syntax->list #`bodies)]) - (if (equal? '() (cdr bodies)) - (list (annotate (car bodies) new-bound-vars #t)) - (cons (annotate (car bodies) new-bound-vars #f) - (loop (cdr bodies)))))]) - (quasisyntax/loc clause - (arg-list #,@new-bodies)))])) - - (define (break-wrap debug-info annotated) - #`(begin - (#,break (current-continuation-marks) 'debugger-break #,debug-info) - #,annotated)) - - (define annotated - (kernel:kernel-syntax-case expr #f - [var-stx (identifier? (syntax var-stx)) expr] - - [(#%plain-lambda . clause) - (quasisyntax/loc expr - (#%plain-lambda #,@(lambda-clause-annotator #`clause)))] - - [(case-lambda . clauses) - (quasisyntax/loc expr - (case-lambda #,@(map lambda-clause-annotator (syntax->list #`clauses))))] - - [(if test then else) - (quasisyntax/loc expr (if #,(annotate #`test bound-vars #f) - #,(annotate #`then bound-vars is-tail?) - #,(annotate #`else bound-vars is-tail?)))] - - [(begin . bodies) - (letrec ([traverse - (lambda (lst) - (if (and (pair? lst) (equal? '() (cdr lst))) - `(,(annotate (car lst) bound-vars is-tail?)) - (cons (annotate (car lst) bound-vars #f) - (traverse (cdr lst)))))]) - (quasisyntax/loc expr (begin #,@(traverse (syntax->list #`bodies)))))] - - [(begin0 . bodies) - (quasisyntax/loc expr (begin0 #,@(map (lambda (expr) - (annotate expr bound-vars #f)) - (syntax->list #`bodies))))] - - [(let-values . clause) - (let/rec-values-annotator #f)] - - [(letrec-values . clause) - (let/rec-values-annotator #t)] - - [(set! var val) - (quasisyntax/loc expr (set! var #,(annotate #`val bound-vars #f)))] - - [(quote _) expr] - - [(quote-syntax _) expr] - - ;; FIXME: we have to think harder about this - [(with-continuation-mark key mark body) - (quasisyntax/loc expr (with-continuation-mark key - #,(annotate #`mark bound-vars #f) - #,(annotate #`body bound-vars is-tail?)))] - - [(#%plain-app . exprs) - (let ([subexprs (map (lambda (expr) - (annotate expr bound-vars #f)) - (syntax->list #`exprs))]) - (if is-tail? - (quasisyntax/loc expr #,subexprs) - (wcm-wrap (make-debug-info expr bound-vars bound-vars 'normal #f) - (quasisyntax/loc expr #,subexprs))))] - - [(#%top . var) expr] - - [else (error 'expr-syntax-object-iterator "unknown expr: ~a" - (syntax->datum expr))])) - - (set! count (+ count 1)) - (when (= (modulo count 100) 0) - (fprintf (current-error-port) "syntax-source: ~v\nsyntax-position: ~v\n" (syntax-source expr) (syntax-position expr))) - - - (if (and (eq? (syntax-source expr) breakpoint-origin) - (memq (- (syntax-position expr) 1) ; syntax positions start at one. - breakpoints)) - (break-wrap (make-debug-info expr bound-vars bound-vars 'at-break #f) - annotated) - annotated)) - - (top-level-annotate stx))) diff --git a/collects/stepper/private/debugger-bindings.ss b/collects/stepper/private/debugger-bindings.ss deleted file mode 100644 index e5518fbb20..0000000000 --- a/collects/stepper/private/debugger-bindings.ss +++ /dev/null @@ -1,124 +0,0 @@ -; this module is a cheap hack; it interacts with the debugger -; REPL by getting & setting values in the top-level environment - -(module debugger-bindings mzscheme - (require mzlib/contract - "marks.ss" - mzlib/etc - mzlib/list - (prefix kernel: syntax/kerncase)) - - (provide/contract [set-event-num! (-> number? void?)] - [bt (-> void?)] - [set-frame-num! (-> number? void?)] - [src (-> void?)] - [binding (-> symbol? any)]) - - (provide install-debugger-bindings) - - (define (install-debugger-bindings) - ; yuck! dependence on the list of names provided by the module - (namespace-set-variable-value! 'e set-event-num!) - (namespace-set-variable-value! 'bt bt) - (namespace-set-variable-value! 'f set-frame-num!) - (namespace-set-variable-value! 'src src) - (namespace-set-variable-value! 'v binding) - (namespace-set-variable-value! 'c continue) - (namespace-set-variable-value! 'bound bound) - (namespace-set-variable-value! 'help help)) - - (define (help) - (printf "Help Summary:\n") - (call-with-input-file (build-path (collection-path "stepper" "private") "debugger-summary.txt") - (lambda (port) - (let loop ([line (read-line port)]) - (unless (eof-object? line) - (printf "~a\n" line) - (loop (read-line port))))))) - - (define (continue) - (semaphore-post (namespace-variable-value 'go-semaphore))) - - (define (events) - ((namespace-variable-value 'events))) - - (define (current-event-num) - (namespace-variable-value 'current-event-num)) - - (define (current-event) - (list-ref (events) (current-event-num))) - - ; this retrieves the mark list from the most recent event with normal breakpoint info - ; unless an event with breakpoint info has been specified, in which case it returns that - (define (current-mark-list) - (if (normal-breakpoint-info? (current-event)) - (normal-breakpoint-info-mark-list (current-event)) - (let loop ((l (reverse (events)))) - (cond - ((null? l) (error 'current-mark-list "no events with mark lists: ~v" (events))) - ((normal-breakpoint-info? (car l)) (normal-breakpoint-info-mark-list (car l))) - (else (loop (cdr l))))))) - - (define (current-frame-num) - (namespace-variable-value 'current-frame-num)) - - (define (current-frame) - (list-ref (current-mark-list) (current-frame-num))) - - (define (check-range num bottom top) - (when (or (< num bottom) (> num top)) - (error 'check-range "argument ~v out of range [~v ... ~v]" num bottom top))) - - ; pretty-print code (represented as sexp) - ; stolen from MrFlow - (define (simplify t) - (kernel:kernel-syntax-case t #f - [(#%plain-app . rest) (map simplify (syntax->list #`rest))] - [(#%top . v) #`v] - [(a ...) (map simplify (syntax->list #`(a ...)))] - [x #`x])) - - (define (unexpand t) - (if (pair? t) - (let ([kw (car t)]) - (if (list? t) - (cond - [(eq? kw '#%app) (map unexpand (cdr t))] - [(eq? kw '#%plain-app) (map unexpand (cdr t))] - [else (map unexpand t)]) - (cond - [(eq? kw '#%top) (cdr t)] - [else t]))) - t)) - - (define (set-event-num! num) - (check-range num 0 (- (length (events)) 1)) - (namespace-set-variable-value! 'current-event-num num) - (namespace-set-variable-value! 'current-frame-num 0)) - - (define (set-frame-num! num) - (check-range num 0 (- (length (current-mark-list)) 1)) - (namespace-set-variable-value! 'current-frame-num num)) - - (define (bt) - (for-each - (lambda (mark num) - (printf "~v: ~v\n" num (unexpand (syntax-object->datum (mark-source mark))))) - (current-mark-list) - (build-list (length (current-mark-list)) (lambda (x) x)))) - - (define (src) - (let ([source (mark-source (list-ref (current-mark-list) (current-frame-num)))]) - ((namespace-variable-value 'highlight-source-position) (syntax-position source)) - (printf "~v\n" source))) - - (define (binding sym) - (map (lambda (binding) (list (mark-binding-binding binding) (mark-binding-value binding))) - (lookup-all-bindings (lambda (id) (eq? (syntax-e id) sym)) (do-n-times cdr (current-frame-num) (current-mark-list))))) - - (define (bound) - (map (lambda (binding) (list (syntax-e binding) binding)) - (all-bindings (car (do-n-times cdr (current-frame-num) (current-mark-list)))))) - - (define (do-n-times fn n arg) - (foldl (lambda (x arg) (fn arg)) arg (build-list n (lambda (x) x))))) diff --git a/collects/stepper/private/debugger-model.ss b/collects/stepper/private/debugger-model.ss deleted file mode 100644 index 10b4786ed7..0000000000 --- a/collects/stepper/private/debugger-model.ss +++ /dev/null @@ -1,81 +0,0 @@ -(module debugger-model mzscheme - (require mzlib/unitsig - mzlib/contract - mzlib/etc - mred - stepper/debugger-sig - "my-macros.ss" - "debugger-annotate.ss" - "shared.ss" - "marks.ss" - "debugger-vc.ss" - "debugger-bindings.ss") - - - (define program-expander-contract - (-> (-> void?) ; init - (-> (or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) void?) ; iter - void?)) - - (provide debugger-model@) - - ;(provide/contract [go (-> program-expander-contract ; program-expander - ; void?)]) - - (define (send-to-eventspace eventspace thunk) - (parameterize ([current-eventspace eventspace]) - (queue-callback thunk))) - - (define debugger-debugger-error-port (current-error-port)) - - (define debugger-model@ - (unit/sig debugger-model^ - (import debugger-vc^ - (program-expander) - (breakpoints breakpoint-origin)) - - (define go-semaphore (make-semaphore)) - (define user-custodian (make-custodian)) - - (define queue-eventspace (make-eventspace)) - - (define (queue-result result) - (send-to-eventspace - queue-eventspace - (lambda () - (receive-result result)))) - - (define basic-eval (current-eval)) - - (define (break mark-set kind final-mark) - (let ([mark-list (continuation-mark-set->list mark-set debug-key)]) - (queue-result (make-normal-breakpoint-info (cons final-mark mark-list) kind)) - (queue-result (make-breakpoint-halt)) - (semaphore-wait go-semaphore))) - - - (define (step-through-expression expanded expand-next-expression) - (with-output-to-file "/dev/stderr" - (printf "about-to-annotate\n")) - (let* ([annotated (annotate expanded breakpoints breakpoint-origin break)]) - ; (fprintf (current-error-port) "annotated: ~v\n" (syntax-object->datum annotated)) - (let ([expression-result - (parameterize ([current-eval basic-eval]) - (eval annotated))]) - (queue-result (make-expression-finished (list expression-result))) - (queue-result (make-breakpoint-halt)) - (semaphore-wait go-semaphore) - (expand-next-expression)))) - - (define (err-display-handler message exn) - (queue-result (make-error-breakpoint-info message))) - - (define (go) - (parameterize ([current-custodian user-custodian]) - (program-expander - (lambda () - (error-display-handler err-display-handler)) ; init - (lambda (expanded continue-thunk) ; iter - (unless (eof-object? expanded) - (step-through-expression expanded continue-thunk))))))))) - diff --git a/collects/stepper/private/debugger-summary.txt b/collects/stepper/private/debugger-summary.txt deleted file mode 100644 index a92604bfc0..0000000000 --- a/collects/stepper/private/debugger-summary.txt +++ /dev/null @@ -1,16 +0,0 @@ - -(c) : continue execution (more accurately, post to the continue semaphore) -(events) : show all debugging events -(e #) : pick which event to examine - -... the following are all implicitly parameterized - by the chosen event: - - (bt) : summarize the continuation - (f #) : examine the #th frame of the continuation - - ... the following are all implicitly parameterized - by the chosen frame - (bound) : all bound vars - (v ) : value of a named variable - (src) : the source code diff --git a/collects/stepper/private/debugger-vc.ss b/collects/stepper/private/debugger-vc.ss deleted file mode 100644 index 89f3296fea..0000000000 --- a/collects/stepper/private/debugger-vc.ss +++ /dev/null @@ -1,102 +0,0 @@ -(module debugger-vc mzscheme - (require mzlib/unitsig - stepper/debugger-sig - mred - mzlib/class - framework - "marks.ss" - "debugger-bindings.ss") - - (provide debugger-vc@) - - (define debugger-vc@ - (unit/sig debugger-vc^ - (import debugger-model^ - (drs-window)) - - (define debugger-eventspace - (parameterize ([current-custodian user-custodian]) - (make-eventspace))) - - (define (receive-result result) - (set! event-list (append event-list (list result))) - (parameterize ([current-eventspace debugger-eventspace]) - (queue-callback - (lambda () - (namespace-set-variable-value! 'current-event-num (- (length event-list) 1)) - (namespace-set-variable-value! 'current-frame-num 0)))) - (send-output-to-debugger-window (format-event result) debugger-output)) - - (define (format-event debugger-event) - (cond [(normal-breakpoint-info? debugger-event) - (when (null? (normal-breakpoint-info-mark-list debugger-event)) - (error 'format-event "mark list was empty")) ; should never happen; at-brpt mark should always be there - (format "normal breakpoint\nsource:~v\n" (mark-source (car (normal-breakpoint-info-mark-list debugger-event))))] - [(error-breakpoint-info? debugger-event) - (format "error breakpoint\nmessage: ~v\n" (error-breakpoint-info-message debugger-event))] - [(breakpoint-halt? debugger-event) - (format "breakpoint halt\n")] - [(expression-finished? debugger-event) - (format "expression finished\nresults: ~v\n" (expression-finished-returned-value-list debugger-event))])) - - - (define event-list null) - - (define (events) event-list) - - (thread - (lambda () - (graphical-read-eval-print-loop debugger-eventspace #t))) - - (define (highlight-source-position posn) - (send (send drs-window get-definitions-text) - set-position - posn - (+ 1 posn))) - - (define debugger-output (make-output-window drs-window user-custodian)) - - ; set up debugger eventspace - - (parameterize ([current-eventspace debugger-eventspace]) - (queue-callback - (lambda () - (namespace-set-variable-value! 'go-semaphore go-semaphore) - (namespace-set-variable-value! 'events events) - (namespace-set-variable-value! 'user-custodian user-custodian) - (namespace-set-variable-value! 'highlight-source-position highlight-source-position) - (install-debugger-bindings)))))) - - ;; Info functions: - - ;; Debugger Output Window: - - (define output-frame% - (class frame:basic% () - - (init-field drs-window) - (init-field user-custodian) - - (define/override (on-close) - (send drs-window on-debugger-close) - (custodian-shutdown-all user-custodian)) - - (super-instantiate ()))) - - ; make-output-window : (-> text:basic%) - (define (make-output-window drs-window cust) - (let* ([frame (instantiate output-frame% () - (label "Debugger Output") - (width 400) - (height 400) - (drs-window drs-window) - (user-custodian cust))] - [canvas (instantiate canvas:basic% () (parent (send frame get-area-container)))] - [text (instantiate text:basic% ())]) - (send canvas set-editor text) - (send frame show #t) - text)) - - ; send-output-to-debugger-window : (string text:basic% -> void) - (define (send-output-to-debugger-window str text) - (send text insert str (send text last-position)))) diff --git a/collects/stepper/private/model-settings.ss b/collects/stepper/private/model-settings.ss index 070cd825d9..7b4449c18a 100644 --- a/collects/stepper/private/model-settings.ss +++ b/collects/stepper/private/model-settings.ss @@ -9,7 +9,7 @@ ; reason 2) the render-settings should be recomputed once for each stepper ; invocation. invoke-unit is a nice way of doing this without dropping back ; to linking-by-position, which is what happens with a simple closure - ; implementatian. + ; implementation. ; HOWEVER, like I said, it's just too painful. Once this is a unit, then ; everything else wants to be a unit too. For instance, to make sure that