diff --git a/collects/mztake/annotator.ss b/collects/mztake/annotator.ss new file mode 100644 index 0000000000..7e4e939121 --- /dev/null +++ b/collects/mztake/annotator.ss @@ -0,0 +1,299 @@ +(module annotator mzscheme + + (require (prefix kernel: (lib "kerncase.ss" "syntax")) + (lib "class.ss") + (lib "list.ss") + (lib "marks.ss" "mztake" "private") + (lib "mred.ss" "mred") + (lib "load-annotator.ss" "mztake" "private") + (prefix srfi: (lib "search.ss" "srfi" "1")) + ) + (provide annotate-stx annotate-for-single-stepping bindings) + + (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))])) + + + + + ;; Retreives the binding of a variable from a normal-breakpoint-info. + ;; Returns a list of pairs `(,variable-name-stx ,variable-value). Each + ;; item in the list is a shadowed instance of a variable with the given + ;; name, with the first item being the one in scope. + (define (bindings top-mark marks sym) + (let ([mark-list (cons top-mark (continuation-mark-set->list marks debug-key))]) + (map (lambda (binding) (list (mark-binding-binding binding) + (mark-binding-value binding))) + (lookup-all-bindings (lambda (id) (eq? (syntax-e id) sym)) + mark-list)))) + + + + (define (annotate-for-single-stepping stx break? break-before break-after record-bound-id) + (annotate-stx + stx + (lambda (debug-info annotated raw is-tail?) + (let* ([start (syntax-position raw)] + [end (+ start (syntax-span raw) -1)]) + (if is-tail? + #`(let-values ([(value-list) #f]) + (if (#,break? #,start) + (set! value-list (#,break-before + #,debug-info + (current-continuation-marks)))) + (if (not value-list) + #,annotated + (apply values value-list))) + #`(let-values ([(value-list) #f]) + (if (#,break? #,start) + (set! value-list (#,break-before + #,debug-info + (current-continuation-marks)))) + (if (not value-list) + (call-with-values + (lambda () #,annotated) + (case-lambda + [(val) (if (#,break? #,end) + (#,break-after + #,debug-info + (current-continuation-marks) val) + val)] + [vals (if (#,break? #,end) + (apply #,break-after + #,debug-info + (current-continuation-marks) vals) + (apply values vals))])) + (if (#,break? #,end) + (apply #,break-after + #,debug-info + (current-continuation-marks) value-list) + (apply values value-list))))))) + record-bound-id)) + + + ; annotate-stx : (syntax? (syntax? . -> . syntax?) + ; (symbol? syntax? syntax? . -> . void?) . -> . syntax?) + (define (annotate-stx stx break-wrap record-bound-id) + + (define breakpoints (make-hash-table)) + + (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) + (when (not is-tail?) + (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?)))]) + (for-each (lambda (id) (record-bound-id 'bind id id)) new-bindings) + (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 (arglist-bindings #'arg-list)] + [all-bound-vars (append new-bound-vars bound-vars)] + [new-bodies (let loop ([bodies (syntax->list #'bodies)]) + (if (equal? '() (cdr bodies)) + (list (annotate (car bodies) all-bound-vars #t)) + (cons (annotate (car bodies) all-bound-vars #f) + (loop (cdr bodies)))))]) + (for-each (lambda (id) (record-bound-id 'bind id id)) new-bound-vars) + (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 'ref 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 'set 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 + is-tail?) + annotated)) + + (values (top-level-annotate stx) (hash-table-map breakpoints (lambda (k v) k)))) + + #; + (define (tests) + (run/single-stepping-annotation + (current-custodian) "a.ss" + (map string->path '("/home/gmarceau/projects/mztake/collects/mztake/a.ss" + "/home/gmarceau/projects/mztake/collects/mztake/b.ss")) + (lambda (fn pos) + (printf "break?: ~a ~a~n" fn pos) #t) + (lambda (bp-info) (printf "break: ~a~n" bp-info) #f))) +) \ No newline at end of file diff --git a/collects/mztake/debug-tool.ss b/collects/mztake/debug-tool.ss new file mode 100644 index 0000000000..29d2992b4a --- /dev/null +++ b/collects/mztake/debug-tool.ss @@ -0,0 +1,730 @@ +(module debug-tool mzscheme + (require (lib "etc.ss") + (lib "list.ss") + (lib "string.ss") + ;(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" "mztake" "private") + (lib "boundmap.ss" "syntax") + (lib "bitmap-label.ss" "mrlib") + (lib "annotator.ss" "mztake") + (lib "load-annotator.ss" "mztake" "private") + ;(lib "framework.ss" "framework") + #;(lib "string-constant.ss" "string-constants")) + + (provide tool@) + + ; QUESTIONS/IDEAS + ; what is the right way to deal with macros? + ; how can the three tool classes communicate with each other safely + + (define tool@ + (unit/sig drscheme:tool-exports^ + (import drscheme:tool^) + + (define phase1 void) + (define phase2 void) + + (define (break-at bp p) + (hash-table-get bp p)) + + (define (truncate str n) + (if (< (string-length str) n) + str + (if (>= n 3) + (string-append + (substring str 0 (- n 3)) + "...") + (substring str 0 (min n (string-length str)))))) + + (define (string-map! f str) + (let loop ([i 0]) + (when (< i (string-length str)) + (string-set! str i (f (string-ref str i))) + (loop (add1 i))) + str)) + + (define (newlines->spaces str) + (string-map! (lambda (chr) + (case chr + [(#\newline) #\space] + [else chr])) + str)) + + (define (index-of chr str) + (let loop ([i 0]) + (if (< i (string-length str)) + (if (char=? chr (string-ref str i)) + i + (loop (add1 i))) + #f))) + + (define (trim-expr-str str) + (cond + [(index-of #\newline str) => (lambda (i) + (string-append + (substring str 0 i) + (if (char=? (string-ref str 0) #\() + " ...)" + " ...")))] + [str])) + + (define (average . values) + (/ (apply + values) (length values))) + + (define (debug-definitions-text-mixin super%) + (class super% + + (inherit dc-location-to-editor-location + editor-location-to-dc-location + invalidate-bitmap-cache + begin-edit-sequence + end-edit-sequence + get-canvas + get-top-level-window) + + (define parent #f) + (define debug? #f) + (define/public (set-parent! p) + (set! parent p) + (set! debug? (send parent debug?))) + (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/augment (on-delete start len) + (begin-edit-sequence) + (inner (void) on-delete start len)) + (define/augment (after-delete start len) + (inner (void) after-delete start len) + (clean-up) + (end-edit-sequence)) + + (define/augment (on-insert start len) + (begin-edit-sequence) + (inner (void) on-insert start len)) + (define/augment (after-insert start len) + (inner (void) after-insert start len) + (clean-up) + (end-edit-sequence)) + + (define/private (clean-up) + (set! debug? #f) + (when parent + (send parent hide-debug)) + (invalidate-bitmap-cache)) + + (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 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) + (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 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)]) + (send parent + set-mouse-over-msg + (cond + [(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 + #;(format "~a = ~a" id-sym + (namespace-variable-value + id-sym + #f + (lambda () (k #f)) + (send + (send parent get-interactions-text) + get-user-namespace))))))] + [val (mark-binding-value + binding)]) + (truncate (format "~a = ~a" id-sym val) 200))))] + [""]))) + (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)] + [f (get-top-level-window)]) + (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 + (let/ec k + (send parent set-break-status + (cons 'exit-break + (call-with-values + (lambda () + (with-handlers ([exn:fail? k]) ; LATER: message box + (eval-string tmp))) + list)))))))))) + (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) + (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)))] + [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 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) (average yl yr)]) + (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)) + #;(let loop ([end-pos pos] + [marks (send parent get-stack-frames)]) + (when (cons? marks) + (let*-values ([(start-pos) (syntax-position (mark-source (first marks)))] + [(xl0 yl0 xr0 yr0) (find-char-box this (sub1 start-pos) start-pos)] + [(xm0) (average xl0 xr0)] + [(ym0) (average yl0 yr0)] + [(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 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 xm0 ym0 xr ym dx dy) + (loop start-pos (rest marks))))))))))) + + (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-before break-after) + (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 + (parameterize ([current-eval oe]) + (eval/annotations + top-e + (lambda (fn m) #f) ; TODO: multiple file support + (lambda (stx) + (let*-values ([(breakpoints) (send parent get-breakpoints)] + [(pos-vec) (send parent get-pos-vec)] + [(annotated break-posns) + (annotate-for-single-stepping + (expand-syntax top-e) + break? + break-before + break-after + (lambda (type 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))))))]) + (for-each (lambda (posn) (hash-table-put! breakpoints posn #f)) break-posns) + ;(display-results (list orig-exp)) + 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 () + ;(print-struct #t) + (let ([self (current-thread)] + [oeh (current-exception-handler)] + [err-hndlr (error-display-handler)]) + (error-display-handler + (lambda (msg exn) + (err-hndlr msg exn) + (if (and (eq? self (current-thread)) (exn:fail? exn)) + (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)))) + ; break-before + (lambda (top-mark ccm) + (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) + (send parent suspend oeh (cons top-mark debug-marks) 'entry-break))) + ; break-after + (case-lambda + [(top-mark ccm val) + (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) + (send parent suspend oeh (cons top-mark debug-marks) (list 'exit-break val)))] + [(top-mark ccm . vals) + (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) + (send parent suspend oeh (cons top-mark debug-marks) (cons 'exit-break vals)))]))) + (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)]) + (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 + get-top-level-window) + + (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 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 (set-mouse-over-msg msg) + (when (not (string=? msg (send mouse-over-message get-label))) + (send mouse-over-message set-label msg))) + + (define/public (get-pc) + (if (cons? stack-frames) + (let* ([src-stx (mark-source (first stack-frames))] + [start (syntax-position src-stx)] + [end (and start (+ 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) + (send pause-button enable #f) + (send step-button enable #t) + (send resume-button enable #t) + ;(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) + (when (cons? status) + (let ([expr (mark-source (first frames))]) + (send status-message set-label + (truncate + (format "~a ==> ~a" + (trim-expr-str + (send (get-definitions-text) get-text + (sub1 (syntax-position expr)) + (+ -1 (syntax-position expr) (syntax-span expr)))) + (if (= 2 (length status)) + (cadr status) + (cons 'values (rest status)))) + 200)))) + (cond [(get-pc) => (lambda (pc) (send (get-definitions-text) scroll-to-position pc))]) + (send (get-definitions-text) invalidate-bitmap-cache) + (with-handlers ([exn:break? + (lambda (exn) + (set! stack-frames osf) + (set! break-status obs) + (send status-message set-label "") + (send (get-definitions-text) invalidate-bitmap-cache) + (break-handler exn))]) + (semaphore-wait/enable-break resume-sem)) + (begin0 + (if (cons? break-status) + (apply values (rest break-status)) + #f) + (set! stack-frames osf) + (set! break-status obs) + (send pause-button enable #t) + (send step-button enable #f) + (send resume-button enable #f) + (send status-message set-label "") + (send (get-definitions-text) invalidate-bitmap-cache))))) + + (define (my-execute debug?) + (set! want-debug? debug?) + (if debug? + (show-debug) + (hide-debug)) + (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) + (super execute-callback)) + + (define/override (execute-callback) + (my-execute #f)) + + (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 debug-parent-panel 'uninitialized-debug-parent-panel) + (define debug-panel 'uninitialized-debug-panel) + (define/override (get-definitions/interactions-panel-parent) + (set! debug-parent-panel + (make-object vertical-panel% + (super get-definitions/interactions-panel-parent))) + (set! debug-panel (instantiate horizontal-panel% () + (parent debug-parent-panel) + (stretchable-height #f) + (alignment '(center center)) + (style '(border)))) + (send debug-parent-panel change-children (lambda (l) null)) + #;(instantiate button% () + (label "Hide") + (parent debug-panel) + (callback (lambda (x y) (hide-debug))) + (stretchable-height #t)) + (make-object vertical-panel% debug-parent-panel)) + + (define/public (hide-debug) + (when (member debug-panel (send debug-parent-panel get-children)) + (send debug-parent-panel change-children + (lambda (l) (remq debug-panel l))))) + + (define/public (show-debug) + (unless (member debug-panel (send debug-parent-panel get-children)) + (send debug-parent-panel change-children + (lambda (l) (cons debug-panel l))))) + + (super-new) + + (define status-message + (instantiate message% () + [label ""] + [parent debug-panel] + [stretchable-width #t])) + + (define debug-button + (make-object button% + ((bitmap-label-maker + "Debug" + (build-path (collection-path "mztake" "icons") "icon-small.png")) this) + (get-button-panel) + (lambda (button evt) + (my-execute #t)))) + + (define pause-button + (instantiate button% () + [label ((bitmap-label-maker + "Pause" + (build-path (collection-path "mztake" "icons") "pause.png")) this)] + [parent debug-panel] + [callback (lambda (button evt) + (if stack-frames + (bell) + (begin + (set! want-suspend-on-break? #t) + (break-callback) + (reset-offer-kill))))] + [enabled #t])) + + (define resume-button + (instantiate button% () + [label ((bitmap-label-maker + "Continue" + (build-path (collection-path "mztake" "icons") "resume.png")) this)] + [parent debug-panel] + [callback (lambda (button evt) + (if stack-frames + (semaphore-post resume-sem) + (bell)))] + [enabled #f])) + + (define step-button + (instantiate button% () + [label ((bitmap-label-maker + "Step" + (build-path (collection-path "mztake" "icons") "step.png")) this)] + [parent debug-panel] + [callback (lambda (btn evt) + (if stack-frames + (begin + (hash-table-put! breakpoints -1 #t) + (semaphore-post resume-sem)) + (bell)))] + [enabled #f])) + + (define mouse-over-message + (instantiate message% () + [label ""] + [parent debug-panel] + [stretchable-width #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)))) \ No newline at end of file diff --git a/collects/mztake/debugger-annotate.ss b/collects/mztake/debugger-annotate.ss deleted file mode 100644 index d553626abf..0000000000 --- a/collects/mztake/debugger-annotate.ss +++ /dev/null @@ -1,232 +0,0 @@ -(module debugger-annotate mzscheme - - (require (prefix kernel: (lib "kerncase.ss" "syntax")) - (lib "marks.ss" "mztake" "private") - (lib "mred.ss" "mred") - (lib "load-annotator.ss" "mztake" "private") - (lib "more-useful-code.ss" "mztake" "private") - (lib "list.ss")) - - (provide annotate-stx - run/incremental-annotation - bindings) - - ;; TARGETS is a list of pairs: - ;; `(,module-long-filename (,character-offset ...)) - - (define (run/incremental-annotation main-module custodian targets receive-result) - - (define ((break target) mark-set kind final-mark) - (let ([mark-list (continuation-mark-set->list mark-set debug-key)]) - (receive-result (make-normal-breakpoint-info (cons final-mark mark-list) target)))) - - (define ((err-display-handler source) message exn) - (thread (lambda () (receive-result (make-error-breakpoint-info (list source exn)))))) - - (define (annotate-module-with-error-handler stx err-hndlr) - (syntax-case stx (module #%plain-module-begin) - [(module name req (#%plain-module-begin body ...)) - #`(module name req (#%plain-module-begin - (error-display-handler #,err-hndlr) - body ...))])) - - (define (path->target path) - (first (filter (lambda (c) (equal? (first c) path)) - targets))) - - (let* ([all-used-module-paths (map first targets)] - - [annotate-module? (lambda (fn m) - (memf (lambda (sym) (equal? sym fn)) - all-used-module-paths))] - - [annotator (lambda (fn m stx) - ;;(printf "annotating: ~a~n~n" fn) - (let* ([target (path->target fn)] - [breakpoints (second target)] - [stx (annotate-stx (expand stx) (list fn breakpoints) (break target))]) - ;; add an error handler so anything that goes wrong points to the correct module - (annotate-module-with-error-handler stx (err-display-handler fn))))]) - - (parameterize ([current-custodian custodian] - [current-namespace (make-namespace-with-mred)] - [error-display-handler (err-display-handler (format "Loading module ~a..." main-module))]) - (require/annotations `(file ,main-module) annotate-module? annotator)))) - - (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-break? expr targets) - (and (eq? (syntax-source expr) (first targets)) - (memq (- (syntax-position expr) 1) ; syntax positions start at one. - (second targets)))) - - (define (annotate-stx stx targets break-fn) - - (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 (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-fn (current-continuation-marks) 'debugger-break #,debug-info) - #,annotated)) - - (define annotated - (kernel:kernel-syntax-case expr #f - [var-stx (identifier? (syntax var-stx)) 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) - (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))])) - - (if (annotate-break? expr targets) - (break-wrap (make-debug-info expr bound-vars bound-vars 'at-break #f) - annotated) - annotated)) - - (top-level-annotate stx)) - - ;; Retreives the binding of a variable from a normal-breakpoint-info. - ;; Returns a list of pairs `(,variable-name-stx ,variable-value). Each - ;; item in the list is a shadowed instance of a variable with the given - ;; name, with the first item being the one in scope. - (define (bindings event sym) - (let ([mark-list (normal-breakpoint-info-mark-list event)]) - (map (lambda (binding) (list (mark-binding-binding binding) - (mark-binding-value binding))) - (lookup-all-bindings (lambda (id) (eq? (syntax-e id) sym)) - mark-list))))) - diff --git a/collects/mztake/demos/sine/sine-mztake-uncommented.ss b/collects/mztake/demos/sine/sine-mztake-uncommented.ss index f79692374a..29ff10b76e 100644 --- a/collects/mztake/demos/sine/sine-mztake-uncommented.ss +++ b/collects/mztake/demos/sine/sine-mztake-uncommented.ss @@ -1,41 +1,41 @@ -(require (lib "animation.ss" "frtime")) - - -(define-mztake-process p ("sine.ss" [x/sinx-trace 5 8 bind '(x sin-x)])) - - -(define x/sinx (hold x/sinx-trace)) - - -(define x (first x/sinx)) -(define sin-x (second x/sinx)) - - -(printf-b "x: ~a" x) -(printf-b "sin(x/20): ~a" sin-x) - - -(printf-b "largest x: ~a sin(x/20): ~a" - (largest-val-b (changes (first x/sinx))) - (largest-val-b (changes (second x/sinx)))) - -(printf-b "smallest x:~a sin(x/20):~a" - (smallest-val-b (changes (first x/sinx))) - (smallest-val-b (changes (second x/sinx)))) - - -(display-shapes - (list* (make-line (make-posn 0 200) (make-posn 400 200) "gray") - (make-line (make-posn 200 0) (make-posn 200 400) "gray") - - (let ([x (+ 200 x)] - [sin-x (+ 200 (* 100 sin-x))]) - (history-b 50 (changes (make-circle - (make-posn x sin-x) - 5 - (if (< 200 sin-x) - (if (< 200 x) "blue" "darkblue") #| Quadrants 3 and 4 |# - (if (< 200 x) "red" "darkred")))))))) #| 1 and 2 |# - - +(require (lib "animation.ss" "frtime")) +(require (lib "mztake-syntax.ss" "mztake")) + +(define-mztake-process p ("sine.ss" [x/sinx-trace 5 8 bind '(x sin-x)])) + + +(define x/sinx (hold x/sinx-trace)) + + +(define x (first x/sinx)) +(define sin-x (second x/sinx)) + + +(printf-b "x: ~a" x) +(printf-b "sin(x/20): ~a" sin-x) + + +(printf-b "largest x: ~a sin(x/20): ~a" + (largest-val-b (changes (first x/sinx))) + (largest-val-b (changes (second x/sinx)))) + +(printf-b "smallest x:~a sin(x/20):~a" + (smallest-val-b (changes (first x/sinx))) + (smallest-val-b (changes (second x/sinx)))) + + +(display-shapes + (list* (make-line (make-posn 0 200) (make-posn 400 200) "gray") + (make-line (make-posn 200 0) (make-posn 200 400) "gray") + + (let ([x (+ 200 x)] + [sin-x (+ 200 (* 100 sin-x))]) + (history-b 50 (changes (make-circle + (make-posn x sin-x) + 5 + (if (< 200 sin-x) + (if (< 200 x) "blue" "darkblue") #| Quadrants 3 and 4 |# + (if (< 200 x) "red" "darkred")))))))) #| 1 and 2 |# + + (start/resume p) \ No newline at end of file diff --git a/collects/mztake/emblem-ohno.png b/collects/mztake/icons/emblem-ohno.png similarity index 100% rename from collects/mztake/emblem-ohno.png rename to collects/mztake/icons/emblem-ohno.png diff --git a/collects/mztake/icons/icon-big.png b/collects/mztake/icons/icon-big.png new file mode 100644 index 0000000000..4f919a1f4a Binary files /dev/null and b/collects/mztake/icons/icon-big.png differ diff --git a/collects/mztake/icons/icon-small.png b/collects/mztake/icons/icon-small.png new file mode 100644 index 0000000000..6d2a92389f Binary files /dev/null and b/collects/mztake/icons/icon-small.png differ diff --git a/collects/mztake/icons/icon.png b/collects/mztake/icons/icon.png new file mode 100644 index 0000000000..94f0f0bec5 Binary files /dev/null and b/collects/mztake/icons/icon.png differ diff --git a/collects/mztake/icons/icon2.png b/collects/mztake/icons/icon2.png new file mode 100644 index 0000000000..6a48b00815 Binary files /dev/null and b/collects/mztake/icons/icon2.png differ diff --git a/collects/mztake/icons/no.png b/collects/mztake/icons/no.png new file mode 100644 index 0000000000..6f16ff9c49 Binary files /dev/null and b/collects/mztake/icons/no.png differ diff --git a/collects/mztake/icons/pause.png b/collects/mztake/icons/pause.png new file mode 100644 index 0000000000..29f8e10d07 Binary files /dev/null and b/collects/mztake/icons/pause.png differ diff --git a/collects/mztake/icons/resume.png b/collects/mztake/icons/resume.png new file mode 100644 index 0000000000..7670630e84 Binary files /dev/null and b/collects/mztake/icons/resume.png differ diff --git a/collects/mztake/icons/step.png b/collects/mztake/icons/step.png new file mode 100644 index 0000000000..feb20ab7c3 Binary files /dev/null and b/collects/mztake/icons/step.png differ diff --git a/collects/mztake/icons/stock_macro-check-brackets-16.png b/collects/mztake/icons/stock_macro-check-brackets-16.png new file mode 100644 index 0000000000..98dcd84a30 Binary files /dev/null and b/collects/mztake/icons/stock_macro-check-brackets-16.png differ diff --git a/collects/mztake/icons/stock_macro-check-brackets.png b/collects/mztake/icons/stock_macro-check-brackets.png new file mode 100644 index 0000000000..4c88dabf80 Binary files /dev/null and b/collects/mztake/icons/stock_macro-check-brackets.png differ diff --git a/collects/mztake/info.ss b/collects/mztake/info.ss index 9422a0acb6..5724c38864 100644 --- a/collects/mztake/info.ss +++ b/collects/mztake/info.ss @@ -1,7 +1,7 @@ (module info (lib "infotab.ss" "setup") (define name "Debugger") - (define tools '(("debugger-tool.ss"))) - (define blurb '("MzTake is a scripted debugger for PLT Scheme.")) - (define tool-names '("MzTake Debugger")) - (define tool-icons '(("emblem-ohno.png" "mztake"))) + (define tools '(("mztake-lang.ss") ("debug-tool.ss"))) + (define blurb '("MzTake is a scripted debugger for PLT Scheme." "A debugging tool for DrScheme")) + (define tool-names '("MzTake Debugger" "Skipper")) + (define tool-icons '(("emblem-ohno.png" "mztake" "icons") ("icon-big.png" "mztake" "icons"))) ) diff --git a/collects/mztake/debugger-tool.ss b/collects/mztake/mztake-lang.ss similarity index 84% rename from collects/mztake/debugger-tool.ss rename to collects/mztake/mztake-lang.ss index 6585b37181..1be95b167a 100644 --- a/collects/mztake/debugger-tool.ss +++ b/collects/mztake/mztake-lang.ss @@ -15,12 +15,13 @@ ; ; ; ; ;;;; -(module debugger-tool mzscheme +(module mztake-lang mzscheme (require "mztake.ss" (lib "etc.ss") (lib "list.ss") (lib "class.ss") (lib "unitsig.ss") + (lib "bitmap-label.ss" "mrlib") (lib "contract.ss") (lib "mred.ss" "mred") (lib "tool.ss" "drscheme") @@ -44,11 +45,10 @@ (drscheme:language:simple-module-based-language->module-based-language-mixin base)) (field (watch-list empty)) - (rename [super-on-execute on-execute]) (inherit get-language-position) (define/override (on-execute settings run-in-user-thread) (let ([drs-eventspace (current-eventspace)]) - (super-on-execute settings run-in-user-thread) + (super on-execute settings run-in-user-thread) (run-in-user-thread (lambda () (let ([new-watch (namespace-variable-value 'render)] @@ -60,15 +60,12 @@ (lambda (r) (cons (make-weak-box new-watch) r))) (filter weak-box-value watch-list)))))))) - (rename (super:render-value/format render-value/format) - (super:render-value render-value)) - (override render-value/format render-value) - (define (render-value/format value settings port put-snip width) - (super:render-value/format (watch watch-list value put-snip) - settings port put-snip width)) - (define (render-value value settings port put-snip) - (super:render-value (watch watch-list value put-snip) - settings port put-snip)) + (define/override (render-value/format value settings port width) + (super render-value/format (watch watch-list value) + settings port width)) + (define/override (render-value value settings port) + (super render-value (watch watch-list value) + settings port)) (define/override (use-namespace-require/copy?) #t) (super-instantiate ()))) @@ -103,12 +100,12 @@ [else false]) (loop (rest lis))))))) - (define (watch watch-list value as-snip?) + (define (watch watch-list value) (foldl (lambda (wb acc) (cond [(weak-box-value wb) - => (lambda (f) (f acc as-snip?))] + => (lambda (f) (f acc))] [else acc])) value watch-list)) @@ -116,9 +113,9 @@ (define debugger-bitmap - (drscheme:unit:make-bitmap + (bitmap-label-maker "Syntax Location" - (build-path (collection-path "mztake") "stock_macro-check-brackets-16.png"))) + (build-path (collection-path "mztake" "icons") "stock_macro-check-brackets-16.png"))) (define (debugger-unit-frame-mixin super%) (class super% diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss index 13ca20be47..be52ba9e5b 100644 --- a/collects/mztake/mztake.ss +++ b/collects/mztake/mztake.ss @@ -2,128 +2,16 @@ (define mztake-version "rev. 8/6/2004") - #|:::::::::LOAD/ANNOTATOR BUGS::::::::::: -* catch oops exception -* catch the other two exceptions that my loaders throw -* detect if the source code for a certain module is missing and throw an exception -* do I want to parameterize it over a given namespace? -* does this handle module prefixes? -* what happens if two modules have the same name in different directories -* MAKE SURE THERE WONT BE COLLISIONS WHEN EVAL'NG MODULES...GIVE THEM UNIQUE NAMES BASED ON PATH! -:::::::::::::::::::::::::::::::::::::::::: - -CHANGES TO MAKE----------------------------------------------------------------------------- -Ability to add named anchors into code using Special menu in DRS -- use those anchors as tracepoints. - -Mailing list just for MzTake updates - -Demo monitoring DrScheme for Robby? - -Bind Stop button to kill-all. - -Remove the tool button for 299 update. - -Reword hacked changes in doc.txt for stopping MzTake with kill - -Test Suite for debugger annotator - -Demo and docs for debugging multiple files, to make Robby happy. It is true that the docs are not very helpful on this count. It'd be nice if you could mock up a quick example of tracing something inside DrScheme.... - -On the whole, I like the tool, although it'd be nice to have either - (a) an interactive pointy-clicky interface rather than figuring - out line/column co-ordinates, or - (b) an AST-based description of the thing to be monitored (shades - of aspect-oriented programming). - -(1) montecarlo never gets to pi: I think there's a math error. -Shouldn't montecarlo.ss check whether (length . <= . 200)? Otherwise, you're off by about 1% which gives an underestimate by about 0.03. (You could speed it up by removing the sqrt call and checking against 40000). - -(2) dijkstra seems to go into an infinite loop -- but I don't know what the source of the problem is, because - -(3) plt scheme becomes quite unstable: the STOP button no longer works, and I end up killing things using Windows Task Manager, at which point I cannot run PLT Scheme (208) until I reboot :-( - - -Re-direct, or at least prefix, program output from the client so that it can be distinguished from the script - -Paramterize print-struct to #f for printing in the script - - -DEMOS--------------------------------------------------------------------------------------- -* Data structure examples - Binary search over a tree, show which node is being examined, or the most commonly taken path - Parse, graph the AST -- show OR and AND precedence getting messed up - -* MST example - -* something with multiple threads doing something and draw the threads in different colors in a window - - -SCRIPT-------------------------------------------------------------------------------------- -* document history-e; provide a variant of history which takes no n, and keeps a complete history - -* process:time-per-event/milliseconds is broken - (printf-b "~a ms per event" (time-per-event/milliseconds p (changes (hold sin/x-trace)))) - -* process:running? is broken - -* Make script errors highlight the location of the error - -* Let traces take a line number without offset and find the first bindable location. - -* Provide a body to bind instead or returning an eventstream, like (list x y) - Write a nested syntax for bind so that you can take a first-class function that defines a way to return variables, not just as a list - -* Maybe take a thunk to do when a entry trace is hit? - -* Way to turn printouts on and off like (print-struct #t), or should we have an output window? (mztake-verbose) (parameterize it?) - - -OPTIMIZATIONS------------------------------------------------------------------------------- -* improve speed of lookup for line-col->pos; load them into a hashtable? not important since this is just startup time for the script. - -* improve speed of load/annotate - -* improve speed of functions in (run) - -* Remove marks.ss from MzTake as soon as the new version of it becomes standard with releases. -Search for everywhere marks.ss shows up in mztake and replace -(lib "marks.ss" "mztake" "private") with (lib "marks.ss" "stepper" "private") - - -ERROR-CHECKING/HANDLING--------------------------------------------------------------------- -* Make (script-error) map to some exception stream for script errors only. - -* Make all exposed cells and evstreams read-only by lifting the identity function on them - -* Turn script errors into syntax errors (i.e. what happens when you bind to variables that don't exist) - --take the syntax when the binding is made and save it in a hashtable - -* Offer a way to install a special handler for exceptions -- somehow identify which client an exceptions comes from - - -TESTING/CAPABILITIES------------------------------------------------------------------------ -* Does user interaction work? Can we step through loops one line at a time waiting for input? GUIs? - -* We want a way to interactively step through code one line at a time when we pause. - Provide way to check bindings at the same time -- EVEN IF NOT BOUND USING TRACE/BIND - -* What kind of interface do we want to dig into frames - -* Need to know where the program pauses at - -* What do we do about binding to a variable and following it EVERYWHERE it goes. Even if it is assigned to something else. - -* Find a way to bind to the result of ananonymous expression: here->(add1 2) -|# - (require (lib "match.ss") (lib "contract.ss") - (lib "marks.ss" "mztake" "private") ; TODO local private copy until stepper release + (lib "marks.ss" "mztake" "private") (prefix frp: (lib "frp.ss" "frtime")) (lib "useful-code.ss" "mztake" "private") (lib "more-useful-code.ss" "mztake" "private") ; mostly for hash- bindings "mztake-structs.ss" - "debugger-annotate.ss") + (lib "load-annotator.ss" "mztake" "private") + "annotator.ss" + ) (provide/contract [start/resume (debug-process? . -> . void?)] [kill (debug-process? . -> . void?)] @@ -143,11 +31,11 @@ TESTING/CAPABILITIES------------------------------------------------------------ (debug-process? . -> . frp:behavior?)]) #| DISABLED - BROKEN - [process:running? (debug-process? . -> . frp:behavior?)] - [rename time-per-event/milliseconds - process:time-per-event/milliseconds - (debug-process? frp:behavior? . -> . frp:behavior?)] - |# + [process:running? (debug-process? . -> . frp:behavior?)] + [rename time-per-event/milliseconds + process:time-per-event/milliseconds + (debug-process? frp:behavior? . -> . frp:behavior?)] + |# ; ; ; ; @@ -173,64 +61,6 @@ TESTING/CAPABILITIES------------------------------------------------------------ ;########################################################################################################### - ; ; ; ; ; - ; ;;;;; ; ; ; ; - ; ;; ; ; ; ; ; - ; ; ; ; ; ; - ; ; ;;;; ; ; ; ;;;; ;;;; ;;; ; ; ;;;; - ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ;;; ;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; - ; ;;;;; ;;;; ; ; ; ;;;;;; ;;;; ; ;;; ; ; ;;;; - ; - - (define (find-client process modpath) - (first - (filter (lambda (c) (equal? modpath (debug-client-modpath c))) - (debug-process-clients process)))) - - ; Callback for when a breakpoint (tracepoint) is hit by the model - ; ((client) breakpoint-struct) -> () - (define ((receive-result process) result) - - ; Before we process the trace, see if we are supposed to pause - ;; TODO : this condition variable has a race condition - (unless (running-now? process) - (semaphore-wait (debug-process-run-semaphore process))) - - (match result - ; regular breakpoint - [($ normal-breakpoint-info (top-mark rest-mark ...) target) - (let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))] - ;; TODO : find-client is slow and awkward - [client (find-client process (first target))] - [traces (hash-get (debug-client-tracepoints client) byte-offset)]) - - (assert (not (empty? traces)) - (format "There are no traces at offset ~a, but a trace point is defined!~n" - (number->string byte-offset))) - - ; Run all traces at this trace point - (let ([to-send (map (lambda (t) (trace->frp-event client result t)) traces)]) - (frp:send-synchronous-events to-send)) - - ; Now that we processed the trace, do we want to pause or continue - (unless (running-now? process) - (semaphore-wait (debug-process-run-semaphore process))))] - - [($ error-breakpoint-info (source exn)) - ; all errors and raises from the TARGET program will be caught here - ; FrTime errors from the script have their own eventstream - (frp:send-event (debug-process-exceptions process) exn) - (client-error (format "source: ~a | exception: ~a" source (if (exn? exn) (exn-message exn) exn)))])) - - ;########################################################################################################### - - ; ; ; ; @@ -257,7 +87,7 @@ TESTING/CAPABILITIES------------------------------------------------------------ (display "All debug processes have been killed."))) - ; wrapper for errors related to the script only + ; wrapper for errors related to the script only (define (script-error err) (raise-syntax-error 'mztake:script-error (format "~a" err)) (kill-all)) @@ -291,31 +121,31 @@ TESTING/CAPABILITIES------------------------------------------------------------ (create-trace client line col type null)])) - ; takes a single trace, looks up what it needs to do, and returns an frp-event to publish - (define (trace->frp-event client event trace) + ; takes a single trace, looks up what it needs to do, and returns an frp-event to publish + (define (trace->frp-event client top-mark marks trace) (match trace - [($ entry-trace evnt-rcvr) - (list evnt-rcvr #t)] - - [($ bind-trace evnt-rcvr variable-to-bind) - (let* ([vars (if (list? variable-to-bind) variable-to-bind - (list variable-to-bind))] - [values (map - (lambda (var) - (let ([val (bindings event var)]) - (if (empty? val) - (script-error - (format "Variable not found at the syntax location for the BIND: `~a'" var)) - (cadar (bindings event var))))) - vars)]) - (list evnt-rcvr - (if (list? variable-to-bind) values - (first values))))])) + [($ entry-trace evnt-rcvr) + (list evnt-rcvr #t)] + + [($ bind-trace evnt-rcvr variable-to-bind) + (let* ([vars (if (list? variable-to-bind) variable-to-bind + (list variable-to-bind))] + [values (map + (lambda (var) + (let ([val (bindings top-mark marks var)]) + (if (empty? val) + (script-error + (format "Variable not found at the syntax location for the BIND: `~a'" var)) + (cadar (bindings top-mark marks var))))) + vars)]) + (list evnt-rcvr + (if (list? variable-to-bind) values + (first values))))])) - ; returns a memoized function that takes (line column) -> position - ; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?))) + ; returns a memoized function that takes (line column) -> position + ; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?))) (define (line-col->pos filename) - ; produces a nested list of (line column offset) for all addressable syntax + ; produces a nested list of (line column offset) for all addressable syntax (define (unwrap-syntax stx) (let ([elt (list (syntax-line stx) (syntax-column stx) @@ -328,26 +158,26 @@ TESTING/CAPABILITIES------------------------------------------------------------ (flatten (parameterize ([port-count-lines-enabled #t]) (let ([port (open-input-file filename)]) (begin0 - (let loop ([stx (read-syntax filename port)]) - (if (eof-object? stx) '() - (cons (unwrap-syntax stx) - (loop (read-syntax filename port))))) + (let loop ([stx (read-syntax filename port)]) + (if (eof-object? stx) '() + (cons (unwrap-syntax stx) + (loop (read-syntax filename port))))) (close-input-port port)))))]) (lambda (line col) (let loop ([lst pos-list] [last-coord (first pos-list)]) (cond - ; none is found - [(empty? lst) - (raise (format "No syntax found for trace at line/column ~a:~a in client `~a'" line col filename))] - - ; if first is correct line and correct column - [(and (= line (caar lst)) - (= col (cadar lst))) - (third (first lst))] - - [else (loop (rest lst) - (first lst))]))))) + ; none is found + [(empty? lst) + (raise (format "No syntax found for trace at line/column ~a:~a in client `~a'" line col filename))] + + ; if first is correct line and correct column + [(and (= line (caar lst)) + (= col (cadar lst))) + (third (first lst))] + + [else (loop (rest lst) + (first lst))]))))) ;########################################################################################################### @@ -367,26 +197,95 @@ TESTING/CAPABILITIES------------------------------------------------------------ ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;; - (define (run* process receive-result) - (run/incremental-annotation - (debug-client-modpath (debug-process-main-client process)) - (debug-process-custodian process) - (map (lambda (c) (list (debug-client-modpath c) - (hash-keys (debug-client-tracepoints c)))) - (debug-process-clients process)) - receive-result)) + + (define (find-client process modpath) + (printf "find-client ~s ~s ~n" (map debug-client-modpath (debug-process-clients process)) modpath) + (cond + [(memf (lambda (c) (equal? (debug-client-modpath c) modpath)) + (debug-process-clients process)) => first] + [else false])) - (define (start-debug-process receive-result process) - ; initialize the semaphore + (define (break? process client) + (printf "break? ~a ~a~n" client (debug-client-tracepoints client)) + (let ([tracepoints (and client (debug-client-tracepoints client))]) + (if tracepoints + (lambda (pos) + (begin0/rtn + (hash-get tracepoints (sub1 pos) (lambda () false)) + (printf "break? ~a~n" rtn))) + (lambda (pos) false)))) + + (define (receive-result process client top-mark marks) + (printf "receive-result~n") + (let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))] + [traces (hash-get (debug-client-tracepoints client) byte-offset)]) + + (assert (not (empty? traces)) + (format "There are no traces at offset ~a, but a trace point is defined!~n" + (number->string byte-offset))) + + ; Run all traces at this trace point + (let ([to-send (map (lambda (t) (trace->frp-event client top-mark marks t)) traces)]) + (printf "frp:send-synchronous-events ~a~n" to-send) + (frp:send-synchronous-events to-send)) + + ; Now that we processed the trace, do we want to pause ojr continue + (unless (running-now? process) + (semaphore-wait (debug-process-run-semaphore process))))) + + + + + (define ((break-after process client) top-mark marks . vals) + (receive-result process client top-mark marks) ; TODO: have access to return value + (apply values vals)) ; TODO: allow modification of the return value + + (define ((break-before process client) top-mark marks) + (receive-result process client top-mark marks) ; TODO: allow substitute value + false) + + (define (run* process) + (require/sandbox+annotations + (debug-process-custodian process) + ;; error-display-handler : + (let ([orig-err-disp (error-display-handler)]) + (lambda (msg exn) + (frp:send-event (debug-process-exceptions process) exn) + (orig-err-disp msg exn))) + `(file ,(debug-client-modpath (debug-process-main-client process))) + ;; annotate-module? + (lambda (filename module-name) + (begin0/rtn + (memf (lambda (c) (equal? (debug-client-modpath c) (path->string filename)));; TODO: harmonize path & string + (debug-process-clients process)) + (printf "annotate-module? ~s ~s ~s : ~s~n" + (map debug-client-modpath (debug-process-clients process)) + filename module-name rtn))) + ;; annotator? + (lambda (stx) + (let ([client (find-client process (syntax-source stx))]) + (if (not client) + stx + (let-values ([(annotated-stx pos-list) + (annotate-for-single-stepping + stx + (break? process client) + (break-before process client) + (break-after process client) + (lambda (kind bound binding) (void)))]) + annotated-stx)))))) + + (define (start-debug-process process) + ; initialize the semaphore (set-debug-process-run-semaphore! process (make-semaphore)) - ; set initial state of exit predicate + ; set initial state of exit predicate (frp:set-cell! (debug-process-exited? process) #f) (thread (lambda () - (thread-wait (thread (lambda () (run* process receive-result)))) - ; program terminates + (thread-wait (thread (lambda () (run* process)))) + ; program terminates (stop process) - (print-info (format "process exited normally: ~a" (main-client-name process)))))) + (print-info (format "process exited: ~a" (main-client-name process)))))) ; predicate - is the debugee supposed to be running now? @@ -408,7 +307,7 @@ TESTING/CAPABILITIES------------------------------------------------------------ ; start the debugger if needed (when (null? (debug-process-run-semaphore process)) (print-info (format "starting debugger for ~a" (main-client-name process))) - (start-debug-process (receive-result process) process)) + (start-debug-process process)) (when run? (semaphore-post (debug-process-run-semaphore process))) @@ -519,7 +418,7 @@ TESTING/CAPABILITIES------------------------------------------------------------ (define (create-debug-client process filename) ; throwaway namespace so the module-name-resolver doesn't load an unannotated module (parameterize ([current-namespace (make-namespace)]) - (with-handlers ([exn:module? + (with-handlers ([exn:fail? (lambda (exn) (client-error (format "Expected a module in client file: ~a" filename)))]) @@ -537,7 +436,6 @@ TESTING/CAPABILITIES------------------------------------------------------------ modpath))] [client (create-empty-debug-client)]) - (for-each (lambda (c) (when (equal? modpath (debug-client-modpath c)) (raise-syntax-error 'mztake:script-error:create-debug-client diff --git a/collects/mztake/private/load-annotator.ss b/collects/mztake/private/load-annotator.ss index c1cf6a104d..75bea2f696 100644 --- a/collects/mztake/private/load-annotator.ss +++ b/collects/mztake/private/load-annotator.ss @@ -4,8 +4,10 @@ (lib "class.ss" "mzlib") (lib "mred.ss" "mred")) - (provide require/annotations - load/annotate) + (provide eval/annotations + require/annotations + require/sandbox+annotations + load-module/annotate) #|load-with-annotations : @@ -22,23 +24,30 @@ >annotator : (string? symbol? syntax? . -> . syntax?) |# + + (define (require/sandbox+annotations custodian err-display-handler initial-module annotate-module? annotator) + (printf "require/sandbox+annotations ~a~n" initial-module) + (parameterize ([current-custodian custodian] + [current-namespace (make-namespace-with-mred)] + [error-display-handler err-display-handler]) + (require/annotations initial-module annotate-module? annotator))) + + (define (require/annotations initial-module annotate-module? annotator) + (eval/annotations #`(require #,initial-module) annotate-module? annotator)) + + (define (eval/annotations stx annotate-module? annotator) (parameterize - ([current-load/use-compiled - (let ([ocload/use-compiled (current-load/use-compiled)]) - (lambda (fn m) - (with-handlers - ([exn:module? - (lambda (exn) - (raise (format "mztake:client:not-a-module: file:`~a' module:`~a'" fn m)))]) - - (cond [(annotate-module? fn m) - (load/annotate annotator fn m)] - [else - (ocload/use-compiled fn m)]))))]) - (eval #`(require #,initial-module)))) + ([current-load/use-compiled + (let ([ocload/use-compiled (current-load/use-compiled)]) + (lambda (fn m) + (cond [(annotate-module? fn m) + (load-module/annotate annotator fn m)] + [else + (ocload/use-compiled fn m)])))]) + (eval-syntax (annotator stx)))) - (define (load/annotate annotator fn m) + (define (load-module/annotate annotator fn m) (let-values ([(base _ __) (split-path fn)] [(in-port src) (build-input-port fn)]) (dynamic-wind @@ -47,15 +56,15 @@ (lambda () (parameterize ([read-accept-compiled #f] [current-load-relative-directory base]) - (unless m (raise 'module-name-not-passed-to-load/annotate)) + (unless m (raise 'module-name-not-passed-to-load-module/annotate)) (with-module-reading-parameterization (lambda () (let* ([first (expand (read-syntax src in-port))] - [module-ized-exp (annotator fn m (check-module-form first m fn))] + [module-ized-exp (annotator (check-module-form first m fn))] [second (read in-port)]) (unless (eof-object? second) (raise-syntax-error - 'load/annotate + 'load-module/annotate (format "expected only a `module' declaration for `~s', but found an extra expression" m) second)) (eval module-ized-exp)))))) @@ -76,7 +85,7 @@ [else p])]) (port-count-lines! p) (let loop () - (when (with-handlers ([not-break-exn? (lambda (x) #f)]) + (when (with-handlers ([exn:fail? (lambda (x) #f)]) (regexp-match-peek "^#!" p)) (let lloop ([prev #f]) (let ([c (read-char-or-special p)]) @@ -97,4 +106,4 @@ (lambda (fn m stx) stx))) ;(test #t) ; slow ;(test #f) ; fast - ) \ No newline at end of file +) \ No newline at end of file diff --git a/collects/mztake/private/marks.ss b/collects/mztake/private/marks.ss index efa6a37fea..946102c558 100644 --- a/collects/mztake/private/marks.ss +++ b/collects/mztake/private/marks.ss @@ -1,180 +1,186 @@ -(module marks mzscheme - - (require (lib "list.ss") - (lib "contract.ss") - (lib "my-macros.ss" "stepper" "private") - (lib "shared.ss" "stepper" "private")) - - (define-struct full-mark-struct (source label bindings values)) - - ; CONTRACTS - (define mark? (-> ; no args - full-mark-struct?)) - (define mark-list? (listof procedure?)) - - (provide/contract - ;[make-debug-info (-> any? binding-set? varref-set? any? boolean? syntax?)] ; (location tail-bound free label lifting? -> mark-stx) - [expose-mark (-> mark? (list/p any? symbol? (listof (list/p identifier? any?))))] - [make-top-level-mark (syntax? . -> . syntax?)] - [lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any?))] - [lookup-first-binding ((identifier? . -> . boolean?) mark-list? ( -> any) . -> . any?)] - [lookup-binding (mark-list? identifier? . -> . any)]) - - (provide - make-debug-info - wcm-wrap - skipto-mark? - skipto-mark - strip-skiptos - mark-list? - mark-source - mark-bindings - mark-label - mark-binding-value - mark-binding-binding - display-mark - all-bindings - #;lookup-binding-list - debug-key - extract-mark-list - (struct normal-breakpoint-info (mark-list kind)) - (struct error-breakpoint-info (message)) - (struct breakpoint-halt ()) - (struct expression-finished (returned-value-list))) - - ; BREAKPOINT STRUCTURES - - (define-struct normal-breakpoint-info (mark-list kind)) - (define-struct error-breakpoint-info (message)) - (define-struct breakpoint-halt ()) - (define-struct expression-finished (returned-value-list)) - - (define-struct skipto-mark-struct ()) - (define skipto-mark? skipto-mark-struct?) - (define skipto-mark (make-skipto-mark-struct)) - (define (strip-skiptos mark-list) - (filter (lx (not (skipto-mark? _))) mark-list)) - - - ; debug-key: this key will be used as a key for the continuation marks. - (define-struct debug-key-struct ()) - (define debug-key (make-debug-key-struct)) - - (define (extract-mark-list mark-set) - (strip-skiptos (continuation-mark-set->list mark-set debug-key))) - - - ; the 'varargs' creator is used to avoid an extra cons cell in every mark: - (define (make-make-full-mark-varargs source label bindings) - (lambda values - (make-full-mark-struct source label bindings values))) - - ; see module top for type - (define (make-full-mark location label bindings) - (datum->syntax-object #'here `(lambda () (,(make-make-full-mark-varargs location label bindings) - ,@(map make-mark-binding-stx bindings))))) - - (define (mark-source mark) - (full-mark-struct-source (mark))) - - ; : identifier -> identifier - (define (make-mark-binding-stx id) - #`(lambda () #,(syntax-property id 'stepper-dont-check-for-function #t))) - - (define (mark-bindings mark) - (map list - (full-mark-struct-bindings (mark)) - (full-mark-struct-values (mark)))) - - (define (mark-label mark) - (full-mark-struct-label (mark))) - - (define (mark-binding-value mark-binding) - ((cadr mark-binding))) - - (define (mark-binding-binding mark-binding) - (car mark-binding)) - - (define (expose-mark mark) - (let ([source (mark-source mark)] - [label (mark-label mark)] - [bindings (mark-bindings mark)]) - (list source - label - (map (lambda (binding) - (list (mark-binding-binding binding) - (mark-binding-value binding))) - bindings)))) - - (define (display-mark mark) - (apply - string-append - (format "source: ~a~n" (syntax-object->datum (mark-source mark))) - (format "label: ~a~n" (mark-label mark)) - (format "bindings:~n") - (map (lambda (binding) - (format " ~a : ~a~n" (syntax-e (mark-binding-binding binding)) - (mark-binding-value binding))) - (mark-bindings mark)))) - - - ; possible optimization: rig the mark-maker to guarantee statically that a - ; variable can occur at most once in a mark. - - (define (binding-matches matcher mark) - (filter (lambda (binding-pair) (matcher (mark-binding-binding binding-pair))) (mark-bindings mark))) - - (define (lookup-all-bindings matcher mark-list) - (apply append (map (lambda (m) (binding-matches matcher m)) mark-list))) - - (define (lookup-first-binding matcher mark-list fail-thunk) - (let ([all-bindings (lookup-all-bindings matcher mark-list)]) - (if (null? all-bindings) - (fail-thunk) - (car all-bindings)))) - - (define (lookup-binding mark-list id) - (mark-binding-value - (lookup-first-binding (lambda (id2) (module-identifier=? id id2)) - mark-list - (lambda () - (error 'lookup-binding "variable not found in environment: ~a~n" (if (syntax? id) - (syntax-object->datum id) - id)))))) - - (define (all-bindings mark) - (map mark-binding-binding (mark-bindings mark))) - - (define (wcm-wrap debug-info expr) - #`(with-continuation-mark #,debug-key #,debug-info #,expr)) - - - ; DEBUG-INFO STRUCTURES - - ;;;;;;;;;; - ;; - ;; make-debug-info builds the thunk which will be the mark at runtime. It contains - ;; a source expression and a set of binding/value pairs. - ;; (syntax-object BINDING-SET VARREF-SET any boolean) -> debug-info) - ;; - ;;;;;;;;;; - - (define (make-debug-info source tail-bound free-vars label lifting?) - (let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)]) - (if lifting? - (let*-2vals ([let-bindings (filter (lambda (var) - (case (syntax-property var 'stepper-binding-type) - ((let-bound macro-bound) #t) - ((lambda-bound stepper-temp non-lexical) #f) - (else (error 'make-debug-info - "varref ~a's binding-type info was not recognized: ~a" - (syntax-e var) - (syntax-property var 'stepper-binding-type))))) - kept-vars)] - [lifter-syms (map get-lifted-var let-bindings)]) - (make-full-mark source label (append kept-vars lifter-syms))) - (make-full-mark source label kept-vars)))) - - - (define (make-top-level-mark source-expr) - (make-full-mark source-expr 'top-level null))) +(module marks mzscheme + + (require (lib "list.ss") + (lib "contract.ss") + (lib "my-macros.ss" "stepper" "private") + (lib "shared.ss" "stepper" "private")) + + (define-struct full-mark-struct (source label bindings values)) + + ; CONTRACTS + (define mark? (-> ; no args + full-mark-struct?)) + (define mark-list? (listof procedure?)) + + (provide/contract + ;[make-debug-info (-> any? binding-set? varref-set? any? boolean? syntax?)] ; (location tail-bound free label lifting? -> mark-stx) + [expose-mark (-> mark? (list/c any/c symbol? (listof (list/c identifier? any/c))))] + [make-top-level-mark (syntax? . -> . syntax?)] + [lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any/c))] + [lookup-first-binding ((identifier? . -> . boolean?) mark-list? ( -> any) . -> . any)] + [lookup-binding (mark-list? identifier? . -> . any)]) + + (provide + make-debug-info + wcm-wrap + skipto-mark? + skipto-mark + strip-skiptos + mark-list? + mark-source + mark-bindings + mark-label + mark-binding-value + mark-binding-binding + mark-binding-set! + display-mark + all-bindings + #;lookup-binding-list + debug-key + extract-mark-list + (struct normal-breakpoint-info (mark-list kind)) + (struct error-breakpoint-info (message)) + (struct breakpoint-halt ()) + (struct expression-finished (returned-value-list))) + + ; BREAKPOINT STRUCTURES + + (define-struct normal-breakpoint-info (mark-list kind)) + (define-struct error-breakpoint-info (message)) + (define-struct breakpoint-halt ()) + (define-struct expression-finished (returned-value-list)) + + (define-struct skipto-mark-struct ()) + (define skipto-mark? skipto-mark-struct?) + (define skipto-mark (make-skipto-mark-struct)) + (define (strip-skiptos mark-list) + (filter (lx (not (skipto-mark? _))) mark-list)) + + + ; debug-key: this key will be used as a key for the continuation marks. + (define-struct debug-key-struct ()) + (define debug-key (make-debug-key-struct)) + + (define (extract-mark-list mark-set) + (strip-skiptos (continuation-mark-set->list mark-set debug-key))) + + + ; the 'varargs' creator is used to avoid an extra cons cell in every mark: + (define (make-make-full-mark-varargs source label bindings) + (lambda values + (make-full-mark-struct source label bindings values))) + + ; see module top for type + (define (make-full-mark location label bindings) + (datum->syntax-object #'here `(lambda () (,(make-make-full-mark-varargs location label bindings) + ,@(map make-mark-binding-stx bindings))))) + + (define (mark-source mark) + (full-mark-struct-source (mark))) + + ; : identifier -> identifier + (define (make-mark-binding-stx id) + #`(case-lambda + [() #,(syntax-property id 'stepper-dont-check-for-function #t)] + [(v) (set! #,(syntax-property id 'stepper-dont-check-for-function #t) v)])) + + (define (mark-bindings mark) + (map list + (full-mark-struct-bindings (mark)) + (full-mark-struct-values (mark)))) + + (define (mark-label mark) + (full-mark-struct-label (mark))) + + (define (mark-binding-value mark-binding) + ((cadr mark-binding))) + + (define (mark-binding-binding mark-binding) + (car mark-binding)) + + (define (mark-binding-set! mark-binding v) + ((cadr mark-binding) v)) + + (define (expose-mark mark) + (let ([source (mark-source mark)] + [label (mark-label mark)] + [bindings (mark-bindings mark)]) + (list source + label + (map (lambda (binding) + (list (mark-binding-binding binding) + (mark-binding-value binding))) + bindings)))) + + (define (display-mark mark) + (apply + string-append + (format "source: ~a~n" (syntax-object->datum (mark-source mark))) + (format "label: ~a~n" (mark-label mark)) + (format "bindings:~n") + (map (lambda (binding) + (format " ~a : ~a~n" (syntax-e (mark-binding-binding binding)) + (mark-binding-value binding))) + (mark-bindings mark)))) + + + ; possible optimization: rig the mark-maker to guarantee statically that a + ; variable can occur at most once in a mark. + + (define (binding-matches matcher mark) + (filter (lambda (binding-pair) (matcher (mark-binding-binding binding-pair))) (mark-bindings mark))) + + (define (lookup-all-bindings matcher mark-list) + (apply append (map (lambda (m) (binding-matches matcher m)) mark-list))) + + (define (lookup-first-binding matcher mark-list fail-thunk) + (let ([all-bindings (lookup-all-bindings matcher mark-list)]) + (if (null? all-bindings) + (fail-thunk) + (car all-bindings)))) + + (define (lookup-binding mark-list id) + (mark-binding-value + (lookup-first-binding (lambda (id2) (module-identifier=? id id2)) + mark-list + (lambda () + (error 'lookup-binding "variable not found in environment: ~a~n" (if (syntax? id) + (syntax-object->datum id) + id)))))) + + (define (all-bindings mark) + (map mark-binding-binding (mark-bindings mark))) + + (define (wcm-wrap debug-info expr) + (quasisyntax/loc expr (with-continuation-mark #,debug-key #,debug-info #,expr))) + + + ; DEBUG-INFO STRUCTURES + + ;;;;;;;;;; + ;; + ;; make-debug-info builds the thunk which will be the mark at runtime. It contains + ;; a source expression and a set of binding/value pairs. + ;; (syntax-object BINDING-SET VARREF-SET any boolean) -> debug-info) + ;; + ;;;;;;;;;; + + (define (make-debug-info source tail-bound free-vars label lifting?) + (let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)]) + (if lifting? + (let*-2vals ([let-bindings (filter (lambda (var) + (case (syntax-property var 'stepper-binding-type) + ((let-bound macro-bound) #t) + ((lambda-bound stepper-temp non-lexical) #f) + (else (error 'make-debug-info + "varref ~a's binding-type info was not recognized: ~a" + (syntax-e var) + (syntax-property var 'stepper-binding-type))))) + kept-vars)] + [lifter-syms (map get-lifted-var let-bindings)]) + (make-full-mark source label (append kept-vars lifter-syms))) + (make-full-mark source label kept-vars)))) + + + (define (make-top-level-mark source-expr) + (make-full-mark source-expr 'top-level null))) diff --git a/collects/mztake/private/useful-code.ss b/collects/mztake/private/useful-code.ss index 2a2f4ba1d3..a4e40cabbb 100644 --- a/collects/mztake/private/useful-code.ss +++ b/collects/mztake/private/useful-code.ss @@ -50,7 +50,7 @@ +inf.0)))) ; Matches a sequence of items in a list to event pings - (define/contract sequence-match? ((listof any?) . -> . any) + (define/contract sequence-match? ((listof any/c) . -> . any) (lambda (seq evs) (equal? seq (history-b (length seq) evs))))