chiark - git - mdw - sod/blob - pre-reorg/sift.lisp

   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