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 ;; 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 (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol)
 338               (specialized-on-p #'sod:expand-c-type-form 0 symbol))
 339       (push :c-type things))
 340     (when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol)
 341               (specialized-on-p #'sod-parser:expand-parser-form 1 symbol))
 342       (push :parser things))
 343     (when (get symbol 'optparse::opthandler)
 344       (push :opthandler things))
 345     (when (get symbol 'optparse::optmacro)
 346       (push :optmacro things))
 347     (nreverse things)))
 348
 349 (defun categorize-symbols (paths package)
 350   "Return a categorized list of the symbols exported by PACKAGE.
 351
 352    Return an alist of PAIRS (PATH . SYMBOLS), for each PATH in PATHS, where
 353    SYMBOLS is itself an alist (SYMBOL . KEYWORDS) listing the kinds of
 354    definitions that SYMBOL has (see `categorize')."
 355   (mapcar (lambda (assoc)
 356             (let ((home (car assoc))
 357                   (symbols (delete-duplicates
 358                             (sort (mapcan (lambda (sym)
 359                                             (multiple-value-bind
 360                                                 (symbol foundp)
 361                                                 (find-symbol
 362                                                  (symbol-name sym)
 363                                                  package)
 364                                               (and foundp (list symbol))))
 365                                           (cdr assoc))
 366                                   #'string< :key #'symbol-name))))
 367               (cons home (mapcar (lambda (symbol)
 368                                    (cons symbol (categorize symbol)))
 369                                  symbols))))
 370           (find-symbol-homes paths package)))
 371
 372 ;;;--------------------------------------------------------------------------
 373 ;;; Reporting.
 374
 375 (defun best-package-name (package)
 376   "Return a convenient name for PACKAGE."
 377
 378   ;; We pick the shortest one.  Strangely, there's no `find minimal thing
 379   ;; according to this valuation' function in Common Lisp.
 380   (loop with best = (package-name package)
 381         with best-length = (length best)
 382         for name in (package-nicknames package)
 383         for name-length = (length name)
 384         when (< name-length best-length)
 385           do (setf best name
 386                    best-length name-length)
 387         finally (return best)))
 388
 389 (defvar charbuf-size 0)
 390
 391 (defun exported-symbol-p (symbol &optional (package (symbol-package symbol)))
 392   "Return whether SYMBOL is exported by PACKAGE.
 393
 394    PACKAGE default's to the SYMBOL's home package, but may be different."
 395   (and package
 396        (multiple-value-bind (sym how)
 397            (find-symbol (symbol-name symbol) package)
 398          (and (eq sym symbol)
 399               (eq how :external)))))
 400
 401 (defun downcase-or-escape (name)
 402   "Return a presentable form for a symbol or package name.
 403
 404    If NAME consists only of uppercase letters and ordinary punctuation, then
 405    return NAME in lowercase; otherwise wrap it in `|...|' and escape as
 406    necessary."
 407
 408   (if (every (lambda (char)
 409                (or (upper-case-p char)
 410                    (digit-char-p char)
 411                    (member char '(#\% #\+ #\- #\* #\/ #\= #\[ #\] #\?))))
 412              name)
 413       (string-downcase name)
 414       (with-output-to-string (out)
 415         (write-char #\| out)
 416         (map nil (lambda (char)
 417                    (when (or (char= char #\|)
 418                              (char= char #\\))
 419                      (write-char #\\ out))
 420                    (write-char char out))
 421              name)
 422         (write-char #\| out))))
 423
 424 (defun pretty-symbol-name (symbol package)
 425   "Return a presentable form for SYMBOL, relative to PACKAGE.
 426
 427    If SYMBOL is exported by PACKAGE then just write the SYMBOL's name
 428    otherwise prefix the name with the SYMBOL's home package name, separated
 429    joined with one or two colons.  Uninterned symbols and keywords are also
 430    printed specially."
 431
 432   (let ((pkg (symbol-package symbol))
 433         (exportp (exported-symbol-p symbol)))
 434     (format nil "~:[~A:~:[:~;~]~;~2*~]~A"
 435             (and exportp (eq pkg package))
 436             (cond ((keywordp symbol) "")
 437                   ((eq pkg nil) "#")
 438                   (t (downcase-or-escape (best-package-name pkg))))
 439             (or exportp (null pkg))
 440             (downcase-or-escape (symbol-name symbol)))))
 441
 442 (deftype interesting-class ()
 443   "The type of `interesting' classes, which might be user-defined."
 444   '(or standard-class
 445        structure-class
 446        #.(class-name (class-of (find-class 'condition)))))
 447
 448 (defun analyse-classes (package)
 449   "Print a report on the classes defined by PACKAGE."
 450
 451   ;; Canonify PACKAGE into a package object.
 452   (setf package (find-package package))
 453
 454   (let ((classes (mapcan (lambda (symbol)
 455                            (let ((class (find-class symbol nil)))
 456                              (and class
 457                                   (typep class 'interesting-class)
 458                                   (list class))))
 459                          (list-exported-symbols package)))
 460         (subs (make-hash-table)))
 461     ;; CLASSES is a list of the `interesting' classes defined by (i.e., whose
 462     ;; names are exported by) PACKAGE.  SUBS maps a class to those of its
 463     ;; direct subclasses which are relevant to our report.
 464
 465     ;; Populate the SUBS table.
 466     (let ((done (make-hash-table)))
 467       (labels ((walk-up (class)
 468                  (unless (gethash class done)
 469                    (dolist (super (class-direct-superclasses class))
 470                      (push class (gethash super subs))
 471                      (walk-up super))
 472                    (setf (gethash class done) t))))
 473         (dolist (class classes)
 474           (walk-up class))))
 475
 476     (labels ((walk-down (this super depth)
 477                ;; Recursively traverse the class graph from THIS, recalling
 478                ;; that our parent is SUPER, and that we are DEPTH levels
 479                ;; down.
 480
 481                (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%"
 482                        (* 2 depth)
 483                        (pretty-symbol-name (class-name this) package)
 484                        (mapcar (lambda (class)
 485                                  (pretty-symbol-name (class-name class)
 486                                                      package))
 487                                (remove super
 488                                        (class-direct-superclasses this))))
 489                (dolist (sub (sort (copy-list (gethash this subs))
 490                                   #'string< :key #'class-name))
 491                  (walk-down sub this (1+ depth)))))
 492
 493       ;; Print the relevant fragment of the class graph.
 494       (walk-down (find-class t) nil 0))))
 495
 496 (defmacro deep-compare ((left right) &body body)
 497   "Helper macro for traversing two similar objects in parallel.
 498
 499    Specifically it's good at defining complex structural ordering relations,
 500    answering the question: is the LEFT value strictly less than the RIGHT
 501    value.
 502
 503    Evaluate the BODY forms, maintaining a pair of `cursors', initially at the
 504    LEFT and RIGHT values.
 505
 506    The following local macros are defined to do useful things.
 507
 508      * (focus EXPR . BODY) -- EXPR is an expression in terms of `it': advance
 509        each of the cursors to the result of evaluating this expression, with
 510        `it' bound to the current cursor value, and evaluate the BODY in the
 511        resulting environment.
 512
 513      * (update EXPR) -- as `focus', but mutate the cursors rather than
 514        binding them.
 515
 516      * (compare EXPR) -- EXPR is an expression in terms of the literal
 517        symbols `left' and `right', which returns non-nil if it thinks `left'
 518        is (strictly) less than `right' in some sense: evaluate this both ways
 519        round, and return if LEFT is determined to be less than or greater
 520        than RIGHT.
 521
 522      * (typesw (TYPE . BODY)*) -- process each clause in turn: if the left
 523        cursor value has TYPE, but the right does not, then LEFT is less than
 524        RIGHT; if the right cursor value has TYPE but the left does not, then
 525        LEFT is greater than RIGHT; otherwise, evaluate BODY."
 526
 527   (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-"))
 528         (l (gensym "LEFT-")) (r (gensym "RIGHT-")))
 529     `(macrolet ((focus (expr &body body)
 530                   `(flet ((,',func (it) ,expr))
 531                      (let ((,',l (,',func ,',l))
 532                            (,',r (,',func ,',r)))
 533                        ,@body)))
 534                 (update (expr)
 535                   `(flet ((,',func (it) ,expr))
 536                      (psetf ,',l (,',func ,',l)
 537                             ,',r (,',func ,',r))))
 538                 (compare (expr)
 539                   `(cond ((let ((left ,',l) (right ,',r)) ,expr)
 540                           (return-from ,',block t))
 541                          ((let ((right ,',l) (left ,',r)) ,expr)
 542                           (return-from ,',block nil))))
 543                 (typesw (&rest clauses)
 544                   (labels ((iter (clauses)
 545                              (if (null clauses)
 546                                  'nil
 547                                  (destructuring-bind (type &rest body)
 548                                      (car clauses)
 549                                    (if (eq type t)
 550                                        `(progn ,@body)
 551                                        `(if (typep ,',l ',type)
 552                                             (if (typep ,',r ',type)
 553                                                 (progn ,@body)
 554                                                 (return-from ,',block t))
 555                                             (if (typep ,',r ',type)
 556                                                 (return-from ,',block nil)
 557                                                 ,(iter (cdr clauses)))))))))
 558                     (iter clauses))))
 559        (let ((,l ,left) (,r ,right))
 560          (block ,block
 561            ,@body)))))
 562
 563 (defun order-specializers (la lb)
 564   "Return whether specializers LA should be sorted before LB."
 565
 566   (deep-compare (la lb)
 567     ;; Iterate over the two lists.  The cursors advance down the spine, and
 568     ;; we focus on each car in turn.
 569
 570     (loop
 571       (typesw (null (return nil)))
 572       ;; If one list reaches the end, then it's lesser; if both, they're
 573       ;; equal.
 574
 575       (focus (car it)
 576         ;; Examine the two specializers at this position.
 577
 578         (typesw (eql-specializer
 579                  (focus (eql-specializer-object it)
 580                    ;; We found an `eql' specializer.  Compare the objects.
 581
 582                    (typesw (keyword
 583                             ;; Keywords compare by name.
 584
 585                             (compare (string< left right)))
 586
 587                            (symbol
 588                             ;; Symbols compare by package and name.
 589
 590                             (focus (package-name (symbol-package it))
 591                               (compare (string< left right)))
 592                             (compare (string< left right)))
 593
 594                            (t
 595                             ;; Compare two other objects by comparing their
 596                             ;; string representations.
 597
 598                             (focus (with-output-to-string (out)
 599                                      (prin1 it out)
 600                                      (write-char #\nul))
 601                               (compare (string< left right)))))))
 602
 603                 (class
 604                  ;; We found a class,   Compare the class names.
 605                  (focus (class-name it)
 606                    (focus (package-name (symbol-package it))
 607                      (compare (string< left right)))
 608                    (compare (string< left right))))
 609
 610                 (t
 611                  ;; We found some other kind of specializer that we don't
 612                  ;; understand.
 613
 614                  (error "unexpected things"))))
 615
 616       ;; No joy with that pair of specializers: try the next.
 617       (update (cdr it)))))
 618
 619 (defun analyse-generic-functions (package)
 620   "Print a report of the generic functions and methods defined by PACKAGE."
 621
 622   ;; Canonify package into a package object.
 623   (setf package (find-package package))
 624
 625   (flet ((function-name-core (name)
 626            ;; Return the underlying name for a function NAME.  Specifically,
 627            ;; if NAME is (setf THING) then the core is THING; if NAME is a
 628            ;; symbol then the core is simply NAME; otherwise we're confused.
 629            ;; Return a second value to say whether we got the job done.
 630
 631            (typecase name
 632              (symbol (values name t))
 633              ((cons (eql setf) t) (values (cadr name) t))
 634              (t (values nil nil)))))
 635
 636     (let ((methods (make-hash-table))
 637           (functions (make-hash-table))
 638           (externs (make-hash-table)))
 639       ;; EXTERNS is a set of the symbols exported by PACKAGE.  FUNCTIONS and
 640       ;; METHODS are sets of generic function names (not cores), and method
 641       ;; objects, which we've decided are worth reporting.
 642
 643       ;; Collect the EXTERNS symbols.
 644       (dolist (symbol (list-exported-symbols package))
 645         (setf (gethash symbol externs) t))
 646
 647       ;; Collect the FUNCTIONS and METHODS.
 648       (dolist (symbol (list-exported-symbols package))
 649
 650         ;; Mark the generic functions and `setf'-functions named by exported
 651         ;; symbols as interesting, along with all of their methods.
 652         (flet ((dofunc (func)
 653                  (when (typep func 'generic-function)
 654                    (setf (gethash func functions) t)
 655                    (dolist (method (generic-function-methods func))
 656                      (setf (gethash method methods) t)))))
 657           (dofunc (and (fboundp symbol) (fdefinition symbol)))
 658           (dofunc (ignore-errors (fdefinition (list 'setf symbol)))))
 659
 660         ;; For symbols whose home package is PACKAGE, and which name a class,
 661         ;; also collect functions with methods specialized on that class, and
 662         ;; (only) the specialized methods.
 663         (when (eq (symbol-package symbol) package)
 664           (let ((class (find-class symbol nil)))
 665             (when class
 666               (dolist (func (specializer-direct-generic-functions class))
 667                 (multiple-value-bind (name knownp)
 668                     (function-name-core (generic-function-name func))
 669                   (when (and knownp
 670                              (or (not (eq (symbol-package name) package))
 671                                  (gethash name externs)))
 672                     (setf (gethash func functions) t)
 673                     (dolist (method (specializer-direct-methods class))
 674                       (setf (gethash method methods) t)))))))))
 675
 676       ;; Print the report.
 677       (let ((funclist nil))
 678
 679         ;; Gather the functions we've decided are interesting, and sort them.
 680         (maphash (lambda (func value)
 681                    (declare (ignore value))
 682                    (push func funclist))
 683                  functions)
 684         (setf funclist (sort funclist
 685                              (lambda (a b)
 686                                ;; Sort by the core symbols, and order the
 687                                ;; `setf' variant after the base version.
 688                                (let ((core-a (function-name-core a))
 689                                      (core-b (function-name-core b)))
 690                                  (if (eq core-a core-b)
 691                                      (and (atom a) (consp b))
 692                                      (string< core-a core-b))))
 693                              :key #'generic-function-name))
 694
 695         (dolist (function funclist)
 696           ;; Print out each function in turn.
 697
 698           ;; Print the header line.
 699           (let ((name (generic-function-name function)))
 700             (etypecase name
 701               (symbol
 702                (format t "~A~%" (pretty-symbol-name name package)))
 703               ((cons (eql setf) t)
 704                (format t "(setf ~A)~%"
 705                        (pretty-symbol-name (cadr name) package)))))
 706
 707           ;; Report on the function's (interesting) methods.
 708           (dolist (method (sort (copy-list
 709                                  (generic-function-methods function))
 710                                 #'order-specializers
 711                                 :key #'method-specializers))
 712
 713             (when (gethash method methods)
 714               (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%"
 715                       (mapcar
 716                        (lambda (spec)
 717                          (etypecase spec
 718                            (class
 719                             (let ((name (class-name spec)))
 720                               (if (eq name t) "t"
 721                                   (pretty-symbol-name name package))))
 722                            (eql-specializer
 723                             (let ((obj (eql-specializer-object spec)))
 724                               (format nil "(eql ~A)"
 725                                       (if (symbolp obj)
 726                                           (pretty-symbol-name obj package)
 727                                           obj))))))
 728                        (method-specializers method))
 729                       (method-qualifiers method)))))))))
 730
 731 (defun check-slot-names (package)
 732   "Check that PACKAGE defines no slots whose names are exported symbols.
 733
 734    This acts to discourage the use of `slot-value' by external callers.
 735    Return two values:
 736
 737      * an alist of entries (CLASS . SLOT-NAMES), listing for each offending
 738        class, whose of its slot names which are either (a) external or (b)
 739        from a foreign package; and
 740
 741      * the distilled list of bad SLOT-NAMES."
 742
 743   ;; Canonify PACKAGE into a package objects.
 744   (setf package (find-package package))
 745
 746   (let* ((symbols (list-all-symbols package))
 747
 748          ;; Determine all of the named classes.
 749          (classes (mapcan (lambda (symbol)
 750                             (when (eq (symbol-package symbol) package)
 751                               (let ((class (find-class symbol nil)))
 752                                 (and class (list class)))))
 753                           symbols))
 754
 755          ;; Build the main alist of offending classes and slots.
 756          (offenders (mapcan
 757                      (lambda (class)
 758                        (let* ((slot-names
 759                                (mapcar #'slot-definition-name
 760                                        (class-direct-slots class)))
 761                               (exported (remove-if
 762                                          (lambda (sym)
 763                                            (or (not (symbol-package sym))
 764                                                (and (not (exported-symbol-p
 765                                                           sym))
 766                                                     (eq (symbol-package sym)
 767                                                         package))))
 768                                          slot-names)))
 769                          (and exported
 770                               (list (cons (class-name class)
 771                                           exported)))))
 772                             classes))
 773
 774          ;; Distill the bad slot names into a separate list.
 775          (bad-words (remove-duplicates (mapcan (lambda (list)
 776                                                  (copy-list (cdr list)))
 777                                                offenders))))
 778
 779     ;; Done.
 780     (values offenders bad-words)))
 781
 782 (defun report-symbols (paths package)
 783   "Report on all of the symbols defined in PACKAGE by the files in PATHS."
 784
 785   ;; Canonify PACKAGE to a package object.
 786   (setf package (find-package package))
 787
 788   ;; Print the breakdown of symbols by source file, with their purposes.
 789   (format t "~A~%Package `~(~A~)'~2%"
 790           (make-string 77 :initial-element #\-)
 791           (package-name package))
 792   (dolist (assoc (sort (categorize-symbols paths package) #'string<
 793                        :key (lambda (assoc)
 794                               (file-namestring (car assoc)))))
 795     (when (cdr assoc)
 796       (format t "~A~%" (file-namestring (car assoc)))
 797       (dolist (def (cdr assoc))
 798         (let ((sym (car def)))
 799           (format t "  ~A~@[~48T~{~(~A~)~^ ~}~]~%"
 800                   (pretty-symbol-name sym package)
 801                   (cdr def))))
 802       (terpri)))
 803
 804   ;; Report on leaked slot names, if any are exported or foreign.
 805   (multiple-value-bind (alist names) (check-slot-names package)
 806     (when names
 807       (format t "Leaked slot names: ~{~A~^, ~}~%"
 808               (mapcar (lambda (name) (pretty-symbol-name name package))
 809                       names))
 810       (dolist (assoc alist)
 811         (format t "~2T~A: ~{~A~^, ~}~%"
 812                 (pretty-symbol-name (car assoc) package)
 813                 (mapcar (lambda (name) (pretty-symbol-name name package))
 814                         (cdr assoc))))
 815       (terpri)))
 816
 817   ;; Report on classes and generic functions.
 818   (format t "Classes:~%")
 819   (analyse-classes package)
 820   (terpri)
 821   (format t "Methods:~%")
 822   (analyse-generic-functions package)
 823   (terpri))
 824
 825 (export 'report-project-symbols)
 826 (defun report-project-symbols ()
 827   "Write to `*standard-output*' a report on all of the symbols in Sod."
 828
 829   (labels ((components (comp)
 830              ;; Return the subcomponents of an ASDF component.
 831
 832              (asdf:component-children comp))
 833
 834            (files (comp)
 835              ;; Return a list of files needed by an ASDF component.
 836
 837              (sort (remove-if-not (lambda (comp)
 838                                     (typep comp 'asdf:cl-source-file))
 839                                   (components comp))
 840                    #'string< :key #'asdf:component-name))
 841
 842            (by-name (comp name)
 843              ;; Find the subcomponent called NAME of an ASDF component.
 844
 845              (gethash name (asdf:component-children-by-name comp)))
 846
 847            (file-name (file)
 848              ;; Return the pathname of an ASDF file component.
 849
 850              (slot-value file 'asdf/component:absolute-pathname)))
 851
 852   (let* ((sod (asdf:find-system "sod"))
 853          (parser-files (files (by-name sod "parser")))
 854          (utilities (by-name sod "utilities"))
 855          (sod-frontend (asdf:find-system "sod-frontend"))
 856          (optparse (by-name sod "optparse"))
 857          (frontend (by-name sod-frontend "frontend"))
 858          (sod-files (set-difference (files sod) (list optparse utilities))))
 859
 860     ;; Report on the various major pieces of the project.
 861     (report-symbols (mapcar #'file-name sod-files) "SOD")
 862     (report-symbols (mapcar #'file-name (list frontend)) "SOD-FRONTEND")
 863     (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER")
 864     (report-symbols (mapcar #'file-name (list optparse)) "OPTPARSE")
 865     (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES"))))
 866
 867 ;;;--------------------------------------------------------------------------
 868 ;;; Command-line use.
 869
 870 (defun main ()
 871   "Write a report to `doc/SYMBOLS'."
 872   (with-open-file (*standard-output* #p"doc/SYMBOLS"
 873                    :direction :output
 874                    :if-exists :supersede
 875                    :if-does-not-exist :create)
 876     (report-project-symbols)))
 877
 878 #+interactive (main)
 879
 880 ;;;----- That's all, folks --------------------------------------------------