guile/module/slib/trace.scm

;;;; "trace.scm" Utility macros for tracing in Scheme.
;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2000 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

(require 'qp)				;for the qp printer.
(define trace:indent 0)
(define debug:call-stack '())		;keeps track of call stack.
(define debug:max-count 5)

;;Formats for call-stack elements:
;; (procedure-count name . args)	;for debug:track procedure
;; (procedure-count name)		;for debug:stack procedure
;;Traced functions also stack.

(define print-call-stack
  (let ((car car) (null? null?) (current-error-port current-error-port)
	(qpn qpn) (for-each for-each))
    (lambda cep
      (set! cep (if (null? cep) (current-error-port) (car cep)))
      (for-each qpn debug:call-stack))))

(define (call-stack-news? name)
  (or (null? debug:call-stack)
      (not (eq? name (cadar debug:call-stack)))
      (< (caar debug:call-stack) debug:max-count)))

(define debug:trace-procedure
  (let ((null? null?) (not not)		;These bindings are so that
	(cdar cdar) (cadar cadar)	;trace will not trace parts
	(car car) (cdr cdr) (caar caar)	;of itself.
	(eq? eq?) (+ +) (zero? zero?) (modulo modulo)
	(apply apply) (display display) (qpn qpn) (list list) (cons cons)

	(CALL (string->symbol "CALL"))
	(RETN (string->symbol "RETN")))
    (lambda (how function . optname)
      (set! trace:indent 0)
      (let ((name (if (null? optname) function (car optname))))
	(case how
	  ((trace)
	   (lambda args
	     (cond ((and (not (null? args))
			 (eq? (car args) 'debug:untrace-object)
			 (null? (cdr args)))
		    function)
		   ((call-stack-news? name)
		    (let ((cs debug:call-stack))
		      (set! debug:call-stack
			    (if (and (not (null? debug:call-stack))
				     (eq? name (cadar debug:call-stack)))
				(cons (cons (+ 1 (caar debug:call-stack))
					    (cdar debug:call-stack))
				      (cdr debug:call-stack))
				(cons (list 1 name) debug:call-stack)))
		      (do ((i trace:indent (+ -1 i))) ((zero? i)) (display #\ ))
		      (apply qpn CALL name args)
		      (set! trace:indent (modulo (+ 1 trace:indent) 16))
		      (let ((ans (apply function args)))
			(set! trace:indent (modulo (+ -1 trace:indent) 16))
			(do ((i trace:indent (+ -1 i))) ((zero? i)) (display #\ ))
			(qpn RETN name ans)
			(set! debug:call-stack cs)
			ans)))
		   (else (apply function args)))))
	  ((track)
	   (lambda args
	     (cond ((and (not (null? args))
			 (eq? (car args) 'debug:untrace-object)
			 (null? (cdr args)))
		    function)
		   ((call-stack-news? name)
		    (let ((cs debug:call-stack))
		      (set! debug:call-stack
			    (if (and (not (null? debug:call-stack))
				     (eq? name (cadar debug:call-stack)))
				(cons (cons (+ 1 (caar debug:call-stack))
					    (cdar debug:call-stack))
				      (cdr debug:call-stack))
				(cons (cons 1 (cons name args))
				      debug:call-stack)))
		      (let ((ans (apply function args)))
			(set! debug:call-stack cs)
			ans)))
		   (else (apply function args)))))
	  ((stack)
	   (lambda args
	     (cond ((and (not (null? args))
			 (eq? (car args) 'debug:untrace-object)
			 (null? (cdr args)))
		    function)
		   ((call-stack-news? name)
		    (let ((cs debug:call-stack))
		      (set! debug:call-stack
			    (if (and (not (null? debug:call-stack))
				     (eq? name (cadar debug:call-stack)))
				(cons (cons (+ 1 (caar debug:call-stack))
					    (cdar debug:call-stack))
				      (cdr debug:call-stack))
				(cons (list 1 name) debug:call-stack)))
		      (let ((ans (apply function args)))
			(set! debug:call-stack cs)
			ans)))
		   (else (apply function args)))))
	  (else
	   (slib:error 'debug:trace-procedure 'unknown 'how '= how)))))))

;;; The reason I use a symbol for debug:untrace-object is so that
;;; functions can still be untraced if this file is read in twice.

(define (untracef function)
  (set! trace:indent 0)
  (function 'debug:untrace-object))

;;;;The trace: functions wrap around the debug: functions to provide
;;; niceties like keeping track of traced functions and dealing with
;;; redefinition.

(require 'alist)
(define trace:adder (alist-associator eq?))
(define trace:deler (alist-remover eq?))

(define *traced-procedures* '())
(define *tracked-procedures* '())
(define *stacked-procedures* '())
(define (trace:trace-procedure how fun sym)
  (define cep (current-error-port))
  (cond ((not (procedure? fun))
	 (display "WARNING: not a procedure " cep)
	 (display sym cep)
	 (newline cep)
	 (set! *traced-procedures* (trace:deler *traced-procedures* sym))
	 (set! *tracked-procedures* (trace:deler *tracked-procedures* sym))
	 (set! *stacked-procedures* (trace:deler *stacked-procedures* sym))
	 fun)
	(else
	 (let ((p (assq sym (case how
			      ((trace) *traced-procedures*)
			      ((track) *tracked-procedures*)
			      ((stack) *stacked-procedures*)))))
	   (cond ((and p (eq? (cdr p) fun))
		  fun)
		 (else
		  (let ((tfun (debug:trace-procedure how fun sym)))
		    (case how
		      ((trace)
		       (set! *traced-procedures*
			     (trace:adder *traced-procedures* sym tfun)))
		      ((track)
		       (set! *tracked-procedures*
			     (trace:adder *tracked-procedures* sym tfun)))
		      ((stack)
		       (set! *stacked-procedures*
			     (trace:adder *stacked-procedures* sym tfun))))
		    tfun)))))))

(define (trace:untrace-procedure fun sym)
  (define finish
    (lambda (p)
      (cond ((not (procedure? fun)) fun)
	    ((eq? (cdr p) fun) (untracef fun))
	    (else fun))))
  (cond ((assq sym *traced-procedures*)
	 =>
	 (lambda (p)
	   (set! *traced-procedures* (trace:deler *traced-procedures* sym))
	   (finish p)))
	((assq sym *tracked-procedures*)
	 =>
	 (lambda (p)
	   (set! *tracked-procedures* (trace:deler *tracked-procedures* sym))
	   (finish p)))
	((assq sym *stacked-procedures*)
	 =>
	 (lambda (p)
	   (set! *stacked-procedures* (trace:deler *stacked-procedures* sym))
	   (finish p)))
	(else fun)))

(define (tracef . args) (apply debug:trace-procedure 'trace args))
(define (trackf . args) (apply debug:trace-procedure 'track args))
(define (stackf . args) (apply debug:trace-procedure 'stack args))

;;;; Finally, the macros trace and untrace

(defmacro trace xs
  (if (null? xs)
      `(begin (set! trace:indent 0)
	      ,@(map (lambda (x)
		       `(set! ,x (trace:trace-procedure 'trace ,x ',x)))
		     (map car *traced-procedures*))
	      (map car *traced-procedures*))
      `(begin ,@(map (lambda (x)
		       `(set! ,x (trace:trace-procedure 'trace ,x ',x))) xs))))
(defmacro track xs
  (if (null? xs)
      `(begin ,@(map (lambda (x)
		       `(set! ,x (trace:trace-procedure 'track ,x ',x)))
		     (map car *tracked-procedures*))
	      (map car *tracked-procedures*))
      `(begin ,@(map (lambda (x)
		       `(set! ,x (trace:trace-procedure 'track ,x ',x))) xs))))
(defmacro stack xs
  (if (null? xs)
      `(begin ,@(map (lambda (x)
		       `(set! ,x (trace:trace-procedure 'stack ,x ',x)))
		     (map car *stacked-procedures*))
	      (map car *stacked-procedures*))
      `(begin ,@(map (lambda (x)
		       `(set! ,x (trace:trace-procedure 'stack ,x ',x))) xs))))

(defmacro untrace xs
  (if (null? xs)
      (slib:eval
       `(begin ,@(map (lambda (x)
			`(set! ,x (trace:untrace-procedure ,x ',x)))
		      (map car *traced-procedures*))
	       '',(map car *traced-procedures*)))
      `(begin ,@(map (lambda (x)
		       `(set! ,x (trace:untrace-procedure ,x ',x))) xs))))

(defmacro untrack xs
  (if (null? xs)
      (slib:eval
       `(begin ,@(map (lambda (x)
			`(set! ,x (track:untrack-procedure ,x ',x)))
		      (map car *tracked-procedures*))
	       '',(map car *tracked-procedures*)))
      `(begin ,@(map (lambda (x)
		       `(set! ,x (track:untrack-procedure ,x ',x))) xs))))

(defmacro unstack xs
  (if (null? xs)
      (slib:eval
       `(begin ,@(map (lambda (x)
			`(set! ,x (stack:unstack-procedure ,x ',x)))
		      (map car *stacked-procedures*))
	       '',(map car *stacked-procedures*)))
      `(begin ,@(map (lambda (x)
		       `(set! ,x (stack:unstack-procedure ,x ',x))) xs))))