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

deleted obsolete stuff MzTake Publicity, Talk, and interface

Browse Source 
svn: r185
This commit is contained in:
Guillaume Marceau 2005-06-14 16:06:28 +00:00
parent e82a136fbe
commit cf34a57f36
7 changed files with 495 additions and 503 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/mztake/demos/dijkstra/dijkstra-mztake-uncommented.ss
View File

@ -1,11 +1,9 @@
(require "dijkstra-solver.ss" (require (lib "mztake.ss" "mztake")
"dijkstra-solver.ss"
(lib "match.ss")) (lib "match.ss"))
(define/bind (loc "heap.ss" 49 6) item)
(define-mztake-process p (define/bind (loc "heap.ss" 67 10) result)
("dijkstra.ss")
("heap.ss" [inserts 49 6 bind 'item]
[removes 67 10 bind 'result]))
(define (not-in-order e) (define (not-in-order e)
(filter-e (filter-e
@ -39,4 +37,4 @@
(define inserters (accum-b (inserts . ==> . insert-in-model) empty)) (define inserters (accum-b (inserts . ==> . insert-in-model) empty))
(define removers (accum-b (removes . ==> . remove-from-model) inserters)) (define removers (accum-b (removes . ==> . remove-from-model) inserters))
(start/resume p) (set-running-e! (violations . -=> . false))

8
collects/mztake/demos/exception/exception-mztake-uncommented.ss
View File

@ -1,7 +1,7 @@
(define-mztake-process p ("exception.ss")) (set-main! "exception.ss")
(printf-b "exception.ss exited? ~a" (process:exited? p)) (printf-b "exception.ss exited? ~a" (process:exited?))
(printf-b "last exception seen: ~a" (hold (process:exceptions p))) (printf-b "last exception seen: ~a" (hold (process:exceptions)))
(start/resume p) (set-running! true)

9
collects/mztake/demos/first-class/first-class-mztake-uncommented.ss
View File

@ -1,6 +1,7 @@
(define-mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x] (define x-before-let (trace (loc "first-class.ss" 3 29) (bind (x) x)))
[x-in-let 4 25 bind 'x] (define x-in-let (trace (loc "first-class.ss" 4 25) (bind (x) x)))
[x-after-let 5 11 bind 'x])) (define x-after-let (trace (loc "first-class.ss" 5 11) (bind (x) x)))
(printf-b "Number of times x updates, should be 12: ~a" (printf-b "Number of times x updates, should be 12: ~a"
(count-b (merge-e x-before-let (count-b (merge-e x-before-let
@ -11,4 +12,4 @@
(printf-b "x in let, should be (6 10 14 16): ~a" (history-b 4 x-in-let)) (printf-b "x in let, should be (6 10 14 16): ~a" (history-b 4 x-in-let))
(printf-b "x after let, should be (5 9 13 15): ~a" (history-b 4 x-after-let)) (printf-b "x after let, should be (5 9 13 15): ~a" (history-b 4 x-after-let))
(start/resume p) (set-running! true)

8
collects/mztake/demos/highway/highway-mztake-uncommented.ss
View File

@ -1,7 +1,7 @@
(require (lib "animation.ss" "frtime")) (require (lib "mztake.ss" "mztake")
(lib "animation.ss" "frtime"))
(define-mztake-process radar-program ("highway.ss" [values-of-speed 3 4 bind 'speed]))
(define/bind (loc "highway.ss" 3 4) speed)
(printf-b "current speed: ~a" (hold values-of-speed)) (printf-b "current speed: ~a" (hold values-of-speed))
(printf-b "last ten speeds: ~a" (history-b 10 values-of-speed)) (printf-b "last ten speeds: ~a" (history-b 10 values-of-speed))
@ -25,4 +25,4 @@
(display-shapes (make-speed-gauge (hold values-of-speed))) (display-shapes (make-speed-gauge (hold values-of-speed)))
(start/resume radar-program) (set-runnning! true)

20
collects/mztake/demos/montecarlo/montecarlo-mztake-uncommented.ss
View File

@ -1,19 +1,11 @@
(require (lib "graphics.ss" "graphics")) (require (lib "graphics.ss" "graphics")
(lib "match.ss"))
(open-graphics) (open-graphics)
(define window (open-viewport "Debugger" 400 400)) (define window (open-viewport "Debugger" 400 400))
(define/bind (loc "montecarlo.ss" 13 13) x y pi)
(define-mztake-process p ("montecarlo.ss" [x/y/pi-trace 13 13 bind '(x y pi)]))
(define x/y/pi (hold x/y/pi-trace))
(define x (+ 200 (first x/y/pi)))
(define y (+ 200 (second x/y/pi)))
(define current-pi (third x/y/pi))
(printf-b "total points chosen: ~a" (count-b (changes x))) (printf-b "total points chosen: ~a" (count-b (changes x)))
@ -26,8 +18,8 @@
((draw-solid-ellipse window) (make-posn 0 0) 400 400 "sienna") ((draw-solid-ellipse window) (make-posn 0 0) 400 400 "sienna")
(map-e (lambda (x/y) ((draw-solid-ellipse window) (make-posn (first x/y) (second x/y)) (map-e (match-lambda [(x y) ((draw-solid-ellipse window) (make-posn x y)
3 3 "black")) 3 3 "black")])
(changes (list x y))) (changes (list x y)))
(start/resume p) (set-running! true)

7
collects/mztake/demos/random/random-mztake-uncommented.ss
View File

@ -1,5 +1,6 @@
(require (lib "graphics.ss" "graphics") (require (lib "graphics.ss" "graphics")
(lifted mzscheme (lib "mztake.ss" "mztake")
(lifted mzscheme
make-hash-table make-hash-table
hash-table-put! hash-table-put!
hash-table-get)) hash-table-get))
@ -10,7 +11,7 @@
((draw-viewport window) (make-rgb 0.95 0.95 0.95)) ((draw-viewport window) (make-rgb 0.95 0.95 0.95))
(define-mztake-process p ("random.ss" [x-trace 4 6 bind 'x])) (define/bind (loc "random.ss" 4 6) x)
(define largest-bin 0) (define largest-bin 0)
@ -40,4 +41,4 @@
(printf-b "count: ~a" (count-b x-trace)) (printf-b "count: ~a" (count-b x-trace))
(start/resume p) (set-running! true)

934
collects/mztake/mztake.ss
View File

@ -1,467 +1,467 @@
(module mztake mzscheme (module mztake mzscheme
(define mztake-version "rev. 8/6/2004") (define mztake-version "rev. 8/6/2004")
(require (lib "match.ss") (require (lib "match.ss")
(lib "contract.ss") (lib "contract.ss")
(lib "marks.ss" "mztake" "private") (lib "marks.ss" "mztake" "private")
(prefix frp: (lib "frp.ss" "frtime")) (prefix frp: (lib "frp.ss" "frtime"))
(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)
(lib "useful-code.ss" "mztake" "private") (lib "useful-code.ss" "mztake" "private")
(lib "more-useful-code.ss" "mztake" "private") ; mostly for hash- bindings (lib "more-useful-code.ss" "mztake" "private") ; mostly for hash- bindings
"mztake-structs.ss" "mztake-structs.ss"
(lib "load-annotator.ss" "mztake" "private") (lib "load-annotator.ss" "mztake" "private")
"annotator.ss" "annotator.ss"
) )
(provide/contract [kill (() (debug-process?) . opt-> . void?)] (provide/contract [kill (() (debug-process?) . opt-> . void?)]
[kill-all (-> void?)] [kill-all (-> void?)]
[pause (() (debug-process?) . opt-> . void?)] [pause (() (debug-process?) . opt-> . void?)]
[resume (debug-process? . -> . void?)] [resume (debug-process? . -> . void?)]
[set-running-e! (frp:event? . -> . void?)] [set-running-e! (frp:event? . -> . void?)]
[set-running! (frp:value-nowable? . -> . void?)] [set-running! (frp:value-nowable? . -> . void?)]
[rename debug-process-exceptions [rename debug-process-exceptions
process:exceptions process:exceptions
(debug-process? . -> . frp:event?)] (() (debug-process?) . opt-> . frp:event?)]
[rename debug-process-exited? [rename debug-process-exited?
process:exited? process:exited?
(debug-process? . -> . frp:behavior?)]) (debug-process? . -> . frp:behavior?)])
#| DISABLED - BROKEN #| DISABLED - BROKEN
[process:running? (debug-process? . -> . frp:behavior?)] [process:running? (debug-process? . -> . frp:behavior?)]
[rename time-per-event/milliseconds [rename time-per-event/milliseconds
process:time-per-event/milliseconds process:time-per-event/milliseconds
(debug-process? frp:behavior? . -> . frp:behavior?)] (debug-process? frp:behavior? . -> . frp:behavior?)]
|# |#
; ; ; ; ; ; ; ;
; ;;;;;; ; ; ; ; ; ; ;;;;;; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ;;;; ; ;;;; ;;;; ; ; ; ;;;; ; ;;; ;;;; ; ; ; ;;;; ; ;;;; ;;;; ; ; ; ;;;; ; ;;; ;;;;
; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ;;;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ;
; ;;;;;; ; ;;;; ;;;;;; ;;;; ; ; ; ;;;; ; ; ;;;; ; ;;;;;; ; ;;;; ;;;;;; ;;;; ; ; ; ;;;; ; ; ;;;;
;Keeps track of all debugging processes ;Keeps track of all debugging processes
(define all-debug-processes null) (define all-debug-processes null)
; turns debug output on and off ; turns debug output on and off
(define debugging? #f) (define debugging? #f)
;########################################################################################################### ;###########################################################################################################
; ; ; ; ; ; ; ;
; ;;;;;; ; ;;;;;; ; ; ; ;;;;;; ; ;;;;;; ; ;
; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ;;;; ;;;;;; ; ;;; ; ; ;;;; ;;; ; ; ;;; ; ;;;; ;;;;;; ; ; ; ; ;;;; ;;;;;; ; ;;; ; ; ;;;; ;;; ; ; ;;; ; ;;;; ;;;;;;
; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;;;;;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;;
; ;;;;;; ;;;;;; ;;;; ; ; ;;;;;; ;;;; ; ;;; ; ; ;;;; ; ; ;;;; ; ; ;;;;;; ;;;;;; ;;;; ; ; ;;;;;; ;;;; ; ;;; ; ; ;;;; ; ; ;;;; ;
; ; ; ;
; ; ; ; ; ;
; ;;;; ; ;;;;
(define (kill process) (define (kill process)
(unless (debug-process-exited? process) (unless (debug-process-exited? process)
(process:->dead process))) (process:->dead process)))
(define (kill-all) (define (kill-all)
(unless (empty? all-debug-processes) (unless (empty? all-debug-processes)
(for-each (lambda (p) (kill p)) all-debug-processes) (for-each (lambda (p) (kill p)) all-debug-processes)
(display "All debug processes have been killed."))) (display "All debug processes have been killed.")))
; wrapper for errors related to the script only ; wrapper for errors related to the script only
(define (script-error err) (define (script-error err)
(raise-syntax-error 'mztake:script-error (format "~a" err)) (raise-syntax-error 'mztake:script-error (format "~a" err))
(kill-all)) (kill-all))
(define (client-error err) (define (client-error err)
(display (format "mztake:client-error: ~a~n---~n" err)) (display (format "mztake:client-error: ~a~n---~n" err))
(kill-all)) (kill-all))
(define (print-debug str) (define (print-debug str)
(when debugging? (when debugging?
(display (format "mztake:debug: ~a~n---~n" str)))) (display (format "mztake:debug: ~a~n---~n" str))))
(define (print-info str) (define (print-info str)
(display (format "mztake: ~a~n---~n" str))) (display (format "mztake: ~a~n---~n" str)))
;; returns a memoized function that takes (line column) -> position ;; returns a memoized function that takes (line column) -> position
;; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?))) ;; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?)))
(define (line-col->pos filename) (define (line-col->pos filename)
; produces a nested list of (line column offset) for all addressable syntax ; produces a nested list of (line column offset) for all addressable syntax
(define (unwrap-syntax stx) (define (unwrap-syntax stx)
(let ([elt (list (syntax-line stx) (let ([elt (list (syntax-line stx)
(syntax-column stx) (syntax-column stx)
(sub1 (syntax-position stx)))]) (sub1 (syntax-position stx)))])
(syntax-case stx () (syntax-case stx ()
[(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))] [(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))]
[x elt]))) [x elt])))
(let ([pos-list (let ([pos-list
(flatten (parameterize ([port-count-lines-enabled #t]) (flatten (parameterize ([port-count-lines-enabled #t])
(let ([port (open-input-file filename)]) (let ([port (open-input-file filename)])
(begin0 (begin0
(let loop ([stx (read-syntax filename port)]) (let loop ([stx (read-syntax filename port)])
(if (eof-object? stx) '() (if (eof-object? stx) '()
(cons (unwrap-syntax stx) (cons (unwrap-syntax stx)
(loop (read-syntax filename port))))) (loop (read-syntax filename port)))))
(close-input-port port)))))]) (close-input-port port)))))])
(lambda (line col) (lambda (line col)
(let loop ([lst pos-list] (let loop ([lst pos-list]
[last-coord (first pos-list)]) [last-coord (first pos-list)])
(cond (cond
; none is found ; none is found
[(empty? lst) [(empty? lst)
(raise (format "No syntax found for trace at line/column ~a:~a in client `~a'" line col filename))] (raise (format "No syntax found for trace at line/column ~a:~a in client `~a'" line col filename))]
; if first is correct line and correct column ; if first is correct line and correct column
[(and (= line (caar lst)) [(and (= line (caar lst))
(= col (cadar lst))) (= col (cadar lst)))
(third (first lst))] (third (first lst))]
[else (loop (rest lst) [else (loop (rest lst)
(first lst))]))))) (first lst))])))))
;########################################################################################################### ;###########################################################################################################
; ;;;;;; ;;;;;;; ; ;;;;;; ;;;;;;;
; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ;
; ; ; ; ;;; ;;;; ;;; ;;; ;;;; ;;;; ; ; ; ; ;;;; ;;; ;;;; ; ; ; ; ;;; ;;;; ;;; ;;; ;;;; ;;;; ; ; ; ; ;;;; ;;; ;;;;
; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;;;;; ; ; ; ; ;;;;;;; ;;;; ;;;; ; ; ; ; ; ; ;;;; ; ;;;;;; ; ; ; ; ;;;;;;; ;;;; ;;;; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;
; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;; ; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;;
(define (find-client process modpath) (define (find-client process modpath)
(cond (cond
[(memf (lambda (c) (equal? (debug-client-modpath c) (path->string modpath))) [(memf (lambda (c) (equal? (debug-client-modpath c) (path->string modpath)))
(debug-process-clients process)) => first] (debug-process-clients process)) => first]
[else false])) [else false]))
(define (break? process client) (define (break? process client)
(let ([tracepoints (and client (debug-client-tracepoints client))]) (let ([tracepoints (and client (debug-client-tracepoints client))])
(lambda (pos) (lambda (pos)
(or (debug-process-pause-requested? process) (or (debug-process-pause-requested? process)
(and tracepoints (and tracepoints
(hash-get tracepoints (sub1 pos) (lambda () false))))))) (hash-get tracepoints (sub1 pos) (lambda () false)))))))
(define (receive-result process client top-mark rest-marks) (define (receive-result process client top-mark rest-marks)
(let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))] (let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))]
[traces (hash-get (debug-client-tracepoints client) byte-offset (lambda () empty))] [traces (hash-get (debug-client-tracepoints client) byte-offset (lambda () empty))]
[marks (cons top-mark (continuation-mark-set->list rest-marks debug-key))] [marks (cons top-mark (continuation-mark-set->list rest-marks debug-key))]
[w (map (compose syntax-local-infer-name mark-source) marks)] [w (map (compose syntax-local-infer-name mark-source) marks)]
[where-event ((frp:signal-thunk (debug-process-where process)) #t)]) [where-event ((frp:signal-thunk (debug-process-where process)) #t)])
(set-debug-process-marks! process marks) (set-debug-process-marks! process marks)
(if (empty? traces) (if (empty? traces)
(frp:send-synchronous-event where-event w) (frp:send-synchronous-event where-event w)
; Run all traces at this trace point ; Run all traces at this trace point
(let* ([to-send (map (lambda (t) (let* ([to-send (map (lambda (t)
(list (trace-struct-evnt-rcvr t) (list (trace-struct-evnt-rcvr t)
((trace-struct-thunk t)))) ((trace-struct-thunk t))))
traces)]) traces)])
(frp:send-synchronous-events (cons (list where-event w) to-send)))) (frp:send-synchronous-events (cons (list where-event w) to-send))))
; Now that we processed the trace, do we want to pause or continue ; Now that we processed the trace, do we want to pause or continue
(when (debug-process-pause-requested? process) (when (debug-process-pause-requested? process)
(set-debug-process-pause-requested?! process false) (set-debug-process-pause-requested?! process false)
(let loop () (let loop ()
(unless (debug-process-resume-requested? process) (unless (debug-process-resume-requested? process)
(semaphore-wait (debug-process-run-semaphore process)) (semaphore-wait (debug-process-run-semaphore process))
(loop))) (loop)))
(set-debug-process-resume-requested?! process false)) (set-debug-process-resume-requested?! process false))
(set-debug-process-marks! process false))) (set-debug-process-marks! process false)))
(define ((break-after process client) top-mark marks . vals) (define ((break-after process client) top-mark marks . vals)
(receive-result process client top-mark marks) ; TODO: have access to return value (receive-result process client top-mark marks) ; TODO: have access to return value
(apply values vals)) ; TODO: allow modification of the return value (apply values vals)) ; TODO: allow modification of the return value
(define ((break-before process client) top-mark marks) (define ((break-before process client) top-mark marks)
(receive-result process client top-mark marks) ; TODO: allow substitute value (receive-result process client top-mark marks) ; TODO: allow substitute value
false) false)
(define (launch-sandbox process) (define (launch-sandbox process)
(require/sandbox+annotations (require/sandbox+annotations
(debug-process-custodian process) (debug-process-custodian process)
;; error-display-handler : ;; error-display-handler :
(let ([orig-err-disp (error-display-handler)]) (let ([orig-err-disp (error-display-handler)])
(lambda (msg exn) (lambda (msg exn)
(frp:send-event (debug-process-exceptions process) exn) (frp:send-event (debug-process-exceptions process) exn)
(orig-err-disp msg exn))) (orig-err-disp msg exn)))
`(file ,(debug-client-modpath (debug-process-main-client process))) `(file ,(debug-client-modpath (debug-process-main-client process)))
;; annotate-module? ;; annotate-module?
(lambda (filename module-name) (lambda (filename module-name)
(memf (lambda (c) (equal? (debug-client-modpath c) (path->string filename)));; TODO: harmonize path & string (memf (lambda (c) (equal? (debug-client-modpath c) (path->string filename)));; TODO: harmonize path & string
(debug-process-clients process))) (debug-process-clients process)))
;; annotator ;; annotator
(lambda (stx) (lambda (stx)
(let ([client (and (syntax-source stx) (let ([client (and (syntax-source stx)
(find-client process (syntax-source stx)))]) (find-client process (syntax-source stx)))])
(if (not client) (if (not client)
stx stx
(let-values ([(annotated-stx pos-list) (let-values ([(annotated-stx pos-list)
(annotate-for-single-stepping (annotate-for-single-stepping
stx stx
(break? process client) (break? process client)
(break-before process client) (break-before process client)
(break-after process client) (break-after process client)
(lambda (kind bound binding) (void)))]) (lambda (kind bound binding) (void)))])
annotated-stx)))))) annotated-stx))))))
(define (process:new->running process) (define (process:new->running process)
(set-debug-process-run-semaphore! process (make-semaphore)) (set-debug-process-run-semaphore! process (make-semaphore))
(thread (lambda () (thread (lambda ()
(launch-sandbox process) (launch-sandbox process)
(process:running->finished process)))) (process:running->finished process))))
(define (process:running->finished process) (define (process:running->finished process)
(process:->dead process)) (process:->dead process))
(define (process:->dead process) (define (process:->dead process)
(set! all-debug-processes (remq process all-debug-processes)) (set! all-debug-processes (remq process all-debug-processes))
(custodian-shutdown-all (debug-process-custodian process)) (custodian-shutdown-all (debug-process-custodian process))
(frp:set-cell! (debug-process-exited? process) true)) (frp:set-cell! (debug-process-exited? process) true))
(define set-running-e! (define set-running-e!
(opt-lambda (e [process (current-process)]) (opt-lambda (e [process (current-process)])
(resume process) (resume process)
(frp:set-cell! (debug-process-running-e process) e))) (frp:set-cell! (debug-process-running-e process) e)))
(define set-running! (define set-running!
(opt-lambda (b [process (current-process)]) (opt-lambda (b [process (current-process)])
(if (frp:value-now b) (resume process) (pause process)) (if (frp:value-now b) (resume process) (pause process))
(frp:set-cell! (debug-process-running-e process) (frp:changes b)))) (frp:set-cell! (debug-process-running-e process) (frp:changes b))))
(define (process:running->paused process) (define (process:running->paused process)
(set-debug-process-pause-requested?! process true)) (set-debug-process-pause-requested?! process true))
(define (process:paused->running process) (define (process:paused->running process)
(set-debug-process-resume-requested?! process true) (set-debug-process-resume-requested?! process true)
(semaphore-post (debug-process-run-semaphore process))) (semaphore-post (debug-process-run-semaphore process)))
(define (main-client-name process) (define (main-client-name process)
(let-values ([(_ name __) (let-values ([(_ name __)
(split-path (debug-client-modpath (debug-process-main-client process)))]) (split-path (debug-client-modpath (debug-process-main-client process)))])
name)) name))
(define (pause process) (define (pause process)
(when (and (debug-process-run-semaphore process) (when (and (debug-process-run-semaphore process)
(not (frp:value-now (debug-process-exited? process))) (not (frp:value-now (debug-process-exited? process)))
(not (debug-process-pause-requested? process))) (not (debug-process-pause-requested? process)))
(process:running->paused process))) (process:running->paused process)))
(define (resume process) (define (resume process)
(cond (cond
[(not (debug-process-run-semaphore process)) (process:new->running process)] [(not (debug-process-run-semaphore process)) (process:new->running process)]
[(and (not (frp:value-now (debug-process-exited? process))) [(and (not (frp:value-now (debug-process-exited? process)))
(not (debug-process-resume-requested? process))) (not (debug-process-resume-requested? process)))
(process:paused->running process)])) (process:paused->running process)]))
(define (create-debug-process) (define (create-debug-process)
(letrec ([running-e (frp:new-cell frp:never-e)] (letrec ([running-e (frp:new-cell frp:never-e)]
[run-manager (running-e . frp:==> . [run-manager (running-e . frp:==> .
(lambda (r) (lambda (r)
(if r (resume process) (pause process))))] (if r (resume process) (pause process))))]
[process (make-debug-process (make-custodian) [process (make-debug-process (make-custodian)
false ; run-semaphore - false so we know it has never started false ; run-semaphore - false so we know it has never started
running-e ; running-e running-e ; running-e
run-manager ; run-manager run-manager ; run-manager
false ; pause-requested? false ; pause-requested?
false ; resume-requested? false ; resume-requested?
(frp:new-cell false) ; exited? (frp:new-cell false) ; exited?
(frp:event-receiver) ; exceptions (frp:event-receiver) ; exceptions
false ; main-client false ; main-client
empty ; clients empty ; clients
(frp:new-cell empty) ; where (frp:new-cell empty) ; where
false)]) ; marks false)]) ; marks
(set! all-debug-processes (cons process all-debug-processes)) (set! all-debug-processes (cons process all-debug-processes))
process)) process))
(define where (define where
(frp:new-cell empty)) (frp:new-cell empty))
(define current-process (define current-process
(let* ([proc (create-debug-process)] (let* ([proc (create-debug-process)]
[p (make-parameter proc)]) [p (make-parameter proc)])
(frp:set-cell! where (debug-process-where proc)) (frp:set-cell! where (debug-process-where proc))
(case-lambda (case-lambda
[() (p)] [() (p)]
[(new-p) (frp:set-cell! where (debug-process-where new-p)) (p new-p)]))) [(new-p) (frp:set-cell! where (debug-process-where new-p)) (p new-p)])))
;########################################################################################################### ;###########################################################################################################
; ;;;;; ; ; ;;;;;;; ; ;;;;; ; ; ;;;;;;;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ;
; ; ;;; ; ;;; ; ; ;;;; ;;;;; ; ; ; ; ;;;; ;;; ;;;; ; ; ;;; ; ;;; ; ; ;;;; ;;;;; ; ; ; ; ;;;; ;;; ;;;;
; ; ; ; ;; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ;; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;
; ;;;;; ;;; ; ; ;;;;;; ;;; ; ;;;; ; ; ; ;;; ;;;; ; ;;;;; ;;; ; ; ;;;;;; ;;; ; ;;;; ; ; ; ;;; ;;;;
; ; ; ;
; ; ; ;
; ; ; ;
; Creates a debugger client ; Creates a debugger client
; (debug-process? require-path. -> . debug-file?) ; (debug-process? require-path. -> . debug-file?)
(define (create-debug-client process modpath) (define (create-debug-client process modpath)
; throwaway namespace so the module-name-resolver doesn't load an unannotated module ; throwaway namespace so the module-name-resolver doesn't load an unannotated module
(parameterize ([current-namespace (make-namespace)]) (parameterize ([current-namespace (make-namespace)])
(let ([client (create-empty-debug-client)]) (let ([client (create-empty-debug-client)])
(for-each (lambda (c) (for-each (lambda (c)
(when (equal? modpath (debug-client-modpath c)) (when (equal? modpath (debug-client-modpath c))
(raise-syntax-error 'mztake:script-error:create-debug-client (raise-syntax-error 'mztake:script-error:create-debug-client
(format "A client for `~a' is already defined for this process." modpath)))) (format "A client for `~a' is already defined for this process." modpath))))
(debug-process-clients process)) (debug-process-clients process))
(set-debug-client-modpath! client modpath) (set-debug-client-modpath! client modpath)
(set-debug-client-process! client process) (set-debug-client-process! client process)
(set-debug-client-line-col->pos! client (line-col->pos modpath)) (set-debug-client-line-col->pos! client (line-col->pos modpath))
(set-debug-process-clients! process (set-debug-process-clients! process
(append (list client) (debug-process-clients process))) (append (list client) (debug-process-clients process)))
; set the main module if it has not been set ; set the main module if it has not been set
; this implies that the first client created is always the main module ; this implies that the first client created is always the main module
(unless (debug-process-main-client process) (unless (debug-process-main-client process)
(set-debug-process-main-client! process client)) (set-debug-process-main-client! process client))
client))) client)))
(define (set-main! mod-path) (define (set-main! mod-path)
(let ([client (find-client (current-process) mod-path)]) (let ([client (find-client (current-process) mod-path)])
(if client (if client
(set-debug-process-main-client! (current-process) client) (set-debug-process-main-client! (current-process) client)
(create-debug-client (current-process) mod-path)))) (create-debug-client (current-process) mod-path))))
(define (hold-b b) (define (hold-b b)
(frp:hold (frp:filter-e (lambda (ev) (not (frp:undefined? ev))) (frp:changes b)))) (frp:hold (frp:filter-e (lambda (ev) (not (frp:undefined? ev))) (frp:changes b))))
(define (expand-module-filename filename) (define (expand-module-filename filename)
(define (build-module-filename str) ; taken from module-overview.ss (define (build-module-filename str) ; taken from module-overview.ss
(let ([try (lambda (ext) (let ([try (lambda (ext)
(let ([tst (string-append str ext)]) (let ([tst (string-append str ext)])
(and (file-exists? tst) tst)))]) (and (file-exists? tst) tst)))])
(or (try ".ss") (try ".scm") (try "") str))) (or (try ".ss") (try ".scm") (try "") str)))
(let ([modpath (symbol->string ((current-module-name-resolver) filename #f #f))]) (let ([modpath (symbol->string ((current-module-name-resolver) filename #f #f))])
(build-module-filename (build-module-filename
(if (regexp-match #rx"^," modpath) (if (regexp-match #rx"^," modpath)
(substring modpath 1 (string-length modpath)) (substring modpath 1 (string-length modpath))
modpath)))) modpath))))
(define (trace* loc thunk) (define (trace* loc thunk)
(let* ([modpath (expand-module-filename (loc-modpath loc))] (let* ([modpath (expand-module-filename (loc-modpath loc))]
[clients (filter (lambda (c) [clients (filter (lambda (c)
(equal? modpath (debug-client-modpath c))) (equal? modpath (debug-client-modpath c)))
(debug-process-clients (current-process)))] (debug-process-clients (current-process)))]
[client (if (empty? clients) [client (if (empty? clients)
(create-debug-client (current-process) modpath) (create-debug-client (current-process) modpath)
(first clients))] (first clients))]
[trace-hash (debug-client-tracepoints client)] [trace-hash (debug-client-tracepoints client)]
[trace (make-trace-struct (frp:event-receiver) thunk)] [trace (make-trace-struct (frp:event-receiver) thunk)]
[pos ((debug-client-line-col->pos client) (loc-line loc) (loc-col loc))]) [pos ((debug-client-line-col->pos client) (loc-line loc) (loc-col loc))])
; add the trace to the list of traces for that byte-offset ; add the trace to the list of traces for that byte-offset
(hash-put! trace-hash pos (hash-put! trace-hash pos
(append (hash-get trace-hash pos (lambda () '())) (append (hash-get trace-hash pos (lambda () '()))
(list trace))) (list trace)))
(trace-struct-evnt-rcvr trace))) (trace-struct-evnt-rcvr trace)))
(define-syntax trace (define-syntax trace
(syntax-rules () (syntax-rules ()
[(_ loc) [(_ loc)
(trace* loc (lambda () true))] (trace* loc (lambda () true))]
[(_ loc body ...) [(_ loc body ...)
(trace* loc (lambda () body ...))])) (trace* loc (lambda () body ...))]))
(define-syntax bind (define-syntax bind
(syntax-rules () (syntax-rules ()
[(_ (name ...) body0 body ...) [(_ (name ...) body0 body ...)
(let ([name (mark-binding-value (let ([name (mark-binding-value
(first (lookup-all-bindings (first (lookup-all-bindings
(lambda (id) (eq? (syntax-e id) 'name)) (lambda (id) (eq? (syntax-e id) 'name))
(debug-process-marks (current-process)))))] ...) (debug-process-marks (current-process)))))] ...)
body0 body ...)])) body0 body ...)]))
(define-syntax define/bind (define-syntax define/bind
(syntax-rules () (syntax-rules ()
[(_ loc name ...) [(_ loc name ...)
(begin (begin
(define here loc) (define here loc)
(define name (frp:hold (trace here (bind (name) name)))) (define name (frp:hold (trace here (bind (name) name))))
...)])) ...)]))
(define (syntax-local-infer-name stx) (define (syntax-local-infer-name stx)
(or (syntax-property stx 'inferred-name) (or (syntax-property stx 'inferred-name)
(let ([s (syntax-source stx)]) (let ([s (syntax-source stx)])
(and s (and s
(let ([s (cond (let ([s (cond
[(path? s) (path->string s)] [(path? s) (path->string s)]
[else s])] [else s])]
[l (syntax-line stx)] [l (syntax-line stx)]
[c (syntax-column stx)]) [c (syntax-column stx)])
(if l (if l
(string->symbol (format "~a:~a:~a" s l c)) (string->symbol (format "~a:~a:~a" s l c))
(let ([p (syntax-position stx)]) (let ([p (syntax-position stx)])
(string->symbol (format "~a::~a" s p))))))))) (string->symbol (format "~a::~a" s p)))))))))
(provide loc$ loc loc-modpath loc-line loc-col (provide loc$ loc loc-modpath loc-line loc-col
trace trace* bind define/bind create-debug-process trace trace* bind define/bind create-debug-process
create-debug-client where set-main! create-debug-client where set-main!
mztake-version) mztake-version)
;########################################################################################################### ;###########################################################################################################
) )