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 ((head (eql 'cl:macrolet)) tail)
163 "Return the symbols expored by a toplevel
`macrolet' form.
165 Which are simply the symbols exported by its body."
166 (mapcan #'form-exports (cdr tail)))
168 (defmethod form-list-exports ((head (eql 'cl:eval-when)) tail)
169 "Return the symbols expored by a toplevel `eval-when
' form.
171 Which are simply the symbols exported by its body."
173 ;; We don't bother checking when it
'd actually be evaluated.
174 (mapcan #'form-exports
(cdr
tail)))
176 (defmethod form-list-exports
((head (eql
'cl:progn)) tail)
177 "Return the symbols expored by a toplevel `progn' form.
179 Which are simply the symbols exported by its body.
"
180 (mapcan #'form-exports tail))
182 (defgeneric form-exports (form)
184 "Return a list of symbols exported by a toplevel FORM.
")
186 (:method ((form cons)) (form-list-exports (car form) (cdr form))))
188 (defgeneric list-exports (thing)
190 "Return a list of symbols exported by THING.
"))
192 (defmethod list-exports ((stream stream))
193 "Return a list of symbols exported by a STREAM.
195 By reading it and analysing the forms.
"
197 (loop with eof = '#:eof
198 for form = (read stream nil eof)
200 when (consp form) nconc (form-exports form)))
202 (defmethod list-exports ((path pathname))
203 "Return a list of symbols exported by a directory PATHNAME.
205 Return an alist of pairs
(PATH . SYMBOL
) listing each SYMBOL exported by a
206 PATH of the form PATHNAME
/*.lisp.
"
208 (mapcar (lambda (each)
209 (cons each (with-open-file (stream each) (list-exports stream))))
210 (directory (merge-pathnames path #p"*.lisp
"))))
212 (defmethod list-exports ((path string))
213 "Return a list of symbols exported by a PATH string.
215 By converting it into a pathname.
"
217 (list-exports (pathname path)))
219 (defun list-exported-symbols (package)
220 "Return a sorted list of symbols exported by PACKAGE.
"
221 (sort (loop for s being the external-symbols of package collect s)
222 #'string< :key #'symbol-name))
224 (defun list-all-symbols (package)
225 "Return a sorted list of all symbols exported by or private to PACKAGE.
"
226 (let ((externs (make-hash-table)))
227 (dolist (sym (list-exported-symbols package))
228 (setf (gethash sym externs) t))
229 (sort (loop for s being the symbols of package
230 when (or (not (exported-symbol-p s))
233 #'string< :key #'symbol-name)))
235 (defun find-symbol-homes (paths package)
236 "Determine the
`home' file for the symbols exported by PACKAGE.
238 Return an alist of pairs (PATH . SYMBOL) listing each SYMBOL exported by a
239 PATH of the form PATHNAME/*.lisp where PATHNAME is a member of PATHS. Do
240 this by finding all the files and parsing them (somewhat superficially),
241 and cross-checking the result against the actual symbols exported by the
244 ;; Building the alist is exactly what `list-exports
' is for. The rest of
245 ;; this function is the cross-checking.
246 (let* ((symbols (list-exported-symbols package))
247 (exports-alist (let ((*package* package))
248 (mapcan #'list-exports paths
)))
249 (homes
(make-hash-table
:test #'equal)))
251 ;; Work through the alist recording where we found each symbol. Check
252 ;; that they
're actually exported by poking at the package.
253 (dolist (assoc exports-alist)
254 (let ((home (car assoc)))
255 (dolist (symbol (cdr assoc))
256 (let ((name (symbol-name symbol)))
257 (unless (nth-value 1 (find-symbol name package))
258 (format *error-output* ";; unexported: ~S~%" symbol))
259 (setf (gethash name homes) home)))))
261 ;; Check that all of the symbols exported by the package are accounted
263 (dolist (symbol symbols)
264 (unless (gethash (symbol-name symbol) homes)
265 (format *error-output* ";; mysterious: ~S~%" symbol)))
270 ;;;--------------------------------------------------------------------------
271 ;;; Determining the kinds of definitions attached to symbols.
273 (defun boring-setf-expansion-p
(symbol
)
274 "Return non-nil if SYMBOL has a trivial `setf' expansion.
276 i.e., (setf (SYMBOL ...) ...) works by (funcall #'(setf SYMBOL) ...)."
278 (multiple-value-bind
(temps args stores store fetch
)
279 (ignore-errors
(get-setf-expansion
(list symbol
)))
280 (declare (ignore temps args stores fetch
))
282 (eq
(car store
) 'funcall)
283 (consp (cdr store)) (consp (cadr store))
284 (eq (caadr store) 'function)
285 (let ((func
(cadadr store
)))
286 (and
(consp func
) (consp
(cdr func
))
287 (eq
(car func
) 'setf))))))
289 (defun specialized-on-p (func arg what)
290 "Check whether FUNC has a method specialized for the symbol WHAT.
292 We assume FUNC is a (well-known) generic function. ARG is a small integer
293 identifying one of FUNC's mandatory arguments. Return non-nil
if FUNC has
294 a method
for which this ARG is
`eql'-specialized on WHAT."
296 (some (lambda (method)
297 (let ((spec (nth arg (method-specializers method))))
298 (and (typep spec 'eql-specializer)
299 (eql (eql-specializer-object spec) what))))
300 (generic-function-methods func)))
302 (defun categorize (symbol)
303 "Determine what things SYMBOL is defined to do.
305 Return a list of keywords:
307 * :constant -- SYMBOL's value cell is `boundp
' and `constantp'
308 * :variable
-- SYMBOL
's value cell is `boundp' but not
`constantp'
309 * :macro -- SYMBOL's function cell is `macro-function
'
310 * :generic -- SYMBOL's
function cell is a
`generic-function'
311 * :function -- SYMBOL's function cell is a non-generic `function'
312 * :setf-generic -- (setf SYMBOL) is a `generic-function'
313 * :setf-function
-- (setf SYMBOL
) is a non-generic
`function'
314 * :class -- SYMBOL is `find-class
'
315 * :c-type -- `expand-c-type-spec' or
`expand-c-type-form' has a method
316 specialized on SYMBOL
317 * :parser -- `expand-parser-spec
' or `expand-parser-form' has a method
318 specialized on SYMBOL
319 * :opthandler
-- SYMBOL has an
`opthandler' property
320 * :optmacro -- SYMBOL has an `optmacro
' property
322 categorizing the kinds of definitions that SYMBOL has."
325 (when (boundp symbol)
326 (push (if (constantp symbol) :constant :variable) things))
327 (when (fboundp symbol)
328 (push (cond ((macro-function symbol) :macro)
329 ((typep (fdefinition symbol) 'generic-function
)
333 (etypecase
(ignore-errors
(fdefinition
(list
'setf symbol)))
334 (generic-function (push :setf-generic things))
335 (function (push :setf-function things))
337 (when (find-class symbol nil)
338 (push :class things))
339 (when (specialized-on-p #'sod
:expand-c-type-spec
0 symbol
)
340 (push
:c-type-spec things
))
341 (when
(specialized-on-p
#'sod:expand-c-type-form 0 symbol)
342 (push
:c-type-form things
))
343 (when
(specialized-on-p
#'sod-parser:expand-parser-spec 1 symbol)
344 (push
:parser-spec things
))
345 (when
(specialized-on-p
#'sod-parser:expand-parser-form 1 symbol)
346 (push
:parser-form things
))
347 (when
(get symbol
'optparse::opthandler)
348 (push :opthandler things))
349 (when (get symbol 'optparse
::optmacro
)
350 (push
:optmacro things
))
353 (defun categorize-symbols
(paths package
)
354 "Return a categorized list of the symbols exported by PACKAGE.
356 Return an alist of PAIRS (PATH . SYMBOLS), for each PATH in PATHS, where
357 SYMBOLS is itself an alist (SYMBOL . KEYWORDS) listing the kinds of
358 definitions that SYMBOL has (see `categorize')."
359 (mapcar
(lambda
(assoc
)
360 (let ((home
(car assoc
))
361 (symbols
(delete-duplicates
362 (sort (mapcan
(lambda
(sym
)
368 (and foundp
(list symbol
))))
370 #'string< :key #'symbol-name))))
371 (cons home
(mapcar
(lambda
(symbol
)
372 (cons symbol
(categorize symbol
)))
374 (find-symbol-homes paths package
)))
376 ;;;--------------------------------------------------------------------------
379 (defun best-package-name
(package
)
380 "Return a convenient name for PACKAGE."
382 ;; We pick the shortest one. Strangely
, there
's no `find minimal thing
383 ;; according to this valuation' function in Common Lisp.
384 (loop with best
= (package-name package
)
385 with best-length
= (length best
)
386 for name
in (package-nicknames package
)
387 for name-length
= (length name
)
388 when
(< name-length best-length
)
390 best-length name-length
)
391 finally
(return best
)))
393 (defvar charbuf-size
0)
395 (defun exported-symbol-p
(symbol
&optional
(package
(symbol-package symbol
)))
396 "Return whether SYMBOL is exported by PACKAGE.
398 PACKAGE default's to the SYMBOL's home package, but may be different."
400 (multiple-value-bind
(sym how
)
401 (find-symbol
(symbol-name symbol
) package
)
403 (eq how
:external
)))))
405 (defun downcase-or-escape
(name
)
406 "Return a presentable form for a symbol or package name.
408 If NAME consists only of uppercase letters and ordinary punctuation, then
409 return NAME in lowercase; otherwise wrap it in `|...|' and escape as
412 (if (every
(lambda
(char
)
413 (or
(upper-case-p char
)
415 (member char
'(#\% #\+ #\- #\* #\/ #\= #\[ #\] #\?))))
417 (string-downcase name)
418 (with-output-to-string (out)
420 (map nil (lambda (char)
421 (when (or (char= char #\|)
423 (write-char #\\ out))
424 (write-char char out))
426 (write-char #\| out))))
428 (defun pretty-symbol-name (symbol package)
429 "Return a presentable form for SYMBOL, relative to PACKAGE.
431 If SYMBOL is exported by PACKAGE then just write the SYMBOL's name
432 otherwise prefix the name with the SYMBOL
's home package name, separated
433 joined with one or two colons. Uninterned symbols and keywords are also
436 (let ((pkg (symbol-package symbol))
437 (exportp (exported-symbol-p symbol)))
438 (format nil "~:[~A:~:[:~;~]~;~2*~]~A"
439 (and exportp (eq pkg package))
440 (cond ((keywordp symbol) "")
442 (t (downcase-or-escape (best-package-name pkg))))
443 (or exportp (null pkg))
444 (downcase-or-escape (symbol-name symbol)))))
446 (deftype interesting-class ()
447 "The type of `interesting' classes
, which might be user-defined.
"
450 #.(class-name (class-of (find-class 'condition)))))
452 (defun analyse-classes (package)
453 "Print a report on the classes defined by PACKAGE.
"
455 ;; Canonify PACKAGE into a package object.
456 (setf package (find-package package))
458 (let ((classes (mapcan (lambda (symbol)
459 (let ((class (find-class symbol nil)))
461 (typep class 'interesting-class)
463 (list-exported-symbols package)))
464 (subs (make-hash-table)))
465 ;; CLASSES is a list of the `interesting' classes defined by (i.e., whose
466 ;; names are exported by) PACKAGE. SUBS maps a class to those of its
467 ;; direct subclasses which are relevant to our report.
469 ;; Populate the SUBS table.
470 (let ((done (make-hash-table)))
471 (labels ((walk-up (class)
472 (unless (gethash class done)
473 (dolist (super (class-direct-superclasses class))
474 (push class (gethash super subs))
476 (setf (gethash class done) t))))
477 (dolist (class classes)
480 (labels ((walk-down (this super depth)
481 ;; Recursively traverse the class graph from THIS, recalling
482 ;; that our parent is SUPER, and that we are DEPTH levels
485 (format t "~v
,0T~A~@
[ [~
{~A~^ ~
}]~
]~
%"
487 (pretty-symbol-name (class-name this) package)
488 (mapcar (lambda (class)
489 (pretty-symbol-name (class-name class)
492 (class-direct-superclasses this))))
493 (dolist (sub (sort (copy-list (gethash this subs))
494 #'string< :key #'class-name))
495 (walk-down sub this (1+ depth)))))
497 ;; Print the relevant fragment of the class graph.
498 (walk-down (find-class t) nil 0))))
500 (defmacro deep-compare ((left right) &body body)
501 "Helper macro
for traversing two similar objects
in parallel.
503 Specifically it
's good at defining complex structural ordering relations,
504 answering the question: is the LEFT value strictly less than the RIGHT
507 Evaluate the BODY forms, maintaining a pair of `cursors', initially
at the
508 LEFT and RIGHT values.
510 The following
local macros are defined to
do useful things.
512 * (focus EXPR . BODY
) -- EXPR is an expression
in terms of
`it': advance
513 each of the cursors to the result of evaluating this expression, with
514 `it
' bound to the current cursor value, and evaluate the BODY in the
515 resulting environment.
517 * (update EXPR) -- as `focus', but mutate the cursors rather than
520 * (compare EXPR
) -- EXPR is an expression
in terms of the literal
521 symbols
`left' and `right
', which returns non-nil if it thinks `left'
522 is
(strictly
) less than
`right' in some sense: evaluate this both ways
523 round, and return if LEFT is determined to be less than or greater
526 * (typesw (TYPE . BODY)*) -- process each clause in turn: if the left
527 cursor value has TYPE, but the right does not, then LEFT is less than
528 RIGHT; if the right cursor value has TYPE but the left does not, then
529 LEFT is greater than RIGHT; otherwise, evaluate BODY."
531 (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-"))
532 (l (gensym "LEFT-")) (r (gensym "RIGHT-")))
533 `(macrolet
((focus
(expr &body body
)
534 `(flet ((,',func (it) ,expr))
535 (let ((,',l (,',func ,',l))
536 (,',r (,',func ,',r)))
539 `(flet
((,',func (it) ,expr))
540 (psetf ,',l
(,',func ,',l
)
541 ,',r (,',func
,',r))))
543 `(cond ((let ((left ,',l
) (right
,',r)) ,expr)
544 (return-from ,',block t
))
545 ((let ((right
,',l) (left ,',r
)) ,expr)
546 (return-from
,',block nil))))
547 (typesw (&rest clauses)
548 (labels ((iter (clauses)
551 (destructuring-bind
(type &rest body
)
555 `(if (typep
,',l ',type)
556 (if (typep
,',r ',type)
558 (return-from
,',block t))
559 (if (typep ,',r
',type)
560 (return-from ,',block nil
)
561 ,(iter
(cdr clauses
)))))))))
563 (let ((,l
,left
) (,r
,right
))
567 (defun order-specializers
(la lb
)
568 "Return whether specializers LA should be sorted before LB."
570 (deep-compare
(la lb
)
571 ;; Iterate over the two lists. The cursors advance down the spine
, and
572 ;; we focus on each car
in turn.
575 (typesw
(null
(return nil
)))
576 ;; If one list reaches the end
, then it
's lesser; if both, they're
580 ;; Examine the two specializers
at this position.
582 (typesw
(eql-specializer
583 (focus
(eql-specializer-object it
)
584 ;; We found an
`eql' specializer. Compare the objects.
587 ;; Keywords compare by name.
589 (compare (string< left right)))
592 ;; Symbols compare by package and name.
594 (focus (package-name (symbol-package it))
595 (compare (string< left right)))
596 (compare (string< left right)))
599 ;; Compare two other objects by comparing their
600 ;; string representations.
602 (focus (with-output-to-string (out)
605 (compare (string< left right)))))))
608 ;; We found a class, Compare the class names.
609 (focus (class-name it)
610 (focus (package-name (symbol-package it))
611 (compare (string< left right)))
612 (compare (string< left right))))
615 ;; We found some other kind of specializer that we don't
618 (error "unexpected things"))))
620 ;; No joy with that pair of specializers: try the next.
623 (defun analyse-generic-functions (package)
624 "Print a report of the generic functions and methods defined by PACKAGE."
626 ;; Canonify package into a package object.
627 (setf package (find-package package))
629 (flet ((function-name-core (name)
630 ;; Return the underlying name for a function NAME. Specifically,
631 ;; if NAME is (setf THING) then the core is THING; if NAME is a
632 ;; symbol then the core is simply NAME; otherwise we're confused.
633 ;; Return a second value to say whether we got the job done.
636 (symbol (values name t))
637 ((cons (eql setf) t) (values (cadr name) t))
638 (t (values nil nil)))))
640 (let ((methods (make-hash-table))
641 (functions (make-hash-table))
642 (externs (make-hash-table)))
643 ;; EXTERNS is a set of the symbols exported by PACKAGE. FUNCTIONS and
644 ;; METHODS are sets of generic function names (not cores), and method
645 ;; objects, which we've decided are worth reporting.
647 ;; Collect the EXTERNS symbols.
648 (dolist (symbol (list-exported-symbols package))
649 (setf (gethash symbol externs) t))
651 ;; Collect the FUNCTIONS and METHODS.
652 (dolist (symbol (list-exported-symbols package))
654 ;; Mark the generic functions and `setf
'-functions named by exported
655 ;; symbols as interesting, along with all of their methods.
656 (flet ((dofunc (func)
657 (when (typep func 'generic-function
)
658 (setf
(gethash func functions
) t
)
659 (dolist
(method
(generic-function-methods func
))
660 (setf
(gethash method methods
) t
)))))
661 (dofunc
(and
(fboundp symbol
) (fdefinition symbol
)))
662 (dofunc
(ignore-errors
(fdefinition
(list
'setf symbol)))))
664 ;; For symbols whose home package is PACKAGE, and which name a class,
665 ;; also collect functions with methods specialized on that class, and
666 ;; (only) the specialized methods.
667 (when (eq (symbol-package symbol) package)
668 (let ((class (find-class symbol nil)))
670 (dolist (func (specializer-direct-generic-functions class))
671 (multiple-value-bind (name knownp)
672 (function-name-core (generic-function-name func))
674 (or (not (eq (symbol-package name) package))
675 (gethash name externs)))
676 (setf (gethash func functions) t)
677 (dolist (method (specializer-direct-methods class))
678 (setf (gethash method methods) t)))))))))
681 (let ((funclist nil))
683 ;; Gather the functions we've decided are interesting
, and
sort them.
684 (maphash
(lambda
(func value
)
685 (declare (ignore value
))
686 (push func funclist
))
688 (setf funclist
(sort funclist
690 ;; Sort by the core symbols
, and order the
691 ;; `setf' variant after the base version.
692 (let ((core-a (function-name-core a))
693 (core-b (function-name-core b)))
694 (if (eq core-a core-b)
695 (and (atom a) (consp b))
696 (string< core-a core-b))))
697 :key #'generic-function-name))
699 (dolist (function funclist)
700 ;; Print out each function in turn.
702 ;; Print the header line.
703 (let ((name (generic-function-name function)))
706 (format t "~A~%" (pretty-symbol-name name package)))
708 (format t "(setf ~A)~%"
709 (pretty-symbol-name (cadr name) package)))))
711 ;; Report on the function's (interesting) methods.
712 (dolist (method (sort (copy-list
713 (generic-function-methods function))
715 :key #'method-specializers))
717 (when (gethash method methods)
718 (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%"
723 (let ((name (class-name spec)))
725 (pretty-symbol-name name package))))
727 (let ((obj (eql-specializer-object spec)))
728 (format nil "(eql ~A)"
730 (pretty-symbol-name obj package)
732 (method-specializers method))
733 (method-qualifiers method)))))))))
735 (defun check-slot-names (package)
736 "Check that PACKAGE defines no slots whose names are exported symbols.
738 This acts to discourage the use of `slot-value
' by external callers.
741 * an alist of entries (CLASS . SLOT-NAMES), listing for each offending
742 class, whose of its slot names which are either (a) external or (b)
743 from a foreign package; and
745 * the distilled list of bad SLOT-NAMES."
747 ;; Canonify PACKAGE into a package objects.
748 (setf package (find-package package))
750 (let* ((symbols (list-all-symbols package))
752 ;; Determine all of the named classes.
753 (classes (mapcan (lambda (symbol)
754 (when (eq (symbol-package symbol) package)
755 (let ((class (find-class symbol nil)))
756 (and class (list class)))))
759 ;; Build the main alist of offending classes and slots.
763 (mapcar #'slot-definition-name
764 (class-direct-slots class
)))
767 (or
(not
(symbol-package sym
))
768 (and
(not
(exported-symbol-p
770 (eq
(symbol-package sym
)
774 (list
(cons
(class-name class
)
778 ;; Distill the bad slot names into a separate list.
779 (bad-words
(remove-duplicates
(mapcan
(lambda
(list
)
780 (copy-list
(cdr list
)))
784 (values offenders bad-words
)))
786 (defun report-symbols
(paths package
)
787 "Report on all of the symbols defined in PACKAGE by the files in PATHS."
789 ;; Canonify PACKAGE to a package object.
790 (setf package
(find-package package
))
792 ;; Print the breakdown of symbols by
source file, with their purposes.
793 (format t
"~A~%Package `~(~A~)'~2%"
794 (make-string
77 :initial-element
#\-)
795 (package-name package
))
796 (dolist
(assoc
(sort (categorize-symbols paths package
) #'string<
798 (file-namestring
(car assoc
)))))
800 (format t
"~A~%" (file-namestring
(car assoc
)))
801 (dolist
(def
(cdr assoc
))
802 (let ((sym
(car def
)))
803 (format t
" ~A~@[~48T~{~(~A~)~^ ~}~]~%"
804 (pretty-symbol-name sym package
)
808 ;; Report on leaked slot names
, if any are exported or foreign.
809 (multiple-value-bind
(alist names
) (check-slot-names package
)
811 (format t
"Leaked slot names: ~{~A~^, ~}~%"
812 (mapcar
(lambda
(name
) (pretty-symbol-name name package
))
814 (dolist
(assoc alist
)
815 (format t
"~2T~A: ~{~A~^, ~}~%"
816 (pretty-symbol-name
(car assoc
) package
)
817 (mapcar
(lambda
(name
) (pretty-symbol-name name package
))
821 ;; Report on classes and generic functions.
822 (format t
"Classes:~%")
823 (analyse-classes package
)
825 (format t
"Methods:~%")
826 (analyse-generic-functions package
)
829 (export 'report-project-symbols)
830 (defun report-project-symbols ()
831 "Write to `*standard-output*' a report on all of the symbols
in Sod.
"
833 (labels ((components (comp)
834 ;; Return the subcomponents of an ASDF component.
836 (asdf:component-children comp))
839 ;; Return a list of files needed by an ASDF component.
841 (sort (remove-if-not (lambda (comp)
842 (typep comp 'asdf:cl-source-file))
844 #'string< :key #'asdf:component-name))
847 ;; Find the subcomponent called NAME of an ASDF component.
849 (gethash name (asdf:component-children-by-name comp)))
852 ;; Return the pathname of an ASDF file component.
854 (slot-value file 'asdf/component:absolute-pathname)))
856 (let* ((sod (asdf:find-system "sod
"))
857 (parser-files (files (by-name sod "parser
")))
858 (utilities (by-name sod "utilities
"))
859 (sod-frontend (asdf:find-system "sod-frontend
"))
860 (optparse (by-name sod "optparse
"))
861 (frontend (by-name sod-frontend "frontend
"))
862 (sod-files (set-difference (files sod) (list optparse utilities))))
864 ;; Report on the various major pieces of the project.
865 (report-symbols (mapcar #'file-name sod-files) "SOD
")
866 (report-symbols (mapcar #'file-name (list frontend)) "SOD-FRONTEND
")
867 (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER
")
868 (report-symbols (mapcar #'file-name (list optparse)) "OPTPARSE
")
869 (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES
"))))
871 ;;;--------------------------------------------------------------------------
872 ;;; Command-line use.
875 "Write a report to
`doc/SYMBOLS'."
876 (with-open-file (*standard-output* #p"doc/SYMBOLS"
878 :if-exists :supersede
879 :if-does-not-exist :create)
880 (report-project-symbols)))
884 ;;;----- That's all, folks --------------------------------------------------