suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cleaned up and fixed base-gm.ss in frtime and mztake

Browse Source 
svn: r2596
This commit is contained in:
Guillaume Marceau 2006-04-04 23:22:49 +00:00
parent 3d50bb27f2
commit 1f702fab15
15 changed files with 171 additions and 401 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/mztake/TODO.txt
View File

@ -2,16 +2,6 @@
- Automated tests - Automated tests
- Trace by function name - Trace by function name
#|:::::::::LOAD/ANNOTATOR BUGS:::::::::::
* catch oops exception
* catch the other two exceptions that my loaders throw
* detect if the source code for a certain module is missing and throw an exception
* do I want to parameterize it over a given namespace?
* does this handle module prefixes?
* what happens if two modules have the same name in different directories
* MAKE SURE THERE WONT BE COLLISIONS WHEN EVAL'NG MODULES...GIVE THEM UNIQUE NAMES BASED ON PATH!
::::::::::::::::::::::::::::::::::::::::::
CHANGES TO MAKE----------------------------------------------------------------------------- CHANGES TO MAKE-----------------------------------------------------------------------------
Ability to add named anchors into code using Special menu in DRS -- use those anchors as tracepoints. Ability to add named anchors into code using Special menu in DRS -- use those anchors as tracepoints.
@ -19,42 +9,15 @@ Demo monitoring DrScheme for Robby?
Bind Stop button to kill-all. Bind Stop button to kill-all.
Test Suite for debugger annotator
Demo and docs for debugging multiple files, to make Robby happy. It is true that the docs are not very helpful on this count. It'd be nice if you could mock up a quick example of tracing something inside DrScheme....
On the whole, I like the tool, although it'd be nice to have either On the whole, I like the tool, although it'd be nice to have either
(a) an interactive pointy-clicky interface rather than figuring (a) an interactive pointy-clicky interface rather than figuring
out line/column co-ordinates, or out line/column co-ordinates, or
(b) an AST-based description of the thing to be monitored (shades
of aspect-oriented programming).
Re-direct, or at least prefix, program output from the client so that it can be distinguished from the script Re-direct, or at least prefix, program output from the client so that it can be distinguished from the script
Paramterize print-struct to #f for printing in the script Paramterize print-struct to #f for printing in the script
DEMOS---------------------------------------------------------------------------------------
* Data structure examples
Binary search over a tree, show which node is being examined, or the most commonly taken path
Parse, graph the AST -- show OR and AND precedence getting messed up
* MST example
* something with multiple threads doing something and draw the threads in different colors in a window
OPTIMIZATIONS-------------------------------------------------------------------------------
* improve speed of lookup for line-col->pos; load them into a hashtable? not important since this is just startup time for the script.
* improve speed of load/annotate
* improve speed of functions in (run)
* Remove marks.ss from MzTake as soon as the new version of it becomes standard with releases.
ERROR-CHECKING/HANDLING--------------------------------------------------------------------- ERROR-CHECKING/HANDLING---------------------------------------------------------------------
* Make all exposed cells and evstreams read-only by lifting the identity function on them * Make all exposed cells and evstreams read-only by lifting the identity function on them

1
collects/mztake/annotator.ss
View File

@ -6,6 +6,7 @@
(lib "marks.ss" "mztake") (lib "marks.ss" "mztake")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "pretty.ss") (lib "pretty.ss")
(lib "base-gm.ss" "frtime")
(lib "load-sandbox.ss" "mztake") (lib "load-sandbox.ss" "mztake")
(prefix srfi: (lib "search.ss" "srfi" "1")) (prefix srfi: (lib "search.ss" "srfi" "1"))
) )

6
collects/mztake/demos/dijkstra/dijkstra-mztake.ss
View File

@ -37,9 +37,9 @@
"dijkstra-solver.ss" "dijkstra-solver.ss"
(lib "match.ss")) (lib "match.ss"))
(define inserts (trace (loc "heap.ss" 49 6) item)) (define inserts (trace (loc '(lib "heap.ss" "frtime") '(let* ((sorter _) _) _))
;(define removes (trace (loc "heap.ss" 67 10) result)) item))
(define removes (trace (loc/r 66 22))) (define removes (trace (loc/r '(dv:ref (t-data _) _))))
#| The following code #| The following code
merely observes the insertions and removals merely observes the insertions and removals

2
collects/mztake/demos/dijkstra/dijkstra-solver.ss
View File

@ -1,5 +1,5 @@
(module dijkstra-solver mzscheme (module dijkstra-solver mzscheme
(require "heap.ss" (require (lib "heap.ss" "frtime")
(lib "list.ss") (lib "list.ss")
"graph.ss") "graph.ss")

111
collects/mztake/demos/dijkstra/graph.ss
View File

@ -1,6 +1,8 @@
;; -*- compile-command: "mzscheme -M errortrace -u graph.ss" -*- ;; -*- compile-command: "mzscheme -M errortrace -u graph.ss" -*-
(module graph mzscheme (module graph mzscheme
(require (lib "more-useful-code.ss" "mztake")) (require (lib "base-gm.ss" "frtime")
(lib "etc.ss")
(lib "list.ss"))
(provide make-graph (provide make-graph
;; --- Constructors : ;; --- Constructors :
@ -57,7 +59,7 @@
(define (make-graph . flags) (define (make-graph . flags)
(let ((flag-hash (make-hash))) (let ((flag-hash (make-hash)))
(set! flags (expands-safe-flag flags)) (set! flags (expands-safe-flag flags))
(for-each-f flags (lambda (flag) (hash-put! flag-hash flag true))) (for-each (lambda (flag) (hash-put! flag-hash flag true)) flags)
(if (member 'equal 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 'equal) (make-hash 'equal) (make-hash 'equal))
(make-t flag-hash 0 0 (make-hash) (make-hash) (make-hash))))) (make-t flag-hash 0 0 (make-hash) (make-hash) (make-hash)))))
@ -119,8 +121,8 @@
(define (graph-directed? graph) (define (graph-directed? graph)
(hash-mem? (t-flags graph) 'directed)) (hash-mem? (t-flags graph) 'directed))
;;; ===================================================================== ;;; =====================================================================
;;; Nodes ;;; Nodes
(define (graph-nodes graph) (hash-keys (t-nodes graph))) (define (graph-nodes graph) (hash-keys (t-nodes graph)))
@ -159,12 +161,12 @@
(define (graph-node-remove! graph node) (define (graph-node-remove! graph node)
(assert (graph-node-mem? graph node)) (assert (graph-node-mem? graph node))
(for-each-f (hash-get (t-successors graph) node) (for-each (lambda (i) (graph-edge-remove! graph node i))
(lambda (i) (graph-edge-remove! graph node i))) (hash-keys (hash-get (t-successors graph) node)))
(if (graph-directed? graph) (if (graph-directed? graph)
(for-each-f (hash-get (t-predessessors graph) node) (for-each (lambda (i) (graph-edge-remove! graph i node))
(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-nodes graph) node)
(hash-remove! (t-successors graph) node) (hash-remove! (t-successors graph) node)
@ -177,15 +179,10 @@
[(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) (graph-node-collapse! graph node with-self-loop (lambda (pred-label succ-label) no-value))]
[(graph node with-self-loop label-fn) [(graph node with-self-loop label-fn)
(let ((is-directed (graph-directed? graph))) (let ((is-directed (graph-directed? graph)))
(for-each-f (for-each
(if is-directed
(hash-get (t-predessessors graph) node)
(hash-get (t-successors graph) node))
(lambda (pred) (lambda (pred)
(for-each-f (for-each
(hash-get (t-successors graph) node)
(lambda (succ) (lambda (succ)
(unless (or (and (not is-directed) (eq? pred succ)) (unless (or (and (not is-directed) (eq? pred succ))
(graph-edge-mem? graph pred succ)) (graph-edge-mem? graph pred succ))
@ -197,7 +194,12 @@
(hash-put! (hash-get (t-successors graph) pred) succ new-label) (hash-put! (hash-get (t-successors graph) pred) succ new-label)
(if is-directed (if is-directed
(hash-put! (hash-get (t-predessessors graph) succ) pred new-label) (hash-put! (hash-get (t-predessessors graph) succ) pred new-label)
(hash-put! (hash-get (t-successors 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)])) (graph-node-remove! graph node)]))
(define (graph-node-has-label? graph node) (define (graph-node-has-label? graph node)
@ -223,14 +225,14 @@
(hash-keys (hash-get (t-successors graph) node)))) (hash-keys (hash-get (t-successors graph) node))))
(define (graph-for-each-adjs graph node fn) (define (graph-for-each-adjs graph node fn)
(for-each (lambda (succ) (fn node succ)) (for-each (hash-keys (hash-get (t-successors graph) node))
(hash-get (t-successors graph) node)) (lambda (succ) (fn node succ)))
(when (graph-directed? graph) (when (graph-directed? graph)
(for-each (lambda (pred) (fn pred node)) (for-each (hash-keys (hash-get (t-predessessors graph) node))
(hash-get (t-predessessors graph) node)))) (lambda (pred) (fn pred node)))))
(define (graph-for-each-node graph fn) (define (graph-for-each-node graph fn)
(for-each-f (t-nodes graph) fn)) (for-each fn (hash-keys (t-nodes graph))))
(define (graph-fold-nodes graph init fn) (define (graph-fold-nodes graph init fn)
(let ((acc init)) (let ((acc init))
@ -239,8 +241,8 @@
(lambda (node) (set! acc (fn node acc)))) (lambda (node) (set! acc (fn node acc))))
acc)) acc))
;;; ===================================================================== ;;; =====================================================================
;;; Edges ;;; Edges
(define (graph-edges graph) (define (graph-edges graph)
(let ((rtn empty)) (let ((rtn empty))
@ -308,8 +310,8 @@
(graph-for-each-node (graph-for-each-node
graph graph
(lambda (from) (lambda (from)
(for-each-f (hash-get (t-successors graph) from) (for-each (lambda (to) (fn from to))
(lambda (to) (fn from to)))))) (hash-keys (hash-get (t-successors graph) from))))))
(define (graph-fold-edges graph init fn) (define (graph-fold-edges graph init fn)
(let ((acc init)) (let ((acc init))
@ -318,18 +320,18 @@
(lambda (from to) (set! acc (fn from to acc)))) (lambda (from to) (set! acc (fn from to acc))))
acc)) acc))
;;; ===================================================================== ;;; =====================================================================
;;; Algos ;;; Algos
(define (graph-dfs-from-node-with-log graph node dealt-with pre-fn post-fn backward) (define (graph-dfs-from-node-with-log graph node dealt-with pre-fn post-fn backward)
(assert (or (not backward) (graph-directed? graph))) (assert (or (not backward) (graph-directed? graph)))
(if (not (hash-mem? dealt-with node)) (if (not (hash-mem? dealt-with node))
(begin (hash-put! dealt-with node true) (begin (hash-put! dealt-with node true)
(pre-fn node) (pre-fn node)
(for-each-f (if backward (for-each (lambda (n) (graph-dfs-from-node-with-log graph n dealt-with pre-fn post-fn backward))
(hash-get (t-predessessors graph) node) (if backward
(hash-get (t-successors graph) node)) (hash-keys (hash-get (t-predessessors graph) node))
(lambda (n) (graph-dfs-from-node-with-log graph n dealt-with pre-fn post-fn backward))) (hash-keys (hash-get (t-successors graph) node))))
(post-fn node)))) (post-fn node))))
@ -356,11 +358,11 @@
(lambda (node acc) (lambda (node acc)
(if (hash-mem? dealt-with node) acc (if (hash-mem? dealt-with node) acc
(let ((cur-component (let ((cur-component
(let loop ((cur node) (acc empty)) (let loop ((cur node) (acc empty))
(if (hash-mem? dealt-with cur) acc (if (hash-mem? dealt-with cur) acc
(begin (hash-put! dealt-with cur true) (begin (hash-put! dealt-with cur true)
(foldl (lambda (adj acc) (loop adj acc)) (cons cur acc) (foldl (lambda (adj acc) (loop adj acc)) (cons cur acc)
(graph-adjs graph cur))))))) (graph-adjs graph cur)))))))
(cons cur-component acc))))))) (cons cur-component acc)))))))
(define (graph-strongly-connected-components graph) (define (graph-strongly-connected-components graph)
@ -381,8 +383,7 @@
(let ((component-graph (graph-make-similar graph empty '(safe equal))) (let ((component-graph (graph-make-similar graph empty '(safe equal)))
(node2supernode (make-hash))) (node2supernode (make-hash)))
(for-each-f (for-each
finish-times
(lambda (n) (lambda (n)
(if (not (hash-mem? dealt-with n)) (if (not (hash-mem? dealt-with n))
(let ((super-node (graph-make-node! component-graph empty))) (let ((super-node (graph-make-node! component-graph empty)))
@ -392,7 +393,8 @@
(graph-node-set! component-graph super-node (cons i (graph-node-label component-graph super-node))) (graph-node-set! component-graph super-node (cons i (graph-node-label component-graph super-node)))
(hash-put! node2supernode i super-node)) (hash-put! node2supernode i super-node))
(lambda (i) i) (lambda (i) i)
true))))) true))))
finish-times)
(graph-for-each-edge graph (graph-for-each-edge graph
(lambda (from to) (lambda (from to)
(graph-edge-add! component-graph (graph-edge-add! component-graph
@ -407,8 +409,8 @@
rtn)) rtn))
;;; ===================================================================== ;;; =====================================================================
;;; Utils ;;; Utils
(define graph-to-list (define graph-to-list
(case-lambda (case-lambda
@ -441,12 +443,9 @@
(define (graph-to-string-with-labels graph . 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)))) (graph-to-string-prv graph true (if (empty? to-string) true (first to-string))))
(define to-string-f (make-to-string `((,t? ,graph-to-string))))
(define debug-f (make-debug to-string-f))
(define for-each-f (make-for-each))
;;; ===================================================================== ;;; =====================================================================
;;; Tests ;;; Tests
(define (graph-test) (define (graph-test)
(define graph (make-graph 'safe 'directed)) (define graph (make-graph 'safe 'directed))
@ -470,8 +469,8 @@
(display (graph-edge-mem? graph 'a 'b)) (display (graph-edge-mem? graph 'a 'b))
(newline) (newline)
(debug-f (graph-to-list graph true)) (print-each (graph-to-list graph true))
(graph-for-each-edge graph (lambda (a b) (debug-f "A " a b))) (graph-for-each-edge graph (lambda (a b) (print-each "A " a b)))
(graph-dfs-from-node graph 'a (lambda (i) (display i))) (graph-dfs-from-node graph 'a (lambda (i) (display i)))
(newline) (newline)
@ -490,7 +489,7 @@
(graph-edge-add! star 'x 4) (graph-edge-add! star 'x 4)
(graph-edge-add! star 'x 5) (graph-edge-add! star 'x 5)
(graph-node-collapse! star 'x false) (graph-node-collapse! star 'x false)
(debug-f "collapsed:" (graph-to-list star))) (print-each "collapsed:" (graph-to-list star)))
(let ((strong-graph (make-graph 'directed))) (let ((strong-graph (make-graph 'directed)))
@ -513,11 +512,11 @@
(graph-edge-add! strong-graph 'xb 'xc) (graph-edge-add! strong-graph 'xb 'xc)
(graph-edge-add! strong-graph 'xc 'xa) (graph-edge-add! strong-graph 'xc 'xa)
(debug-f "strong-graph" strong-graph) (print-each "strong-graph" strong-graph)
(debug-f "component" (graph-components strong-graph)) (print-each "component" (graph-components strong-graph))
(let ((components (graph-strongly-connected-components strong-graph))) (let ((components (graph-strongly-connected-components strong-graph)))
(debug-f "strong-components" components) (print-each "strong-components" components)
(debug-f "toposort" (graph-topological-sort (first components))))) (print-each "toposort" (graph-topological-sort (first components)))))
(let ((u-graph (make-graph))) (let ((u-graph (make-graph)))
(graph-edge-add! u-graph 'a 'b) (graph-edge-add! u-graph 'a 'b)
@ -531,11 +530,11 @@
(graph-edge-add! u-graph 'xa 'xc) (graph-edge-add! u-graph 'xa 'xc)
(graph-edge-add! u-graph 'xb 'xd) (graph-edge-add! u-graph 'xb 'xd)
(newline) (newline)
(debug-f "u-graph" u-graph) (print-each "u-graph" u-graph)
(graph-edge-remove! u-graph 'b 'a) (graph-edge-remove! u-graph 'b 'a)
(graph-node-remove! u-graph 'd) (graph-node-remove! u-graph 'd)
(debug-f "u-graph" u-graph) (print-each "u-graph" u-graph)
(debug-f "component" (graph-components u-graph))) (print-each "component" (graph-components u-graph)))
) )
;(graph-test) ;(graph-test)

2
collects/mztake/demos/dijkstra/heap-speed-mztake.ss
View File

@ -1,5 +1,5 @@
(require (lib "mztake.ss" "mztake")) (require (lib "mztake.ss" "mztake"))
(set-main! "heap.ss") (set-main! '(lib "heap.ss" "frtime"))
(define start (current-milliseconds)) (define start (current-milliseconds))
(set-running! #t) (set-running! #t)

162
collects/mztake/demos/dijkstra/heap.ss
View File

@ -1,162 +0,0 @@
(module heap mzscheme
(require (lib "etc.ss")
"dv.ss")
(provide make-heap heap-empty? heap-size heap-insert heap-pop
heap-peak heap-remove heap-find
heap-contains heap-resort)
(define-struct t (sorter equality data))
;; sorter: elements which have the most trueness according to
;; the sorter pop out first
(define (make-heap sorter equality)
(let ((data (dv:make 5)))
(dv:append data 0)
(make-t sorter equality data)))
(define (heap-size heap)
(- (dv:length (t-data heap)) 1))
(define (heap-empty? heap)
(= (heap-size heap) 0))
(define (heap-last heap)
(- (dv:length (t-data heap)) 1))
(define (heap-parent i)
(floor (/ i 2)))
(define (heap-left i) (* i 2))
(define (heap-right i) (+ 1 (* i 2)))
(define (heap-has-right heap i)
(<= (heap-right i) (heap-last heap)))
(define (heap-has-left heap i)
(<= (heap-left i) (heap-last heap)))
(define (heap-insert heap item)
(let* ((sorter (t-sorter heap))
(data (t-data heap)))
(dv:append data item)
(let ((d (let loop ((prev (heap-last heap))
(current (heap-parent (heap-last heap))))
(cond ((= current 0) prev)
((sorter item (dv:ref data current))
(dv:set! data prev (dv:ref data current))
(loop current (heap-parent current)))
(#t prev)))))
(dv:set! data d item))))
(define (heap-peak heap)
(if (= (heap-size heap) 0) (error "heap-peak: empty")
(dv:ref (t-data heap) 1)))
(define (heap-pop heap)
(if (= (heap-size heap) 0) (error "heap-pop: empty")
(let ([result (dv:ref (t-data heap) 1)])
(heap-remove-pos heap 1)
result)))
(define (heap-remove-pos heap pos)
(let* ((data (t-data heap))
(sorter (t-sorter heap)))
(cond ((= 0 (heap-size heap)) (error "heap: removing from empty"))
((= pos (heap-last heap)) (dv:remove-last data))
(#t (let ((item (dv:ref data (heap-last heap))))
(dv:remove-last data)
(let loop ((current pos))
(dv:set! data current item)
(let* ((left (heap-left current))
(right (heap-right current))
(best-1 (if (and (heap-has-left heap current)
(sorter (dv:ref data left) item))
left current))
(best-2 (if (and (heap-has-right heap current)
(sorter (dv:ref data right)
(dv:ref data best-1)))
right best-1)))
(if (not (= best-2 current))
(begin (dv:set! data current (dv:ref data best-2))
(loop best-2))))))))))
;; return false if the object is not found
(define (heap-remove heap item)
(let ((pos (heap-find heap item)))
(if (not pos) false
(begin (heap-remove-pos heap pos) true))))
(define (heap-contains heap item)
(if (heap-find heap item) true false))
(define (heap-find heap item)
(let ((data (t-data heap))
(equality (t-equality heap))
(sorter (t-sorter heap)))
(let loop ((current 1))
(let ((current-item (dv:ref data current)))
(cond ((equality item current-item) current)
((sorter item current-item) #f)
(#t (or (and (heap-has-left heap current)
(not (sorter item (dv:ref data (heap-left current))))
(loop (heap-left current)))
(and (heap-has-right heap current)
(not (sorter item (dv:ref data (heap-right current))))
(loop (heap-right current))))))))))
(define (heap-resort heap item)
(heap-remove heap item)
(heap-insert heap item))
(define (test)
(define f (make-heap > eq?))
(define d (t-data f))
(heap-insert f 99)
;(debug "A " d)
(heap-remove-pos f 1)
;(debug "B " d)
(for-each (lambda (x) (heap-insert f x)) '(1 2 3 4 5 6 7 8 9 10 11 12 13 14))
;(debug "C " d)
(heap-remove f 10) ;(debug " " d)
(heap-remove f 5) ;(debug " " d)
(heap-remove f 8) ;(debug " " d)
(heap-remove f 13) ;(debug " " d)
;(debug (heap-contains f 11))
;(debug (heap-contains f 123))
(heap-pop f)
(heap-pop f)
(heap-pop f)
(heap-pop f) ;(debug " " d)
;(debug (heap-contains f 11))
;(debug (heap-contains f 4))
;(debug (heap-tostring f))
(heap-remove f 2)
;(debug (heap-tostring f))
(heap-remove f 3)
;(debug (heap-tostring f))
)
(define (test-speed)
(let loop ([count 3000])
(when (> count 0)
(test)
(loop (sub1 count)))))
; (time (test-speed))
)

2
collects/mztake/demos/random/random-mztake.ss
View File

@ -3,7 +3,7 @@
(lib "useful-code.ss" "mztake") (lib "useful-code.ss" "mztake")
(as-is mzscheme assoc)) (as-is mzscheme assoc))
(define/bind (loc "random.ss" 4 6) x) (define/bind (loc "random.ss" '(loop _)) x)
(define (assoc-inc l x) (define (assoc-inc l x)
(let ([filtered (filter (lambda (y) (not (eq? x (first y)))) l)] (let ([filtered (filter (lambda (y) (not (eq? x (first y)))) l)]

3
collects/mztake/demos/sine/sine-mztake.ss
View File

@ -2,8 +2,7 @@
(lib "useful-code.ss" "mztake")) (lib "useful-code.ss" "mztake"))
(require (lib "mztake.ss" "mztake")) (require (lib "mztake.ss" "mztake"))
;(define/bind (loc "sine.ss" 5 ) x sin-x) (define/bind (loc "sine.ss" '(if _) ) x sin-x)
(define/bind (loc "sine.ss" '(if _ ...) ) x sin-x)
(define (pick-cute-color x y) (define (pick-cute-color x y)
(if (< 200 y) (if (< 200 y)

2
collects/mztake/demos/sprofiler/sprofiler-mztake.ss
View File

@ -1,6 +1,6 @@
(require (lib "mztake.ss" "mztake" ) (require (lib "mztake.ss" "mztake" )
(lib "match.ss") (lib "match.ss")
(lib "more-useful-code.ss" "mztake")) (lib "base-gm.ss" "frtime"))
(set-main! "picture.ss") (set-main! "picture.ss")

21
collects/mztake/doc.txt
View File

@ -26,14 +26,14 @@ behavior of the program "highway-mztake.ss", in the demos directory of
the MzTake collection: the MzTake collection:
(require (lib "mztake.ss" "mztake")) (require (lib "mztake.ss" "mztake"))
(define/bind (loc "highway.ss" 3) speed) (define/bind (loc "highway.ss" 4) speed)
(printf-b "current speed: ~a" speed) (printf-b "current speed: ~a" speed)
;; more code ;; more code
(set-running! true) (set-running! true)
This code executes a target module in the file "highway.ss" This code executes a target module in the file "highway.ss"
after installing a _trace point_ (also known as a _watch after installing a _trace point_ (also known as a _watch
point_) just before the Scheme expression on the third line point_) just before the Scheme expression on the fourth line
of "highway.ss". SPEED is a FrTime behavior that always of "highway.ss". SPEED is a FrTime behavior that always
contains the *current* value of the variable named SPEED in contains the *current* value of the variable named SPEED in
the target program. the target program.
@ -167,7 +167,22 @@ _Installing Trace Points_
datum. For instance, to install a trace point on the tenth line of datum. For instance, to install a trace point on the tenth line of
the MzLib's list library, use: the MzLib's list library, use:
(trace (loc '(lib "list.ss") 10) ...) (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 ...) > (trace loc body ...)

27
collects/mztake/engine.ss
View File

@ -2,11 +2,12 @@
(require "marks.ss" (require "marks.ss"
(lib "etc.ss") (lib "etc.ss")
(lib "list.ss") (lib "list.ss")
(lib "match.ss")
(prefix frp: (lib "lang-ext.ss" "frtime")) (prefix frp: (lib "lang-ext.ss" "frtime"))
(rename (lib "frp-core.ss" "frtime") (rename (lib "frp-core.ss" "frtime")
frp:signal-thunk signal-thunk) frp:signal-thunk signal-thunk)
"useful-code.ss" "useful-code.ss"
"more-useful-code.ss" ; mostly for hash- bindings (lib "base-gm.ss" "frtime")
"mztake-structs.ss" "mztake-structs.ss"
"load-sandbox.ss" "load-sandbox.ss"
"annotator.ss" "annotator.ss"
@ -71,13 +72,13 @@
(define (pattern->pos stx-lst) (define (pattern->pos stx-lst)
(define (quote-symbols lst) (define (quote-symbols lst)
(cond (match lst
[(empty? lst) empty] [(? symbol? s) `(quote ,s)]
[(eq? lst '_) lst] [() empty]
[(eq? lst '...) lst] [('_ tl ...) `(_ ... ,@(quote-symbols tl))]
[(symbol? lst) `(quote ,lst)] [(hd tl ...) (cons (quote-symbols hd)
[else (cons (quote-symbols (first lst)) (quote-symbols tl))]
(quote-symbols (rest lst)))])) [item item]))
(define (collect-locations h stx lst) (define (collect-locations h stx lst)
(let loop ([stx stx] [lst lst]) (let loop ([stx stx] [lst lst])
@ -271,6 +272,11 @@
;; annotate-module? ;; annotate-module?
(lambda (filename module-name) (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) (or (process-has-file? process filename)
(policy-requests-annotatation? (debug-process-policy process) filename))) (policy-requests-annotatation? (debug-process-policy process) filename)))
@ -278,7 +284,10 @@
(lambda (stx) (lambda (stx)
(if (not (syntax-source stx)) (if (not (syntax-source stx))
stx stx
(let*-values ([(client) (find-client/create process (path->string (syntax-source stx)))] (let*-values ([(client)
(find-client/create
process
(path->string (syntax-source stx)))]
[(annotated-stx pos-list) [(annotated-stx pos-list)
(annotate-for-single-stepping (annotate-for-single-stepping
stx stx

54
collects/mztake/more-useful-code.ss
View File

@ -1,54 +0,0 @@
(module more-useful-code mzscheme
(require (lib "list.ss")
(lib "etc.ss"))
(provide make-hash
hash?
hash-get
hash-put!
hash-remove!
hash-map
hash-for-each
hash-size/slow
hash-mem?
hash-fold
hash-filter!
hash-keys
hash-values
hash-pairs
hash-add-all!
hash-get-or-define!)
(define make-hash make-hash-table)
(define hash? hash-table?)
(define hash-get hash-table-get)
(define hash-put! hash-table-put!)
(define hash-remove! hash-table-remove!)
(define hash-map hash-table-map)
(define hash-for-each hash-table-for-each)
(define (hash-empty? hash)(let/ec k (hash-for-each hash (lambda (k v) (k false))) true))
(define (hash-size/slow hash) (hash-fold hash 0 (lambda (key val acc) (+ acc 1))))
(define (hash-mem? hash item) (let/ec k (begin (hash-get hash item (lambda () (k false))) true)))
(define (hash-fold hash init fn)
(hash-for-each hash (lambda (key val) (set! init (fn key val init)))) init)
(define (hash-filter! hash predicate)
(hash-for-each
hash (lambda (key val) (if (not (predicate key val))
(hash-remove! hash key)))))
(define (hash-keys hash)
(hash-fold hash empty (lambda (key val acc) (cons key acc))))
(define (hash-values hash)
(hash-fold hash empty (lambda (key val acc) (cons val acc))))
(define (hash-pairs hash)
(hash-fold hash empty (lambda (key val acc) (cons (list key val) acc))))
(define (hash-add-all! to-hash from-hash) ;; // memcpy-style argument order
(hash-for-each from-hash
(lambda (key val) (hash-put! to-hash key val))))
(define (hash-get-or-define! hash key val-fn)
(if (not (hash-mem? hash key))
(begin (let ((v (val-fn)))
(hash-put! hash key v)
v))
(hash-get hash key))))

2
collects/mztake/mztake-structs.ss
View File

@ -1,7 +1,7 @@
(module mztake-structs mzscheme (module mztake-structs mzscheme
(require (lib "match.ss") (require (lib "match.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "more-useful-code.ss" "mztake")) (lib "base-gm.ss" "frtime"))
(provide (all-defined)) (provide (all-defined))

2
collects/mztake/mztake.ss
View File

@ -6,7 +6,7 @@
(rename (lib "frtime.ss" "frtime") frp:value-nowable? value-nowable?) (rename (lib "frtime.ss" "frtime") frp:value-nowable? value-nowable?)
(rename (lib "frtime.ss" "frtime") frp:behaviorof behaviorof) (rename (lib "frtime.ss" "frtime") frp:behaviorof behaviorof)
"mztake-structs.ss" "mztake-structs.ss"
"more-useful-code.ss" (lib "base-gm.ss" "frtime")
(lib "etc.ss") (lib "etc.ss")
(lib "list.ss") (lib "list.ss")
"marks.ss" "marks.ss"