1 ;;;; the DESCRIBE system
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 ;;; SB-IMPL, not SB!IMPL, since we're built in warm load.
13 (in-package "SB-IMPL")
15 ;;;; Utils, move elsewhere.
17 (defun class-name-or-class (class)
18 (let ((name (class-name class
)))
19 (if (eq class
(find-class name nil
))
24 (if (typep x
'standard-generic-function
)
25 (sb-pcl:generic-function-name x
)
28 ;;;; the ANSI interface to function names (and to other stuff too)
29 ;;; Note: this function gets called by the compiler (as of 1.0.17.x,
30 ;;; in MAYBE-INLINE-SYNTACTIC-CLOSURE), and so although ANSI says
31 ;;; we're allowed to return NIL here freely, it seems plausible that
32 ;;; small changes to the circumstances under which this function
33 ;;; returns non-NIL might have subtle consequences on the compiler.
34 ;;; So it might be desirable to have the compiler not rely on this
35 ;;; function, eventually.
36 (defun function-lambda-expression (fun)
38 "Return (VALUES DEFINING-LAMBDA-EXPRESSION CLOSURE-P NAME), where
39 DEFINING-LAMBDA-EXPRESSION is NIL if unknown, or a suitable argument
40 to COMPILE otherwise, CLOSURE-P is non-NIL if the function's definition
41 might have been enclosed in some non-null lexical environment, and
42 NAME is some name (for debugging only) or NIL if there is no name."
43 (declare (type function fun
))
46 (sb-eval:interpreted-function
47 (let ((name (sb-eval:interpreted-function-name fun
))
48 (lambda-list (sb-eval:interpreted-function-lambda-list fun
))
49 (declarations (sb-eval:interpreted-function-declarations fun
))
50 (body (sb-eval:interpreted-function-body fun
)))
51 (values `(lambda ,lambda-list
52 ,@(when declarations
`((declare ,@declarations
)))
56 (let* ((name (fun-name fun
))
57 (fun (%simple-fun-self
(%fun-fun fun
)))
58 (code (sb-di::fun-code-header fun
))
59 (info (sb-kernel:%code-debug-info code
))
60 (source (if info
(sb-c::debug-info-source info
))))
61 (cond ((and source
(sb-c::debug-source-form source
)
62 (eq (sb-c::debug-source-function source
) fun
))
63 (values (sb-c::debug-source-form source
) nil name
))
64 ((legal-fun-name-p name
)
65 (let ((exp (fun-name-inline-expansion name
)))
66 (values exp
(not exp
) name
)))
68 (values nil t name
)))))))
70 ;;; Prints X on a single line, limiting output length by *PRINT-RIGHT-MARGIN*
71 ;;; -- good for printing object parts, etc.
72 (defun prin1-to-line (x &key
(columns 1) (reserve 0))
73 (let* ((line (write-to-string x
:escape t
:readably nil
:lines
2 :circle t
))
74 (p (position #\newline line
))
75 (limit (truncate (- *print-right-margin
* reserve
) columns
)))
76 (flet ((trunc (&optional end
)
77 (let ((line-end (- limit
2)))
78 (with-simple-output-to-string (s)
79 (write-string line s
:end
(if end
82 (write-string ".." s
)))))
85 ((> (length line
) limit
)
90 (defun describe (object &optional
(stream-designator *standard-output
*))
92 "Print a description of OBJECT to STREAM-DESIGNATOR."
93 (let ((stream (out-synonym-of stream-designator
))
94 (*print-right-margin
* (or *print-right-margin
* 72))
96 (*suppress-print-errors
*
97 (if (subtypep 'serious-condition
*suppress-print-errors
*)
98 *suppress-print-errors
*
100 ;; Until sbcl-0.8.0.x, we did
101 ;; (FRESH-LINE STREAM)
102 ;; (PPRINT-LOGICAL-BLOCK (STREAM NIL)
104 ;; here. However, ANSI's specification of DEFUN DESCRIBE,
105 ;; DESCRIBE exists as an interface primarily to manage argument
106 ;; defaulting (including conversion of arguments T and NIL into
107 ;; stream objects) and to inhibit any return values from
109 ;; doesn't mention either FRESH-LINEing or PPRINT-LOGICAL-BLOCKing,
110 ;; and the example of typical DESCRIBE-OBJECT behavior in ANSI's
111 ;; specification of DESCRIBE-OBJECT will work poorly if we do them
112 ;; here. (The example method for DESCRIBE-OBJECT does its own
113 ;; FRESH-LINEing, which is a physical directive which works poorly
114 ;; inside a pretty-printer logical block.)
115 (handler-bind ((print-not-readable #'print-unreadably
))
116 (describe-object object stream
))
117 ;; We don't TERPRI here either (any more since sbcl-0.8.0.x), because
118 ;; again ANSI's specification of DESCRIBE doesn't mention it and
119 ;; ANSI's example of DESCRIBE-OBJECT does its own final TERPRI.
126 ;;;; * Each interesting class has a primary method of its own.
128 ;;;; * Output looks like
130 ;;;; object-self-string
131 ;;;; [object-type-string]
140 ;;;; * The newline policy that gets the whitespace right is for
141 ;;;; each block to both start and end with a newline.
143 (defgeneric object-self-string
(x))
145 (defmethod object-self-string (x)
148 (defmethod object-self-string ((x symbol
))
149 (let ((*package
* (find-package :keyword
)))
150 (prin1-to-string x
)))
152 (defgeneric object-type-string
(x))
154 (defmethod object-type-string (x)
155 (let ((type (class-name-or-class (class-of x
))))
157 (string-downcase type
)
158 (prin1-to-string type
))))
160 (defmethod object-type-string ((x cons
))
161 (if (listp (cdr x
)) "list" "cons"))
163 (defmethod object-type-string ((x hash-table
))
166 (defmethod object-type-string ((x condition
))
169 (defmethod object-type-string ((x structure-object
))
172 (defmethod object-type-string ((x standard-object
))
175 (defmethod object-type-string ((x function
))
177 (simple-fun "compiled function")
178 (closure "compiled closure")
180 (sb-eval:interpreted-function
181 "interpreted function")
185 "funcallable-instance")))
187 (defmethod object-type-string ((x stream
))
190 (defmethod object-type-string ((x sb-gray
:fundamental-stream
))
193 (defmethod object-type-string ((x package
))
196 (defmethod object-type-string ((x array
))
197 (cond ((or (stringp x
) (bit-vector-p x
))
198 (format nil
"~@[simple-~*~]~A"
199 (typep x
'simple-array
)
201 (base-string "base-string")
205 (if (simple-vector-p x
)
207 (format nil
"~@[simple ~*~]~@[specialized ~*~]~:[array~;vector~]"
208 (typep x
'simple-array
)
209 (neq t
(array-element-type x
))
212 (defmethod object-type-string ((x character
))
214 (standard-char "standard-char")
215 (base-char "base-char")
218 (defun print-standard-describe-header (x stream
)
219 (format stream
"~&~A~% [~A]~%"
220 (object-self-string x
)
221 (object-type-string x
)))
223 (defgeneric describe-object
(x stream
))
227 (defmethod describe-object ((x t
) s
)
228 (print-standard-describe-header x s
))
230 (defmethod describe-object ((x cons
) s
)
231 (print-standard-describe-header x s
)
232 (describe-function x nil s
))
234 (defmethod describe-object ((x function
) s
)
235 (print-standard-describe-header x s
)
236 (describe-function nil x s
))
238 (defmethod describe-object ((x class
) s
)
239 (print-standard-describe-header x s
)
240 (describe-class nil x s
)
241 (describe-instance x s
))
243 (defmethod describe-object ((x sb-pcl
::slot-object
) s
)
244 (print-standard-describe-header x s
)
245 (describe-instance x s
))
247 (defmethod describe-object ((x character
) s
)
248 (print-standard-describe-header x s
)
249 (format s
"~%Char-code: ~S" (char-code x
))
250 (format s
"~%Char-name: ~A" (char-name x
)))
252 (defmethod describe-object ((x array
) s
)
253 (print-standard-describe-header x s
)
254 (format s
"~%Element-type: ~S" (array-element-type x
))
256 (if (array-has-fill-pointer-p x
)
257 (format s
"~%Fill-pointer: ~S~%Size: ~S"
259 (array-total-size x
))
260 (format s
"~%Length: ~S" (length x
)))
261 (format s
"~%Dimensions: ~S" (array-dimensions x
)))
262 (let ((*print-array
* nil
))
263 (unless (typep x
'simple-array
)
264 (format s
"~%Adjustable: ~A" (if (adjustable-array-p x
) "yes" "no"))
265 (multiple-value-bind (to offset
) (array-displacement x
)
266 (if (format s
"~%Displaced-to: ~A~%Displaced-offset: ~S"
269 (format s
"~%Displaced: no"))))
270 (when (and (not (array-displacement x
)) (array-header-p x
))
271 (format s
"~%Storage vector: ~A"
272 (prin1-to-line (array-storage-vector x
))))
275 (defmethod describe-object ((x hash-table
) s
)
276 (print-standard-describe-header x s
)
277 ;; Don't print things which are already apparent from the printed
278 ;; representation -- COUNT, TEST, and WEAKNESS
279 (format s
"~%Occupancy: ~,1F" (float (/ (hash-table-count x
)
280 (hash-table-size x
))))
281 (format s
"~%Rehash-threshold: ~S" (hash-table-rehash-threshold x
))
282 (format s
"~%Rehash-size: ~S" (hash-table-rehash-size x
))
283 (format s
"~%Size: ~S" (hash-table-size x
))
284 (format s
"~%Synchronized: ~A" (if (hash-table-synchronized-p x
) "yes" "no"))
287 (defmethod describe-object ((symbol symbol
) stream
)
288 (print-standard-describe-header symbol stream
)
289 ;; Describe the value cell.
290 (let* ((kind (info :variable
:kind symbol
))
292 (:special
"a special variable")
293 (:macro
"a symbol macro")
294 (:constant
"a constant variable")
295 (:global
"a global variable")
296 (:unknown
"an undefined variable")
297 (:alien
"an alien variable"))))
298 (when (or (not (eq :unknown kind
)) (boundp symbol
))
299 (pprint-logical-block (stream nil
)
300 (format stream
"~@:_~A names ~A:" symbol wot
)
301 (pprint-indent :block
2 stream
)
302 (when (eq (info :variable
:where-from symbol
) :declared
)
303 (format stream
"~@:_Declared type: ~S"
304 (type-specifier (info :variable
:type symbol
))))
305 (when (info :variable
:always-bound symbol
)
306 (format stream
"~@:_Declared always-bound."))
309 (let ((info (info :variable
:alien-info symbol
)))
310 (format stream
"~@:_Value: ~S" (eval symbol
))
311 (format stream
"~@:_Type: ~S"
312 (sb-alien-internals:unparse-alien-type
313 (sb-alien::heap-alien-info-type info
)))
314 (format stream
"~@:_Address: #x~8,'0X"
315 (sap-int (sb-alien::heap-alien-info-sap info
)))))
317 (let ((expansion (info :variable
:macro-expansion symbol
)))
318 (format stream
"~@:_Expansion: ~S" expansion
)))
320 (format stream
"~:@_Value: ~S" (symbol-value symbol
)))
321 ((not (eq kind
:unknown
))
322 (format stream
"~:@_Currently unbound.")))
323 (describe-documentation symbol
'variable stream
)
326 ;; TODO: We could grovel over all packages looking for and
327 ;; reporting other phenomena, e.g. IMPORT and SHADOW, or
328 ;; availability in some package even after (SYMBOL-PACKAGE SYMBOL) has
331 ;; TODO: It might also be nice to describe (find-package symbol)
332 ;; if one exists. Maybe not all the exports, etc, but the package
334 (describe-function symbol nil stream
)
335 (describe-class symbol nil stream
)
338 (let* ((kind (info :type
:kind symbol
))
341 (or (info :type
:expander symbol
) t
))
343 (or (info :type
:translator symbol
) t
)))))
345 (pprint-newline :mandatory stream
)
346 (pprint-logical-block (stream nil
)
347 (format stream
"~@:_~A names a ~@[primitive~* ~]type-specifier:"
349 (eq kind
:primitive
))
350 (pprint-indent :block
2 stream
)
351 (describe-documentation symbol
'type stream
(eq t fun
))
353 ;; even though :translator can store a CTYPE, this is safe
354 ;; because a symbol can't have a non-FUNCTIONP translator.
355 (describe-lambda-list (%fun-lambda-list fun
) stream
)
356 (multiple-value-bind (expansion ok
)
357 (handler-case (typexpand-1 symbol
)
358 (error () (values nil nil
)))
360 (format stream
"~@:_Expansion: ~S" expansion
)))))
363 (awhen (sb-c::policy-quality-name-p symbol
)
364 (pprint-logical-block (stream nil
)
365 (pprint-newline :mandatory stream
)
366 (pprint-indent :block
2 stream
)
367 (format stream
"~A names a~:[ dependent~;n~] optimization policy quality:"
369 (describe-documentation symbol
'optimize stream t
))
372 ;; Print out properties.
373 (let ((plist (symbol-plist symbol
)))
375 (pprint-logical-block (stream nil
)
376 (format stream
"~%Symbol-plist:")
377 (pprint-indent :block
2 stream
)
378 (sb-pcl::doplist
(key value
) plist
379 (format stream
"~@:_~A -> ~A"
380 (prin1-to-line key
:columns
2 :reserve
5)
381 (prin1-to-line value
:columns
2 :reserve
5))))
384 (defmethod describe-object ((package package
) stream
)
385 (print-standard-describe-header package stream
)
386 (pprint-logical-block (stream nil
)
387 (describe-documentation package t stream
)
388 (flet ((humanize (list)
389 (sort (mapcar (lambda (x)
396 (describe-stuff label list stream
:escape nil
)))
398 (do-external-symbols (ext package
)
401 (let ((implemented (humanize (package-implemented-by-list package
)))
402 (implements (humanize (package-implements-list package
)))
403 (this (list (package-name package
))))
404 (when (package-locked-p package
)
405 (format stream
"~@:_Locked."))
406 (when (set-difference implemented this
:test
#'string
=)
407 (out "Implemented-by-list" implemented
))
408 (when (set-difference implements this
:test
#'string
=)
409 (out "Implements-list" implements
)))
410 (out "Nicknames" (humanize (package-nicknames package
)))
411 (out "Use-list" (humanize (package-use-list package
)))
412 (out "Used-by-list" (humanize (package-used-by-list package
)))
413 (out "Shadows" (humanize (package-shadowing-symbols package
)))
414 (out "Exports" (humanize exports
))
415 (format stream
"~@:_~S internal symbols."
416 (package-internal-symbol-count package
))))
419 ;;;; Helpers to deal with shared functionality
421 (defun describe-class (name class stream
)
422 (let* ((by-name (not class
))
423 (name (if class
(class-name class
) name
))
424 (class (if class class
(find-class name nil
))))
426 (let ((metaclass-name (class-name (class-of class
))))
427 (pprint-logical-block (stream nil
)
429 (format stream
"~@:_~A names the ~(~A~) ~S:"
433 (pprint-indent :block
2 stream
))
434 (describe-documentation class t stream
)
435 (when (sb-mop:class-finalized-p class
)
436 (describe-stuff "Class precedence-list"
437 (mapcar #'class-name-or-class
(sb-mop:class-precedence-list class
))
439 (describe-stuff "Direct superclasses"
440 (mapcar #'class-name-or-class
(sb-mop:class-direct-superclasses class
))
442 (let ((subs (mapcar #'class-name-or-class
(sb-mop:class-direct-subclasses class
))))
444 (describe-stuff "Direct subclasses" subs stream
)
445 (format stream
"~@:_No subclasses.")))
446 (unless (sb-mop:class-finalized-p class
)
447 (format stream
"~@:_Not yet finalized."))
448 (if (eq 'structure-class metaclass-name
)
449 (let* ((dd (find-defstruct-description name
))
450 (slots (dd-slots dd
)))
452 (format stream
"~@:_Slots:~:{~@:_ ~S~
453 ~@:_ Type: ~A ~@[~A~]~
455 (mapcar (lambda (dsd)
459 (unless (eq t
(dsd-raw-type dsd
))
463 (format stream
"~@:_No slots.")))
464 (let ((slots (sb-mop:class-direct-slots class
)))
466 (format stream
"~@:_Direct slots:~:{~@:_ ~S~
468 ~@[~@:_ Allocation: ~S~]~
469 ~@[~@:_ Initargs: ~{~S~^, ~}~]~
470 ~@[~@:_ Initform: ~S~]~
471 ~@[~@:_ Readers: ~{~S~^, ~}~]~
472 ~@[~@:_ Writers: ~{~S~^, ~}~]~
473 ~@[~@:_ Documentation:~@:_ ~@<~@;~A~:>~]~}"
474 (mapcar (lambda (slotd)
475 (list (sb-mop:slot-definition-name slotd
)
476 (let ((type (sb-mop:slot-definition-type slotd
)))
477 (unless (eq t type
) type
))
478 (let ((alloc (sb-mop:slot-definition-allocation slotd
)))
479 (unless (eq :instance alloc
) alloc
))
480 (sb-mop:slot-definition-initargs slotd
)
481 (sb-mop:slot-definition-initform slotd
)
482 (sb-mop:slot-definition-readers slotd
)
483 (sb-mop:slot-definition-writers slotd
)
484 ;; FIXME: does this get the prefix right?
485 (quiet-doc slotd t
)))
487 (format stream
"~@:_No direct slots."))))
488 (pprint-indent :block
0 stream
)
489 (pprint-newline :mandatory stream
))))))
491 (defun describe-instance (object stream
)
492 (let* ((class (class-of object
))
493 (slotds (sb-mop:class-slots class
))
494 (max-slot-name-length 0)
497 ;; Figure out a good width for the slot-name column.
498 (flet ((adjust-slot-name-length (name)
499 (setf max-slot-name-length
500 (max max-slot-name-length
(length (symbol-name name
))))))
501 (dolist (slotd slotds
)
502 (adjust-slot-name-length (sb-mop:slot-definition-name slotd
))
503 (push slotd
(getf plist
(sb-mop:slot-definition-allocation slotd
))))
504 (setf max-slot-name-length
(min (+ max-slot-name-length
3) 30)))
506 ;; Now that we know the width, we can print.
507 (flet ((describe-slot (name value
)
508 (format stream
"~% ~A~VT = ~A" name max-slot-name-length
509 (prin1-to-line value
))))
510 (sb-pcl::doplist
(allocation slots
) plist
511 (format stream
"~%Slots with ~S allocation:" allocation
)
512 (dolist (slotd (nreverse slots
))
514 (sb-mop:slot-definition-name slotd
)
515 (sb-pcl::slot-value-or-default object
(sb-mop:slot-definition-name slotd
))))))
517 (format stream
"~@:_No slots."))
520 (defun quiet-doc (object type
)
521 (handler-bind ((warning #'muffle-warning
))
522 (documentation object type
)))
524 (defun describe-documentation (object type stream
&optional undoc newline
)
525 (let ((doc (quiet-doc object type
)))
527 (format stream
"~@:_Documentation:~@:_")
528 (pprint-logical-block (stream nil
:per-line-prefix
" ")
531 (format stream
"~@:_(undocumented)")))
533 (pprint-newline :mandatory stream
))))
535 (defun describe-stuff (label list stream
&key
(escape t
))
538 (format stream
"~@:_~A:~@<~;~{ ~S~^,~:_~}~;~:>" label list
)
539 (format stream
"~@:_~A:~@<~;~{ ~A~^,~:_~}~;~:>" label list
))))
541 (defun describe-lambda-list (lambda-list stream
)
542 (let ((*print-circle
* nil
)
545 (format stream
"~@:_Lambda-list: ~:A" lambda-list
)))
547 (defun describe-function-source (function stream
)
548 (if (compiled-function-p function
)
549 (let* ((code (fun-code-header (%fun-fun function
)))
550 (info (sb-kernel:%code-debug-info code
)))
552 (let ((source (sb-c::debug-info-source info
)))
554 (let ((namestring (sb-c::debug-source-namestring source
)))
555 ;; This used to also report the times the source was created
556 ;; and compiled, but that seems more like noise than useful
557 ;; information -- but FWIW that are to be had as
558 ;; SB-C::DEBUG-SOUCE-CREATED/COMPILED.
560 (format stream
"~@:_Source file: ~A" namestring
))
561 ((sb-di:debug-source-form source
)
562 (format stream
"~@:_Source form:~@:_ ~S"
563 (sb-di:debug-source-form source
)))))))))
565 (let ((source (sb-eval:interpreted-function-source-location function
)))
567 (let ((namestring (sb-c:definition-source-location-namestring source
)))
569 (format stream
"~@:_Source file: ~A" namestring
)))))))
571 (defun describe-function (name function stream
)
572 (let ((name (if function
(fun-name function
) name
)))
573 (if (not (or function
(and (legal-fun-name-p name
) (fboundp name
))))
574 ;; Not defined, but possibly the type is declared, or we have
575 ;; compiled calls to it.
576 (when (legal-fun-name-p name
)
577 (multiple-value-bind (from sure
) (info :function
:where-from name
)
578 (when (or (eq :declared from
) (and sure
(eq :assumed from
)))
579 (pprint-logical-block (stream nil
)
580 (format stream
"~%~A names an undefined function" name
)
581 (pprint-indent :block
2 stream
)
582 (format stream
"~@:_~:(~A~) type: ~S"
584 (type-specifier (info :function
:type name
)))))))
586 (multiple-value-bind (fun what lambda-list derived-type declared-type
588 (cond ((and (not function
) (symbolp name
) (special-operator-p name
))
589 ;; The function in the symbol is irrelevant.
590 ;; Use the def-ir1-translator function for source location.
591 (let ((fun (info :function
:ir1-convert name
)))
592 (values fun
"a special operator" (%fun-lambda-list fun
))))
593 ((and (not function
) (symbolp name
) (macro-function name
))
594 (let ((fun (macro-function name
)))
595 (values fun
"a macro" (%fun-lambda-list fun
))))
597 (let* ((fun (or function
(fdefinition name
)))
598 (derived-type (and function
599 (%fun-type function
)))
600 (legal-name-p (legal-fun-name-p name
))
601 (ctype (and legal-name-p
602 (info :function
:type name
)))
603 (type (and ctype
(type-specifier ctype
)))
604 (from (and legal-name-p
605 (info :function
:where-from name
)))
607 ;; Ensure lazy pickup of information
610 (sb-c::maybe-update-info-for-gf name
))
613 (setf declared-type type
))
614 ((and (not derived-type
)
615 (member from
'(:defined-method
:defined
)))
616 (setf derived-type type
)))
618 (setf derived-type
(%fun-type fun
)))
619 (if (typep fun
'standard-generic-function
)
622 (sb-mop:generic-function-lambda-list fun
)
626 (or (sb-mop:generic-function-methods fun
)
629 (if (compiled-function-p fun
)
630 "a compiled function"
631 "an interpreted function")
632 (%fun-lambda-list fun
)
636 (info :function
:inlinep name
)
637 (info :function
:inline-expansion-designator
639 (pprint-logical-block (stream nil
)
641 (format stream
"~%~A names ~A:" name what
)
642 (pprint-indent :block
2 stream
))
643 (describe-lambda-list lambda-list stream
)
645 (format stream
"~@:_Declared type: ~S" declared-type
))
646 (when (and derived-type
647 (not (equal declared-type derived-type
)))
648 (format stream
"~@:_Derived type: ~S" derived-type
))
649 (describe-documentation name
'function stream
)
651 (format stream
"~@:_Inline proclamation: ~
652 ~A (~:[no ~;~]inline expansion available)"
655 (awhen (info :function
:info name
)
656 (awhen (sb-c::decode-ir1-attributes
(sb-c::fun-info-attributes it
))
657 (format stream
"~@:_Known attributes: ~(~{~A~^, ~}~)" it
)))
659 (format stream
"~@:_Method-combination: ~S"
660 (sb-pcl::method-combination-type-name
661 (sb-pcl:generic-function-method-combination fun
)))
662 (cond ((eq :none methods
)
663 (format stream
"~@:_No methods."))
665 (pprint-newline :mandatory stream
)
666 (pprint-logical-block (stream nil
)
667 (format stream
"Methods:")
668 (dolist (method methods
)
669 (pprint-indent :block
2 stream
)
670 (format stream
"~@:_(~A ~{~S ~}~:S)"
672 (method-qualifiers method
)
673 (sb-pcl::unparse-specializers
674 fun
(sb-mop:method-specializers method
)))
675 (pprint-indent :block
4 stream
)
676 (describe-documentation method t stream nil
))))))
677 (describe-function-source fun stream
)
680 (awhen (and (legal-fun-name-p name
) (compiler-macro-function name
))
681 (pprint-logical-block (stream nil
)
682 (format stream
"~@:_~A has a compiler-macro:" name
)
683 (pprint-indent :block
2 stream
)
684 (describe-documentation it t stream
)
685 (describe-function-source it stream
))
687 (when (and (consp name
) (eq 'setf
(car name
)) (not (cddr name
)))
688 (let* ((name2 (second name
))
689 (inverse (info :setf
:inverse name2
))
690 (expander (info :setf
:expander name2
)))
692 (pprint-logical-block (stream nil
)
693 (format stream
"~&~A has setf-expansion: ~S"
695 (pprint-indent :block
2 stream
)
696 (describe-documentation name2
'setf stream
))
699 (when (listp expander
)
700 (setq expander
(cdr expander
)))
701 (pprint-logical-block (stream nil
)
702 (format stream
"~&~A has a complex setf-expansion:"
704 (pprint-indent :block
2 stream
)
705 (describe-lambda-list (%fun-lambda-list expander
) stream
)
706 (describe-documentation name2
'setf stream t
)
707 (describe-function-source expander stream
))
710 (describe-function `(setf ,name
) nil stream
))))