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

[Edi Weitz]

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

Modified Files:
	ChangeLog swank-lispworks.lisp 
Log Message:
call-with-compilation-hooks: better implementation for LW

Date: Wed May  4 10:39:16 2005
Author: eweitz

Index: slime/ChangeLog
diff -u slime/ChangeLog:1.678 slime/ChangeLog:1.679
--- slime/ChangeLog:1.678	Tue May  3 20:59:56 2005
+++ slime/ChangeLog	Wed May  4 10:39:14 2005
@@ -1,3 +1,18 @@
+2005-05-04  Edi Weitz  <edi at agharta.de>
+
+	* swank-lispworks.lisp (call-with-compilation-hooks): Provide
+	better implementation.
+	(compile-file-and-collect-notes): Advice for COMPILE-FILE so
+	pathname information for undefined functions can be recorded.
+	(*within-call-with-compilation-hooks*): New special variable used
+	by CALL-WITH-COMPILATION-HOOKS.
+	(*undefined-functions-hash*): New special variable to record
+	pathname information for undefined functions.
+	(signal-error-database): Make LOCATION parameter optional, use
+	FILENAME info from error database if not provided.
+	(signal-undefined-functions): Make LOCATION parameter optional,
+	use info from *UNDEFINED-FUNCTIONS-HASH* if not provided.
+
 2005-05-03  Luke Gorrie  <luke at synap.se>
 
 	* swank.lisp (slime-secret): Removed #+unix conditional, suggested


Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.69 slime/swank-lispworks.lisp:1.70
--- slime/swank-lispworks.lisp:1.69	Tue Apr  5 15:45:32 2005
+++ slime/swank-lispworks.lisp	Wed May  4 10:39:14 2005
@@ -370,9 +370,32 @@
   (with-swank-compilation-unit (filename)
     (compile-file filename :load load-p)))
 
+(defvar *within-call-with-compilation-hooks* nil
+  "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
+
+(defvar *undefined-functions-hash* nil
+  "Hash table to map info about undefined functions to pathnames.")
+
+(lw:defadvice (compile-file compile-file-and-collect-notes :around)
+    (pathname &rest rest)
+  (prog1 (apply #'lw:call-next-advice pathname rest)
+    (when *within-call-with-compilation-hooks*
+      (maphash (lambda (unfun dspecs)
+                 (dolist (dspec dspecs)
+                   (let ((unfun-info (list unfun dspec)))
+                     (unless (gethash unfun-info *undefined-functions-hash*)
+                       (setf (gethash unfun-info *undefined-functions-hash*)
+                               pathname)))))
+               compiler::*unknown-functions*))))
+
 (defimplementation call-with-compilation-hooks (function)
-  ;; #'pray instead of #'handler-bind
-  (funcall function))
+  (let ((compiler::*error-database* '())
+        (*undefined-functions-hash* (make-hash-table :test 'equal))
+        (*within-call-with-compilation-hooks* t))
+    (with-compilation-unit ()
+      (prog1 (funcall function)
+        (signal-error-data-base compiler::*error-database*)
+        (signal-undefined-functions compiler::*unknown-functions*)))))
 
 (defun map-error-database (database fn)
   (loop for (filename . defs) in database do
@@ -496,22 +519,24 @@
        nil)
      location)))
 
-(defun signal-error-data-base (database location)
+(defun signal-error-data-base (database &optional location)
   (map-error-database 
    database
    (lambda (filename dspec condition)
-     (declare (ignore filename))
      (signal-compiler-condition
       (format nil "~A" condition)
-      (make-dspec-progenitor-location dspec location)
+      (make-dspec-progenitor-location dspec (or location filename))
       condition))))
 
-(defun signal-undefined-functions (htab filename)
+(defun signal-undefined-functions (htab &optional filename)
   (maphash (lambda (unfun dspecs)
 	     (dolist (dspec dspecs)
 	       (signal-compiler-condition 
 		(format nil "Undefined function ~A" unfun)
-		(make-dspec-progenitor-location dspec filename)
+		(make-dspec-progenitor-location dspec
+                                                (or filename
+                                                    (gethash (list unfun dspec)
+                                                             *undefined-functions-hash*)))
 		nil)))
 	   htab))