X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/ed00691544c3b6d4ad15b1c7ef975964ea72b0b6..4b8e5c0347115ff30841f1d1e71afe59ecb6c82c:/doc/list-exports.lisp

diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp
index ef10b00..abbf94a 100644
--- a/doc/list-exports.lisp
+++ b/doc/list-exports.lisp
@@ -128,14 +128,16 @@
 (defun categorize-symbols (paths package)
   (mapcar (lambda (assoc)
 	    (let ((home (car assoc))
-		  (symbols (sort (mapcan (lambda (sym)
-					   (multiple-value-bind
-					       (symbol foundp)
-					       (find-symbol (symbol-name sym)
-							    package)
-					     (and foundp (list symbol))))
-					 (cdr assoc))
-				 #'string< :key #'symbol-name)))
+		  (symbols (delete-duplicates
+			    (sort (mapcan (lambda (sym)
+					    (multiple-value-bind
+						(symbol foundp)
+						(find-symbol
+						 (symbol-name sym)
+						 package)
+					      (and foundp (list symbol))))
+					  (cdr assoc))
+				  #'string< :key #'symbol-name))))
 	      (cons home (mapcar (lambda (symbol)
 				   (cons symbol (categorize symbol)))
 				 symbols))))
@@ -190,6 +192,106 @@
 		 (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 check-slot-names (package)
+  (setf package (find-package package))
+  (let* ((symbols (list-exported-symbols package))
+	 (classes (mapcan (lambda (symbol)
+			    (when (eq (symbol-package symbol) package)
+			      (let ((class (find-class symbol nil)))
+				(and class (list class)))))
+			  symbols))
+	 (offenders (mapcan
+		     (lambda (class)
+		       (let* ((slot-names
+			       (mapcar #'sb-mop:slot-definition-name
+				       (sb-mop:class-direct-slots class)))
+			      (exported (remove-if-not
+					 (lambda (sym)
+					   (or (and (symbol-package sym)
+						    (not (eq (symbol-package
+							      sym)
+							     package)))
+					       (member sym symbols)))
+					 slot-names)))
+			 (and exported
+			      (list (cons (class-name class)
+					  exported)))))
+			    classes))
+	 (bad-words (remove-duplicates (mapcan (lambda (list)
+						 (copy-list (cdr list)))
+					       offenders))))
+    (values offenders bad-words)))
+
 (defun report-symbols (paths package)
   (setf package (find-package package))
   (format t "~A~%Package `~(~A~)'~2%"
@@ -204,8 +306,22 @@
 		  (pretty-symbol-name sym package)
 		  (cdr def))))
       (terpri)))
+  (multiple-value-bind (alist names) (check-slot-names package)
+    (when names
+      (format t "Leaked slot names: ~{~A~^, ~}~%"
+	      (mapcar (lambda (name) (pretty-symbol-name name package))
+		      names))
+      (dolist (assoc alist)
+	(format t "~2T~A: ~{~A~^, ~}~%"
+		(pretty-symbol-name (car assoc) package)
+		(mapcar (lambda (name) (pretty-symbol-name name package))
+			(cdr assoc))))
+      (terpri)))
   (format t "Classes:~%")
   (analyse-classes package)
+  (terpri)
+  (format t "Methods:~%")
+  (analyse-generic-functions package)
   (terpri))
 
 (defun report-project-symbols ()