diff --git a/collects/mztake/debugger-annotate.ss b/collects/mztake/debugger-annotate.ss index c49537faa6..0fa9b0aa6d 100644 --- a/collects/mztake/debugger-annotate.ss +++ b/collects/mztake/debugger-annotate.ss @@ -1,7 +1,7 @@ (module debugger-annotate mzscheme (require (prefix kernel: (lib "kerncase.ss" "syntax")) - (lib "marks.ss" "stepper" "private")) + (lib "marks.ss" "mztake" "private")) ;; (define count 0) diff --git a/collects/mztake/debugger-model.ss b/collects/mztake/debugger-model.ss index ad3bd66832..aa2339ad3a 100644 --- a/collects/mztake/debugger-model.ss +++ b/collects/mztake/debugger-model.ss @@ -1,11 +1,11 @@ (module debugger-model mzscheme (require (lib "unit.ss") (lib "mred.ss" "mred") - (lib "marks.ss" "stepper" "private") + (lib "marks.ss" "mztake" "private") "debugger-annotate.ss" "mztake-structs.ss" - "private/load-annotator.ss" - "private/more-useful-code.ss") + (lib "load-annotator.ss" "mztake" "private") + (lib "more-useful-code.ss" "mztake" "private")) (provide debugger-model@) diff --git a/collects/mztake/demos/dijkstra/dijkstra-test.ss b/collects/mztake/demos/dijkstra/dijkstra-test.ss index ba3261a07d..446e3e725d 100644 --- a/collects/mztake/demos/dijkstra/dijkstra-test.ss +++ b/collects/mztake/demos/dijkstra/dijkstra-test.ss @@ -2,7 +2,7 @@ (require "dijkstra-solver.ss" (lib "match.ss")) -(mztake-process p +(define-mztake-process p ("dijkstra.ss") ("heap.ss" [inserts 49 6 bind 'item] diff --git a/collects/mztake/demos/highway/highway-test.ss b/collects/mztake/demos/highway/highway-test.ss index aacbb8869f..36eff02198 100644 --- a/collects/mztake/demos/highway/highway-test.ss +++ b/collects/mztake/demos/highway/highway-test.ss @@ -3,7 +3,7 @@ (require (lib "animation.ss" "frtime")) ;; needed for display-shapes -(mztake-process radar-program ("highway.ss" [values-of-speed 3 4 bind 'speed])) +(define-mztake-process radar-program ("highway.ss" [values-of-speed 3 4 bind 'speed])) #| * Create a process to debug highway.ss * Add a tracepoint at line 3, column 4; in the program, diff --git a/collects/mztake/demos/misc/exception-test.ss b/collects/mztake/demos/misc/exception-test.ss index f155f5bfcb..e0b077b8d2 100644 --- a/collects/mztake/demos/misc/exception-test.ss +++ b/collects/mztake/demos/misc/exception-test.ss @@ -6,7 +6,7 @@ run the program and catch the exception it throws. |# -(mztake-process p ("exception.ss")) +(define-mztake-process p ("exception.ss")) (printf-b "exception.ss exited? ~a" (process:exited? p)) ;; Prints out a behavior that tells you whether the debug-process is still running... diff --git a/collects/mztake/demos/misc/first-class-test.ss b/collects/mztake/demos/misc/first-class-test.ss index 4c04422a95..eb641bb32f 100644 --- a/collects/mztake/demos/misc/first-class-test.ss +++ b/collects/mztake/demos/misc/first-class-test.ss @@ -9,7 +9,7 @@ and idea of why they recieve different values from the same "x". |# -(mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x] +(define-mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x] [x-in-let 4 25 bind 'x] [x-after-let 5 11 bind 'x])) diff --git a/collects/mztake/demos/montecarlo/montecarlo-test.ss b/collects/mztake/demos/montecarlo/montecarlo-test.ss index 8cc90c4fa4..1b5a6e0d2b 100644 --- a/collects/mztake/demos/montecarlo/montecarlo-test.ss +++ b/collects/mztake/demos/montecarlo/montecarlo-test.ss @@ -20,7 +20,7 @@ See the doc for more information on this kind of drawing. |# -(mztake-process p ("montecarlo.ss" [x/y/pi-trace 13 18 bind '(x y pi)])) +(define-mztake-process p ("montecarlo.ss" [x/y/pi-trace 13 18 bind '(x y pi)])) #| * Create a process to debug montecarlo.ss * Add a tracepoint at line 13, column 18; in the program, diff --git a/collects/mztake/demos/random/random-Xs-test.ss b/collects/mztake/demos/random/random-Xs-test.ss index 19218ac16c..72e8912157 100644 --- a/collects/mztake/demos/random/random-Xs-test.ss +++ b/collects/mztake/demos/random/random-Xs-test.ss @@ -29,7 +29,7 @@ See the doc for more information on this kind of drawing. |# -(mztake-process p ("random-Xs.ss" [x-trace 4 6 bind 'x])) +(define-mztake-process p ("random-Xs.ss" [x-trace 4 6 bind 'x])) #| * Create a process to debug random-xs.ss * Add a tracepoint at line 4, column 6; in the program, diff --git a/collects/mztake/demos/sine/sine-test.ss b/collects/mztake/demos/sine/sine-test.ss index 0a4d84d22a..f73e7bc7fd 100644 --- a/collects/mztake/demos/sine/sine-test.ss +++ b/collects/mztake/demos/sine/sine-test.ss @@ -7,7 +7,7 @@ (require (lib "animation.ss" "frtime")) ;; needed for display-shapes -(mztake-process p ("sine.ss" [sin/x-trace 5 8 bind '(sin-x x)])) +(define-mztake-process p ("sine.ss" [sin/x-trace 5 8 bind '(sin-x x)])) #| * Create a process to debug sine.ss * Add a tracepoint at line 5, column 8; in the program, diff --git a/collects/mztake/doc.txt b/collects/mztake/doc.txt index b046894836..4eef70a85f 100644 --- a/collects/mztake/doc.txt +++ b/collects/mztake/doc.txt @@ -23,7 +23,7 @@ using callbacks). Consider a MzTake script to monitor the behavior of the program "highway.ss", in the demos directory of the MzTake collection: - (debug-mztake-process + (define-mztake-process radar-program ("highway.ss" [values-of-speed 3 4 bind 'speed])) (printf-b "current speed: ~a" (hold values-of-speed)) @@ -112,6 +112,11 @@ MzTake is a DrScheme tool distributed as a self-installing http://planet.plt-scheme.org/ +You need to have the latest version of FrTime installed +for MzTake to work correctly (it may function, though +unpredictably, in older versions). Please use FrTime from +DrScheme v208 and up, or the latest CVS revision. + ============================================================ @@ -205,11 +210,11 @@ The model of the debugger is as follows: that you run it in DrScheme in the "module..." language), assuming there will be side-effects that start the debugging. - The rest of the files traced in a mztake-process are typically + The rest of the files traced in a MZTAKE-PROCESS are typically modules used *by* the main-module, allowing you to see what is going on deeper than the main module. For example: - (mztake-process p1 + (define-mztake-process p1 ("my-stack-tests.ss") ((lib "my-stack.ss" "my-stack") [s-push-p1 3 29 bind 'insert-value] [s-pop-p1 10 16 bind 'return-value])) @@ -221,7 +226,7 @@ The model of the debugger is as follows: * The same file can be traced differently in different processes, even with different main clients using them: - (mztake-process p2 + (define-mztake-process p2 ("more-my-stack-tests.ss") ((lib "my-stack.ss" "my-stack") [s-clear-p2 22 8 ENTRY])) @@ -257,7 +262,7 @@ ENTRYs are event streams that get a "#t" event every time the target program reaches the trace point. Binds are event streams that ping the value of one or more variables when the trace point is reached. -> (mztake-process process-name +> (define-mztake-process process-name [target-filename trace-clause ...] ...) Where trace-clause is one of the following: @@ -278,15 +283,15 @@ ping the value of one or more variables when the trace point is reached. syntax for modules: * Absolute path: - (mztake-process p [(file "/home/me/test.ss") [brk 10 7 ENTRY]]) + (define-mztake-process p [(file "/home/me/test.ss") [brk 10 7 ENTRY]]) * Relative path: - (mztake-process p ["../test.ss" [brk 10 7 ENTRY]]) + (define-mztake-process p ["../test.ss" [brk 10 7 ENTRY]]) * Library path: - (mztake-process p [(lib "test.ss" "collect-dir") [brk 10 7 ENTRY]]) + (define-mztake-process p [(lib "test.ss" "collect-dir") [brk 10 7 ENTRY]]) - For each trace-clause in the call to mztake-process, + For each trace-clause in the call to DEFINE-MZTAKE-PROCESS, the trace-name is a variable name bound at the top-level, whose value is a FrTime event stream. Each time the execution of the target @@ -337,7 +342,7 @@ and can be used in the Interactions window. > (start/resume process-name) - Start the execution and monitoring of the mztake-process, + Start the execution and monitoring of the MZTAKE-PROCESS, process-name. If the process given to START/RESUME is already running, and was paused with the function PAUSE (below), START/RESUME resumes its execution. @@ -442,12 +447,12 @@ Known Problems you are putting bind-traces on: ORIGINAL FILE: - (define (my-fun some-struct) ...) + (define (my-fun some-struct) ...) MZTAKE SCRIPT: - (require "original-file.ss") - (mztake-process p ("original-file.ss" [val 10 12 bind 'my-struct])) - (my-fun (hold val)) + (require "original-file.ss") + (define-mztake-process p ("original-file.ss" [val 10 12 bind 'my-struct])) + (my-fun (hold val)) Sometimes this causes unusual errors. These problems usually only show up if you are binding to structs (defined in the same file) and @@ -472,23 +477,10 @@ Known Problems (let ([x (add1 x)]) x) ^ ^^ ^ ^ -* Don't rely completely on MzTake to complain when you change +* Don't rely entirely on MzTake to complain when you change target code and your line/col locations in the script are out of date. It can only raise an error if the locations are invalid. -* Order matters -- if you have more than one kind of trace at - an identical syntax location, the order that trace events get - updated is currently undefined. - - For now, the hack is to add traces as follows: - - First trace: Second trace: - (code ... (more-code ...)) (code ... (more-code ...)) - ^ ^ - Because of how Scheme is evaluated, usually nothing happens on - the same line of between two "open" parentheses as they are - traversed from left to right; this gives you a definite trace order. - * MzTake has not been tested for stability if the target is using multiple threads. This only applies to threaded modules *with* traces on them -- other REQUIRE'd modules will work @@ -514,6 +506,29 @@ Known Problems there will probably be some sort of name-clash and strange error. This will be fixed. +* If you find that sometimes it seems one of the breakpoints you + set in a file REQUIRE'd by the main client module, your problem + may be that the file-specification you used is different in the + script than it is in the main client module (occuring in REQUIREs + that use sub-directories): + + MAIN CLIENT: + (require (lib "my-lib.ss" "mycollect" "private")) + + MZTAKE SCRIPT: + (define-mztake-process p ("main.ss") + ((lib "my-lib.ss" "mycollect/private") [traces...]) + + This seems to be an issue with DrScheme rather than MzTake. + For instance, you get an error if you make a module like this + on Windows: + + (module m mzschem + (require (lib "my-lib.ss" "mycollect" "private")) + (provide (lib "my-lib.ss" "mycollect/private"))) + + This will be looked into, but keep your eyes open for it. + ============================================================ @@ -529,16 +544,40 @@ Tips and Tricks * Then 'x updates and 'y is out-of-date. * Then 'y updates, and both are up-to-date. - But code that draws using a position derived from x and y + But code that draws using a position derived from X and Y will draw twice, in two locations, one for each update, the second one being correct. +* Order matters -- if you have more than one trace at an identical + syntax location (in the same file), the order that trace events + get updated is identical to the order they exist in the script. + For example: + + (define-mztake-process p ("file.ss" [a-bind 5 55 bind 'x] + [some-bind 2 22 bind 'irrelevent] + [a-entry 5 55 entry] + [another-bind 5 55 bind 'y])) + + When that trace gets evaluated, A-BIND will get the new value + of X, and relevant FrTime code will get re-evaluated. *Then* + A-ENTRY will be notified about the trace and a #t will be emitted, + (at this point in time, Y is out-of-date, but X is up-to-date). Lastly, + ANOTHER-BIND will get the new value of Y, and the trace is complete. + + Of course, you will typically want ENTRY as the first trace, + and all other BINDs to be in a list, so that you get two updates, + as explained in the previous tip: + + (define-mztake-process p ("file.ss" [a-entry 5 55 entry] + [x/y-bind 5 55 bind '(x y)] + [some-bind 2 22 bind 'irrelevent])) + * You can trace the *same* file in different ways by using multiple processes on the same file, under different contexts, and compare results. For example, in "demos/misc/first-class-test.ss": - (mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x] + (define-mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x] [x-in-let 4 25 bind 'x] [x-after-let 5 11 bind 'x])) (... code omitted ...) @@ -546,9 +585,9 @@ Tips and Tricks is functionally equivalent to: - (mztake-process p1 ("first-class.ss" [x-before-let 3 29 bind 'x])) - (mztake-process p2 ("first-class.ss" [x-in-let 4 25 bind 'x])) - (mztake-process p3 ("first-class.ss" [x-after-let 5 11 bind 'x])) + (define-mztake-process p1 ("first-class.ss" [x-before-let 3 29 bind 'x])) + (define-mztake-process p2 ("first-class.ss" [x-in-let 4 25 bind 'x])) + (define-mztake-process p3 ("first-class.ss" [x-after-let 5 11 bind 'x])) (... code omitted ...) (start/resume p1) (start/resume p2) (start/resume p3) diff --git a/collects/mztake/mztake-structs.ss b/collects/mztake/mztake-structs.ss index 15707d892b..578687f888 100644 --- a/collects/mztake/mztake-structs.ss +++ b/collects/mztake/mztake-structs.ss @@ -1,6 +1,6 @@ (module mztake-structs mzscheme (require (prefix frp: (lib "frp.ss" "frtime")) - "private/more-useful-code.ss") + (lib "more-useful-code.ss" "mztake" "private")) (provide (all-defined)) @@ -19,7 +19,7 @@ (define-struct trace-struct (evnt-rcvr)) ; frp:event-receiver - (define-struct (break-trace trace-struct) ()) + (define-struct (entry-trace trace-struct) ()) (define-struct (bind-trace trace-struct) (variable-to-bind)) ; symbol @@ -59,9 +59,9 @@ (define (create-bind-trace sym-to-bind) ; ((union (listof symbol?) symbol?) . -> . trace?) (make-bind-trace (frp:event-receiver) sym-to-bind)) - ; Creates a trace that simply pauses the program - (define (create-break-trace) ; (void? . -> . trace?) - (make-break-trace (frp:event-receiver))) + ; Creates a trace that simply alerts that it was hit + (define (create-entry-trace) ; (void? . -> . trace?) + (make-entry-trace (frp:event-receiver))) (define (create-empty-debug-process) (make-debug-process (make-custodian) diff --git a/collects/mztake/mztake-syntax.ss b/collects/mztake/mztake-syntax.ss index 4179280cc8..674a71f434 100644 --- a/collects/mztake/mztake-syntax.ss +++ b/collects/mztake/mztake-syntax.ss @@ -1,7 +1,7 @@ #| (mztake-process p ("sine.ss" [sin/x 5 8 bind '(sin-x x)] - [foo 10 20 bind '(sin-x x)]) - ("sine-extra.ss")) + [foo 10 20 bind '(sin-x x)]) + ("sine-extra.ss")) (define sin/x (hold sin/x)) (define x (+ 200 (second sin/x))) @@ -19,11 +19,11 @@ (module mztake-syntax (lib "frtime-big.ss" "frtime") (require (lib "mztake.ss" "mztake") - (lib "useful-code.ss" "mztake/private")) + (lib "useful-code.ss" "mztake" "private")) - (define-syntax mztake-process - (syntax-rules (mztake-process) - [(mztake-process proc-id (client (trace line col cmd . args) ...) ...) + (define-syntax define-mztake-process + (syntax-rules (define-mztake-process) + [(define-mztake-process proc-id (client (trace line col cmd . args) ...) ...) (begin (define proc-id (create-debug-process)) (begin @@ -33,7 +33,7 @@ (create-trace tmp line col 'cmd . args) ...))) ...))])) - (provide mztake-process - (all-from-except (lib "frtime-big.ss" "frtime") #%module-begin) + (provide define-mztake-process + (all-from (lib "frtime-big.ss" "frtime")) (all-from (lib "mztake.ss" "mztake")) - (all-from (lib "useful-code.ss" "mztake/private")))) \ No newline at end of file + (all-from (lib "useful-code.ss" "mztake" "private")))) diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss index 6a14a513ee..90b90bb2cf 100644 --- a/collects/mztake/mztake.ss +++ b/collects/mztake/mztake.ss @@ -1,4 +1,12 @@ -#| TODO +(module mztake mzscheme + + (define mztake-version "Rev. Wed Aug 5, 2004 - 23:12:00") + + #| TODO + +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") :::::::::LOAD/ANNOTATOR BUGS:::::::::::::: * catch oops exception @@ -38,7 +46,7 @@ SCRIPT-------------------------------------------------------------------------- * 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 break-point is hit? +* 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?) @@ -65,26 +73,25 @@ ERROR-CHECKING/HANDLING--------------------------------------------------------- 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 hit a breakpoint. +* 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 breaks at -- need to know *when* it breaks too -- print something out +* 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) |# - -(module mztake mzscheme + (require (lib "match.ss") (lib "unit.ss") (lib "contract.ss") - (lib "marks.ss" "stepper" "private") + (lib "marks.ss" "mztake" "private") ; TODO local private copy until stepper release (prefix frp: (lib "frp.ss" "frtime")) - "private/useful-code.ss" - "private/more-useful-code.ss" ; mostly for hash- bindings + (lib "useful-code.ss" "mztake" "private") + (lib "more-useful-code.ss" "mztake" "private") ; mostly for hash- bindings "mztake-structs.ss" "debugger-model.ss") @@ -104,14 +111,14 @@ TESTING/CAPABILITIES------------------------------------------------------------ [rename debug-process-exited? process:exited? (debug-process? . -> . frp:behavior?)]) - - #| DISABLED - BROKEN + + #| DISABLED - BROKEN [process:running? (debug-process? . -> . frp:behavior?)] [rename time-per-event/milliseconds process:time-per-event/milliseconds (debug-process? frp:behavior? . -> . frp:behavior?)] |# - + ; ; ; ; ; ;;;;;; ; ; ; ; ; @@ -133,11 +140,8 @@ TESTING/CAPABILITIES------------------------------------------------------------ ; turns debug output on and off (define debugging? #f) - ; - (define mztake-version "Rev. Wed Aug 4, 2004 - 17:06:00") - ;########################################################################################################### - + ; ; ; ; ; ; ;;;;; ; ; ; ; @@ -169,10 +173,10 @@ TESTING/CAPABILITIES------------------------------------------------------------ [traces (hash-get (debug-client-tracepoints client) byte-offset)]) (assert (not (empty? traces)) - (format "There are no traces at offset ~a, but a breakpoint is defined!~n" + (format "There are no traces at offset ~a, but a trace point is defined!~n" (number->string byte-offset))) - ; Run all traces at this breakpoint + ; 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)) @@ -217,7 +221,7 @@ TESTING/CAPABILITIES------------------------------------------------------------ ; wrapper for errors related to the script only (define (script-error err) - (raise-syntax-error 'mztake:script-error: (format "~a" err)) + (raise-syntax-error 'mztake:script-error (format "~a" err)) (kill-all)) @@ -235,7 +239,7 @@ TESTING/CAPABILITIES------------------------------------------------------------ (display (format "mztake: ~a~n---~n" str))) - ; retreives the binding of a variable from a breakpoint event + ; retreives the binding of a variable from a bind trace event (define (binding event sym) (define (do-n-times fn n arg) (foldl (lambda (x arg) (fn arg)) arg (build-list n (lambda (x) x)))) @@ -253,7 +257,10 @@ TESTING/CAPABILITIES------------------------------------------------------------ [(client line col type args) (case type ['bind (trace/bind client line col args)] - ['break (trace/break client line col)])] + ['entry (trace/entry client line col)] + [else (script-error (format "Invalid trace type: `~a' in client: `~a'" + (symbol->string type) + (debug-client-modpath client)))])] [(client line col type) (create-trace client line col type null)])) @@ -262,18 +269,20 @@ TESTING/CAPABILITIES------------------------------------------------------------ ; 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) (match trace - [($ break-trace evnt-rcvr) + [($ 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 (binding event var)]) - (if (empty? val) - (script-error (format "trace/bind: No binding found in trace for symbol '~a" var)) - (cadar (binding event var))))) - vars)]) + [values (map + (lambda (var) + (let ([val (binding event var)]) + (if (empty? val) + (script-error + (format "Variable not found at the syntax location for the BIND: `~a'" var)) + (cadar (binding event var))))) + vars)]) (list evnt-rcvr (if (list? variable-to-bind) values (first values))))])) @@ -305,7 +314,7 @@ TESTING/CAPABILITIES------------------------------------------------------------ (cond ; none is found [(empty? lst) - (raise (format "No syntax found for trace at line/column ~a:~a in ~a" line col filename))] + (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)) @@ -334,9 +343,6 @@ TESTING/CAPABILITIES------------------------------------------------------------ ; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;; (define (start-debug-process receive-result process) - (assert (not (null? (debug-process-main-client process))) - "main-client not defined for one of the processes!") - ; initialize the semaphore (set-debug-process-run-semaphore! process (make-semaphore)) ; set initial state of exit predicate @@ -459,13 +465,13 @@ TESTING/CAPABILITIES------------------------------------------------------------ #;(define (running? process) - (script-error "client-running? is broken") - (and (running-now? process) - (not (debug-process-exited? process)))) + (script-error "client-running? is broken") + (and (running-now? process) + (not (debug-process-exited? process)))) #;(define (time-per-event/milliseconds process behavior) - (frp:lift (truncate (/ (frp:value-now (debug-process-runtime process)) - (add1 (frp:value-now (count-e (frp:changes behavior)))))))) + (frp:lift (truncate (/ (frp:value-now (debug-process-runtime process)) + (add1 (frp:value-now (count-e (frp:changes behavior)))))))) (define (runtime/milliseconds process) (debug-process-runtime process)) @@ -484,7 +490,7 @@ TESTING/CAPABILITIES------------------------------------------------------------ (parameterize ([current-namespace (make-namespace)]) (with-handlers ([exn:module? (lambda (exn) - (client-error (format "Expected a module in client: ~a" filename)))]) + (client-error (format "Expected a module in client file: ~a" filename)))]) (let* ([build-module-filename ; taken from module-overview.ss (lambda (str) @@ -526,6 +532,10 @@ TESTING/CAPABILITIES------------------------------------------------------------ ; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver) ; (debug-client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?) (define (trace/bind client line col binding-symbol) + (when (empty? binding-symbol) + (script-error (format "No symbols defined in BIND for client: `~a'" + (debug-client-modpath client)))) + (with-handlers ([(lambda (exn) #t) (lambda (exn) (raise-syntax-error 'mztake:script-error:trace/bind exn))]) (let ([trace-hash (debug-client-tracepoints client)] @@ -533,19 +543,19 @@ TESTING/CAPABILITIES------------------------------------------------------------ [pos ((debug-client-line-col->pos client) line col)]) ; add the trace to the list of traces for that byte-offset (hash-put! trace-hash pos - (cons trace - (hash-get trace-hash pos (lambda () '())))) + (append (hash-get trace-hash pos (lambda () '())) + (list trace))) (trace-struct-evnt-rcvr trace)))) ;(debug-file? number? number? . -> . frp:event?) - (define (trace/break client line col) + (define (trace/entry client line col) (let ([trace-hash (debug-client-tracepoints client)] - [trace (create-break-trace)] + [trace (create-entry-trace)] [pos ((debug-client-line-col->pos client) line col)]) (hash-put! trace-hash pos - (cons trace - (hash-get trace-hash pos (lambda () '())))) + (append (hash-get trace-hash pos (lambda () '())) + (list trace))) (trace-struct-evnt-rcvr trace))) @@ -556,4 +566,4 @@ TESTING/CAPABILITIES------------------------------------------------------------ ;########################################################################################################### - ) \ No newline at end of file + ) diff --git a/collects/mztake/private/marks.ss b/collects/mztake/private/marks.ss new file mode 100644 index 0000000000..efa6a37fea --- /dev/null +++ b/collects/mztake/private/marks.ss @@ -0,0 +1,180 @@ +(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)))