144 lines
4.9 KiB
Scheme
144 lines
4.9 KiB
Scheme
(module mztake mzscheme
|
|
(require (lib "contract.ss")
|
|
(prefix frp: (lib "lang-ext.ss" "frtime"))
|
|
(rename (lib "frtime.ss" "frtime") frp:list list)
|
|
(rename (lib "frtime.ss" "frtime") frp:value-nowable? value-nowable?)
|
|
(rename (lib "frtime.ss" "frtime") frp:behaviorof behaviorof)
|
|
"mztake-structs.ss"
|
|
(lib "etc.ss")
|
|
(lib "list.ss")
|
|
"marks.ss"
|
|
"engine.ss")
|
|
|
|
;; Turn struct printing on for MzTake users.
|
|
(print-struct true)
|
|
|
|
(provide loc$
|
|
trace
|
|
bind
|
|
define/bind
|
|
define/bind-e
|
|
[rename mztake-top #%top])
|
|
|
|
(provide/contract [loc-reqspec (loc? . -> . require-spec?)]
|
|
[loc-line (loc? . -> . number?)]
|
|
[loc-col (loc? . -> . number?)]
|
|
[rename loc/opt-col loc
|
|
((any/c number?) (number?) . opt-> . loc?)]
|
|
[exceptions (() (debug-process?) . opt-> . frp:event?)]
|
|
[exited? (() (debug-process?) . opt-> . frp:behavior?)]
|
|
[kill (() (debug-process?) . opt-> . void?)]
|
|
[kill-all (-> void?)]
|
|
[set-running-e! ((frp:event?) (debug-process?) . opt-> . any)]
|
|
[set-running! ((frp:value-nowable?) (debug-process?) . opt-> . any)]
|
|
[where (() (debug-process?) . opt-> . frp:behavior?)]
|
|
[current-policy (case-> (-> any)
|
|
(any/c . -> . void?))]
|
|
[current-process (case-> (-> debug-process?)
|
|
(debug-process? . -> . void?))]
|
|
[create-debug-process (-> debug-process?)]
|
|
[set-main! ((require-spec?) (debug-process?) . opt-> . void?)]
|
|
[trace* (debug-process? loc? (-> any) . -> . frp:event?)]
|
|
[bind* (debug-process? symbol? . -> . any)])
|
|
|
|
(define loc/opt-col
|
|
(opt-lambda (reqspec line [col #f])
|
|
(loc reqspec line col)))
|
|
|
|
(define exceptions
|
|
(opt-lambda ([p (current-process)])
|
|
(debug-process-exceptions p)))
|
|
|
|
(define exited?
|
|
(opt-lambda ([p (current-process)])
|
|
(debug-process-exited? p)))
|
|
|
|
(define kill
|
|
(opt-lambda ([p (current-process)])
|
|
(unless (debug-process-exited? p)
|
|
(process:->dead p))))
|
|
|
|
(define (kill-all)
|
|
(unless (empty? all-debug-processes)
|
|
(for-each (lambda (p) (kill p)) all-debug-processes)
|
|
(display "All debug processes have been killed.")))
|
|
|
|
(define set-running-e!
|
|
(opt-lambda (e [process (current-process)])
|
|
(resume process)
|
|
(frp:set-cell! (debug-process-running-e process) e)))
|
|
|
|
(define set-running!
|
|
(opt-lambda (b [process (current-process)])
|
|
(if (frp:value-now b) (resume process) (pause process))
|
|
(frp:set-cell! (debug-process-running-e process) (frp:changes b))))
|
|
|
|
(define where
|
|
(opt-lambda ([p (current-process)])
|
|
(unless (debug-process-where p)
|
|
(set-debug-process-where! p (frp:new-cell empty)))
|
|
(debug-process-where p)))
|
|
|
|
(define current-process (make-parameter (create-debug-process)))
|
|
|
|
(define set-main!
|
|
(opt-lambda (reqspec [p (current-process)])
|
|
(process:set-main! p reqspec)))
|
|
|
|
(define-syntax trace
|
|
(syntax-rules ()
|
|
[(_ loc)
|
|
(trace* (current-process) loc (lambda () true))]
|
|
[(_ loc body ...)
|
|
(trace* (current-process) loc (lambda () body ...))]))
|
|
|
|
(define-syntax (mztake-top stx)
|
|
(syntax-case stx ()
|
|
[(_ . name)
|
|
(begin
|
|
#'(with-handlers
|
|
([exn:fail?
|
|
(lambda (exn)
|
|
(with-handlers
|
|
([exn:fail? (lambda (exn2) (raise exn))])
|
|
(bind* (current-process) 'name)))])
|
|
(#%top . name)))]))
|
|
|
|
(define (bind* p name)
|
|
(unless (debug-process-marks p)
|
|
(error "Bind called but the target process is not paused."))
|
|
|
|
(let ([bs (lookup-all-bindings
|
|
(lambda (id) (eq? (syntax-e id) name))
|
|
(debug-process-marks p))])
|
|
(when (empty? bs)
|
|
(error 'bind "variable `~a' not found in target at the current location" name))
|
|
|
|
(mark-binding-value (first bs))))
|
|
|
|
(define-syntax bind
|
|
(syntax-rules ()
|
|
[(_ (name ...) body0 body ...)
|
|
(let* ([p (current-process)]
|
|
[name (bind* p 'name)]
|
|
...)
|
|
body0 body ...)]))
|
|
|
|
(define-syntax define/bind-e
|
|
(syntax-rules ()
|
|
[(_ loc name ...)
|
|
(begin
|
|
(define here loc)
|
|
(define name (trace here (bind (name) name)))
|
|
...)]))
|
|
|
|
(define-syntax define/bind
|
|
(syntax-rules ()
|
|
[(_ loc name ...)
|
|
(begin
|
|
(define here loc)
|
|
(define name (frp:hold (trace here (bind (name) name))))
|
|
...)]))
|
|
|
|
|
|
) |