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
8 (cl:defpackage #:sod-exports
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)))
18 ;;;--------------------------------------------------------------------------
19 ;;; Miscelleneous utilities.
21 (defun symbolicate (&rest things)
22 "Concatenate the THINGS and turn the result into a symbol."
23 (intern (apply #'concatenate 'string (mapcar #'string things))))
25 ;;;--------------------------------------------------------------------------
26 ;;; Determining the symbols exported by particular files.
28 (defun incomprehensible-form (head tail)
29 "Report an incomprehensible form (HEAD . TAIL)."
30 (format *error-output* ";; incomprehensible: ~S~%" (cons head tail)))
32 (defgeneric form-list-exports (head tail)
34 "Return a list of symbols exported by the form (HEAD . TAIL).
36 This is called from `form-exports' below.")
38 "By default, a form exports nothing."
39 (declare (ignore head tail))
42 (defmethod form-list-exports ((head (eql 'cl:export)) tail)
43 "Return the symbols exported by a toplevel `export' form.
45 We can cope with (export 'SYMBOLS), where SYMBOLS is a symbol or a list."
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))))
54 (defmethod form-list-exports ((head (eql 'sod:definst)) tail)
55 "Return the symbols exported by a `form-list-exports' form.
59 (definst CODE (STREAMVAR [[:export FLAG]]) ARGS
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:
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.)
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
75 (destructuring-bind (code (streamvar &key export) args &body body) tail
76 (declare (ignore streamvar body))
79 (list* (symbolicate code '-inst)
80 (symbolicate 'make- code '-inst)
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
86 (if (or (atom tree) (null path)) tree
87 (dig (nth (car path) tree) (cdr path))))
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))
96 ;; Convert ARG name into the `inst-ARG' accessor.
97 (symbolicate 'inst- (cook arg))))
99 ;; Work through the lambda-list, keeping track of where we
100 ;; expect the argument symbols to be.
101 (loop with state = :mandatory
103 if (and (symbolp arg)
104 (char= (char (symbol-name arg) 0) #\&))
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)))
113 do (error "Confused by ~S." arg)))))))
115 (defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail)
116 "Return the symbols exported by a `define-tagged-type' form.
118 This is a scummy internal macro in `c-types-impl.lisp'. The syntax is
120 (define-tagged-type KIND DESCRIPTION)
122 It exports `KIND' and `make-KIND'."
124 (destructuring-bind (kind what) tail
125 (declare (ignore what))
127 (symbolicate 'c- kind '-type)
128 (symbolicate 'make- kind '-type))))
130 (defmethod form-list-exports ((head (eql 'sod:defctype)) tail)
131 "Return the symbols exported by a `defctype' form.
135 (defctype {NAME | (NAME SYNONYM*)} VALUE [[:export FLAG]])
137 If FLAG is non-nil, this form exports `c-type-NAME', `NAME', and all of
140 (destructuring-bind (names value &key export) tail
141 (declare (ignore value))
142 (let ((names (if (listp names) names (list names))))
144 (list* (symbolicate 'c-type- (car names)) names)))))
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.
151 (define-simple-c-type {NAME | (NAME SYNONYM*)} TYPE [[:export FLAG]])
153 If FLAG is non-nil, this form exports `c-type-NAME', `NAME', and all of
156 (destructuring-bind (names type &key export) tail
157 (declare (ignore type))
158 (let ((names (if (listp names) names (list names))))
160 (list* (symbolicate 'c-type- (car names)) names)))))
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.
166 This is a scummy internal macro in `c-types-impl.lisp'. The syntax is
168 (define-cross-product-types PIECES)
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'."
177 ;; Huh. I feel a hack coming on.
178 (mapcar (lambda (row)
179 (intern (with-output-to-string (out)
181 (dotimes (i (length s))
182 (let ((ch (char s i)))
185 (write-char (char-upcase ch) out))))))))
186 (reduce (lambda (piece tails)
187 (mapcan (lambda (tail)
188 (mapcar (lambda (head)
190 (if (listp piece) piece
193 (cons '("" "c-type_") tail)
195 :initial-value '(nil))))
198 (defmethod form-list-exports ((head (eql 'cl:macrolet)) tail)
199 "Return the symbols expored by a toplevel `macrolet' form.
201 Which are simply the symbols exported by its body."
202 (mapcan #'form-exports (cdr tail)))
204 (defmethod form-list-exports ((head (eql 'cl:eval-when)) tail)
205 "Return the symbols expored by a toplevel `eval-when' form.
207 Which are simply the symbols exported by its body."
209 ;; We don't bother checking when it'd actually be evaluated.
210 (mapcan #'form-exports (cdr tail)))
212 (defmethod form-list-exports ((head (eql 'cl:progn)) tail)
213 "Return the symbols expored by a toplevel `progn' form.
215 Which are simply the symbols exported by its body."
216 (mapcan #'form-exports tail))
218 (defgeneric form-exports (form)
220 "Return a list of symbols exported by a toplevel FORM.")
222 (:method ((form cons)) (form-list-exports (car form) (cdr form))))
224 (defgeneric list-exports (thing)
226 "Return a list of symbols exported by THING."))
228 (defmethod list-exports ((stream stream))
229 "Return a list of symbols exported by a STREAM.
231 By reading it and analysing the forms."
233 (loop with eof = '#:eof
234 for form = (read stream nil eof)
236 when (consp form) nconc (form-exports form)))
238 (defmethod list-exports ((path pathname))
239 "Return a list of symbols exported by a directory PATHNAME.
241 Return an alist of pairs (PATH . SYMBOL) listing each SYMBOL exported by a
242 PATH of the form PATHNAME/*.lisp."
244 (mapcar (lambda (each)
245 (cons each (with-open-file (stream each) (list-exports stream))))
246 (directory (merge-pathnames path #p"*.lisp"))))
248 (defmethod list-exports ((path string))
249 "Return a list of symbols exported by a PATH string.
251 By converting it into a pathname."
253 (list-exports (pathname path)))
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))
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))
269 #'string< :key #'symbol-name)))
271 (defun find-symbol-homes (paths package)
272 "Determine the `home' file for the symbols exported by PACKAGE.
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
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)))
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)))))
297 ;; Check that all of the symbols exported by the package are accounted
299 (dolist (symbol symbols)
300 (unless (gethash (symbol-name symbol) homes)
301 (format *error-output* ";; mysterious: ~S~%" symbol)))
306 ;;;--------------------------------------------------------------------------
307 ;;; Determining the kinds of definitions attached to symbols.
309 (defun boring-setf-expansion-p (symbol)
310 "Return non-nil if SYMBOL has a trivial `setf' expansion.
312 i.e., (setf (SYMBOL ...) ...) works by (funcall #'(setf SYMBOL) ...)."
314 (multiple-value-bind (temps args stores store fetch)
315 (ignore-errors (get-setf-expansion (list symbol)))
316 (declare (ignore temps args stores fetch))
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))))))
325 (defun specialized-on-p (func arg what)
326 "Check whether FUNC has a method specialized for the symbol WHAT.
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."
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)))
338 (defun categorize (symbol)
339 "Determine what things SYMBOL is defined to do.
341 Return a list of keywords:
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
358 categorizing the kinds of definitions that SYMBOL has."
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)
369 (etypecase (ignore-errors (fdefinition (list 'setf symbol)))
370 (generic-function (push :setf-generic things))
371 (function (push :setf-function things))
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))
389 (defun categorize-symbols (paths package)
390 "Return a categorized list of the symbols exported by PACKAGE.
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)
404 (and foundp (list symbol))))
406 #'string< :key #'symbol-name))))
407 (cons home (mapcar (lambda (symbol)
408 (cons symbol (categorize symbol)))
410 (find-symbol-homes paths package)))
412 ;;;--------------------------------------------------------------------------
415 (defun best-package-name (package)
416 "Return a convenient name for PACKAGE."
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)
426 best-length name-length)
427 finally (return best)))
429 (defvar charbuf-size 0)
431 (defun exported-symbol-p (symbol &optional (package (symbol-package symbol)))
432 "Return whether SYMBOL is exported by PACKAGE.
434 PACKAGE default's to the SYMBOL's home package, but may be different."
436 (multiple-value-bind (sym how)
437 (find-symbol (symbol-name symbol) package)
439 (eq how :external)))))
441 (defun downcase-or-escape (name)
442 "Return a presentable form for a symbol or package name.
444 If NAME consists only of uppercase letters and ordinary punctuation, then
445 return NAME in lowercase; otherwise wrap it in `|...|' and escape as
448 (if (every (lambda (char)
449 (or (upper-case-p char)
451 (member char '(#\% #\+ #\- #\* #\/ #\= #\[ #\] #\?))))
453 (string-downcase name)
454 (with-output-to-string (out)
456 (map nil (lambda (char)
457 (when (or (char= char #\|)
459 (write-char #\\ out))
460 (write-char char out))
462 (write-char #\| out))))
464 (defun pretty-symbol-name (symbol package)
465 "Return a presentable form for SYMBOL, relative to PACKAGE.
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
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) "")
478 (t (downcase-or-escape (best-package-name pkg))))
479 (or exportp (null pkg))
480 (downcase-or-escape (symbol-name symbol)))))
482 (deftype interesting-class ()
483 "The type of `interesting' classes, which might be user-defined."
486 #.(class-name (class-of (find-class 'condition)))))
488 (defun analyse-classes (package)
489 "Print a report on the classes defined by PACKAGE."
491 ;; Canonify PACKAGE into a package object.
492 (setf package (find-package package))
494 (let ((classes (mapcan (lambda (symbol)
495 (let ((class (find-class symbol nil)))
497 (typep class 'interesting-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.
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))
512 (setf (gethash class done) t))))
513 (dolist (class classes)
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
521 (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%"
523 (pretty-symbol-name (class-name this) package)
524 (mapcar (lambda (class)
525 (pretty-symbol-name (class-name class)
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)))))
533 ;; Print the relevant fragment of the class graph.
534 (walk-down (find-class t) nil 0))))
536 (defmacro deep-compare ((left right) &body body)
537 "Helper macro for traversing two similar objects in parallel.
539 Specifically it's good at defining complex structural ordering relations,
540 answering the question: is the LEFT value strictly less than the RIGHT
543 Evaluate the BODY forms, maintaining a pair of `cursors', initially at the
544 LEFT and RIGHT values.
546 The following local macros are defined to do useful things.
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.
553 * (update EXPR) -- as `focus', but mutate the cursors rather than
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
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."
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)))
575 `(flet ((,',func (it) ,expr))
576 (psetf ,',l (,',func ,',l)
577 ,',r (,',func ,',r))))
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)
587 (destructuring-bind (type &rest body)
591 `(if (typep ,',l ',type)
592 (if (typep ,',r ',type)
594 (return-from ,',block t))
595 (if (typep ,',r ',type)
596 (return-from ,',block nil)
597 ,(iter (cdr clauses)))))))))
599 (let ((,l ,left) (,r ,right))
603 (defun order-specializers (la lb)
604 "Return whether specializers LA should be sorted before LB."
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.
611 (typesw (null (return nil)))
612 ;; If one list reaches the end, then it's lesser; if both, they're
616 ;; Examine the two specializers at this position.
618 (typesw (eql-specializer
619 (focus (eql-specializer-object it)
620 ;; We found an `eql' specializer. Compare the objects.
623 ;; Keywords compare by name.
625 (compare (string< left right)))
628 ;; Symbols compare by package and name.
630 (focus (package-name (symbol-package it))
631 (compare (string< left right)))
632 (compare (string< left right)))
635 ;; Compare two other objects by comparing their
636 ;; string representations.
638 (focus (with-output-to-string (out)
641 (compare (string< left right)))))))
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))))
651 ;; We found some other kind of specializer that we don't
654 (error "unexpected things"))))
656 ;; No joy with that pair of specializers: try the next.
659 (defun analyse-generic-functions (package)
660 "Print a report of the generic functions and methods defined by PACKAGE."
662 ;; Canonify package into a package object.
663 (setf package (find-package package))
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.
672 (symbol (values name t))
673 ((cons (eql setf) t) (values (cadr name) t))
674 (t (values nil nil)))))
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.
683 ;; Collect the EXTERNS symbols.
684 (dolist (symbol (list-exported-symbols package))
685 (setf (gethash symbol externs) t))
687 ;; Collect the FUNCTIONS and METHODS.
688 (dolist (symbol (list-exported-symbols package))
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)))))
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)))
706 (dolist (func (specializer-direct-generic-functions class))
707 (multiple-value-bind (name knownp)
708 (function-name-core (generic-function-name func))
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)))))))))
717 (let ((funclist nil))
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))
724 (setf funclist (sort funclist
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))
735 (dolist (function funclist)
736 ;; Print out each function in turn.
738 ;; Print the header line.
739 (let ((name (generic-function-name function)))
742 (format t "~A~%" (pretty-symbol-name name package)))
744 (format t "(setf ~A)~%"
745 (pretty-symbol-name (cadr name) package)))))
747 ;; Report on the function's (interesting) methods.
748 (dolist (method (sort (copy-list
749 (generic-function-methods function))
751 :key #'method-specializers))
753 (when (gethash method methods)
754 (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%"
759 (let ((name (class-name spec)))
761 (pretty-symbol-name name package))))
763 (let ((obj (eql-specializer-object spec)))
764 (format nil "(eql ~A)"
766 (pretty-symbol-name obj package)
768 (method-specializers method))
769 (method-qualifiers method)))))))))
771 (defun check-slot-names (package)
772 "Check that PACKAGE defines no slots whose names are exported symbols.
774 This acts to discourage the use of `slot-value' by external callers.
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
781 * the distilled list of bad SLOT-NAMES."
783 ;; Canonify PACKAGE into a package objects.
784 (setf package (find-package package))
786 (let* ((symbols (list-all-symbols package))
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)))))
795 ;; Build the main alist of offending classes and slots.
799 (mapcar #'slot-definition-name
800 (class-direct-slots class)))
803 (or (not (symbol-package sym))
804 (and (not (exported-symbol-p
806 (eq (symbol-package sym)
810 (list (cons (class-name class)
814 ;; Distill the bad slot names into a separate list.
815 (bad-words (remove-duplicates (mapcan (lambda (list)
816 (copy-list (cdr list)))
820 (values offenders bad-words)))
822 (defun report-symbols (paths package)
823 "Report on all of the symbols defined in PACKAGE by the files in PATHS."
825 ;; Canonify PACKAGE to a package object.
826 (setf package (find-package package))
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<
834 (file-namestring (car 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)
844 ;; Report on leaked slot names, if any are exported or foreign.
845 (multiple-value-bind (alist names) (check-slot-names package)
847 (format t "Leaked slot names: ~{~A~^, ~}~%"
848 (mapcar (lambda (name) (pretty-symbol-name name package))
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))
857 ;; Report on classes and generic functions.
858 (format t "Classes:~%")
859 (analyse-classes package)
861 (format t "Methods:~%")
862 (analyse-generic-functions package)
865 (export 'report-project-symbols)
866 (defun report-project-symbols ()
867 "Write to `*standard-output*' a report on all of the symbols in Sod."
869 (labels ((components (comp)
870 ;; Return the subcomponents of an ASDF component.
872 (asdf:component-children comp))
875 ;; Return a list of files needed by an ASDF component.
877 (sort (remove-if-not (lambda (comp)
878 (typep comp 'asdf:cl-source-file))
880 #'string< :key #'asdf:component-name))
883 ;; Find the subcomponent called NAME of an ASDF component.
885 (gethash name (asdf:component-children-by-name comp)))
888 ;; Return the pathname of an ASDF file component.
890 (slot-value file 'asdf/component:absolute-pathname)))
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))))
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"))))
907 ;;;--------------------------------------------------------------------------
908 ;;; Command-line use.
911 "Write a report to `doc/SYMBOLS'."
912 (with-open-file (*standard-output* #p"doc/SYMBOLS"
914 :if-exists :supersede
915 :if-does-not-exist :create)
916 (report-project-symbols)))
920 ;;;----- That's all, folks --------------------------------------------------