Commit | Line | Data |
---|---|---|
097d5a3e MW |
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))) | |
de8f0794 | 72 | (unless (nth-value 1 (find-symbol name package)) |
097d5a3e MW |
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 | ||
649798ab | 137 | (find-symbol-homes paths package))) |
097d5a3e MW |
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")))) |