From: Mark Wooding Date: Sun, 30 Aug 2015 09:58:38 +0000 (+0100) Subject: doc/list-exports.lisp: Some sketchy code to report on exported symbols. X-Git-Url: https://git.distorted.org.uk/~mdw/sod/commitdiff_plain/097d5a3ebbadefec2471e0046ab62a312b459934 doc/list-exports.lisp: Some sketchy code to report on exported symbols. Currently produces a list with category indications, and a class hierarchy. Useful for preparing documentation. --- diff --git a/.gitignore b/.gitignore index 1abd9a1..0bf9e54 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ Makefile.in /autom4te.cache/ /config/ /configure +/doc/SYMBOLS diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp new file mode 100644 index 0000000..c7086ca --- /dev/null +++ b/doc/list-exports.lisp @@ -0,0 +1,220 @@ +(defun symbolicate (&rest things) + (intern (apply #'concatenate 'string (mapcar #'string things)))) + +(defun incomprehensible-form (head tail) + (format *error-output* ";; incomprehensible: ~S~%" (cons head tail))) + +(defgeneric form-list-exports (head tail) + (:method (head tail) + (declare (ignore head tail)) + nil)) + +(defmethod form-list-exports ((head (eql 'export)) tail) + (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 'definst)) tail) + (destructuring-bind (code (streamvar &key export) args &body body) tail + (declare (ignore streamvar args body)) + (and export + (list (symbolicate code '-inst) + (symbolicate 'make- code '-inst))))) + +(defmethod form-list-exports ((head (eql 'define-tagged-type)) tail) + (destructuring-bind (kind what) tail + (declare (ignore what)) + (list kind + (symbolicate 'c- kind '-type) + (symbolicate 'make- kind '-type)))) + +(defmethod form-list-exports ((head (eql 'macrolet)) tail) + (mapcan #'form-exports (cdr tail))) + +(defmethod form-list-exports ((head (eql 'progn)) tail) + (mapcan #'form-exports tail)) + +(defgeneric form-exports (form) + (:method (form) nil) + (:method ((form cons)) (form-list-exports (car form) (cdr form)))) + +(defgeneric list-exports (thing)) + +(defmethod list-exports ((stream stream)) + (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)) + (mapcar (lambda (each) + (cons each (with-open-file (stream each) (list-exports stream)))) + (directory (merge-pathnames path #p"*.lisp")))) + +(defmethod list-exports ((path string)) + (list-exports (pathname path))) + +(defun list-exported-symbols (package) + (sort (loop for s being the external-symbols of package collect s) + #'string< :key #'symbol-name)) + +(defun find-symbol-homes (paths package) + (let* ((symbols (list-exported-symbols package)) + (exports-alist (mapcan #'list-exports paths)) + (homes (make-hash-table :test #'equal))) + (dolist (assoc exports-alist) + (let ((home (car assoc))) + (dolist (symbol (cdr assoc)) + (let ((name (symbol-name symbol))) + (unless (find-symbol name package) + (format *error-output* ";; unexported: ~S~%" symbol)) + (setf (gethash name homes) home))))) + (dolist (symbol symbols) + (unless (gethash (symbol-name symbol) homes) + (format *error-output* ";; mysterious: ~S~%" symbol))) + exports-alist)) + +(defun boring-setf-expansion-p (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) + (some (lambda (method) + (let ((spec (nth arg (sb-mop:method-specializers method)))) + (and (typep spec 'sb-mop:eql-specializer) + (eql (sb-mop:eql-specializer-object spec) what)))) + (sb-mop:generic-function-methods func))) + +(defun categorize (symbol) + (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) + (when (or ;;(not (boring-setf-expansion-p symbol)) + (ignore-errors (fdefinition (list 'setf symbol)))) + (push :setf things))) + (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)) + (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))) + (cons home (mapcar (lambda (symbol) + (cons symbol (categorize symbol))) + symbols)))) + + (mapcan #'list-exports paths))) + +(defun best-package-name (package) + (car (sort (cons (package-name package) + (copy-list (package-nicknames package))) + #'< :key #'length))) + +(defvar charbuf-size 0) + +(defun pretty-symbol-name (symbol package) + (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) + exportp (symbol-name symbol)))) + +(defun analyse-classes (package) + (setf package (find-package package)) + (let ((classes (mapcan (lambda (symbol) + (let ((class (find-class symbol nil))) + (and class + (typep class '(or standard-class + structure-class)) + (list class)))) + (list-exported-symbols package))) + (subs (make-hash-table))) + (let ((done (make-hash-table))) + (labels ((walk-up (class) + (unless (gethash class done) + (dolist (super (sb-mop: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) + (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 + (sb-mop:class-direct-superclasses this)))) + (dolist (sub (reverse (gethash this subs))) + (walk-down sub this (1+ depth))))) + (walk-down (find-class t) nil 0)))) + +(defun report-symbols (paths package) + (setf package (find-package package)) + (format t "~A~%Package `~(~A~)'~2%" + (make-string 77 :initial-element #\-) + (package-name package)) + (dolist (assoc (categorize-symbols paths package)) + (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))) + (analyse-classes package) + (terpri)) + +(defun report-project-symbols () + (labels ((components (comp) + (slot-value comp 'asdf::components)) + (files (comp) + (remove-if-not (lambda (comp) + (typep comp 'asdf:cl-source-file)) + (components comp))) + (by-name (comp name) + (find name (components comp) + :test #'string= :key #'asdf:component-name)) + (file-name (file) + (slot-value file 'asdf::absolute-pathname))) + (let* ((sod (asdf:find-system "sod")) + (parser-files (files (by-name sod "parser"))) + (utilities (by-name sod "utilities")) + (sod-files (remove utilities (files sod)))) + (report-symbols (mapcar #'file-name sod-files) "SOD") + (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER") + (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES"))))