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
|
; 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
|
; 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
|
; 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
|
; 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
|
; everything else wants to be a unit too. For instance, to make sure that
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user