add support for stack navigation, along with a bit more documentation
refactor some large blocks of code and add a few comments svn: r8791
This commit is contained in:
Greg Cooper
parent
c569701f4c
commit
c4b76ea3dc
|
|
@ -79,15 +79,27 @@
|
||||||
(loop (add1 i)))
|
(loop (add1 i)))
|
||||||
#f)))
|
#f)))
|
||||||
|
|
||||||
|
;; trim-expr-str: string -> string
|
||||||
|
;; examples:
|
||||||
|
;; short-id => short-id
|
||||||
|
;; really-long-identifier => really-lon...
|
||||||
|
;; (<form>) => (<form>)
|
||||||
|
;; (<form> <arg1> ... <argn>) => (<form> ...)
|
||||||
(define (trim-expr-str str)
|
(define (trim-expr-str str)
|
||||||
|
(let ([starts-with-paren (and (> (string-length str) 0))])
|
||||||
(cond
|
(cond
|
||||||
[(index-of #\newline str) => (lambda (i)
|
[(and starts-with-paren
|
||||||
|
(or (index-of #\space str)
|
||||||
|
(index-of #\newline str)
|
||||||
|
(and (> (string-length str) 14) 10)))
|
||||||
|
;; non-atomic expr: truncate to (form-name ...)
|
||||||
|
=> (lambda (i)
|
||||||
(string-append
|
(string-append
|
||||||
(substring str 0 i)
|
(substring str 0 i)
|
||||||
(if (char=? (string-ref str 0) #\()
|
(if starts-with-paren
|
||||||
" ...)"
|
" ...)"
|
||||||
" ...")))]
|
" ...")))]
|
||||||
[str]))
|
[str])))
|
||||||
|
|
||||||
(define (average . values)
|
(define (average . values)
|
||||||
(/ (apply + values) (length values)))
|
(/ (apply + values) (length values)))
|
||||||
|
|
@ -117,8 +129,7 @@
|
||||||
(cond
|
(cond
|
||||||
[(is-a? source editor<%>) source]
|
[(is-a? source editor<%>) source]
|
||||||
[(or (not source) (symbol? source)) #f]
|
[(or (not source) (symbol? source)) #f]
|
||||||
[(and source (not (symbol? source))
|
[(send (group:get-the-frame-group) locate-file source)
|
||||||
(send (group:get-the-frame-group) locate-file source))
|
|
||||||
=>
|
=>
|
||||||
(lambda (frame)
|
(lambda (frame)
|
||||||
(let ([defss (map (lambda (t) (send t get-defs)) (send frame get-tabs))])
|
(let ([defss (map (lambda (t) (send t get-defs)) (send frame get-tabs))])
|
||||||
|
|
@ -139,18 +150,27 @@
|
||||||
get-tab)
|
get-tab)
|
||||||
|
|
||||||
(define mouse-over-pos #f)
|
(define mouse-over-pos #f)
|
||||||
|
;; pen and brush for drawing a breakpoint
|
||||||
(define bp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
(define bp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||||
(define bp-brush (send the-brush-list find-or-create-brush "red" 'solid))
|
(define bp-brush (send the-brush-list find-or-create-brush "red" 'solid))
|
||||||
|
;; pen and brush for marking a location that could have a breakpoint installed
|
||||||
(define bp-mo-pen (send the-pen-list find-or-create-pen "darkgray" 1 'solid))
|
(define bp-mo-pen (send the-pen-list find-or-create-pen "darkgray" 1 'solid))
|
||||||
(define bp-mo-brush (send the-brush-list find-or-create-brush "tomato"
|
(define bp-mo-brush (send the-brush-list find-or-create-brush "tomato"
|
||||||
'solid))
|
'solid))
|
||||||
|
;; pen and brush for marking a conditional breakpoint
|
||||||
(define bp-tmp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
(define bp-tmp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||||
(define bp-tmp-brush (send the-brush-list find-or-create-brush "yellow"
|
(define bp-tmp-brush (send the-brush-list find-or-create-brush "yellow"
|
||||||
'solid))
|
'solid))
|
||||||
|
;; pen and brush for drawing the normal execution location
|
||||||
(define pc-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
(define pc-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||||
(define pc-brush (send the-brush-list find-or-create-brush "forestgreen" 'solid))
|
(define pc-brush (send the-brush-list find-or-create-brush "forestgreen" 'solid))
|
||||||
|
;; pen and brush for marking the expression when not at the top of the stack
|
||||||
|
(define pc-up-stack-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||||
|
(define pc-up-stack-brush (send the-brush-list find-or-create-brush "lightgreen" 'solid))
|
||||||
|
;; pen and brush for marking the location when there's an an error
|
||||||
(define pc-err-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
(define pc-err-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||||
(define pc-err-brush (send the-brush-list find-or-create-brush "red" 'solid))
|
(define pc-err-brush (send the-brush-list find-or-create-brush "red" 'solid))
|
||||||
|
;; pen and brush for marking the location following a break
|
||||||
(define pc-brk-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
(define pc-brk-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||||
(define pc-brk-brush (send the-brush-list find-or-create-brush "gray" 'solid))
|
(define pc-brk-brush (send the-brush-list find-or-create-brush "gray" 'solid))
|
||||||
|
|
||||||
|
|
@ -192,8 +212,11 @@
|
||||||
breakpoints
|
breakpoints
|
||||||
(lambda (pos status)
|
(lambda (pos status)
|
||||||
(when (< start pos)
|
(when (< start pos)
|
||||||
|
;; text inserted before this breakpoint, so shift
|
||||||
|
;; the breakpoint forward by <len> positions
|
||||||
(hash-table-remove! breakpoints pos)
|
(hash-table-remove! breakpoints pos)
|
||||||
(set! shifts (cons (cons (+ pos len) status) shifts)))))
|
(set! shifts (cons (cons (+ pos len) status) shifts)))))
|
||||||
|
;; update the breakpoint locations
|
||||||
(for-each (lambda (p) (hash-table-put! breakpoints (car p) (cdr p)))
|
(for-each (lambda (p) (hash-table-put! breakpoints (car p) (cdr p)))
|
||||||
shifts))
|
shifts))
|
||||||
(inner (void) on-insert start len))
|
(inner (void) on-insert start len))
|
||||||
|
|
@ -204,6 +227,9 @@
|
||||||
(send (get-tab) hide-debug))
|
(send (get-tab) hide-debug))
|
||||||
(end-edit-sequence))
|
(end-edit-sequence))
|
||||||
|
|
||||||
|
;; lookup id in the given set of stack frames;
|
||||||
|
;; if that fails, try the top-level environment
|
||||||
|
;; invokes sk on success, fk on failure
|
||||||
(define (lookup-var id frames sk fk)
|
(define (lookup-var id frames sk fk)
|
||||||
(cond
|
(cond
|
||||||
[(and id frames (lookup-first-binding
|
[(and id frames (lookup-first-binding
|
||||||
|
|
@ -222,6 +248,7 @@
|
||||||
(sk (tlb) tlb))]
|
(sk (tlb) tlb))]
|
||||||
[else (fk)]))
|
[else (fk)]))
|
||||||
|
|
||||||
|
;; mouse-event -> (or (values #f #f) (values pos editor))
|
||||||
(define/private (get-pos/text event)
|
(define/private (get-pos/text event)
|
||||||
(let ([event-x (send event get-x)]
|
(let ([event-x (send event get-x)]
|
||||||
[event-y (send event get-y)]
|
[event-y (send event get-y)]
|
||||||
|
|
@ -248,6 +275,9 @@
|
||||||
(values #f #f)))]
|
(values #f #f)))]
|
||||||
[else (values #f #f)])))))
|
[else (values #f #f)])))))
|
||||||
|
|
||||||
|
;; text% start end -> (values left top right bottom)
|
||||||
|
;; (four numbers that indicate the locations in pixels of the
|
||||||
|
;; box bounding the text between start and end
|
||||||
(define/private (find-char-box text left-pos right-pos)
|
(define/private (find-char-box text left-pos right-pos)
|
||||||
(let ([xlb (box 0)]
|
(let ([xlb (box 0)]
|
||||||
[ylb (box 0)]
|
[ylb (box 0)]
|
||||||
|
|
@ -266,56 +296,49 @@
|
||||||
(define/private (render v)
|
(define/private (render v)
|
||||||
(send (get-tab) render v))
|
(send (get-tab) render v))
|
||||||
|
|
||||||
(define/override (on-event event)
|
(define (debugger-handle-right-click-non-breakable event pos)
|
||||||
(if (send (get-tab) debug?)
|
|
||||||
(let ([breakpoints (send (get-tab) get-breakpoints)])
|
|
||||||
(cond
|
|
||||||
[(send event leaving?)
|
|
||||||
(when mouse-over-pos
|
|
||||||
(set! mouse-over-pos #f)
|
|
||||||
(invalidate-bitmap-cache))
|
|
||||||
(super on-event event)]
|
|
||||||
[(or (send event moving?)
|
|
||||||
(send event entering?))
|
|
||||||
(let-values ([(pos text) (get-pos/text event)])
|
|
||||||
(when (and pos text)
|
|
||||||
(let ([pos (add1 pos)])
|
|
||||||
(cond
|
|
||||||
; mouse on breakable pos and hasn't moved significantly
|
|
||||||
[(eq? pos mouse-over-pos)]
|
|
||||||
; mouse on new breakable pos
|
|
||||||
[(not (eq? (hash-table-get
|
|
||||||
breakpoints
|
|
||||||
pos (lambda () 'invalid)) 'invalid))
|
|
||||||
(set! mouse-over-pos pos)
|
|
||||||
(invalidate-bitmap-cache)]
|
|
||||||
; moved off breakable pos
|
|
||||||
[mouse-over-pos
|
|
||||||
(set! mouse-over-pos #f)
|
|
||||||
(invalidate-bitmap-cache)])
|
|
||||||
(let* ([frames (send (get-tab) get-stack-frames)]
|
(let* ([frames (send (get-tab) get-stack-frames)]
|
||||||
[pos-vec (send (get-tab) get-pos-vec)]
|
[pos-vec (send (get-tab) get-pos-vec)]
|
||||||
[id (robust-vector-ref pos-vec pos)]
|
[id (robust-vector-ref pos-vec pos)])
|
||||||
#;
|
(unless (lookup-var
|
||||||
[_ (printf "frames = ~a~npos-vec = ~a~nid = ~a~n"
|
id
|
||||||
frames pos-vec id)])
|
frames
|
||||||
(send (get-tab)
|
(lambda (val wr)
|
||||||
set-mouse-over-msg
|
(let ([id-sym (syntax-e id)]
|
||||||
|
[menu (make-object popup-menu% #f)])
|
||||||
|
(make-object menu-item%
|
||||||
(clean-status
|
(clean-status
|
||||||
(lookup-var id frames
|
(format "Print value of ~a to console" id-sym))
|
||||||
; id found
|
menu
|
||||||
(lambda (val _)
|
(lambda (item evt)
|
||||||
(format "~a = ~a" (syntax-e id) (render val)))
|
(send (get-tab) print-to-console (format "~a = ~a" id-sym val))))
|
||||||
; id not found
|
(make-object menu-item%
|
||||||
(lambda () ""))))))))
|
(format "(set! ~a ...)" id-sym)
|
||||||
(super on-event event)]
|
menu
|
||||||
[(send event button-down? 'right)
|
(lambda (item evt)
|
||||||
(let-values ([(pos text) (get-pos/text event)])
|
(let* ([tmp
|
||||||
(if (and pos text)
|
(get-text-from-user
|
||||||
(let* ([pos (add1 pos)]
|
(format "New value for ~a" id-sym) #f #f
|
||||||
[break-status (hash-table-get breakpoints pos (lambda () 'invalid))])
|
(format "~a" val))])
|
||||||
(match break-status
|
(when tmp
|
||||||
[(or #t #f (? procedure?))
|
(let/ec k
|
||||||
|
(wr (with-handlers
|
||||||
|
([exn:fail?
|
||||||
|
(lambda (exn)
|
||||||
|
(message-box
|
||||||
|
"Debugger Error"
|
||||||
|
(format "The following error occurred: ~a"
|
||||||
|
(exn-message exn)))
|
||||||
|
(k))])
|
||||||
|
(read (open-input-string tmp)))))))))
|
||||||
|
(send (get-canvas) popup-menu menu
|
||||||
|
(+ 1 (inexact->exact (floor (send event get-x))))
|
||||||
|
(+ 1 (inexact->exact (floor (send event get-y)))))
|
||||||
|
#t))
|
||||||
|
(lambda () #f))
|
||||||
|
(super on-event event))))
|
||||||
|
|
||||||
|
(define (debugger-handle-right-click-breakable event breakpoints pos break-status)
|
||||||
(let ([menu (make-object popup-menu% #f)])
|
(let ([menu (make-object popup-menu% #f)])
|
||||||
(make-object menu-item%
|
(make-object menu-item%
|
||||||
(if break-status
|
(if break-status
|
||||||
|
|
@ -380,58 +403,72 @@
|
||||||
(send (get-tab) resume))))))
|
(send (get-tab) resume))))))
|
||||||
(send (get-canvas) popup-menu menu
|
(send (get-canvas) popup-menu menu
|
||||||
(+ 1 (inexact->exact (floor (send event get-x))))
|
(+ 1 (inexact->exact (floor (send event get-x))))
|
||||||
(+ 1 (inexact->exact (floor (send event get-y))))))]
|
(+ 1 (inexact->exact (floor (send event get-y)))))))
|
||||||
|
|
||||||
|
(define (debugger-handle-right-click event breakpoints)
|
||||||
|
(let-values ([(pos text) (get-pos/text event)])
|
||||||
|
(if (and pos text)
|
||||||
|
(let* ([pos (add1 pos)]
|
||||||
|
[break-status (hash-table-get breakpoints pos (lambda () 'invalid))])
|
||||||
|
(match break-status
|
||||||
|
[(or #t #f (? procedure?))
|
||||||
|
(debugger-handle-right-click-breakable event breakpoints pos break-status)]
|
||||||
['invalid
|
['invalid
|
||||||
|
(debugger-handle-right-click-non-breakable event pos)]))
|
||||||
|
(super on-event event))))
|
||||||
|
|
||||||
|
(define (debugger-handle-event event)
|
||||||
|
(let ([breakpoints (send (get-tab) get-breakpoints)])
|
||||||
|
(cond
|
||||||
|
[(send event leaving?)
|
||||||
|
(when mouse-over-pos
|
||||||
|
(set! mouse-over-pos #f)
|
||||||
|
(invalidate-bitmap-cache))
|
||||||
|
(super on-event event)]
|
||||||
|
[(or (send event moving?)
|
||||||
|
(send event entering?))
|
||||||
|
(let-values ([(pos text) (get-pos/text event)])
|
||||||
|
(when (and pos text)
|
||||||
|
(let ([pos (add1 pos)])
|
||||||
|
(cond
|
||||||
|
;; mouse on breakable pos and hasn't moved significantly
|
||||||
|
[(eq? pos mouse-over-pos)]
|
||||||
|
;; mouse on new breakable pos
|
||||||
|
[(not (eq? (hash-table-get
|
||||||
|
breakpoints
|
||||||
|
pos (lambda () 'invalid)) 'invalid))
|
||||||
|
(set! mouse-over-pos pos)
|
||||||
|
(invalidate-bitmap-cache)]
|
||||||
|
;; moved off breakable pos
|
||||||
|
[mouse-over-pos
|
||||||
|
(set! mouse-over-pos #f)
|
||||||
|
(invalidate-bitmap-cache)])
|
||||||
(let* ([frames (send (get-tab) get-stack-frames)]
|
(let* ([frames (send (get-tab) get-stack-frames)]
|
||||||
[pos-vec (send (get-tab) get-pos-vec)]
|
[pos-vec (send (get-tab) get-pos-vec)]
|
||||||
[id (robust-vector-ref pos-vec pos)]
|
[id (robust-vector-ref pos-vec pos)])
|
||||||
#;
|
(send (get-tab)
|
||||||
[_ (printf "frames = ~a~npos-vec = ~a~nid = ~a~n"
|
set-mouse-over-msg
|
||||||
frames pos-vec id)])
|
|
||||||
(unless (lookup-var
|
|
||||||
id
|
|
||||||
frames
|
|
||||||
(lambda (val wr)
|
|
||||||
(let ([id-sym (syntax-e id)]
|
|
||||||
[menu (make-object popup-menu% #f)])
|
|
||||||
(make-object menu-item%
|
|
||||||
(clean-status
|
(clean-status
|
||||||
(format "Print value of ~a to console" id-sym))
|
(lookup-var id (list-tail frames (send (get-tab) get-frame-num))
|
||||||
menu
|
;; id found
|
||||||
(lambda (item evt)
|
(lambda (val _)
|
||||||
(send (get-tab) print-to-console (format "~a = ~a" id-sym val))))
|
(format "~a = ~a" (syntax-e id) (render val)))
|
||||||
(make-object menu-item%
|
;; id not found
|
||||||
(format "(set! ~a ...)" id-sym)
|
(lambda () ""))))))))
|
||||||
menu
|
(super on-event event)]
|
||||||
(lambda (item evt)
|
[(send event button-down? 'right)
|
||||||
(let ([tmp
|
(debugger-handle-right-click event breakpoints)]
|
||||||
(get-text-from-user
|
[else (super on-event event)])))
|
||||||
(format "New value for ~a" id-sym) #f #f
|
|
||||||
(format "~a" val))])
|
(define/override (on-event event)
|
||||||
(when tmp
|
(if (send (get-tab) debug?)
|
||||||
(let/ec k
|
(debugger-handle-event event)
|
||||||
(wr (with-handlers
|
|
||||||
([exn:fail?
|
|
||||||
(lambda (exn)
|
|
||||||
(message-box
|
|
||||||
"Debugger Error"
|
|
||||||
(format "The following error occurred: ~a"
|
|
||||||
(exn-message exn)))
|
|
||||||
(k))])
|
|
||||||
(read (open-input-string tmp)))))))))
|
|
||||||
(send (get-canvas) popup-menu menu
|
|
||||||
(+ 1 (inexact->exact (floor (send event get-x))))
|
|
||||||
(+ 1 (inexact->exact (floor (send event get-y)))))
|
|
||||||
#t))
|
|
||||||
(lambda () #f))
|
|
||||||
(super on-event event)))]))
|
|
||||||
(super on-event event)))]
|
|
||||||
[else (super on-event event)]))
|
|
||||||
(super on-event event)))
|
(super on-event event)))
|
||||||
|
|
||||||
(define/override (on-paint before dc left top right bottom dx dy draw-caret)
|
(define/override (on-paint before dc left top right bottom dx dy draw-caret)
|
||||||
(super on-paint before dc left top right bottom dx dy draw-caret)
|
(super on-paint before dc left top right bottom dx dy draw-caret)
|
||||||
(when (and (send (get-tab) debug?) (not before))
|
(when (and (send (get-tab) debug?) (not before))
|
||||||
|
;; render breakpoints
|
||||||
(let ([breakpoints (send (get-tab) get-breakpoints)])
|
(let ([breakpoints (send (get-tab) get-breakpoints)])
|
||||||
(hash-table-for-each
|
(hash-table-for-each
|
||||||
breakpoints
|
breakpoints
|
||||||
|
|
@ -449,55 +486,56 @@
|
||||||
(send dc set-brush bp-mo-brush)]
|
(send dc set-brush bp-mo-brush)]
|
||||||
[else (send dc set-pen bp-tmp-pen)
|
[else (send dc set-pen bp-tmp-pen)
|
||||||
(send dc set-brush bp-tmp-brush)])
|
(send dc set-brush bp-tmp-brush)])
|
||||||
;(drscheme:arrow:draw-arrow dc xl yl xr yr dx dy)
|
|
||||||
(send dc draw-ellipse (+ xl dx) (+ yl dy yoff) diameter diameter)
|
(send dc draw-ellipse (+ xl dx) (+ yl dy yoff) diameter diameter)
|
||||||
#;
|
|
||||||
(send dc draw-polygon stop-sign
|
|
||||||
(+ xl dx)
|
|
||||||
(+ yl dy 2))
|
|
||||||
(send dc set-pen op)
|
(send dc set-pen op)
|
||||||
(send dc set-brush ob)))))))
|
(send dc set-brush ob)))))))
|
||||||
(let ([pc-defs (send (get-tab) defs-containing-pc)]
|
;; mark the boundaries of the current stack frame
|
||||||
[pos (send (get-tab) get-pc)])
|
;; unless we're at the end of the expression and looking at the top frame,
|
||||||
#;(printf "pc-defs = ~a, this frame = ~a, pos = ~a~n" pc-defs this pos)
|
;; in which case just mark the current location
|
||||||
(when (and (eq? pc-defs this) pos)
|
(let* ([frame-defs (send (get-tab) defs-containing-current-frame)]
|
||||||
(let*-values ([(xl yl xr yr) (find-char-box this (sub1 pos) pos)]
|
[pos (send (get-tab) get-current-frame-endpoints)]
|
||||||
[(ym) (average yl yr)])
|
[start (and pos (first pos))]
|
||||||
|
[end (and pos (second pos))]
|
||||||
|
[frame-num (send (get-tab) get-frame-num)]
|
||||||
|
[break-status (send (get-tab) get-break-status)])
|
||||||
|
(when (and (eq? frame-defs this) start end)
|
||||||
|
(let*-values ([(xl yl xr yr) (find-char-box this (sub1 start) start)]
|
||||||
|
[(ym) (average yl yr)]
|
||||||
|
[(xa ya xb yb) (find-char-box this (sub1 end) end)]
|
||||||
|
[(diameter) (- xb xa)]
|
||||||
|
[(yoff) (/ (- yb ya diameter) 2)]
|
||||||
|
[(ym2) (average ya yb)])
|
||||||
(let ([op (send dc get-pen)]
|
(let ([op (send dc get-pen)]
|
||||||
[ob (send dc get-brush)])
|
[ob (send dc get-brush)])
|
||||||
(case (send (get-tab) get-break-status)
|
(cond
|
||||||
[(error) (send dc set-pen pc-err-pen)
|
[(and (zero? frame-num)
|
||||||
|
(eq? break-status 'error))
|
||||||
|
(send dc set-pen pc-err-pen)
|
||||||
(send dc set-brush pc-err-brush)]
|
(send dc set-brush pc-err-brush)]
|
||||||
[(break) (send dc set-pen pc-brk-pen)
|
[(and (zero? frame-num)
|
||||||
|
(eq? break-status 'break))
|
||||||
|
(send dc set-pen pc-brk-pen)
|
||||||
(send dc set-brush pc-brk-brush)]
|
(send dc set-brush pc-brk-brush)]
|
||||||
[else (send dc set-pen pc-pen)
|
[(zero? frame-num)
|
||||||
(send dc set-brush pc-brush)]))
|
(send dc set-pen pc-pen)
|
||||||
|
(send dc set-brush pc-brush)]
|
||||||
|
[else
|
||||||
|
(send dc set-pen pc-up-stack-pen)
|
||||||
|
(send dc set-brush pc-up-stack-brush)])
|
||||||
|
(unless (and (zero? frame-num) (cons? break-status))
|
||||||
|
;; mark the beginning of the expression with a triangle
|
||||||
(send dc draw-polygon (list (make-object point% xl yl)
|
(send dc draw-polygon (list (make-object point% xl yl)
|
||||||
(make-object point% xl yr)
|
(make-object point% xl yr)
|
||||||
(make-object point% xr ym)) dx dy)
|
(make-object point% xr ym)) dx dy))
|
||||||
#;(drscheme:arrow:draw-arrow dc xl ym xr ym dx dy))
|
(if (and (zero? frame-num) (cons? break-status))
|
||||||
#;
|
;; top frame, end: mark the end of the expression with a triangle
|
||||||
(let loop ([end-pos pos]
|
(send dc draw-polygon (list (make-object point% xa ya)
|
||||||
[marks (send (get-tab) get-stack-frames)])
|
(make-object point% xa yb)
|
||||||
(when (cons? marks)
|
(make-object point% xb ym2)) dx dy)
|
||||||
(let*-values ([(start-pos) (syntax-position (mark-source (first marks)))]
|
;; otherwise: make the end of the expression with a circle
|
||||||
[(xl0 yl0 xr0 yr0) (find-char-box this (sub1 start-pos) start-pos)]
|
(send dc draw-ellipse (+ xa dx) (+ ya dy yoff) diameter diameter))
|
||||||
[(xm0) (average xl0 xr0)]
|
(send dc set-pen op)
|
||||||
[(ym0) (average yl0 yr0)]
|
(send dc set-brush ob)))))))
|
||||||
[(xl yl xr yr) (find-char-box this (sub1 end-pos) end-pos)]
|
|
||||||
[(xm) (average xl xr)]
|
|
||||||
[(ym) (average yl yr)])
|
|
||||||
(let ([op (send dc get-pen)]
|
|
||||||
[ob (send dc get-brush)])
|
|
||||||
(case (send (get-tab) get-break-status)
|
|
||||||
[(error) (send dc set-pen pc-err-pen)
|
|
||||||
(send dc set-brush pc-err-brush)]
|
|
||||||
[(break) (send dc set-pen pc-brk-pen)
|
|
||||||
(send dc set-brush pc-brk-brush)]
|
|
||||||
[else (send dc set-pen pc-pen)
|
|
||||||
(send dc set-brush pc-brush)]))
|
|
||||||
(drscheme:arrow:draw-arrow dc xm0 ym0 xr ym dx dy)
|
|
||||||
(loop start-pos (rest marks)))))))))
|
|
||||||
|
|
||||||
(define/augment (after-set-next-settings s)
|
(define/augment (after-set-next-settings s)
|
||||||
(let ([tlw (get-top-level-window)])
|
(let ([tlw (get-top-level-window)])
|
||||||
|
|
@ -542,8 +580,6 @@
|
||||||
top-e
|
top-e
|
||||||
; annotate-module?
|
; annotate-module?
|
||||||
(lambda (fn m)
|
(lambda (fn m)
|
||||||
#;
|
|
||||||
(printf "debugger: loading ~a (~a)~n" m fn)
|
|
||||||
(cond
|
(cond
|
||||||
[(filename->defs fn)
|
[(filename->defs fn)
|
||||||
=>
|
=>
|
||||||
|
|
@ -551,9 +587,6 @@
|
||||||
(lambda (defs)
|
(lambda (defs)
|
||||||
(let ([extern-tab (send defs get-tab)]
|
(let ([extern-tab (send defs get-tab)]
|
||||||
[this-tab (get-tab)])
|
[this-tab (get-tab)])
|
||||||
; TODO: make sure that defs's tab is
|
|
||||||
; not already involved in a debugging session
|
|
||||||
; perhaps allow takeover of previous session
|
|
||||||
(case (if (or (not (send extern-tab debug?))
|
(case (if (or (not (send extern-tab debug?))
|
||||||
(eq? this-tab (send extern-tab get-master)))
|
(eq? this-tab (send extern-tab get-master)))
|
||||||
(message-box
|
(message-box
|
||||||
|
|
@ -710,7 +743,7 @@
|
||||||
[slaves empty]
|
[slaves empty]
|
||||||
[closed? (box #f)]
|
[closed? (box #f)]
|
||||||
[stack-frames (box #f)]
|
[stack-frames (box #f)]
|
||||||
[frame-num 0]
|
[frame-num (box 0)]
|
||||||
[break-status (box #f)]
|
[break-status (box #f)]
|
||||||
[current-language-settings #f]
|
[current-language-settings #f]
|
||||||
[pos-vec (vector #f)]
|
[pos-vec (vector #f)]
|
||||||
|
|
@ -732,18 +765,20 @@
|
||||||
(define/public (get-pos-vec) pos-vec)
|
(define/public (get-pos-vec) pos-vec)
|
||||||
(define/public (get-breakpoints) breakpoints)
|
(define/public (get-breakpoints) breakpoints)
|
||||||
(define/public (get-break-status) (unbox break-status))
|
(define/public (get-break-status) (unbox break-status))
|
||||||
|
(define/public (get-frame-num) (unbox frame-num))
|
||||||
|
|
||||||
(define/public (set-shared-data bs sf sema res-ch usr-ch step? m)
|
(define/public (set-shared-data bs sf sema res-ch usr-ch step? frame m)
|
||||||
(set! break-status bs)
|
(set! break-status bs)
|
||||||
(set! stack-frames sf)
|
(set! stack-frames sf)
|
||||||
(set! suspend-sema sema)
|
(set! suspend-sema sema)
|
||||||
(set! resume-ch res-ch)
|
(set! resume-ch res-ch)
|
||||||
(set! in-user-ch usr-ch)
|
(set! in-user-ch usr-ch)
|
||||||
(set! single-step? step?)
|
(set! single-step? step?)
|
||||||
|
(set! frame-num frame)
|
||||||
(set! master m))
|
(set! master m))
|
||||||
|
|
||||||
(define/public (get-shared-data)
|
(define/public (get-shared-data)
|
||||||
(values break-status stack-frames suspend-sema resume-ch in-user-ch single-step? master))
|
(values break-status stack-frames suspend-sema resume-ch in-user-ch single-step? frame-num master))
|
||||||
|
|
||||||
(define/public (get-single-step-box) single-step?)
|
(define/public (get-single-step-box) single-step?)
|
||||||
(define/public (set-single-step?! v) (set-box! single-step? v))
|
(define/public (set-single-step?! v) (set-box! single-step? v))
|
||||||
|
|
@ -763,6 +798,14 @@
|
||||||
res) (cdar bindings)]
|
res) (cdar bindings)]
|
||||||
[else (loop (rest bindings))])))
|
[else (loop (rest bindings))])))
|
||||||
|
|
||||||
|
(define/public (move-up-frame)
|
||||||
|
(set-box! frame-num (add1 (unbox frame-num)))
|
||||||
|
(suspend-gui (get-stack-frames) (get-break-status) #t))
|
||||||
|
|
||||||
|
(define/public (move-down-frame)
|
||||||
|
(set-box! frame-num (sub1 (unbox frame-num)))
|
||||||
|
(suspend-gui (get-stack-frames) (get-break-status) #t))
|
||||||
|
|
||||||
(define/public (resume)
|
(define/public (resume)
|
||||||
(let ([v (get-break-status)])
|
(let ([v (get-break-status)])
|
||||||
(resume-gui)
|
(resume-gui)
|
||||||
|
|
@ -780,6 +823,15 @@
|
||||||
(filename->defs source)
|
(filename->defs source)
|
||||||
(get-defs))))))
|
(get-defs))))))
|
||||||
|
|
||||||
|
(define/public (defs-containing-current-frame)
|
||||||
|
(let ([stack-frames (get-stack-frames)])
|
||||||
|
(and (cons? stack-frames)
|
||||||
|
(let* ([src-stx (mark-source (list-ref stack-frames (get-frame-num)))]
|
||||||
|
[source (syntax-source src-stx)])
|
||||||
|
(if source
|
||||||
|
(filename->defs source)
|
||||||
|
(get-defs))))))
|
||||||
|
|
||||||
(define/public (get-pc)
|
(define/public (get-pc)
|
||||||
(let ([stack-frames (get-stack-frames)])
|
(let ([stack-frames (get-stack-frames)])
|
||||||
(and (cons? stack-frames)
|
(and (cons? stack-frames)
|
||||||
|
|
@ -790,6 +842,14 @@
|
||||||
end
|
end
|
||||||
start)))))
|
start)))))
|
||||||
|
|
||||||
|
(define/public (get-current-frame-endpoints)
|
||||||
|
(let ([stack-frames (get-stack-frames)])
|
||||||
|
(and (cons? stack-frames)
|
||||||
|
(let* ([src-stx (mark-source (list-ref stack-frames (get-frame-num)))]
|
||||||
|
[start (syntax-position src-stx)]
|
||||||
|
[end (and start (+ start (syntax-span src-stx) -1))])
|
||||||
|
(list start end)))))
|
||||||
|
|
||||||
(define (do-in-user-thread thunk)
|
(define (do-in-user-thread thunk)
|
||||||
(if (get-break-status)
|
(if (get-break-status)
|
||||||
(channel-put in-user-ch thunk)
|
(channel-put in-user-ch thunk)
|
||||||
|
|
@ -831,67 +891,81 @@
|
||||||
(hash-table-get bps pos 'invalid))))
|
(hash-table-get bps pos 'invalid))))
|
||||||
|
|
||||||
(define (can-step-over? frames status)
|
(define (can-step-over? frames status)
|
||||||
(and (eq? status 'entry-break)
|
(and (or (not (zero? (get-frame-num))) (eq? status 'entry-break))
|
||||||
(not (eq? (frame->end-breakpoint-status (first frames)) 'invalid))))
|
(not (eq? (frame->end-breakpoint-status (list-ref frames (get-frame-num))) 'invalid))))
|
||||||
|
|
||||||
(define (can-step-out? frames status)
|
(define (can-step-out? frames status)
|
||||||
(or (and (not (empty? frames))
|
(let ([frames (list-tail frames (get-frame-num))])
|
||||||
|
(and (not (empty? frames))
|
||||||
(ormap (lambda (f) (not (eq? (frame->end-breakpoint-status f) 'invalid)))
|
(ormap (lambda (f) (not (eq? (frame->end-breakpoint-status f) 'invalid)))
|
||||||
(rest frames)))
|
(rest frames)))))
|
||||||
(begin
|
|
||||||
#;(printf "cannot step out: stack is ~a~n" frames)
|
(define (can-move-up-frame? frames)
|
||||||
#f)))
|
(< (get-frame-num) (sub1 (length frames))))
|
||||||
|
|
||||||
|
(define (can-move-down-frame? frames)
|
||||||
|
(> (get-frame-num) 0))
|
||||||
|
|
||||||
(define/public suspend-gui
|
(define/public suspend-gui
|
||||||
(opt-lambda (frames status [switch-tabs? #f])
|
(opt-lambda (frames status [switch-tabs? #f])
|
||||||
|
(let ([top-of-stack? (zero? (get-frame-num))]
|
||||||
|
[status-message (send (get-frame) get-status-message)])
|
||||||
(set! want-suspend-on-break? #f)
|
(set! want-suspend-on-break? #f)
|
||||||
(set-single-step?! #f)
|
(set-single-step?! #f)
|
||||||
(set-box! stack-frames frames)
|
(set-box! stack-frames frames)
|
||||||
(set-box! break-status status)
|
(set-box! break-status status)
|
||||||
(send (send (get-frame) get-pause-button) enable #f)
|
(send (send (get-frame) get-pause-button) enable #f)
|
||||||
(send (send (get-frame) get-step-button) enable #t)
|
(send (send (get-frame) get-step-button) enable top-of-stack?)
|
||||||
(send (send (get-frame) get-step-over-button) enable (can-step-over? frames status))
|
(send (send (get-frame) get-step-over-button) enable (can-step-over? frames status))
|
||||||
(send (send (get-frame) get-step-out-button) enable (can-step-out? frames status))
|
(send (send (get-frame) get-step-out-button) enable (can-step-out? frames status))
|
||||||
|
(send (send (get-frame) get-up-frame-button) enable (can-move-up-frame? frames))
|
||||||
|
(send (send (get-frame) get-down-frame-button) enable (can-move-down-frame? frames))
|
||||||
(send (send (get-frame) get-resume-button) enable #t)
|
(send (send (get-frame) get-resume-button) enable #t)
|
||||||
;;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames))
|
;;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames))
|
||||||
;;(printf "status = ~a~n" status)
|
;;(printf "status = ~a~n" status)
|
||||||
(when (cons? status)
|
(send status-message set-label
|
||||||
|
(if (and (cons? status) top-of-stack?)
|
||||||
(let ([expr (mark-source (first frames))])
|
(let ([expr (mark-source (first frames))])
|
||||||
(cond
|
(cond
|
||||||
; should succeed unless the user closes a slave tab during debugging
|
; should succeed unless the user closes a slave tab during debugging
|
||||||
[(filename->defs (syntax-source expr))
|
[(filename->defs (syntax-source expr))
|
||||||
=>
|
=>
|
||||||
(lambda (defs)
|
(lambda (defs)
|
||||||
(send (send (get-frame) get-status-message) set-label
|
|
||||||
(clean-status
|
(clean-status
|
||||||
(format "~a ==> ~a"
|
(format "~a => ~a"
|
||||||
|
(if (syntax-position expr)
|
||||||
(trim-expr-str
|
(trim-expr-str
|
||||||
(send defs get-text
|
(send defs get-text
|
||||||
(sub1 (syntax-position expr))
|
(sub1 (syntax-position expr))
|
||||||
(+ -1 (syntax-position expr) (syntax-span expr))))
|
(+ -1 (syntax-position expr) (syntax-span expr))))
|
||||||
|
"??")
|
||||||
(if (= 2 (length status))
|
(if (= 2 (length status))
|
||||||
(render (cadr status))
|
(render (cadr status))
|
||||||
(cons 'values (map (lambda (v) (render v)) (rest status))))))))])))
|
(cons 'values (map (lambda (v) (render v)) (rest status)))))))]))
|
||||||
(cond [(get-pc)
|
""))
|
||||||
=> (lambda (pc)
|
(cond [(get-current-frame-endpoints)
|
||||||
(cond [(defs-containing-pc)
|
=> (lambda (start/end)
|
||||||
|
(cond [(and (first start/end) (defs-containing-current-frame))
|
||||||
=> (lambda (defs)
|
=> (lambda (defs)
|
||||||
(cond
|
(cond
|
||||||
[(and switch-tabs? (send defs get-filename))
|
[(and switch-tabs? (send defs get-filename))
|
||||||
=>
|
=>
|
||||||
(lambda (fn)
|
(lambda (fn)
|
||||||
(handler:edit-file fn))])
|
(handler:edit-file fn))])
|
||||||
(send defs scroll-to-position pc))]))])
|
(send defs scroll-to-position (first start/end)))]))])
|
||||||
(send (get-defs) invalidate-bitmap-cache)))
|
(send (get-defs) invalidate-bitmap-cache))))
|
||||||
|
|
||||||
(define/public (resume-gui)
|
(define/public (resume-gui)
|
||||||
(set-box! stack-frames #f)
|
(set-box! stack-frames #f)
|
||||||
(set-box! break-status #f)
|
(set-box! break-status #f)
|
||||||
|
(set-box! frame-num 0)
|
||||||
(send (send (get-frame) get-pause-button) enable #t)
|
(send (send (get-frame) get-pause-button) enable #t)
|
||||||
(send (send (get-frame) get-step-button) enable #f)
|
(send (send (get-frame) get-step-button) enable #f)
|
||||||
(send (send (get-frame) get-step-over-button) enable #f)
|
(send (send (get-frame) get-step-over-button) enable #f)
|
||||||
(send (send (get-frame) get-step-out-button) enable #f)
|
(send (send (get-frame) get-step-out-button) enable #f)
|
||||||
(send (send (get-frame) get-resume-button) enable #f)
|
(send (send (get-frame) get-resume-button) enable #f)
|
||||||
|
(send (send (get-frame) get-up-frame-button) enable #f)
|
||||||
|
(send (send (get-frame) get-down-frame-button) enable #f)
|
||||||
(send (send (get-frame) get-status-message) set-label "")
|
(send (send (get-frame) get-status-message) set-label "")
|
||||||
(send (get-defs) invalidate-bitmap-cache))
|
(send (get-defs) invalidate-bitmap-cache))
|
||||||
|
|
||||||
|
|
@ -1062,7 +1136,7 @@
|
||||||
(define resume-button
|
(define resume-button
|
||||||
(instantiate button% ()
|
(instantiate button% ()
|
||||||
[label ((bitmap-label-maker
|
[label ((bitmap-label-maker
|
||||||
"Continue"
|
"Go"
|
||||||
(build-path (collection-path "gui-debugger" "icons") "resume.png")) this)]
|
(build-path (collection-path "gui-debugger" "icons") "resume.png")) this)]
|
||||||
[parent debug-panel]
|
[parent debug-panel]
|
||||||
[callback (lambda (button evt)
|
[callback (lambda (button evt)
|
||||||
|
|
@ -1088,7 +1162,8 @@
|
||||||
(define (make-big-step-callback out?)
|
(define (make-big-step-callback out?)
|
||||||
(lambda (btn evt)
|
(lambda (btn evt)
|
||||||
; go through stack frames until it's possible to set a breakpoint at the end
|
; go through stack frames until it's possible to set a breakpoint at the end
|
||||||
(let* ([frames (send (get-current-tab) get-stack-frames)]
|
(let* ([frames (list-tail (send (get-current-tab) get-stack-frames)
|
||||||
|
(send (get-current-tab) get-frame-num))]
|
||||||
[frames (case (send (get-current-tab) get-break-status)
|
[frames (case (send (get-current-tab) get-break-status)
|
||||||
[(entry-break) (if out? (rest frames) frames)]
|
[(entry-break) (if out? (rest frames) frames)]
|
||||||
[else (if out? (rest frames) empty)])]
|
[else (if out? (rest frames) empty)])]
|
||||||
|
|
@ -1141,12 +1216,30 @@
|
||||||
[callback (make-big-step-callback #t)]
|
[callback (make-big-step-callback #t)]
|
||||||
[enabled #f]))
|
[enabled #f]))
|
||||||
|
|
||||||
|
(define up-frame-button
|
||||||
|
(new button%
|
||||||
|
[label ((bitmap-label-maker
|
||||||
|
"Up"
|
||||||
|
(build-path (collection-path "gui-debugger" "icons") "up.png")) this)]
|
||||||
|
[parent debug-panel]
|
||||||
|
[callback (lambda (btn evt) (send (get-current-tab) move-up-frame))] [enabled #f]))
|
||||||
|
|
||||||
|
(define down-frame-button
|
||||||
|
(new button%
|
||||||
|
[label ((bitmap-label-maker
|
||||||
|
"Down"
|
||||||
|
(build-path (collection-path "gui-debugger" "icons") "down.png")) this)]
|
||||||
|
[parent debug-panel]
|
||||||
|
[callback (lambda (btn evt) (send (get-current-tab) move-down-frame))] [enabled #f]))
|
||||||
|
|
||||||
(define/public (get-debug-button) debug-button)
|
(define/public (get-debug-button) debug-button)
|
||||||
(define/public (get-pause-button) pause-button)
|
(define/public (get-pause-button) pause-button)
|
||||||
(define/public (get-resume-button) resume-button)
|
(define/public (get-resume-button) resume-button)
|
||||||
(define/public (get-step-button) step-button)
|
(define/public (get-step-button) step-button)
|
||||||
(define/public (get-step-over-button) step-over-button)
|
(define/public (get-step-over-button) step-over-button)
|
||||||
(define/public (get-step-out-button) step-out-button)
|
(define/public (get-step-out-button) step-out-button)
|
||||||
|
(define/public (get-up-frame-button) up-frame-button)
|
||||||
|
(define/public (get-down-frame-button) down-frame-button)
|
||||||
(define/public (get-status-message) status-message)
|
(define/public (get-status-message) status-message)
|
||||||
|
|
||||||
(define mouse-over-message
|
(define mouse-over-message
|
||||||
|
|
|
||||||
|
|
@ -517,8 +517,9 @@ a Scheme splice box.
|
||||||
|
|
||||||
@bold{Tip:} The debugger will not work properly on @onscreen{Untitled}
|
@bold{Tip:} The debugger will not work properly on @onscreen{Untitled}
|
||||||
windows or tabs. To debug a new program, make sure it has been saved
|
windows or tabs. To debug a new program, make sure it has been saved
|
||||||
to the file system. For best results, do not change the name of the
|
to the file system. Also, changing the name of a file in the middle
|
||||||
file in the middle of a debugging session.
|
of a debugging session will prevent the debugger from working properly
|
||||||
|
on that file.
|
||||||
|
|
||||||
Like the @onscreen{Run} button, the @as-index{@onscreen{Debug} button}
|
Like the @onscreen{Run} button, the @as-index{@onscreen{Debug} button}
|
||||||
runs the program in the definitions window. However, instead of
|
runs the program in the definitions window. However, instead of
|
||||||
|
|
@ -559,6 +560,15 @@ the @onscreen{Over} button, it sets a one-time breakpoint and
|
||||||
continues execution. In this case, the program stops upon returning
|
continues execution. In this case, the program stops upon returning
|
||||||
to the context or raising an unhandled exception.}
|
to the context or raising an unhandled exception.}
|
||||||
|
|
||||||
|
@item{The @as-index{@onscreen{Up} button} is only enabled when
|
||||||
|
execution is paused within the context of another expression. It
|
||||||
|
switches the debugger's view to the outer context.}
|
||||||
|
|
||||||
|
@item{The @as-index{@onscreen{Down} button} is only enabled when
|
||||||
|
execution is paused and the @onscreen{Up} button has been clicked at
|
||||||
|
least once, so the debugger's view is not at the lowest-level
|
||||||
|
expression. It moves the view context inward one level.}
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
If the program is running (not paused), then only the @as-index{Pause}
|
If the program is running (not paused), then only the @as-index{Pause}
|
||||||
|
|
@ -590,7 +600,13 @@ and a one-time breakpoint appears as a yellow circle.
|
||||||
language, then the @italic{first time} it is debugged, breakpoints
|
language, then the @italic{first time} it is debugged, breakpoints
|
||||||
will only become available in expressions as they are evaluated.
|
will only become available in expressions as they are evaluated.
|
||||||
However, the next time the program is debugged, the debugger will
|
However, the next time the program is debugged, the debugger will
|
||||||
remember the set of breakable locations from the previous session.}
|
remember the set of breakable locations from the previous session.
|
||||||
|
|
||||||
|
@bold{Tip:} Clicking the @onscreen{Run} button after a debugging
|
||||||
|
session will cause all breakpoints to disappear from the definitions
|
||||||
|
window. These breakpoints are not forgotten, and clicking
|
||||||
|
@onscreen{Debug} again will restore them. However, breakpoints do
|
||||||
|
@italic{not} persist across restarts of DrScheme.}
|
||||||
|
|
||||||
@item{If execution is paused at the start of an expression, then
|
@item{If execution is paused at the start of an expression, then
|
||||||
right-clicking or control-clicking (Mac OS X) on the green triangle
|
right-clicking or control-clicking (Mac OS X) on the green triangle
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user