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

annotator now takes an optional parameter to restrict (by source)

Browse Source 
which syntax objects will have breakpoint annotations installed; this
is the "right way" (for now, with a single file), so i've removed a
bunch of the old hacky restrictions that didn't really work

top-level begins are no longer handled specially by the tool---just
passed on to the annotator, which should do the right thing

svn: r4206
This commit is contained in:
Greg Cooper 2006-08-31 22:24:35 +00:00
parent 3353d9a58d
commit 489e9c6ed9
2 changed files with 345 additions and 362 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/mztake/annotator.ss
View File

@ -1,13 +1,9 @@
(module annotator mzscheme
(require (prefix kernel: (lib "kerncase.ss" "syntax"))
(lib "class.ss")
(lib "list.ss")
(lib "marks.ss" "mztake")
(lib "mred.ss" "mred")
(lib "pretty.ss")
(lib "base-gm.ss" "frtime")
(lib "load-sandbox.ss" "mztake")
(lib "etc.ss")
(prefix srfi: (lib "search.ss" "srfi" "1"))
)
(provide annotate-stx annotate-for-single-stepping)
@ -58,7 +54,8 @@
;;
;; RECORD-BOUND-ID and RECORD-TOP-LEVEL-ID are simply passed to ANNOTATE-STX.
(define (annotate-for-single-stepping stx break? break-before break-after record-bound-id record-top-level-id )
(define annotate-for-single-stepping
(opt-lambda (stx break? break-before break-after record-bound-id record-top-level-id [source #f])
(annotate-stx
stx
(lambda (debug-info annotated raw is-tail?)
@ -98,7 +95,8 @@
(current-continuation-marks) value-list)
(apply values value-list)))))))
record-bound-id
record-top-level-id ))
record-top-level-id
source)))
; annotate-stx : (syntax?
@ -138,7 +136,8 @@
;;
;; Naturally, when USE-CASE is 'bind, BOUND-STX and BINDING-STX are equal.
;;
(define (annotate-stx stx break-wrap record-bound-id record-top-level-id)
(define annotate-stx
(opt-lambda (stx break-wrap record-bound-id record-top-level-id [source #f])
(define breakpoints (make-hash-table))
@ -209,8 +208,8 @@
(define annotate-break?
(let ([pos (syntax-position expr)]
[src (syntax-source expr)])
(and src
(eq? src (syntax-source stx))
(and (or (not source)
(eq? src source #;(syntax-source stx)))
; (is-a? src object%) ; FIX THIS
pos
(hash-table-get breakpoints pos (lambda () #t))
@ -391,7 +390,7 @@
is-tail?)
annotated))
(values (top-level-annotate stx) (hash-table-map breakpoints (lambda (k v) k))))
(values (top-level-annotate stx) (hash-table-map breakpoints (lambda (k v) k)))))
#;
(define (tests)

24
collects/mztake/debug-tool.ss
View File

@ -451,32 +451,15 @@
;; 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)
(if (compiled-expression? (if (syntax? orig-exp)
(syntax-e orig-exp)
orig-exp))
(not (robust-syntax-source orig-exp))
(not (eq? (robust-syntax-source orig-exp)
(send (get-tab) get-defs))))
(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
@ -501,7 +484,8 @@
(lambda (mod var val)
(send (get-tab) add-top-level-binding var val)
#;
(printf "top-level binding: ~a ~a ~a~n" mod var val)))])
(printf "top-level binding: ~a ~a ~a~n" mod var val))
(send (get-tab) get-defs))])
(hash-table-for-each
breakpoints
(lambda (pos status)
@ -516,7 +500,7 @@
breakpoints posn
(hash-table-get breakpoints posn (lambda () #f)))) break-posns)
;(display-results (list orig-exp))
annotated))))]))))))
annotated)))))))))
(define/override (reset-console)
(super reset-console)