;;; Trace.scheme
Copyright Ó 1989, 1991 by Xerox Corporation. All rights reserved.
;;; Last changed by Pavel on March 22, 1989 6:18:58 pm PST
;;; Michael Plass, January 20, 1989 10:13:55 pm PST
;;; (TRACE <name>*) -- Enables tracing on the functions with the given names
;;; in the top-level environment. Returns a list of all currently-traced
;;; functions.
;;; (UNTRACE <name>+) -- Restores the named functions to their original,
;;; untraced state.
;;; (UNTRACE) -- Restores all currently-traced functions to their original,
;;; untraced state.
;;;
;;; It is an error to
;;; 1) Use TRACE or UNTRACE at anything other than top level.
;;; 2) Use TRACE on an undefined function, a non-function,
;;; or an already-TRACE'd function.
;;; 3) Redefine a TRACE'd function without first UNTRACE'ing it.
(define *traced-functions* '())
This is an a-list of names and procedures.
(define trace (make-syntax (lambda names
(if (null? names)
'(map car *traced-functions*)
(let ((name (car names)))
`(begin
(set! *traced-functions*
(cons (cons ',name ,name) *traced-functions*))
(set! ,name
(let ((old-fn ,name))
(lambda args
(display "Entering: ")
(write (cons ',name args))
(newline)
(let ((result (apply old-fn args)))
(display "Exiting ")
(write ',name)
(display " => ")
(write result)
(newline)
result))))
(trace ,@(cdr names))))))))
(define untrace (make-syntax (lambda args
(let ((names (or args (map car *traced-functions*))))
`(begin
,@(map
(lambda (name)
`(set! ,name
(cdr (assq ',name *traced-functions*))))
names)
(set! *traced-functions*
,(if (null? args)
`'()
`(remove-if
(lambda (entry) (memq (car entry) ',names))
*traced-functions*))))))))