--- /dev/null
+#! /bin/sh
+":"; ### -*-lisp-*-
+":"; CL_SOURCE_REGISTRY=$(pwd)/build/src/:; export CL_SOURCE_REGISTRY
+":"; exec cl-launch -X -l "sbcl cmucl" -s asdf -i "(sod-exports::main)" -- "$0" "$@" || exit 1
+
+(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)
+ (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 '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 (boundp symbol)
+ (push (if (constantp symbol) :constant :variable) things))
+ (when (fboundp symbol)
+ (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 (find-class symbol nil)
+ (push :class things))
+ (when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol)
+ (specialized-on-p #'sod:expand-c-type-form 0 symbol))
+ (push :c-type things))
+ (when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol)
+ (specialized-on-p #'sod-parser:expand-parser-form 1 symbol))
+ (push :parser things))
+ (when (get symbol 'optparse::opthandler)
+ (push :opthandler things))
+ (when (get symbol 'optparse::optmacro)
+ (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 `doc/SYMBOLS'."
+ (with-open-file (*standard-output* #p"doc/SYMBOLS"
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (report-project-symbols)))
+
+#+interactive (main)
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff