| 1 | (defun symbolicate (&rest things) |
| 2 | (intern (apply #'concatenate 'string (mapcar #'string things)))) |
| 3 | |
| 4 | (defun incomprehensible-form (head tail) |
| 5 | (format *error-output* ";; incomprehensible: ~S~%" (cons head tail))) |
| 6 | |
| 7 | (defgeneric form-list-exports (head tail) |
| 8 | (:method (head tail) |
| 9 | (declare (ignore head tail)) |
| 10 | nil)) |
| 11 | |
| 12 | (defmethod form-list-exports ((head (eql 'export)) tail) |
| 13 | (let ((symbols (car tail))) |
| 14 | (if (and (consp symbols) |
| 15 | (eq (car symbols) 'quote)) |
| 16 | (let ((thing (cadr symbols))) |
| 17 | (if (atom thing) (list thing) thing)) |
| 18 | (incomprehensible-form head tail)))) |
| 19 | |
| 20 | (defmethod form-list-exports ((head (eql 'definst)) tail) |
| 21 | (destructuring-bind (code (streamvar &key export) args &body body) tail |
| 22 | (declare (ignore streamvar args body)) |
| 23 | (and export |
| 24 | (list (symbolicate code '-inst) |
| 25 | (symbolicate 'make- code '-inst))))) |
| 26 | |
| 27 | (defmethod form-list-exports ((head (eql 'define-tagged-type)) tail) |
| 28 | (destructuring-bind (kind what) tail |
| 29 | (declare (ignore what)) |
| 30 | (list kind |
| 31 | (symbolicate 'c- kind '-type) |
| 32 | (symbolicate 'make- kind '-type)))) |
| 33 | |
| 34 | (defmethod form-list-exports ((head (eql 'macrolet)) tail) |
| 35 | (mapcan #'form-exports (cdr tail))) |
| 36 | |
| 37 | (defmethod form-list-exports ((head (eql 'progn)) tail) |
| 38 | (mapcan #'form-exports tail)) |
| 39 | |
| 40 | (defgeneric form-exports (form) |
| 41 | (:method (form) nil) |
| 42 | (:method ((form cons)) (form-list-exports (car form) (cdr form)))) |
| 43 | |
| 44 | (defgeneric list-exports (thing)) |
| 45 | |
| 46 | (defmethod list-exports ((stream stream)) |
| 47 | (loop with eof = '#:eof |
| 48 | for form = (read stream nil eof) |
| 49 | until (eq form eof) |
| 50 | when (consp form) nconc (form-exports form))) |
| 51 | |
| 52 | (defmethod list-exports ((path pathname)) |
| 53 | (mapcar (lambda (each) |
| 54 | (cons each (with-open-file (stream each) (list-exports stream)))) |
| 55 | (directory (merge-pathnames path #p"*.lisp")))) |
| 56 | |
| 57 | (defmethod list-exports ((path string)) |
| 58 | (list-exports (pathname path))) |
| 59 | |
| 60 | (defun list-exported-symbols (package) |
| 61 | (sort (loop for s being the external-symbols of package collect s) |
| 62 | #'string< :key #'symbol-name)) |
| 63 | |
| 64 | (defun find-symbol-homes (paths package) |
| 65 | (let* ((symbols (list-exported-symbols package)) |
| 66 | (exports-alist (mapcan #'list-exports paths)) |
| 67 | (homes (make-hash-table :test #'equal))) |
| 68 | (dolist (assoc exports-alist) |
| 69 | (let ((home (car assoc))) |
| 70 | (dolist (symbol (cdr assoc)) |
| 71 | (let ((name (symbol-name symbol))) |
| 72 | (unless (find-symbol name package) |
| 73 | (format *error-output* ";; unexported: ~S~%" symbol)) |
| 74 | (setf (gethash name homes) home))))) |
| 75 | (dolist (symbol symbols) |
| 76 | (unless (gethash (symbol-name symbol) homes) |
| 77 | (format *error-output* ";; mysterious: ~S~%" symbol))) |
| 78 | exports-alist)) |
| 79 | |
| 80 | (defun boring-setf-expansion-p (symbol) |
| 81 | (multiple-value-bind (temps args stores store fetch) |
| 82 | (ignore-errors (get-setf-expansion (list symbol))) |
| 83 | (declare (ignore temps args stores fetch)) |
| 84 | (and (consp store) |
| 85 | (eq (car store) 'funcall) |
| 86 | (consp (cdr store)) (consp (cadr store)) |
| 87 | (eq (caadr store) 'function) |
| 88 | (let ((func (cadadr store))) |
| 89 | (and (consp func) (consp (cdr func)) |
| 90 | (eq (car func) 'setf)))))) |
| 91 | |
| 92 | (defun specialized-on-p (func arg what) |
| 93 | (some (lambda (method) |
| 94 | (let ((spec (nth arg (sb-mop:method-specializers method)))) |
| 95 | (and (typep spec 'sb-mop:eql-specializer) |
| 96 | (eql (sb-mop:eql-specializer-object spec) what)))) |
| 97 | (sb-mop:generic-function-methods func))) |
| 98 | |
| 99 | (defun categorize (symbol) |
| 100 | (let ((things nil)) |
| 101 | (when (boundp symbol) |
| 102 | (push (if (constantp symbol) :constant :variable) things)) |
| 103 | (when (fboundp symbol) |
| 104 | (push (cond ((macro-function symbol) :macro) |
| 105 | ((typep (fdefinition symbol) 'generic-function) |
| 106 | :generic) |
| 107 | (t :function)) |
| 108 | things) |
| 109 | (when (or ;;(not (boring-setf-expansion-p symbol)) |
| 110 | (ignore-errors (fdefinition (list 'setf symbol)))) |
| 111 | (push :setf things))) |
| 112 | (when (find-class symbol nil) |
| 113 | (push :class things)) |
| 114 | (when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol) |
| 115 | (specialized-on-p #'sod:expand-c-type-form 0 symbol)) |
| 116 | (push :c-type things)) |
| 117 | (when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol) |
| 118 | (specialized-on-p #'sod-parser:expand-parser-form 1 symbol)) |
| 119 | (push :parser things)) |
| 120 | (nreverse things))) |
| 121 | |
| 122 | (defun categorize-symbols (paths package) |
| 123 | (mapcar (lambda (assoc) |
| 124 | (let ((home (car assoc)) |
| 125 | (symbols (sort (mapcan (lambda (sym) |
| 126 | (multiple-value-bind |
| 127 | (symbol foundp) |
| 128 | (find-symbol (symbol-name sym) |
| 129 | package) |
| 130 | (and foundp (list symbol)))) |
| 131 | (cdr assoc)) |
| 132 | #'string< :key #'symbol-name))) |
| 133 | (cons home (mapcar (lambda (symbol) |
| 134 | (cons symbol (categorize symbol))) |
| 135 | symbols)))) |
| 136 | |
| 137 | (mapcan #'list-exports paths))) |
| 138 | |
| 139 | (defun best-package-name (package) |
| 140 | (car (sort (cons (package-name package) |
| 141 | (copy-list (package-nicknames package))) |
| 142 | #'< :key #'length))) |
| 143 | |
| 144 | (defvar charbuf-size 0) |
| 145 | |
| 146 | (defun pretty-symbol-name (symbol package) |
| 147 | (let* ((pkg (symbol-package symbol)) |
| 148 | (exportp (member symbol (list-exported-symbols pkg)))) |
| 149 | (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)" |
| 150 | (and exportp (eq pkg package)) (best-package-name pkg) |
| 151 | exportp (symbol-name symbol)))) |
| 152 | |
| 153 | (defun analyse-classes (package) |
| 154 | (setf package (find-package package)) |
| 155 | (let ((classes (mapcan (lambda (symbol) |
| 156 | (let ((class (find-class symbol nil))) |
| 157 | (and class |
| 158 | (typep class '(or standard-class |
| 159 | structure-class)) |
| 160 | (list class)))) |
| 161 | (list-exported-symbols package))) |
| 162 | (subs (make-hash-table))) |
| 163 | (let ((done (make-hash-table))) |
| 164 | (labels ((walk-up (class) |
| 165 | (unless (gethash class done) |
| 166 | (dolist (super (sb-mop:class-direct-superclasses class)) |
| 167 | (push class (gethash super subs)) |
| 168 | (walk-up super)) |
| 169 | (setf (gethash class done) t)))) |
| 170 | (dolist (class classes) |
| 171 | (walk-up class)))) |
| 172 | (labels ((walk-down (this super depth) |
| 173 | (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%" |
| 174 | (* 2 depth) |
| 175 | (pretty-symbol-name (class-name this) package) |
| 176 | (mapcar (lambda (class) |
| 177 | (pretty-symbol-name (class-name class) |
| 178 | package)) |
| 179 | (remove super |
| 180 | (sb-mop:class-direct-superclasses this)))) |
| 181 | (dolist (sub (reverse (gethash this subs))) |
| 182 | (walk-down sub this (1+ depth))))) |
| 183 | (walk-down (find-class t) nil 0)))) |
| 184 | |
| 185 | (defun report-symbols (paths package) |
| 186 | (setf package (find-package package)) |
| 187 | (format t "~A~%Package `~(~A~)'~2%" |
| 188 | (make-string 77 :initial-element #\-) |
| 189 | (package-name package)) |
| 190 | (dolist (assoc (categorize-symbols paths package)) |
| 191 | (when (cdr assoc) |
| 192 | (format t "~A~%" (file-namestring (car assoc))) |
| 193 | (dolist (def (cdr assoc)) |
| 194 | (let ((sym (car def))) |
| 195 | (format t " ~A~@[~48T~{~(~A~)~^ ~}~]~%" |
| 196 | (pretty-symbol-name sym package) |
| 197 | (cdr def)))) |
| 198 | (terpri))) |
| 199 | (analyse-classes package) |
| 200 | (terpri)) |
| 201 | |
| 202 | (defun report-project-symbols () |
| 203 | (labels ((components (comp) |
| 204 | (slot-value comp 'asdf::components)) |
| 205 | (files (comp) |
| 206 | (remove-if-not (lambda (comp) |
| 207 | (typep comp 'asdf:cl-source-file)) |
| 208 | (components comp))) |
| 209 | (by-name (comp name) |
| 210 | (find name (components comp) |
| 211 | :test #'string= :key #'asdf:component-name)) |
| 212 | (file-name (file) |
| 213 | (slot-value file 'asdf::absolute-pathname))) |
| 214 | (let* ((sod (asdf:find-system "sod")) |
| 215 | (parser-files (files (by-name sod "parser"))) |
| 216 | (utilities (by-name sod "utilities")) |
| 217 | (sod-files (remove utilities (files sod)))) |
| 218 | (report-symbols (mapcar #'file-name sod-files) "SOD") |
| 219 | (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER") |
| 220 | (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES")))) |