mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 21:59:17 +02:00
8b5eb68238
They can be close()d explicitly with close-file-descriptor, and will close() on gc, but only explicitly closing the last port on them will close the fileno. Notably needed for network sockets where we open separate input and output ports on the same socket.
78 lines
2.2 KiB
Scheme
78 lines
2.2 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)))
|
|
(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))))
|
|
|
|
(define-syntax trace
|
|
(syntax-rules ()
|
|
((trace id)
|
|
(trace-cell (env-cell (interaction-environment) '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)))
|
|
|
|
(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))))))
|
|
|
|
(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))))))
|
|
|
|
(define (untrace-all)
|
|
(hash-table-walk (all-traces) (lambda (cell proc) (set-cdr! cell proc)))
|
|
(all-traces (make-hash-table eq?)))
|