Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; sift through lists of classes and so on. |
2 | ||
3 | (in-package #:cl-user) | |
4 | ||
5 | (defstruct (cset (:conc-name s-)) | |
6 | members supers subs gfs) | |
7 | ||
8 | (defstruct (class-node (:conc-name c-)) | |
9 | name class own-p supers subs visited-p sets) | |
10 | ||
11 | (defmacro pushnew-end (object place &rest keys &environment env) | |
12 | (multiple-value-bind (temps inits newtemps setform getform) | |
13 | (get-setf-expansion place env) | |
14 | (let ((objvar (gensym "OBJECT")) | |
15 | (listvar (gensym "LIST"))) | |
16 | `(let* ((,objvar ,object) | |
17 | ,@(mapcar #'list temps inits) | |
18 | (,listvar ,getform)) | |
19 | (cond ((member ,objvar ,listvar ,@keys) | |
20 | ,listvar) | |
21 | (t | |
22 | (multiple-value-bind ,newtemps | |
23 | (append ,listvar (list ,objvar)) | |
24 | ,setform | |
25 | (values ,@newtemps)))))))) | |
26 | ||
27 | (defun show-classes (classes) | |
28 | (let ((map (make-hash-table))) | |
29 | ||
30 | (labels ((getnode (class &optional own-p) | |
31 | (let ((found (gethash class map))) | |
32 | (if found | |
33 | (values found t) | |
34 | (values (setf (gethash class map) | |
35 | (make-class-node :name (class-name class) | |
36 | :class class | |
37 | :own-p own-p)) | |
38 | nil)))) | |
39 | ||
40 | (gather (class) | |
41 | (let ((node (getnode class))) | |
42 | (dolist (super (class-direct-superclasses class)) | |
43 | (unless (member super (append (mapcar #'find-class | |
44 | '(t standard-object | |
45 | structure-object)) | |
46 | (class-direct-superclasses | |
47 | (find-class 'condition)))) | |
48 | (multiple-value-bind (supernode foundp) | |
49 | (getnode super) | |
50 | (pushnew-end supernode (c-supers node)) | |
51 | (pushnew node (c-subs supernode)) | |
52 | (unless foundp (gather super))))))) | |
53 | ||
54 | (walk (node &optional (level 0) super) | |
55 | (format *standard-output* "~v,0T~(~:[[~A]~;~A~]~)" | |
56 | (* 2 level) | |
57 | (c-own-p node) | |
58 | (c-name node)) | |
59 | (cond ((null (cdr (c-supers node)))) | |
60 | ((eq (car (c-supers node)) super) | |
61 | (format *standard-output* " ~:<~@{~(~A~)~^ ~_~}~:>" | |
62 | (mapcar #'c-name (c-supers node)))) | |
63 | (t | |
64 | (format *standard-output* "*~%") | |
65 | (return-from walk))) | |
66 | (terpri *standard-output*) | |
67 | (dolist (sub (c-subs node)) | |
68 | (walk sub (1+ level) node)))) | |
69 | ||
70 | ;; make nodes for all of the official classes. | |
71 | (dolist (class classes) | |
72 | (getnode class t)) | |
73 | ||
74 | ;; build the hierarchy, up and down. this may drag in classes from | |
75 | ;; other packages. | |
76 | (dolist (class classes) | |
77 | (gather class)) | |
78 | ||
79 | ;; write the table. | |
80 | (dolist (node (sort (loop for node being the hash-values of map | |
81 | unless (c-supers node) | |
82 | collect node) | |
83 | #'string< :key #'c-name)) | |
84 | (walk node))))) | |
85 | ||
86 | (defun check-sets (members) | |
87 | (let ((done (make-hash-table))) | |
88 | (labels ((check (s) | |
89 | (when (gethash s done) | |
90 | (return-from check)) | |
91 | (setf (gethash s done) t) | |
92 | ||
93 | ;; subsets must be proper subsets | |
94 | (dolist (u (s-supers s)) | |
95 | (assert (subsetp (s-members s) (s-members u))) | |
96 | (assert (not (subsetp (s-members u) (s-members s)))) | |
97 | (assert (member s (s-subs u)))) | |
98 | ||
99 | ;; supersets must be proper supersets | |
100 | (dolist (u (s-subs s)) | |
101 | (assert (subsetp (s-members u) (s-members s))) | |
102 | (assert (not (subsetp (s-members s) (s-members u)))) | |
103 | (assert (member s (s-supers u)))) | |
104 | ||
105 | ;; supersets must be minimal | |
106 | (dolist (u (s-supers s)) | |
107 | (dolist (v (s-supers s)) | |
108 | (assert (or (eq u v) | |
109 | (not (subsetp (s-members u) | |
110 | (s-members v))))))) | |
111 | ||
112 | ;; subsets must be maximal | |
113 | (dolist (u (s-subs s)) | |
114 | (dolist (v (s-subs s)) | |
115 | (assert (or (eq u v) | |
116 | (not (subsetp (s-members u) | |
117 | (s-members v))))))) | |
118 | ||
119 | ;; members must link to us, directly or indirectly. | |
120 | (dolist (m (s-members s)) | |
121 | (labels ((look (u) | |
122 | (or (eq u s) (some #'look (s-supers u))))) | |
123 | (assert (some #'look (c-sets m))))) | |
124 | ||
125 | ;; check supersets and subsets | |
126 | (dolist (u (s-supers s)) (check u)) | |
127 | (dolist (u (s-subs s)) (check u)))) | |
128 | ||
129 | (dolist (m members) | |
130 | (dolist (s (c-sets m)) | |
131 | ||
132 | ;; sets must contain us | |
133 | (assert (member m (s-members s))) | |
134 | ||
135 | ;; sets must be minimal | |
136 | (dolist (u (c-sets m)) | |
137 | (assert (or (eq u s) | |
138 | (not (subsetp (s-members u) | |
139 | (s-members s)))))) | |
140 | ||
141 | ;; check set | |
142 | (check s)))))) | |
143 | ||
144 | (defmethod print-object ((c class-node) stream) | |
145 | (format stream "#[~(~A~)]" (c-name c))) | |
146 | ||
147 | (defmethod print-object ((s cset) stream) | |
148 | (format stream "~<#{~;~@{~A~^ ~_~}~;}~:>" (s-members s))) | |
149 | ||
150 | (defun ensure-set (members) | |
151 | ||
152 | (setf members (remove-duplicates members)) | |
153 | (check-sets members) | |
154 | ||
155 | (let ((subs nil) (supers nil)) | |
156 | ||
157 | ;; find the maximal subsets and minimal supersets. if s is not a subset | |
158 | ;; then answer nil; otherwise answer t, and recursively process all the | |
159 | ;; supersets of s; if none of them answer t then is maximal, so add it to | |
160 | ;; the list. | |
161 | (labels ((up (s) | |
162 | (cond ((subsetp (s-members s) members) | |
163 | (unless (some #'up (s-supers s)) (pushnew s subs)) | |
164 | t) | |
165 | ((subsetp members (s-members s)) | |
166 | (pushnew s supers) | |
167 | nil) | |
168 | (t nil)))) | |
169 | (dolist (m members) | |
170 | (mapc #'up (c-sets m)))) | |
171 | (when (and subs (subsetp members (s-members (car subs)))) | |
172 | (return-from ensure-set (car subs))) | |
173 | (let* ((new (make-cset :members members :supers supers :subs subs))) | |
174 | ||
175 | ;; now we have to interpolate ourselves properly. this is the tricky | |
176 | ;; part. | |
177 | (dolist (s supers) | |
178 | (setf (s-subs s) | |
179 | (cons new (set-difference (s-subs s) subs)))) | |
180 | (dolist (s subs) | |
181 | (setf (s-supers s) | |
182 | (cons new (set-difference (s-supers s) supers)))) | |
183 | (dolist (m members) | |
184 | (unless (some (lambda (s) (subsetp (s-members s) members)) | |
185 | (c-sets m)) | |
186 | (setf (c-sets m) (cons new | |
187 | (remove-if (lambda (s) | |
188 | (subsetp members | |
189 | (s-members s))) | |
190 | (c-sets m)))))) | |
191 | ||
192 | ;; done | |
193 | (check-sets members) | |
194 | new))) | |
195 | ||
196 | (defun categorize-protocols (generics classes) | |
197 | (let ((cmap (make-hash-table))) | |
198 | ||
199 | (labels ((getnode (class &optional own-p) | |
200 | (let ((found (gethash class cmap))) | |
201 | (if found | |
202 | (values found t) | |
203 | (values (setf (gethash class cmap) | |
204 | (make-class-node :name (class-name class) | |
205 | :class class | |
206 | :own-p own-p)) | |
207 | nil)))) | |
208 | ||
209 | (gather (class) | |
210 | (let ((node (getnode class))) | |
211 | (dolist (super (class-direct-superclasses class)) | |
212 | (unless (member super (append (mapcar #'find-class | |
213 | '(t standard-object | |
214 | structure-object)) | |
215 | (class-direct-superclasses | |
216 | (find-class 'condition)))) | |
217 | (multiple-value-bind (supernode foundp) | |
218 | (getnode super) | |
219 | (pushnew-end supernode (c-supers node)) | |
220 | (pushnew node (c-subs supernode)) | |
221 | (unless foundp (gather super)))))))) | |
222 | ||
223 | ;; make nodes for all of the official classes. | |
224 | (dolist (class classes) | |
225 | (getnode class t)) | |
226 | ||
227 | ;; build the hierarchy, up and down. this may drag in classes from | |
228 | ;; other packages. | |
229 | (dolist (class classes) | |
230 | (gather class)) | |
231 | ||
232 | ;; go through the generic functions collecting sets of implementing | |
233 | ;; classes. | |
234 | (dolist (gf generics) | |
235 | (let* ((specs (reduce #'append | |
236 | (mapcar #'method-specializers | |
237 | (generic-function-methods gf)) | |
238 | :from-end t)) | |
239 | (members (labels ((down (c) | |
240 | (delete-duplicates | |
241 | (cons c (mapcan #'down (c-subs c))))) | |
242 | (gather (spec) | |
243 | (let ((c (gethash spec cmap))) | |
244 | (and c (down c))))) | |
245 | (delete-duplicates (mapcan #'gather specs)))) | |
246 | (s (and members (ensure-set members)))) | |
247 | (when s | |
248 | (push gf (s-gfs s))))) | |
249 | ||
250 | ;; finally dump the list of participating classes. | |
251 | (let ((tops nil)) | |
252 | ||
253 | ;; find the top-level sets | |
254 | (let ((m (make-hash-table))) | |
255 | (labels ((ascend (s) | |
256 | (unless (gethash s m) | |
257 | (setf (gethash s m) t) | |
258 | (if (s-supers s) | |
259 | (mapc #'ascend (s-supers s)) | |
260 | (push s tops))))) | |
261 | (dolist (c classes) | |
262 | (mapc #'ascend (c-sets (gethash c cmap)))))) | |
263 | ||
264 | (let ((done (make-hash-table))) | |
265 | (labels ((walk (s &optional (level 0)) | |
266 | (let ((seen (gethash s done))) | |
267 | (unless seen | |
268 | (setf (gethash s done) t) | |
269 | (dolist (gf (s-gfs s)) | |
270 | (format *standard-output* "~v,0T~(~A~)~%" | |
271 | (* 2 level) | |
272 | (generic-function-name gf)))) | |
273 | (dolist (c (set-difference | |
274 | (s-members s) | |
275 | (reduce #'union (mapcar #'s-members | |
276 | (s-subs s)) | |
277 | :initial-value nil))) | |
278 | (format *standard-output* "~40T~(~A~)~:[~;*~]~%" | |
279 | (c-name c) seen)) | |
280 | (dolist (u (s-subs s)) | |
281 | (walk u (1+ level)))))) | |
282 | (mapc #'walk tops) | |
283 | nil)))))) | |
284 | ||
285 | (defun gather-stuff (package) | |
286 | (let ((classes nil) | |
287 | (functions nil) | |
288 | (generics nil) | |
289 | (structs nil) | |
290 | (macros nil) | |
291 | (methods nil) | |
292 | (package (find-package package))) | |
293 | ||
294 | ;; find all of the interesting things in the package. | |
295 | (do-symbols (sym package) | |
296 | (when (eq (symbol-package sym) package) | |
297 | (let ((class (find-class sym nil))) | |
298 | (typecase class | |
299 | ((or standard-class sb-pcl::condition-class) | |
300 | (push class classes)) | |
301 | (structure-class (push class structs)))) | |
302 | (when (fboundp sym) | |
303 | (let ((func (symbol-function sym))) | |
304 | (if (typep func 'generic-function) | |
305 | (push func generics) | |
306 | (push sym functions)))) | |
307 | (let ((macro (macro-function sym))) | |
308 | (when macro (push sym macros))))) | |
309 | ||
310 | ;; sort the lists -- makes things look prettier. | |
311 | (macrolet ((frob (list key) | |
312 | `(setf ,list (sort ,list #'string< :key #',key)))) | |
313 | (frob classes class-name) | |
314 | (frob functions identity) | |
315 | (frob structs class-name) | |
316 | (frob generics generic-function-name) | |
317 | (frob macros identity) | |
318 | (frob methods (lambda (m) | |
319 | (generic-function-name (method-generic-function m))))) | |
320 | ||
321 | ;; present the classes in a vaguely useful way | |
322 | (flet ((sep () | |
323 | (format t "~%-------------------------~2%"))) | |
324 | (show-classes classes) | |
325 | (sep) | |
326 | (show-classes structs) | |
327 | (sep) | |
328 | (categorize-protocols generics classes) | |
329 | (loop for title in '("Macros" "Functions") | |
330 | for list in (list macros functions) do | |
331 | (sep) | |
332 | (format t "~{~(~A~)~%~}" list))))) | |
333 |