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
parent
2d5242e5f4
commit
04e9cefc17
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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@)
|
||||
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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...
|
||||
|
|
|
|||
|
|
@ -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]))
|
||||
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
@ -446,7 +451,7 @@ Known Problems
|
|||
|
||||
MZTAKE SCRIPT:
|
||||
(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))
|
||||
|
||||
Sometimes this causes unusual errors. These problems usually only
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"))))
|
||||
(all-from (lib "useful-code.ss" "mztake" "private"))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,13 @@
|
|||
(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
|
||||
* catch the other two exceptions that my loaders throw
|
||||
|
|
@ -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")
|
||||
|
||||
|
|
@ -133,9 +140,6 @@ 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,16 +269,18 @@ 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)
|
||||
[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))
|
||||
(script-error
|
||||
(format "Variable not found at the syntax location for the BIND: `~a'" var))
|
||||
(cadar (binding event var)))))
|
||||
vars)])
|
||||
(list evnt-rcvr
|
||||
|
|
@ -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
|
||||
|
|
@ -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)))
|
||||
|
||||
|
||||
|
|
|
|||
180
collects/mztake/private/marks.ss
Normal file
180
collects/mztake/private/marks.ss
Normal 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)))
|
||||
Loading…
Reference in New Issue
Block a user