[slime-devel] find-definitions enhancements for sbcl

[Thomas F. Burdick]

"M-."
"How in the hell could that function *possibly* behave like it does?!?!"
" ... oh, wait ... "

The following patch adds compiler-macros, deftransforms, and
defoptimizers to the things that M-. finds on sbcl.

"Ahhhhh"



Index: ChangeLog
===================================================================
RCS file: /project/slime/cvsroot/slime/ChangeLog,v
retrieving revision 1.548
diff -u -F^(def -r1.548 ChangeLog
--- ChangeLog	7 Oct 2004 19:33:00 -0000	1.548
+++ ChangeLog	11 Oct 2004 18:07:51 -0000
@@ -1,3 +1,11 @@
+2004-10-11  Thomas Burdick  <tfb at OCF.Berkeley.EDU>
+
+	* swank-sbcl.lisp
+	(function-definitions): Find compiler macros, too.
+	(find-defintions, compiler-definitions)
+	(optimizer-definitions, transform-definitions): Add compiler
+	transformers and optimizers to the list of definitions.
+
 2004-10-07  Peter Seibel  <peter at javamonkey.com>
 
 	* swank.lisp (spawn-threads-for-connection): Bind *debugger-hook*
Index: swank-sbcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v
retrieving revision 1.104
diff -u -F^(def -r1.104 swank-sbcl.lisp
--- swank-sbcl.lisp	17 Sep 2004 12:51:33 -0000	1.104
+++ swank-sbcl.lisp	11 Oct 2004 18:07:58 -0000
@@ -409,20 +409,52 @@ (defun method-definitions (gf)
 
 (defun function-definitions (name)
   (flet ((loc (fn name) (safe-function-source-location fn name)))
-    (cond ((and (symbolp name) (macro-function name))
-           (list (list `(defmacro ,name) 
-                       (loc (macro-function name) name))))
-          ((fboundp name)
-           (let ((fn (fdefinition name)))
-             (typecase fn
-               (generic-function
-                (cons (list `(defgeneric ,name) (loc fn name))
-                      (method-definitions fn)))
-               (t
-                (list (list `(function ,name) (loc fn name))))))))))
+    (append
+     (cond ((and (symbolp name) (macro-function name))
+            (list (list `(defmacro ,name) 
+                        (loc (macro-function name) name))))
+           ((fboundp name)
+            (let ((fn (fdefinition name)))
+              (typecase fn
+                (generic-function
+                 (cons (list `(defgeneric ,name) (loc fn name))
+                       (method-definitions fn)))
+                (t
+                 (list (list `(function ,name) (loc fn name))))))))
+     (when (compiler-macro-function name)
+       (list (list `(define-compiler-macro ,name)
+                   (loc (compiler-macro-function name) name)))))))
+
+(defun transform-definitions (fun-info name)
+  (loop for xform in (sb-c::fun-info-transforms fun-info)
+        for loc = (safe-function-source-location
+                   (sb-c::transform-function xform) name)
+        for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform))
+        for note = (sb-c::transform-note xform)
+        for spec = (if (consp typespec)
+                       `(sb-c:deftransform ,(second typespec) ,note)
+                       `(sb-c:deftransform ,note))
+        collect `(,spec ,loc)))
+
+(defun optimizer-definitions (fun-info fun-name)
+  (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
+                  (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
+                  (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
+                  (sb-c::fun-info-optimizer . sb-c:optimizer))))
+    (loop for (reader . name) in otypes
+          for fn = (funcall reader fun-info)
+          when fn collect `((sb-c:defoptimizer ,name)
+                            ,(safe-function-source-location fn fun-name)))))
+
+(defun compiler-definitions (name)
+  (let ((fun-info (sb-int:info :function :info name)))
+    (when fun-info
+      (append (transform-definitions fun-info name)
+              (optimizer-definitions fun-info name)))))
 
 (defimplementation find-definitions (name)
-  (function-definitions name))
+  (append (function-definitions name)
+          (compiler-definitions name)))
 
 (defimplementation describe-symbol-for-emacs (symbol)
   "Return a plist describing SYMBOL.