From a535feed31204e82c6443411d16a03958c3ca4d2 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Sun, 30 Aug 2015 10:58:38 +0100
Subject: [PATCH] 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.
---
 doc/list-exports.lisp | 73 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 73 insertions(+)

diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp
index 0c809ee..9f1382b 100644
--- 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 ()
-- 
2.11.0