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

   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 ;; Load the target system so that we can poke about in it.
  12 (cl:in-package #:sod-exports)
  13 (eval-when (:compile-toplevel :load-toplevel :execute)
  14   (mapc #'asdf:load-system '(:sod :sod-frontend)))
  15
  16 ;;;--------------------------------------------------------------------------
  17 ;;; Miscelleneous utilities.
  18
  19 (defun symbolicate (&rest things)
  20   "Concatenate the THINGS and turn the result into a symbol."
  21   (intern (apply #'concatenate 'string (mapcar #'string things))))
  22
  23 ;;;--------------------------------------------------------------------------
  24 ;;; Determining the symbols exported by particular files.
  25
  26 (defun incomprehensible-form (head tail)
  27   "Report an incomprehensible form (HEAD . TAIL)."
  28   (format *error-output* ";; incomprehensible: ~S~%" (cons head tail)))
  29
  30 (defgeneric form-list-exports (head tail)
  31   (:documentation
  32    "Return a list of symbols exported by the form (HEAD . TAIL).
  33
  34    This is called from `form-exports' below.")
  35   (:method (head tail)
  36     "By default, a form exports nothing."
  37     (declare (ignore head tail))
  38     nil))
  39
  40 (defmethod form-list-exports ((head (eql 'cl:export)) tail)
  41   "Return the symbols exported by a toplevel `export' form.
  42
  43    We can cope with (export 'SYMBOLS), where SYMBOLS is a symbol or a list."
  44
  45   (let ((symbols (car tail)))
  46     (if (and (consp symbols)
  47              (eq (car symbols) 'quote))
  48         (let ((thing (cadr symbols)))
  49           (if (atom thing) (list thing) thing))
  50         (incomprehensible-form head tail))))
  51
  52 (defmethod form-list-exports ((head (eql 'sod:definst)) tail)
  53   "Return the symbols exported by a `form-list-exports' form.
  54
  55    The syntax is:
  56
  57         (definst CODE (STREAMVAR [[:export FLAG]]) ARGS
  58           FORM*)
  59
  60    If FLAG is non-nil, then we export `CODE-inst', `make-CODE-inst', and
  61    `inst-ARG' for each argument ARG in the lambda-list ARGS.  There are some
  62    quirks in this lambda-list:
  63
  64      * If we find a list (PUBLIC PRIVATE) where we expected an argument-name
  65        symbol (but not a list), then the argument is PUBLIC.  (PRIVATE is
  66        used to name a slot in the class created by the macro, presumably
  67        because PUBLIC on its own is a public symbol in some package.)
  68
  69      * If we find a symbol %NAME, this means the same as the list (NAME
  70        %NAME), only we recognize it even where the lambda-list syntax expects
  71        a list."
  72
  73   (destructuring-bind (code (streamvar &key export) args &body body) tail
  74     (declare (ignore streamvar body))
  75
  76     (and export
  77          (list* (symbolicate code '-inst)
  78                 (symbolicate 'make- code '-inst)
  79
  80                 (labels ((dig (tree path)
  81                            ;; Dig down into a TREE, following the PATH.  Stop
  82                            ;; when we find an atom, or reach the end of the
  83                            ;; path.
  84                            (if (or (atom tree) (null path)) tree
  85                                (dig (nth (car path) tree) (cdr path))))
  86                          (cook (arg)
  87                            ;; Convert an ARG name which might start with `%'.
  88                            (if (consp arg) (car arg)
  89                                (let ((name (symbol-name arg)))
  90                                  (if (char= (char name 0) #\%)
  91                                      (intern (subseq name 1))
  92                                      arg))))
  93                          (instify (arg)
  94                            ;; Convert ARG name into the `inst-ARG' accessor.
  95                            (symbolicate 'inst- (cook arg))))
  96
  97                   ;; Work through the lambda-list, keeping track of where we
  98                   ;; expect the argument symbols to be.
  99                   (loop with state = :mandatory
 100                         for arg in args
 101                         if (and (symbolp arg)
 102                                 (char= (char (symbol-name arg) 0) #\&))
 103                           do (setf state arg)
 104                         else if (member state '(:mandatory &rest))
 105                           collect (instify arg)
 106                         else if (member state '(&optional &aux))
 107                           collect (instify (dig arg '(0)))
 108                         else if (eq state '&key)
 109                           collect (instify (dig arg '(0 1)))
 110                         else
 111                           do (error "Confused by ~S." arg)))))))
 112
 113 (defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail)
 114   "Return the symbols exported by a `define-tagged-type' form.
 115
 116    This is a scummy internal macro in `c-types-impl.lisp'.  The syntax is
 117
 118         (define-tagged-type KIND DESCRIPTION)
 119
 120    It exports `KIND' and `make-KIND'."
 121
 122   (destructuring-bind (kind what) tail
 123     (declare (ignore what))
 124     (list kind
 125           (symbolicate 'c- kind '-type)
 126           (symbolicate 'make- kind '-type))))
 127
 128 (defmethod form-list-exports ((head (eql 'sod:defctype)) tail)
 129   "Return the symbols exported by a `defctype' form.
 130
 131    The syntax is:
 132
 133         (defctype {NAME | (NAME SYNONYM*)} VALUE [[:export FLAG]])
 134
 135    If FLAG is non-nil, this form exports `c-type-NAME', `NAME', and all of
 136    the `SYNONYM's."
 137
 138   (destructuring-bind (names value &key export) tail
 139     (declare (ignore value))
 140     (let ((names (if (listp names) names (list names))))
 141       (and export
 142            (list* (symbolicate 'c-type- (car names)) names)))))
 143
 144 (defmethod form-list-exports ((head (eql 'sod:define-simple-c-type)) tail)
 145   "Return the symbols exported by a `define-simple-c-type' form.
 146
 147    The syntax is:
 148
 149         (define-simple-c-type {NAME | (NAME SYNONYM*)} TYPE [[:export FLAG]])
 150
 151    If FLAG is non-nil, this form exports `c-type-NAME', `NAME', and all of
 152    the `SYNONYM's."
 153
 154   (destructuring-bind (names type &key export) tail
 155     (declare (ignore type))
 156     (let ((names (if (listp names) names (list names))))
 157       (and export
 158            (list* (symbolicate 'c-type- (car names)) names)))))
 159
 160 (defmethod form-list-exports ((head (eql 'cl:macrolet)) tail)
 161   "Return the symbols expored by a toplevel `macrolet' form.
 162
 163    Which are simply the symbols exported by its body."
 164   (mapcan #'form-exports (cdr tail)))
 165
 166 (defmethod form-list-exports ((head (eql 'cl:eval-when)) tail)
 167   "Return the symbols expored by a toplevel `eval-when' form.
 168
 169    Which are simply the symbols exported by its body."
 170
 171   ;; We don't bother checking when it'd actually be evaluated.
 172   (mapcan #'form-exports (cdr tail)))
 173
 174 (defmethod form-list-exports ((head (eql 'cl:progn)) tail)
 175   "Return the symbols expored by a toplevel `progn' form.
 176
 177    Which are simply the symbols exported by its body."
 178   (mapcan #'form-exports tail))
 179
 180 (defgeneric form-exports (form)
 181   (:documentation
 182    "Return a list of symbols exported by a toplevel FORM.")
 183   (:method (form) nil)
 184   (:method ((form cons)) (form-list-exports (car form) (cdr form))))
 185
 186 (defgeneric list-exports (thing)
 187   (:documentation
 188    "Return a list of symbols exported by THING."))
 189
 190 (defmethod list-exports ((stream stream))
 191   "Return a list of symbols exported by a STREAM.
 192
 193    By reading it and analysing the forms."
 194
 195   (loop with eof = '#:eof
 196         for form = (read stream nil eof)
 197         until (eq form eof)
 198         when (consp form) nconc (form-exports form)))
 199
 200 (defmethod list-exports ((path pathname))
 201   "Return a list of symbols exported by a directory PATHNAME.
 202
 203    Return an alist of pairs (PATH . SYMBOL) listing each SYMBOL exported by a
 204    PATH of the form PATHNAME/*.lisp."
 205
 206   (mapcar (lambda (each)
 207             (cons each (with-open-file (stream each) (list-exports stream))))
 208           (directory (merge-pathnames path #p"*.lisp"))))
 209
 210 (defmethod list-exports ((path string))
 211   "Return a list of symbols exported by a PATH string.
 212
 213    By converting it into a pathname."
 214
 215   (list-exports (pathname path)))
 216
 217 (defun list-exported-symbols (package)
 218   "Return a sorted list of symbols exported by PACKAGE."
 219   (sort (loop for s being the external-symbols of package collect s)
 220         #'string< :key #'symbol-name))
 221
 222 (defun list-all-symbols (package)
 223   "Return a sorted list of all symbols exported by or private to PACKAGE."
 224   (let ((externs (make-hash-table)))
 225     (dolist (sym (list-exported-symbols package))
 226       (setf (gethash sym externs) t))
 227     (sort (loop for s being the symbols of package
 228                 when (or (not (exported-symbol-p s))
 229                          (gethash s externs))
 230                   collect s)
 231           #'string< :key #'symbol-name)))
 232
 233 (defun find-symbol-homes (paths package)
 234   "Determine the `home' file for the symbols exported by PACKAGE.
 235
 236    Return an alist of pairs (PATH . SYMBOL) listing each SYMBOL exported by a
 237    PATH of the form PATHNAME/*.lisp where PATHNAME is a member of PATHS.  Do
 238    this by finding all the files and parsing them (somewhat superficially),
 239    and cross-checking the result against the actual symbols exported by the
 240    PACKAGE."
 241
 242   ;; Building the alist is exactly what `list-exports' is for.  The rest of
 243   ;; this function is the cross-checking.
 244   (let* ((symbols (list-exported-symbols package))
 245          (exports-alist (let ((*package* package))
 246                           (mapcan #'list-exports paths)))
 247          (homes (make-hash-table :test #'equal)))
 248
 249     ;; Work through the alist recording where we found each symbol.  Check
 250     ;; that they're actually exported by poking at the package.
 251     (dolist (assoc exports-alist)
 252       (let ((home (car assoc)))
 253         (dolist (symbol (cdr assoc))
 254           (let ((name (symbol-name symbol)))
 255             (unless (nth-value 1 (find-symbol name package))
 256               (format *error-output* ";; unexported: ~S~%" symbol))
 257             (setf (gethash name homes) home)))))
 258
 259     ;; Check that all of the symbols exported by the package are accounted
 260     ;; for in our alist.
 261     (dolist (symbol symbols)
 262       (unless (gethash (symbol-name symbol) homes)
 263         (format *error-output* ";; mysterious: ~S~%" symbol)))
 264
 265     ;; We're done.
 266     exports-alist))
 267
 268 ;;;--------------------------------------------------------------------------
 269 ;;; Determining the kinds of definitions attached to symbols.
 270
 271 (defun boring-setf-expansion-p (symbol)
 272   "Return non-nil if SYMBOL has a trivial `setf' expansion.
 273
 274    i.e., (setf (SYMBOL ...) ...) works by (funcall #'(setf SYMBOL) ...)."
 275
 276   (multiple-value-bind (temps args stores store fetch)
 277       (ignore-errors (get-setf-expansion (list symbol)))
 278     (declare (ignore temps args stores fetch))
 279     (and (consp store)
 280          (eq (car store) 'funcall)
 281          (consp (cdr store)) (consp (cadr store))
 282          (eq (caadr store) 'function)
 283          (let ((func (cadadr store)))
 284            (and (consp func) (consp (cdr func))
 285                 (eq (car func) 'setf))))))
 286
 287 (defun specialized-on-p (func arg what)
 288   "Check whether FUNC has a method specialized for the symbol WHAT.
 289
 290    We assume FUNC is a (well-known) generic function.  ARG is a small integer
 291    identifying one of FUNC's mandatory arguments.  Return non-nil if FUNC has
 292    a method for which this ARG is `eql'-specialized on WHAT."
 293
 294   (some (lambda (method)
 295           (let ((spec (nth arg (method-specializers method))))
 296             (and (typep spec 'eql-specializer)
 297                  (eql (eql-specializer-object spec) what))))
 298         (generic-function-methods func)))
 299
 300 (defun categorize (symbol)
 301   "Determine what things SYMBOL is defined to do.
 302
 303    Return a list of keywords:
 304
 305      * :constant -- SYMBOL's value cell is `boundp' and `constantp'
 306      * :variable -- SYMBOL's value cell is `boundp' but not `constantp'
 307      * :macro -- SYMBOL's function cell is `macro-function'
 308      * :generic -- SYMBOL's function cell is a `generic-function'
 309      * :function -- SYMBOL's function cell is a non-generic `function'
 310      * :setf-generic -- (setf SYMBOL) is a `generic-function'
 311      * :setf-function -- (setf SYMBOL) is a non-generic `function'
 312      * :class -- SYMBOL is `find-class'
 313      * :c-type -- `expand-c-type-spec' or `expand-c-type-form' has a method
 314        specialized on SYMBOL
 315      * :parser -- `expand-parser-spec' or `expand-parser-form' has a method
 316        specialized on SYMBOL
 317      * :opthandler -- SYMBOL has an `opthandler' property
 318      * :optmacro -- SYMBOL has an `optmacro' property
 319
 320    categorizing the kinds of definitions that SYMBOL has."
 321
 322   (let ((things nil))
 323     (when (boundp symbol)
 324       (push (if (constantp symbol) :constant :variable) things))
 325     (when (fboundp symbol)
 326       (push (cond ((macro-function symbol) :macro)
 327                   ((typep (fdefinition symbol) 'generic-function)
 328                    :generic)
 329                   (t :function))
 330             things)
 331       (etypecase (ignore-errors (fdefinition (list 'setf symbol)))
 332         (generic-function (push :setf-generic things))
 333         (function (push :setf-function things))
 334         (null)))
 335     (when (find-class symbol nil)
 336       (push :class things))
 337     (when (specialized-on-p #'sod:expand-c-type-spec 0 symbol)
 338       (push :c-type-spec things))
 339     (when (specialized-on-p #'sod:expand-c-type-form 0 symbol)
 340       (push :c-type-form things))
 341     (when (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol)
 342       (push :parser-spec things))
 343     (when (specialized-on-p #'sod-parser:expand-parser-form 1 symbol)
 344       (push :parser-form things))
 345     (when (get symbol 'optparse::opthandler)
 346       (push :opthandler things))
 347     (when (get symbol 'optparse::optmacro)
 348       (push :optmacro things))
 349     (nreverse things)))
 350
 351 (defun categorize-symbols (paths package)
 352   "Return a categorized list of the symbols exported by PACKAGE.
 353
 354    Return an alist of PAIRS (PATH . SYMBOLS), for each PATH in PATHS, where
 355    SYMBOLS is itself an alist (SYMBOL . KEYWORDS) listing the kinds of
 356    definitions that SYMBOL has (see `categorize')."
 357   (mapcar (lambda (assoc)
 358             (let ((home (car assoc))
 359                   (symbols (delete-duplicates
 360                             (sort (mapcan (lambda (sym)
 361                                             (multiple-value-bind
 362                                                 (symbol foundp)
 363                                                 (find-symbol
 364                                                  (symbol-name sym)
 365                                                  package)
 366                                               (and foundp (list symbol))))
 367                                           (cdr assoc))
 368                                   #'string< :key #'symbol-name))))
 369               (cons home (mapcar (lambda (symbol)
 370                                    (cons symbol (categorize symbol)))
 371                                  symbols))))
 372           (find-symbol-homes paths package)))
 373
 374 ;;;--------------------------------------------------------------------------
 375 ;;; Reporting.
 376
 377 (defun best-package-name (package)
 378   "Return a convenient name for PACKAGE."
 379
 380   ;; We pick the shortest one.  Strangely, there's no `find minimal thing
 381   ;; according to this valuation' function in Common Lisp.
 382   (loop with best = (package-name package)
 383         with best-length = (length best)
 384         for name in (package-nicknames package)
 385         for name-length = (length name)
 386         when (< name-length best-length)
 387           do (setf best name
 388                    best-length name-length)
 389         finally (return best)))
 390
 391 (defvar charbuf-size 0)
 392
 393 (defun exported-symbol-p (symbol &optional (package (symbol-package symbol)))
 394   "Return whether SYMBOL is exported by PACKAGE.
 395
 396    PACKAGE default's to the SYMBOL's home package, but may be different."
 397   (and package
 398        (multiple-value-bind (sym how)
 399            (find-symbol (symbol-name symbol) package)
 400          (and (eq sym symbol)
 401               (eq how :external)))))
 402
 403 (defun downcase-or-escape (name)
 404   "Return a presentable form for a symbol or package name.
 405
 406    If NAME consists only of uppercase letters and ordinary punctuation, then
 407    return NAME in lowercase; otherwise wrap it in `|...|' and escape as
 408    necessary."
 409
 410   (if (every (lambda (char)
 411                (or (upper-case-p char)
 412                    (digit-char-p char)
 413                    (member char '(#\% #\+ #\- #\* #\/ #\= #\[ #\] #\?))))
 414              name)
 415       (string-downcase name)
 416       (with-output-to-string (out)
 417         (write-char #\| out)
 418         (map nil (lambda (char)
 419                    (when (or (char= char #\|)
 420                              (char= char #\\))
 421                      (write-char #\\ out))
 422                    (write-char char out))
 423              name)
 424         (write-char #\| out))))
 425
 426 (defun pretty-symbol-name (symbol package)
 427   "Return a presentable form for SYMBOL, relative to PACKAGE.
 428
 429    If SYMBOL is exported by PACKAGE then just write the SYMBOL's name
 430    otherwise prefix the name with the SYMBOL's home package name, separated
 431    joined with one or two colons.  Uninterned symbols and keywords are also
 432    printed specially."
 433
 434   (let ((pkg (symbol-package symbol))
 435         (exportp (exported-symbol-p symbol)))
 436     (format nil "~:[~A:~:[:~;~]~;~2*~]~A"
 437             (and exportp (eq pkg package))
 438             (cond ((keywordp symbol) "")
 439                   ((eq pkg nil) "#")
 440                   (t (downcase-or-escape (best-package-name pkg))))
 441             (or exportp (null pkg))
 442             (downcase-or-escape (symbol-name symbol)))))
 443
 444 (deftype interesting-class ()
 445   "The type of `interesting' classes, which might be user-defined."
 446   '(or standard-class
 447        structure-class
 448        #.(class-name (class-of (find-class 'condition)))))
 449
 450 (defun analyse-classes (package)
 451   "Print a report on the classes defined by PACKAGE."
 452
 453   ;; Canonify PACKAGE into a package object.
 454   (setf package (find-package package))
 455
 456   (let ((classes (mapcan (lambda (symbol)
 457                            (let ((class (find-class symbol nil)))
 458                              (and class
 459                                   (typep class 'interesting-class)
 460                                   (list class))))
 461                          (list-exported-symbols package)))
 462         (subs (make-hash-table)))
 463     ;; CLASSES is a list of the `interesting' classes defined by (i.e., whose
 464     ;; names are exported by) PACKAGE.  SUBS maps a class to those of its
 465     ;; direct subclasses which are relevant to our report.
 466
 467     ;; Populate the SUBS table.
 468     (let ((done (make-hash-table)))
 469       (labels ((walk-up (class)
 470                  (unless (gethash class done)
 471                    (dolist (super (class-direct-superclasses class))
 472                      (push class (gethash super subs))
 473                      (walk-up super))
 474                    (setf (gethash class done) t))))
 475         (dolist (class classes)
 476           (walk-up class))))
 477
 478     (labels ((walk-down (this super depth)
 479                ;; Recursively traverse the class graph from THIS, recalling
 480                ;; that our parent is SUPER, and that we are DEPTH levels
 481                ;; down.
 482
 483                (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%"
 484                        (* 2 depth)
 485                        (pretty-symbol-name (class-name this) package)
 486                        (mapcar (lambda (class)
 487                                  (pretty-symbol-name (class-name class)
 488                                                      package))
 489                                (remove super
 490                                        (class-direct-superclasses this))))
 491                (dolist (sub (sort (copy-list (gethash this subs))
 492                                   #'string< :key #'class-name))
 493                  (walk-down sub this (1+ depth)))))
 494
 495       ;; Print the relevant fragment of the class graph.
 496       (walk-down (find-class t) nil 0))))
 497
 498 (defmacro deep-compare ((left right) &body body)
 499   "Helper macro for traversing two similar objects in parallel.
 500
 501    Specifically it's good at defining complex structural ordering relations,
 502    answering the question: is the LEFT value strictly less than the RIGHT
 503    value.
 504
 505    Evaluate the BODY forms, maintaining a pair of `cursors', initially at the
 506    LEFT and RIGHT values.
 507
 508    The following local macros are defined to do useful things.
 509
 510      * (focus EXPR . BODY) -- EXPR is an expression in terms of `it': advance
 511        each of the cursors to the result of evaluating this expression, with
 512        `it' bound to the current cursor value, and evaluate the BODY in the
 513        resulting environment.
 514
 515      * (update EXPR) -- as `focus', but mutate the cursors rather than
 516        binding them.
 517
 518      * (compare EXPR) -- EXPR is an expression in terms of the literal
 519        symbols `left' and `right', which returns non-nil if it thinks `left'
 520        is (strictly) less than `right' in some sense: evaluate this both ways
 521        round, and return if LEFT is determined to be less than or greater
 522        than RIGHT.
 523
 524      * (typesw (TYPE . BODY)*) -- process each clause in turn: if the left
 525        cursor value has TYPE, but the right does not, then LEFT is less than
 526        RIGHT; if the right cursor value has TYPE but the left does not, then
 527        LEFT is greater than RIGHT; otherwise, evaluate BODY."
 528
 529   (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-"))
 530         (l (gensym "LEFT-")) (r (gensym "RIGHT-")))
 531     `(macrolet ((focus (expr &body body)
 532                   `(flet ((,',func (it) ,expr))
 533                      (let ((,',l (,',func ,',l))
 534                            (,',r (,',func ,',r)))
 535                        ,@body)))
 536                 (update (expr)
 537                   `(flet ((,',func (it) ,expr))
 538                      (psetf ,',l (,',func ,',l)
 539                             ,',r (,',func ,',r))))
 540                 (compare (expr)
 541                   `(cond ((let ((left ,',l) (right ,',r)) ,expr)
 542                           (return-from ,',block t))
 543                          ((let ((right ,',l) (left ,',r)) ,expr)
 544                           (return-from ,',block nil))))
 545                 (typesw (&rest clauses)
 546                   (labels ((iter (clauses)
 547                              (if (null clauses)
 548                                  'nil
 549                                  (destructuring-bind (type &rest body)
 550                                      (car clauses)
 551                                    (if (eq type t)
 552                                        `(progn ,@body)
 553                                        `(if (typep ,',l ',type)
 554                                             (if (typep ,',r ',type)
 555                                                 (progn ,@body)
 556                                                 (return-from ,',block t))
 557                                             (if (typep ,',r ',type)
 558                                                 (return-from ,',block nil)
 559                                                 ,(iter (cdr clauses)))))))))
 560                     (iter clauses))))
 561        (let ((,l ,left) (,r ,right))
 562          (block ,block
 563            ,@body)))))
 564
 565 (defun order-specializers (la lb)
 566   "Return whether specializers LA should be sorted before LB."
 567
 568   (deep-compare (la lb)
 569     ;; Iterate over the two lists.  The cursors advance down the spine, and
 570     ;; we focus on each car in turn.
 571
 572     (loop
 573       (typesw (null (return nil)))
 574       ;; If one list reaches the end, then it's lesser; if both, they're
 575       ;; equal.
 576
 577       (focus (car it)
 578         ;; Examine the two specializers at this position.
 579
 580         (typesw (eql-specializer
 581                  (focus (eql-specializer-object it)
 582                    ;; We found an `eql' specializer.  Compare the objects.
 583
 584                    (typesw (keyword
 585                             ;; Keywords compare by name.
 586
 587                             (compare (string< left right)))
 588
 589                            (symbol
 590                             ;; Symbols compare by package and name.
 591
 592                             (focus (package-name (symbol-package it))
 593                               (compare (string< left right)))
 594                             (compare (string< left right)))
 595
 596                            (t
 597                             ;; Compare two other objects by comparing their
 598                             ;; string representations.
 599
 600                             (focus (with-output-to-string (out)
 601                                      (prin1 it out)
 602                                      (write-char #\nul))
 603                               (compare (string< left right)))))))
 604
 605                 (class
 606                  ;; We found a class,   Compare the class names.
 607                  (focus (class-name it)
 608                    (focus (package-name (symbol-package it))
 609                      (compare (string< left right)))
 610                    (compare (string< left right))))
 611
 612                 (t
 613                  ;; We found some other kind of specializer that we don't
 614                  ;; understand.
 615
 616                  (error "unexpected things"))))
 617
 618       ;; No joy with that pair of specializers: try the next.
 619       (update (cdr it)))))
 620
 621 (defun analyse-generic-functions (package)
 622   "Print a report of the generic functions and methods defined by PACKAGE."
 623
 624   ;; Canonify package into a package object.
 625   (setf package (find-package package))
 626
 627   (flet ((function-name-core (name)
 628            ;; Return the underlying name for a function NAME.  Specifically,
 629            ;; if NAME is (setf THING) then the core is THING; if NAME is a
 630            ;; symbol then the core is simply NAME; otherwise we're confused.
 631            ;; Return a second value to say whether we got the job done.
 632
 633            (typecase name
 634              (symbol (values name t))
 635              ((cons (eql setf) t) (values (cadr name) t))
 636              (t (values nil nil)))))
 637
 638     (let ((methods (make-hash-table))
 639           (functions (make-hash-table))
 640           (externs (make-hash-table)))
 641       ;; EXTERNS is a set of the symbols exported by PACKAGE.  FUNCTIONS and
 642       ;; METHODS are sets of generic function names (not cores), and method
 643       ;; objects, which we've decided are worth reporting.
 644
 645       ;; Collect the EXTERNS symbols.
 646       (dolist (symbol (list-exported-symbols package))
 647         (setf (gethash symbol externs) t))
 648
 649       ;; Collect the FUNCTIONS and METHODS.
 650       (dolist (symbol (list-exported-symbols package))
 651
 652         ;; Mark the generic functions and `setf'-functions named by exported
 653         ;; symbols as interesting, along with all of their methods.
 654         (flet ((dofunc (func)
 655                  (when (typep func 'generic-function)
 656                    (setf (gethash func functions) t)
 657                    (dolist (method (generic-function-methods func))
 658                      (setf (gethash method methods) t)))))
 659           (dofunc (and (fboundp symbol) (fdefinition symbol)))
 660           (dofunc (ignore-errors (fdefinition (list 'setf symbol)))))
 661
 662         ;; For symbols whose home package is PACKAGE, and which name a class,
 663         ;; also collect functions with methods specialized on that class, and
 664         ;; (only) the specialized methods.
 665         (when (eq (symbol-package symbol) package)
 666           (let ((class (find-class symbol nil)))
 667             (when class
 668               (dolist (func (specializer-direct-generic-functions class))
 669                 (multiple-value-bind (name knownp)
 670                     (function-name-core (generic-function-name func))
 671                   (when (and knownp
 672                              (or (not (eq (symbol-package name) package))
 673                                  (gethash name externs)))
 674                     (setf (gethash func functions) t)
 675                     (dolist (method (specializer-direct-methods class))
 676                       (setf (gethash method methods) t)))))))))
 677
 678       ;; Print the report.
 679       (let ((funclist nil))
 680
 681         ;; Gather the functions we've decided are interesting, and sort them.
 682         (maphash (lambda (func value)
 683                    (declare (ignore value))
 684                    (push func funclist))
 685                  functions)
 686         (setf funclist (sort funclist
 687                              (lambda (a b)
 688                                ;; Sort by the core symbols, and order the
 689                                ;; `setf' variant after the base version.
 690                                (let ((core-a (function-name-core a))
 691                                      (core-b (function-name-core b)))
 692                                  (if (eq core-a core-b)
 693                                      (and (atom a) (consp b))
 694                                      (string< core-a core-b))))
 695                              :key #'generic-function-name))
 696
 697         (dolist (function funclist)
 698           ;; Print out each function in turn.
 699
 700           ;; Print the header line.
 701           (let ((name (generic-function-name function)))
 702             (etypecase name
 703               (symbol
 704                (format t "~A~%" (pretty-symbol-name name package)))
 705               ((cons (eql setf) t)
 706                (format t "(setf ~A)~%"
 707                        (pretty-symbol-name (cadr name) package)))))
 708
 709           ;; Report on the function's (interesting) methods.
 710           (dolist (method (sort (copy-list
 711                                  (generic-function-methods function))
 712                                 #'order-specializers
 713                                 :key #'method-specializers))
 714
 715             (when (gethash method methods)
 716               (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%"
 717                       (mapcar
 718                        (lambda (spec)
 719                          (etypecase spec
 720                            (class
 721                             (let ((name (class-name spec)))
 722                               (if (eq name t) "t"
 723                                   (pretty-symbol-name name package))))
 724                            (eql-specializer
 725                             (let ((obj (eql-specializer-object spec)))
 726                               (format nil "(eql ~A)"
 727                                       (if (symbolp obj)
 728                                           (pretty-symbol-name obj package)
 729                                           obj))))))
 730                        (method-specializers method))
 731                       (method-qualifiers method)))))))))
 732
 733 (defun check-slot-names (package)
 734   "Check that PACKAGE defines no slots whose names are exported symbols.
 735
 736    This acts to discourage the use of `slot-value' by external callers.
 737    Return two values:
 738
 739      * an alist of entries (CLASS . SLOT-NAMES), listing for each offending
 740        class, whose of its slot names which are either (a) external or (b)
 741        from a foreign package; and
 742
 743      * the distilled list of bad SLOT-NAMES."
 744
 745   ;; Canonify PACKAGE into a package objects.
 746   (setf package (find-package package))
 747
 748   (let* ((symbols (list-all-symbols package))
 749
 750          ;; Determine all of the named classes.
 751          (classes (mapcan (lambda (symbol)
 752                             (when (eq (symbol-package symbol) package)
 753                               (let ((class (find-class symbol nil)))
 754                                 (and class (list class)))))
 755                           symbols))
 756
 757          ;; Build the main alist of offending classes and slots.
 758          (offenders (mapcan
 759                      (lambda (class)
 760                        (let* ((slot-names
 761                                (mapcar #'slot-definition-name
 762                                        (class-direct-slots class)))
 763                               (exported (remove-if
 764                                          (lambda (sym)
 765                                            (or (not (symbol-package sym))
 766                                                (and (not (exported-symbol-p
 767                                                           sym))
 768                                                     (eq (symbol-package sym)
 769                                                         package))))
 770                                          slot-names)))
 771                          (and exported
 772                               (list (cons (class-name class)
 773                                           exported)))))
 774                             classes))
 775
 776          ;; Distill the bad slot names into a separate list.
 777          (bad-words (remove-duplicates (mapcan (lambda (list)
 778                                                  (copy-list (cdr list)))
 779                                                offenders))))
 780
 781     ;; Done.
 782     (values offenders bad-words)))
 783
 784 (defun report-symbols (paths package)
 785   "Report on all of the symbols defined in PACKAGE by the files in PATHS."
 786
 787   ;; Canonify PACKAGE to a package object.
 788   (setf package (find-package package))
 789
 790   ;; Print the breakdown of symbols by source file, with their purposes.
 791   (format t "~A~%Package `~(~A~)'~2%"
 792           (make-string 77 :initial-element #\-)
 793           (package-name package))
 794   (dolist (assoc (sort (categorize-symbols paths package) #'string<
 795                        :key (lambda (assoc)
 796                               (file-namestring (car assoc)))))
 797     (when (cdr assoc)
 798       (format t "~A~%" (file-namestring (car assoc)))
 799       (dolist (def (cdr assoc))
 800         (let ((sym (car def)))
 801           (format t "  ~A~@[~48T~{~(~A~)~^ ~}~]~%"
 802                   (pretty-symbol-name sym package)
 803                   (cdr def))))
 804       (terpri)))
 805
 806   ;; Report on leaked slot names, if any are exported or foreign.
 807   (multiple-value-bind (alist names) (check-slot-names package)
 808     (when names
 809       (format t "Leaked slot names: ~{~A~^, ~}~%"
 810               (mapcar (lambda (name) (pretty-symbol-name name package))
 811                       names))
 812       (dolist (assoc alist)
 813         (format t "~2T~A: ~{~A~^, ~}~%"
 814                 (pretty-symbol-name (car assoc) package)
 815                 (mapcar (lambda (name) (pretty-symbol-name name package))
 816                         (cdr assoc))))
 817       (terpri)))
 818
 819   ;; Report on classes and generic functions.
 820   (format t "Classes:~%")
 821   (analyse-classes package)
 822   (terpri)
 823   (format t "Methods:~%")
 824   (analyse-generic-functions package)
 825   (terpri))
 826
 827 (export 'report-project-symbols)
 828 (defun report-project-symbols ()
 829   "Write to `*standard-output*' a report on all of the symbols in Sod."
 830
 831   (labels ((components (comp)
 832              ;; Return the subcomponents of an ASDF component.
 833
 834              (asdf:component-children comp))
 835
 836            (files (comp)
 837              ;; Return a list of files needed by an ASDF component.
 838
 839              (sort (remove-if-not (lambda (comp)
 840                                     (typep comp 'asdf:cl-source-file))
 841                                   (components comp))
 842                    #'string< :key #'asdf:component-name))
 843
 844            (by-name (comp name)
 845              ;; Find the subcomponent called NAME of an ASDF component.
 846
 847              (gethash name (asdf:component-children-by-name comp)))
 848
 849            (file-name (file)
 850              ;; Return the pathname of an ASDF file component.
 851
 852              (slot-value file 'asdf/component:absolute-pathname)))
 853
 854   (let* ((sod (asdf:find-system "sod"))
 855          (parser-files (files (by-name sod "parser")))
 856          (utilities (by-name sod "utilities"))
 857          (sod-frontend (asdf:find-system "sod-frontend"))
 858          (optparse (by-name sod "optparse"))
 859          (frontend (by-name sod-frontend "frontend"))
 860          (sod-files (set-difference (files sod) (list optparse utilities))))
 861
 862     ;; Report on the various major pieces of the project.
 863     (report-symbols (mapcar #'file-name sod-files) "SOD")
 864     (report-symbols (mapcar #'file-name (list frontend)) "SOD-FRONTEND")
 865     (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER")
 866     (report-symbols (mapcar #'file-name (list optparse)) "OPTPARSE")
 867     (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES"))))
 868
 869 ;;;--------------------------------------------------------------------------
 870 ;;; Command-line use.
 871
 872 (defun main ()
 873   "Write a report to `doc/SYMBOLS'."
 874   (with-open-file (*standard-output* #p"doc/SYMBOLS"
 875                    :direction :output
 876                    :if-exists :supersede
 877                    :if-does-not-exist :create)
 878     (report-project-symbols)))
 879
 880 #+interactive (main)
 881
 882 ;;;----- That's all, folks --------------------------------------------------