[slime-cvs] CVS slime

[CVS User heller]

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv25094

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
Don't clutter compiler messages with source positions.  Especially
stuff like "In an anonymous lambda form inside an anonymous lambda
form inside an anonymous lambda form inside FOO: Undeclared free
variable X" is not helpful.

* swank-openmcl.lisp (compiler-warning-short-message): New GF.
(handle-compiler-warning): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2009/06/04 09:08:06	1.1779
+++ /project/slime/cvsroot/slime/ChangeLog	2009/06/05 19:49:01	1.1780
@@ -1,3 +1,13 @@
+2009-06-05  Helmut Eller  <heller at common-lisp.net>
+
+	Don't clutter compiler messages with source positions.  Especially
+	stuff like "In an anonymous lambda form inside an anonymous lambda
+	form inside an anonymous lambda form inside FOO: Undeclared free
+	variable X" is not helpful.
+
+	* swank-openmcl.lisp (compiler-warning-short-message): New GF.
+	(handle-compiler-warning): Use it.
+
 2009-06-04  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (slime-dispatch-event [:emcas-rex]): Don't clutter
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/06/04 08:50:24	1.173
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/06/05 19:49:02	1.174
@@ -229,6 +229,7 @@
            'compiler-condition
            :original-condition condition
            :message (format nil "~A" condition)
+           :short-message (compiler-warning-short-message condition)
            :severity (compiler-warning-severity condition)
            :location (source-note-to-source-location 
                       (ccl::compiler-warning-source-note condition)
@@ -238,6 +239,24 @@
 (defmethod compiler-warning-severity ((c ccl::compiler-warning)) :warning)
 (defmethod compiler-warning-severity ((c ccl::style-warning)) :style-warning)
 
+(defgeneric compiler-warning-short-message (condition))
+
+;; Pretty much the same as ccl::report-compiler-warning but
+;; without the source position and function name stuff.
+(defmethod compiler-warning-short-message ((c ccl::compiler-warning))
+  (with-accessors ((type ccl::compiler-warning-warning-type) 
+                   (args ccl::compiler-warning-args) 
+                   (nrefs ccl::compiler-warning-nrefs)) c
+    (with-output-to-string (stream)
+      (let ((format-string (cdr (assoc type ccl::*compiler-warning-formats*))))
+        (typecase format-string
+          (string (apply #'format stream format-string 
+                         (ccl::adjust-compiler-warning-args type args)))
+          (null (format stream "~A: ~S" type args))
+          (t (funcall format-string c stream)))
+        (when (and nrefs (/= nrefs 1))
+          (format stream " (~D references)" nrefs))))))
+
 (defimplementation call-with-compilation-hooks (function)
   (handler-bind ((ccl::compiler-warning 'handle-compiler-warning))
     (funcall function)))
@@ -519,7 +538,7 @@
 
 (defimplementation disassemble-frame (the-frame-number)
   (with-frame (p context lfun pc) the-frame-number
-    (declare (ignore p context pc))
+    (format t "LFUN: ~a~%PC: ~a  FP: #x~x  CONTEXT: ~a~%" flun pc p context)
     (disassemble lfun)))
 
 ;; BREAK