take the MzTake out of mztake
svn: r8755
This commit is contained in:
Greg Cooper
parent
f39b12a555
commit
3e204e0641
|
|
@ -384,15 +384,4 @@
|
|||
is-tail?)
|
||||
annotated))
|
||||
|
||||
(values (top-level-annotate stx) (hash-table-map breakpoints (lambda (k v) k)))))
|
||||
|
||||
#;
|
||||
(define (tests)
|
||||
(run/single-stepping-annotation
|
||||
(current-custodian) "a.ss"
|
||||
(map string->path '("/home/gmarceau/projects/mztake/collects/mztake/a.ss"
|
||||
"/home/gmarceau/projects/mztake/collects/mztake/b.ss"))
|
||||
(lambda (fn pos)
|
||||
(printf "break?: ~a ~a~n" fn pos) #t)
|
||||
(lambda (bp-info) (printf "break: ~a~n" bp-info) #f)))
|
||||
)
|
||||
(values (top-level-annotate stx) (hash-table-map breakpoints (lambda (k v) k))))))
|
||||
|
|
|
|||
|
|
@ -116,7 +116,7 @@
|
|||
(if (is-a? source editor<%>)
|
||||
source
|
||||
(cond
|
||||
[(send (group:get-the-frame-group) locate-file source)
|
||||
[(and source (send (group:get-the-frame-group) locate-file source))
|
||||
=>
|
||||
(lambda (frame)
|
||||
(let ([defss (map (lambda (t) (send t get-defs)) (send frame get-tabs))])
|
||||
|
|
@ -587,7 +587,7 @@
|
|||
(lambda (defs)
|
||||
(send (send defs get-tab)
|
||||
add-top-level-binding var val))]
|
||||
[else (printf "record-top-level failed~n")])
|
||||
[else (void) #;(printf "record-top-level failed~n")])
|
||||
#;
|
||||
(printf "top-level binding: ~a ~a ~a~n" mod var val))
|
||||
source)])
|
||||
|
|
|
|||
|
|
@ -1,85 +0,0 @@
|
|||
#| This script tests a priority queue (heap) that is correctly implemented, but incorrectly used.
|
||||
It is not commented because it uses a some advanced FrTime concepts that can easily be looked
|
||||
up in the help desk, and both the description and motivation of the example can be found in
|
||||
"A Dataflow Language for Scriptable Debugging" (Marceau, Cooper, Krishnamurthi, Reiss),
|
||||
available at:
|
||||
|
||||
http://www.cs.brown.edu/~sk/Publications/Papers/Published/mckr-dataflow-lang-script-debug/
|
||||
|
||||
This script uses the concept of maintaining a local model of the heap being debugged, as a simple,
|
||||
and very slow, list. The difference is that a fancy heap used can be naively implemented as a list,
|
||||
simply removing only the smallest element each time. Models are external to your program, you don't
|
||||
have to add any test code to your program to use them. By adding and removing the items to our local
|
||||
"model" (the values come from the heap code we used), we can compare the results and assert whether
|
||||
it is working correctly or not. Our model shows the values we should be getting from the program,
|
||||
but clearly are not.
|
||||
|
||||
To provide some context for this demo, and what debugging problem MzTake helps us explore, I offer
|
||||
the following, out of context, taken directly from the paper:
|
||||
We find that the queue's elements are not in sorted order while those in the model
|
||||
are. More revealingly, the queue's elements are not the same as those in the model.
|
||||
A little further study shows that the bug is in our usage of the priority queue:
|
||||
we have failed to account for the fact that the assignment to dest.weight
|
||||
in relax (figure 1) updates the weights of nodes already in the queue. Because
|
||||
the queue is not sensitive to these updates, what it returns is no longer the
|
||||
smallest element in the queue.
|
||||
|
||||
On further reading, we trace the error to a subtle detail in the description of
|
||||
Dijkstra's algorithm in Cormen, et al.'s book [9, page 530]. The book permits
|
||||
the use of a binary heap (which is how we implemented the priority queue) for
|
||||
sparse graphs, but subsequently amends the pseudocode to say that the assignment
|
||||
to dest.weight must explicitly invoke a key-decrement operation. Our error,
|
||||
therefore, was not in the implementation of the heap, but in using the (faster)
|
||||
binary heap implementation without satisfying its (stronger) contract. |#
|
||||
|
||||
(require (lib "mztake.ss" "mztake")
|
||||
(lib "useful-code.ss" "mztake")
|
||||
"dijkstra-solver.ss"
|
||||
(lib "match.ss"))
|
||||
|
||||
(define inserts (trace (loc '(lib "heap.ss" "frtime") '(let* ((sorter _) _) _))
|
||||
item))
|
||||
(define removes (trace (loc/r '(dv:ref (t-data _) _))))
|
||||
|
||||
#| The following code
|
||||
merely observes the insertions and removals
|
||||
from the heap. We notice whether any of the removals are out
|
||||
of order based on the last item removed, as long as there are
|
||||
no insertions between the two events. We can keep track of the
|
||||
last 2 using history-e. |#
|
||||
|
||||
(define (not-in-order e)
|
||||
(filter-e
|
||||
(match-lambda
|
||||
[('reset _) false]
|
||||
[(_ 'reset) false]
|
||||
[(previous current) (> previous current)]
|
||||
[else false])
|
||||
(history-e e 2)))
|
||||
|
||||
|
||||
(define inserts-and-removes-e (merge-e (removes . ==> . node-weight)
|
||||
(inserts . -=> . 'reset)))
|
||||
(define violations (not-in-order inserts-and-removes-e))
|
||||
|
||||
(printf-b "all inserts and removes: ~a" (history-b inserts-and-removes-e))
|
||||
(printf-b "all violations: ~a" (history-b violations))
|
||||
(printf-b "latest-violation: ~a" (hold violations))
|
||||
#| This output indicates that the queue has yielded nodes whose weights are out of order.
|
||||
This confirms our suspicion that the problem somehow involves the priority queue. |#
|
||||
|
||||
#| Implementation of the local model follows... |#
|
||||
(define ((insert-in-model item) model)
|
||||
(printf "~nInserting ~a into model containing:~n~a~n" item (value-now model))
|
||||
(cons item model))
|
||||
|
||||
(define ((remove-from-model item) model)
|
||||
(printf "~nRemoving ~a from model containing:~n~a~n" item (value-now model))
|
||||
(filter (lambda (i) (not (equal? i item))) model))
|
||||
|
||||
(define inserters (accum-b (inserts . ==> . insert-in-model) empty))
|
||||
(define removers (accum-b (removes . ==> . remove-from-model) inserters))
|
||||
|
||||
(set-main! "dijkstra.ss")
|
||||
|
||||
(set-running-e! (violations . -=> . false))
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
(module dijkstra-solver mzscheme
|
||||
(require (lib "heap.ss" "frtime")
|
||||
(lib "list.ss")
|
||||
"graph.ss")
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
(define (make-node label x y weight) (vector label x y weight))
|
||||
(define (node-label n) (vector-ref n 0))
|
||||
(define (node-x n) (vector-ref n 1))
|
||||
(define (node-y n) (vector-ref n 2))
|
||||
(define (node-weight n) (vector-ref n 3))
|
||||
(define (set-node-weight! n v) (vector-set! n 3 v))
|
||||
|
||||
(define (node< a b) (< (node-weight a) (node-weight b)))
|
||||
(define (sqr x) (* x x))
|
||||
(define (distance-to a b)
|
||||
(sqrt (+ (sqr (- (node-x a) (node-x b)))
|
||||
(sqr (- (node-y a) (node-y b))))))
|
||||
|
||||
(define (hash-table-pairs hash)
|
||||
(hash-table-map hash (lambda (key val) (list key val))))
|
||||
|
||||
(define (relax backtrace heap origin dest)
|
||||
(let ([candidate-weight
|
||||
(+ (node-weight origin)
|
||||
(distance-to origin dest))])
|
||||
(when (candidate-weight . < . (node-weight dest))
|
||||
(set-node-weight! dest candidate-weight)
|
||||
;;(heap-resort heap dest)
|
||||
(hash-table-put! backtrace dest origin))))
|
||||
|
||||
(define (solve graph nodes source)
|
||||
(let ([backtrace (make-hash-table)]
|
||||
[heap (make-heap node< eq?)])
|
||||
(set-node-weight! source 0)
|
||||
(for-each (lambda (node) (heap-insert heap node))
|
||||
nodes)
|
||||
|
||||
(let loop ()
|
||||
(unless (heap-empty? heap)
|
||||
(let* ([node (heap-pop heap)]
|
||||
[successors (graph-succs graph node)])
|
||||
(for-each
|
||||
(lambda (succ) (relax backtrace heap node succ))
|
||||
successors))
|
||||
(loop)))
|
||||
|
||||
(hash-table-pairs backtrace))))
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
(module dijkstra mzscheme
|
||||
(require "dijkstra-solver.ss"
|
||||
"graph.ss"
|
||||
(lib "list.ss"))
|
||||
|
||||
(define g (make-graph 'directed))
|
||||
(define (m-node label x y) (make-node label x y +inf.0))
|
||||
(define nodes
|
||||
(list
|
||||
(m-node 'J 200 100)
|
||||
(m-node 's 100 125)
|
||||
(m-node '1 150 100)
|
||||
(m-node '2 150 150)
|
||||
(m-node '4 250 100)
|
||||
(m-node '5 300 100)
|
||||
(m-node '6 300 150)))
|
||||
(for-each (lambda (n) (graph-node-add! g n)) nodes)
|
||||
(define (n-ref label)
|
||||
(first (filter (lambda (n) (eq? label (node-label n))) nodes)))
|
||||
|
||||
(define edges
|
||||
(list (list (n-ref 's) (n-ref '1))
|
||||
(list (n-ref 's) (n-ref '2))
|
||||
(list (n-ref '1) (n-ref 'J))
|
||||
(list (n-ref '4) (n-ref '5))
|
||||
(list (n-ref 'J) (n-ref '4))
|
||||
(list (n-ref 'J) (n-ref '6))))
|
||||
(for-each (lambda (e) (graph-edge-add! g (first e) (second e)))
|
||||
edges)
|
||||
|
||||
(printf "~n~n---output from dijkstra.ss:~n~a~n---~n"
|
||||
(solve g (reverse nodes) (n-ref 's))))
|
||||
|
|
@ -1,100 +0,0 @@
|
|||
; -*- Scheme -*-
|
||||
|
||||
; Shriram Krishnamurthi (shriram@cs.rice.edu)
|
||||
; Tue Jul 25 23:20:45 EDT 1995
|
||||
|
||||
; (define-structure (dv:vector length size contents))
|
||||
|
||||
(module dv mzscheme
|
||||
|
||||
(provide dv:make dv:make-w/-init dv:length dv:contents dv:append
|
||||
dv:remove-last dv:legitimate-index dv:ref dv:set!)
|
||||
|
||||
(define dv:vector?
|
||||
(lambda (obj)
|
||||
(if (vector? obj)
|
||||
(if (= (vector-length obj) 4)
|
||||
(eq? (vector-ref obj 0) 'dv:vector)
|
||||
#f)
|
||||
#f)))
|
||||
(define dv:vector-length
|
||||
(lambda (obj) (vector-ref obj 1)))
|
||||
(define dv:vector-size
|
||||
(lambda (obj) (vector-ref obj 2)))
|
||||
(define dv:vector-contents
|
||||
(lambda (obj) (vector-ref obj 3)))
|
||||
(define dv:set-vector-length!
|
||||
(lambda (obj newval) (vector-set! obj 1 newval)))
|
||||
(define dv:set-vector-size!
|
||||
(lambda (obj newval) (vector-set! obj 2 newval)))
|
||||
(define dv:set-vector-contents!
|
||||
(lambda (obj newval) (vector-set! obj 3 newval)))
|
||||
(define dv:make-vector
|
||||
(lambda (length size contents)
|
||||
((lambda () (vector 'dv:vector length size contents)))))
|
||||
|
||||
(define dv:make
|
||||
(let* ((default-initial-size 8)
|
||||
(default-initial-vector (make-vector default-initial-size)))
|
||||
(lambda arg
|
||||
(cond
|
||||
((null? arg)
|
||||
(dv:make-vector 0 default-initial-size default-initial-vector))
|
||||
((= 1 (length arg))
|
||||
(let ((l (car arg)))
|
||||
(dv:make-vector 0 l (make-vector l))))
|
||||
(else
|
||||
(error 'dv:make "wrong number of arguments"))))))
|
||||
|
||||
(define dv:make-w/-init
|
||||
(lambda values
|
||||
(let ((l (length values)))
|
||||
(dv:make-vector l l (list->vector values)))))
|
||||
|
||||
(define dv:append
|
||||
(lambda (dv item)
|
||||
(let ((length (dv:vector-length dv))
|
||||
(size (dv:vector-size dv))
|
||||
(contents (dv:vector-contents dv)))
|
||||
(if (< length size)
|
||||
(begin
|
||||
(vector-set! contents length item)
|
||||
(dv:set-vector-length! dv (+ length 1)))
|
||||
(begin
|
||||
(let ((new-vector (make-vector (* size 2))))
|
||||
(let loop
|
||||
((i 0))
|
||||
(when (< i size)
|
||||
(vector-set! new-vector i (vector-ref contents i))
|
||||
(loop (+ i 1))))
|
||||
(dv:set-vector-contents! dv new-vector)
|
||||
(dv:set-vector-size! dv (* size 2))
|
||||
(dv:append dv item)))))))
|
||||
|
||||
(define dv:remove-last
|
||||
(lambda (dv)
|
||||
(dv:set-vector-length! dv (- (dv:vector-length dv) 1))
|
||||
(vector-set! (dv:vector-contents dv) (dv:vector-length dv) 0)))
|
||||
|
||||
|
||||
(define dv:legitimate-index
|
||||
(lambda (dv index)
|
||||
(< index (dv:vector-length dv))))
|
||||
|
||||
(define dv:ref
|
||||
(lambda (dv index)
|
||||
(if (dv:legitimate-index dv index)
|
||||
(vector-ref (dv:vector-contents dv) index)
|
||||
(error 'dv:ref "index too large"))))
|
||||
|
||||
(define dv:set!
|
||||
(lambda (dv index value)
|
||||
(if (dv:legitimate-index dv index)
|
||||
(vector-set! (dv:vector-contents dv) index value)
|
||||
(error 'dv:set! "index too large"))))
|
||||
|
||||
(define dv:contents dv:vector-contents)
|
||||
|
||||
(define dv:length dv:vector-length)
|
||||
)
|
||||
|
||||
|
|
@ -1,542 +0,0 @@
|
|||
;; -*- compile-command: "mzscheme -M errortrace -u graph.ss" -*-
|
||||
(module graph mzscheme
|
||||
(require (lib "base-gm.ss" "frtime")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss"))
|
||||
|
||||
(provide make-graph
|
||||
;; --- Constructors :
|
||||
graph?
|
||||
graph-directed?
|
||||
graph-make-similar
|
||||
graph-copy
|
||||
graph-add-all!
|
||||
;; --- Functions on nodes:
|
||||
graph-nodes
|
||||
graph-nodes-size
|
||||
graph-make-node!
|
||||
graph-node-add!
|
||||
graph-node-mem?
|
||||
graph-node-set!
|
||||
graph-node-remove!
|
||||
graph-node-collapse!
|
||||
graph-node-has-label?
|
||||
graph-node-label
|
||||
graph-for-each-node
|
||||
graph-fold-nodes
|
||||
;; --- Functions on neighbors:
|
||||
graph-succs
|
||||
graph-preds
|
||||
graph-adjs
|
||||
graph-for-each-adjs
|
||||
;; --- Functions on edges:
|
||||
graph-edges
|
||||
graph-edges-size
|
||||
graph-edge-add!
|
||||
graph-edge-mem?
|
||||
graph-edge-set!
|
||||
graph-edge-remove!
|
||||
graph-edge-has-label?
|
||||
graph-edge-label
|
||||
graph-for-each-edge
|
||||
graph-fold-edges
|
||||
;; --- Simple graph algorithms:
|
||||
graph-dfs-from-node
|
||||
graph-dfs-all
|
||||
graph-components
|
||||
graph-strongly-connected-components
|
||||
graph-topological-sort
|
||||
;; --- Debugging:
|
||||
graph-to-list
|
||||
graph-to-string
|
||||
graph-test
|
||||
)
|
||||
|
||||
(define-struct t (flags nNodes nEdges nodes successors predessessors))
|
||||
|
||||
;; Flags can be: 'equal 'directed 'unique-node 'unique-edge 'nodes-must-exists 'safe
|
||||
;; 'safe is a short for '(unique-node unique-edge nodes-must-exists)
|
||||
(define (make-graph . flags)
|
||||
(let ((flag-hash (make-hash)))
|
||||
(set! flags (expands-safe-flag flags))
|
||||
(for-each (lambda (flag) (hash-put! flag-hash flag true)) flags)
|
||||
(if (member 'equal flags)
|
||||
(make-t flag-hash 0 0 (make-hash 'equal) (make-hash 'equal) (make-hash 'equal))
|
||||
(make-t flag-hash 0 0 (make-hash) (make-hash) (make-hash)))))
|
||||
|
||||
(define (graph? graph) (t? graph))
|
||||
|
||||
(define no-value (box empty))
|
||||
|
||||
;; Makes a hash with the same 'equal as the graph
|
||||
(define (graph-make-hash graph)
|
||||
(if (graph-has-flag? graph 'equal)
|
||||
(make-hash 'equal)
|
||||
(make-hash)))
|
||||
|
||||
|
||||
(define (expands-safe-flag flags)
|
||||
(let loop ((cur flags) (acc empty))
|
||||
(cond [(empty? cur) acc]
|
||||
[(eq? (first cur) 'safe) (loop (rest cur) (append '(unique-node unique-edge nodes-must-exists) flags))]
|
||||
[true (loop (rest cur) (cons (first cur) acc))])))
|
||||
|
||||
;; Make a graph with mostly the same flags as another graph
|
||||
(define (graph-make-similar graph plus-flags minus-flags)
|
||||
(set! plus-flags (expands-safe-flag plus-flags))
|
||||
(set! minus-flags (expands-safe-flag minus-flags))
|
||||
(apply make-graph
|
||||
(append plus-flags
|
||||
(filter (lambda (i) (not (member i minus-flags)))
|
||||
(hash-keys (t-flags graph))))))
|
||||
|
||||
(define (graph-copy graph)
|
||||
(let* ((rtn-nodes (graph-make-hash graph))
|
||||
(rtn-successors (graph-make-hash graph))
|
||||
(rtn-predessessors (graph-make-hash graph))
|
||||
(rtn (make-t (t-flags graph) (t-nNodes graph) (t-nEdges graph) rtn-nodes rtn-successors rtn-predessessors)))
|
||||
|
||||
(hash-add-all! rtn-nodes (t-nodes graph))
|
||||
(hash-add-all! rtn-successors (t-successors graph))
|
||||
(hash-add-all! rtn-predessessors (t-predessessors graph))
|
||||
rtn))
|
||||
|
||||
(define (graph-add-all! dest-graph src-graph)
|
||||
(graph-for-each-node
|
||||
src-graph
|
||||
(lambda (node)
|
||||
(if (graph-node-has-label? src-graph node)
|
||||
(graph-node-add! dest-graph node (graph-node-label src-graph node))
|
||||
(graph-node-add! dest-graph node))))
|
||||
(graph-for-each-edge
|
||||
src-graph
|
||||
(lambda (from to)
|
||||
(if (graph-edge-has-label? src-graph from to)
|
||||
(graph-edge-add! dest-graph from to (graph-edge-label src-graph from to))
|
||||
(graph-edge-add! dest-graph from to)))))
|
||||
|
||||
(define (graph-has-flag? graph flag)
|
||||
(hash-mem? (t-flags graph) flag))
|
||||
|
||||
(define (graph-directed? graph)
|
||||
(hash-mem? (t-flags graph) 'directed))
|
||||
|
||||
;;; =====================================================================
|
||||
;;; Nodes
|
||||
|
||||
(define (graph-nodes graph) (hash-keys (t-nodes graph)))
|
||||
|
||||
(define (graph-nodes-size graph) (t-nNodes graph))
|
||||
|
||||
(define graph-make-node!
|
||||
(case-lambda
|
||||
[(graph) (graph-make-node! graph no-value)]
|
||||
[(graph val)
|
||||
(let ((sym (string->symbol (string-append "node" (number->string (t-nNodes graph))))))
|
||||
(graph-node-add! graph sym val)
|
||||
sym)]))
|
||||
|
||||
;; Add a node to the graph. If the node already exists,
|
||||
;; sets its label, unless the graph has the 'unique-node property,
|
||||
;; in which case this will assert.
|
||||
(define graph-node-add!
|
||||
(case-lambda
|
||||
[(graph node) (graph-node-add! graph node no-value)]
|
||||
[(graph node val)
|
||||
(if (hash-mem? (t-nodes graph) node)
|
||||
(assert (not (graph-has-flag? graph 'unique-node)))
|
||||
(begin
|
||||
(set-t-nNodes! graph (+ 1 (t-nNodes graph)))
|
||||
(hash-put! (t-successors graph) node (graph-make-hash graph))
|
||||
(if (graph-directed? graph)
|
||||
(hash-put! (t-predessessors graph) node (graph-make-hash graph)))))
|
||||
(hash-put! (t-nodes graph) node val)]))
|
||||
|
||||
(define (graph-node-mem? graph node)
|
||||
(hash-mem? (t-nodes graph) node))
|
||||
|
||||
(define (graph-node-set! graph node val)
|
||||
(assert (hash-mem? (t-nodes graph) node))
|
||||
(hash-put! (t-nodes graph) node val))
|
||||
|
||||
(define (graph-node-remove! graph node)
|
||||
(assert (graph-node-mem? graph node))
|
||||
(for-each (lambda (i) (graph-edge-remove! graph node i))
|
||||
(hash-keys (hash-get (t-successors graph) node)))
|
||||
|
||||
(if (graph-directed? graph)
|
||||
(for-each (lambda (i) (graph-edge-remove! graph i node))
|
||||
(hash-keys (hash-get (t-predessessors graph) node))))
|
||||
|
||||
(hash-remove! (t-nodes graph) node)
|
||||
(hash-remove! (t-successors graph) node)
|
||||
(if (graph-directed? graph)
|
||||
(hash-remove! (t-predessessors graph) node))
|
||||
(set-t-nNodes! graph (- (t-nNodes graph) 1)))
|
||||
|
||||
(define graph-node-collapse!
|
||||
(case-lambda
|
||||
[(graph node with-self-loop) (graph-node-collapse! graph node with-self-loop (lambda (pred-label succ-label) no-value))]
|
||||
[(graph node with-self-loop label-fn)
|
||||
(let ((is-directed (graph-directed? graph)))
|
||||
(for-each
|
||||
|
||||
(lambda (pred)
|
||||
(for-each
|
||||
(lambda (succ)
|
||||
(unless (or (and (not is-directed) (eq? pred succ))
|
||||
(graph-edge-mem? graph pred succ))
|
||||
(let* ((label-pred (hash-get (hash-get (t-successors graph) pred) node))
|
||||
(label-succ (hash-get (hash-get (t-successors graph) node) succ))
|
||||
(new-label (label-fn (if (eq? label-pred no-value) false label-pred)
|
||||
(if (eq? label-succ no-value) false label-succ))))
|
||||
(when (or with-self-loop (not (eq? pred succ)))
|
||||
(hash-put! (hash-get (t-successors graph) pred) succ new-label)
|
||||
(if is-directed
|
||||
(hash-put! (hash-get (t-predessessors graph) succ) pred new-label)
|
||||
(hash-put! (hash-get (t-successors graph) succ) pred new-label))))))
|
||||
(hash-keys (hash-get (t-successors graph) node))))
|
||||
|
||||
(hash-keys (hash-get
|
||||
(if is-directed (t-predessessors graph) (t-successors graph))
|
||||
node))))
|
||||
(graph-node-remove! graph node)]))
|
||||
|
||||
(define (graph-node-has-label? graph node)
|
||||
(not (eq? (hash-get (t-nodes graph) node) no-value)))
|
||||
|
||||
(define (graph-node-label graph node)
|
||||
(let ((r (hash-get (t-nodes graph) node)))
|
||||
(if (eq? r no-value) (error "graph-node-label: no value for node" node)
|
||||
r)))
|
||||
|
||||
(define (graph-succs graph node)
|
||||
(assert (graph-directed? graph))
|
||||
(hash-keys (hash-get (t-successors graph) node)))
|
||||
|
||||
(define (graph-preds graph node)
|
||||
(assert (graph-directed? graph))
|
||||
(hash-keys (hash-get (t-predessessors graph) node)))
|
||||
|
||||
(define (graph-adjs graph node)
|
||||
(if (graph-directed? graph)
|
||||
(append (hash-keys (hash-get (t-successors graph) node))
|
||||
(hash-keys (hash-get (t-predessessors graph) node)))
|
||||
(hash-keys (hash-get (t-successors graph) node))))
|
||||
|
||||
(define (graph-for-each-adjs graph node fn)
|
||||
(for-each (hash-keys (hash-get (t-successors graph) node))
|
||||
(lambda (succ) (fn node succ)))
|
||||
(when (graph-directed? graph)
|
||||
(for-each (hash-keys (hash-get (t-predessessors graph) node))
|
||||
(lambda (pred) (fn pred node)))))
|
||||
|
||||
(define (graph-for-each-node graph fn)
|
||||
(for-each fn (hash-keys (t-nodes graph))))
|
||||
|
||||
(define (graph-fold-nodes graph init fn)
|
||||
(let ((acc init))
|
||||
(graph-for-each-node
|
||||
graph
|
||||
(lambda (node) (set! acc (fn node acc))))
|
||||
acc))
|
||||
|
||||
;;; =====================================================================
|
||||
;;; Edges
|
||||
|
||||
(define (graph-edges graph)
|
||||
(let ((rtn empty))
|
||||
(graph-for-each-edge graph (lambda (from to) (set! rtn (cons from to))))
|
||||
rtn))
|
||||
|
||||
(define (graph-edges-size graph) (t-nEdges graph))
|
||||
|
||||
;; Add an edge to the graph. If the edge already exists,
|
||||
;; sets its label, unless the graph has the 'unique-edge property,
|
||||
;; in which case this will assert.
|
||||
(define graph-edge-add!
|
||||
(case-lambda
|
||||
[(graph from to) (graph-edge-add! graph from to no-value)]
|
||||
[(graph from to val)
|
||||
|
||||
(if (graph-edge-mem? graph from to)
|
||||
(assert (not (graph-has-flag? graph 'unique-edge)))
|
||||
(set-t-nEdges! graph (+ (t-nEdges graph) 1)))
|
||||
|
||||
(if (graph-has-flag? graph 'nodes-must-exists)
|
||||
(assert (and (graph-node-mem? graph from) (graph-node-mem? graph to)))
|
||||
(begin (if (not (graph-node-mem? graph from)) (graph-node-add! graph from))
|
||||
(if (not (graph-node-mem? graph to)) (graph-node-add! graph to))))
|
||||
|
||||
(hash-put! (hash-get (t-successors graph) from) to val)
|
||||
|
||||
(if (graph-directed? graph)
|
||||
(hash-put! (hash-get (t-predessessors graph) to) from val)
|
||||
(hash-put! (hash-get (t-successors graph) to) from val))]))
|
||||
|
||||
(define (graph-edge-mem? graph from to)
|
||||
(if (graph-has-flag? graph 'nodes-must-exists)
|
||||
(assert (and (graph-node-mem? graph from)
|
||||
(graph-node-mem? graph to))))
|
||||
|
||||
(and (hash-mem? (t-successors graph) from)
|
||||
(hash-mem? (hash-get (t-successors graph) from) to)))
|
||||
|
||||
(define (graph-edge-set! graph from to val)
|
||||
(assert (graph-edge-mem? graph from to))
|
||||
(hash-put! (hash-get (t-successors graph) from) to val)
|
||||
|
||||
(if (graph-directed? graph)
|
||||
(hash-put! (hash-get (t-predessessors graph) to) from val)
|
||||
(hash-put! (hash-get (t-successors graph) to) from val)))
|
||||
|
||||
(define (graph-edge-remove! graph from to)
|
||||
(assert (graph-edge-mem? graph from to))
|
||||
(hash-remove! (hash-get (t-successors graph) from) to)
|
||||
|
||||
(if (graph-directed? graph)
|
||||
(hash-remove! (hash-get (t-predessessors graph) to) from)
|
||||
(hash-remove! (hash-get (t-successors graph) to) from)))
|
||||
|
||||
(define (graph-edge-has-label? graph from to)
|
||||
(not (eq? (hash-get (hash-get (t-successors graph) from) to) no-value)))
|
||||
|
||||
(define (graph-edge-label graph from to)
|
||||
(let ((r (hash-get (hash-get (t-successors graph) from) to)))
|
||||
(if (eq? r no-value) (error "graph-edge-label: no value for edge" (cons from to)))
|
||||
r))
|
||||
|
||||
(define (graph-for-each-edge graph fn)
|
||||
(graph-for-each-node
|
||||
graph
|
||||
(lambda (from)
|
||||
(for-each (lambda (to) (fn from to))
|
||||
(hash-keys (hash-get (t-successors graph) from))))))
|
||||
|
||||
(define (graph-fold-edges graph init fn)
|
||||
(let ((acc init))
|
||||
(graph-for-each-edge
|
||||
graph
|
||||
(lambda (from to) (set! acc (fn from to acc))))
|
||||
acc))
|
||||
|
||||
;;; =====================================================================
|
||||
;;; Algos
|
||||
|
||||
(define (graph-dfs-from-node-with-log graph node dealt-with pre-fn post-fn backward)
|
||||
(assert (or (not backward) (graph-directed? graph)))
|
||||
(if (not (hash-mem? dealt-with node))
|
||||
(begin (hash-put! dealt-with node true)
|
||||
(pre-fn node)
|
||||
(for-each (lambda (n) (graph-dfs-from-node-with-log graph n dealt-with pre-fn post-fn backward))
|
||||
(if backward
|
||||
(hash-keys (hash-get (t-predessessors graph) node))
|
||||
(hash-keys (hash-get (t-successors graph) node))))
|
||||
(post-fn node))))
|
||||
|
||||
|
||||
(define graph-dfs-from-node
|
||||
(case-lambda
|
||||
[(graph node pre-fn) (graph-dfs-from-node graph node pre-fn (lambda (i) i))]
|
||||
[(graph node pre-fn post-fn)
|
||||
(graph-dfs-from-node-with-log graph node (graph-make-hash graph) pre-fn post-fn false)]))
|
||||
|
||||
(define graph-dfs-all
|
||||
(case-lambda
|
||||
[(graph pre-fn) (graph-dfs-all graph pre-fn (lambda (i) i))]
|
||||
[(graph pre-fn post-fn)
|
||||
(let ((dealt-with (graph-make-hash graph)))
|
||||
(graph-for-each-node graph (lambda (n) (if (not (hash-mem? dealt-with n))
|
||||
(graph-dfs-from-node-with-log graph n dealt-with pre-fn post-fn false)))))]))
|
||||
|
||||
|
||||
(define (graph-components graph)
|
||||
(let ((dealt-with (graph-make-hash graph)))
|
||||
(graph-fold-nodes
|
||||
graph
|
||||
empty
|
||||
(lambda (node acc)
|
||||
(if (hash-mem? dealt-with node) acc
|
||||
(let ((cur-component
|
||||
(let loop ((cur node) (acc empty))
|
||||
(if (hash-mem? dealt-with cur) acc
|
||||
(begin (hash-put! dealt-with cur true)
|
||||
(foldl (lambda (adj acc) (loop adj acc)) (cons cur acc)
|
||||
(graph-adjs graph cur)))))))
|
||||
(cons cur-component acc)))))))
|
||||
|
||||
(define (graph-strongly-connected-components graph)
|
||||
(assert (graph-directed? graph))
|
||||
(let ((finish-times empty)
|
||||
(dealt-with (graph-make-hash graph)))
|
||||
|
||||
(graph-for-each-node
|
||||
graph
|
||||
(lambda (n) (graph-dfs-from-node-with-log
|
||||
graph n dealt-with
|
||||
(lambda (i) i)
|
||||
(lambda (i) (set! finish-times (cons i finish-times)))
|
||||
false)))
|
||||
|
||||
(set! dealt-with (graph-make-hash graph))
|
||||
|
||||
(let ((component-graph (graph-make-similar graph empty '(safe equal)))
|
||||
(node2supernode (make-hash)))
|
||||
|
||||
(for-each
|
||||
(lambda (n)
|
||||
(if (not (hash-mem? dealt-with n))
|
||||
(let ((super-node (graph-make-node! component-graph empty)))
|
||||
(graph-dfs-from-node-with-log
|
||||
graph n dealt-with
|
||||
(lambda (i)
|
||||
(graph-node-set! component-graph super-node (cons i (graph-node-label component-graph super-node)))
|
||||
(hash-put! node2supernode i super-node))
|
||||
(lambda (i) i)
|
||||
true))))
|
||||
finish-times)
|
||||
(graph-for-each-edge graph
|
||||
(lambda (from to)
|
||||
(graph-edge-add! component-graph
|
||||
(hash-get node2supernode from)
|
||||
(hash-get node2supernode to))))
|
||||
(cons component-graph node2supernode))))
|
||||
|
||||
(define (graph-topological-sort graph)
|
||||
(assert (graph-directed? graph))
|
||||
(let ((rtn empty))
|
||||
(graph-dfs-all graph (lambda (i) i) (lambda (node) (set! rtn (cons node rtn))))
|
||||
rtn))
|
||||
|
||||
|
||||
;;; =====================================================================
|
||||
;;; Utils
|
||||
|
||||
(define graph-to-list
|
||||
(case-lambda
|
||||
[(graph) (graph-to-list graph false)]
|
||||
[(graph with-labels)
|
||||
(hash-map (t-nodes graph)
|
||||
(lambda (node node-val)
|
||||
(let ((node-rep (if (and with-labels (graph-node-has-label? graph node))
|
||||
(cons node (graph-node-label graph node))
|
||||
node)))
|
||||
(cons node-rep
|
||||
(hash-fold (hash-get (t-successors graph) node) empty
|
||||
(lambda (succ edge-val acc)
|
||||
(if (and with-labels (graph-edge-has-label? graph node succ))
|
||||
(cons (cons succ (graph-edge-label graph node succ)) acc)
|
||||
(cons succ acc))))))))]))
|
||||
|
||||
(define (graph-to-string-prv graph with-labels to-string)
|
||||
(let ([the-to-string (or to-string
|
||||
(lambda (item) (format "~a" item)))])
|
||||
(string-append (if (graph-directed? graph) "[di-graph: " "[undirected-graph:")
|
||||
(the-to-string (map (lambda (n)
|
||||
(cons (first n) (cons '--> (rest n))))
|
||||
(graph-to-list graph with-labels)))
|
||||
"]")))
|
||||
|
||||
(define (graph-to-string graph . to-string)
|
||||
(graph-to-string-prv graph false (if (empty? to-string) false (first to-string))))
|
||||
|
||||
(define (graph-to-string-with-labels graph . to-string)
|
||||
(graph-to-string-prv graph true (if (empty? to-string) true (first to-string))))
|
||||
|
||||
|
||||
;;; =====================================================================
|
||||
;;; Tests
|
||||
|
||||
(define (graph-test)
|
||||
(define graph (make-graph 'safe 'directed))
|
||||
|
||||
(graph-node-add! graph 'a)
|
||||
(graph-node-add! graph 'b 2)
|
||||
(graph-node-add! graph 'c 3)
|
||||
(graph-node-add! graph 'd)
|
||||
|
||||
(graph-edge-add! graph 'a 'c)
|
||||
(graph-edge-add! graph 'a 'd "asd")
|
||||
(graph-edge-add! graph 'b 'c "dfg")
|
||||
(graph-edge-add! graph 'b 'd)
|
||||
(graph-edge-add! graph 'd 'a)
|
||||
|
||||
(display (graph-node-mem? graph 'a))
|
||||
(display (graph-edge-mem? graph 'a 'c))
|
||||
(newline)
|
||||
(display (graph-node-mem? graph 'v))
|
||||
(display (graph-edge-mem? graph 'c 'a))
|
||||
(display (graph-edge-mem? graph 'a 'b))
|
||||
(newline)
|
||||
|
||||
(print-each (graph-to-list graph true))
|
||||
(graph-for-each-edge graph (lambda (a b) (print-each "A " a b)))
|
||||
|
||||
(graph-dfs-from-node graph 'a (lambda (i) (display i)))
|
||||
(newline)
|
||||
(graph-dfs-from-node graph 'b (lambda (i) (display i)))
|
||||
(newline)
|
||||
(graph-dfs-from-node graph 'c (lambda (i) (display i)))
|
||||
(newline)
|
||||
(graph-dfs-from-node graph 'd (lambda (i) (display i)))
|
||||
(newline)
|
||||
|
||||
(let ((star (make-graph 'directed)))
|
||||
(graph-edge-add! star 1 'x)
|
||||
(graph-edge-add! star 'x 1)
|
||||
(graph-edge-add! star 2 'x)
|
||||
(graph-edge-add! star 'x 3)
|
||||
(graph-edge-add! star 'x 4)
|
||||
(graph-edge-add! star 'x 5)
|
||||
(graph-node-collapse! star 'x false)
|
||||
(print-each "collapsed:" (graph-to-list star)))
|
||||
|
||||
(let ((strong-graph (make-graph 'directed)))
|
||||
|
||||
(graph-edge-add! strong-graph 'e 'a)
|
||||
(graph-edge-add! strong-graph 'a 'b)
|
||||
(graph-edge-add! strong-graph 'b 'e)
|
||||
(graph-edge-add! strong-graph 'e 'f)
|
||||
(graph-edge-add! strong-graph 'b 'f)
|
||||
(graph-edge-add! strong-graph 'b 'c)
|
||||
(graph-edge-add! strong-graph 'f 'g)
|
||||
(graph-edge-add! strong-graph 'g 'f)
|
||||
(graph-edge-add! strong-graph 'c 'g)
|
||||
(graph-edge-add! strong-graph 'c 'd)
|
||||
(graph-edge-add! strong-graph 'd 'c)
|
||||
(graph-edge-add! strong-graph 'g 'h)
|
||||
(graph-edge-add! strong-graph 'd 'h)
|
||||
(graph-edge-add! strong-graph 'h 'h)
|
||||
|
||||
(graph-edge-add! strong-graph 'xa 'xb)
|
||||
(graph-edge-add! strong-graph 'xb 'xc)
|
||||
(graph-edge-add! strong-graph 'xc 'xa)
|
||||
|
||||
(print-each "strong-graph" strong-graph)
|
||||
(print-each "component" (graph-components strong-graph))
|
||||
(let ((components (graph-strongly-connected-components strong-graph)))
|
||||
(print-each "strong-components" components)
|
||||
(print-each "toposort" (graph-topological-sort (first components)))))
|
||||
|
||||
(let ((u-graph (make-graph)))
|
||||
(graph-edge-add! u-graph 'a 'b)
|
||||
(graph-edge-add! u-graph 'b 'c)
|
||||
(graph-edge-add! u-graph 'c 'd)
|
||||
(graph-edge-add! u-graph 'd 'a)
|
||||
(graph-edge-add! u-graph 'd 'e)
|
||||
(graph-edge-add! u-graph 'e 'c)
|
||||
|
||||
(graph-edge-add! u-graph 'xa 'xb)
|
||||
(graph-edge-add! u-graph 'xa 'xc)
|
||||
(graph-edge-add! u-graph 'xb 'xd)
|
||||
(newline)
|
||||
(print-each "u-graph" u-graph)
|
||||
(graph-edge-remove! u-graph 'b 'a)
|
||||
(graph-node-remove! u-graph 'd)
|
||||
(print-each "u-graph" u-graph)
|
||||
(print-each "component" (graph-components u-graph)))
|
||||
|
||||
)
|
||||
;(graph-test)
|
||||
)
|
||||
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
(require (lib "mztake.ss" "mztake"))
|
||||
(set-main! '(lib "heap.ss" "frtime"))
|
||||
|
||||
(define start (current-milliseconds))
|
||||
(set-running! #t)
|
||||
(exited?)
|
||||
(- (hold (map-e (lambda (e) (current-milliseconds))
|
||||
(changes (exited?)))) start)
|
||||
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
(require (lib "mztake.ss" "mztake")
|
||||
(lib "useful-code.ss" "mztake"))
|
||||
|
||||
(set-main! "exception.ss")
|
||||
|
||||
(printf-b "exception.ss exited? ~a" (exited?))
|
||||
|
||||
(printf-b "last exception seen: ~a" (exceptions))
|
||||
|
||||
(set-running! true)
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
(module exception mzscheme
|
||||
(thread (lambda () (raise 'exn:oops-made-a-mztake!))))
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
(require (lib "mztake.ss" "mztake")
|
||||
(lib "animation.ss" "frtime")
|
||||
(lib "useful-code.ss" "mztake"))
|
||||
|
||||
(define/bind (loc "highway.ss" 4) speed)
|
||||
|
||||
(printf-b "current speed: ~a" speed)
|
||||
|
||||
(define (make-speed-gauge speed)
|
||||
(let ([center (make-posn 200 200)])
|
||||
(list (make-circle center 170 "black")
|
||||
(make-circle center 160 "white")
|
||||
(make-rect (make-posn 0 202) 1000 1000 "white")
|
||||
(make-line (make-posn 30 201) (make-posn 370 201) "black")
|
||||
(make-line center
|
||||
(posn+ center (make-posn (- (* 150 (cos (/ speed 30))))
|
||||
(- (* 150 (sin (/ speed 30))))))
|
||||
"red"))))
|
||||
|
||||
|
||||
(display-shapes (make-speed-gauge speed))
|
||||
|
||||
(set-running! (< speed 55))
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
(module highway mzscheme
|
||||
(let ([nap-time 0.8])
|
||||
(let loop ([speed 0])
|
||||
(sleep nap-time)
|
||||
;; Generate some fake speeds readings:
|
||||
(loop (+ speed 4)))))
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
(module picture mzscheme
|
||||
|
||||
(require (lib "graphics.ss" "graphics")
|
||||
(lib "math.ss"))
|
||||
|
||||
(open-graphics)
|
||||
|
||||
(define d 400)
|
||||
|
||||
(define viewport (open-viewport "Blah" (* 2 d) (* 2 d)))
|
||||
|
||||
(values 1 2 3)
|
||||
|
||||
(define-syntax for
|
||||
(syntax-rules (=)
|
||||
[(_ (var = init) condn delta proc ...)
|
||||
(let loop ([var init])
|
||||
(when condn
|
||||
proc ...
|
||||
(loop (delta var))))]))
|
||||
|
||||
(for (i = (- d)) (< i d) add1
|
||||
(for (j = (- d)) (< j d) add1
|
||||
(when (<= (+ (sqr i) (sqr j)) (sqr d))
|
||||
((draw-pixel viewport) (make-posn (+ d i) (+ d j))
|
||||
(if (or (zero? i) (zero? j))
|
||||
(make-rgb 0 0 1)
|
||||
(let ([i (- 1 (/ (abs (gcd i j)) (+ (abs i) (abs j))))])
|
||||
(make-rgb i i 1))))))))
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
(require (lib "mztake.ss" "mztake" )
|
||||
(lib "match.ss")
|
||||
(lib "base-gm.ss" "frtime")
|
||||
(only mzscheme hash-table-map))
|
||||
|
||||
(set-main! "picture.ss")
|
||||
|
||||
(define (hash-table-increment! h k)
|
||||
(let ([old (hash-get h k (lambda () 0))])
|
||||
(hash-put! h k (add1 old))))
|
||||
|
||||
(define pings (make-hash 'equal))
|
||||
|
||||
(for-each-e! (where)
|
||||
(match-lambda [(line function context rest ...)
|
||||
(hash-table-increment! pings (list function context))]
|
||||
[_ (void)]))
|
||||
|
||||
(define clicks (changes (quotient milliseconds 50)))
|
||||
|
||||
(set-running-e! (merge-e (clicks . -=> . false)
|
||||
(clicks . -=> . true)))
|
||||
|
||||
(define (hash-pairs ht)
|
||||
(hash-table-map ht (lambda (k v) (list k v))))
|
||||
|
||||
(define (show-profile)
|
||||
(sort (hash-pairs pings) (lambda (a b) (> (second a) (second b)))))
|
||||
|
|
@ -1,519 +0,0 @@
|
|||
|
||||
|
||||
============================================================
|
||||
|
||||
About MzTake
|
||||
|
||||
_MzTake_ is a _scripted debugger_ for PLT Scheme. It helps
|
||||
programmers monitor the execution of a target program as it
|
||||
unfolds (and optionally pause or resume its execution). MzTake
|
||||
gives you the power to easily write real programs that debug real
|
||||
programs. You are no longer limited to a tool chest of buttons
|
||||
like "add breakpoint", "step-next", "step-into", and "step-over".
|
||||
|
||||
MzTake scripts are written in the FrTime programming
|
||||
language, which is bundled with DrScheme. FrTime supports the
|
||||
implementation of reactive systems in a functional style.
|
||||
The key abstraction it adds is a type of value called a 'signal',
|
||||
which can change over time. FrTime infers dataflow dependencies
|
||||
between signals and automatically recomputes them when necessary. In
|
||||
order to use MzTake, you will need to familiarize yourself with the
|
||||
FrTime language by reading its own documentation.
|
||||
|
||||
With signals it is possible to respond to outside events concisely,
|
||||
without using callbacks. Consider a MzTake script to monitor the
|
||||
behavior of the program "highway-mztake.ss", in the demos directory of
|
||||
the MzTake collection:
|
||||
|
||||
(require (lib "mztake.ss" "mztake"))
|
||||
(define/bind (loc "highway.ss" 4) speed)
|
||||
(printf-b "current speed: ~a" speed)
|
||||
;; more code
|
||||
(set-running! true)
|
||||
|
||||
This code executes a target module in the file "highway.ss"
|
||||
after installing a _trace point_ (also known as a _watch
|
||||
point_) just before the Scheme expression on the fourth line
|
||||
of "highway.ss". SPEED is a FrTime behavior that always
|
||||
contains the *current* value of the variable named SPEED in
|
||||
the target program.
|
||||
|
||||
PRINTF-B works like Scheme's PRINTF function, consuming a
|
||||
format-string and fill-values, printing the result in
|
||||
DrScheme's interaction pane. Whereas PRINTF accumulates
|
||||
outdated text on the screen, PRINTF-B will replace old text
|
||||
with updated text if any of the fill-values change. In this
|
||||
invocation, it prints the current speed to screen, throughout
|
||||
the execution of "highway.ss". The last line invokes SET-RUNNING!,
|
||||
which lunches the execution of highway.ss
|
||||
|
||||
MzTake scripts are also powerful tools for building external
|
||||
test suites. Whereas typical test cases may only assert that
|
||||
the result of a computation is correct, MzTake scripts
|
||||
can dynamically break open an execution, record inner state,
|
||||
and *compute* with it. This allows you to confirm that the
|
||||
intermediate steps which lead to a correct answer were
|
||||
also correct. In the highway example, perhaps knowing the last ten speeds
|
||||
would prove useful. You could PRINTF the value
|
||||
onto a new line each time, but after ten updates the screen
|
||||
is already starting to fill up with information -- we are
|
||||
only interested in the last ten speeds, after all.
|
||||
One possible solution:
|
||||
|
||||
(printf-b "last ten speeds: ~a" (history-b (changes speed) 10))
|
||||
|
||||
HISTORY-B consumes an event stream (CHANGES SPEED) and an
|
||||
optional number n, returning a FrTime behavior containing a
|
||||
FIFO ordered list of the n values emitted on that event
|
||||
stream. In this case, HISTORY-B maintains a list of the ten
|
||||
most recent SPEEDS seen on SPEED.
|
||||
|
||||
We might want to pause the program when something goes awry. We do
|
||||
this by exploiting the fact that the SET-RUNNING! function consumes a
|
||||
FrTime behavior. The value of a behavior can change over time, and
|
||||
SET-RUNNING! monitors these changes. Whenever the behavior is true,
|
||||
the target program runs, and whenever it is false, the target program
|
||||
pauses. We can indicate to MzTake to pause when the speed exceeds 55
|
||||
as follow:
|
||||
|
||||
(printf-b "last ten speeds: ~a" (history-b (changes speed) 10))
|
||||
(set-running! (< speed 55))
|
||||
|
||||
Once paused, it is possible to interactively explore the state of the
|
||||
paused process. You may enter names of variables bound in the target
|
||||
program, and MzTake will look up and return their values. For
|
||||
example, typing 'nap-time' in the REPL while the program is paused
|
||||
yields the value 0.8.
|
||||
|
||||
You can resume execution with "(set-running #t)", or
|
||||
some other behavior, or end the execution altogether with "(kill)".
|
||||
|
||||
Finally, FrTime provides a rich animation library. Combined
|
||||
with the MzTake debugger, it takes only a few lines to animate
|
||||
your algorithms and see them in action, easily letting you
|
||||
confirm (or refute!) that they are working correctly.
|
||||
|
||||
(require (lib "animation.ss" "frtime"))
|
||||
(display-shapes (make-speed-gauge (hold speed)))
|
||||
|
||||
|
||||
============================================================
|
||||
|
||||
Demos
|
||||
|
||||
The demos directory contains a sub-directory for each of the demos.
|
||||
For instance, the highway directory contains "highway.ss" and
|
||||
"highway-mztake.ss". To run this demo, switch to the "FrTime" language
|
||||
level from the "Experimental Languages" section of DrScheme's language
|
||||
dialog, load "highway-mztake.ss", and click "Run". What you see is
|
||||
generated by the debugging script. Each demo directory contains
|
||||
the following two files: one is the program being debugged
|
||||
(named after the directory), and the other is a file ending
|
||||
in "...-mztake.ss" (the MzTake script).
|
||||
|
||||
The demos are (starting with the simplest one):
|
||||
|
||||
./highway/highway-mztake.ss - The program simulates a very simple
|
||||
speedometer, and the MzTake script
|
||||
monitors it.
|
||||
|
||||
./sine/sine-mztake.ss - Plots values extracted from a program
|
||||
which generates coordinates for a
|
||||
single sine wave.
|
||||
|
||||
./random/random-mztake.ss - Tests the quality of Scheme's random
|
||||
number generator with a histogram.
|
||||
|
||||
./exception/exception-mztake.ss - Demonstrates how MzTake catches exceptions.
|
||||
|
||||
./djikstra/dijkstra-mztake.ss - Debugs a buggy implementation of
|
||||
Dijkstra's algorithm
|
||||
|
||||
|
||||
The demos demonstrate many ways to debug with MzTake using
|
||||
FrTime, even if you are not very familiar with the language.
|
||||
That said, in order to become more proficient in using MzTake,
|
||||
you will want to learn more about the FrTime language.
|
||||
|
||||
You can refer to FrTime's own documentation by searching for
|
||||
"FrTime" in DrScheme's Help window. It explains how to use
|
||||
time-varying behaviors and event streams in greater depth, and
|
||||
also describes the many useful functions FrTime provides to work
|
||||
with them.
|
||||
|
||||
|
||||
|
||||
============================================================
|
||||
|
||||
_Debugging with MzTake_
|
||||
|
||||
MzTake is a library for the FrTime languages which provides functions
|
||||
that execute a target program (or many), and "connect" to points in
|
||||
its code. MzTake then provides the running FrTime script with
|
||||
interesting information (such as a variable's current value) which it
|
||||
derives from these "connections". FrTime then handles the rest.
|
||||
|
||||
MzTake defines the following functions and macros:
|
||||
|
||||
_Installing Trace Points_
|
||||
|
||||
> (loc require-spec line-number)
|
||||
> (loc require-spec line-number column-number)
|
||||
|
||||
Creates a LOC structure containing the target file, the target line
|
||||
number, and (optionally) the target column number. LOC structures
|
||||
are consumed by TRACE and by DEFINE/BIND. The first argument to LOC
|
||||
is a file specification suitable for require, provided as a
|
||||
datum. For instance, to install a trace point on the tenth line of
|
||||
the MzLib's list library, use:
|
||||
|
||||
(trace (loc '(lib "list.ss") 10) <body> )
|
||||
|
||||
> (loc require-spec pattern)
|
||||
|
||||
The LOC function can also accept a pattern. MzTake will scan the
|
||||
text of the target source file and install a breakpoint at every
|
||||
location where the text matches the pattern. The pattern language
|
||||
is very simple. Every symbol in the pattern is taken literally,
|
||||
with the exception of the underscore. In a pattern, and underscore
|
||||
stand for zero, one, or many items. Unlike the patterns used by
|
||||
match.ss, MzTake does not make use of an ellipsis to indicate
|
||||
repetition. The repetition is always implicit. The following
|
||||
expression inserts a tracepoint on every lambda expression that has
|
||||
exactly one argument, called "l" :
|
||||
|
||||
(trace (loc '(lib "list.ss") '(lambda (l) _)) <body> )
|
||||
|
||||
> (trace loc body ...)
|
||||
|
||||
Install a trace point at the location indicated by the LOC value.
|
||||
The result is a FrTime event stream containing one value each time
|
||||
the target reaches the location specified. To get the value event,
|
||||
TRACE evaluates its body (once per event. During the evaluation of
|
||||
the body, the target process is paused, and the body can inspect
|
||||
the state of the paused program.
|
||||
|
||||
The body is optional. If no body is provided, the value #t is used
|
||||
by default.
|
||||
|
||||
Unless SET-MAIN! is used, the first call to trace sets the file
|
||||
name that will be run when SET-RUNNING! is invoked the first time.
|
||||
|
||||
> (trace* process loc thunk)
|
||||
|
||||
Like TRACE, but takes an explicit process argument, and a thunk
|
||||
rather than a body.
|
||||
|
||||
> (bind (name ...) body ...)
|
||||
|
||||
When the target process is paused (or during the execution of a
|
||||
trace body), BIND reaches in the lexical context at the point of
|
||||
the pause (or of the trace point) and finds the values for the
|
||||
variables whose names are given. These values are then bound in the
|
||||
body (in the MzTake script) to the variables of the same name.
|
||||
|
||||
It is an error to call BIND while the target process is running.
|
||||
|
||||
You can use BIND to look up values of identifiers in the target
|
||||
program that are shadowed by identifiers in the script.
|
||||
|
||||
> (bind* process symbol)
|
||||
|
||||
In the given process, find the variable whose name has the given
|
||||
symbol, and returns its value.
|
||||
|
||||
|
||||
> (define/bind loc name ...)
|
||||
|
||||
Define the NAMEs to behaviors reflecting the values of the
|
||||
given names in the target program, at the given
|
||||
location. DEFINE/BIND is short for:
|
||||
|
||||
(define name (hold (trace loc (bind (name) name))))
|
||||
|
||||
|
||||
> (define/bind-e loc name ...)
|
||||
|
||||
Same as DEFINE/BIND, but binds event streams to the names instead
|
||||
of behaviors.
|
||||
|
||||
|
||||
> (exceptions)
|
||||
> (exceptions process)
|
||||
|
||||
Returns an event stream containing one EXN structure for each
|
||||
exception raised in the target process and not caught.
|
||||
|
||||
|
||||
> (exited?)
|
||||
> (exited? process)
|
||||
|
||||
Returns a behavior which starts as #f and take on the value #t when
|
||||
the target process exits.
|
||||
|
||||
|
||||
> (set-running! val)
|
||||
> (set-running! val process)
|
||||
> (set-running! event)
|
||||
> (set-running! event process)
|
||||
|
||||
Launches the execution of the target process. Execution continues
|
||||
as long as the given behavior is true (aka, any value beside #f),
|
||||
or until an event comes on the given event stream with the value
|
||||
#f. When execution pauses, the target remains on the line where
|
||||
the pause occured. You can then inspect the state of the program,
|
||||
or resume execution with another call to SET-RUNNING!.
|
||||
|
||||
|
||||
> (set-main! require-spec)
|
||||
> (set-main! require-spec process)
|
||||
|
||||
Sets the file where execution begins when SET-RUNNING! is called
|
||||
for the first time. When SET-MAIN! is not used explicitly,
|
||||
execution begins with the file specified in the first call to
|
||||
TRACE. It is an error to call SET-RUNNING! without first calling
|
||||
either TRACE or SET-MAIN!.
|
||||
|
||||
|
||||
> (where)
|
||||
> (where process)
|
||||
|
||||
Returns an event stream that contains one event for each expression
|
||||
evaluated in the target process. Combined with HISTORY-B, this makes
|
||||
it possible to record entire execution traces for the target program.
|
||||
|
||||
|
||||
> (kill)
|
||||
|
||||
Kills the target process and releases all resources
|
||||
it used -- you cannot resume after a KILL.
|
||||
|
||||
This will not stop evaluation of the MzTake script, however. In
|
||||
particular, if the script depends on input the varies independently
|
||||
of the target process, FrTime will continue to update them. You can
|
||||
use "Kill" command from DrScheme's "Scheme" menu to stop both the
|
||||
MzTake script and its target process at once.
|
||||
|
||||
Also, note that closing a FrTime animation/graphics window does *not*
|
||||
kill a running MzTake process.
|
||||
|
||||
> (kill-all)
|
||||
|
||||
When using more than one target process at a time, KILL-ALL invokes
|
||||
KILL on all of them at once.
|
||||
|
||||
|
||||
> (current-process)
|
||||
> (current-process process)
|
||||
|
||||
The CURRENT-PROCESS parameter gets or sets the process manipulated
|
||||
by the MzTake function when they are not provided with a process
|
||||
argument. The CURRENT-PROCESS parameter is initialized with a blank
|
||||
process, and you can create additional processes using the
|
||||
CREATE-DEBUG-PROCESS function. Using more than one process at a
|
||||
time lets your MzTake run multiple programs different at once and
|
||||
compare their output using a single script.
|
||||
|
||||
|
||||
> (create-debug-process)
|
||||
|
||||
Creates a fresh blank debug process. Each debug process has its own
|
||||
set of trace points, its own run trigger (set via SET-RUNNING!),
|
||||
its own exceptions stream, etc. Each debug process run
|
||||
independently from the others, and they can be paused and killed
|
||||
individually. All debug processes in a single MzTake script share
|
||||
the same FrTime event space, and so it is possible to compare
|
||||
output and traces between each of them.
|
||||
|
||||
> (current-policy)
|
||||
> (current-policy policy)
|
||||
|
||||
Every file executed under MzTake can run either in fast mode or in
|
||||
debuggable mode. The CURRENT-POLICY decides which.
|
||||
|
||||
- debuggable mode: the file is instrumented with MzTake debugging
|
||||
information. It can be the target of tracepoint and it generate
|
||||
events on the WHERE stream. Execution can also be paused in the middle
|
||||
of code running in debuggable mode. The instrumentation overhead
|
||||
is considerable, however, of the order of 10x-20x slowdown.
|
||||
|
||||
- fast mode: the file is not instrumented, and runs at its normal
|
||||
speed, but cannot be debugged. Inserting trace points into fast
|
||||
mode files after the beginning of the execution has no
|
||||
effect. Also, pausing while executing a fast mode file will be
|
||||
delayed until execution reaches a debuggable mode file.
|
||||
|
||||
Files that are the target of a trace point when first lunching the
|
||||
process run in debuggable mode, so is the main file set by
|
||||
SET-MAIN!. Otherwise, the current policy is consulted to decide
|
||||
between fast and debuggable mode. In this case, if the policy does
|
||||
not decide, MzTake raises an error.
|
||||
|
||||
Policies have the following contract:
|
||||
|
||||
(listof (list/c (symbols 'fast 'debuggable)
|
||||
(union (symbols 'everything-else)
|
||||
path?
|
||||
string?
|
||||
(listof (union path? string?)))))
|
||||
|
||||
A policy consist of a list of entries. Each entry is a pair
|
||||
specifying either fast mode or debuggable mode, then a directory,
|
||||
or a list of directories. Files in these directories, or their
|
||||
subdirectories will run under the given mode. The special symbol
|
||||
'everything-else can be used instead of a directory, and this will
|
||||
match any file. The policy is checked in order, and the first entry
|
||||
that applies to the given filename assign a mode the file.
|
||||
|
||||
The default policy run files of the directories specified by
|
||||
CURRENT-LIBRARY-COLLECTIONS-PATHS in fast mode, and runs everything
|
||||
else in debuggable mode. This poloicy is set as follow:
|
||||
|
||||
(current-policy `((fast ,(current-library-collection-paths))
|
||||
(debuggable everything-else)))
|
||||
|
||||
You can change this policy by calling the
|
||||
CURRENT-POLICY function with a new policy as an argument. The
|
||||
policy is assigned to a process when the process lunches.
|
||||
|
||||
|
||||
_Useful Functions for Time-Varying Values_
|
||||
|
||||
Note: FrTime uses a naming convention where functions which
|
||||
return behaviors have names that end in "-b", and
|
||||
functions that return event streams end in "-e".
|
||||
|
||||
Tips: When you have a behavior that you want to turn into
|
||||
an event, use "(changes behavior)".
|
||||
|
||||
When you have an event that you want to be a
|
||||
behavior, use "(hold event)"
|
||||
|
||||
|
||||
MzTake defines a few functions on time-varying values
|
||||
that are particularly useful when debugging. You can require these
|
||||
functions with (require (lib "useful-code.ss" "mztake"))
|
||||
|
||||
> (history-e stream)
|
||||
> (history-b stream)
|
||||
|
||||
Keeps a complete history of all the values seen
|
||||
on an event stream as a list, oldest events last.
|
||||
|
||||
Use with BINDs: (history-b x-trace)
|
||||
|
||||
> (history-e stream n)
|
||||
> (history-b stream n)
|
||||
|
||||
Keeps a list of the last n values of a behavior
|
||||
Returns a list of at most n elements, where the
|
||||
elements are the n last values seem on the stream,
|
||||
in order, oldest first.
|
||||
|
||||
> (count-b stream)
|
||||
|
||||
Counts number of events seen on an eventstream.
|
||||
|
||||
Often used directly on ENTRY traces, counting how many
|
||||
times ENTRY occured: (count-b entry-trace)
|
||||
|
||||
Also useful to count how many times a BIND changed
|
||||
by calling: (count-b (changes bind-trace))
|
||||
|
||||
> (largest-val-b stream)
|
||||
> (smallest-val-b stream)
|
||||
|
||||
Keeps track of the largest/smallest values seen on a stream.
|
||||
Use with BINDs: (largest-val-b (changes bind-trace)).
|
||||
|
||||
> (sequence-match? seq stream)
|
||||
|
||||
Matches a sequence of items in a list to the history
|
||||
of event pings, on the event stream evs. Returns #t
|
||||
when it matches, and #f otherwise. Use when you expect
|
||||
a certain pattern to show up, and want to know when:
|
||||
(sequence-match? '(0 1 2 1 0) (changes bind-trace))
|
||||
|
||||
> (printf-b format-string arg ...)
|
||||
|
||||
Displays the value of the behaviors with the given format,
|
||||
using "~a" just like in Scheme's FORMAT function.
|
||||
|
||||
|
||||
============================================================
|
||||
|
||||
Known Problems
|
||||
|
||||
* In general, you should not REQUIRE in your MzTake script any
|
||||
functions that act on the structures of your target program.
|
||||
|
||||
ORIGINAL FILE:
|
||||
(define-struct foo (a b))
|
||||
(let ([x (make-foo 1 2)])
|
||||
x)
|
||||
|
||||
MZTAKE SCRIPT:
|
||||
(require "original-file.ss")
|
||||
(define/bind (loc "original-file.ss" 3) x)
|
||||
(foo-a x) ;; this will fail!
|
||||
|
||||
The target program and the MzTake will have different
|
||||
instances of the struct, and the call to FOO-A will fail.
|
||||
Instead, use BIND to bring the function from the target program to
|
||||
the script:
|
||||
|
||||
(define/bind (loc "original-file.ss" 3) x foo-a)
|
||||
(foo-a x) ;; this succeeds
|
||||
|
||||
* The break button will *not* kill runaway client processes.
|
||||
You must type (kill) or (kill-all).
|
||||
|
||||
* Some legal syntax locations (used in setting trace points)
|
||||
are unreachable during program execution (they do not get
|
||||
triggered and produce empty eventstreams). For instance,
|
||||
the name clause of a LET is never the current point of execution:
|
||||
|
||||
(define x 12)
|
||||
(let ([x (add1 x)]) x)
|
||||
^
|
||||
Recommended syntax locations to use for trace points:
|
||||
|
||||
(define x 12)
|
||||
(let ([x (add1 x)]) x)
|
||||
^ ^^ ^ ^
|
||||
|
||||
* Watch out: when you change target code, your line/col locations in
|
||||
the script will drift out of align.
|
||||
|
||||
* Error handling is not perfect -- e.g., the little "bug"
|
||||
buttons on syntax errors don't reference the correct code.
|
||||
However, the messages that are printed are as accurate as
|
||||
possible.
|
||||
|
||||
* You can add trace points to the body first-class functions, and they
|
||||
will send trace update from anywhere they are passed to and invoked.
|
||||
|
||||
============================================================
|
||||
|
||||
Authors and Thanks
|
||||
|
||||
MzTake is an experimental debugger. It should enable new
|
||||
debugging approaches that were not possible (easily) before.
|
||||
Please send feedback to the PLT-Scheme mailing list:
|
||||
http://www.plt-scheme.org/maillist/
|
||||
|
||||
We are eager to hear about how you are using MzTake!
|
||||
|
||||
Jonathan Spiro
|
||||
Guillaume Marceau
|
||||
Gregory Cooper
|
||||
John Clements
|
||||
Shriram Krishnamurthi
|
||||
|
||||
|
||||
Please send bug reports to: jspiro@cs.brown.edu
|
||||
|
||||
---
|
||||
Icons for MzTake come from the Gnome Project: Nautilus Emblems.
|
||||
These are provided under the GPL license.
|
||||
http://jimmac.musichall.cz/ikony.php3
|
||||
|
|
@ -1,445 +0,0 @@
|
|||
(module engine mzscheme
|
||||
(require "marks.ss"
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "match.ss")
|
||||
(prefix frp: (lib "lang-ext.ss" "frtime"))
|
||||
(rename (lib "frp-core.ss" "frtime")
|
||||
frp:signal-thunk signal-thunk)
|
||||
"useful-code.ss"
|
||||
(lib "base-gm.ss" "frtime")
|
||||
"mztake-structs.ss"
|
||||
"load-sandbox.ss"
|
||||
"annotator.ss"
|
||||
(lib "match.ss"))
|
||||
|
||||
(provide process:set-main!
|
||||
current-policy
|
||||
all-debug-processes
|
||||
create-debug-process
|
||||
process:->dead
|
||||
process:new->running
|
||||
process:running->finished
|
||||
process:running->paused
|
||||
process:paused->running
|
||||
pause
|
||||
resume
|
||||
trace*
|
||||
|
||||
read-all-syntax
|
||||
pattern->pos)
|
||||
|
||||
;Keeps track of all debugging processes
|
||||
(define all-debug-processes null)
|
||||
|
||||
; produces a nested list of (line column offset span) for all addressable syntax
|
||||
(define (unwrap-syntax stx)
|
||||
(let ([elt (list (syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(sub1 (syntax-position stx))
|
||||
(syntax-span stx))])
|
||||
(syntax-case stx ()
|
||||
[(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))]
|
||||
[x elt])))
|
||||
|
||||
(define (read-all-syntax filename)
|
||||
(parameterize ([port-count-lines-enabled #t])
|
||||
(let ([port (open-input-file filename)])
|
||||
(begin0
|
||||
(let loop ([stx (read-syntax filename port)])
|
||||
(if (eof-object? stx) '()
|
||||
(cons stx
|
||||
(loop (read-syntax filename port)))))
|
||||
(close-input-port port)))))
|
||||
|
||||
;; returns a memoized function that takes (line column) -> (list/c position span)
|
||||
;; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?)))
|
||||
(define (line-col->pos stx)
|
||||
(let ([pos-list (flatten (map unwrap-syntax stx))])
|
||||
(lambda (line maybe-col)
|
||||
(let loop ([lst pos-list])
|
||||
(cond
|
||||
[(empty? lst)
|
||||
(error 'loc
|
||||
"No syntax found for trace at line/column ~a:~a in `~a'"
|
||||
line maybe-col (syntax-source stx))]
|
||||
[(and (<= line (first (first lst)))
|
||||
(or (not maybe-col)
|
||||
(<= maybe-col (second (first lst)))))
|
||||
(list (third (first lst)) (fourth (first lst)))]
|
||||
|
||||
[else (loop (rest lst))])))))
|
||||
|
||||
(define (pattern->pos stx-lst)
|
||||
(define (quote-symbols lst)
|
||||
(match lst
|
||||
[(? symbol? s) `(quote ,s)]
|
||||
[() empty]
|
||||
[('_ tl ...) `(_ ... ,@(quote-symbols tl))]
|
||||
[(hd tl ...) (cons (quote-symbols hd)
|
||||
(quote-symbols tl))]
|
||||
[item item]))
|
||||
|
||||
(define (collect-locations h stx lst)
|
||||
(let loop ([stx stx] [lst lst])
|
||||
(cond
|
||||
[(empty? stx) (void)]
|
||||
[(pair? stx)
|
||||
(loop (first stx) (first lst))
|
||||
(loop (rest stx) (rest lst))]
|
||||
[else
|
||||
(when (syntax-line stx)
|
||||
(hash-put! h lst (list (sub1 (syntax-position stx)) (syntax-span stx))))
|
||||
(when (pair? (syntax-e stx))
|
||||
(loop (first (syntax-e stx)) (first lst))
|
||||
(loop (rest (syntax-e stx)) (rest lst)))])))
|
||||
|
||||
(define stx2line-col (make-hash))
|
||||
(define lst (map syntax-object->datum stx-lst))
|
||||
|
||||
(for-each (lambda (s l) (collect-locations stx2line-col s l))
|
||||
stx-lst lst)
|
||||
|
||||
(lambda (pattern)
|
||||
(let ([pred (eval `(begin (require (lib "match.ss"))
|
||||
(lambda (v)
|
||||
(match v
|
||||
[,(quote-symbols pattern) #t]
|
||||
[_ #f]))))])
|
||||
(let loop ([lst lst])
|
||||
(let ([sub (if (pair? lst)
|
||||
(append (loop (first lst))
|
||||
(loop (rest lst)))
|
||||
empty)])
|
||||
(if (and (hash-mem? stx2line-col lst) (pred lst))
|
||||
(cons (hash-get stx2line-col lst) sub)
|
||||
sub))))))
|
||||
|
||||
|
||||
(define (find-client process modpath)
|
||||
(cond
|
||||
[(memf (lambda (c) (equal? (debug-client-modpath c) modpath))
|
||||
(debug-process-clients process)) => first]
|
||||
[else false]))
|
||||
|
||||
(define (find-client/create process modpath)
|
||||
(or (find-client process modpath)
|
||||
(create-debug-client process modpath)))
|
||||
|
||||
(define (process:set-main! p reqspec)
|
||||
(let* ([modpath (reqspec->modpath reqspec)]
|
||||
[client (find-client/create p modpath)])
|
||||
(set-debug-process-main-client! p client)))
|
||||
|
||||
|
||||
(define (break? process client)
|
||||
(let ([tracepoints (and client (debug-client-tracepoints client))])
|
||||
(lambda (pos)
|
||||
(or (debug-process-pause-requested? process)
|
||||
(and tracepoints
|
||||
(hash-get tracepoints (sub1 pos) (lambda () false)))))))
|
||||
|
||||
(define (traces->events traces vals)
|
||||
(map (lambda (t)
|
||||
(list (trace-struct-evnt-rcvr t)
|
||||
(apply (trace-struct-thunk t) vals)))
|
||||
traces))
|
||||
|
||||
(define (receive-result process client byte-offset top-mark rest-marks vals)
|
||||
(let* ([traces (hash-get (debug-client-tracepoints client) byte-offset (lambda () empty))]
|
||||
[no-traces? (empty? traces)]
|
||||
[has-single-trace? (and (not no-traces?) (empty? (rest traces)))]
|
||||
[no-where? (not (debug-process-where process))]
|
||||
[no-events? (and no-traces? no-where?
|
||||
(not (debug-process-pause-requested? process)))])
|
||||
|
||||
|
||||
(unless no-events?
|
||||
(let* ([marks (cons top-mark (continuation-mark-set->list rest-marks debug-key))])
|
||||
(set-debug-process-marks! process marks)
|
||||
|
||||
(if no-where?
|
||||
;; No where event to generate
|
||||
(cond [has-single-trace?
|
||||
;; fast-path
|
||||
(let* ([t (first traces)]
|
||||
[e (apply (trace-struct-thunk t) vals)])
|
||||
(frp:send-synchronous-event (trace-struct-evnt-rcvr t) e))]
|
||||
[no-traces? (void)]
|
||||
[else (frp:send-synchronous-events (traces->events traces vals))])
|
||||
|
||||
;; With a where event to generate
|
||||
(let ([where-event (debug-process-where process)]
|
||||
[w (map (compose syntax-local-infer-name mark-source) marks)])
|
||||
(if no-traces?
|
||||
(frp:send-synchronous-event where-event w)
|
||||
|
||||
(let* ([where-event (list where-event w)]
|
||||
[trace-events (traces->events traces vals)])
|
||||
(frp:send-synchronous-events (cons where-event trace-events))))))
|
||||
|
||||
;; Now that we processed the trace, do we want to pause or continue
|
||||
(when (debug-process-pause-requested? process)
|
||||
(let loop ()
|
||||
(unless (debug-process-resume-requested? process)
|
||||
(semaphore-wait (debug-process-run-semaphore process))
|
||||
(loop)))
|
||||
(set-debug-process-pause-requested?! process false)
|
||||
(set-debug-process-resume-requested?! process false))
|
||||
|
||||
(set-debug-process-marks! process false)))))
|
||||
|
||||
|
||||
|
||||
|
||||
(define ((break-after process client) top-mark marks . vals)
|
||||
(let* ([stx (mark-source top-mark)]
|
||||
[byte-offset (+ (syntax-position stx) (syntax-span stx) -2)])
|
||||
(receive-result process client byte-offset top-mark marks vals)
|
||||
(apply values vals))) ; TODO: allow modification of the return value
|
||||
|
||||
(define ((break-before process client) top-mark marks)
|
||||
(let ([byte-offset (sub1 (syntax-position (mark-source top-mark)))])
|
||||
(receive-result process client byte-offset top-mark marks empty) ; TODO: allow substitute value
|
||||
false))
|
||||
|
||||
(define (unbuild-path path)
|
||||
(let-values ([(base name _) (split-path path)])
|
||||
(if base
|
||||
(append (unbuild-path base) (list name))
|
||||
empty)))
|
||||
|
||||
(define (head lst n)
|
||||
(if (= n 0)
|
||||
empty
|
||||
(cons (first lst) (head (rest lst) (sub1 n)))))
|
||||
|
||||
(define (dir-contains? dir filename)
|
||||
(let ([dir-lst (unbuild-path dir)]
|
||||
[file-lst (unbuild-path filename)])
|
||||
(and (< (length dir-lst) (length file-lst))
|
||||
(equal? dir-lst (head file-lst (length dir-lst))))))
|
||||
|
||||
(define (map-policy-tag tag)
|
||||
(cond [(eq? tag 'fast) false]
|
||||
[(eq? tag 'debuggable) true]
|
||||
[else (error 'map-policy-tag "unknown policy tag ~a" tag)]))
|
||||
|
||||
(define (policy-requests-annotatation? policy filename)
|
||||
(if (empty? policy)
|
||||
true
|
||||
(let ([tag (first (first policy))]
|
||||
[collect-paths (second (first policy))])
|
||||
(map-policy-tag tag) ;; complains if the tag doesn't exists
|
||||
(if (or (eq? collect-paths 'everything-else)
|
||||
(ormap (lambda (dir) (dir-contains? dir filename))
|
||||
(if (list? collect-paths)
|
||||
collect-paths
|
||||
(list collect-paths))))
|
||||
(map-policy-tag tag)
|
||||
(policy-requests-annotatation? (rest policy) filename)))))
|
||||
|
||||
(define (process-has-file? process filename)
|
||||
(and
|
||||
(memf (lambda (c) (equal? (debug-client-modpath c)
|
||||
(path->string filename)));; TODO: harmonize path & string
|
||||
(debug-process-clients process))
|
||||
true))
|
||||
|
||||
(define ((record-top-level-id process) module-name var-name val)
|
||||
(let* ([modules (debug-process-top-level process)]
|
||||
[bindings (hash-get modules module-name (lambda () (make-hash)))])
|
||||
(unless (hash-mem? modules module-name)
|
||||
(hash-put! modules module-name bindings))
|
||||
(hash-put! bindings var-name val)))
|
||||
|
||||
(define (launch-sandbox process)
|
||||
(unless (debug-process-main-client process)
|
||||
(error 'launch-sandbox
|
||||
"No main file specified. Use TRACE or SET-MAIN! to indicate where to start execution"))
|
||||
|
||||
(parameterize ([current-inspector (make-inspector)])
|
||||
(require/sandbox+annotations
|
||||
(debug-process-custodian process)
|
||||
;; error-display-handler :
|
||||
(let ([orig-err-disp (error-display-handler)])
|
||||
(lambda (msg exn)
|
||||
(frp:send-event (debug-process-exceptions process) exn)
|
||||
(orig-err-disp msg exn)))
|
||||
|
||||
;; target file
|
||||
`(file ,(debug-client-modpath (debug-process-main-client process)))
|
||||
|
||||
;; annotate-module?
|
||||
(lambda (filename module-name)
|
||||
#;(print-each "annotate-module?"
|
||||
filename
|
||||
(process-has-file? process filename)
|
||||
(policy-requests-annotatation? (debug-process-policy process) filename))
|
||||
|
||||
(or (process-has-file? process filename)
|
||||
(policy-requests-annotatation? (debug-process-policy process) filename)))
|
||||
|
||||
;; annotator
|
||||
(lambda (stx)
|
||||
(if (not (syntax-source stx))
|
||||
stx
|
||||
(let*-values ([(client)
|
||||
(find-client/create
|
||||
process
|
||||
(path->string (syntax-source stx)))]
|
||||
[(annotated-stx pos-list)
|
||||
(annotate-for-single-stepping
|
||||
stx
|
||||
(lambda (_) (break? process client))
|
||||
(break-before process client)
|
||||
(break-after process client)
|
||||
(lambda (kind bound binding) (void))
|
||||
(record-top-level-id process))])
|
||||
annotated-stx))))))
|
||||
|
||||
(define (process:new->running process)
|
||||
(printf "mztake: starting ~a~n" (debug-client-modpath (debug-process-main-client process)))
|
||||
(set-debug-process-run-semaphore! process (make-semaphore))
|
||||
(set-debug-process-policy! process (current-policy))
|
||||
|
||||
(thread (lambda ()
|
||||
(launch-sandbox process)
|
||||
(process:running->finished process))))
|
||||
|
||||
(define (process:running->finished process)
|
||||
(process:->dead process))
|
||||
|
||||
(define (process:->dead process)
|
||||
(printf "mztake: finished ~a~n" (debug-client-modpath (debug-process-main-client process)))
|
||||
(set! all-debug-processes (remq process all-debug-processes))
|
||||
(custodian-shutdown-all (debug-process-custodian process))
|
||||
(frp:set-cell! (debug-process-exited? process) true))
|
||||
|
||||
(define (process:running->paused process)
|
||||
(set-debug-process-pause-requested?! process true))
|
||||
|
||||
(define (process:paused->running process)
|
||||
(set-debug-process-resume-requested?! process true)
|
||||
(semaphore-post (debug-process-run-semaphore process)))
|
||||
|
||||
(define (pause process)
|
||||
(when (and (debug-process-run-semaphore process)
|
||||
(not (frp:value-now (debug-process-exited? process)))
|
||||
(not (debug-process-pause-requested? process)))
|
||||
(process:running->paused process)))
|
||||
|
||||
(define (resume process)
|
||||
(cond
|
||||
[(not (debug-process-run-semaphore process)) (process:new->running process)]
|
||||
[(and (not (frp:value-now (debug-process-exited? process)))
|
||||
(debug-process-pause-requested? process)
|
||||
(not (debug-process-resume-requested? process)))
|
||||
(process:paused->running process)]))
|
||||
|
||||
(define current-policy (make-parameter `((fast ,(current-library-collection-paths))
|
||||
(debuggable everything-else))))
|
||||
|
||||
(define (create-debug-process)
|
||||
|
||||
(letrec ([running-e (frp:new-cell frp:never-e)]
|
||||
[run-manager (running-e . frp:==> .
|
||||
(lambda (r)
|
||||
(if r (resume process) (pause process))))]
|
||||
[process (make-debug-process (make-custodian)
|
||||
false ; run-semaphore - false so we know it has never started
|
||||
running-e ; running-e
|
||||
run-manager ; run-manager
|
||||
false ; pause-requested?
|
||||
false ; resume-requested?
|
||||
false ; policy
|
||||
|
||||
(frp:new-cell false) ; exited?
|
||||
(frp:event-receiver) ; exceptions
|
||||
false ; main-client
|
||||
empty ; clients
|
||||
(make-hash 'equal ) ; top-level
|
||||
|
||||
false ; where
|
||||
false)]) ; marks
|
||||
(set! all-debug-processes (cons process all-debug-processes))
|
||||
process))
|
||||
|
||||
; Creates a debugger client
|
||||
; (debug-process? require-path. -> . debug-file?)
|
||||
(define (create-debug-client process modpath)
|
||||
; throwaway namespace so the module-name-resolver doesn't load an unannotated module
|
||||
(parameterize ([current-namespace (make-namespace)])
|
||||
(let ([client (create-empty-debug-client)]
|
||||
[stx (read-all-syntax modpath)])
|
||||
(for-each (lambda (c)
|
||||
(when (equal? modpath (debug-client-modpath c))
|
||||
(raise-syntax-error 'mztake:script-error:create-debug-client
|
||||
(format "A client for `~a' is already defined for this process." modpath))))
|
||||
(debug-process-clients process))
|
||||
|
||||
(set-debug-client-modpath! client modpath)
|
||||
(set-debug-client-process! client process)
|
||||
(set-debug-client-line-col->pos! client (line-col->pos stx))
|
||||
(set-debug-client-pattern->pos! client (pattern->pos stx))
|
||||
(set-debug-process-clients! process
|
||||
(append (list client) (debug-process-clients process)))
|
||||
|
||||
; set the main module if it has not been set
|
||||
; this implies that the first client created is always the main module
|
||||
(unless (debug-process-main-client process)
|
||||
(set-debug-process-main-client! process client))
|
||||
|
||||
client)))
|
||||
|
||||
(define (reqspec->modpath filename)
|
||||
(define (build-module-filename str) ; taken from module-overview.ss
|
||||
(let ([try (lambda (ext)
|
||||
(let ([tst (string-append str ext)])
|
||||
(and (file-exists? tst) tst)))])
|
||||
(or (try ".ss") (try ".scm") (try "") str)))
|
||||
(let ([modpath (symbol->string ((current-module-name-resolver) filename #f #f))])
|
||||
(build-module-filename
|
||||
(if (regexp-match #rx"^," modpath)
|
||||
(substring modpath 1 (string-length modpath))
|
||||
modpath))))
|
||||
|
||||
(define (loc->positions client loc)
|
||||
(let ([pos&spans
|
||||
(if (loc/lc? loc)
|
||||
(list ((debug-client-line-col->pos client) (loc/lc-line loc) (loc/lc-col loc)))
|
||||
((debug-client-pattern->pos client) (loc/p-pattern loc)))])
|
||||
(if (loc-after? loc)
|
||||
(map (lambda (p&s) (+ (first p&s) (second p&s) -1)) pos&spans)
|
||||
(map first pos&spans))))
|
||||
|
||||
(define (trace* p loc thunk)
|
||||
(let* ([modpath (reqspec->modpath (loc-reqspec loc))]
|
||||
[client (find-client/create p modpath)]
|
||||
[trace-hash (debug-client-tracepoints client)]
|
||||
[trace (make-trace-struct (frp:event-receiver) thunk)]
|
||||
[positions (loc->positions client loc)])
|
||||
; add the trace to the list of traces for these byte-offsets
|
||||
(for-each (lambda (pos)
|
||||
(hash-put! trace-hash pos
|
||||
(append (hash-get trace-hash pos (lambda () '()))
|
||||
(list trace))))
|
||||
positions)
|
||||
(trace-struct-evnt-rcvr trace)))
|
||||
|
||||
(define (syntax-local-infer-name stx)
|
||||
(or (syntax-property stx 'inferred-name)
|
||||
(let ([s (syntax-source stx)])
|
||||
(and s
|
||||
(let ([s (cond
|
||||
[(path? s) (path->string s)]
|
||||
[else s])]
|
||||
[l (syntax-line stx)]
|
||||
[c (syntax-column stx)])
|
||||
(if l
|
||||
(string->symbol (format "~a:~a:~a" s l c))
|
||||
(let ([p (syntax-position stx)])
|
||||
(string->symbol (format "~a::~a" s p)))))))))
|
||||
|
||||
|
||||
)
|
||||
|
|
@ -1,84 +0,0 @@
|
|||
(module mztake-structs mzscheme
|
||||
(require (lib "match.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "base-gm.ss" "frtime"))
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
(define require-spec?
|
||||
(match-lambda
|
||||
[(? string?) true]
|
||||
[('file (? string?)) true]
|
||||
[('lib (? string?) (? string?) ...) true]
|
||||
[('planet . arg) true]
|
||||
[else false]))
|
||||
|
||||
; ;;;;; ; ;
|
||||
; ; ; ; ;
|
||||
; ; ; ;
|
||||
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ;;;;
|
||||
; ; ; ;; ; ; ; ; ; ; ;
|
||||
; ;;; ; ; ; ; ; ; ;
|
||||
; ;;; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ;;;;
|
||||
; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ;; ; ; ; ; ;
|
||||
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;
|
||||
|
||||
(define-struct trace-struct (evnt-rcvr thunk)) ; frp:event-receiver
|
||||
|
||||
(define-struct debug-client (modpath ; complete-path of the module
|
||||
tracepoints ; hash-table of traces
|
||||
line-col->pos ; memoized O(n) function to map line/col -> byte offset
|
||||
pattern->pos
|
||||
process)) ; parent debug-process
|
||||
|
||||
(define-struct debug-process (custodian ; If you shutdown-all it will kill the debugger process
|
||||
run-semaphore ; When you post to this the debuggee will continue executing
|
||||
running-e ; #t on this event resumes, #f pauses
|
||||
run-manager ; saves behavior that actually pauses/resumes from GC
|
||||
pause-requested?
|
||||
resume-requested?
|
||||
policy
|
||||
|
||||
exited? ; FrTime cell receives #t when the target exits
|
||||
exceptions ; (an event stream) Exceptions thrown during the evaluation of the target
|
||||
main-client ; the main client module that will be run
|
||||
clients ; list of all the clients attached to this process
|
||||
top-level
|
||||
|
||||
where ; a behavior signaling each position where we pause
|
||||
marks)) ; while paused, the marks at the point of the pause (else false)
|
||||
|
||||
(define-struct loc (reqspec after?))
|
||||
(define-struct (loc/lc loc) (line col))
|
||||
(define-struct (loc/p loc) (pattern))
|
||||
|
||||
;###########################################################################################################
|
||||
|
||||
|
||||
|
||||
|
||||
; ;;;;; ; ; ;;;;; ;
|
||||
; ; ; ; ; ;; ; ;
|
||||
; ; ; ; ; ;
|
||||
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ; ; ;;; ;;; ;;;; ;;;;; ;;;; ; ;;; ;;;;
|
||||
; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ;
|
||||
; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; ;;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ;
|
||||
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;;
|
||||
|
||||
(define (create-empty-debug-client)
|
||||
(make-debug-client null ; modpath
|
||||
(make-hash) ; tracepoints
|
||||
null ; line-col->pos function
|
||||
null
|
||||
null)) ; process
|
||||
|
||||
;###########################################################################################################
|
||||
)
|
||||
|
|
@ -1,176 +0,0 @@
|
|||
(module mztake mzscheme
|
||||
(require (lib "contract.ss")
|
||||
(lib "match.ss")
|
||||
(prefix frp: (lib "lang-ext.ss" "frtime"))
|
||||
(rename (lib "frtime.ss" "frtime") frp:list list)
|
||||
(rename (lib "frtime.ss" "frtime") frp:value-nowable? value-nowable?)
|
||||
(rename (lib "frtime.ss" "frtime") frp:behaviorof behaviorof)
|
||||
"mztake-structs.ss"
|
||||
(lib "base-gm.ss" "frtime")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
"marks.ss"
|
||||
"engine.ss")
|
||||
|
||||
;; Turn struct printing on for MzTake users.
|
||||
(print-struct true)
|
||||
|
||||
(provide (rename loc loc$)
|
||||
debug-process-running-e
|
||||
loc/r
|
||||
trace
|
||||
bind
|
||||
define/bind
|
||||
define/bind-e
|
||||
[rename loc/opt-col loc]
|
||||
[rename mztake-top #%top])
|
||||
|
||||
(provide/contract [exceptions (() (debug-process?) . opt-> . frp:event?)]
|
||||
[exited? (() (debug-process?) . opt-> . frp:behavior?)]
|
||||
[kill (() (debug-process?) . opt-> . void?)]
|
||||
[kill-all (-> void?)]
|
||||
[set-running-e! ((frp:event?) (debug-process?) . opt-> . any)]
|
||||
[set-running! ((frp:value-nowable?) (debug-process?) . opt-> . any)]
|
||||
[where (() (debug-process?) . opt-> . frp:event?)]
|
||||
|
||||
[current-policy (case-> (-> any)
|
||||
(any/c . -> . void?))]
|
||||
[current-process (case-> (-> debug-process?)
|
||||
(debug-process? . -> . void?))]
|
||||
[current-reqspec (case-> (-> string?)
|
||||
(string? . -> . void?))]
|
||||
[create-debug-process (-> debug-process?)]
|
||||
[set-main! ((require-spec?) (debug-process?) . opt-> . void?)]
|
||||
[trace* (debug-process? loc? (-> any) . -> . frp:event?)]
|
||||
[bind* (debug-process? symbol? . -> . any)])
|
||||
|
||||
(define (loc* after?)
|
||||
(define (set-r r) (current-reqspec r))
|
||||
(match-lambda*
|
||||
[(arg) ((loc* after?) (current-reqspec) arg)]
|
||||
[((and (not (? require-spec?)) arg) args ...) (apply (loc* after?) (current-reqspec) arg args)]
|
||||
[((? require-spec? r) (? number? line)) (set-r r) (make-loc/lc r after? line false)]
|
||||
[((? require-spec? r) (? number? line) (? number? col)) (set-r r) (make-loc/lc r after? line col)]
|
||||
[((? require-spec? r) pattern) (set-r r) (make-loc/p r after? pattern)]))
|
||||
|
||||
(define loc/r (loc* true))
|
||||
|
||||
(define loc/opt-col (loc* false))
|
||||
|
||||
(define exceptions
|
||||
(opt-lambda ([p (current-process)])
|
||||
(debug-process-exceptions p)))
|
||||
|
||||
(define exited?
|
||||
(opt-lambda ([p (current-process)])
|
||||
(debug-process-exited? p)))
|
||||
|
||||
(define kill
|
||||
(opt-lambda ([p (current-process)])
|
||||
(unless (debug-process-exited? p)
|
||||
(process:->dead p))))
|
||||
|
||||
(define (kill-all)
|
||||
(unless (empty? all-debug-processes)
|
||||
(for-each (lambda (p) (kill p)) all-debug-processes)
|
||||
(display "All debug processes have been killed.")))
|
||||
|
||||
(define set-running-e!
|
||||
(opt-lambda (e [process (current-process)])
|
||||
(resume process)
|
||||
(frp:set-cell! (debug-process-running-e process) e)))
|
||||
|
||||
(define set-running!
|
||||
(opt-lambda (b [process (current-process)])
|
||||
(if (frp:value-now b) (resume process) (pause process))
|
||||
(frp:set-cell! (debug-process-running-e process) (frp:changes b))))
|
||||
|
||||
(define where
|
||||
(opt-lambda ([p (current-process)])
|
||||
(unless (debug-process-where p)
|
||||
(set-debug-process-where! p (frp:event-receiver)))
|
||||
(debug-process-where p)))
|
||||
|
||||
(define current-process (make-parameter (create-debug-process)))
|
||||
(define current-reqspec (make-parameter false))
|
||||
|
||||
(define set-main!
|
||||
(opt-lambda (reqspec [p (current-process)])
|
||||
(current-reqspec reqspec )
|
||||
(process:set-main! p reqspec)))
|
||||
|
||||
(define-syntax trace
|
||||
(syntax-rules (=>)
|
||||
[(_ loc)
|
||||
(let ([loc* loc])
|
||||
(if (loc-after? loc*)
|
||||
(trace* (current-process) loc* identity)
|
||||
(trace* (current-process) loc* (lambda () true))))]
|
||||
[(_ loc => proc)
|
||||
(trace* (current-process) loc proc)]
|
||||
[(_ loc body ...)
|
||||
(trace* (current-process) loc (lambda () body ...))]))
|
||||
|
||||
(define (mztake-top* name thunk)
|
||||
(if (debug-process-marks (current-process))
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (exn)
|
||||
(with-handlers
|
||||
([exn:fail? (lambda (exn2) (raise exn2))])
|
||||
(bind* (current-process) name)))])
|
||||
(thunk))
|
||||
(thunk)))
|
||||
|
||||
(define-syntax (mztake-top stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . name)
|
||||
#'(mztake-top* 'name (lambda () (#%top . name)))]))
|
||||
|
||||
(define (lookup-in-top-level p name)
|
||||
(let/ec success
|
||||
(define (try m)
|
||||
(let/ec fail
|
||||
(define (fail*) (fail false))
|
||||
(success (hash-get (hash-get (debug-process-top-level p) m fail*) name fail*))))
|
||||
(for-each try (map mark-module-name (debug-process-marks p)))
|
||||
(hash-for-each (debug-process-top-level p) (lambda (m ns) (try m)))
|
||||
(error 'bind "variable `~a' not found in target at the current location" name)))
|
||||
|
||||
(define (bind* p name)
|
||||
(unless (debug-process-marks p)
|
||||
(error "Bind called but the target process is not paused."))
|
||||
|
||||
(let ([bs (lookup-all-bindings
|
||||
(lambda (id) (eq? (syntax-e id) name))
|
||||
(debug-process-marks p))])
|
||||
(if (empty? bs)
|
||||
(lookup-in-top-level p name)
|
||||
(mark-binding-value (first bs)))))
|
||||
|
||||
(define-syntax bind
|
||||
(syntax-rules ()
|
||||
[(_ (name ...) body0 body ...)
|
||||
(let* ([p (current-process)]
|
||||
[name (bind* p 'name)]
|
||||
...)
|
||||
body0 body ...)]))
|
||||
|
||||
(define-syntax define/bind-e
|
||||
(syntax-rules ()
|
||||
[(_ loc name ...)
|
||||
(begin
|
||||
(define here loc)
|
||||
(define name (trace here (bind (name) name)))
|
||||
...)]))
|
||||
|
||||
(define-syntax define/bind
|
||||
(syntax-rules ()
|
||||
[(_ loc name ...)
|
||||
(begin
|
||||
(define here loc)
|
||||
(define name (frp:hold (trace here (bind (name) name))))
|
||||
...)]))
|
||||
|
||||
|
||||
)
|
||||
|
|
@ -1,64 +0,0 @@
|
|||
(module useful-code frtime
|
||||
|
||||
(require (lib "string.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "list.ss"))
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
; Keeps a list of the last n values of a behavior
|
||||
(define/contract history-e (case-> (event? . -> . any)
|
||||
(event? number? . -> . any))
|
||||
(case-lambda [(stream)
|
||||
(define ((add-to-complete-hist x) hist) (append hist (list x)))
|
||||
(accum-e (stream . ==> . add-to-complete-hist) empty)]
|
||||
|
||||
[(stream n)
|
||||
(define ((add-to-short-hist x) hist) (append (if (< (length hist) n) hist (rest hist)) (list x)))
|
||||
(accum-e (stream . ==> . add-to-short-hist) empty)]))
|
||||
|
||||
(define/contract history-b (case-> (event? . -> . any)
|
||||
(event? number? . -> . any))
|
||||
(case-lambda [(stream) (hold (history-e stream) empty)]
|
||||
[(stream n) (hold (history-e stream n) empty)]))
|
||||
|
||||
; Counts number of events on an event stream
|
||||
(define/contract count-b (event? . -> . any)
|
||||
(lambda (stream)
|
||||
(hold (accum-e (stream . -=> . add1) 0) 0)))
|
||||
|
||||
; Keeps track of the largest value seen on a stream
|
||||
(define/contract largest-val-b (event? . -> . any)
|
||||
(lambda (stream)
|
||||
(hold (accum-e (stream
|
||||
. ==> .
|
||||
(lambda (last)
|
||||
(lambda (x)
|
||||
(if (> x last) x last))))
|
||||
-inf.0))))
|
||||
|
||||
; Keeps track of the smallest value seen on a stream
|
||||
(define/contract smallest-val-b (event? . -> . any)
|
||||
(lambda (stream)
|
||||
(hold (accum-e (stream
|
||||
. ==> .
|
||||
(lambda (last)
|
||||
(lambda (x)
|
||||
(if (< x last) x last))))
|
||||
+inf.0))))
|
||||
|
||||
; Matches a sequence of items in a list to event pings
|
||||
(define/contract sequence-match? ((listof any/c) . -> . any)
|
||||
(lambda (seq evs)
|
||||
(equal? seq (history-b evs (length seq)))))
|
||||
|
||||
; Cheap printf for behaviors
|
||||
(define printf-b format)
|
||||
|
||||
; Flattens a list
|
||||
(define (flatten x)
|
||||
(cond ((empty? x) '())
|
||||
((and (list? x)
|
||||
(list? (first x)))
|
||||
(append (flatten (car x)) (flatten (cdr x))))
|
||||
(else (list x)))))
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
(module engine-test mzscheme
|
||||
|
||||
(require "../engine.ss")
|
||||
|
||||
(define stx (read-all-syntax "../demos/dijkstra/dijkstra.ss"))
|
||||
|
||||
(define fn (pattern->pos stx))
|
||||
(define result (fn '(define (_ ...) _ ...)))
|
||||
|
||||
(define expected '((7 2 147) (18 2 463)))
|
||||
(printf "~a~n" (list (equal? result expected) result expected))
|
||||
)
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
(require (as-is mzscheme load)
|
||||
(as-is "test-harness.ss" test))
|
||||
(load "../demos/dijkstra/dijkstra-mztake.ss")
|
||||
(map-e (lambda (e)
|
||||
(unless e
|
||||
(test (dv:vector-length (t-data heap)) 5)))
|
||||
(debug-process-running-e (current-process)))
|
||||
|
|
@ -1,75 +0,0 @@
|
|||
(module test-harness mzscheme
|
||||
(provide (all-defined))
|
||||
(require (lib "list.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "pretty.ss"))
|
||||
|
||||
(define print-tests (make-parameter #f))
|
||||
(define test-inspector (make-parameter (current-inspector)))
|
||||
(define test-inexact-epsilon (make-parameter 0.01))
|
||||
|
||||
(define-struct (exn:test exn) ())
|
||||
|
||||
(define (install-test-inspector)
|
||||
(test-inspector (current-inspector))
|
||||
(current-inspector (make-inspector))
|
||||
(print-struct #t))
|
||||
|
||||
(define (may-print-result result)
|
||||
(parameterize ([current-inspector (test-inspector)]
|
||||
[print-struct #t])
|
||||
(when (or (eq? (print-tests) (first result))
|
||||
(eq? (print-tests) #t))
|
||||
(pretty-print result))
|
||||
(when (and (eq? (print-tests) 'stop)
|
||||
(eq? (first result) 'bad))
|
||||
(raise (make-exn:test (format "test failed: ~a" result)
|
||||
(current-continuation-marks))))))
|
||||
|
||||
|
||||
(define test
|
||||
(opt-lambda (result expected [compare equal?])
|
||||
(let* ([test-result
|
||||
(cond [(or (and (number? result) (not (exact? result)))
|
||||
(and (number? expected) (not (exact? expected))))
|
||||
(< (abs (- result expected)) (test-inexact-epsilon))]
|
||||
[else
|
||||
(parameterize ([current-inspector (test-inspector)])
|
||||
(compare result expected))])]
|
||||
[to-print (if test-result
|
||||
(list 'good result expected)
|
||||
(list 'bad result expected))])
|
||||
|
||||
(may-print-result to-print)
|
||||
to-print)))
|
||||
|
||||
(define (test/pred result pred)
|
||||
(let* ([test-result (pred result)]
|
||||
[to-print (if test-result
|
||||
(list 'good result test-result)
|
||||
(list 'bad result test-result))])
|
||||
(may-print-result to-print)
|
||||
to-print))
|
||||
|
||||
(define (test/exn thunk expected-exception-msg)
|
||||
(unless (and (procedure? thunk)
|
||||
(procedure-arity-includes? thunk 0))
|
||||
(error (format
|
||||
"the first argument to test/exn should be a function of no arguments (a \"thunk\"), got ~a"
|
||||
thunk)))
|
||||
(let* ([result
|
||||
(with-handlers
|
||||
([void (lambda (exn) exn)])
|
||||
(thunk))]
|
||||
[test-result
|
||||
(if (and (exn? result)
|
||||
(regexp-match expected-exception-msg (exn-message result)))
|
||||
(list 'good result expected-exception-msg)
|
||||
(list 'bad result expected-exception-msg))])
|
||||
(may-print-result test-result)
|
||||
test-result))
|
||||
|
||||
(install-test-inspector)
|
||||
)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user