Path: utzoo!attcan!uunet!zephyr.ens.tek.com!uw-beaver!mit-eddie!wuarchive!zaphod.mps.ohio-state.edu!ub!boulder!grunwald
From: grunwald@foobar.colorado.edu (Dirk Grunwald)
Newsgroups: comp.lang.scheme
Subject: trace in xscheme
Message-ID: <28787@boulder.Colorado.EDU>
Date: 27 Oct 90 03:56:05 GMT
Sender: news@boulder.Colorado.EDU
Reply-To: grunwald@foobar.colorado.edu
Distribution: comp
Organization: University of Colorado at Boulder
Lines: 205


I'm using xscheme-0.22 for a class in programming languages.  There's
no trace facility, so I wrote one. I'm wondering if anyone has written
any other debugging facilities; my students are having a tough time
with debugging xscheme programs.

In case others find it useful, here's the trace package I wrote:

;;
;; Tracing package (of a sorts) by Dirk Grunwald, Oct. 1990
;;
;; (trace list of function names) will trace the execution of those
;; functions.
;;
;; Redefining a function will cause it to loose its tracing information.
;; You can say (trace ...) again to resume tracing of it.
;;
;; (untrace list of function names) will disable tracing for those functions.
;; (untrace) will disable tracing on all functions.
;;
;; Untracing a function will restore the function as it was when you
;; traced it.  Thus, you should be leary of untracing things. You should
;; probably just untrace everything, reload your file and then continue.
;;
;; E.g.,, if you execute:
;;
;;		(define (foo a b) (+ a b))
;;		(trace foo)
;;		(define (foo a b) (- a b))
;;		(untrace foo)
;;		(foo 20 10)
;;
;; The output will be ``30'' not ``10'' as you might expect.
;;

(set! *trace-alist* nil)

(define (*trace-mkassoc* x y alist)
  (if (null? alist)
      (list (list x y))
      (if (eqv? x (caar alist))
	  ;; then
	  (cons (list x y) (cdr alist))
	  ;; else
	  (cons (car alist) (*trace-mkassoc* x y (cdr alist)))
	  )
      )
  )

(define (*trace-delassoc* x alist)
  (if (null? alist)
      nil
      (if (eqv? x (caar alist))
	  ;; then
	  (cdr alist)
	  ;; else
	  (cons (car alist) (*trace-delassoc* x (cdr alist)))
	  )
      )
  )

(set! *trace-levels* 0)

(define (*trace-space*)
  (let
      ((i *trace-levels*))
    (while (> i 0)
	   (begin
	     (display " ")
	     (set! i (-1+ i))
	     )
	   )
    )
  )


(define (trace-handler form)
  (let* (
	 (fcn (cadr form))
	 (fcn-assoc (assoc fcn *trace-alist*))
	 )
    (if (not (bound? fcn))
	(begin
	  (display "Can't find function ") (display fcn) (newline)
	  nil
	  )
	(begin
	  (set! *trace-alist*
		(*trace-mkassoc* fcn (symbol-value fcn) *trace-alist*))
	  (%expand-macros
	   `(set! ,fcn
		  (lambda args 
		    (let ((*value* nil))
		      (begin
			(set! *trace-levels* (+ *trace-levels* 1))
			(*trace-space*)
			(display "Entering ") (display ',fcn)
			(display ": w/args ") (display args) (newline)
			(set! *value* (apply ,(symbol-value fcn) args))
			(*trace-space*)
			(display "Exiting ") (display ',fcn)
			(display " w/value ") (display *value*) (newline)
			(set! *trace-levels* (- *trace-levels* 1))
			*value*
			)
		      )
		    )
		  )
	   )
	  )
	)
    )
  )

(define (trace-pre-handler form)
  (let
      ((return-value nil))
    (cond
     ((= (length form) 1) (begin
			    (display "Trace all") (newline)
			    (set! return-value
				  (cons 'begin
					(map (lambda (x)
					       (trace-handler
						(list 'trace  x)))
					     (map car *trace-alist*))
					)
				  
				  )
			    )
			  )
     (else  (set! return-value (cons
			  'begin
			  (map (lambda (x) (trace-handler (list 'trace  x)))
			       (cdr form)
			       )
			  )
		  )
	    )
     )
    (display "Now tracing: ")
    (display (map car *trace-alist*))
    (newline)
    return-value
    )
  )

(compiler-syntax trace trace-pre-handler)

(define (untrace-handler form)
  (let* (
	 (fcn (cadr form))
	 (fcn-assoc (assoc fcn *trace-alist*))
	 )
    (if (not fcn-assoc)
	(begin
	  (display "Not tracing ") (display fcn) (newline)
	  nil)
	(begin
	  (set! *trace-alist* (*trace-delassoc* fcn *trace-alist*))
	  (display "Untracing ") (display fcn) (newline)
	  `(set! ,fcn ,(cadr fcn-assoc))
	  )
	)
    )
  )

(define (untrace-pre-handler form)
  (let
      ((return-value nil))
    (cond
     ((= (length form) 1) (begin
			    (display "Untrace all") (newline)
			    (set! return-value
				  (cons 'begin
					(map (lambda (x)
					       (untrace-handler
						(list 'untrace  x)))
					     (map car *trace-alist*))
					)
				  )
			    )
			  )

     (else (set! return-value
		 (cons 'begin
		       (map (lambda (x) (untrace-handler (list 'untrace  x)))
			    (cdr form)))
		 )
	   )
     )
    return-value
    )
  )

(compiler-syntax untrace untrace-pre-handler)

(macro top-level
  (lambda ()
    (begin
      (set! *trace-level* 0)
      (reset)
      )
    )
  )