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

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