diff --git a/collects/mztake/annotator.ss b/collects/mztake/annotator.ss index f823857411..eeecafcfe3 100644 --- a/collects/mztake/annotator.ss +++ b/collects/mztake/annotator.ss @@ -5,6 +5,7 @@ (lib "list.ss") (lib "marks.ss" "mztake") (lib "mred.ss" "mred") + (lib "pretty.ss") (lib "load-sandbox.ss" "mztake") (prefix srfi: (lib "search.ss" "srfi" "1")) ) @@ -170,14 +171,16 @@ (kernel:kernel-syntax-case stx #f [(define-values (var ...) expr) + (begin (for-each (lambda (v) (record-bound-id 'bind v v)) (syntax->list #'(var ...))) (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) #`(begin (#,record-top-level-id '#,module-name 'var var) ...) #'(void)) - (void)))) + (void))) + ) ] [(define-syntaxes (var ...) expr) stx] @@ -361,7 +364,7 @@ (syntax->list #'exprs))]) (if is-tail? (quasisyntax/loc expr #,subexprs) - (wcm-wrap (make-debug-info expr bound-vars bound-vars 'normal #f (previous-bindings bound-vars)) + (wcm-wrap (make-debug-info module-name expr bound-vars bound-vars 'normal #f (previous-bindings bound-vars)) (quasisyntax/loc expr #,subexprs))))] [(#%datum . _) expr] @@ -376,7 +379,7 @@ (if annotate-break? (break-wrap - (make-debug-info expr bound-vars bound-vars 'at-break #f (previous-bindings bound-vars)) + (make-debug-info module-name expr bound-vars bound-vars 'at-break #f (previous-bindings bound-vars)) annotated expr is-tail?) diff --git a/collects/mztake/engine.ss b/collects/mztake/engine.ss index 5501219a5e..6c7d3e1644 100644 --- a/collects/mztake/engine.ss +++ b/collects/mztake/engine.ss @@ -245,7 +245,6 @@ [bindings (hash-get modules module-name (lambda () (make-hash)))]) (unless (hash-mem? modules module-name) (hash-put! modules module-name bindings)) - (printf "record-top-level-id ~a ~a ~a ~n" module-name var-name val) (hash-put! bindings var-name val))) (define (launch-sandbox process) diff --git a/collects/mztake/marks.ss b/collects/mztake/marks.ss index 4355843ec1..57c475985b 100644 --- a/collects/mztake/marks.ss +++ b/collects/mztake/marks.ss @@ -5,7 +5,7 @@ (lib "my-macros.ss" "stepper" "private") (lib "shared.ss" "stepper" "private")) - (define-struct full-mark-struct (source label bindings values)) + (define-struct full-mark-struct (module-name source label bindings values)) ; CONTRACTS (define mark? (-> ; no args @@ -28,6 +28,7 @@ skipto-mark strip-skiptos mark-list? + mark-module-name mark-source mark-bindings mark-label @@ -67,15 +68,18 @@ ; the 'varargs' creator is used to avoid an extra cons cell in every mark: - (define (make-make-full-mark-varargs source label bindings) + (define (make-make-full-mark-varargs module-name source label bindings) (lambda (values) - (make-full-mark-struct source label bindings values))) + (make-full-mark-struct module-name source label bindings values))) ; see module top for type - (define (make-full-mark location label bindings assembled-info-stx) - (datum->syntax-object #'here `(lambda () (,(make-make-full-mark-varargs location label bindings) + (define (make-full-mark module-name source label bindings assembled-info-stx) + (datum->syntax-object #'here `(lambda () (,(make-make-full-mark-varargs module-name source label bindings) ,assembled-info-stx)))) + (define (mark-module-name mark) + (full-mark-struct-module-name (mark))) + (define (mark-source mark) (full-mark-struct-source (mark))) @@ -166,8 +170,8 @@ ;; ;;;;;;;;;; - (define (make-debug-info source tail-bound free-vars label lifting? assembled-info-stx) - (make-full-mark source label free-vars assembled-info-stx)) + (define (make-debug-info module-name source tail-bound free-vars label lifting? assembled-info-stx) + (make-full-mark module-name source label free-vars assembled-info-stx)) (define (assemble-debug-info tail-bound free-vars label lifting?) (map make-mark-binding-stx free-vars)) diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss index a8f720d6db..f48fcff90d 100644 --- a/collects/mztake/mztake.ss +++ b/collects/mztake/mztake.ss @@ -6,6 +6,7 @@ (rename (lib "frtime.ss" "frtime") frp:value-nowable? value-nowable?) (rename (lib "frtime.ss" "frtime") frp:behaviorof behaviorof) "mztake-structs.ss" + "more-useful-code.ss" (lib "etc.ss") (lib "list.ss") "marks.ss" @@ -15,6 +16,7 @@ (print-struct true) (provide (rename loc loc$) + debug-process-running-e loc/r trace bind @@ -108,18 +110,30 @@ (trace* (current-process) loc proc)] [(_ loc body ...) (trace* (current-process) loc (lambda () body ...))])) - + + (define (mztake-top* name thunk ) + (with-handlers + ([exn:fail? + (lambda (exn) + (with-handlers + ([exn:fail? (lambda (exn2) (raise exn))]) + (bind* (current-process) name)))]) + (thunk))) + (define-syntax (mztake-top stx) (syntax-case stx () [(_ . name) - (begin - #'(with-handlers - ([exn:fail? - (lambda (exn) - (with-handlers - ([exn:fail? (lambda (exn2) (raise exn))]) - (bind* (current-process) 'name)))]) - (#%top . name)))])) + #'(mztake-top* 'name (lambda () (#%top . name)))])) + + (define (lookup-in-top-level p name) + (let/ec success + (for-each + (lambda (m) + (let/ec fail + (let ([fail* (lambda () (fail false))]) + (success (hash-get (hash-get (debug-process-top-level p) m fail*) name fail*))))) + (map mark-module-name (debug-process-marks p))) + (error 'bind "variable `~a' not found in target at the current location" name))) (define (bind* p name) (unless (debug-process-marks p) @@ -128,10 +142,9 @@ (let ([bs (lookup-all-bindings (lambda (id) (eq? (syntax-e id) name)) (debug-process-marks p))]) - (when (empty? bs) - (error 'bind "variable `~a' not found in target at the current location" name)) - - (mark-binding-value (first bs)))) + (if (empty? bs) + (lookup-in-top-level p name) + (mark-binding-value (first bs))))) (define-syntax bind (syntax-rules ()