removed unused debugger files
svn: r15000
This commit is contained in:
John Clements
parent
55a2990543
commit
b181309703
|
|
@ -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...).
|
||||
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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)))))))))
|
||||
|
||||
|
|
@ -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 <x>) : value of a named variable
|
||||
(src) : the source code
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user