mdw@git.distorted.org.uk Git - sod/blob - doc/list-exports

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