From cf34a57f36ece268261bbc7642a1abfdc74c2823 Mon Sep 17 00:00:00 2001 From: Guillaume Marceau Date: Tue, 14 Jun 2005 16:06:28 +0000 Subject: [PATCH] deleted obsolete stuff MzTake Publicity, Talk, and interface svn: r185 --- .../dijkstra/dijkstra-mztake-uncommented.ss | 12 +- .../exception/exception-mztake-uncommented.ss | 8 +- .../first-class-mztake-uncommented.ss | 9 +- .../highway/highway-mztake-uncommented.ss | 8 +- .../montecarlo-mztake-uncommented.ss | 20 +- .../demos/random/random-mztake-uncommented.ss | 7 +- collects/mztake/mztake.ss | 934 +++++++++--------- 7 files changed, 495 insertions(+), 503 deletions(-) diff --git a/collects/mztake/demos/dijkstra/dijkstra-mztake-uncommented.ss b/collects/mztake/demos/dijkstra/dijkstra-mztake-uncommented.ss index fc4f621702..2cf4183a27 100644 --- a/collects/mztake/demos/dijkstra/dijkstra-mztake-uncommented.ss +++ b/collects/mztake/demos/dijkstra/dijkstra-mztake-uncommented.ss @@ -1,11 +1,9 @@ -(require "dijkstra-solver.ss" +(require (lib "mztake.ss" "mztake") + "dijkstra-solver.ss" (lib "match.ss")) - -(define-mztake-process p - ("dijkstra.ss") - ("heap.ss" [inserts 49 6 bind 'item] - [removes 67 10 bind 'result])) +(define/bind (loc "heap.ss" 49 6) item) +(define/bind (loc "heap.ss" 67 10) result) (define (not-in-order e) (filter-e @@ -39,4 +37,4 @@ (define inserters (accum-b (inserts . ==> . insert-in-model) empty)) (define removers (accum-b (removes . ==> . remove-from-model) inserters)) -(start/resume p) \ No newline at end of file +(set-running-e! (violations . -=> . false)) \ No newline at end of file diff --git a/collects/mztake/demos/exception/exception-mztake-uncommented.ss b/collects/mztake/demos/exception/exception-mztake-uncommented.ss index ddb41c3ee1..1e8e42383b 100644 --- a/collects/mztake/demos/exception/exception-mztake-uncommented.ss +++ b/collects/mztake/demos/exception/exception-mztake-uncommented.ss @@ -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) \ No newline at end of file +(set-running! true) \ No newline at end of file diff --git a/collects/mztake/demos/first-class/first-class-mztake-uncommented.ss b/collects/mztake/demos/first-class/first-class-mztake-uncommented.ss index c86bf13425..9f8199e64d 100644 --- a/collects/mztake/demos/first-class/first-class-mztake-uncommented.ss +++ b/collects/mztake/demos/first-class/first-class-mztake-uncommented.ss @@ -1,6 +1,7 @@ -(define-mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x] - [x-in-let 4 25 bind 'x] - [x-after-let 5 11 bind 'x])) +(define x-before-let (trace (loc "first-class.ss" 3 29) (bind (x) x))) +(define x-in-let (trace (loc "first-class.ss" 4 25) (bind (x) 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" (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 after let, should be (5 9 13 15): ~a" (history-b 4 x-after-let)) -(start/resume p) \ No newline at end of file +(set-running! true) \ No newline at end of file diff --git a/collects/mztake/demos/highway/highway-mztake-uncommented.ss b/collects/mztake/demos/highway/highway-mztake-uncommented.ss index 415ae967ad..5e56cfaa39 100644 --- a/collects/mztake/demos/highway/highway-mztake-uncommented.ss +++ b/collects/mztake/demos/highway/highway-mztake-uncommented.ss @@ -1,7 +1,7 @@ -(require (lib "animation.ss" "frtime")) - -(define-mztake-process radar-program ("highway.ss" [values-of-speed 3 4 bind 'speed])) +(require (lib "mztake.ss" "mztake") + (lib "animation.ss" "frtime")) +(define/bind (loc "highway.ss" 3 4) speed) (printf-b "current speed: ~a" (hold 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))) -(start/resume radar-program) \ No newline at end of file +(set-runnning! true) diff --git a/collects/mztake/demos/montecarlo/montecarlo-mztake-uncommented.ss b/collects/mztake/demos/montecarlo/montecarlo-mztake-uncommented.ss index 98daa2cb31..e57b675b31 100644 --- a/collects/mztake/demos/montecarlo/montecarlo-mztake-uncommented.ss +++ b/collects/mztake/demos/montecarlo/montecarlo-mztake-uncommented.ss @@ -1,19 +1,11 @@ -(require (lib "graphics.ss" "graphics")) +(require (lib "graphics.ss" "graphics") + (lib "match.ss")) (open-graphics) (define window (open-viewport "Debugger" 400 400)) - -(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)) +(define/bind (loc "montecarlo.ss" 13 13) x y pi) (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") -(map-e (lambda (x/y) ((draw-solid-ellipse window) (make-posn (first x/y) (second x/y)) - 3 3 "black")) +(map-e (match-lambda [(x y) ((draw-solid-ellipse window) (make-posn x y) + 3 3 "black")]) (changes (list x y))) -(start/resume p) +(set-running! true) diff --git a/collects/mztake/demos/random/random-mztake-uncommented.ss b/collects/mztake/demos/random/random-mztake-uncommented.ss index 65ff57b256..ce27c303bc 100644 --- a/collects/mztake/demos/random/random-mztake-uncommented.ss +++ b/collects/mztake/demos/random/random-mztake-uncommented.ss @@ -1,5 +1,6 @@ (require (lib "graphics.ss" "graphics") - (lifted mzscheme + (lib "mztake.ss" "mztake") + (lifted mzscheme make-hash-table hash-table-put! hash-table-get)) @@ -10,7 +11,7 @@ ((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) @@ -40,4 +41,4 @@ (printf-b "count: ~a" (count-b x-trace)) -(start/resume p) \ No newline at end of file +(set-running! true) \ No newline at end of file diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss index 6ca189dc1c..2cb153c875 100644 --- a/collects/mztake/mztake.ss +++ b/collects/mztake/mztake.ss @@ -1,467 +1,467 @@ -(module mztake mzscheme - - (define mztake-version "rev. 8/6/2004") - - (require (lib "match.ss") - (lib "contract.ss") - (lib "marks.ss" "mztake" "private") - (prefix frp: (lib "frp.ss" "frtime")) - (rename (lib "frtime.ss" "frtime") frp:value-nowable? value-nowable?) - (rename (lib "frtime.ss" "frtime") frp:behaviorof behaviorof) - (lib "useful-code.ss" "mztake" "private") - (lib "more-useful-code.ss" "mztake" "private") ; mostly for hash- bindings - "mztake-structs.ss" - (lib "load-annotator.ss" "mztake" "private") - "annotator.ss" - ) - - (provide/contract [kill (() (debug-process?) . opt-> . void?)] - [kill-all (-> void?)] - [pause (() (debug-process?) . opt-> . void?)] - [resume (debug-process? . -> . void?)] - [set-running-e! (frp:event? . -> . void?)] - [set-running! (frp:value-nowable? . -> . void?)] - [rename debug-process-exceptions - process:exceptions - (debug-process? . -> . frp:event?)] - [rename debug-process-exited? - process:exited? - (debug-process? . -> . frp:behavior?)]) - - #| DISABLED - BROKEN - [process:running? (debug-process? . -> . frp:behavior?)] - [rename time-per-event/milliseconds - process:time-per-event/milliseconds - (debug-process? frp:behavior? . -> . frp:behavior?)] - |# - - - ; ; ; ; - ; ;;;;;; ; ; ; ; ; - ; ;; ; ; ; ; ; ; - ; ; ; ; ; ; ; - ; ; ; ;;;; ; ;;;; ;;;; ; ; ; ;;;; ; ;;; ;;;; - ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ;;;;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ; - ; ;;;;;; ; ;;;; ;;;;;; ;;;; ; ; ; ;;;; ; ; ;;;; - - ;Keeps track of all debugging processes - (define all-debug-processes null) - - ; turns debug output on and off - (define debugging? #f) - - ;########################################################################################################### - - - - - ; ; ; ; - ; ;;;;;; ; ;;;;;; ; ; - ; ; ;; ; ; ; ; ; - ; ; ; ; ; ; ; ; - ; ; ; ; ;;;; ;;;;;; ; ;;; ; ; ;;;; ;;; ; ; ;;; ; ;;;; ;;;;;; - ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; - ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;;;;;; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ;; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;; - ; ;;;;;; ;;;;;; ;;;; ; ; ;;;;;; ;;;; ; ;;; ; ; ;;;; ; ; ;;;; ; - ; ; - ; ; ; - ; ;;;; - - - (define (kill process) - (unless (debug-process-exited? process) - (process:->dead process))) - - (define (kill-all) - (unless (empty? all-debug-processes) - (for-each (lambda (p) (kill p)) all-debug-processes) - (display "All debug processes have been killed."))) - - - ; wrapper for errors related to the script only - (define (script-error err) - (raise-syntax-error 'mztake:script-error (format "~a" err)) - (kill-all)) - - - (define (client-error err) - (display (format "mztake:client-error: ~a~n---~n" err)) - (kill-all)) - - - (define (print-debug str) - (when debugging? - (display (format "mztake:debug: ~a~n---~n" str)))) - - - (define (print-info str) - (display (format "mztake: ~a~n---~n" str))) - - - ;; returns a memoized function that takes (line column) -> position - ;; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?))) - (define (line-col->pos filename) - ; produces a nested list of (line column offset) for all addressable syntax - (define (unwrap-syntax stx) - (let ([elt (list (syntax-line stx) - (syntax-column stx) - (sub1 (syntax-position stx)))]) - (syntax-case stx () - [(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))] - [x elt]))) - - (let ([pos-list - (flatten (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 (unwrap-syntax stx) - (loop (read-syntax filename port))))) - (close-input-port port)))))]) - (lambda (line col) - (let loop ([lst pos-list] - [last-coord (first pos-list)]) - (cond - ; none is found - [(empty? lst) - (raise (format "No syntax found for trace at line/column ~a:~a in client `~a'" line col filename))] - - ; if first is correct line and correct column - [(and (= line (caar lst)) - (= col (cadar lst))) - (third (first lst))] - - [else (loop (rest lst) - (first lst))]))))) - - - ;########################################################################################################### - - - - ; ;;;;;; ;;;;;;; - ; ; ; ; - ; ; ; ; - ; ; ; ; ;;; ;;;; ;;; ;;; ;;;; ;;;; ; ; ; ; ;;;; ;;; ;;;; - ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;;;;; ; ; ; ; ;;;;;;; ;;;; ;;;; ; ; ; ; ; ; ;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; - ; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;; - - - (define (find-client process modpath) - (cond - [(memf (lambda (c) (equal? (debug-client-modpath c) (path->string modpath))) - (debug-process-clients process)) => first] - [else false])) - - (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 (receive-result process client top-mark rest-marks) - (let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))] - [traces (hash-get (debug-client-tracepoints client) byte-offset (lambda () empty))] - [marks (cons top-mark (continuation-mark-set->list rest-marks debug-key))] - [w (map (compose syntax-local-infer-name mark-source) marks)] - [where-event ((frp:signal-thunk (debug-process-where process)) #t)]) - - (set-debug-process-marks! process marks) - - (if (empty? traces) - - (frp:send-synchronous-event where-event w) - - ; Run all traces at this trace point - (let* ([to-send (map (lambda (t) - (list (trace-struct-evnt-rcvr t) - ((trace-struct-thunk t)))) - traces)]) - (frp:send-synchronous-events (cons (list where-event w) to-send)))) - - ; Now that we processed the trace, do we want to pause or continue - (when (debug-process-pause-requested? process) - (set-debug-process-pause-requested?! process false) - (let loop () - (unless (debug-process-resume-requested? process) - (semaphore-wait (debug-process-run-semaphore process)) - (loop))) - (set-debug-process-resume-requested?! process false)) - - (set-debug-process-marks! process false))) - - - - - (define ((break-after process client) top-mark marks . vals) - (receive-result process client top-mark marks) ; TODO: have access to return value - (apply values vals)) ; TODO: allow modification of the return value - - (define ((break-before process client) top-mark marks) - (receive-result process client top-mark marks) ; TODO: allow substitute value - false) - - (define (launch-sandbox process) - - (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))) - `(file ,(debug-client-modpath (debug-process-main-client process))) - ;; annotate-module? - (lambda (filename module-name) - (memf (lambda (c) (equal? (debug-client-modpath c) (path->string filename)));; TODO: harmonize path & string - (debug-process-clients process))) - ;; annotator - (lambda (stx) - (let ([client (and (syntax-source stx) - (find-client process (syntax-source stx)))]) - (if (not client) - stx - (let-values ([(annotated-stx pos-list) - (annotate-for-single-stepping - stx - (break? process client) - (break-before process client) - (break-after process client) - (lambda (kind bound binding) (void)))]) - annotated-stx)))))) - - (define (process:new->running process) - (set-debug-process-run-semaphore! process (make-semaphore)) - - (thread (lambda () - (launch-sandbox process) - (process:running->finished process)))) - - (define (process:running->finished process) - (process:->dead process)) - - (define (process:->dead 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 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 (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 (main-client-name process) - (let-values ([(_ name __) - (split-path (debug-client-modpath (debug-process-main-client process)))]) - name)) - - (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))) - (not (debug-process-resume-requested? process))) - (process:paused->running process)])) - - (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? - (frp:new-cell false) ; exited? - (frp:event-receiver) ; exceptions - false ; main-client - empty ; clients - (frp:new-cell empty) ; where - false)]) ; marks - (set! all-debug-processes (cons process all-debug-processes)) - process)) - - (define where - (frp:new-cell empty)) - - (define current-process - (let* ([proc (create-debug-process)] - [p (make-parameter proc)]) - (frp:set-cell! where (debug-process-where proc)) - (case-lambda - [() (p)] - [(new-p) (frp:set-cell! where (debug-process-where new-p)) (p new-p)]))) - - - ;########################################################################################################### - - - - - ; ;;;;; ; ; ;;;;;;; - ; ; ; ; ; ; - ; ; ; ; - ; ; ;;; ; ;;; ; ; ;;;; ;;;;; ; ; ; ; ;;;; ;;; ;;;; - ; ; ; ; ;; ; ;; ; ; ; ; ; ;; ; ; ; ; ; - ; ;;; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; - ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; - ; ;;;;; ;;; ; ; ;;;;;; ;;; ; ;;;; ; ; ; ;;; ;;;; - ; ; - ; ; - ; ; - - - - ; 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)]) - (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 modpath)) - (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 (set-main! mod-path) - (let ([client (find-client (current-process) mod-path)]) - (if client - (set-debug-process-main-client! (current-process) client) - (create-debug-client (current-process) mod-path)))) - - (define (hold-b b) - (frp:hold (frp:filter-e (lambda (ev) (not (frp:undefined? ev))) (frp:changes b)))) - - (define (expand-module-filename 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 (trace* loc thunk) - (let* ([modpath (expand-module-filename (loc-modpath loc))] - [clients (filter (lambda (c) - (equal? modpath (debug-client-modpath c))) - (debug-process-clients (current-process)))] - [client (if (empty? clients) - (create-debug-client (current-process) modpath) - (first clients))] - [trace-hash (debug-client-tracepoints client)] - [trace (make-trace-struct (frp:event-receiver) thunk)] - [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 - (hash-put! trace-hash pos - (append (hash-get trace-hash pos (lambda () '())) - (list trace))) - (trace-struct-evnt-rcvr trace))) - - (define-syntax trace - (syntax-rules () - [(_ loc) - (trace* loc (lambda () true))] - [(_ loc body ...) - (trace* loc (lambda () body ...))])) - - (define-syntax bind - (syntax-rules () - [(_ (name ...) body0 body ...) - (let ([name (mark-binding-value - (first (lookup-all-bindings - (lambda (id) (eq? (syntax-e id) 'name)) - (debug-process-marks (current-process)))))] ...) - body0 body ...)])) - - (define-syntax define/bind - (syntax-rules () - [(_ loc name ...) - (begin - (define here loc) - (define name (frp:hold (trace here (bind (name) name)))) - ...)])) - - (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))))))))) - - (provide loc$ loc loc-modpath loc-line loc-col - trace trace* bind define/bind create-debug-process - create-debug-client where set-main! - mztake-version) - - ;########################################################################################################### - - ) +(module mztake mzscheme + + (define mztake-version "rev. 8/6/2004") + + (require (lib "match.ss") + (lib "contract.ss") + (lib "marks.ss" "mztake" "private") + (prefix frp: (lib "frp.ss" "frtime")) + (rename (lib "frtime.ss" "frtime") frp:value-nowable? value-nowable?) + (rename (lib "frtime.ss" "frtime") frp:behaviorof behaviorof) + (lib "useful-code.ss" "mztake" "private") + (lib "more-useful-code.ss" "mztake" "private") ; mostly for hash- bindings + "mztake-structs.ss" + (lib "load-annotator.ss" "mztake" "private") + "annotator.ss" + ) + + (provide/contract [kill (() (debug-process?) . opt-> . void?)] + [kill-all (-> void?)] + [pause (() (debug-process?) . opt-> . void?)] + [resume (debug-process? . -> . void?)] + [set-running-e! (frp:event? . -> . void?)] + [set-running! (frp:value-nowable? . -> . void?)] + [rename debug-process-exceptions + process:exceptions + (() (debug-process?) . opt-> . frp:event?)] + [rename debug-process-exited? + process:exited? + (debug-process? . -> . frp:behavior?)]) + + #| DISABLED - BROKEN + [process:running? (debug-process? . -> . frp:behavior?)] + [rename time-per-event/milliseconds + process:time-per-event/milliseconds + (debug-process? frp:behavior? . -> . frp:behavior?)] + |# + + + ; ; ; ; + ; ;;;;;; ; ; ; ; ; + ; ;; ; ; ; ; ; ; + ; ; ; ; ; ; ; + ; ; ; ;;;; ; ;;;; ;;;; ; ; ; ;;;; ; ;;; ;;;; + ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ;;;;; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ; + ; ;;;;;; ; ;;;; ;;;;;; ;;;; ; ; ; ;;;; ; ; ;;;; + + ;Keeps track of all debugging processes + (define all-debug-processes null) + + ; turns debug output on and off + (define debugging? #f) + + ;########################################################################################################### + + + + + ; ; ; ; + ; ;;;;;; ; ;;;;;; ; ; + ; ; ;; ; ; ; ; ; + ; ; ; ; ; ; ; ; + ; ; ; ; ;;;; ;;;;;; ; ;;; ; ; ;;;; ;;; ; ; ;;; ; ;;;; ;;;;;; + ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; + ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;;;;;; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;; + ; ;;;;;; ;;;;;; ;;;; ; ; ;;;;;; ;;;; ; ;;; ; ; ;;;; ; ; ;;;; ; + ; ; + ; ; ; + ; ;;;; + + + (define (kill process) + (unless (debug-process-exited? process) + (process:->dead process))) + + (define (kill-all) + (unless (empty? all-debug-processes) + (for-each (lambda (p) (kill p)) all-debug-processes) + (display "All debug processes have been killed."))) + + + ; wrapper for errors related to the script only + (define (script-error err) + (raise-syntax-error 'mztake:script-error (format "~a" err)) + (kill-all)) + + + (define (client-error err) + (display (format "mztake:client-error: ~a~n---~n" err)) + (kill-all)) + + + (define (print-debug str) + (when debugging? + (display (format "mztake:debug: ~a~n---~n" str)))) + + + (define (print-info str) + (display (format "mztake: ~a~n---~n" str))) + + + ;; returns a memoized function that takes (line column) -> position + ;; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?))) + (define (line-col->pos filename) + ; produces a nested list of (line column offset) for all addressable syntax + (define (unwrap-syntax stx) + (let ([elt (list (syntax-line stx) + (syntax-column stx) + (sub1 (syntax-position stx)))]) + (syntax-case stx () + [(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))] + [x elt]))) + + (let ([pos-list + (flatten (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 (unwrap-syntax stx) + (loop (read-syntax filename port))))) + (close-input-port port)))))]) + (lambda (line col) + (let loop ([lst pos-list] + [last-coord (first pos-list)]) + (cond + ; none is found + [(empty? lst) + (raise (format "No syntax found for trace at line/column ~a:~a in client `~a'" line col filename))] + + ; if first is correct line and correct column + [(and (= line (caar lst)) + (= col (cadar lst))) + (third (first lst))] + + [else (loop (rest lst) + (first lst))]))))) + + + ;########################################################################################################### + + + + ; ;;;;;; ;;;;;;; + ; ; ; ; + ; ; ; ; + ; ; ; ; ;;; ;;;; ;;; ;;; ;;;; ;;;; ; ; ; ; ;;;; ;;; ;;;; + ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;;;;; ; ; ; ; ;;;;;;; ;;;; ;;;; ; ; ; ; ; ; ;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; + ; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;; + + + (define (find-client process modpath) + (cond + [(memf (lambda (c) (equal? (debug-client-modpath c) (path->string modpath))) + (debug-process-clients process)) => first] + [else false])) + + (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 (receive-result process client top-mark rest-marks) + (let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))] + [traces (hash-get (debug-client-tracepoints client) byte-offset (lambda () empty))] + [marks (cons top-mark (continuation-mark-set->list rest-marks debug-key))] + [w (map (compose syntax-local-infer-name mark-source) marks)] + [where-event ((frp:signal-thunk (debug-process-where process)) #t)]) + + (set-debug-process-marks! process marks) + + (if (empty? traces) + + (frp:send-synchronous-event where-event w) + + ; Run all traces at this trace point + (let* ([to-send (map (lambda (t) + (list (trace-struct-evnt-rcvr t) + ((trace-struct-thunk t)))) + traces)]) + (frp:send-synchronous-events (cons (list where-event w) to-send)))) + + ; Now that we processed the trace, do we want to pause or continue + (when (debug-process-pause-requested? process) + (set-debug-process-pause-requested?! process false) + (let loop () + (unless (debug-process-resume-requested? process) + (semaphore-wait (debug-process-run-semaphore process)) + (loop))) + (set-debug-process-resume-requested?! process false)) + + (set-debug-process-marks! process false))) + + + + + (define ((break-after process client) top-mark marks . vals) + (receive-result process client top-mark marks) ; TODO: have access to return value + (apply values vals)) ; TODO: allow modification of the return value + + (define ((break-before process client) top-mark marks) + (receive-result process client top-mark marks) ; TODO: allow substitute value + false) + + (define (launch-sandbox process) + + (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))) + `(file ,(debug-client-modpath (debug-process-main-client process))) + ;; annotate-module? + (lambda (filename module-name) + (memf (lambda (c) (equal? (debug-client-modpath c) (path->string filename)));; TODO: harmonize path & string + (debug-process-clients process))) + ;; annotator + (lambda (stx) + (let ([client (and (syntax-source stx) + (find-client process (syntax-source stx)))]) + (if (not client) + stx + (let-values ([(annotated-stx pos-list) + (annotate-for-single-stepping + stx + (break? process client) + (break-before process client) + (break-after process client) + (lambda (kind bound binding) (void)))]) + annotated-stx)))))) + + (define (process:new->running process) + (set-debug-process-run-semaphore! process (make-semaphore)) + + (thread (lambda () + (launch-sandbox process) + (process:running->finished process)))) + + (define (process:running->finished process) + (process:->dead process)) + + (define (process:->dead 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 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 (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 (main-client-name process) + (let-values ([(_ name __) + (split-path (debug-client-modpath (debug-process-main-client process)))]) + name)) + + (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))) + (not (debug-process-resume-requested? process))) + (process:paused->running process)])) + + (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? + (frp:new-cell false) ; exited? + (frp:event-receiver) ; exceptions + false ; main-client + empty ; clients + (frp:new-cell empty) ; where + false)]) ; marks + (set! all-debug-processes (cons process all-debug-processes)) + process)) + + (define where + (frp:new-cell empty)) + + (define current-process + (let* ([proc (create-debug-process)] + [p (make-parameter proc)]) + (frp:set-cell! where (debug-process-where proc)) + (case-lambda + [() (p)] + [(new-p) (frp:set-cell! where (debug-process-where new-p)) (p new-p)]))) + + + ;########################################################################################################### + + + + + ; ;;;;; ; ; ;;;;;;; + ; ; ; ; ; ; + ; ; ; ; + ; ; ;;; ; ;;; ; ; ;;;; ;;;;; ; ; ; ; ;;;; ;;; ;;;; + ; ; ; ; ;; ; ;; ; ; ; ; ; ;; ; ; ; ; ; + ; ;;; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; + ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; + ; ;;;;; ;;; ; ; ;;;;;; ;;; ; ;;;; ; ; ; ;;; ;;;; + ; ; + ; ; + ; ; + + + + ; 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)]) + (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 modpath)) + (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 (set-main! mod-path) + (let ([client (find-client (current-process) mod-path)]) + (if client + (set-debug-process-main-client! (current-process) client) + (create-debug-client (current-process) mod-path)))) + + (define (hold-b b) + (frp:hold (frp:filter-e (lambda (ev) (not (frp:undefined? ev))) (frp:changes b)))) + + (define (expand-module-filename 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 (trace* loc thunk) + (let* ([modpath (expand-module-filename (loc-modpath loc))] + [clients (filter (lambda (c) + (equal? modpath (debug-client-modpath c))) + (debug-process-clients (current-process)))] + [client (if (empty? clients) + (create-debug-client (current-process) modpath) + (first clients))] + [trace-hash (debug-client-tracepoints client)] + [trace (make-trace-struct (frp:event-receiver) thunk)] + [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 + (hash-put! trace-hash pos + (append (hash-get trace-hash pos (lambda () '())) + (list trace))) + (trace-struct-evnt-rcvr trace))) + + (define-syntax trace + (syntax-rules () + [(_ loc) + (trace* loc (lambda () true))] + [(_ loc body ...) + (trace* loc (lambda () body ...))])) + + (define-syntax bind + (syntax-rules () + [(_ (name ...) body0 body ...) + (let ([name (mark-binding-value + (first (lookup-all-bindings + (lambda (id) (eq? (syntax-e id) 'name)) + (debug-process-marks (current-process)))))] ...) + body0 body ...)])) + + (define-syntax define/bind + (syntax-rules () + [(_ loc name ...) + (begin + (define here loc) + (define name (frp:hold (trace here (bind (name) name)))) + ...)])) + + (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))))))))) + + (provide loc$ loc loc-modpath loc-line loc-col + trace trace* bind define/bind create-debug-process + create-debug-client where set-main! + mztake-version) + + ;########################################################################################################### + + )