doc/list-exports.lisp: Document and lightly reformat.

Much more pleasant.

diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp
index 6663801eabf4d9dba7a3ab86397ad0b1e98d86ac..a90c0d5b6f4f20c686e0d3e0f9bf39547e5cf363 100755 (executable)
--- a/doc/list-exports.lisp
+++ b/doc/list-exports.lisp
@@ -8,22 +8,40 @@ (cl:defpackage #:sod-exports
        #+cmu #:mop
        #+sbcl #:sb-mop))
 
        #+cmu #:mop
        #+sbcl #:sb-mop))
 

+;; Load the target system so that we can poke about in it.

 (cl:in-package #:sod-exports)
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (mapc #'asdf:load-system '(:sod :sod-frontend)))
 
 (cl:in-package #:sod-exports)
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (mapc #'asdf:load-system '(:sod :sod-frontend)))
 

+;;;--------------------------------------------------------------------------
+;;; Miscelleneous utilities.
+

 (defun symbolicate (&rest things)
 (defun symbolicate (&rest things)

+  "Concatenate the THINGS and turn the result into a symbol."

   (intern (apply #'concatenate 'string (mapcar #'string things))))
 
   (intern (apply #'concatenate 'string (mapcar #'string things))))
 

+;;;--------------------------------------------------------------------------
+;;; Determining the symbols exported by particular files.
+

 (defun incomprehensible-form (head tail)
 (defun incomprehensible-form (head tail)

+  "Report an incomprehensible form (HEAD . TAIL)."

   (format *error-output* ";; incomprehensible: ~S~%" (cons head tail)))
 
 (defgeneric form-list-exports (head tail)
   (format *error-output* ";; incomprehensible: ~S~%" (cons head tail)))
 
 (defgeneric form-list-exports (head tail)

+  (:documentation
+   "Return a list of symbols exported by the form (HEAD . TAIL).
+
+   This is called from `form-exports' below.")

   (:method (head tail)
   (:method (head tail)

+    "By default, a form exports nothing."

     (declare (ignore head tail))
     nil))
 
 (defmethod form-list-exports ((head (eql 'cl:export)) tail)
     (declare (ignore head tail))
     nil))
 
 (defmethod form-list-exports ((head (eql 'cl:export)) tail)

+  "Return the symbols exported by a toplevel `export' form.
+
+   We can cope with (export 'SYMBOLS), where SYMBOLS is a symbol or a list."
+

   (let ((symbols (car tail)))
     (if (and (consp symbols)
             (eq (car symbols) 'quote))
   (let ((symbols (car tail)))
     (if (and (consp symbols)
             (eq (car symbols) 'quote))


@@ -32,22 +50,52 @@ (defmethod form-list-exports ((head (eql 'cl:export)) tail)
        (incomprehensible-form head tail))))
 
 (defmethod form-list-exports ((head (eql 'sod:definst)) tail)
        (incomprehensible-form head tail))))
 
 (defmethod form-list-exports ((head (eql 'sod:definst)) tail)

+  "Return the symbols exported by a `form-list-exports' form.
+
+   The syntax is:
+
+       (definst CODE (STREAMVAR [[:export FLAG]]) ARGS
+         FORM*)
+
+   If FLAG is non-nil, then we export `CODE-inst', `make-CODE-inst', and
+   `inst-ARG' for each argument ARG in the lambda-list ARGS.  There are some
+   quirks in this lambda-list:
+
+     * If we find a list (PUBLIC PRIVATE) where we expected an argument-name
+       symbol (but not a list), then the argument is PUBLIC.  (PRIVATE is
+       used to name a slot in the class created by the macro, presumably
+       because PUBLIC on its own is a public symbol in some package.)
+
+     * If we find a symbol %NAME, this means the same as the list (NAME
+       %NAME), only we recognize it even where the lambda-list syntax expects
+       a list."
+

   (destructuring-bind (code (streamvar &key export) args &body body) tail
     (declare (ignore streamvar body))
   (destructuring-bind (code (streamvar &key export) args &body body) tail
     (declare (ignore streamvar body))

+

     (and export
         (list* (symbolicate code '-inst)
                (symbolicate 'make- code '-inst)
     (and export
         (list* (symbolicate code '-inst)
                (symbolicate 'make- code '-inst)

+

                (labels ((dig (tree path)
                (labels ((dig (tree path)

+                          ;; Dig down into a TREE, following the PATH.  Stop
+                          ;; when we find an atom, or reach the end of the
+                          ;; path.

                           (if (or (atom tree) (null path)) tree
                               (dig (nth (car path) tree) (cdr path))))
                         (cook (arg)
                           (if (or (atom tree) (null path)) tree
                               (dig (nth (car path) tree) (cdr path))))
                         (cook (arg)

+                          ;; Convert an ARG name which might start with `%'.

                           (if (consp arg) (car arg)
                               (let ((name (symbol-name arg)))
                                 (if (char= (char name 0) #\%)
                                     (intern (subseq name 1))
                                     arg))))
                         (instify (arg)
                           (if (consp arg) (car arg)
                               (let ((name (symbol-name arg)))
                                 (if (char= (char name 0) #\%)
                                     (intern (subseq name 1))
                                     arg))))
                         (instify (arg)

+                          ;; Convert ARG name into the `inst-ARG' accessor.

                           (symbolicate 'inst- (cook arg))))
                           (symbolicate 'inst- (cook arg))))

+
+                 ;; Work through the lambda-list, keeping track of where we
+                 ;; expect the argument symbols to be.

                  (loop with state = :mandatory
                        for arg in args
                        if (and (symbolp arg)
                  (loop with state = :mandatory
                        for arg in args
                        if (and (symbolp arg)


@@ -63,6 +111,14 @@ (defmethod form-list-exports ((head (eql 'sod:definst)) tail)
                          do (error "Confused by ~S." arg)))))))
 
 (defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail)
                          do (error "Confused by ~S." arg)))))))
 
 (defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail)

+  "Return the symbols exported by a `define-tagged-type' form.
+
+   This is a scummy internal macro in `c-types-impl.lisp'.  The syntax is
+
+       (define-tagged-type KIND DESCRIPTION)
+
+   It exports `KIND' and `make-KIND'."
+

   (destructuring-bind (kind what) tail
     (declare (ignore what))
     (list kind
   (destructuring-bind (kind what) tail
     (declare (ignore what))
     (list kind


@@ -70,6 +126,15 @@ (defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail)
          (symbolicate 'make- kind '-type))))
 
 (defmethod form-list-exports ((head (eql 'sod:defctype)) tail)
          (symbolicate 'make- kind '-type))))
 
 (defmethod form-list-exports ((head (eql 'sod:defctype)) tail)

+  "Return the symbols exported by a `defctype' form.
+
+   The syntax is:
+
+       (defctype {NAME | (NAME SYNONYM*)} VALUE [[:export FLAG]])
+
+   If FLAG is non-nil, this form exports `c-type-NAME', `NAME', and all of
+   the `SYNONYM's."
+

   (destructuring-bind (names value &key export) tail
     (declare (ignore value))
     (let ((names (if (listp names) names (list names))))
   (destructuring-bind (names value &key export) tail
     (declare (ignore value))
     (let ((names (if (listp names) names (list names))))


@@ -77,6 +142,15 @@ (defmethod form-list-exports ((head (eql 'sod:defctype)) tail)
           (list* (symbolicate 'c-type- (car names)) names)))))
 
 (defmethod form-list-exports ((head (eql 'sod:define-simple-c-type)) tail)
           (list* (symbolicate 'c-type- (car names)) names)))))
 
 (defmethod form-list-exports ((head (eql 'sod:define-simple-c-type)) tail)

+  "Return the symbols exported by a `define-simple-c-type' form.
+
+   The syntax is:
+
+       (define-simple-c-type {NAME | (NAME SYNONYM*)} TYPE [[:export FLAG]])
+
+   If FLAG is non-nil, this form exports `c-type-NAME', `NAME', and all of
+   the `SYNONYM's."
+

   (destructuring-bind (names type &key export) tail
     (declare (ignore type))
     (let ((names (if (listp names) names (list names))))
   (destructuring-bind (names type &key export) tail
     (declare (ignore type))
     (let ((names (if (listp names) names (list names))))


@@ -84,39 +158,69 @@ (defmethod form-list-exports ((head (eql 'sod:define-simple-c-type)) tail)
           (list* (symbolicate 'c-type- (car names)) names)))))
 
 (defmethod form-list-exports ((head (eql 'cl:macrolet)) tail)
           (list* (symbolicate 'c-type- (car names)) names)))))
 
 (defmethod form-list-exports ((head (eql 'cl:macrolet)) tail)

+  "Return the symbols expored by a toplevel `macrolet' form.
+
+   Which are simply the symbols exported by its body."

   (mapcan #'form-exports (cdr tail)))
 
 (defmethod form-list-exports ((head (eql 'cl:eval-when)) tail)
   (mapcan #'form-exports (cdr tail)))
 
 (defmethod form-list-exports ((head (eql 'cl:eval-when)) tail)

+  "Return the symbols expored by a toplevel `eval-when' form.
+
+   Which are simply the symbols exported by its body."
+
+  ;; We don't bother checking when it'd actually be evaluated.

   (mapcan #'form-exports (cdr tail)))
 
 (defmethod form-list-exports ((head (eql 'cl:progn)) tail)
   (mapcan #'form-exports (cdr tail)))
 
 (defmethod form-list-exports ((head (eql 'cl:progn)) tail)

+  "Return the symbols expored by a toplevel `progn' form.
+
+   Which are simply the symbols exported by its body."

   (mapcan #'form-exports tail))
 
 (defgeneric form-exports (form)
   (mapcan #'form-exports tail))
 
 (defgeneric form-exports (form)

+  (:documentation
+   "Return a list of symbols exported by a toplevel FORM.")

   (:method (form) nil)
   (:method ((form cons)) (form-list-exports (car form) (cdr form))))
 
   (:method (form) nil)
   (:method ((form cons)) (form-list-exports (car form) (cdr form))))
 

-(defgeneric list-exports (thing))
+(defgeneric list-exports (thing)
+  (:documentation
+   "Return a list of symbols exported by THING."))

 
 (defmethod list-exports ((stream stream))
 
 (defmethod list-exports ((stream stream))

+  "Return a list of symbols exported by a STREAM.
+
+   By reading it and analysing the forms."
+

   (loop with eof = '#:eof
        for form = (read stream nil eof)
        until (eq form eof)
        when (consp form) nconc (form-exports form)))
 
 (defmethod list-exports ((path pathname))
   (loop with eof = '#:eof
        for form = (read stream nil eof)
        until (eq form eof)
        when (consp form) nconc (form-exports form)))
 
 (defmethod list-exports ((path pathname))

+  "Return a list of symbols exported by a directory PATHNAME.
+
+   Return an alist of pairs (PATH . SYMBOL) listing each SYMBOL exported by a
+   PATH of the form PATHNAME/*.lisp."
+

   (mapcar (lambda (each)
            (cons each (with-open-file (stream each) (list-exports stream))))
          (directory (merge-pathnames path #p"*.lisp"))))
 
 (defmethod list-exports ((path string))
   (mapcar (lambda (each)
            (cons each (with-open-file (stream each) (list-exports stream))))
          (directory (merge-pathnames path #p"*.lisp"))))
 
 (defmethod list-exports ((path string))

+  "Return a list of symbols exported by a PATH string.
+
+   By converting it into a pathname."
+

   (list-exports (pathname path)))
 
 (defun list-exported-symbols (package)
   (list-exports (pathname path)))
 
 (defun list-exported-symbols (package)

+  "Return a sorted list of symbols exported by PACKAGE."

   (sort (loop for s being the external-symbols of package collect s)
        #'string< :key #'symbol-name))
 
 (defun list-all-symbols (package)
   (sort (loop for s being the external-symbols of package collect s)
        #'string< :key #'symbol-name))
 
 (defun list-all-symbols (package)

+  "Return a sorted list of all symbols exported by or private to PACKAGE."

   (let ((externs (make-hash-table)))
     (dolist (sym (list-exported-symbols package))
       (setf (gethash sym externs) t))
   (let ((externs (make-hash-table)))
     (dolist (sym (list-exported-symbols package))
       (setf (gethash sym externs) t))


@@ -127,10 +231,23 @@ (defun list-all-symbols (package)
          #'string< :key #'symbol-name)))
 
 (defun find-symbol-homes (paths package)
          #'string< :key #'symbol-name)))
 
 (defun find-symbol-homes (paths package)

+  "Determine the `home' file for the symbols exported by PACKAGE.
+
+   Return an alist of pairs (PATH . SYMBOL) listing each SYMBOL exported by a
+   PATH of the form PATHNAME/*.lisp where PATHNAME is a member of PATHS.  Do
+   this by finding all the files and parsing them (somewhat superficially),
+   and cross-checking the result against the actual symbols exported by the
+   PACKAGE."
+
+  ;; Building the alist is exactly what `list-exports' is for.  The rest of
+  ;; this function is the cross-checking.

   (let* ((symbols (list-exported-symbols package))
         (exports-alist (let ((*package* package))
                          (mapcan #'list-exports paths)))
         (homes (make-hash-table :test #'equal)))
   (let* ((symbols (list-exported-symbols package))
         (exports-alist (let ((*package* package))
                          (mapcan #'list-exports paths)))
         (homes (make-hash-table :test #'equal)))

+
+    ;; Work through the alist recording where we found each symbol.  Check
+    ;; that they're actually exported by poking at the package.

     (dolist (assoc exports-alist)
       (let ((home (car assoc)))
        (dolist (symbol (cdr assoc))
     (dolist (assoc exports-alist)
       (let ((home (car assoc)))
        (dolist (symbol (cdr assoc))


@@ -138,12 +255,24 @@ (defun find-symbol-homes (paths package)
            (unless (nth-value 1 (find-symbol name package))
              (format *error-output* ";; unexported: ~S~%" symbol))
            (setf (gethash name homes) home)))))
            (unless (nth-value 1 (find-symbol name package))
              (format *error-output* ";; unexported: ~S~%" symbol))
            (setf (gethash name homes) home)))))

+
+    ;; Check that all of the symbols exported by the package are accounted
+    ;; for in our alist.

     (dolist (symbol symbols)
       (unless (gethash (symbol-name symbol) homes)
        (format *error-output* ";; mysterious: ~S~%" symbol)))
     (dolist (symbol symbols)
       (unless (gethash (symbol-name symbol) homes)
        (format *error-output* ";; mysterious: ~S~%" symbol)))

+
+    ;; We're done.

     exports-alist))
 
     exports-alist))
 

+;;;--------------------------------------------------------------------------
+;;; Determining the kinds of definitions attached to symbols.
+

 (defun boring-setf-expansion-p (symbol)
 (defun boring-setf-expansion-p (symbol)

+  "Return non-nil if SYMBOL has a trivial `setf' expansion.
+
+   i.e., (setf (SYMBOL ...) ...) works by (funcall #'(setf SYMBOL) ...)."
+

   (multiple-value-bind (temps args stores store fetch)
       (ignore-errors (get-setf-expansion (list symbol)))
     (declare (ignore temps args stores fetch))
   (multiple-value-bind (temps args stores store fetch)
       (ignore-errors (get-setf-expansion (list symbol)))
     (declare (ignore temps args stores fetch))


@@ -156,6 +285,12 @@ (defun boring-setf-expansion-p (symbol)
                (eq (car func) 'setf))))))
 
 (defun specialized-on-p (func arg what)
                (eq (car func) 'setf))))))
 
 (defun specialized-on-p (func arg what)

+  "Check whether FUNC has a method specialized for the symbol WHAT.
+
+   We assume FUNC is a (well-known) generic function.  ARG is a small integer
+   identifying one of FUNC's mandatory arguments.  Return non-nil if FUNC has
+   a method for which this ARG is `eql'-specialized on WHAT."
+

   (some (lambda (method)
          (let ((spec (nth arg (method-specializers method))))
            (and (typep spec 'eql-specializer)
   (some (lambda (method)
          (let ((spec (nth arg (method-specializers method))))
            (and (typep spec 'eql-specializer)


@@ -163,6 +298,27 @@ (defun specialized-on-p (func arg what)
        (generic-function-methods func)))
 
 (defun categorize (symbol)
        (generic-function-methods func)))
 
 (defun categorize (symbol)

+  "Determine what things SYMBOL is defined to do.
+
+   Return a list of keywords:
+
+     * :constant -- SYMBOL's value cell is `boundp' and `constantp'
+     * :variable -- SYMBOL's value cell is `boundp' but not `constantp'
+     * :macro -- SYMBOL's function cell is `macro-function'
+     * :generic -- SYMBOL's function cell is a `generic-function'
+     * :function -- SYMBOL's function cell is a non-generic `function'
+     * :setf-generic -- (setf SYMBOL) is a `generic-function'
+     * :setf-function -- (setf SYMBOL) is a non-generic `function'
+     * :class -- SYMBOL is `find-class'
+     * :c-type -- `expand-c-type-spec' or `expand-c-type-form' has a method
+       specialized on SYMBOL
+     * :parser -- `expand-parser-spec' or `expand-parser-form' has a method
+       specialized on SYMBOL
+     * :opthandler -- SYMBOL has an `opthandler' property
+     * :optmacro -- SYMBOL has an `optmacro' property
+
+   categorizing the kinds of definitions that SYMBOL has."
+

   (let ((things nil))
     (when (boundp symbol)
       (push (if (constantp symbol) :constant :variable) things))
   (let ((things nil))
     (when (boundp symbol)
       (push (if (constantp symbol) :constant :variable) things))


@@ -191,6 +347,11 @@ (defun categorize (symbol)
     (nreverse things)))
 
 (defun categorize-symbols (paths package)
     (nreverse things)))
 
 (defun categorize-symbols (paths package)

+  "Return a categorized list of the symbols exported by PACKAGE.
+
+   Return an alist of PAIRS (PATH . SYMBOLS), for each PATH in PATHS, where
+   SYMBOLS is itself an alist (SYMBOL . KEYWORDS) listing the kinds of
+   definitions that SYMBOL has (see `categorize')."

   (mapcar (lambda (assoc)
            (let ((home (car assoc))
                  (symbols (delete-duplicates
   (mapcar (lambda (assoc)
            (let ((home (car assoc))
                  (symbols (delete-duplicates


@@ -206,10 +367,13 @@ (defun categorize-symbols (paths package)
              (cons home (mapcar (lambda (symbol)
                                   (cons symbol (categorize symbol)))
                                 symbols))))
              (cons home (mapcar (lambda (symbol)
                                   (cons symbol (categorize symbol)))
                                 symbols))))

-

          (find-symbol-homes paths package)))
 
          (find-symbol-homes paths package)))
 

+;;;--------------------------------------------------------------------------
+;;; Reporting.
+

 (defun best-package-name (package)
 (defun best-package-name (package)

+  "Return a convenient name for PACKAGE."

 
   ;; We pick the shortest one.  Strangely, there's no `find minimal thing
   ;; according to this valuation' function in Common Lisp.
 
   ;; We pick the shortest one.  Strangely, there's no `find minimal thing
   ;; according to this valuation' function in Common Lisp.


@@ -225,6 +389,9 @@ (defun best-package-name (package)
 (defvar charbuf-size 0)
 
 (defun exported-symbol-p (symbol &optional (package (symbol-package symbol)))
 (defvar charbuf-size 0)
 
 (defun exported-symbol-p (symbol &optional (package (symbol-package symbol)))

+  "Return whether SYMBOL is exported by PACKAGE.
+
+   PACKAGE default's to the SYMBOL's home package, but may be different."

   (and package
        (multiple-value-bind (sym how)
           (find-symbol (symbol-name symbol) package)
   (and package
        (multiple-value-bind (sym how)
           (find-symbol (symbol-name symbol) package)


@@ -232,6 +399,12 @@ (defun exported-symbol-p (symbol &optional (package (symbol-package symbol)))
              (eq how :external)))))
 
 (defun downcase-or-escape (name)
              (eq how :external)))))
 
 (defun downcase-or-escape (name)

+  "Return a presentable form for a symbol or package name.
+
+   If NAME consists only of uppercase letters and ordinary punctuation, then
+   return NAME in lowercase; otherwise wrap it in `|...|' and escape as
+   necessary."
+

   (if (every (lambda (char)
               (or (upper-case-p char)
                   (digit-char-p char)
   (if (every (lambda (char)
               (or (upper-case-p char)
                   (digit-char-p char)


@@ -249,6 +422,13 @@ (defun downcase-or-escape (name)
        (write-char #\| out))))
 
 (defun pretty-symbol-name (symbol package)
        (write-char #\| out))))
 
 (defun pretty-symbol-name (symbol package)

+  "Return a presentable form for SYMBOL, relative to PACKAGE.
+
+   If SYMBOL is exported by PACKAGE then just write the SYMBOL's name
+   otherwise prefix the name with the SYMBOL's home package name, separated
+   joined with one or two colons.  Uninterned symbols and keywords are also
+   printed specially."
+

   (let ((pkg (symbol-package symbol))
        (exportp (exported-symbol-p symbol)))
     (format nil "~:[~A:~:[:~;~]~;~2*~]~A"
   (let ((pkg (symbol-package symbol))
        (exportp (exported-symbol-p symbol)))
     (format nil "~:[~A:~:[:~;~]~;~2*~]~A"


@@ -260,12 +440,17 @@ (defun pretty-symbol-name (symbol package)
            (downcase-or-escape (symbol-name symbol)))))
 
 (deftype interesting-class ()
            (downcase-or-escape (symbol-name symbol)))))
 
 (deftype interesting-class ()

+  "The type of `interesting' classes, which might be user-defined."

   '(or standard-class
        structure-class
        #.(class-name (class-of (find-class 'condition)))))
 
 (defun analyse-classes (package)
   '(or standard-class
        structure-class
        #.(class-name (class-of (find-class 'condition)))))
 
 (defun analyse-classes (package)

+  "Print a report on the classes defined by PACKAGE."
+
+  ;; Canonify PACKAGE into a package object.

   (setf package (find-package package))
   (setf package (find-package package))

+

   (let ((classes (mapcan (lambda (symbol)
                           (let ((class (find-class symbol nil)))
                             (and class
   (let ((classes (mapcan (lambda (symbol)
                           (let ((class (find-class symbol nil)))
                             (and class


@@ -273,6 +458,11 @@ (defun analyse-classes (package)
                                  (list class))))
                         (list-exported-symbols package)))
        (subs (make-hash-table)))
                                  (list class))))
                         (list-exported-symbols package)))
        (subs (make-hash-table)))

+    ;; CLASSES is a list of the `interesting' classes defined by (i.e., whose
+    ;; names are exported by) PACKAGE.  SUBS maps a class to those of its
+    ;; direct subclasses which are relevant to our report.
+
+    ;; Populate the SUBS table.

     (let ((done (make-hash-table)))
       (labels ((walk-up (class)
                 (unless (gethash class done)
     (let ((done (make-hash-table)))
       (labels ((walk-up (class)
                 (unless (gethash class done)


@@ -282,7 +472,12 @@ (defun analyse-classes (package)
                   (setf (gethash class done) t))))
        (dolist (class classes)
          (walk-up class))))
                   (setf (gethash class done) t))))
        (dolist (class classes)
          (walk-up class))))

+

     (labels ((walk-down (this super depth)
     (labels ((walk-down (this super depth)

+              ;; Recursively traverse the class graph from THIS, recalling
+              ;; that our parent is SUPER, and that we are DEPTH levels
+              ;; down.
+

               (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%"
                       (* 2 depth)
                       (pretty-symbol-name (class-name this) package)
               (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%"
                       (* 2 depth)
                       (pretty-symbol-name (class-name this) package)


@@ -294,9 +489,41 @@ (defun analyse-classes (package)
               (dolist (sub (sort (copy-list (gethash this subs))
                                  #'string< :key #'class-name))
                 (walk-down sub this (1+ depth)))))
               (dolist (sub (sort (copy-list (gethash this subs))
                                  #'string< :key #'class-name))
                 (walk-down sub this (1+ depth)))))

+
+      ;; Print the relevant fragment of the class graph.

       (walk-down (find-class t) nil 0))))
 
 (defmacro deep-compare ((left right) &body body)
       (walk-down (find-class t) nil 0))))
 
 (defmacro deep-compare ((left right) &body body)

+  "Helper macro for traversing two similar objects in parallel.
+
+   Specifically it's good at defining complex structural ordering relations,
+   answering the question: is the LEFT value strictly less than the RIGHT
+   value.
+
+   Evaluate the BODY forms, maintaining a pair of `cursors', initially at the
+   LEFT and RIGHT values.
+
+   The following local macros are defined to do useful things.
+
+     * (focus EXPR . BODY) -- EXPR is an expression in terms of `it': advance
+       each of the cursors to the result of evaluating this expression, with
+       `it' bound to the current cursor value, and evaluate the BODY in the
+       resulting environment.
+
+     * (update EXPR) -- as `focus', but mutate the cursors rather than
+       binding them.
+
+     * (compare EXPR) -- EXPR is an expression in terms of the literal
+       symbols `left' and `right', which returns non-nil if it thinks `left'
+       is (strictly) less than `right' in some sense: evaluate this both ways
+       round, and return if LEFT is determined to be less than or greater
+       than RIGHT.
+
+     * (typesw (TYPE . BODY)*) -- process each clause in turn: if the left
+       cursor value has TYPE, but the right does not, then LEFT is less than
+       RIGHT; if the right cursor value has TYPE but the left does not, then
+       LEFT is greater than RIGHT; otherwise, evaluate BODY."
+

   (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-"))
        (l (gensym "LEFT-")) (r (gensym "RIGHT-")))
     `(macrolet ((focus (expr &body body)
   (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-"))
        (l (gensym "LEFT-")) (r (gensym "RIGHT-")))
     `(macrolet ((focus (expr &body body)


@@ -334,44 +561,94 @@ (defmacro deep-compare ((left right) &body body)
           ,@body)))))
 
 (defun order-specializers (la lb)
           ,@body)))))
 
 (defun order-specializers (la lb)

+  "Return whether specializers LA should be sorted before LB."
+

   (deep-compare (la lb)
   (deep-compare (la lb)

-    (loop (typesw (null (return nil)))
-         (focus (car it)
-           (typesw (eql-specializer
-                    (focus (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)))))
+    ;; Iterate over the two lists.  The cursors advance down the spine, and
+    ;; we focus on each car in turn.
+
+    (loop
+      (typesw (null (return nil)))
+      ;; If one list reaches the end, then it's lesser; if both, they're
+      ;; equal.
+
+      (focus (car it)
+       ;; Examine the two specializers at this position.
+
+       (typesw (eql-specializer
+                (focus (eql-specializer-object it)
+                  ;; We found an `eql' specializer.  Compare the objects.
+
+                  (typesw (keyword
+                           ;; Keywords compare by name.
+
+                           (compare (string< left right)))
+
+                          (symbol
+                           ;; Symbols compare by package and name.
+
+                           (focus (package-name (symbol-package it))
+                             (compare (string< left right)))
+                           (compare (string< left right)))
+
+                          (t
+                           ;; Compare two other objects by comparing their
+                           ;; string representations.
+
+                           (focus (with-output-to-string (out)
+                                    (prin1 it out)
+                                    (write-char #\nul))
+                             (compare (string< left right)))))))
+
+               (class
+                ;; We found a class,   Compare the class names.
+                (focus (class-name it)
+                  (focus (package-name (symbol-package it))
+                    (compare (string< left right)))
+                  (compare (string< left right))))
+
+               (t
+                ;; We found some other kind of specializer that we don't
+                ;; understand.
+
+                (error "unexpected things"))))
+
+      ;; No joy with that pair of specializers: try the next.
+      (update (cdr it)))))

 
 (defun analyse-generic-functions (package)
 
 (defun analyse-generic-functions (package)

+  "Print a report of the generic functions and methods defined by PACKAGE."
+
+  ;; Canonify package into a package object.

   (setf package (find-package package))
   (setf package (find-package package))

+

   (flet ((function-name-core (name)
   (flet ((function-name-core (name)

+          ;; Return the underlying name for a function NAME.  Specifically,
+          ;; if NAME is (setf THING) then the core is THING; if NAME is a
+          ;; symbol then the core is simply NAME; otherwise we're confused.
+          ;; Return a second value to say whether we got the job done.
+

           (typecase name
             (symbol (values name t))
             ((cons (eql setf) t) (values (cadr name) t))
             (t (values nil nil)))))
           (typecase name
             (symbol (values name t))
             ((cons (eql setf) t) (values (cadr name) t))
             (t (values nil nil)))))

+

     (let ((methods (make-hash-table))
          (functions (make-hash-table))
          (externs (make-hash-table)))
     (let ((methods (make-hash-table))
          (functions (make-hash-table))
          (externs (make-hash-table)))

+      ;; EXTERNS is a set of the symbols exported by PACKAGE.  FUNCTIONS and
+      ;; METHODS are sets of generic function names (not cores), and method
+      ;; objects, which we've decided are worth reporting.
+
+      ;; Collect the EXTERNS symbols.

       (dolist (symbol (list-exported-symbols package))
        (setf (gethash symbol externs) t))
       (dolist (symbol (list-exported-symbols package))
        (setf (gethash symbol externs) t))

+
+      ;; Collect the FUNCTIONS and METHODS.

       (dolist (symbol (list-exported-symbols package))
       (dolist (symbol (list-exported-symbols package))

+
+       ;; Mark the generic functions and `setf'-functions named by exported
+       ;; symbols as interesting, along with all of their methods.

        (flet ((dofunc (func)
                 (when (typep func 'generic-function)
                   (setf (gethash func functions) t)
        (flet ((dofunc (func)
                 (when (typep func 'generic-function)
                   (setf (gethash func functions) t)


@@ -379,11 +656,14 @@ (defun analyse-generic-functions (package)
                     (setf (gethash method methods) t)))))
          (dofunc (and (fboundp symbol) (fdefinition symbol)))
          (dofunc (ignore-errors (fdefinition (list 'setf symbol)))))
                     (setf (gethash method methods) t)))))
          (dofunc (and (fboundp symbol) (fdefinition symbol)))
          (dofunc (ignore-errors (fdefinition (list 'setf symbol)))))

+
+       ;; For symbols whose home package is PACKAGE, and which name a class,
+       ;; also collect functions with methods specialized on that class, and
+       ;; (only) the specialized methods.

        (when (eq (symbol-package symbol) package)
          (let ((class (find-class symbol nil)))
            (when class
        (when (eq (symbol-package symbol) package)
          (let ((class (find-class symbol nil)))
            (when class

-             (dolist
-                 (func (specializer-direct-generic-functions class))
+             (dolist (func (specializer-direct-generic-functions class))

                (multiple-value-bind (name knownp)
                    (function-name-core (generic-function-name func))
                  (when (and knownp
                (multiple-value-bind (name knownp)
                    (function-name-core (generic-function-name func))
                  (when (and knownp


@@ -392,20 +672,30 @@ (defun analyse-generic-functions (package)
                    (setf (gethash func functions) t)
                    (dolist (method (specializer-direct-methods class))
                      (setf (gethash method methods) t)))))))))
                    (setf (gethash func functions) t)
                    (dolist (method (specializer-direct-methods class))
                      (setf (gethash method methods) t)))))))))

+
+      ;; Print the report.

       (let ((funclist nil))
       (let ((funclist nil))

+
+       ;; Gather the functions we've decided are interesting, and sort them.

        (maphash (lambda (func value)
                   (declare (ignore value))
                   (push func funclist))
                 functions)
        (setf funclist (sort funclist
                             (lambda (a b)
        (maphash (lambda (func value)
                   (declare (ignore value))
                   (push func funclist))
                 functions)
        (setf funclist (sort funclist
                             (lambda (a b)

+                              ;; Sort by the core symbols, and order the
+                              ;; `setf' variant after the base version.

                               (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 #'generic-function-name))
                               (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 #'generic-function-name))

+

        (dolist (function funclist)
        (dolist (function funclist)

+         ;; Print out each function in turn.
+
+         ;; Print the header line.

          (let ((name (generic-function-name function)))
            (etypecase name
              (symbol
          (let ((name (generic-function-name function)))
            (etypecase name
              (symbol


@@ -413,10 +703,13 @@ (defun analyse-generic-functions (package)
              ((cons (eql setf) t)
               (format t "(setf ~A)~%"
                       (pretty-symbol-name (cadr name) package)))))
              ((cons (eql setf) t)
               (format t "(setf ~A)~%"
                       (pretty-symbol-name (cadr name) package)))))

+
+         ;; Report on the function's (interesting) methods.

          (dolist (method (sort (copy-list
                                 (generic-function-methods function))
                                #'order-specializers
                                :key #'method-specializers))
          (dolist (method (sort (copy-list
                                 (generic-function-methods function))
                                #'order-specializers
                                :key #'method-specializers))

+

            (when (gethash method methods)
              (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%"
                      (mapcar
            (when (gethash method methods)
              (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%"
                      (mapcar


@@ -436,13 +729,30 @@ (defun analyse-generic-functions (package)
                      (method-qualifiers method)))))))))
 
 (defun check-slot-names (package)
                      (method-qualifiers method)))))))))
 
 (defun check-slot-names (package)

+  "Check that PACKAGE defines no slots whose names are exported symbols.
+
+   This acts to discourage the use of `slot-value' by external callers.
+   Return two values:
+
+     * an alist of entries (CLASS . SLOT-NAMES), listing for each offending
+       class, whose of its slot names which are either (a) external or (b)
+       from a foreign package; and
+
+     * the distilled list of bad SLOT-NAMES."
+
+  ;; Canonify PACKAGE into a package objects.

   (setf package (find-package package))
   (setf package (find-package package))

+

   (let* ((symbols (list-all-symbols package))
   (let* ((symbols (list-all-symbols package))

+
+        ;; Determine all of the named classes.

         (classes (mapcan (lambda (symbol)
                            (when (eq (symbol-package symbol) package)
                              (let ((class (find-class symbol nil)))
                                (and class (list class)))))
                          symbols))
         (classes (mapcan (lambda (symbol)
                            (when (eq (symbol-package symbol) package)
                              (let ((class (find-class symbol nil)))
                                (and class (list class)))))
                          symbols))

+
+        ;; Build the main alist of offending classes and slots.

         (offenders (mapcan
                     (lambda (class)
                       (let* ((slot-names
         (offenders (mapcan
                     (lambda (class)
                       (let* ((slot-names


@@ -460,13 +770,22 @@ (defun check-slot-names (package)
                              (list (cons (class-name class)
                                          exported)))))
                            classes))
                              (list (cons (class-name class)
                                          exported)))))
                            classes))

+
+        ;; Distill the bad slot names into a separate list.

         (bad-words (remove-duplicates (mapcan (lambda (list)
                                                 (copy-list (cdr list)))
                                               offenders))))
         (bad-words (remove-duplicates (mapcan (lambda (list)
                                                 (copy-list (cdr list)))
                                               offenders))))

+
+    ;; Done.

     (values offenders bad-words)))
 
 (defun report-symbols (paths package)
     (values offenders bad-words)))
 
 (defun report-symbols (paths package)

+  "Report on all of the symbols defined in PACKAGE by the files in PATHS."
+
+  ;; Canonify PACKAGE to a package object.

   (setf package (find-package package))
   (setf package (find-package package))

+
+  ;; Print the breakdown of symbols by source file, with their purposes.

   (format t "~A~%Package `~(~A~)'~2%"
          (make-string 77 :initial-element #\-)
          (package-name package))
   (format t "~A~%Package `~(~A~)'~2%"
          (make-string 77 :initial-element #\-)
          (package-name package))


@@ -481,6 +800,8 @@ (defun report-symbols (paths package)
                  (pretty-symbol-name sym package)
                  (cdr def))))
       (terpri)))
                  (pretty-symbol-name sym package)
                  (cdr def))))
       (terpri)))

+
+  ;; Report on leaked slot names, if any are exported or foreign.

   (multiple-value-bind (alist names) (check-slot-names package)
     (when names
       (format t "Leaked slot names: ~{~A~^, ~}~%"
   (multiple-value-bind (alist names) (check-slot-names package)
     (when names
       (format t "Leaked slot names: ~{~A~^, ~}~%"


@@ -492,6 +813,8 @@ (defun report-symbols (paths package)
                (mapcar (lambda (name) (pretty-symbol-name name package))
                        (cdr assoc))))
       (terpri)))
                (mapcar (lambda (name) (pretty-symbol-name name package))
                        (cdr assoc))))
       (terpri)))

+
+  ;; Report on classes and generic functions.

   (format t "Classes:~%")
   (analyse-classes package)
   (terpri)
   (format t "Classes:~%")
   (analyse-classes package)
   (terpri)


@@ -501,17 +824,31 @@ (defun report-symbols (paths package)
 
 (export 'report-project-symbols)
 (defun report-project-symbols ()
 
 (export 'report-project-symbols)
 (defun report-project-symbols ()

+  "Write to `*standard-output*' a report on all of the symbols in Sod."
+

   (labels ((components (comp)
   (labels ((components (comp)

+            ;; Return the subcomponents of an ASDF component.
+

             (asdf:component-children comp))
             (asdf:component-children comp))

+

           (files (comp)
           (files (comp)

+            ;; Return a list of files needed by an ASDF component.
+

             (sort (remove-if-not (lambda (comp)
                                    (typep comp 'asdf:cl-source-file))
                                  (components comp))
                   #'string< :key #'asdf:component-name))
             (sort (remove-if-not (lambda (comp)
                                    (typep comp 'asdf:cl-source-file))
                                  (components comp))
                   #'string< :key #'asdf:component-name))

+

           (by-name (comp name)
           (by-name (comp name)

+            ;; Find the subcomponent called NAME of an ASDF component.
+

             (gethash name (asdf:component-children-by-name comp)))
             (gethash name (asdf:component-children-by-name comp)))

+

           (file-name (file)
           (file-name (file)

+            ;; Return the pathname of an ASDF file component.
+

             (slot-value file 'asdf/component:absolute-pathname)))
             (slot-value file 'asdf/component:absolute-pathname)))

+

   (let* ((sod (asdf:find-system "sod"))
         (parser-files (files (by-name sod "parser")))
         (utilities (by-name sod "utilities"))
   (let* ((sod (asdf:find-system "sod"))
         (parser-files (files (by-name sod "parser")))
         (utilities (by-name sod "utilities"))


@@ -519,13 +856,19 @@ (defun report-project-symbols ()
         (optparse (by-name sod "optparse"))
         (frontend (by-name sod-frontend "frontend"))
         (sod-files (set-difference (files sod) (list optparse utilities))))
         (optparse (by-name sod "optparse"))
         (frontend (by-name sod-frontend "frontend"))
         (sod-files (set-difference (files sod) (list optparse utilities))))

+
+    ;; Report on the various major pieces of the project.

     (report-symbols (mapcar #'file-name sod-files) "SOD")
     (report-symbols (mapcar #'file-name (list frontend)) "SOD-FRONTEND")
     (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER")
     (report-symbols (mapcar #'file-name (list optparse)) "OPTPARSE")
     (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES"))))
 
     (report-symbols (mapcar #'file-name sod-files) "SOD")
     (report-symbols (mapcar #'file-name (list frontend)) "SOD-FRONTEND")
     (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER")
     (report-symbols (mapcar #'file-name (list optparse)) "OPTPARSE")
     (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES"))))
 

+;;;--------------------------------------------------------------------------
+;;; Command-line use.
+

 (defun main ()
 (defun main ()

+  "Write a report to `doc/SYMBOLS'."

   (with-open-file (*standard-output* #p"doc/SYMBOLS"
                   :direction :output
                   :if-exists :supersede
   (with-open-file (*standard-output* #p"doc/SYMBOLS"
                   :direction :output
                   :if-exists :supersede


@@ -533,3 +876,5 @@ (defun main ()
     (report-project-symbols)))
 
 #+interactive (main)
     (report-project-symbols)))
 
 #+interactive (main)

+
+;;;----- That's all, folks --------------------------------------------------