@@@ mess!

[sod] / doc / list-exports

#! /usr/bin/runlisp -Lsbcl,cmucl
;;; -*-lisp-*-

(cl:defpackage #:sod-exports
  (:use #:common-lisp
	#+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)
  (asdf:clear-configuration)
  (mapc #'asdf:load-system '(:sod :sod/frontend)))

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

(defun symbolicate (&rest things)
  "Concatenate the THINGS and turn the result into a symbol."
  (intern (apply #'concatenate 'string (mapcar #'string things))))

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

(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)
  (:documentation
   "Return a list of symbols exported by the form (HEAD . TAIL).

   This is called from `form-exports' below.")
  (:method (head tail)
    "By default, a form exports nothing."
    (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 ((thing (cadr symbols)))
	  (if (atom thing) (list thing) thing))
	(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))

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

		(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)
			   ;; 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)
			   ;; Convert ARG name into the `inst-ARG' accessor.
			   (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)
				(char= (char (symbol-name arg) 0) #\&))
			  do (setf state arg)
			else if (member state '(:mandatory &rest))
			  collect (instify arg)
			else if (member state '(&optional &aux))
			  collect (instify (dig arg '(0)))
			else if (eq state '&key)
			  collect (instify (dig arg '(0 1)))
			else
			  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
	  (symbolicate 'c- kind '-type)
	  (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))))
      (and export
	   (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))))
      (and export
	   (list* (symbolicate 'c-type- (car names)) names)))))

(defmethod form-list-exports
    ((head (eql 'sod::define-cross-product-types)) tail)
  "Return the symbols exported by a `define-cross-product-types' form.

   This is a scummy internal macro in `c-types-impl.lisp'.  The syntax is

	(define-cross-product-types PIECES)

   Each piece can be a list of strings, or an atomic string (which is
   equivalent to a list containing just that string).  For each string formed
   by concatenating one element from each list in order, define a C type with
   that name; the Lisp name is constructed by translating the letters to
   uppercase and replacing underscores by hyphens.  For each such name,
   export `NAME' and `c-type-NAME'."

  ;; Huh.  I feel a hack coming on.
  (mapcar (lambda (row)
	    (intern (with-output-to-string (out)
		      (dolist (s row)
			(dotimes (i (length s))
			  (let ((ch (char s i)))
			    (if (char= ch #\_)
				(write-char #\- out)
				(write-char (char-upcase ch) out))))))))
	  (reduce (lambda (piece tails)
		    (mapcan (lambda (tail)
			      (mapcar (lambda (head)
					(cons head tail))
				      (if (listp piece) piece
					  (list piece))))
			    tails))
		  (cons '("" "c-type_") tail)
		  :from-end t
		  :initial-value '(nil))))


(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)
  "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)
  "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)
  (:documentation
   "Return a list of symbols exported by a toplevel FORM.")
  (:method (form) nil)
  (:method ((form cons)) (form-list-exports (car form) (cdr form))))

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

(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))
  "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))
  "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)
  "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)
  "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))
    (sort (loop for s being the symbols of package
		when (or (not (exported-symbol-p s))
			 (gethash s externs))
		  collect s)
	  #'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)))

    ;; 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))
	  (let ((name (symbol-name symbol)))
	    (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)))

    ;; We're done.
    exports-alist))

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

(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))
    (and (consp store)
	 (eq (car store) 'funcall)
	 (consp (cdr store)) (consp (cadr store))
	 (eq (caadr store) 'function)
	 (let ((func (cadadr store)))
	   (and (consp func) (consp (cdr func))
		(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)
		 (eql (eql-specializer-object spec) what))))
	(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 (or (boundp symbol) (documentation symbol 'variable))
      (push (if (constantp symbol) :constant :variable) things))
    (when (or (fboundp symbol) (documentation symbol 'function))
      (push (cond ((macro-function symbol) :macro)
		  ((typep (fdefinition symbol) 'generic-function)
		   :generic)
		  (t :function))
	    things)
      (etypecase (ignore-errors (fdefinition (list 'setf symbol)))
	(generic-function (push :setf-generic things))
	(function (push :setf-function things))
	(null)))
    (when (or (find-class symbol nil) (documentation symbol 'type))
      (push (if (find-class symbol nil) :class :type) things))
    (when (specialized-on-p #'sod:expand-c-type-spec 0 symbol)
      (push :c-type-spec things))
    (when (specialized-on-p #'sod:expand-c-type-form 0 symbol)
      (push :c-type-form things))
    (when (specialized-on-p #'sod:expand-c-storage-specifier 0 symbol)
      (push :c-storage-spec things))
    (when (specialized-on-p #'sod:expand-c-storage-specifier-form 0 symbol)
      (push :c-storage-form things))
    (when (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol)
      (push :parser-spec things))
    (when (specialized-on-p #'sod-parser:expand-parser-form 1 symbol)
      (push :parser-form things))
    (when (get symbol 'optparse::opthandler-function)
      (push :opthandler things))
    (when (get symbol 'optparse::optmacro-function)
      (push :optmacro things))
    (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
			    (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))))
	  (find-symbol-homes paths package)))

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

(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.
  (loop with best = (package-name package)
	with best-length = (length best)
	for name in (package-nicknames package)
	for name-length = (length name)
	when (< name-length best-length)
	  do (setf best name
		   best-length name-length)
	finally (return best)))

(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 (eq sym symbol)
	      (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)
		   (member char '(#\% #\+ #\- #\* #\/ #\= #\[ #\] #\?))))
	     name)
      (string-downcase name)
      (with-output-to-string (out)
	(write-char #\| out)
	(map nil (lambda (char)
		   (when (or (char= char #\|)
			     (char= char #\\))
		     (write-char #\\ out))
		   (write-char char out))
	     name)
	(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"
	    (and exportp (eq pkg package))
	    (cond ((keywordp symbol) "")
		  ((eq pkg nil) "#")
		  (t (downcase-or-escape (best-package-name pkg))))
	    (or exportp (null pkg))
	    (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)
  "Print a report on the classes defined by PACKAGE."

  ;; Canonify PACKAGE into a package object.
  (setf package (find-package package))

  (let ((classes (mapcan (lambda (symbol)
			   (let ((class (find-class symbol nil)))
			     (and class
				  (typep class 'interesting-class)
				  (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)
		   (dolist (super (class-direct-superclasses class))
		     (push class (gethash super subs))
		     (walk-up super))
		   (setf (gethash class done) t))))
	(dolist (class classes)
	  (walk-up class))))

    (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)
		       (mapcar (lambda (class)
				 (pretty-symbol-name (class-name class)
						     package))
			       (remove super
				       (class-direct-superclasses this))))
	       (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)
  "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)
		  `(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)
  "Return whether specializers LA should be sorted before LB."

  (deep-compare (la lb)
    ;; 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)
  "Print a report of the generic functions and methods defined by PACKAGE."

  ;; Canonify package into a package object.
  (setf package (find-package package))

  (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)))))

    (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))

      ;; Collect the FUNCTIONS and METHODS.
      (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)
		   (dolist (method (generic-function-methods func))
		     (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
	      (dolist (func (specializer-direct-generic-functions class))
		(multiple-value-bind (name knownp)
		    (function-name-core (generic-function-name func))
		  (when (and knownp
			     (or (not (eq (symbol-package name) package))
				 (gethash name externs)))
		    (setf (gethash func functions) t)
		    (dolist (method (specializer-direct-methods class))
		      (setf (gethash method methods) t)))))))))

      ;; Print the report.
      (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)
			       ;; 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))

	(dolist (function funclist)
	  ;; Print out each function in turn.

	  ;; Print the header line.
	  (let ((name (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)))))

	  ;; Report on the function's (interesting) methods.
	  (dolist (method (sort (copy-list
				 (generic-function-methods function))
				#'order-specializers
				:key #'method-specializers))

	    (when (gethash method methods)
	      (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%"
		      (mapcar
		       (lambda (spec)
			 (etypecase spec
			   (class
			    (let ((name (class-name spec)))
			      (if (eq name t) "t"
				  (pretty-symbol-name name package))))
			   (eql-specializer
			    (let ((obj (eql-specializer-object spec)))
			      (format nil "(eql ~A)"
				      (if (symbolp obj)
					  (pretty-symbol-name obj package)
					  obj))))))
		       (method-specializers method))
		      (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))

  (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))

	 ;; Build the main alist of offending classes and slots.
	 (offenders (mapcan
		     (lambda (class)
		       (let* ((slot-names
			       (mapcar #'slot-definition-name
				       (class-direct-slots class)))
			      (exported (remove-if
					 (lambda (sym)
					   (or (not (symbol-package sym))
					       (and (not (exported-symbol-p
							  sym))
						    (eq (symbol-package sym)
							package))))
					 slot-names)))
			 (and exported
			      (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))))

    ;; Done.
    (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))

  ;; 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))
  (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))
	(let ((sym (car def)))
	  (format t "  ~A~@[~48T~{~(~A~)~^ ~}~]~%"
		  (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~^, ~}~%"
	      (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)))

  ;; Report on classes and generic functions.
  (format t "Classes:~%")
  (analyse-classes package)
  (terpri)
  (format t "Methods:~%")
  (analyse-generic-functions package)
  (terpri))

(export 'report-project-symbols)
(defun report-project-symbols ()
  "Write to `*standard-output*' a report on all of the symbols in Sod."

  (labels ((components (comp)
	     ;; Return the subcomponents of an ASDF component.

	     (asdf:component-children 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))

	   (by-name (comp name)
	     ;; Find the subcomponent called NAME of an ASDF component.

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

	   (file-name (file)
	     ;; Return the pathname of an ASDF file component.

	     (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"))
	 (sod-frontend (asdf:find-system "sod/frontend"))
	 (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"))))

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

(defun main ()
  "Write a report to *standard-output*."
  (report-project-symbols))

#+runlisp-script (main)

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