mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
101 lines
3 KiB
Scheme
101 lines
3 KiB
Scheme
|
|
;; Table mapping traced procedures to their original untraced values.
|
|
(define all-traces
|
|
(make-parameter (make-hash-table eq?)))
|
|
|
|
;; The current number of traced procedure frames on the stack.
|
|
(define active-trace-depth
|
|
(make-parameter 0))
|
|
|
|
(define (show-trace cell args)
|
|
(let ((out (current-error-port)))
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i (active-trace-depth)))
|
|
(display "| " out))
|
|
(display "> " out)
|
|
(write/ss (cons (car cell) args) out)
|
|
(newline out)))
|
|
|
|
(define (show-trace-result cell args res)
|
|
(let ((out (current-error-port)))
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i (active-trace-depth)))
|
|
(display "| " out))
|
|
(write/ss res out)
|
|
(newline out)))
|
|
|
|
(define (make-tracer cell)
|
|
(let ((proc (cdr cell)))
|
|
(if (macro? proc)
|
|
(make-macro
|
|
(lambda (expr use-env mac-env)
|
|
(show-trace cell (strip-syntactic-closures (cdr expr)))
|
|
(active-trace-depth (+ (active-trace-depth) 1))
|
|
(let ((res ((macro-procedure proc) expr use-env mac-env)))
|
|
(active-trace-depth (- (active-trace-depth) 1))
|
|
(show-trace-result cell
|
|
(strip-syntactic-closures (cdr expr))
|
|
(strip-syntactic-closures res))
|
|
res))
|
|
(macro-env proc))
|
|
(lambda args
|
|
(show-trace cell args)
|
|
(active-trace-depth (+ (active-trace-depth) 1))
|
|
(let ((res (apply proc args)))
|
|
(active-trace-depth (- (active-trace-depth) 1))
|
|
(show-trace-result cell args res)
|
|
res)))))
|
|
|
|
;;> Write a trace of all calls to the procedure \var{id} to
|
|
;;> \scheme{(current-error-port)}.
|
|
|
|
(define-syntax trace
|
|
(syntax-rules ()
|
|
((trace id)
|
|
(trace-cell (env-cell (interaction-environment) 'id)))))
|
|
|
|
;;> Remove any active traces on the procedure \var{id}.
|
|
|
|
(define-syntax untrace
|
|
(syntax-rules ()
|
|
((untrace id)
|
|
(untrace-cell (env-cell (interaction-environment) 'id)))))
|
|
|
|
(define (warn . args)
|
|
(let ((out (current-error-port)))
|
|
(display "WARNING: " out)
|
|
(for-each (lambda (x) (display x out)) args)
|
|
(newline out)))
|
|
|
|
;;> Trace a specific environment cell.
|
|
|
|
(define (trace-cell cell)
|
|
(let ((tab (all-traces)))
|
|
(cond
|
|
((not (pair? cell))
|
|
(warn "No such binding."))
|
|
((hash-table-exists? tab cell)
|
|
(warn "Procedure already being traced: " (car cell)))
|
|
(else
|
|
(hash-table-set! tab cell (cdr cell))
|
|
(set-cdr! cell (make-tracer cell))))))
|
|
|
|
;;> Untrace an environment cell.
|
|
|
|
(define (untrace-cell cell)
|
|
(let ((tab (all-traces)))
|
|
(cond
|
|
((not (pair? cell))
|
|
(warn "No such binding."))
|
|
((not (hash-table-exists? tab cell))
|
|
(warn "Procedure not being traced: " (car cell)))
|
|
(else
|
|
(let ((proc (hash-table-ref tab cell)))
|
|
(hash-table-delete! tab cell)
|
|
(set-cdr! cell proc))))))
|
|
|
|
;;> Remove all active procedure traces.
|
|
|
|
(define (untrace-all)
|
|
(hash-table-walk (all-traces) (lambda (cell proc) (set-cdr! cell proc)))
|
|
(all-traces (make-hash-table eq?)))
|