1 ;;; sift through lists of classes and so on.
5 (defstruct (cset (:conc-name s-))
6 members supers subs gfs)
8 (defstruct (class-node (:conc-name c-))
9 name class own-p supers subs visited-p sets)
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)
19 (cond ((member ,objvar ,listvar ,@keys)
22 (multiple-value-bind ,newtemps
23 (append ,listvar (list ,objvar))
25 (values ,@newtemps))))))))
27 (defun show-classes (classes)
28 (let ((map (make-hash-table)))
30 (labels ((getnode (class &optional own-p)
31 (let ((found (gethash class map)))
34 (values (setf (gethash class map)
35 (make-class-node :name (class-name class)
41 (let ((node (getnode class)))
42 (dolist (super (class-direct-superclasses class))
43 (unless (member super (append (mapcar #'find-class
46 (class-direct-superclasses
47 (find-class 'condition))))
48 (multiple-value-bind (supernode foundp)
50 (pushnew-end supernode (c-supers node))
51 (pushnew node (c-subs supernode))
52 (unless foundp (gather super)))))))
54 (walk (node &optional (level 0) super)
55 (format *standard-output* "~v,0T~(~:[[~A]~;~A~]~)"
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))))
64 (format *standard-output* "*~%")
66 (terpri *standard-output*)
67 (dolist (sub (c-subs node))
68 (walk sub (1+ level) node))))
70 ;; make nodes for all of the official classes.
71 (dolist (class classes)
74 ;; build the hierarchy, up and down. this may drag in classes from
76 (dolist (class classes)
80 (dolist (node (sort (loop for node being the hash-values of map
81 unless (c-supers node)
83 #'string< :key #'c-name))
86 (defun check-sets (members)
87 (let ((done (make-hash-table)))
89 (when (gethash s done)
91 (setf (gethash s done) t)
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))))
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))))
105 ;; supersets must be minimal
106 (dolist (u (s-supers s))
107 (dolist (v (s-supers s))
109 (not (subsetp (s-members u)
112 ;; subsets must be maximal
113 (dolist (u (s-subs s))
114 (dolist (v (s-subs s))
116 (not (subsetp (s-members u)
119 ;; members must link to us, directly or indirectly.
120 (dolist (m (s-members s))
122 (or (eq u s) (some #'look (s-supers u)))))
123 (assert (some #'look (c-sets m)))))
125 ;; check supersets and subsets
126 (dolist (u (s-supers s)) (check u))
127 (dolist (u (s-subs s)) (check u))))
130 (dolist (s (c-sets m))
132 ;; sets must contain us
133 (assert (member m (s-members s)))
135 ;; sets must be minimal
136 (dolist (u (c-sets m))
138 (not (subsetp (s-members u)
144 (defmethod print-object ((c class-node) stream)
145 (format stream "#[~(~A~)]" (c-name c)))
147 (defmethod print-object ((s cset) stream)
148 (format stream "~<#{~;~@{~A~^ ~_~}~;}~:>" (s-members s)))
150 (defun ensure-set (members)
152 (setf members (remove-duplicates members))
155 (let ((subs nil) (supers nil))
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
162 (cond ((subsetp (s-members s) members)
163 (unless (some #'up (s-supers s)) (pushnew s subs))
165 ((subsetp members (s-members s))
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)))
175 ;; now we have to interpolate ourselves properly. this is the tricky
179 (cons new (set-difference (s-subs s) subs))))
182 (cons new (set-difference (s-supers s) supers))))
184 (unless (some (lambda (s) (subsetp (s-members s) members))
186 (setf (c-sets m) (cons new
187 (remove-if (lambda (s)
196 (defun categorize-protocols (generics classes)
197 (let ((cmap (make-hash-table)))
199 (labels ((getnode (class &optional own-p)
200 (let ((found (gethash class cmap)))
203 (values (setf (gethash class cmap)
204 (make-class-node :name (class-name class)
210 (let ((node (getnode class)))
211 (dolist (super (class-direct-superclasses class))
212 (unless (member super (append (mapcar #'find-class
215 (class-direct-superclasses
216 (find-class 'condition))))
217 (multiple-value-bind (supernode foundp)
219 (pushnew-end supernode (c-supers node))
220 (pushnew node (c-subs supernode))
221 (unless foundp (gather super))))))))
223 ;; make nodes for all of the official classes.
224 (dolist (class classes)
227 ;; build the hierarchy, up and down. this may drag in classes from
229 (dolist (class classes)
232 ;; go through the generic functions collecting sets of implementing
234 (dolist (gf generics)
235 (let* ((specs (reduce #'append
236 (mapcar #'method-specializers
237 (generic-function-methods gf))
239 (members (labels ((down (c)
241 (cons c (mapcan #'down (c-subs c)))))
243 (let ((c (gethash spec cmap)))
245 (delete-duplicates (mapcan #'gather specs))))
246 (s (and members (ensure-set members))))
248 (push gf (s-gfs s)))))
250 ;; finally dump the list of participating classes.
253 ;; find the top-level sets
254 (let ((m (make-hash-table)))
256 (unless (gethash s m)
257 (setf (gethash s m) t)
259 (mapc #'ascend (s-supers s))
262 (mapc #'ascend (c-sets (gethash c cmap))))))
264 (let ((done (make-hash-table)))
265 (labels ((walk (s &optional (level 0))
266 (let ((seen (gethash s done)))
268 (setf (gethash s done) t)
269 (dolist (gf (s-gfs s))
270 (format *standard-output* "~v,0T~(~A~)~%"
272 (generic-function-name gf))))
273 (dolist (c (set-difference
275 (reduce #'union (mapcar #'s-members
277 :initial-value nil)))
278 (format *standard-output* "~40T~(~A~)~:[~;*~]~%"
280 (dolist (u (s-subs s))
281 (walk u (1+ level))))))
285 (defun gather-stuff (package)
292 (package (find-package package)))
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)))
299 ((or standard-class sb-pcl::condition-class)
300 (push class classes))
301 (structure-class (push class structs))))
303 (let ((func (symbol-function sym)))
304 (if (typep func 'generic-function)
306 (push sym functions))))
307 (let ((macro (macro-function sym)))
308 (when macro (push sym macros)))))
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)))))
321 ;; present the classes in a vaguely useful way
323 (format t "~%-------------------------~2%")))
324 (show-classes classes)
326 (show-classes structs)
328 (categorize-protocols generics classes)
329 (loop for title in '("Macros" "Functions")
330 for list in (list macros functions) do
332 (format t "~{~(~A~)~%~}" list)))))