cleaning up sine.ss
svn: r183
This commit is contained in:
Guillaume Marceau
parent
58114baeee
commit
0b04359f47
|
|
@ -1,25 +1,18 @@
|
|||
(require (lib "animation.ss" "frtime")
|
||||
(lib "list.ss" "frtime")
|
||||
(lib "useful-code.ss" "mztake" "private"))
|
||||
(require (lib "mztake.ss" "mztake"))
|
||||
|
||||
(define x/sinx (hold (trace "sine.ss" 5 8 (bind (x sin-x) (list x sin-x)))))
|
||||
(define/bind (loc "sine.ss" 5 8) x sin-x)
|
||||
|
||||
(define x (first x/sinx))
|
||||
(define sin-x (second x/sinx))
|
||||
|
||||
(printf-b "x: ~a" x)
|
||||
(printf-b "sin(x/20): ~a" sin-x)
|
||||
|
||||
|
||||
(printf-b "largest x: ~a sin(x/20): ~a"
|
||||
(largest-val-b (changes (first x/sinx)))
|
||||
(largest-val-b (changes (second x/sinx))))
|
||||
|
||||
(printf-b "smallest x:~a sin(x/20):~a"
|
||||
(smallest-val-b (changes (first x/sinx)))
|
||||
(smallest-val-b (changes (second x/sinx))))
|
||||
(define (pick-cute-color x y)
|
||||
(if (< 200 y)
|
||||
(if (< 200 x) "blue" "darkblue")
|
||||
(if (< 200 x) "red" "darkred")))
|
||||
|
||||
(define (make-cute-circle x y)
|
||||
(make-circle (make-posn x y)
|
||||
5
|
||||
(pick-cute-color x y)))
|
||||
|
||||
(display-shapes
|
||||
(list* (make-line (make-posn 0 200) (make-posn 400 200) "gray")
|
||||
|
|
@ -27,12 +20,7 @@
|
|||
|
||||
(let ([x (+ 200 x)]
|
||||
[sin-x (+ 200 (* 100 sin-x))])
|
||||
(history-b 50 (changes (make-circle
|
||||
(make-posn x sin-x)
|
||||
5
|
||||
(if (< 200 sin-x)
|
||||
(if (< 200 x) "blue" "darkblue") #| Quadrants 3 and 4 |#
|
||||
(if (< 200 x) "red" "darkred")))))))) #| 1 and 2 |#
|
||||
(history-b 50 (changes (make-cute-circle x sin-x))))))
|
||||
|
||||
(start/resume)
|
||||
(set-running! (even? seconds))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,9 @@
|
|||
(require (prefix frp: (lib "frp.ss" "frtime"))
|
||||
(lib "more-useful-code.ss" "mztake" "private"))
|
||||
|
||||
(provide (all-defined))
|
||||
(provide (all-defined-except loc make-loc)
|
||||
(rename loc loc$)
|
||||
(rename make-loc loc))
|
||||
|
||||
; ;;;;; ; ;
|
||||
; ; ; ; ;
|
||||
|
|
@ -26,14 +28,21 @@
|
|||
|
||||
(define-struct debug-process (custodian ; If you shutdown-all it will kill the debugger process
|
||||
run-semaphore ; When you post to this the debuggee will continue executing
|
||||
running? ; Is the program (supposed-to-be) currently running
|
||||
running-e ; Is the program (supposed-to-be) currently running
|
||||
run-manager ; saves behavior that actually pauses/resumes from GC
|
||||
pause-requested?
|
||||
resume-requested?
|
||||
|
||||
exited? ; FrTime cell receives #t when the target exits
|
||||
exceptions ; (an event stream) Exceptions thrown during the evaluation of the target
|
||||
runtime ; Behavior with current runtime in milliseconds
|
||||
main-client ; the main client module that will be run
|
||||
clients ; list of all the clients attached to this process
|
||||
|
||||
where ; a behavior signaling each position where we pause
|
||||
marks)) ; while paused, the marks at the point of the pause (else false)
|
||||
|
||||
(define-struct loc (modpath line col))
|
||||
|
||||
;###########################################################################################################
|
||||
|
||||
|
||||
|
|
@ -52,17 +61,6 @@
|
|||
; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ;
|
||||
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;;
|
||||
|
||||
(define (create-empty-debug-process)
|
||||
(make-debug-process (make-custodian)
|
||||
null ; run-semaphore - null so we know it has never started
|
||||
#f ; running?
|
||||
(frp:new-cell) ; exited?
|
||||
(frp:event-receiver) ; exceptions
|
||||
null ; runtime
|
||||
null ; main-client
|
||||
empty ; clients
|
||||
false)) ; marks
|
||||
|
||||
(define (create-empty-debug-client)
|
||||
(make-debug-client null ; modpath
|
||||
(make-hash) ; tracepoints
|
||||
|
|
|
|||
|
|
@ -6,6 +6,8 @@
|
|||
(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"
|
||||
|
|
@ -13,19 +15,15 @@
|
|||
"annotator.ss"
|
||||
)
|
||||
|
||||
(provide/contract [start/resume (() (debug-process?) . opt-> . void?)]
|
||||
[kill (() (debug-process?) . opt-> . void?)]
|
||||
(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 runtime/seconds
|
||||
process:runtime/seconds
|
||||
(debug-process? . -> . frp:behavior?)]
|
||||
[rename runtime/milliseconds
|
||||
process:runtime/milliseconds
|
||||
(debug-process? . -> . frp:behavior?)]
|
||||
[rename debug-process-exited?
|
||||
process:exited?
|
||||
(debug-process? . -> . frp:behavior?)])
|
||||
|
|
@ -81,6 +79,10 @@
|
|||
; ;;;;
|
||||
|
||||
|
||||
(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)
|
||||
|
|
@ -163,8 +165,6 @@
|
|||
; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;;
|
||||
|
||||
|
||||
(define current-process (make-parameter (create-empty-debug-process)))
|
||||
|
||||
(define (find-client process modpath)
|
||||
(cond
|
||||
[(memf (lambda (c) (equal? (debug-client-modpath c) (path->string modpath)))
|
||||
|
|
@ -174,28 +174,38 @@
|
|||
(define (break? process client)
|
||||
(let ([tracepoints (and client (debug-client-tracepoints client))])
|
||||
(lambda (pos)
|
||||
(or (not (running-now? process))
|
||||
(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))])
|
||||
[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)])
|
||||
(unless (empty? to-send)
|
||||
(frp:send-synchronous-events to-send)))
|
||||
(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 ojr continue
|
||||
(unless (running-now? process)
|
||||
(semaphore-wait (debug-process-run-semaphore process)))
|
||||
; 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)))
|
||||
|
||||
|
|
@ -210,7 +220,8 @@
|
|||
(receive-result process client top-mark marks) ; TODO: allow substitute value
|
||||
false)
|
||||
|
||||
(define (run* process)
|
||||
(define (launch-sandbox process)
|
||||
|
||||
(require/sandbox+annotations
|
||||
(debug-process-custodian process)
|
||||
;; error-display-handler :
|
||||
|
|
@ -237,112 +248,90 @@
|
|||
(break-after process client)
|
||||
(lambda (kind bound binding) (void)))])
|
||||
annotated-stx))))))
|
||||
|
||||
(define (start-debug-process process)
|
||||
; initialize the semaphore
|
||||
|
||||
(define (process:new->running process)
|
||||
(set-debug-process-run-semaphore! process (make-semaphore))
|
||||
; set initial state of exit predicate
|
||||
(frp:set-cell! (debug-process-exited? process) #f)
|
||||
|
||||
(thread (lambda ()
|
||||
(thread-wait (thread (lambda () (run* process))))
|
||||
; program terminates
|
||||
(stop process)
|
||||
(print-info (format "process exited: ~a" (main-client-name process))))))
|
||||
|
||||
|
||||
; predicate - is the debugee supposed to be running now?
|
||||
(define (running-now? process)
|
||||
(and (not (null? (debug-process-run-semaphore process)))
|
||||
(frp:value-now (debug-process-running? process))))
|
||||
|
||||
(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)))
|
||||
|
||||
|
||||
; Switches the running state on or off
|
||||
; (debug-process? boolean? . -> . void?)
|
||||
(define set-running!
|
||||
(opt-lambda (run? [process (current-process)])
|
||||
(set-debug-process-running?! process run?)
|
||||
|
||||
; start the debugger if needed
|
||||
(when (null? (debug-process-run-semaphore process))
|
||||
(print-info (format "starting debugger for ~a" (main-client-name process)))
|
||||
(start-debug-process process))
|
||||
|
||||
(when run?
|
||||
(semaphore-post (debug-process-run-semaphore process)))
|
||||
(void)))
|
||||
|
||||
|
||||
(define pause
|
||||
(opt-lambda ([process (current-process)])
|
||||
(print-info (format "pausing debugger for ~a" (main-client-name process)))
|
||||
(set-running! #f process)))
|
||||
|
||||
|
||||
(define start/resume
|
||||
(opt-lambda ([process (current-process)])
|
||||
(let ([val (frp:value-now (debug-process-exited? process))])
|
||||
(when (not (null? (debug-process-run-semaphore process)))
|
||||
(print-info (format "resuming debugger for ~a" (main-client-name process))))
|
||||
|
||||
; only start the debugger once for each process
|
||||
(if ((not (equal? val frp:undefined)) . and . val)
|
||||
(print-info (format "Cannot restart a process once it has exited (~a). Try restarting the script."
|
||||
(main-client-name process)))
|
||||
(set-running! #t process)))))
|
||||
|
||||
; Kills and prints out a message stating it
|
||||
(define kill
|
||||
(opt-lambda ([process (current-process)])
|
||||
(print-info (format "killing debugger for ~a" (main-client-name process)))
|
||||
(stop process)))
|
||||
|
||||
; Kills the debugger process immediately and permanently
|
||||
(define stop
|
||||
(opt-lambda ([process (current-process)])
|
||||
; remove the process from the process list
|
||||
(set! all-debug-processes (remq process all-debug-processes))
|
||||
|
||||
(set-running! #f process)
|
||||
; shutdown the custodian
|
||||
(custodian-shutdown-all (debug-process-custodian process))
|
||||
; set the exit predicate to 'exited'
|
||||
(frp:set-cell! (debug-process-exited? process) #t)))
|
||||
|
||||
|
||||
; creates and initializes a debug 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)
|
||||
(let ([p (create-empty-debug-process)])
|
||||
(set-debug-process-runtime! p (runtime p))
|
||||
(set! all-debug-processes (cons p all-debug-processes))
|
||||
(current-process p)
|
||||
p))
|
||||
|
||||
|
||||
; returns a behavior that keeps track of runtime
|
||||
(define (runtime process)
|
||||
(frp:hold
|
||||
((frp:changes
|
||||
(frp:accum-b
|
||||
((frp:changes frp:milliseconds)
|
||||
. frp:-=> .
|
||||
(match-lambda [(prev sum)
|
||||
(if (frp:value-now (debug-process-running? process))
|
||||
(list (frp:value-now frp:milliseconds)
|
||||
(+ (- (frp:value-now frp:milliseconds) prev) sum))
|
||||
(list (frp:value-now frp:milliseconds) sum))]))
|
||||
(list (frp:value-now frp:milliseconds) 0)))
|
||||
. frp:==> .
|
||||
cadr) ; take the second element
|
||||
0))
|
||||
|
||||
(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)])))
|
||||
|
||||
|
||||
;###########################################################################################################
|
||||
|
||||
|
||||
|
|
@ -365,80 +354,65 @@
|
|||
; ;
|
||||
|
||||
|
||||
#;
|
||||
(define (running? process)
|
||||
(script-error "client-running? is broken")
|
||||
(and (running-now? process)
|
||||
(not (debug-process-exited? process))))
|
||||
|
||||
#;
|
||||
(define (time-per-event/milliseconds process behavior)
|
||||
(frp:lift (truncate (/ (frp:value-now (debug-process-runtime process))
|
||||
(add1 (frp:value-now (count-e (frp:changes behavior))))))))
|
||||
|
||||
(define (runtime/milliseconds process)
|
||||
(debug-process-runtime process))
|
||||
|
||||
(define (runtime/seconds process)
|
||||
(frp:hold ((frp:changes (debug-process-runtime process))
|
||||
. frp:==> .
|
||||
(lambda (t) (truncate (/ t 1000))))
|
||||
0))
|
||||
|
||||
|
||||
; Creates a debugger client
|
||||
; (debug-process? require-path. -> . debug-file?)
|
||||
(define (create-debug-client process filename)
|
||||
(define (create-debug-client process modpath)
|
||||
; throwaway namespace so the module-name-resolver doesn't load an unannotated module
|
||||
(parameterize ([current-namespace (make-namespace)])
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(client-error (format "Expected a module in client file: ~a" filename)))])
|
||||
|
||||
(let* ([build-module-filename ; taken from module-overview.ss
|
||||
(lambda (str)
|
||||
(let ([try (lambda (ext)
|
||||
(let ([tst (string-append str ext)])
|
||||
(and (file-exists? tst) tst)))])
|
||||
(or (try ".ss") (try ".scm") (try "") str)))]
|
||||
|
||||
[modpath (symbol->string ((current-module-name-resolver) filename #f #f))]
|
||||
[modpath (build-module-filename
|
||||
(if (regexp-match #rx"^," modpath)
|
||||
(substring modpath 1 (string-length modpath))
|
||||
modpath))]
|
||||
|
||||
[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))
|
||||
(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))
|
||||
|
||||
(print-debug (format "'~a' -> '~a'" filename modpath))
|
||||
(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-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))
|
||||
|
||||
; set the main module if it has not been set
|
||||
; this implies that the first client created is always the main module
|
||||
(when (null? (debug-process-main-client process))
|
||||
(set-debug-process-main-client! process client))
|
||||
|
||||
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 (trace* modpath line col thunk)
|
||||
(let* ([clients (member modpath (debug-process-clients (current-process)))]
|
||||
[client (if clients
|
||||
(first clients)
|
||||
(create-debug-client (current-process) modpath))]
|
||||
(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) line col)])
|
||||
[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 () '()))
|
||||
|
|
@ -447,10 +421,10 @@
|
|||
|
||||
(define-syntax trace
|
||||
(syntax-rules ()
|
||||
[(_ client line col)
|
||||
(trace* client line col (lambda () true))]
|
||||
[(_ client line col body ...)
|
||||
(trace* client line col (lambda () body ...))]))
|
||||
[(_ loc)
|
||||
(trace* loc (lambda () true))]
|
||||
[(_ loc body ...)
|
||||
(trace* loc (lambda () body ...))]))
|
||||
|
||||
(define-syntax bind
|
||||
(syntax-rules ()
|
||||
|
|
@ -461,40 +435,31 @@
|
|||
(debug-process-marks (current-process)))))] ...)
|
||||
body0 body ...)]))
|
||||
|
||||
; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver)
|
||||
; (debug-client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?)
|
||||
#;
|
||||
(define (trace/bind client line col binding-symbol)
|
||||
(when (empty? binding-symbol)
|
||||
(script-error (format "No symbols defined in BIND for client: `~a'"
|
||||
(debug-client-modpath client))))
|
||||
|
||||
(with-handlers ([(lambda (exn) #t)
|
||||
(lambda (exn) (raise-syntax-error 'mztake:script-error:trace/bind exn))])
|
||||
(let ([trace-hash (debug-client-tracepoints client)]
|
||||
[trace (create-bind-trace binding-symbol)]
|
||||
[pos ((debug-client-line-col->pos client) line col)])
|
||||
; add the trace to the list of traces for that byte-offset
|
||||
(hash-put! trace-hash pos
|
||||
(append (hash-get trace-hash pos (lambda () '()))
|
||||
(list trace)))
|
||||
(trace-struct-evnt-rcvr trace))))
|
||||
|
||||
|
||||
;(debug-file? number? number? . -> . frp:event?)
|
||||
#;
|
||||
(define (trace/entry client line col)
|
||||
(let ([trace-hash (debug-client-tracepoints client)]
|
||||
[trace (create-entry-trace)]
|
||||
[pos ((debug-client-line-col->pos client) line col)])
|
||||
(hash-put! trace-hash pos
|
||||
(append (hash-get trace-hash pos (lambda () '()))
|
||||
(list trace)))
|
||||
(trace-struct-evnt-rcvr trace)))
|
||||
|
||||
|
||||
(provide trace trace* bind create-debug-process
|
||||
create-debug-client
|
||||
(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)
|
||||
|
||||
;###########################################################################################################
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user