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

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