doc/list-exports.lisp: Report on generic function methods.

Show all methods on newly defined generic functions, and all methods
specialized on our own classes.

diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp
index 0c809ee..9f1382b 100644 (file)
--- a/doc/list-exports.lisp
+++ b/doc/list-exports.lisp
@@ -192,6 +192,76 @@
                 (walk-down sub this (1+ depth)))))
       (walk-down (find-class t) nil 0))))
 
+(defun analyse-generic-functions (package)
+  (setf package (find-package package))
+  (flet ((function-name-core (name)
+          (etypecase name
+            (symbol name)
+            ((cons (eql setf) t) (cadr name)))))
+    (let ((methods (make-hash-table))
+         (functions (make-hash-table))
+         (externs (make-hash-table)))
+      (dolist (symbol (list-exported-symbols package))
+       (setf (gethash symbol externs) t))
+      (dolist (symbol (list-exported-symbols package))
+       (flet ((dofunc (func)
+                (when (typep func 'generic-function)
+                  (setf (gethash func functions) t)
+                  (dolist (method (sb-mop:generic-function-methods func))
+                    (setf (gethash method methods) t)))))
+         (dofunc (and (fboundp symbol) (fdefinition symbol)))
+         (dofunc (ignore-errors (fdefinition (list 'setf symbol)))))
+       (when (eq (symbol-package symbol) package)
+         (let ((class (find-class symbol nil)))
+           (when class
+             (dolist
+                 (func (sb-mop:specializer-direct-generic-functions class))
+               (let ((name (function-name-core
+                            (sb-mop:generic-function-name func))))
+                 (when (or (not (eq (symbol-package name) package))
+                           (gethash name externs))
+                   (setf (gethash func functions) t)
+                   (dolist (method (sb-mop:specializer-direct-methods class))
+                     (setf (gethash method methods) t)))))))))
+      (let ((funclist nil))
+       (maphash (lambda (func value)
+                  (declare (ignore value))
+                  (push func funclist))
+                functions)
+       (setf funclist (sort funclist
+                            (lambda (a b)
+                              (let ((core-a (function-name-core a))
+                                    (core-b (function-name-core b)))
+                                (if (eq core-a core-b)
+                                    (and (atom a) (consp b))
+                                    (string< core-a core-b))))
+                            :key #'sb-mop:generic-function-name))
+       (dolist (function funclist)
+         (let ((name (sb-mop:generic-function-name function)))
+           (etypecase name
+             (symbol
+              (format t "~A~%" (pretty-symbol-name name package)))
+             ((cons (eql setf) t)
+              (format t "(setf ~A)~%"
+                      (pretty-symbol-name (cadr name) package)))))
+         (dolist (method (sb-mop:generic-function-methods function))
+           (when (gethash method methods)
+             (format t "~2T~{~A~^ ~}~%"
+                     (mapcar
+                      (lambda (spec)
+                        (etypecase spec
+                          (class
+                           (let ((name (class-name spec)))
+                             (if (eq name t) "t"
+                                 (pretty-symbol-name name package))))
+                          (sb-mop:eql-specializer
+                           (let ((obj (sb-mop:eql-specializer-object spec)))
+                             (format nil "(eql ~A)"
+                                     (if (symbolp obj)
+                                         (pretty-symbol-name obj package)
+                                         obj))))))
+                      (sb-mop:method-specializers method))))))))))
+
 (defun report-symbols (paths package)
   (setf package (find-package package))
   (format t "~A~%Package `~(~A~)'~2%"
@@ -208,6 +278,9 @@
       (terpri)))
   (format t "Classes:~%")
   (analyse-classes package)
+  (terpri)
+  (format t "Methods:~%")
+  (analyse-generic-functions package)
   (terpri))
 
 (defun report-project-symbols ()