1 (defun symbolicate (&rest things)
2 (intern (apply #'concatenate 'string (mapcar #'string things))))
4 (defun incomprehensible-form (head tail)
5 (format *error-output* ";; incomprehensible: ~S~%" (cons head tail)))
7 (defgeneric form-list-exports (head tail)
9 (declare (ignore head tail))
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))))
20 (defmethod form-list-exports ((head (eql 'definst)) tail)
21 (destructuring-bind (code (streamvar &key export) args &body body) tail
22 (declare (ignore streamvar body))
24 (list* (symbolicate code '-inst)
25 (symbolicate 'make- code '-inst)
27 (symbolicate 'inst- arg))
30 (defmethod form-list-exports ((head (eql 'define-tagged-type)) tail)
31 (destructuring-bind (kind what) tail
32 (declare (ignore what))
34 (symbolicate 'c- kind '-type)
35 (symbolicate 'make- kind '-type))))
37 (defmethod form-list-exports ((head (eql 'macrolet)) tail)
38 (mapcan #'form-exports (cdr tail)))
40 (defmethod form-list-exports ((head (eql 'eval-when)) tail)
41 (mapcan #'form-exports (cdr tail)))
43 (defmethod form-list-exports ((head (eql 'progn)) tail)
44 (mapcan #'form-exports tail))
46 (defgeneric form-exports (form)
48 (:method ((form cons)) (form-list-exports (car form) (cdr form))))
50 (defgeneric list-exports (thing))
52 (defmethod list-exports ((stream stream))
53 (loop with eof = '#:eof
54 for form = (read stream nil eof)
56 when (consp form) nconc (form-exports form)))
58 (defmethod list-exports ((path pathname))
59 (mapcar (lambda (each)
60 (cons each (with-open-file (stream each) (list-exports stream))))
61 (directory (merge-pathnames path #p"*.lisp"))))
63 (defmethod list-exports ((path string))
64 (list-exports (pathname path)))
66 (defun list-exported-symbols (package)
67 (sort (loop for s being the external-symbols of package collect s)
68 #'string< :key #'symbol-name))
70 (defun find-symbol-homes (paths package)
71 (let* ((symbols (list-exported-symbols package))
72 (exports-alist (mapcan #'list-exports paths))
73 (homes (make-hash-table :test #'equal)))
74 (dolist (assoc exports-alist)
75 (let ((home (car assoc)))
76 (dolist (symbol (cdr assoc))
77 (let ((name (symbol-name symbol)))
78 (unless (nth-value 1 (find-symbol name package))
79 (format *error-output* ";; unexported: ~S~%" symbol))
80 (setf (gethash name homes) home)))))
81 (dolist (symbol symbols)
82 (unless (gethash (symbol-name symbol) homes)
83 (format *error-output* ";; mysterious: ~S~%" symbol)))
86 (defun boring-setf-expansion-p (symbol)
87 (multiple-value-bind (temps args stores store fetch)
88 (ignore-errors (get-setf-expansion (list symbol)))
89 (declare (ignore temps args stores fetch))
91 (eq (car store) 'funcall)
92 (consp (cdr store)) (consp (cadr store))
93 (eq (caadr store) 'function)
94 (let ((func (cadadr store)))
95 (and (consp func) (consp (cdr func))
96 (eq (car func) 'setf))))))
98 (defun specialized-on-p (func arg what)
99 (some (lambda (method)
100 (let ((spec (nth arg (sb-mop:method-specializers method))))
101 (and (typep spec 'sb-mop:eql-specializer)
102 (eql (sb-mop:eql-specializer-object spec) what))))
103 (sb-mop:generic-function-methods func)))
105 (defun categorize (symbol)
107 (when (boundp symbol)
108 (push (if (constantp symbol) :constant :variable) things))
109 (when (fboundp symbol)
110 (push (cond ((macro-function symbol) :macro)
111 ((typep (fdefinition symbol) 'generic-function)
115 (when (or ;;(not (boring-setf-expansion-p symbol))
116 (ignore-errors (fdefinition (list 'setf symbol))))
117 (push :setf things)))
118 (when (find-class symbol nil)
119 (push :class things))
120 (when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol)
121 (specialized-on-p #'sod:expand-c-type-form 0 symbol))
122 (push :c-type things))
123 (when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol)
124 (specialized-on-p #'sod-parser:expand-parser-form 1 symbol))
125 (push :parser things))
128 (defun categorize-symbols (paths package)
129 (mapcar (lambda (assoc)
130 (let ((home (car assoc))
131 (symbols (delete-duplicates
132 (sort (mapcan (lambda (sym)
138 (and foundp (list symbol))))
140 #'string< :key #'symbol-name))))
141 (cons home (mapcar (lambda (symbol)
142 (cons symbol (categorize symbol)))
145 (find-symbol-homes paths package)))
147 (defun best-package-name (package)
148 (car (sort (cons (package-name package)
149 (copy-list (package-nicknames package)))
152 (defvar charbuf-size 0)
154 (defun pretty-symbol-name (symbol package)
155 (let* ((pkg (symbol-package symbol))
156 (exportp (member symbol (list-exported-symbols pkg))))
157 (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)"
158 (and exportp (eq pkg package))
159 (if (keywordp symbol) "" (best-package-name pkg))
160 exportp (symbol-name symbol))))
162 (defun analyse-classes (package)
163 (setf package (find-package package))
164 (let ((classes (mapcan (lambda (symbol)
165 (let ((class (find-class symbol nil)))
167 (typep class '(or standard-class
170 (list-exported-symbols package)))
171 (subs (make-hash-table)))
172 (let ((done (make-hash-table)))
173 (labels ((walk-up (class)
174 (unless (gethash class done)
175 (dolist (super (sb-mop:class-direct-superclasses class))
176 (push class (gethash super subs))
178 (setf (gethash class done) t))))
179 (dolist (class classes)
181 (labels ((walk-down (this super depth)
182 (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%"
184 (pretty-symbol-name (class-name this) package)
185 (mapcar (lambda (class)
186 (pretty-symbol-name (class-name class)
189 (sb-mop:class-direct-superclasses this))))
190 (dolist (sub (sort (copy-list (gethash this subs))
191 #'string< :key #'class-name))
192 (walk-down sub this (1+ depth)))))
193 (walk-down (find-class t) nil 0))))
195 (defun analyse-generic-functions (package)
196 (setf package (find-package package))
197 (flet ((function-name-core (name)
200 ((cons (eql setf) t) (cadr name)))))
201 (let ((methods (make-hash-table))
202 (functions (make-hash-table))
203 (externs (make-hash-table)))
204 (dolist (symbol (list-exported-symbols package))
205 (setf (gethash symbol externs) t))
206 (dolist (symbol (list-exported-symbols package))
207 (flet ((dofunc (func)
208 (when (typep func 'generic-function)
209 (setf (gethash func functions) t)
210 (dolist (method (sb-mop:generic-function-methods func))
211 (setf (gethash method methods) t)))))
212 (dofunc (and (fboundp symbol) (fdefinition symbol)))
213 (dofunc (ignore-errors (fdefinition (list 'setf symbol)))))
214 (when (eq (symbol-package symbol) package)
215 (let ((class (find-class symbol nil)))
218 (func (sb-mop:specializer-direct-generic-functions class))
219 (let ((name (function-name-core
220 (sb-mop:generic-function-name func))))
221 (when (or (not (eq (symbol-package name) package))
222 (gethash name externs))
223 (setf (gethash func functions) t)
224 (dolist (method (sb-mop:specializer-direct-methods class))
225 (setf (gethash method methods) t)))))))))
226 (let ((funclist nil))
227 (maphash (lambda (func value)
228 (declare (ignore value))
229 (push func funclist))
231 (setf funclist (sort funclist
233 (let ((core-a (function-name-core a))
234 (core-b (function-name-core b)))
235 (if (eq core-a core-b)
236 (and (atom a) (consp b))
237 (string< core-a core-b))))
238 :key #'sb-mop:generic-function-name))
239 (dolist (function funclist)
240 (let ((name (sb-mop:generic-function-name function)))
243 (format t "~A~%" (pretty-symbol-name name package)))
245 (format t "(setf ~A)~%"
246 (pretty-symbol-name (cadr name) package)))))
247 (dolist (method (sb-mop:generic-function-methods function))
248 (when (gethash method methods)
249 (format t "~2T~{~A~^ ~}~%"
254 (let ((name (class-name spec)))
256 (pretty-symbol-name name package))))
257 (sb-mop:eql-specializer
258 (let ((obj (sb-mop:eql-specializer-object spec)))
259 (format nil "(eql ~A)"
261 (pretty-symbol-name obj package)
263 (sb-mop:method-specializers method))))))))))
265 (defun check-slot-names (package)
266 (setf package (find-package package))
267 (let* ((symbols (list-exported-symbols package))
268 (classes (mapcan (lambda (symbol)
269 (when (eq (symbol-package symbol) package)
270 (let ((class (find-class symbol nil)))
271 (and class (list class)))))
276 (mapcar #'sb-mop:slot-definition-name
277 (sb-mop:class-direct-slots class)))
278 (exported (remove-if-not
280 (or (and (symbol-package sym)
281 (not (eq (symbol-package
284 (member sym symbols)))
287 (list (cons (class-name class)
290 (bad-words (remove-duplicates (mapcan (lambda (list)
291 (copy-list (cdr list)))
293 (values offenders bad-words)))
295 (defun report-symbols (paths package)
296 (setf package (find-package package))
297 (format t "~A~%Package `~(~A~)'~2%"
298 (make-string 77 :initial-element #\-)
299 (package-name package))
300 (dolist (assoc (categorize-symbols paths package))
302 (format t "~A~%" (file-namestring (car assoc)))
303 (dolist (def (cdr assoc))
304 (let ((sym (car def)))
305 (format t " ~A~@[~48T~{~(~A~)~^ ~}~]~%"
306 (pretty-symbol-name sym package)
309 (multiple-value-bind (alist names) (check-slot-names package)
311 (format t "Leaked slot names: ~{~A~^, ~}~%"
312 (mapcar (lambda (name) (pretty-symbol-name name package))
314 (dolist (assoc alist)
315 (format t "~2T~A: ~{~A~^, ~}~%"
316 (pretty-symbol-name (car assoc) package)
317 (mapcar (lambda (name) (pretty-symbol-name name package))
320 (format t "Classes:~%")
321 (analyse-classes package)
323 (format t "Methods:~%")
324 (analyse-generic-functions package)
327 (defun report-project-symbols ()
328 (labels ((components (comp)
329 (slot-value comp 'asdf::components))
331 (sort (remove-if-not (lambda (comp)
332 (typep comp 'asdf:cl-source-file))
334 #'string< :key #'asdf:component-name))
336 (find name (components comp)
337 :test #'string= :key #'asdf:component-name))
339 (slot-value file 'asdf::absolute-pathname)))
340 (let* ((sod (asdf:find-system "sod"))
341 (parser-files (files (by-name sod "parser")))
342 (utilities (by-name sod "utilities"))
343 (sod-files (remove utilities (files sod))))
344 (report-symbols (mapcar #'file-name sod-files) "SOD")
345 (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER")
346 (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES"))))