chiark - git - mdw - sod/blob - doc/list-exports.lisp

   1 (cl:defpackage #:sod-exports
   2   (:use #:common-lisp))
   3
   4 (cl:in-package #:sod-exports)
   5
   6 (defun symbolicate (&rest things)
   7   (intern (apply #'concatenate 'string (mapcar #'string things))))
   8
   9 (defun incomprehensible-form (head tail)
  10   (format *error-output* ";; incomprehensible: ~S~%" (cons head tail)))
  11
  12 (defgeneric form-list-exports (head tail)
  13   (:method (head tail)
  14     (declare (ignore head tail))
  15     nil))
  16
  17 (defmethod form-list-exports ((head (eql 'cl:export)) tail)
  18   (let ((symbols (car tail)))
  19     (if (and (consp symbols)
  20              (eq (car symbols) 'quote))
  21         (let ((thing (cadr symbols)))
  22           (if (atom thing) (list thing) thing))
  23         (incomprehensible-form head tail))))
  24
  25 (defmethod form-list-exports ((head (eql 'sod:definst)) tail)
  26   (destructuring-bind (code (streamvar &key export) args &body body) tail
  27     (declare (ignore streamvar body))
  28     (and export
  29          (list* (symbolicate code '-inst)
  30                 (symbolicate 'make- code '-inst)
  31                 (mapcar (lambda (arg)
  32                           (symbolicate 'inst- arg))
  33                         args)))))
  34
  35 (defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail)
  36   (destructuring-bind (kind what) tail
  37     (declare (ignore what))
  38     (list kind
  39           (symbolicate 'c- kind '-type)
  40           (symbolicate 'make- kind '-type))))
  41
  42 (defmethod form-list-exports ((head (eql 'sod:defctype)) tail)
  43   (destructuring-bind (names value &key export) tail
  44     (declare (ignore value))
  45     (let ((names (if (listp names) names (list names))))
  46       (and export
  47            (list* (symbolicate 'c-type- (car names)) names)))))
  48
  49 (defmethod form-list-exports ((head (eql 'sod:define-simple-c-type)) tail)
  50   (destructuring-bind (names type &key export) tail
  51     (declare (ignore type))
  52     (let ((names (if (listp names) names (list names))))
  53       (and export
  54            (list* (symbolicate 'c-type- (car names)) names)))))
  55
  56 (defmethod form-list-exports ((head (eql 'cl:macrolet)) tail)
  57   (mapcan #'form-exports (cdr tail)))
  58
  59 (defmethod form-list-exports ((head (eql 'cl:eval-when)) tail)
  60   (mapcan #'form-exports (cdr tail)))
  61
  62 (defmethod form-list-exports ((head (eql 'cl:progn)) tail)
  63   (mapcan #'form-exports tail))
  64
  65 (defgeneric form-exports (form)
  66   (:method (form) nil)
  67   (:method ((form cons)) (form-list-exports (car form) (cdr form))))
  68
  69 (defgeneric list-exports (thing))
  70
  71 (defmethod list-exports ((stream stream))
  72   (loop with eof = '#:eof
  73         for form = (read stream nil eof)
  74         until (eq form eof)
  75         when (consp form) nconc (form-exports form)))
  76
  77 (defmethod list-exports ((path pathname))
  78   (mapcar (lambda (each)
  79             (cons each (with-open-file (stream each) (list-exports stream))))
  80           (directory (merge-pathnames path #p"*.lisp"))))
  81
  82 (defmethod list-exports ((path string))
  83   (list-exports (pathname path)))
  84
  85 (defun list-exported-symbols (package)
  86   (sort (loop for s being the external-symbols of package collect s)
  87         #'string< :key #'symbol-name))
  88
  89 (defun find-symbol-homes (paths package)
  90   (let* ((symbols (list-exported-symbols package))
  91          (exports-alist (let ((*package* package))
  92                           (mapcan #'list-exports paths)))
  93          (homes (make-hash-table :test #'equal)))
  94     (dolist (assoc exports-alist)
  95       (let ((home (car assoc)))
  96         (dolist (symbol (cdr assoc))
  97           (let ((name (symbol-name symbol)))
  98             (unless (nth-value 1 (find-symbol name package))
  99               (format *error-output* ";; unexported: ~S~%" symbol))
 100             (setf (gethash name homes) home)))))
 101     (dolist (symbol symbols)
 102       (unless (gethash (symbol-name symbol) homes)
 103         (format *error-output* ";; mysterious: ~S~%" symbol)))
 104     exports-alist))
 105
 106 (defun boring-setf-expansion-p (symbol)
 107   (multiple-value-bind (temps args stores store fetch)
 108       (ignore-errors (get-setf-expansion (list symbol)))
 109     (declare (ignore temps args stores fetch))
 110     (and (consp store)
 111          (eq (car store) 'funcall)
 112          (consp (cdr store)) (consp (cadr store))
 113          (eq (caadr store) 'function)
 114          (let ((func (cadadr store)))
 115            (and (consp func) (consp (cdr func))
 116                 (eq (car func) 'setf))))))
 117
 118 (defun specialized-on-p (func arg what)
 119   (some (lambda (method)
 120           (let ((spec (nth arg (sb-mop:method-specializers method))))
 121             (and (typep spec 'sb-mop:eql-specializer)
 122                  (eql (sb-mop:eql-specializer-object spec) what))))
 123         (sb-mop:generic-function-methods func)))
 124
 125 (defun categorize (symbol)
 126   (let ((things nil))
 127     (when (boundp symbol)
 128       (push (if (constantp symbol) :constant :variable) things))
 129     (when (fboundp symbol)
 130       (push (cond ((macro-function symbol) :macro)
 131                   ((typep (fdefinition symbol) 'generic-function)
 132                    :generic)
 133                   (t :function))
 134             things)
 135       (when (or ;;(not (boring-setf-expansion-p symbol))
 136                 (ignore-errors (fdefinition (list 'setf symbol))))
 137         (push :setf things)))
 138     (when (find-class symbol nil)
 139       (push :class things))
 140     (when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol)
 141               (specialized-on-p #'sod:expand-c-type-form 0 symbol))
 142       (push :c-type things))
 143     (when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol)
 144               (specialized-on-p #'sod-parser:expand-parser-form 1 symbol))
 145       (push :parser things))
 146     (when (get symbol 'optparse::opthandler)
 147       (push :opthandler things))
 148     (when (get symbol 'optparse::optmacro)
 149       (push :optmacro things))
 150     (nreverse things)))
 151
 152 (defun categorize-symbols (paths package)
 153   (mapcar (lambda (assoc)
 154             (let ((home (car assoc))
 155                   (symbols (delete-duplicates
 156                             (sort (mapcan (lambda (sym)
 157                                             (multiple-value-bind
 158                                                 (symbol foundp)
 159                                                 (find-symbol
 160                                                  (symbol-name sym)
 161                                                  package)
 162                                               (and foundp (list symbol))))
 163                                           (cdr assoc))
 164                                   #'string< :key #'symbol-name))))
 165               (cons home (mapcar (lambda (symbol)
 166                                    (cons symbol (categorize symbol)))
 167                                  symbols))))
 168
 169           (find-symbol-homes paths package)))
 170
 171 (defun best-package-name (package)
 172   (car (sort (cons (package-name package)
 173                    (copy-list (package-nicknames package)))
 174              #'< :key #'length)))
 175
 176 (defvar charbuf-size 0)
 177
 178 (defun exported-symbol-p (symbol &optional (package (symbol-package symbol)))
 179   (and package
 180        (multiple-value-bind (sym how)
 181            (find-symbol (symbol-name symbol) package)
 182          (and (eq sym symbol)
 183               (eq how :external)))))
 184
 185 (defun pretty-symbol-name (symbol package)
 186   (let ((pkg (symbol-package symbol))
 187         (exportp (exported-symbol-p symbol)))
 188     (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)"
 189             (and exportp (eq pkg package))
 190             (cond ((keywordp symbol) "")
 191                   ((eq pkg nil) "#")
 192                   (t (best-package-name pkg)))
 193             (or exportp (null pkg)) (symbol-name symbol))))
 194
 195 (defun analyse-classes (package)
 196   (setf package (find-package package))
 197   (let ((classes (mapcan (lambda (symbol)
 198                            (let ((class (find-class symbol nil)))
 199                              (and class
 200                                   (typep class '(or standard-class
 201                                                  structure-class))
 202                                   (list class))))
 203                          (list-exported-symbols package)))
 204         (subs (make-hash-table)))
 205     (let ((done (make-hash-table)))
 206       (labels ((walk-up (class)
 207                  (unless (gethash class done)
 208                    (dolist (super (sb-mop:class-direct-superclasses class))
 209                      (push class (gethash super subs))
 210                      (walk-up super))
 211                    (setf (gethash class done) t))))
 212         (dolist (class classes)
 213           (walk-up class))))
 214     (labels ((walk-down (this super depth)
 215                (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%"
 216                        (* 2 depth)
 217                        (pretty-symbol-name (class-name this) package)
 218                        (mapcar (lambda (class)
 219                                  (pretty-symbol-name (class-name class)
 220                                                      package))
 221                                (remove super
 222                                        (sb-mop:class-direct-superclasses this))))
 223                (dolist (sub (sort (copy-list (gethash this subs))
 224                                   #'string< :key #'class-name))
 225                  (walk-down sub this (1+ depth)))))
 226       (walk-down (find-class t) nil 0))))
 227
 228 (defmacro deep-compare ((left right) &body body)
 229   (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-"))
 230         (l (gensym "LEFT-")) (r (gensym "RIGHT-")))
 231     `(macrolet ((focus (expr &body body)
 232                   `(flet ((,',func (it) ,expr))
 233                      (let ((,',l (,',func ,',l))
 234                            (,',r (,',func ,',r)))
 235                        ,@body)))
 236                 (update (expr)
 237                   `(flet ((,',func (it) ,expr))
 238                      (psetf ,',l (,',func ,',l)
 239                             ,',r (,',func ,',r))))
 240                 (compare (expr)
 241                   `(cond ((let ((left ,',l) (right ,',r)) ,expr)
 242                           (return-from ,',block t))
 243                          ((let ((right ,',l) (left ,',r)) ,expr)
 244                           (return-from ,',block nil))))
 245                 (typesw (&rest clauses)
 246                   (labels ((iter (clauses)
 247                              (if (null clauses)
 248                                  'nil
 249                                  (destructuring-bind (type &rest body)
 250                                      (car clauses)
 251                                    (if (eq type t)
 252                                        `(progn ,@body)
 253                                        `(if (typep ,',l ',type)
 254                                             (if (typep ,',r ',type)
 255                                                 (progn ,@body)
 256                                                 (return-from ,',block t))
 257                                             (if (typep ,',r ',type)
 258                                                 (return-from ,',block nil)
 259                                                 ,(iter (cdr clauses)))))))))
 260                     (iter clauses))))
 261        (let ((,l ,left) (,r ,right))
 262          (block ,block
 263            ,@body)))))
 264
 265 (defun order-specializers (la lb)
 266   (deep-compare (la lb)
 267     (loop (typesw (null (return nil)))
 268           (focus (car it)
 269             (typesw (sb-mop:eql-specializer
 270                      (focus (sb-mop:eql-specializer-object it)
 271                        (typesw (keyword
 272                                 (compare (string< left right)))
 273                                (symbol
 274                                 (focus (package-name (symbol-package it))
 275                                   (compare (string< left right)))
 276                                 (compare (string< left right)))
 277                                (t
 278                                 (focus (with-output-to-string (out)
 279                                          (prin1 it out)
 280                                          (write-char #\nul))
 281                                   (compare (string< left right)))))))
 282                     (class
 283                      (focus (class-name it)
 284                        (focus (package-name (symbol-package it))
 285                          (compare (string< left right)))
 286                        (compare (string< left right))))
 287                     (t
 288                      (error "unexpected things"))))
 289           (update (cdr it)))))
 290
 291 (defun analyse-generic-functions (package)
 292   (setf package (find-package package))
 293   (flet ((function-name-core (name)
 294            (etypecase name
 295              (symbol name)
 296              ((cons (eql setf) t) (cadr name)))))
 297     (let ((methods (make-hash-table))
 298           (functions (make-hash-table))
 299           (externs (make-hash-table)))
 300       (dolist (symbol (list-exported-symbols package))
 301         (setf (gethash symbol externs) t))
 302       (dolist (symbol (list-exported-symbols package))
 303         (flet ((dofunc (func)
 304                  (when (typep func 'generic-function)
 305                    (setf (gethash func functions) t)
 306                    (dolist (method (sb-mop:generic-function-methods func))
 307                      (setf (gethash method methods) t)))))
 308           (dofunc (and (fboundp symbol) (fdefinition symbol)))
 309           (dofunc (ignore-errors (fdefinition (list 'setf symbol)))))
 310         (when (eq (symbol-package symbol) package)
 311           (let ((class (find-class symbol nil)))
 312             (when class
 313               (dolist
 314                   (func (sb-mop:specializer-direct-generic-functions class))
 315                 (let ((name (function-name-core
 316                              (sb-mop:generic-function-name func))))
 317                   (when (or (not (eq (symbol-package name) package))
 318                             (gethash name externs))
 319                     (setf (gethash func functions) t)
 320                     (dolist (method (sb-mop:specializer-direct-methods class))
 321                       (setf (gethash method methods) t)))))))))
 322       (let ((funclist nil))
 323         (maphash (lambda (func value)
 324                    (declare (ignore value))
 325                    (push func funclist))
 326                  functions)
 327         (setf funclist (sort funclist
 328                              (lambda (a b)
 329                                (let ((core-a (function-name-core a))
 330                                      (core-b (function-name-core b)))
 331                                  (if (eq core-a core-b)
 332                                      (and (atom a) (consp b))
 333                                      (string< core-a core-b))))
 334                              :key #'sb-mop:generic-function-name))
 335         (dolist (function funclist)
 336           (let ((name (sb-mop:generic-function-name function)))
 337             (etypecase name
 338               (symbol
 339                (format t "~A~%" (pretty-symbol-name name package)))
 340               ((cons (eql setf) t)
 341                (format t "(setf ~A)~%"
 342                        (pretty-symbol-name (cadr name) package)))))
 343           (dolist (method (sort (copy-list
 344                                  (sb-mop:generic-function-methods function))
 345                                 #'order-specializers
 346                                 :key #'sb-mop:method-specializers))
 347             (when (gethash method methods)
 348               (format t "~2T~{~A~^ ~}~%"
 349                       (mapcar
 350                        (lambda (spec)
 351                          (etypecase spec
 352                            (class
 353                             (let ((name (class-name spec)))
 354                               (if (eq name t) "t"
 355                                   (pretty-symbol-name name package))))
 356                            (sb-mop:eql-specializer
 357                             (let ((obj (sb-mop:eql-specializer-object spec)))
 358                               (format nil "(eql ~A)"
 359                                       (if (symbolp obj)
 360                                           (pretty-symbol-name obj package)
 361                                           obj))))))
 362                        (sb-mop:method-specializers method))))))))))
 363
 364 (defun check-slot-names (package)
 365   (setf package (find-package package))
 366   (let* ((symbols (list-exported-symbols package))
 367          (classes (mapcan (lambda (symbol)
 368                             (when (eq (symbol-package symbol) package)
 369                               (let ((class (find-class symbol nil)))
 370                                 (and class (list class)))))
 371                           symbols))
 372          (offenders (mapcan
 373                      (lambda (class)
 374                        (let* ((slot-names
 375                                (mapcar #'sb-mop:slot-definition-name
 376                                        (sb-mop:class-direct-slots class)))
 377                               (exported (remove-if
 378                                          (lambda (sym)
 379                                            (or (not (symbol-package sym))
 380                                                (and (not (exported-symbol-p
 381                                                           sym))
 382                                                     (eq (symbol-package sym)
 383                                                         package))))
 384                                          slot-names)))
 385                          (and exported
 386                               (list (cons (class-name class)
 387                                           exported)))))
 388                             classes))
 389          (bad-words (remove-duplicates (mapcan (lambda (list)
 390                                                  (copy-list (cdr list)))
 391                                                offenders))))
 392     (values offenders bad-words)))
 393
 394 (defun report-symbols (paths package)
 395   (setf package (find-package package))
 396   (format t "~A~%Package `~(~A~)'~2%"
 397           (make-string 77 :initial-element #\-)
 398           (package-name package))
 399   (dolist (assoc (sort (categorize-symbols paths package) #'string<
 400                        :key (lambda (assoc)
 401                               (file-namestring (car assoc)))))
 402     (when (cdr assoc)
 403       (format t "~A~%" (file-namestring (car assoc)))
 404       (dolist (def (cdr assoc))
 405         (let ((sym (car def)))
 406           (format t "  ~A~@[~48T~{~(~A~)~^ ~}~]~%"
 407                   (pretty-symbol-name sym package)
 408                   (cdr def))))
 409       (terpri)))
 410   (multiple-value-bind (alist names) (check-slot-names package)
 411     (when names
 412       (format t "Leaked slot names: ~{~A~^, ~}~%"
 413               (mapcar (lambda (name) (pretty-symbol-name name package))
 414                       names))
 415       (dolist (assoc alist)
 416         (format t "~2T~A: ~{~A~^, ~}~%"
 417                 (pretty-symbol-name (car assoc) package)
 418                 (mapcar (lambda (name) (pretty-symbol-name name package))
 419                         (cdr assoc))))
 420       (terpri)))
 421   (format t "Classes:~%")
 422   (analyse-classes package)
 423   (terpri)
 424   (format t "Methods:~%")
 425   (analyse-generic-functions package)
 426   (terpri))
 427
 428 (export 'report-project-symbols)
 429 (defun report-project-symbols ()
 430   (labels ((components (comp)
 431              (slot-value comp 'asdf::components))
 432            (files (comp)
 433              (sort (remove-if-not (lambda (comp)
 434                                     (typep comp 'asdf:cl-source-file))
 435                                   (components comp))
 436                    #'string< :key #'asdf:component-name))
 437            (by-name (comp name)
 438              (find name (components comp)
 439                    :test #'string= :key #'asdf:component-name))
 440            (file-name (file)
 441              (slot-value file 'asdf::absolute-pathname)))
 442   (let* ((sod (asdf:find-system "sod"))
 443          (parser-files (files (by-name sod "parser")))
 444          (utilities (by-name sod "utilities"))
 445          (sod-frontend (asdf:find-system "sod-frontend"))
 446          (optparse (by-name sod-frontend "optparse"))
 447          (frontend (by-name sod-frontend "frontend"))
 448          (sod-files (set-difference (files sod) (list utilities))))
 449     (report-symbols (mapcar #'file-name sod-files) "SOD")
 450     (report-symbols (mapcar #'file-name (list frontend)) "SOD-FRONTEND")
 451     (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER")
 452     (report-symbols (mapcar #'file-name (list optparse)) "OPTPARSE")
 453     (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES"))))
 454
 455 #+interactive
 456 (with-open-file (*standard-output* #p"doc/SYMBOLS" :direction :output
 457                  :if-exists :supersede :if-does-not-exist :create)
 458   (report-project-symbols))