[movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv5443

Modified Files:
	environment.lisp 
Log Message:
Re-wrote the way tracing works. Use a designated closure for each
traced function, rather than the same trace-wrapper function for
everyone. Seems to work much better.

Date: Wed Mar 24 19:52:54 2004
Author: ffjeld

Index: movitz/losp/muerte/environment.lisp
diff -u movitz/losp/muerte/environment.lisp:1.3 movitz/losp/muerte/environment.lisp:1.4
--- movitz/losp/muerte/environment.lisp:1.3	Wed Mar 24 14:33:40 2004
+++ movitz/losp/muerte/environment.lisp	Wed Mar 24 19:52:54 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Oct 20 00:41:57 2001
 ;;;;                
-;;;; $Id: environment.lisp,v 1.3 2004/03/24 19:33:40 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.4 2004/03/25 00:52:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -67,60 +67,52 @@
        ((equal name 'eval)
 	(return nil))))))
 
-(defun trace-wrapper (&edx function-name-symbol &rest args)
-  (declare (dynamic-extent args))
-  (check-type function-name-symbol symbol)
-  (let ((map (assoc function-name-symbol *trace-map*
-		    :key #'function-name-symbol)))
-    (assert map ()
-      "~S is not traced!?" function-name-symbol)
-    (let ((function-name (car map))
-	  (function (cadr map))
-	  (callers (caddr map)))
-      (cond
-       ((or *trace-escape*
-	    (and (not (eq t callers))
-		 (notany 'match-caller callers)))
-	(apply function args))
-       (t (let ((*trace-escape* t))
-	    (fresh-line *trace-output*)
-	    (dotimes (i *trace-level*)
-	      (write-string "  " *trace-output*))
-	    (format *trace-output* "~D: (~S~{ ~S~})~%"
-		    *trace-level* function-name args))
-	  (multiple-value-call
-	      (lambda (&rest results)
-		(declare (dynamic-extent results))
-		(let ((*trace-escape* t))
-		  (fresh-line *trace-output*)
-		  (dotimes (i *trace-level*)
-		    (write-string "  " *trace-output*))
-		  (format *trace-output* "~&~D: =>~{ ~W~^,~}.~%" *trace-level* results)
-		  (values-list results)))
-	    (apply function args)))))))
-
 (defun do-trace (function-name &key (callers t))
   (when (assoc function-name *trace-map* :test #'equal)
     (do-untrace function-name))
   (let ((function-symbol (function-name-symbol function-name)))
     (assert (fboundp function-symbol) (function-name)
       "Can't trace undefined function ~S." function-name)
-    (push (list function-name
-		(symbol-function function-symbol)
-		callers)
-	  *trace-map*)
-    (setf (symbol-function function-symbol)
-      #'trace-wrapper))
+    (let* ((real-function (symbol-function function-symbol))
+	   (wrapper (lambda (&rest args)
+		      (declare (dynamic-extent args))
+		      (if *trace-escape*
+			  (apply real-function args)
+			(let ((*trace-escape* t))
+			  (cond
+			   ((and (not (eq t callers))
+				 (notany 'match-caller callers))
+			    (apply real-function args))
+			   (t (let ((*trace-escape* t))
+				(fresh-line *trace-output*)
+				(dotimes (i *trace-level*)
+				  (write-string "  " *trace-output*))
+				(format *trace-output* "~D: (~S~{ ~S~})~%"
+					*trace-level* function-name args))
+			      (multiple-value-call
+				  (lambda (&rest results)
+				    (declare (dynamic-extent results))
+				    (let ((*trace-escape* t))
+				      (fresh-line *trace-output*)
+				      (dotimes (i *trace-level*)
+					(write-string "  " *trace-output*))
+				      (format *trace-output* "~&~D: =>~{ ~W~^,~}.~%" *trace-level* results)
+				      (values-list results)))
+				(let ((*trace-level* (1+ *trace-level*))
+				      (*trace-escape* nil))
+				  (apply real-function args))))))))))
+      (push (cons function-name
+		  real-function)
+	    *trace-map*)
+      (setf (symbol-function function-symbol)
+	wrapper)))
   (values))
 
 (defun do-untrace (name)
   (let ((map (assoc name *trace-map*)))
     (assert map () "~S is not traced." name)
     (let ((function-name-symbol (function-name-symbol name))
-	  (function (cadr map)))
-      (unless (eq (symbol-function function-name-symbol)
-		  #'trace-wrapper)
-	(warn "~S was traced, but not fbound to trace-wrapper." name))
+	  (function (cdr map)))
       (setf (symbol-function function-name-symbol)
 	function)
       (setf *trace-map*