| 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 | |