7d50e61c7f
* Another big chunk of v4-require-isms * Allow `#lang framework/keybinding-lang' for keybinding files * Move hierlist sources into "mrlib/hierlist", leave stub behind svn: r10689
103 lines
3.8 KiB
Scheme
103 lines
3.8 KiB
Scheme
(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))))
|