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

diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp
index 93ee8be..5cb8600 100644
--- a/doc/list-exports.lisp
+++ b/doc/list-exports.lisp
@@ -155,13 +155,22 @@
 
 (defvar charbuf-size 0)
 
+(defun exported-symbol-p (symbol &optional (package (symbol-package symbol)))
+  (and package
+       (multiple-value-bind (sym how)
+	   (find-symbol (symbol-name symbol) package)
+	 (and (eq sym symbol)
+	      (eq how :external)))))
+
 (defun pretty-symbol-name (symbol package)
-  (let* ((pkg (symbol-package symbol))
-	 (exportp (member symbol (list-exported-symbols pkg))))
+  (let ((pkg (symbol-package symbol))
+	(exportp (exported-symbol-p symbol)))
     (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)"
 	    (and exportp (eq pkg package))
-	    (if (keywordp symbol) "" (best-package-name pkg))
-	    exportp (symbol-name symbol))))
+	    (cond ((keywordp symbol) "")
+		  ((eq pkg nil) "#")
+		  (t (best-package-name pkg)))
+	    (or exportp (null pkg)) (symbol-name symbol))))
 
 (defun analyse-classes (package)
   (setf package (find-package package))
@@ -196,6 +205,69 @@
 		 (walk-down sub this (1+ depth)))))
       (walk-down (find-class t) nil 0))))
 
+(defmacro deep-compare ((left right) &body body)
+  (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-"))
+	(l (gensym "LEFT-")) (r (gensym "RIGHT-")))
+    `(macrolet ((focus (expr &body body)
+		  `(flet ((,',func (it) ,expr))
+		     (let ((,',l (,',func ,',l))
+			   (,',r (,',func ,',r)))
+		       ,@body)))
+		(update (expr)
+		  `(flet ((,',func (it) ,expr))
+		     (psetf ,',l (,',func ,',l)
+			    ,',r (,',func ,',r))))
+		(compare (expr)
+		  `(cond ((let ((left ,',l) (right ,',r)) ,expr)
+			  (return-from ,',block t))
+			 ((let ((right ,',l) (left ,',r)) ,expr)
+			  (return-from ,',block nil))))
+		(typesw (&rest clauses)
+		  (labels ((iter (clauses)
+			     (if (null clauses)
+				 'nil
+				 (destructuring-bind (type &rest body)
+				     (car clauses)
+				   (if (eq type t)
+				       `(progn ,@body)
+				       `(if (typep ,',l ',type)
+					    (if (typep ,',r ',type)
+						(progn ,@body)
+						(return-from ,',block t))
+					    (if (typep ,',r ',type)
+						(return-from ,',block nil)
+						,(iter (cdr clauses)))))))))
+		    (iter clauses))))
+       (let ((,l ,left) (,r ,right))
+	 (block ,block
+	   ,@body)))))
+
+(defun order-specializers (la lb)
+  (deep-compare (la lb)
+    (loop (typesw (null (return nil)))
+	  (focus (car it)
+	    (typesw (sb-mop:eql-specializer
+		     (focus (sb-mop:eql-specializer-object it)
+		       (typesw (keyword
+				(compare (string< left right)))
+			       (symbol
+				(focus (package-name (symbol-package it))
+				  (compare (string< left right)))
+				(compare (string< left right)))
+			       (t
+				(focus (with-output-to-string (out)
+					 (prin1 it out)
+					 (write-char #\nul))
+				  (compare (string< left right)))))))
+		    (class
+		     (focus (class-name it)
+		       (focus (package-name (symbol-package it))
+			 (compare (string< left right)))
+		       (compare (string< left right))))
+		    (t
+		     (error "unexpected things"))))
+	  (update (cdr it)))))
+
 (defun analyse-generic-functions (package)
   (setf package (find-package package))
   (flet ((function-name-core (name)
@@ -248,7 +320,10 @@
 	      ((cons (eql setf) t)
 	       (format t "(setf ~A)~%"
 		       (pretty-symbol-name (cadr name) package)))))
-	  (dolist (method (sb-mop:generic-function-methods function))
+	  (dolist (method (sort (copy-list
+				 (sb-mop:generic-function-methods function))
+				#'order-specializers
+				:key #'sb-mop:method-specializers))
 	    (when (gethash method methods)
 	      (format t "~2T~{~A~^ ~}~%"
 		      (mapcar
@@ -279,13 +354,11 @@
 		       (let* ((slot-names
 			       (mapcar #'sb-mop:slot-definition-name
 				       (sb-mop:class-direct-slots class)))
-			      (exported (remove-if-not
+			      (exported (remove-if
 					 (lambda (sym)
-					   (or (and (symbol-package sym)
-						    (not (eq (symbol-package
-							      sym)
-							     package)))
-					       (member sym symbols)))
+					   (and (not (exported-symbol-p sym))
+						(eq (symbol-package sym)
+						    package)))
 					 slot-names)))
 			 (and exported
 			      (list (cons (class-name class)
@@ -301,7 +374,9 @@
   (format t "~A~%Package `~(~A~)'~2%"
 	  (make-string 77 :initial-element #\-)
 	  (package-name package))
-  (dolist (assoc (categorize-symbols paths package))
+  (dolist (assoc (sort (categorize-symbols paths package) #'string<
+		       :key (lambda (assoc)
+			      (file-namestring (car assoc)))))
     (when (cdr assoc)
       (format t "~A~%" (file-namestring (car assoc)))
       (dolist (def (cdr assoc))
@@ -333,7 +408,7 @@
 	     (slot-value comp 'asdf::components))
 	   (files (comp)
 	     (sort (remove-if-not (lambda (comp)
-			      (typep comp 'asdf:cl-source-file))
+				    (typep comp 'asdf:cl-source-file))
 				  (components comp))
 		   #'string< :key #'asdf:component-name))
 	   (by-name (comp name)