X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/649798abde0fd23d517b09f0c030b266ce117c67..6198298178ae405a8d5060648a30b0db83009cfe:/doc/list-exports.lisp diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp index f4cdfab..bcbf79f 100644 --- a/doc/list-exports.lisp +++ b/doc/list-exports.lisp @@ -19,10 +19,13 @@ (defmethod form-list-exports ((head (eql 'definst)) tail) (destructuring-bind (code (streamvar &key export) args &body body) tail - (declare (ignore streamvar args body)) + (declare (ignore streamvar body)) (and export - (list (symbolicate code '-inst) - (symbolicate 'make- code '-inst))))) + (list* (symbolicate code '-inst) + (symbolicate 'make- code '-inst) + (mapcar (lambda (arg) + (symbolicate 'inst- arg)) + args))))) (defmethod form-list-exports ((head (eql 'define-tagged-type)) tail) (destructuring-bind (kind what) tail @@ -34,6 +37,9 @@ (defmethod form-list-exports ((head (eql 'macrolet)) tail) (mapcan #'form-exports (cdr tail))) +(defmethod form-list-exports ((head (eql 'eval-when)) tail) + (mapcan #'form-exports (cdr tail))) + (defmethod form-list-exports ((head (eql 'progn)) tail) (mapcan #'form-exports tail)) @@ -69,7 +75,7 @@ (let ((home (car assoc))) (dolist (symbol (cdr assoc)) (let ((name (symbol-name symbol))) - (unless (find-symbol name package) + (unless (nth-value 1 (find-symbol name package)) (format *error-output* ";; unexported: ~S~%" symbol)) (setf (gethash name homes) home))))) (dolist (symbol symbols) @@ -117,19 +123,25 @@ (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) (mapcar (lambda (assoc) (let ((home (car assoc)) - (symbols (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))) + (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)))) @@ -147,7 +159,8 @@ (let* ((pkg (symbol-package symbol)) (exportp (member symbol (list-exported-symbols pkg)))) (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)" - (and exportp (eq pkg package)) (best-package-name pkg) + (and exportp (eq pkg package)) + (if (keywordp symbol) "" (best-package-name pkg)) exportp (symbol-name symbol)))) (defun analyse-classes (package) @@ -178,10 +191,111 @@ package)) (remove super (sb-mop:class-direct-superclasses this)))) - (dolist (sub (reverse (gethash this subs))) + (dolist (sub (sort (copy-list (gethash this subs)) + #'string< :key #'class-name)) (walk-down sub this (1+ depth))))) (walk-down (find-class t) nil 0)))) +(defun analyse-generic-functions (package) + (setf package (find-package package)) + (flet ((function-name-core (name) + (etypecase name + (symbol name) + ((cons (eql setf) t) (cadr name))))) + (let ((methods (make-hash-table)) + (functions (make-hash-table)) + (externs (make-hash-table))) + (dolist (symbol (list-exported-symbols package)) + (setf (gethash symbol externs) t)) + (dolist (symbol (list-exported-symbols package)) + (flet ((dofunc (func) + (when (typep func 'generic-function) + (setf (gethash func functions) t) + (dolist (method (sb-mop:generic-function-methods func)) + (setf (gethash method methods) t))))) + (dofunc (and (fboundp symbol) (fdefinition symbol))) + (dofunc (ignore-errors (fdefinition (list 'setf symbol))))) + (when (eq (symbol-package symbol) package) + (let ((class (find-class symbol nil))) + (when class + (dolist + (func (sb-mop:specializer-direct-generic-functions class)) + (let ((name (function-name-core + (sb-mop:generic-function-name func)))) + (when (or (not (eq (symbol-package name) package)) + (gethash name externs)) + (setf (gethash func functions) t) + (dolist (method (sb-mop:specializer-direct-methods class)) + (setf (gethash method methods) t))))))))) + (let ((funclist nil)) + (maphash (lambda (func value) + (declare (ignore value)) + (push func funclist)) + functions) + (setf funclist (sort funclist + (lambda (a b) + (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 #'sb-mop:generic-function-name)) + (dolist (function funclist) + (let ((name (sb-mop: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))))) + (dolist (method (sb-mop:generic-function-methods function)) + (when (gethash method methods) + (format t "~2T~{~A~^ ~}~%" + (mapcar + (lambda (spec) + (etypecase spec + (class + (let ((name (class-name spec))) + (if (eq name t) "t" + (pretty-symbol-name name package)))) + (sb-mop:eql-specializer + (let ((obj (sb-mop:eql-specializer-object spec))) + (format nil "(eql ~A)" + (if (symbolp obj) + (pretty-symbol-name obj package) + obj)))))) + (sb-mop:method-specializers method)))))))))) + +(defun check-slot-names (package) + (setf package (find-package package)) + (let* ((symbols (list-exported-symbols package)) + (classes (mapcan (lambda (symbol) + (when (eq (symbol-package symbol) package) + (let ((class (find-class symbol nil))) + (and class (list class))))) + symbols)) + (offenders (mapcan + (lambda (class) + (let* ((slot-names + (mapcar #'sb-mop:slot-definition-name + (sb-mop:class-direct-slots class))) + (exported (remove-if-not + (lambda (sym) + (or (and (symbol-package sym) + (not (eq (symbol-package + sym) + package))) + (member sym symbols))) + slot-names))) + (and exported + (list (cons (class-name class) + exported))))) + classes)) + (bad-words (remove-duplicates (mapcan (lambda (list) + (copy-list (cdr list))) + offenders)))) + (values offenders bad-words))) + (defun report-symbols (paths package) (setf package (find-package package)) (format t "~A~%Package `~(~A~)'~2%" @@ -196,16 +310,32 @@ (pretty-symbol-name sym package) (cdr def)))) (terpri))) + (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))) + (format t "Classes:~%") (analyse-classes package) + (terpri) + (format t "Methods:~%") + (analyse-generic-functions package) (terpri)) (defun report-project-symbols () (labels ((components (comp) (slot-value comp 'asdf::components)) (files (comp) - (remove-if-not (lambda (comp) + (sort (remove-if-not (lambda (comp) (typep comp 'asdf:cl-source-file)) - (components comp))) + (components comp)) + #'string< :key #'asdf:component-name)) (by-name (comp name) (find name (components comp) :test #'string= :key #'asdf:component-name)) @@ -214,7 +344,10 @@ (let* ((sod (asdf:find-system "sod")) (parser-files (files (by-name sod "parser"))) (utilities (by-name sod "utilities")) - (sod-files (remove utilities (files sod)))) + (sod-frontend (asdf:find-system "sod-frontend")) + (optparse (by-name sod-frontend "optparse")) + (sod-files (set-difference (files sod) (list utilities)))) (report-symbols (mapcar #'file-name sod-files) "SOD") (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"))))