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