lib/sod.h: New macro `SOD_INSTBASE' to find the allocated base address.

[sod] / pre-reorg / sift.lisp

;;; sift through lists of classes and so on.

(in-package #:cl-user)

(defstruct (cset (:conc-name s-))
  members supers subs gfs)

(defstruct (class-node (:conc-name c-))
  name class own-p supers subs visited-p sets)

(defmacro pushnew-end (object place &rest keys &environment env)
  (multiple-value-bind (temps inits newtemps setform getform)
      (get-setf-expansion place env)
    (let ((objvar (gensym "OBJECT"))
          (listvar (gensym "LIST")))
      `(let* ((,objvar ,object)
              ,@(mapcar #'list temps inits)
              (,listvar ,getform))
         (cond ((member ,objvar ,listvar ,@keys)
                ,listvar)
               (t
                (multiple-value-bind ,newtemps
                    (append ,listvar (list ,objvar))
                  ,setform
                  (values ,@newtemps))))))))

(defun show-classes (classes)
  (let ((map (make-hash-table)))

    (labels ((getnode (class &optional own-p)
               (let ((found (gethash class map)))
                 (if found
                     (values found t)
                     (values (setf (gethash class map)
                                   (make-class-node :name (class-name class)
                                                    :class class
                                                    :own-p own-p))
                             nil))))

             (gather (class)
               (let ((node (getnode class)))
                 (dolist (super (class-direct-superclasses class))
                   (unless (member super (append (mapcar #'find-class
                                                         '(t standard-object
                                                           structure-object))
                                                 (class-direct-superclasses
                                                  (find-class 'condition))))
                     (multiple-value-bind (supernode foundp)
                         (getnode super)
                       (pushnew-end supernode (c-supers node))
                       (pushnew node (c-subs supernode))
                       (unless foundp (gather super)))))))

             (walk (node &optional (level 0) super)
               (format *standard-output* "~v,0T~(~:[[~A]~;~A~]~)"
                       (* 2 level)
                       (c-own-p node)
                       (c-name node))
               (cond ((null (cdr (c-supers node))))
                     ((eq (car (c-supers node)) super)
                      (format *standard-output* " ~:<~@{~(~A~)~^ ~_~}~:>"
                              (mapcar #'c-name (c-supers node))))
                     (t
                      (format *standard-output* "*~%")
                      (return-from walk)))
               (terpri *standard-output*)
               (dolist (sub (c-subs node))
                 (walk sub (1+ level) node))))

      ;; make nodes for all of the official classes.
      (dolist (class classes)
        (getnode class t))

      ;; build the hierarchy, up and down.  this may drag in classes from
      ;; other packages.
      (dolist (class classes)
        (gather class))

      ;; write the table.
      (dolist (node (sort (loop for node being the hash-values of map
                                unless (c-supers node)
                                collect node)
                          #'string< :key #'c-name))
        (walk node)))))

(defun check-sets (members)
  (let ((done (make-hash-table)))
    (labels ((check (s)
               (when (gethash s done)
                 (return-from check))
               (setf (gethash s done) t)

               ;; subsets must be proper subsets
               (dolist (u (s-supers s))
                 (assert (subsetp (s-members s) (s-members u)))
                 (assert (not (subsetp (s-members u) (s-members s))))
                 (assert (member s (s-subs u))))

               ;; supersets must be proper supersets
               (dolist (u (s-subs s))
                 (assert (subsetp (s-members u) (s-members s)))
                 (assert (not (subsetp (s-members s) (s-members u))))
                 (assert (member s (s-supers u))))

               ;; supersets must be minimal
               (dolist (u (s-supers s))
                 (dolist (v (s-supers s))
                   (assert (or (eq u v)
                               (not (subsetp (s-members u)
                                             (s-members v)))))))

               ;; subsets must be maximal
               (dolist (u (s-subs s))
                 (dolist (v (s-subs s))
                   (assert (or (eq u v)
                               (not (subsetp (s-members u)
                                             (s-members v)))))))

               ;; members must link to us, directly or indirectly.
               (dolist (m (s-members s))
                 (labels ((look (u)
                            (or (eq u s) (some #'look (s-supers u)))))
                   (assert (some #'look (c-sets m)))))

               ;; check supersets and subsets
               (dolist (u (s-supers s)) (check u))
               (dolist (u (s-subs s)) (check u))))

      (dolist (m members)
        (dolist (s (c-sets m))

          ;; sets must contain us
          (assert (member m (s-members s)))

          ;; sets must be minimal
          (dolist (u (c-sets m))
            (assert (or (eq u s)
                        (not (subsetp (s-members u)
                                      (s-members s))))))

          ;; check set
          (check s))))))

(defmethod print-object ((c class-node) stream)
  (format stream "#[~(~A~)]" (c-name c)))

(defmethod print-object ((s cset) stream)
  (format stream "~<#{~;~@{~A~^ ~_~}~;}~:>" (s-members s)))

(defun ensure-set (members)

  (setf members (remove-duplicates members))
  (check-sets members)

  (let ((subs nil) (supers nil))

    ;; find the maximal subsets and minimal supersets.  if s is not a subset
    ;; then answer nil; otherwise answer t, and recursively process all the
    ;; supersets of s; if none of them answer t then is maximal, so add it to
    ;; the list.
    (labels ((up (s)
               (cond ((subsetp (s-members s) members)
                      (unless (some #'up (s-supers s)) (pushnew s subs))
                      t)
                     ((subsetp members (s-members s))
                      (pushnew s supers)
                      nil)
                     (t nil))))
      (dolist (m members)
        (mapc #'up (c-sets m))))
    (when (and subs (subsetp members (s-members (car subs))))
      (return-from ensure-set (car subs)))
    (let* ((new (make-cset :members members :supers supers :subs subs)))

      ;; now we have to interpolate ourselves properly.  this is the tricky
      ;; part.
      (dolist (s supers)
        (setf (s-subs s)
              (cons new (set-difference (s-subs s) subs))))
      (dolist (s subs)
        (setf (s-supers s)
              (cons new (set-difference (s-supers s) supers))))
      (dolist (m members)
        (unless (some (lambda (s) (subsetp (s-members s) members))
                      (c-sets m))
          (setf (c-sets m) (cons new
                                 (remove-if (lambda (s)
                                              (subsetp members
                                                       (s-members s)))
                                            (c-sets m))))))

      ;; done
      (check-sets members)
      new)))

(defun categorize-protocols (generics classes)
  (let ((cmap (make-hash-table)))

    (labels ((getnode (class &optional own-p)
               (let ((found (gethash class cmap)))
                 (if found
                     (values found t)
                     (values (setf (gethash class cmap)
                                   (make-class-node :name (class-name class)
                                                    :class class
                                                    :own-p own-p))
                             nil))))

             (gather (class)
               (let ((node (getnode class)))
                 (dolist (super (class-direct-superclasses class))
                   (unless (member super (append (mapcar #'find-class
                                                         '(t standard-object
                                                           structure-object))
                                                 (class-direct-superclasses
                                                  (find-class 'condition))))
                     (multiple-value-bind (supernode foundp)
                         (getnode super)
                       (pushnew-end supernode (c-supers node))
                       (pushnew node (c-subs supernode))
                       (unless foundp (gather super))))))))

      ;; make nodes for all of the official classes.
      (dolist (class classes)
        (getnode class t))

      ;; build the hierarchy, up and down.  this may drag in classes from
      ;; other packages.
      (dolist (class classes)
        (gather class))

      ;; go through the generic functions collecting sets of implementing
      ;; classes.
      (dolist (gf generics)
        (let* ((specs (reduce #'append
                              (mapcar #'method-specializers
                                      (generic-function-methods gf))
                              :from-end t))
               (members (labels ((down (c)
                                   (delete-duplicates
                                    (cons c (mapcan #'down (c-subs c)))))
                                 (gather (spec)
                                   (let ((c (gethash spec cmap)))
                                     (and c (down c)))))
                          (delete-duplicates (mapcan #'gather specs))))
               (s (and members (ensure-set members))))
          (when s
            (push gf (s-gfs s)))))

      ;; finally dump the list of participating classes.
      (let ((tops nil))

        ;; find the top-level sets
        (let ((m (make-hash-table)))
          (labels ((ascend (s)
                     (unless (gethash s m)
                       (setf (gethash s m) t)
                       (if (s-supers s)
                           (mapc #'ascend (s-supers s))
                           (push s tops)))))
            (dolist (c classes)
              (mapc #'ascend (c-sets (gethash c cmap))))))

        (let ((done (make-hash-table)))
          (labels ((walk (s &optional (level 0))
                     (let ((seen (gethash s done)))
                       (unless seen
                         (setf (gethash s done) t)
                         (dolist (gf (s-gfs s))
                           (format *standard-output* "~v,0T~(~A~)~%"
                                   (* 2 level)
                                   (generic-function-name gf))))
                       (dolist (c (set-difference
                                   (s-members s)
                                   (reduce #'union (mapcar #'s-members
                                                           (s-subs s))
                                           :initial-value nil)))
                         (format *standard-output* "~40T~(~A~)~:[~;*~]~%"
                                 (c-name c) seen))
                       (dolist (u (s-subs s))
                         (walk u (1+ level))))))
            (mapc #'walk tops)
            nil))))))

(defun gather-stuff (package)
  (let ((classes nil)
        (functions nil)
        (generics nil)
        (structs nil)
        (macros nil)
        (methods nil)
        (package (find-package package)))

    ;; find all of the interesting things in the package.
    (do-symbols (sym package)
      (when (eq (symbol-package sym) package)
        (let ((class (find-class sym nil)))
          (typecase class
            ((or standard-class sb-pcl::condition-class)
             (push class classes))
            (structure-class (push class structs))))
        (when (fboundp sym)
          (let ((func (symbol-function sym)))
            (if (typep func 'generic-function)
                (push func generics)
                (push sym functions))))
        (let ((macro (macro-function sym)))
          (when macro (push sym macros)))))

    ;; sort the lists -- makes things look prettier.
    (macrolet ((frob (list key)
                 `(setf ,list (sort ,list #'string< :key #',key))))
      (frob classes class-name)
      (frob functions identity)
      (frob structs class-name)
      (frob generics generic-function-name)
      (frob macros identity)
      (frob methods (lambda (m)
                      (generic-function-name (method-generic-function m)))))

    ;; present the classes in a vaguely useful way
    (flet ((sep ()
             (format t "~%-------------------------~2%")))
      (show-classes classes)
      (sep)
      (show-classes structs)
      (sep)
      (categorize-protocols generics classes)
      (loop for title in '("Macros" "Functions")
            for list in (list macros functions) do
            (sep)
            (format t "~{~(~A~)~%~}" list)))))