From bfdee6d6f958596ba927924826ed087a282f04b2 Mon Sep 17 00:00:00 2001 From: Greg Cooper Date: Sat, 4 Aug 2007 14:29:49 +0000 Subject: [PATCH] added support for stepping over and stepping out\also, rendered lists, vectors, and strings are capped at 5 levels deep and 100 elements each svn: r7021 --- collects/mztake/debug-tool.ss | 116 +++++++++++++++++++++++++-- collects/mztake/icons/step-out2.png | Bin 0 -> 531 bytes collects/mztake/icons/step-over2.png | Bin 0 -> 511 bytes 3 files changed, 111 insertions(+), 5 deletions(-) create mode 100644 collects/mztake/icons/step-out2.png create mode 100644 collects/mztake/icons/step-over2.png diff --git a/collects/mztake/debug-tool.ss b/collects/mztake/debug-tool.ss index 365c7a75d3..66d984aa8f 100644 --- a/collects/mztake/debug-tool.ss +++ b/collects/mztake/debug-tool.ss @@ -89,6 +89,26 @@ (define (average . values) (/ (apply + values) (length values))) + (define (truncate-value v size depth) + (cond + [(zero? depth) "..."] + [(and (string? v) + (> (string-length v) size)) + (string-append (substring v 0 size) "...")] + [(list? v) + (let* ([len (length v)] + [res (build-list (min size len) + (lambda (i) (truncate-value (list-ref v i) size (sub1 depth))))]) + (if (> len size) (append res (list '...)) res))] + [(vector? v) + (build-vector (min size (vector-length v)) + (lambda (i) + (if (and (= i (sub1 size)) + (> size (vector-length v))) + "..." + (truncate-value (vector-ref v i) size (sub1 depth)))))] + [else v])) + (define (filename->defs source) (if (is-a? source editor<%>) source @@ -340,7 +360,7 @@ (lambda (item evt) (hash-table-put! breakpoints pos - (lambda () (hash-table-put! breakpoints pos #f) #t)) + (lambda () (hash-table-put! breakpoints pos break-status) #t)) (invalidate-bitmap-cache) (when (send (get-tab) get-stack-frames) (send (get-tab) resume)))))) @@ -429,7 +449,10 @@ (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 xl ym xr ym dx dy)) + (send dc draw-polygon (list (make-object point% xl yl) + (make-object point% xl yr) + (make-object point% xr ym)) dx dy) + #;(drscheme:arrow:draw-arrow dc xl ym xr ym dx dy)) #; (let loop ([end-pos pos] [marks (send (get-tab) get-stack-frames)]) @@ -744,7 +767,8 @@ (define/public (render v) ;; ==drscheme eventspace thread== ;; only when a user thread is suspended - (let ([result-ch (make-channel)]) + (let ([result-ch (make-channel)] + [v (truncate-value v 100 5)]) (do-in-user-thread (lambda () (let ([s (open-output-string)]) @@ -763,17 +787,40 @@ ;; only when a user thread is suspended (do-in-user-thread (lambda () (fprintf (current-error-port) " ### DEBUGGER: ~a~n" v)))) + (define (frame->end-breakpoint-status frame) + (let/ec k + (let* ([stx (mark-source frame)] + [src (syntax-source stx)] + [pos (+ (syntax-position stx) (syntax-span stx) -1)] + [defs (filename->defs src)] + [tab (if defs (send defs get-tab) (k (begin #;(printf "no defs for ~a~n" src) 'invalid)))] + [bps (send tab get-breakpoints)]) + (hash-table-get bps pos 'invalid)))) + + (define (can-step-over? frames status) + (and (eq? status 'entry-break) + (not (eq? (frame->end-breakpoint-status (first frames)) 'invalid)))) + + (define (can-step-out? frames status) + (or (ormap (lambda (f) (not (eq? (frame->end-breakpoint-status f) 'invalid))) + (rest frames)) + (begin + #;(printf "cannot step out: stack is ~a~n" frames) + #f))) + (define/public suspend-gui (opt-lambda (frames status [switch-tabs? #f]) (set! want-suspend-on-break? #f) (set-single-step?! #f) + (set-box! stack-frames frames) + (set-box! break-status status) (send (send (get-frame) get-pause-button) enable #f) (send (send (get-frame) get-step-button) enable #t) + (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-resume-button) enable #t) ;;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames)) ;;(printf "status = ~a~n" status) - (set-box! stack-frames frames) - (set-box! break-status status) (when (cons? status) (let ([expr (mark-source (first frames))]) (cond @@ -808,6 +855,8 @@ (set-box! break-status #f) (send (send (get-frame) get-pause-button) enable #t) (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-out-button) enable #f) (send (send (get-frame) get-resume-button) enable #f) (send (send (get-frame) get-status-message) set-label "") (send (get-defs) invalidate-bitmap-cache)) @@ -1000,10 +1049,67 @@ (bell)))] [enabled #f])) + (define (make-big-step-callback out?) + (lambda (btn evt) + ; go through stack frames until it's possible to set a breakpoint at the end + (let* ([frames (send (get-current-tab) get-stack-frames)] + [frames (case (send (get-current-tab) get-break-status) + [(entry-break) (if out? (rest frames) frames)] + [else (if out? (rest frames) empty)])] + [frame (ormap (lambda (f depth) + (let/ec k + (let* ([stx (mark-source f)] + [src (syntax-source stx)] + [pos (+ (syntax-position stx) (syntax-span stx) -1)] + [defs (filename->defs src)] + [tab (if defs (send defs get-tab) (k (begin #;(printf "no defs for ~a~n" src) #f)))] + [bps (send tab get-breakpoints)] + [cur-stat (hash-table-get bps pos 'invalid)]) + ;(printf "stat for ~a in ~a is ~a~n" pos src cur-stat) + (case cur-stat + [(invalid) #f] + [else + (hash-table-put! + bps pos + (lambda () + (and (< (length (continuation-mark-set->list (current-continuation-marks) debug-key)) depth) + (begin + (hash-table-put! bps pos cur-stat) + #t)))) + f])))) + frames + (let ([len (length frames)]) + (build-list len (lambda (i) (- len i)))))]) + (if frames + (begin + (send (get-current-tab) set-single-step?! (not frame)) + (send (get-current-tab) resume)) + (bell))))) + + (define step-over-button + (new button% + [label ((bitmap-label-maker + "Over" + (build-path (collection-path "mztake" "icons") "step-over2.png")) this)] + [parent debug-panel] + [callback (make-big-step-callback #f)] + [enabled #f])) + + (define step-out-button + (new button% + [label ((bitmap-label-maker + "Out" + (build-path (collection-path "mztake" "icons") "step-out2.png")) this)] + [parent debug-panel] + [callback (make-big-step-callback #t)] + [enabled #f])) + (define/public (get-debug-button) debug-button) (define/public (get-pause-button) pause-button) (define/public (get-resume-button) resume-button) (define/public (get-step-button) step-button) + (define/public (get-step-over-button) step-over-button) + (define/public (get-step-out-button) step-out-button) (define/public (get-status-message) status-message) (define mouse-over-message diff --git a/collects/mztake/icons/step-out2.png b/collects/mztake/icons/step-out2.png new file mode 100644 index 0000000000000000000000000000000000000000..b57e03ebd8efcaabbe24da50a4f4cee52dbc9359 GIT binary patch literal 531 zcmV+u0_^>XP);{!`8K}it;K{hN=Y%J6qi=A9Ic<*lF-^^v^zjJ2(nREDy4S25@Z?N7n zQEjqM@u`IO1rJcM0$jycY$}QGz)uVmMhlKwgF5cCIrs@aMv5`4%_EnvacTPl*c|P* z!gKWDDE8n3j)DCcT1tM5g{Zg{4kFg$l864RUv4JTr*Vl!TarZc&w zqmr|dF7vpss43hCa&Mb@P6qEhGQ*Ny3D2-SXAL(@Uyv`hNjef8btBWMj&pf+qxn>F zOtg4R#4x9EuSt%rdGtDV{`=D|d@sG*jf*&kp2Fzr@@me+Vi%!?6aEwZCH@s9`~!zP VW0EML9x?y`002ovPDHLkV1i&r-%tPm literal 0 HcmV?d00001 diff --git a/collects/mztake/icons/step-over2.png b/collects/mztake/icons/step-over2.png new file mode 100644 index 0000000000000000000000000000000000000000..00804e73fde77b6abf31598e63e4726df27eccf8 GIT binary patch literal 511 zcmVMqN09%eaVc9LAUAkQ=xmYEpo+ zHt-6c{KPQcK^{|v4C})RJ}P585%<)XG@=I=a9poxbG~_mYdI90z)2hp9x=`p^9gym_;d%o1R(^w_e19Izb%9NpDg$jqx6D{qoxw9yhLcD_Ha= znQ~oJ8%N4w{o