moved marks.ss to mztake and removed all references to stepper.

changed mztake-process to define-mztake-process
changed 'break to 'entry
improved error messages

traces get processed in the order they are defined in the script file now.

svn: r148
This commit is contained in:
Jono Spiro 2004-08-06 03:14:02 +00:00
parent 2d5242e5f4
commit 04e9cefc17
14 changed files with 332 additions and 103 deletions

View File

@ -1,7 +1,7 @@
(module debugger-annotate mzscheme (module debugger-annotate mzscheme
(require (prefix kernel: (lib "kerncase.ss" "syntax")) (require (prefix kernel: (lib "kerncase.ss" "syntax"))
(lib "marks.ss" "stepper" "private")) (lib "marks.ss" "mztake" "private"))
;; (define count 0) ;; (define count 0)

View File

@ -1,11 +1,11 @@
(module debugger-model mzscheme (module debugger-model mzscheme
(require (lib "unit.ss") (require (lib "unit.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "marks.ss" "stepper" "private") (lib "marks.ss" "mztake" "private")
"debugger-annotate.ss" "debugger-annotate.ss"
"mztake-structs.ss" "mztake-structs.ss"
"private/load-annotator.ss" (lib "load-annotator.ss" "mztake" "private")
"private/more-useful-code.ss") (lib "more-useful-code.ss" "mztake" "private"))
(provide debugger-model@) (provide debugger-model@)

View File

@ -2,7 +2,7 @@
(require "dijkstra-solver.ss" (require "dijkstra-solver.ss"
(lib "match.ss")) (lib "match.ss"))
(mztake-process p (define-mztake-process p
("dijkstra.ss") ("dijkstra.ss")
("heap.ss" ("heap.ss"
[inserts 49 6 bind 'item] [inserts 49 6 bind 'item]

View File

@ -3,7 +3,7 @@
(require (lib "animation.ss" "frtime")) ;; needed for display-shapes (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 #| * Create a process to debug highway.ss
* Add a tracepoint at line 3, column 4; in the program, * Add a tracepoint at line 3, column 4; in the program,

View File

@ -6,7 +6,7 @@
run the program and catch the exception it throws. 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)) (printf-b "exception.ss exited? ~a" (process:exited? p))
;; Prints out a behavior that tells you whether the debug-process is still running... ;; Prints out a behavior that tells you whether the debug-process is still running...

View File

@ -9,7 +9,7 @@
and idea of why they recieve different values from the same "x". 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-in-let 4 25 bind 'x]
[x-after-let 5 11 bind 'x])) [x-after-let 5 11 bind 'x]))

View File

@ -20,7 +20,7 @@
See the doc for more information on this kind of drawing. 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 #| * Create a process to debug montecarlo.ss
* Add a tracepoint at line 13, column 18; in the program, * Add a tracepoint at line 13, column 18; in the program,

View File

@ -29,7 +29,7 @@
See the doc for more information on this kind of drawing. 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 #| * Create a process to debug random-xs.ss
* Add a tracepoint at line 4, column 6; in the program, * Add a tracepoint at line 4, column 6; in the program,

View File

@ -7,7 +7,7 @@
(require (lib "animation.ss" "frtime")) ;; needed for display-shapes (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 #| * Create a process to debug sine.ss
* Add a tracepoint at line 5, column 8; in the program, * Add a tracepoint at line 5, column 8; in the program,

View File

@ -23,7 +23,7 @@ using callbacks). Consider a MzTake script to monitor the
behavior of the program "highway.ss", in the demos directory behavior of the program "highway.ss", in the demos directory
of the MzTake collection: of the MzTake collection:
(debug-mztake-process (define-mztake-process
radar-program radar-program
("highway.ss" [values-of-speed 3 4 bind 'speed])) ("highway.ss" [values-of-speed 3 4 bind 'speed]))
(printf-b "current speed: ~a" (hold values-of-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/ 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 that you run it in DrScheme in the "module..." language), assuming there
will be side-effects that start the debugging. 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 modules used *by* the main-module, allowing you to see
what is going on deeper than the main module. For example: what is going on deeper than the main module. For example:
(mztake-process p1 (define-mztake-process p1
("my-stack-tests.ss") ("my-stack-tests.ss")
((lib "my-stack.ss" "my-stack") [s-push-p1 3 29 bind 'insert-value] ((lib "my-stack.ss" "my-stack") [s-push-p1 3 29 bind 'insert-value]
[s-pop-p1 10 16 bind 'return-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 * The same file can be traced differently in different processes, even with
different main clients using them: different main clients using them:
(mztake-process p2 (define-mztake-process p2
("more-my-stack-tests.ss") ("more-my-stack-tests.ss")
((lib "my-stack.ss" "my-stack") [s-clear-p2 22 8 ENTRY])) ((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 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. 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 ...] ...) [target-filename trace-clause ...] ...)
Where trace-clause is one of the following: 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: syntax for modules:
* Absolute path: * 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: * Relative path:
(mztake-process p ["../test.ss" [brk 10 7 ENTRY]]) (define-mztake-process p ["../test.ss" [brk 10 7 ENTRY]])
* Library path: * 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 the trace-name is a variable name bound at the
top-level, whose value is a FrTime event top-level, whose value is a FrTime event
stream. Each time the execution of the target 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/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 process-name. If the process given to START/RESUME is already
running, and was paused with the function PAUSE (below), running, and was paused with the function PAUSE (below),
START/RESUME resumes its execution. START/RESUME resumes its execution.
@ -442,12 +447,12 @@ Known Problems
you are putting bind-traces on: you are putting bind-traces on:
ORIGINAL FILE: ORIGINAL FILE:
(define (my-fun some-struct) ...) (define (my-fun some-struct) ...)
MZTAKE SCRIPT: MZTAKE SCRIPT:
(require "original-file.ss") (require "original-file.ss")
(mztake-process p ("original-file.ss" [val 10 12 bind 'my-struct])) (define-mztake-process p ("original-file.ss" [val 10 12 bind 'my-struct]))
(my-fun (hold val)) (my-fun (hold val))
Sometimes this causes unusual errors. These problems usually only Sometimes this causes unusual errors. These problems usually only
show up if you are binding to structs (defined in the same file) and 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) (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 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. 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 * MzTake has not been tested for stability if the target is using
multiple threads. This only applies to threaded modules multiple threads. This only applies to threaded modules
*with* traces on them -- other REQUIRE'd modules will work *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. there will probably be some sort of name-clash and strange error.
This will be fixed. 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 'x updates and 'y is out-of-date.
* Then 'y updates, and both are up-to-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, will draw twice, in two locations, one for each update,
the second one being correct. 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 * You can trace the *same* file in different ways by using
multiple processes on the same file, under different multiple processes on the same file, under different
contexts, and compare results. For example, in contexts, and compare results. For example, in
"demos/misc/first-class-test.ss": "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-in-let 4 25 bind 'x]
[x-after-let 5 11 bind 'x])) [x-after-let 5 11 bind 'x]))
(... code omitted ...) (... code omitted ...)
@ -546,9 +585,9 @@ Tips and Tricks
is functionally equivalent to: is functionally equivalent to:
(mztake-process p1 ("first-class.ss" [x-before-let 3 29 bind 'x])) (define-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])) (define-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 p3 ("first-class.ss" [x-after-let 5 11 bind 'x]))
(... code omitted ...) (... code omitted ...)
(start/resume p1) (start/resume p2) (start/resume p3) (start/resume p1) (start/resume p2) (start/resume p3)

View File

@ -1,6 +1,6 @@
(module mztake-structs mzscheme (module mztake-structs mzscheme
(require (prefix frp: (lib "frp.ss" "frtime")) (require (prefix frp: (lib "frp.ss" "frtime"))
"private/more-useful-code.ss") (lib "more-useful-code.ss" "mztake" "private"))
(provide (all-defined)) (provide (all-defined))
@ -19,7 +19,7 @@
(define-struct trace-struct (evnt-rcvr)) ; frp:event-receiver (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) (define-struct (bind-trace trace-struct)
(variable-to-bind)) ; symbol (variable-to-bind)) ; symbol
@ -59,9 +59,9 @@
(define (create-bind-trace sym-to-bind) ; ((union (listof symbol?) symbol?) . -> . trace?) (define (create-bind-trace sym-to-bind) ; ((union (listof symbol?) symbol?) . -> . trace?)
(make-bind-trace (frp:event-receiver) sym-to-bind)) (make-bind-trace (frp:event-receiver) sym-to-bind))
; Creates a trace that simply pauses the program ; Creates a trace that simply alerts that it was hit
(define (create-break-trace) ; (void? . -> . trace?) (define (create-entry-trace) ; (void? . -> . trace?)
(make-break-trace (frp:event-receiver))) (make-entry-trace (frp:event-receiver)))
(define (create-empty-debug-process) (define (create-empty-debug-process)
(make-debug-process (make-custodian) (make-debug-process (make-custodian)

View File

@ -1,7 +1,7 @@
#| #|
(mztake-process p ("sine.ss" [sin/x 5 8 bind '(sin-x x)] (mztake-process p ("sine.ss" [sin/x 5 8 bind '(sin-x x)]
[foo 10 20 bind '(sin-x x)]) [foo 10 20 bind '(sin-x x)])
("sine-extra.ss")) ("sine-extra.ss"))
(define sin/x (hold sin/x)) (define sin/x (hold sin/x))
(define x (+ 200 (second sin/x))) (define x (+ 200 (second sin/x)))
@ -19,11 +19,11 @@
(module mztake-syntax (lib "frtime-big.ss" "frtime") (module mztake-syntax (lib "frtime-big.ss" "frtime")
(require (lib "mztake.ss" "mztake") (require (lib "mztake.ss" "mztake")
(lib "useful-code.ss" "mztake/private")) (lib "useful-code.ss" "mztake" "private"))
(define-syntax mztake-process (define-syntax define-mztake-process
(syntax-rules (mztake-process) (syntax-rules (define-mztake-process)
[(mztake-process proc-id (client (trace line col cmd . args) ...) ...) [(define-mztake-process proc-id (client (trace line col cmd . args) ...) ...)
(begin (begin
(define proc-id (create-debug-process)) (define proc-id (create-debug-process))
(begin (begin
@ -33,7 +33,7 @@
(create-trace tmp line col 'cmd . args) (create-trace tmp line col 'cmd . args)
...))) ...))])) ...))) ...))]))
(provide mztake-process (provide define-mztake-process
(all-from-except (lib "frtime-big.ss" "frtime") #%module-begin) (all-from (lib "frtime-big.ss" "frtime"))
(all-from (lib "mztake.ss" "mztake")) (all-from (lib "mztake.ss" "mztake"))
(all-from (lib "useful-code.ss" "mztake/private")))) (all-from (lib "useful-code.ss" "mztake" "private"))))

View File

@ -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:::::::::::::: :::::::::LOAD/ANNOTATOR BUGS::::::::::::::
* catch oops exception * catch oops exception
@ -38,7 +46,7 @@ SCRIPT--------------------------------------------------------------------------
* Provide a body to bind instead or returning an eventstream, like (list x y) * 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 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?) * 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------------------------------------------------------------------------ TESTING/CAPABILITIES------------------------------------------------------------------------
* Does user interaction work? Can we step through loops one line at a time waiting for input? GUIs? * 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 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 * 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. * 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) * Find a way to bind to the result of ananonymous expression: here->(add1 2)
|# |#
(module mztake mzscheme
(require (lib "match.ss") (require (lib "match.ss")
(lib "unit.ss") (lib "unit.ss")
(lib "contract.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")) (prefix frp: (lib "frp.ss" "frtime"))
"private/useful-code.ss" (lib "useful-code.ss" "mztake" "private")
"private/more-useful-code.ss" ; mostly for hash- bindings (lib "more-useful-code.ss" "mztake" "private") ; mostly for hash- bindings
"mztake-structs.ss" "mztake-structs.ss"
"debugger-model.ss") "debugger-model.ss")
@ -104,14 +111,14 @@ TESTING/CAPABILITIES------------------------------------------------------------
[rename debug-process-exited? [rename debug-process-exited?
process:exited? process:exited?
(debug-process? . -> . frp:behavior?)]) (debug-process? . -> . frp:behavior?)])
#| DISABLED - BROKEN #| DISABLED - BROKEN
[process:running? (debug-process? . -> . frp:behavior?)] [process:running? (debug-process? . -> . frp:behavior?)]
[rename time-per-event/milliseconds [rename time-per-event/milliseconds
process:time-per-event/milliseconds process:time-per-event/milliseconds
(debug-process? frp:behavior? . -> . frp:behavior?)] (debug-process? frp:behavior? . -> . frp:behavior?)]
|# |#
; ; ; ; ; ; ; ;
; ;;;;;; ; ; ; ; ; ; ;;;;;; ; ; ; ; ;
@ -133,11 +140,8 @@ TESTING/CAPABILITIES------------------------------------------------------------
; turns debug output on and off ; turns debug output on and off
(define debugging? #f) (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)]) [traces (hash-get (debug-client-tracepoints client) byte-offset)])
(assert (not (empty? traces)) (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))) (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)]) (let ([to-send (map (lambda (t) (trace->frp-event client result t)) traces)])
(frp:send-synchronous-events to-send)) (frp:send-synchronous-events to-send))
@ -217,7 +221,7 @@ TESTING/CAPABILITIES------------------------------------------------------------
; wrapper for errors related to the script only ; wrapper for errors related to the script only
(define (script-error err) (define (script-error err)
(raise-syntax-error 'mztake:script-error: (format "~a" err)) (raise-syntax-error 'mztake:script-error (format "~a" err))
(kill-all)) (kill-all))
@ -235,7 +239,7 @@ TESTING/CAPABILITIES------------------------------------------------------------
(display (format "mztake: ~a~n---~n" str))) (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 (binding event sym)
(define (do-n-times fn n arg) (define (do-n-times fn n arg)
(foldl (lambda (x arg) (fn arg)) arg (build-list n (lambda (x) x)))) (foldl (lambda (x arg) (fn arg)) arg (build-list n (lambda (x) x))))
@ -253,7 +257,10 @@ TESTING/CAPABILITIES------------------------------------------------------------
[(client line col type args) [(client line col type args)
(case type (case type
['bind (trace/bind client line col args)] ['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) [(client line col type)
(create-trace client line col type null)])) (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 ; 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) (define (trace->frp-event client event trace)
(match trace (match trace
[($ break-trace evnt-rcvr) [($ entry-trace evnt-rcvr)
(list evnt-rcvr #t)] (list evnt-rcvr #t)]
[($ bind-trace evnt-rcvr variable-to-bind) [($ bind-trace evnt-rcvr variable-to-bind)
(let* ([vars (if (list? variable-to-bind) variable-to-bind (let* ([vars (if (list? variable-to-bind) variable-to-bind
(list variable-to-bind))] (list variable-to-bind))]
[values (map (lambda (var) [values (map
(let ([val (binding event var)]) (lambda (var)
(if (empty? val) (let ([val (binding event var)])
(script-error (format "trace/bind: No binding found in trace for symbol '~a" var)) (if (empty? val)
(cadar (binding event var))))) (script-error
vars)]) (format "Variable not found at the syntax location for the BIND: `~a'" var))
(cadar (binding event var)))))
vars)])
(list evnt-rcvr (list evnt-rcvr
(if (list? variable-to-bind) values (if (list? variable-to-bind) values
(first values))))])) (first values))))]))
@ -305,7 +314,7 @@ TESTING/CAPABILITIES------------------------------------------------------------
(cond (cond
; none is found ; none is found
[(empty? lst) [(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 ; if first is correct line and correct column
[(and (= line (caar lst)) [(and (= line (caar lst))
@ -334,9 +343,6 @@ TESTING/CAPABILITIES------------------------------------------------------------
; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;; ; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;;
(define (start-debug-process receive-result process) (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 ; initialize the semaphore
(set-debug-process-run-semaphore! process (make-semaphore)) (set-debug-process-run-semaphore! process (make-semaphore))
; set initial state of exit predicate ; set initial state of exit predicate
@ -459,13 +465,13 @@ TESTING/CAPABILITIES------------------------------------------------------------
#;(define (running? process) #;(define (running? process)
(script-error "client-running? is broken") (script-error "client-running? is broken")
(and (running-now? process) (and (running-now? process)
(not (debug-process-exited? process)))) (not (debug-process-exited? process))))
#;(define (time-per-event/milliseconds process behavior) #;(define (time-per-event/milliseconds process behavior)
(frp:lift (truncate (/ (frp:value-now (debug-process-runtime process)) (frp:lift (truncate (/ (frp:value-now (debug-process-runtime process))
(add1 (frp:value-now (count-e (frp:changes behavior)))))))) (add1 (frp:value-now (count-e (frp:changes behavior))))))))
(define (runtime/milliseconds process) (define (runtime/milliseconds process)
(debug-process-runtime process)) (debug-process-runtime process))
@ -484,7 +490,7 @@ TESTING/CAPABILITIES------------------------------------------------------------
(parameterize ([current-namespace (make-namespace)]) (parameterize ([current-namespace (make-namespace)])
(with-handlers ([exn:module? (with-handlers ([exn:module?
(lambda (exn) (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 (let* ([build-module-filename ; taken from module-overview.ss
(lambda (str) (lambda (str)
@ -526,6 +532,10 @@ TESTING/CAPABILITIES------------------------------------------------------------
; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver) ; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver)
; (debug-client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?) ; (debug-client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?)
(define (trace/bind client line col binding-symbol) (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) (with-handlers ([(lambda (exn) #t)
(lambda (exn) (raise-syntax-error 'mztake:script-error:trace/bind exn))]) (lambda (exn) (raise-syntax-error 'mztake:script-error:trace/bind exn))])
(let ([trace-hash (debug-client-tracepoints client)] (let ([trace-hash (debug-client-tracepoints client)]
@ -533,19 +543,19 @@ TESTING/CAPABILITIES------------------------------------------------------------
[pos ((debug-client-line-col->pos client) line col)]) [pos ((debug-client-line-col->pos client) line col)])
; add the trace to the list of traces for that byte-offset ; add the trace to the list of traces for that byte-offset
(hash-put! trace-hash pos (hash-put! trace-hash pos
(cons trace (append (hash-get trace-hash pos (lambda () '()))
(hash-get trace-hash pos (lambda () '())))) (list trace)))
(trace-struct-evnt-rcvr trace)))) (trace-struct-evnt-rcvr trace))))
;(debug-file? number? number? . -> . frp:event?) ;(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)] (let ([trace-hash (debug-client-tracepoints client)]
[trace (create-break-trace)] [trace (create-entry-trace)]
[pos ((debug-client-line-col->pos client) line col)]) [pos ((debug-client-line-col->pos client) line col)])
(hash-put! trace-hash pos (hash-put! trace-hash pos
(cons trace (append (hash-get trace-hash pos (lambda () '()))
(hash-get trace-hash pos (lambda () '())))) (list trace)))
(trace-struct-evnt-rcvr trace))) (trace-struct-evnt-rcvr trace)))
@ -556,4 +566,4 @@ TESTING/CAPABILITIES------------------------------------------------------------
;########################################################################################################### ;###########################################################################################################
) )

View File

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