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

fixed/changed interface for accumulating top-level ids from annotator

Browse Source 
debugger now supports mousing over top-level ids (but no set! yet)

svn: r3458
This commit is contained in:
Greg Cooper 2006-06-23 22:12:25 +00:00
parent 1df0924b9c
commit 00513d7778
2 changed files with 45 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/mztake/annotator.ss
View File

@ -177,12 +177,15 @@
stx #f stx #f
[(define-values (var ...) expr) [(define-values (var ...) expr)
(begin (for-each (lambda (v) (record-bound-id 'bind v v)) (begin
(for-each (lambda (v) (record-bound-id 'bind v v))
(syntax->list #'(var ...))) (syntax->list #'(var ...)))
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (define-values (var ...) #,(annotate #`expr empty #t module-name)) (begin (define-values (var ...) #,(annotate #`expr empty #t module-name))
#,(if (syntax-source #'stx) #,(if (syntax-source stx)
#`(begin (#,record-top-level-id '#,module-name 'var var) ...) #`(begin (#,record-top-level-id '#,module-name #'var (case-lambda
[() var]
[(v) (set! var v)])) ...)
#'(void)) #'(void))
(void))) (void)))
) )
@ -305,9 +308,10 @@
[var-stx (identifier? (syntax var-stx)) [var-stx (identifier? (syntax var-stx))
(let ([binder (and (syntax-original? expr) (let ([binder (and (syntax-original? expr)
(srfi:member expr bound-vars module-identifier=?))]) (srfi:member expr bound-vars module-identifier=?))])
(when binder (if binder
(let ([f (first binder)]) (let ([f (first binder)])
(record-bound-id 'ref expr f))) (record-bound-id 'ref expr f))
(record-bound-id 'top-level expr expr))
expr)] expr)]
[(lambda . clause) [(lambda . clause)

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

@ -233,6 +233,8 @@
frames pos-vec id)]) frames pos-vec id)])
(send (get-tab) (send (get-tab)
set-mouse-over-msg set-mouse-over-msg
; consider rewriting so we can look up top-level vars even
; when not suspended
(cond (cond
[(and id frames [(and id frames
(let/ec k (let/ec k
@ -240,16 +242,13 @@
[binding (lookup-first-binding [binding (lookup-first-binding
(lambda (id2) (module-identifier=? id id2)) (lambda (id2) (module-identifier=? id id2))
frames (lambda () frames (lambda ()
(k #f ;(printf "failed to find var ~a on stack~n" id)
#; (k (clean-status
(format "~a = ~a" id-sym (format "~a = ~a" id-sym
(namespace-variable-value (render
id-sym ((send (get-tab) lookup-top-level-var
#f id
(lambda () (k #f)) (lambda () (k #f))))))))))]
(send
(send (get-tab) get-ints)
get-user-namespace))))))]
[val (mark-binding-value [val (mark-binding-value
binding)]) binding)])
(clean-status (format "~a = ~a" id-sym (render val))))))] (clean-status (format "~a = ~a" id-sym (render val))))))]
@ -489,7 +488,10 @@
(when (< i (syntax-span bound)) (when (< i (syntax-span bound))
(vector-set! pos-vec (+ i (syntax-position bound)) binding) (vector-set! pos-vec (+ i (syntax-position bound)) binding)
(loop (add1 i)))))) (loop (add1 i))))))
void)]) (lambda (mod var val)
(send (get-tab) add-top-level-binding var val)
#;
(printf "top-level binding: ~a ~a ~a~n" mod var val)))])
(hash-table-for-each (hash-table-for-each
breakpoints breakpoints
(lambda (pos status) (lambda (pos status)
@ -579,6 +581,21 @@
(define break-status #f) (define break-status #f)
(define/public (get-break-status) break-status) (define/public (get-break-status) break-status)
(define/public (set-break-status stat) (set! break-status stat)) (define/public (set-break-status stat) (set! break-status stat))
(define top-level-bindings empty)
(define/public (add-top-level-binding var val)
(set! top-level-bindings (cons (cons var val) top-level-bindings)))
(define/public (lookup-top-level-var var failure-thunk)
#;
(printf "looking for ~a in ~a~n" var top-level-bindings)
(let loop ([bindings top-level-bindings])
(cond
[(empty? bindings) (failure-thunk)]
[(let ([res (or (bound-identifier=? var (caar bindings))
(free-identifier=? var (caar bindings)))])
#;
(printf "~a = ~a -> ~a~n" var (caar bindings) res)
res) (cdar bindings)]
[(loop (rest bindings))])))
(define control-panel #f) (define control-panel #f)
(define/public (resume) (define/public (resume)
(let ([v break-status]) (let ([v break-status])
@ -691,6 +708,7 @@
;(set! breakpoints (make-hash-table)) ;(set! breakpoints (make-hash-table))
(hash-table-put! breakpoints -1 #t) (hash-table-put! breakpoints -1 #t)
(set! pos-vec (make-vector (add1 (send (get-defs) last-position)) #f)) (set! pos-vec (make-vector (add1 (send (get-defs) last-position)) #f))
(set! top-level-bindings empty)
(set! resume-ch (make-channel)) (set! resume-ch (make-channel))
(set! want-suspend-on-break? #f) (set! want-suspend-on-break? #f)
(set! stack-frames #f) (set! stack-frames #f)