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