[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-serv4187

Modified Files:
	ChangeLog swank-lispworks.lisp 
Log Message:
beautify undefined function warnings in LW

Date: Thu May  5 01:15:43 2005
Author: eweitz

Index: slime/ChangeLog
diff -u slime/ChangeLog:1.680 slime/ChangeLog:1.681
--- slime/ChangeLog:1.680	Wed May  4 10:52:10 2005
+++ slime/ChangeLog	Thu May  5 01:15:43 2005
@@ -1,3 +1,9 @@
+2005-05-05  Edi Weitz  <edi at agharta.de>
+
+	* swank-lispworks.lisp (unmangle-unfun): New function to convert
+	strange symbols in SETF package to SETF function names.
+	(signal-undefined-functions): Use it.
+
 2005-05-04  Edi Weitz  <edi at agharta.de>
 
 	* swank-lispworks.lisp (call-with-compilation-hooks): Provide


Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.70 slime/swank-lispworks.lisp:1.71
--- slime/swank-lispworks.lisp:1.70	Wed May  4 10:39:14 2005
+++ slime/swank-lispworks.lisp	Thu May  5 01:15:43 2005
@@ -528,11 +528,30 @@
       (make-dspec-progenitor-location dspec (or location filename))
       condition))))
 
+(defun unmangle-unfun (symbol)
+  "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
+function names like \(SETF GET)."
+  (or (and (eq (symbol-package symbol)
+               (load-time-value (find-package :setf)))
+           (let ((nregex::*regex-groupings* 0)
+                 (nregex::*regex-groups* (make-array 10))
+                 (symbol-name (symbol-name symbol)))
+             (and (funcall (load-time-value
+                             (swank::compiled-regex "^\"(.+)\" \"(.+)\"$"))
+                           symbol-name)
+                  (list 'setf
+                        (intern (apply #'subseq symbol-name
+                                       (aref nregex::*regex-groups* 2))
+                                (find-package
+                                 (apply #'subseq symbol-name
+                                        (aref nregex::*regex-groups* 1))))))))
+      symbol))
+
 (defun signal-undefined-functions (htab &optional filename)
   (maphash (lambda (unfun dspecs)
 	     (dolist (dspec dspecs)
 	       (signal-compiler-condition 
-		(format nil "Undefined function ~A" unfun)
+		(format nil "Undefined function ~A" (unmangle-unfun unfun))
 		(make-dspec-progenitor-location dspec
                                                 (or filename
                                                     (gethash (list unfun dspec)