[slime-cvs] CVS update: slime/swank-cmucl.lisp

[Helmut Eller]

Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv5152

Modified Files:
	swank-cmucl.lisp 
Log Message:
(clear-xref-info): Compare the truenames with equalp instead of the
unix-truenames.  The old version was very inefficient (clearing the
tables with about 1000 entries required serveral seconds).

(xref-context-derived-from-p, pathname=): Delete unused functions.

Date: Tue Feb 17 16:51:24 2004
Author: heller

Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.65 slime/swank-cmucl.lisp:1.66
--- slime/swank-cmucl.lisp:1.65	Mon Feb 16 16:44:18 2004
+++ slime/swank-cmucl.lisp	Tue Feb 17 16:51:24 2004
@@ -403,10 +403,10 @@
     (group-xrefs xrefs)))
 
 (defun clear-xref-info (namestring)
-  "Clear XREF notes pertaining to FILENAME.
+  "Clear XREF notes pertaining to NAMESTRING.
 This is a workaround for a CMUCL bug: XREF records are cumulative."
   (when c:*record-xref-info*
-    (let ((filename (parse-namestring namestring)))
+    (let ((filename (truename namestring)))
       (dolist (db (list xref::*who-calls*
                         #+cmu19 xref::*who-is-called*
                         #+cmu19 xref::*who-macroexpands*
@@ -414,20 +414,12 @@
                         xref::*who-binds*
                         xref::*who-sets*))
         (maphash (lambda (target contexts)
+                   ;; XXX update during traversal?  
                    (setf (gethash target db)
-                         (delete-if 
-			  (lambda (ctx)
-			    (xref-context-derived-from-p ctx filename))
-			  contexts)))
+                         (delete filename contexts 
+                                 :key #'xref:xref-context-file
+                                 :test #'equalp)))
                  db)))))
-
-(defun xref-context-derived-from-p (context filename)
-  (let ((xref-file (xref:xref-context-file context)))
-    (and xref-file (pathname= filename xref-file))))
-  
-(defun pathname= (&rest pathnames)
-  "True if PATHNAMES refer to the same file."
-  (apply #'string= (mapcar #'unix-truename pathnames)))
 
 (defun unix-truename (pathname)
   (ext:unix-namestring (truename pathname)))