(module debug-tool mzscheme
  (require (lib "etc.ss")
           (lib "list.ss")
           (lib "string.ss")
           (prefix srfi: (lib "search.ss" "srfi" "1"))
           ;(lib "math.ss")
           (lib "class.ss")
           (lib "unitsig.ss")
           ;(lib "contract.ss")
           (lib "mred.ss" "mred")
           (prefix drscheme:arrow: (lib "arrow.ss" "drscheme"))
           (lib "tool.ss" "drscheme")
           (lib "marks.ss" "skipper")
           (lib "boundmap.ss" "syntax")
           (prefix kernel: (lib "kerncase.ss" "syntax"))
           (lib "bitmap-label.ss" "mrlib")
           ;(lib "framework.ss" "framework")
           #;(lib "string-constant.ss" "string-constants"))
  
  (provide tool@)
  
  (define tool@
    (unit/sig drscheme:tool-exports^
      (import drscheme:tool^)
      
      (define phase1 void)
      (define phase2 void)
      
      (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 stx breakpoints break-wrap record-bound-id)
        
        (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]
           [(require-for-syntax . require-specs)
            stx]
           [else
            (annotate stx '() #f)]))
        
        (define (annotate expr bound-vars is-tail?)
          
          (define annotate-break?
            (let ([pos (syntax-position expr)]
                  [src (syntax-source expr)])
              (and src
                   (is-a? src object%) ; FIX THIS
                   pos
                   (hash-table-get breakpoints pos (lambda () #t))
                   (kernel:kernel-syntax-case
                    expr #f
                    [(if test then) #t]
                    [(if test then else) #t]
                    [(begin . bodies) #t]
                    [(begin0 . bodies) #t]
                    [(let-values . clause) #t]
                    [(letrec-values . clause) #t]
                    [(set! var val) #t]
                    [(with-continuation-mark key mark body) #t]
                    [(#%app . exprs) #t]
                    [_ #f])
                   (begin
                     (hash-table-put! breakpoints pos #f)
                     (hash-table-put! breakpoints (+ pos (syntax-span expr) -1) #f)
                     #t))))
          
          (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 annotated
            (syntax-recertify
             (kernel:kernel-syntax-case
              expr #f
              [var-stx (identifier? (syntax var-stx))
                       (let ([binder (and (syntax-original? expr)
                                          (srfi:member expr bound-vars module-identifier=?))])
                         (when binder
                           (let ([f (first binder)])
                             (record-bound-id f f)
                             (record-bound-id expr f)))
                         expr)]
              
              [(lambda . clause)
               (quasisyntax/loc expr 
                 (lambda #,@(lambda-clause-annotator #`clause)))]
              
              [(case-lambda . clauses)
               (quasisyntax/loc expr
                 (case-lambda #,@(map lambda-clause-annotator (syntax->list #`clauses))))]
              
              [(if test then)
               (quasisyntax/loc expr (if #,(annotate #`test bound-vars #f)
                                         #,(annotate #`then bound-vars is-tail?)))]
              
              [(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)
               (let ([binder (and (syntax-original? #'var)
                                  (srfi:member #'var bound-vars module-identifier=?))])
                 (when binder
                   (let ([f (first binder)])
                     (record-bound-id f f)
                     (record-bound-id expr f)))
                 (quasisyntax/loc expr (set! var #,(annotate #`val bound-vars #f))))]
              
              [(quote _) expr]
              
              [(quote-syntax _) expr]
              
              [(with-continuation-mark key mark body)
               (quasisyntax/loc expr (with-continuation-mark key
                                       #,(annotate #`mark bound-vars #f)
                                       #,(annotate #`body bound-vars is-tail?)))]
              
              [(#%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))))]
              
              [(#%datum . _) expr]
              
              [(#%top . var) expr]
              
              [else (error 'expr-syntax-object-iterator "unknown expr: ~a"
                           (syntax-object->datum expr))])
             expr
             (current-code-inspector)
             #f))
          
          (if annotate-break?
              (break-wrap
               (make-debug-info expr bound-vars bound-vars 'at-break #f)
               annotated
               expr)
              annotated))
        
        (top-level-annotate stx))
      
      (define (break-at bp p)
        (hash-table-get bp p))
      
      (define (truncate str n)
        (substring str 0 (min n (string-length str))))
      
      (define (debug-definitions-text-mixin super%)
        (class super%
          
          (inherit dc-location-to-editor-location
                   editor-location-to-dc-location
                   invalidate-bitmap-cache
                   get-canvas)
          
          (define parent #f)
          (define/public (set-parent! p)
            (set! parent p))
          (define mouse-over-pos #f)
          (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-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 "pink"
                                    '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"
                                    '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-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-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))
          
          (super-instantiate ())
          
          (define/private (get-pos/text event)
            (let ([event-x (send event get-x)]
                  [event-y (send event get-y)]
                  [on-it? (box #f)])
              (let loop ([editor this])
                (let-values ([(x y) (send editor dc-location-to-editor-location
                                          event-x event-y)])
                  (cond
                    [(is-a? editor text%)
                     (let ([pos (send editor find-position x y #f on-it?)])
                       (cond
                         [(not (unbox on-it?)) (values #f #f)]
                         [else
                          (let ([snip (send editor find-snip pos 'after-or-none)])
                            (if (and snip
                                     (is-a? snip editor-snip%))
                                (loop (send snip get-editor))
                                (values pos editor)))]))]
                    [(is-a? editor pasteboard%)
                     (let ([snip (send editor find-snip x y)])
                       (if (and snip
                                (is-a? snip editor-snip%))
                           (loop (send snip get-editor))
                           (values #f #f)))]
                    [else (values #f #f)])))))
          
          (define/private (find-char-box text left-pos right-pos)
            (let ([xlb (box 0)]
                  [ylb (box 0)]
                  [xrb (box 0)]
                  [yrb (box 0)])
              (send text position-location left-pos xlb ylb #t)
              (send text position-location right-pos xrb yrb #f)
              (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location
                                                   (unbox xlb) (unbox ylb))]
                            [(xl yl) (dc-location-to-editor-location xl-off yl-off)]
                            [(xr-off yr-off) (send text editor-location-to-dc-location
                                                   (unbox xrb) (unbox yrb))]
                            [(xr yr) (dc-location-to-editor-location xr-off yr-off)])
                (values xl yl xr yr))))
          
          (define/override (on-event event)
            (if (and parent (send parent debug?))
                (let ([breakpoints (send parent get-breakpoints)])
                  (cond
                    [(send event leaving?)
                     (when mouse-over-pos
                       (set! mouse-over-pos #f)
                       (invalidate-bitmap-cache))]
                    [(or (send event moving?)
                         (send event entering?))
                     (let-values ([(pos text) (get-pos/text event)])
                       (when (and pos text)
                         (cond
                           ; mouse on breakable pos and hasn't moved significantly
                           [(eq? (add1 pos) mouse-over-pos)]
                           ; mouse on new breakable pos
                           [(not (eq? (hash-table-get
                                       breakpoints
                                       (add1 pos) (lambda () 'invalid)) 'invalid))
                            (set! mouse-over-pos (add1 pos))
                            (invalidate-bitmap-cache)]
                           ; moved off breakable pos
                           [mouse-over-pos
                            (set! mouse-over-pos #f)
                            (invalidate-bitmap-cache)]))
                       (super on-event event))]
                    [(send event button-down? 'right)
                     (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))])
                             (case break-status
                               [(#t #f)
                                (let ([menu (make-object popup-menu% #f)])
                                  (make-object menu-item%
                                    "Toggle breakpoint"
                                    menu
                                    (lambda (item evt)
                                      (hash-table-put! breakpoints pos (not break-status))
                                      (invalidate-bitmap-cache)))
                                  (let ([pc (send parent get-pc)])
                                    (if (and pc (= pos pc))
                                        (let ([stat (send parent get-break-status)])
                                          (when (cons? stat)
                                            (send (make-object menu-item%
                                                    (truncate
                                                     (if (= 2 (length stat))
                                                         (format "value = ~a" (cadr stat))
                                                         (format "~a" (cons 'values (rest stat))))
                                                     200)
                                                    menu
                                                    void) enable #f))
                                          (when (not (eq? stat 'break))
                                            (make-object menu-item%
                                              (if (cons? stat)
                                                  "Change return value..."
                                                  "Skip expression...")
                                              menu
                                              (lambda (item evt)
                                                (let ([tmp
                                                       (get-text-from-user "Return value" #f)])
                                                  (when tmp
                                                    (send parent set-break-status
                                                          (list 'exit-break (eval-string tmp)))))))))
                                        (make-object menu-item%
                                          "Run up to this location"
                                          menu
                                          (lambda (item evt)
                                            (hash-table-put!
                                             breakpoints pos
                                             (lambda () (hash-table-put! breakpoints pos #f) #t))
                                            (invalidate-bitmap-cache)
                                            (when (send parent get-stack-frames)
                                              (send parent resume))))))
                                  (send (get-canvas) popup-menu menu
                                        (+ 1 (inexact->exact (floor (send event get-x))))
                                        (+ 1 (inexact->exact (floor (send event get-y))))))]
                               [(invalid)
                                (if parent
                                    (let* ([frames (send parent get-stack-frames)]
                                           [pos-vec (send parent get-pos-vec)]
                                           [id (vector-ref pos-vec pos)]
                                           #;[_ (printf "frames = ~a~npos-vec = ~a~nid = ~a~n"
                                                        frames pos-vec id)])
                                      (unless (and
                                               id frames
                                               (let/ec k
                                                 (let* ([id-sym (syntax-e id)]
                                                        [binding (lookup-first-binding
                                                                  (lambda (id2) (module-identifier=? id id2))
                                                                  frames (lambda () (k #f)))]
                                                        [val (mark-binding-value
                                                              binding)]
                                                        [menu (make-object popup-menu% #f)])
                                                   (send (make-object menu-item%
                                                           (truncate
                                                            (format "~a = ~a" id-sym val)
                                                            200)
                                                           menu
                                                           (lambda (item evt)
                                                             (printf "~a" val))) enable #f)
                                                   (make-object menu-item%
                                                     (format "(set! ~a ...)" id-sym)
                                                     menu
                                                     (lambda (item evt)
                                                       (let ([tmp
                                                              (get-text-from-user
                                                               (format "New value for ~a" id-sym) #f #f
                                                               (format "~a" val))])
                                                         (when tmp
                                                           (mark-binding-set! binding (eval-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)))
                                        (super on-event event)))
                                    (super on-event event))]))
                           (super on-event event)))]
                    [else (super on-event event)]))
                (super on-event event)))
          
          (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)
            (when (and parent (send parent debug?) (not before))
              (let ([breakpoints (send parent get-breakpoints)])
                (hash-table-for-each
                 breakpoints
                 (lambda (pos enabled?)
                   (when (and (>= pos 0) (or enabled? (and mouse-over-pos (= mouse-over-pos pos))))
                     (let*-values ([(xl yl xr yr) (find-char-box this (sub1 pos) pos)]
                                   [(diameter) (- xr xl)]
                                   [(yoff) (/ (- yr yl diameter) 2)])
                       (let ([op (send dc get-pen)]
                             [ob (send dc get-brush)])
                         (case enabled?
                           [(#t) (send dc set-pen bp-pen)
                                 (send dc set-brush bp-brush)]
                           [(#f) (send dc set-pen bp-mo-pen)
                                 (send dc set-brush bp-mo-brush)]
                           [else (send dc set-pen bp-tmp-pen)
                                   (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-polygon stop-sign
                                 (+ xl dx)
                                 (+ yl dy 2))
                         (send dc set-pen op)
                         (send dc set-brush ob))))))
                (let ([pos (send parent get-pc)])
                  (when pos
                    (let*-values ([(xl yl xr yr) (find-char-box this (sub1 pos) pos)]
                                  [(ym) (/ (+ yl yr) 2)])
                      (let ([op (send dc get-pen)]
                            [ob (send dc get-brush)])
                        (case (send parent 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 xl ym xr ym dx dy)))))))))
      
      (define (debug-interactions-text-mixin super%)
        (class super%
          
          (inherit run-in-evaluation-thread
                   display-results)
          
          (define parent #f)
          (define/public (set-parent! p)
            (set! parent p))
          
          (super-instantiate ())
          
          ;; make-debug-eval-handler : (sexp -> value) -> sexp -> value
          ;; adds debugging information to `sexp' and calls `oe'
          (define/private (make-debug-eval-handler oe break? break)
            (lambda (orig-exp)
              (if (or (compiled-expression? (if (syntax? orig-exp)
                                                (syntax-e orig-exp)
                                                orig-exp))
                      (not parent)
                      (not (syntax-source orig-exp))
                      (not (eq? (syntax-source orig-exp)
                                (send parent get-definitions-text))))
                  (oe orig-exp)
                  (let loop ([exp (if (syntax? orig-exp)
                                      orig-exp
                                      (namespace-syntax-introduce
                                       (datum->syntax-object #f orig-exp)))])
                    (let ([top-e (expand-syntax-to-top-form exp)])
                      (syntax-case top-e (begin)
                        [(begin expr ...)
                         ;; Found a `begin', so expand/eval each contained 
                         ;; expression one at a time 
                         (let i-loop ([exprs (syntax->list #'(expr ...))]
                                      [last-one (list (void))])
                           (cond
                             [(null? exprs) (apply values last-one)]
                             [else (i-loop (cdr exprs)
                                           (call-with-values
                                            (lambda () (loop (car exprs)))
                                            list))]))]
                        [_else
                         ;; Not `begin', so proceed with normal expand and eval 
                         (let* ([breakpoints (send parent get-breakpoints)]
                                [pos-vec (send parent get-pos-vec)]
                                [annotated
                                 (annotate-stx
                                  (expand-syntax top-e)
                                  breakpoints
                                  (lambda (debug-info annotated raw)
                                    (let* ([start (syntax-position raw)]
                                           [end (+ start (syntax-span raw) -1)])
                                      #`(let-values ([(value-list) #f])
                                          (if (#,break? #,start)
                                              (set! value-list (#,break (current-continuation-marks)
                                                                  'entry-break #,debug-info)))
                                          (if (not value-list)
                                              (call-with-values
                                               (lambda () #,annotated)
                                               (case-lambda
                                                 [(val) (if (#,break? #,end)
                                                            (apply values
                                                                   (#,break (current-continuation-marks)
                                                                      (list 'exit-break val) #,debug-info))
                                                            val)]
                                                 [vals (apply values
                                                              (if (#,break? #,end)
                                                                  (#,break (current-continuation-marks)
                                                                     (cons 'exit-break vals) #,debug-info)
                                                                  vals))]))
                                              (apply values
                                                     (if (#,break? #,end)
                                                         (#,break (current-continuation-marks)
                                                            (cons 'exit-break value-list) #,debug-info)
                                                         value-list))))))
                                  (lambda (bound binding)
                                    ;(display-results (list bound))
                                    (let loop ([i 0])
                                      (when (< i (syntax-span bound))
                                        (vector-set! pos-vec (+ i (syntax-position bound)) binding)
                                        (loop (add1 i))))))])
                           ;(display-results (list orig-exp))
                           (oe annotated))]))))))
          
          (define/override (reset-console)
            (super reset-console)
            (when (and parent (send parent debug?))
              (let ([breakpoints (send parent get-breakpoints)])
                (run-in-evaluation-thread
                 (lambda ()
                   (let ([self (current-thread)]
                         [oeh (current-exception-handler)]
                         [err-hndlr (error-display-handler)])
                     (error-display-handler
                      (lambda (msg exn)
                        (err-hndlr msg exn)
                        (if (eq? self (current-thread))
                            (send parent suspend oeh
                                  (continuation-mark-set->list (exn-continuation-marks exn) debug-key)
                                  'error)))) ; this breaks the buttons because it looks like we can resume
                     (current-eval
                      (make-debug-eval-handler
                       (current-eval)
                       (lambda (pos)
                         (or (hash-table-get breakpoints -1)
                             (let ([bp (hash-table-get breakpoints pos)])
                               (if (procedure? bp)
                                   (bp)
                                   bp))))
                       (lambda (ccm kind info)
                         (let* ([debug-marks (continuation-mark-set->list ccm debug-key)])
                           (send parent suspend oeh (cons info debug-marks) kind)))))
                     (current-exception-handler
                      (lambda (exn)
                        (if (and (exn:break? exn) (send parent suspend-on-break?))
                            (let ([marks (exn-continuation-marks exn)]
                                  [cont (exn:break-continuation exn)])
                              (thread (lambda ()
                                        (raise
                                         (make-exn:break
                                          (string->immutable-string
                                           (format "~a (suspending)" (exn-message exn)))
                                          marks
                                          cont))))
                              (send parent suspend oeh (continuation-mark-set->list marks debug-key) 'break)
                              (cont))
                            (oeh exn))))))))))))
      
      (define (debug-unit-frame-mixin super%)
        (class super%
          
          (inherit get-button-panel
                   get-definitions-text
                   get-interactions-text
                   get-menu-bar
                   break-callback
                   reset-offer-kill)
          
          (super-instantiate ())
          
          (define breakpoints (make-hash-table))
          (hash-table-put! breakpoints -1 #f)
          (define resume-sem (make-semaphore))
          (define want-suspend-on-break? #f)
          (define want-debug? #f)
          (define/public (debug?)
            want-debug?)
          (define stack-frames #f)
          (define pos-vec (make-vector 1))
          (define/public (suspend-on-break?)
            want-suspend-on-break?)
          (define/public (get-stack-frames)
            stack-frames)
          (define/public (get-pos-vec)
            pos-vec)
          (define/public (get-breakpoints)
            breakpoints)
          (define in-execute? #f)
          (define/public (running-defs?)
            in-execute?)
          (define break-status #f)
          (define/public (get-break-status)
            break-status)
          (define/public (set-break-status stat)
            (set! break-status stat))
          (define control-panel #f)
          (define/public (resume)
            (semaphore-post resume-sem))
          
          (define/public (get-pc)
            (if (cons? stack-frames)
                (let* ([src-stx (mark-source (first stack-frames))]
                       [start (syntax-position src-stx)]
                       [end (+ start (syntax-span src-stx) -1)])
                  (if (cons? break-status)
                      end
                      start))
                #f))
          
          (define/public suspend
            (opt-lambda (break-handler frames [status #f])
              (set! want-suspend-on-break? #f)
              (hash-table-put! breakpoints -1 #f)
              ;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames))
              ;(printf "status = ~a~n" status)
              (let ([osf stack-frames]
                    [obs break-status])
                (set! stack-frames frames)
                (set! break-status status)
                (send (get-definitions-text) scroll-to-position (get-pc))
                (send (get-definitions-text) invalidate-bitmap-cache)
                (with-handlers ([exn:break? break-handler])
                  (semaphore-wait/enable-break resume-sem))
                (begin0
                  (if (cons? break-status)
                      (rest break-status)
                      #f)
                  (set! stack-frames osf)
                  (set! break-status obs)
                  (send (get-definitions-text) invalidate-bitmap-cache)))))
          
          (define (my-execute debug?)
            (set! want-debug? debug?)
            (when control-panel
              (send control-panel show #f)
              (set! control-panel #f))
            (when debug?
              (make-control-panel))
            (set! breakpoints (make-hash-table))
            (hash-table-put! breakpoints -1 #t)
            (set! pos-vec (make-vector (add1 (send (get-definitions-text) last-position)) #f))
            (set! resume-sem (make-semaphore))
            (set! want-suspend-on-break? #f)
            (set! stack-frames #f)
            (send (get-definitions-text) set-parent! this)
            (send (get-interactions-text) set-parent! this)
            (fluid-let ([in-execute? #t])
              (super execute-callback)))
          
          (define/override (execute-callback)
            (my-execute #f))
          
          (define debug-button
            (make-object button%
              ((bitmap-label-maker
                "Debug"
                (build-path (collection-path "skipper") "icon-small.png")) this)
              (get-button-panel)
              (lambda (button evt)
                (my-execute #t))))
          
          (define/augment (on-close)
            (when control-panel
              (send control-panel show #f))
            (inner (void) on-close))
          
          (define/augment (enable-evaluation)
            (send debug-button enable #t)
            (inner (void) enable-evaluation))
          
          (define/augment (disable-evaluation)
            (send debug-button enable #f)
            (inner (void) disable-evaluation))
          
          (define (make-control-panel)
            (set! control-panel (make-object frame% "Debugging Controls" this))
            (let ([container (make-object vertical-panel% control-panel)])
              (make-object button%
                "Break"
                container
                (lambda (button evt)
                  (if stack-frames
                      (bell)
                      (begin
                        (set! want-suspend-on-break? #t)
                        (break-callback)
                        (reset-offer-kill)))))
              (make-object button%
                "Resume";(debugger-bitmap this)
                container
                (lambda (button evt)
                  (if stack-frames
                      (semaphore-post resume-sem)
                      (bell))))
              (make-object button%
                "Step"
                container
                (lambda (btn evt)
                  (if stack-frames
                      (begin
                        (hash-table-put! breakpoints -1 #t)
                        (semaphore-post resume-sem))
                      (bell))))
              (send control-panel show #t)))
          
          (send (get-button-panel) change-children
                (lambda (_)
                  (cons debug-button
                        (remq debug-button _))))))
      
      (drscheme:get/extend:extend-definitions-text debug-definitions-text-mixin)
      (drscheme:get/extend:extend-interactions-text debug-interactions-text-mixin)
      (drscheme:get/extend:extend-unit-frame debug-unit-frame-mixin))))