doc/SYMBOLS, doc/list-exports.lisp: Nail down output order properly.

[sod] / doc / list-exports.lisp

diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp
index 93ee8be..5cb8600 100644 (file)
--- 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)