suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

while working with greg. skipper is integrated, mztake is in the middle of the load-annotator refactoring

Browse Source 
svn: r180
This commit is contained in:
Guillaume Marceau 2005-02-16 06:27:40 +00:00
parent b76f0e77be
commit be27134ac4
21 changed files with 1435 additions and 728 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

299
collects/mztake/annotator.ss Normal file
View File

@ -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)))
)

730
collects/mztake/debug-tool.ss Normal file
View File

@ -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))))

232
collects/mztake/debugger-annotate.ss
View File

@ -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)))))

80
collects/mztake/demos/sine/sine-mztake-uncommented.ss
View File

@ -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)

0
collects/mztake/emblem-ohno.png → collects/mztake/icons/emblem-ohno.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.6 KiB

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
collects/mztake/icons/icon-big.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.2 KiB

BIN
collects/mztake/icons/icon-small.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 752 B

BIN
collects/mztake/icons/icon.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 648 B

BIN
collects/mztake/icons/icon2.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 415 B

BIN
collects/mztake/icons/no.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.4 KiB

BIN
collects/mztake/icons/pause.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 261 B

BIN
collects/mztake/icons/resume.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 439 B

BIN
collects/mztake/icons/step.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 417 B

BIN
collects/mztake/icons/stock_macro-check-brackets-16.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 372 B

BIN
collects/mztake/icons/stock_macro-check-brackets.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 930 B

8
collects/mztake/info.ss
View File

@ -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")))
)

29
collects/mztake/debugger-tool.ss → collects/mztake/mztake-lang.ss
View File

@ -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%

366
collects/mztake/mztake.ss
View File

@ -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

51
collects/mztake/private/load-annotator.ss
View File

@ -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
)
)

366
collects/mztake/private/marks.ss
View File

@ -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)))

2
collects/mztake/private/useful-code.ss
View File

@ -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))))