Fix FORMAT compilation on non-simple strings.
[sbcl.git] / src / code / describe.lisp
blob001b32ec342c85cd25170431b2a7ba7b9d7d581e
1 ;;;; the DESCRIBE system
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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))
20 name
21 class)))
23 ;;;; the ANSI interface to function names (and to other stuff too)
24 ;;; Note: this function gets called by the compiler (as of 1.0.17.x,
25 ;;; in MAYBE-INLINE-SYNTACTIC-CLOSURE), and so although ANSI says
26 ;;; we're allowed to return NIL here freely, it seems plausible that
27 ;;; small changes to the circumstances under which this function
28 ;;; returns non-NIL might have subtle consequences on the compiler.
29 ;;; So it might be desirable to have the compiler not rely on this
30 ;;; function, eventually.
31 (defun function-lambda-expression (fun)
32 "Return (VALUES DEFINING-LAMBDA-EXPRESSION CLOSURE-P NAME), where
33 DEFINING-LAMBDA-EXPRESSION is NIL if unknown, or a suitable argument
34 to COMPILE otherwise, CLOSURE-P is non-NIL if the function's definition
35 might have been enclosed in some non-null lexical environment, and
36 NAME is some name (for debugging only) or NIL if there is no name."
37 (declare (type function fun))
38 (etypecase fun
39 #+sb-eval
40 (sb-eval:interpreted-function
41 (let ((name (sb-eval:interpreted-function-name fun))
42 (lambda-list (sb-eval:interpreted-function-lambda-list fun))
43 (declarations (sb-eval:interpreted-function-declarations fun))
44 (body (sb-eval:interpreted-function-body fun)))
45 (values `(lambda ,lambda-list
46 ,@(when declarations `((declare ,@declarations)))
47 ,@body)
48 t name)))
49 #+sb-fasteval
50 (sb-interpreter:interpreted-function
51 (sb-interpreter:fun-lambda-expression fun))
52 (function
53 (let* ((name (%fun-name fun))
54 (fun (%fun-fun fun))
55 (code (sb-di::fun-code-header fun))
56 (info (sb-kernel:%code-debug-info code))
57 (source (if info (sb-c::debug-info-source info))))
58 (cond ((and source (sb-c::debug-source-form source)
59 (eq (sb-c::debug-source-function source) fun))
60 (values (sb-c::debug-source-form source) nil name))
61 ((legal-fun-name-p name)
62 (let ((exp (fun-name-inline-expansion name)))
63 (values exp (not exp) name)))
65 (values nil t name)))))))
67 ;;; Prints X on a single line, limiting output length by *PRINT-RIGHT-MARGIN*
68 ;;; -- good for printing object parts, etc.
69 (defun prin1-to-line (x &key (columns 1) (reserve 0))
70 (let* ((line (write-to-string x :escape t :readably nil :lines 2 :circle t))
71 (p (position #\newline line))
72 (limit (truncate (- *print-right-margin* reserve) columns)))
73 (flet ((trunc (&optional end)
74 (let ((line-end (- limit 2)))
75 (with-simple-output-to-string (s)
76 (write-string line s :end (if end
77 (min end line-end)
78 line-end))
79 (write-string ".." s)))))
80 (cond (p
81 (trunc p))
82 ((> (length line) limit)
83 (trunc))
85 line)))))
87 (defun call-as-describe-block (thunk stream format-control format-arguments)
88 (pprint-logical-block (stream nil)
89 (pprint-newline :mandatory stream)
90 (when format-control
91 (apply #'format stream format-control format-arguments)
92 (pprint-indent :block 2 stream))
93 (when thunk
94 (funcall thunk stream)))
95 (terpri stream))
97 (defmacro describe-block ((stream-symbol
98 &optional format-control &rest format-arguments)
99 &body body)
100 `(call-as-describe-block
101 ,(if body
102 `(lambda (,stream-symbol) ,@body)
103 nil)
104 ,stream-symbol ,format-control (list ,@format-arguments)))
106 (defun describe (object &optional (stream-designator *standard-output*))
107 "Print a description of OBJECT to STREAM-DESIGNATOR."
108 (let ((stream (out-stream-from-designator stream-designator))
109 (*print-right-margin* (or *print-right-margin* 72))
110 (*print-circle* t)
111 (*print-pretty* t)
112 (*suppress-print-errors*
113 (if (subtypep 'serious-condition *suppress-print-errors*)
114 *suppress-print-errors*
115 'serious-condition)))
116 ;; Until sbcl-0.8.0.x, we did
117 ;; (FRESH-LINE STREAM)
118 ;; (PPRINT-LOGICAL-BLOCK (STREAM NIL)
119 ;; ...
120 ;; here. However, ANSI's specification of DEFUN DESCRIBE,
121 ;; DESCRIBE exists as an interface primarily to manage argument
122 ;; defaulting (including conversion of arguments T and NIL into
123 ;; stream objects) and to inhibit any return values from
124 ;; DESCRIBE-OBJECT.
125 ;; doesn't mention either FRESH-LINEing or PPRINT-LOGICAL-BLOCKing,
126 ;; and the example of typical DESCRIBE-OBJECT behavior in ANSI's
127 ;; specification of DESCRIBE-OBJECT will work poorly if we do them
128 ;; here. (The example method for DESCRIBE-OBJECT does its own
129 ;; FRESH-LINEing, which is a physical directive which works poorly
130 ;; inside a pretty-printer logical block.)
131 (handler-bind ((print-not-readable #'print-unreadably))
132 (describe-object object stream))
133 ;; We don't TERPRI here either (any more since sbcl-0.8.0.x), because
134 ;; again ANSI's specification of DESCRIBE doesn't mention it and
135 ;; ANSI's example of DESCRIBE-OBJECT does its own final TERPRI.
136 (values)))
138 ;;;; DESCRIBE-OBJECT Protocol
139 ;;;;
140 ;;;; Style guide:
141 ;;;;
142 ;;;; * Each interesting class has a primary method of its own.
143 ;;;;
144 ;;;; * Output looks like
145 ;;;;
146 ;;;; object-self-string
147 ;;;; [object-type-string]
148 ;;;;
149 ;;;; Block1:
150 ;;;; Sublabel1: text
151 ;;;; Sublabel2: text
152 ;;;;
153 ;;;; Block2:
154 ;;;; ...
155 ;;;;
156 ;;;; * The newline policy that gets the whitespace right is for
157 ;;;; each block to both start and end with a newline.
159 (defgeneric describe-object (object stream))
161 (defgeneric object-self-string (object))
163 (defgeneric object-type-string (object))
165 ;;; Methods for builtin objects
167 (defmethod object-self-string ((object t))
168 (prin1-to-line object))
170 (defmethod object-self-string ((object symbol))
171 (let ((*package* (find-package :keyword)))
172 (prin1-to-string object)))
174 (defmethod object-type-string ((object t))
175 (let ((type (class-name-or-class (class-of object))))
176 (if (symbolp type)
177 (string-downcase type)
178 (prin1-to-string type))))
180 (defmethod object-type-string ((object cons))
181 (if (listp (cdr object)) "list" "cons"))
183 (defmethod object-type-string ((object function))
184 (typecase object
185 (simple-fun "compiled function")
186 (closure "compiled closure")
187 ((or #+sb-fasteval sb-interpreter:interpreted-function
188 #+sb-eval sb-eval:interpreted-function) "interpreted function")
189 (generic-function "generic-function")
190 (t "funcallable-instance")))
192 (defmethod object-type-string ((object array))
193 (cond
194 ((or (stringp object) (bit-vector-p object))
195 (format nil "~@[simple-~*~]~A"
196 (typep object 'simple-array)
197 (typecase object
198 (base-string "base-string")
199 (string "string")
200 (t "bit-vector"))))
201 ((simple-vector-p object)
202 "simple-vector")
204 (format nil "~@[simple ~*~]~@[specialized ~*~]~:[array~;vector~]"
205 (typep object 'simple-array)
206 (neq t (array-element-type object))
207 (vectorp object)))))
209 (defmethod object-type-string ((object character))
210 (typecase object
211 (standard-char "standard-char")
212 (base-char "base-char")
213 #+sb-unicode (t "character"))) ; unreachable if no unicode
215 (macrolet ((def (class &optional (string (string-downcase (class-name (find-class class)))))
216 `(defmethod object-type-string ((object ,class))
217 ,string)))
219 (def hash-table)
220 (def condition)
221 (def structure-object)
222 (def standard-object)
223 (def stream)
224 (def sb-gray:fundamental-stream "gray stream")
225 (def package))
227 (defun print-standard-describe-header (object stream)
228 (format stream "~&~A~% [~A]~%"
229 (object-self-string object)
230 (object-type-string object)))
232 ;;; Catch-all.
234 (defmethod describe-object ((object t) stream)
235 (print-standard-describe-header object stream))
237 (defmethod describe-object ((object cons) stream)
238 (print-standard-describe-header object stream)
239 (describe-function object nil stream))
241 (defmethod describe-object ((object function) stream)
242 (print-standard-describe-header object stream)
243 (describe-function nil object stream)
244 (when (funcallable-instance-p object)
245 (describe-instance object stream)))
247 (defmethod describe-object ((object class) stream)
248 (print-standard-describe-header object stream)
249 (describe-class nil object stream)
250 (describe-instance object stream))
252 (defmethod describe-object ((object sb-pcl::slot-object) stream)
253 (print-standard-describe-header object stream)
254 (describe-instance object stream))
256 (defmethod describe-object ((object character) stream)
257 (print-standard-describe-header object stream)
258 (format stream "~%Char-code: ~S~%Char-name: ~A"
259 (char-code object) (char-name object)))
261 (defmethod describe-object ((object array) stream)
262 (print-standard-describe-header object stream)
263 (format stream "~%Element-type: ~/sb-impl:print-type-specifier/"
264 (array-element-type object))
265 (cond
266 ((not (vectorp object))
267 (format stream "~%Dimensions: ~S" (array-dimensions object)))
268 ((array-has-fill-pointer-p object)
269 (format stream "~%Fill-pointer: ~S~%Size: ~S"
270 (fill-pointer object)
271 (array-total-size object)))
273 (format stream "~%Length: ~S" (length object))))
274 (let ((*print-array* nil))
275 (unless (typep object 'simple-array)
276 (format stream "~%Adjustable: ~:[no~;yes~]" (adjustable-array-p object))
277 (multiple-value-bind (to offset) (array-displacement object)
278 (if to
279 (format stream "~%Displaced-to: ~A~%Displaced-offset: ~S"
280 (prin1-to-line to) offset)
281 (format stream "~%Displaced: no"))))
282 (when (and (not (array-displacement object)) (array-header-p object))
283 (format stream "~%Storage vector: ~A"
284 (prin1-to-line (array-storage-vector object))))
285 (terpri stream)))
287 (defmethod describe-object ((object hash-table) stream)
288 (print-standard-describe-header object stream)
289 ;; Don't print things which are already apparent from the printed
290 ;; representation -- COUNT, TEST, and WEAKNESS
291 (format stream "~%Occupancy: ~,1F" (float (/ (hash-table-count object)
292 (hash-table-size object))))
293 (format stream "~%Rehash-threshold: ~S" (hash-table-rehash-threshold object))
294 (format stream "~%Rehash-size: ~S" (hash-table-rehash-size object))
295 (format stream "~%Size: ~S" (hash-table-size object))
296 (format stream "~%Synchronized: ~:[no~;yes~]" (hash-table-synchronized-p object))
297 (terpri stream))
299 (defmethod describe-object ((symbol symbol) stream)
300 (print-standard-describe-header symbol stream)
302 ;; Describe the value cell.
303 (describe-variable symbol stream)
305 ;; TODO: We could grovel over all packages looking for and
306 ;; reporting other phenomena, e.g. IMPORT and SHADOW, or
307 ;; availability in some package even after (SYMBOL-PACKAGE SYMBOL) has
308 ;; been set to NIL.
310 ;; TODO: It might also be nice to describe (find-package symbol)
311 ;; if one exists. Maybe not all the exports, etc, but the package
312 ;; documentation.
313 (describe-function symbol nil stream)
314 (describe-class symbol nil stream)
316 ;; Type specifier
317 (describe-type symbol stream)
319 ;; Declaration specifier
320 (describe-declaration symbol stream)
322 (awhen (sb-c::policy-quality-name-p symbol)
323 (describe-block (stream "~A names a~:[ dependent~;n~] optimization policy quality:"
324 symbol (minusp it))
325 (describe-documentation symbol 'optimize stream t)))
327 ;; Print out properties.
328 (let ((plist (symbol-plist symbol)))
329 (when plist
330 (describe-block (stream "Symbol-plist:")
331 (doplist (key value) plist
332 (format stream "~@:_~A -> ~A"
333 (prin1-to-line key :columns 2 :reserve 5)
334 (prin1-to-line value :columns 2 :reserve 5)))))))
336 (defmethod describe-object ((object package) stream)
337 (print-standard-describe-header object stream)
338 (describe-block (stream)
339 (describe-documentation object t stream)
340 (flet ((humanize (list)
341 (sort (mapcar (lambda (x)
342 (if (packagep x)
343 (package-name x)
345 list)
346 #'string<))
347 (out (label list)
348 (describe-stuff label list stream :escape nil)))
349 (let ((exports nil))
350 (do-external-symbols (ext object)
351 (push ext exports))
352 #+sb-package-locks
353 (let ((implemented (humanize (package-implemented-by-list object)))
354 (implements (humanize (package-implements-list object)))
355 (this (list (package-name object))))
356 (when (package-locked-p object)
357 (format stream "~@:_Locked."))
358 (when (set-difference implemented this :test #'string=)
359 (out "Implemented-by-list" implemented))
360 (when (set-difference implements this :test #'string=)
361 (out "Implements-list" implements)))
362 (out "Nicknames" (humanize (package-nicknames object)))
363 (out "Use-list" (humanize (package-use-list object)))
364 (out "Used-by-list" (humanize (package-used-by-list object)))
365 (out "Shadows" (humanize (package-shadowing-symbols object)))
366 (out "Exports" (humanize exports))
367 (format stream "~@:_~S internal symbols."
368 (package-internal-symbol-count object))))))
370 ;;;; Helpers to deal with shared functionality
372 (defun describe-deprecation (namespace name stream)
373 (multiple-value-bind (state since replacements)
374 (deprecated-thing-p namespace name)
375 (when state
376 (destructuring-bind (software version) since
377 (format stream "~@:_In ~A deprecation since ~@[~A ~]version ~A.~
378 ~@[ ~/sb-impl::print-deprecation-replacements/~]"
379 state software version replacements)))))
381 (defun describe-class (name class stream)
382 (binding* ((by-name (not class))
383 ((name class) (if class
384 (values (class-name class) class)
385 (values name (find-class name nil)))))
386 (when class
387 (let ((metaclass-name (class-name (class-of class))))
388 (describe-block (stream (when by-name "~A names the ~(~A~) ~S:")
389 name metaclass-name class)
390 (describe-deprecation 'type name stream)
391 (describe-documentation class t stream)
392 (when (sb-mop:class-finalized-p class)
393 (describe-stuff "Class precedence-list"
394 (mapcar #'class-name-or-class (sb-mop:class-precedence-list class))
395 stream))
396 (describe-stuff "Direct superclasses"
397 (mapcar #'class-name-or-class (sb-mop:class-direct-superclasses class))
398 stream)
399 (let ((subs (mapcar #'class-name-or-class (sb-mop:class-direct-subclasses class))))
400 (if subs
401 (describe-stuff "Direct subclasses" subs stream)
402 (format stream "~@:_No subclasses.")))
403 (unless (sb-mop:class-finalized-p class)
404 (format stream "~@:_Not yet finalized."))
405 (if (eq 'structure-class metaclass-name)
406 (let* ((dd (find-defstruct-description name))
407 (slots (dd-slots dd)))
408 (if slots
409 (format stream "~@:_Slots:~:{~@:_ ~S~
410 ~@:_ Type: ~/sb-impl:print-type-specifier/ ~@[~A~]~
411 ~@:_ Initform: ~S~}"
412 (mapcar (lambda (dsd)
413 (list
414 (dsd-name dsd)
415 (dsd-type dsd)
416 (unless (eq t (dsd-raw-type dsd))
417 "(unboxed)")
418 (dsd-default dsd)))
419 slots))
420 (format stream "~@:_No slots.")))
421 (let ((slots (sb-mop:class-direct-slots class)))
422 (if slots
423 (format stream "~@:_Direct slots:~:{~@:_ ~S~
424 ~@[~@:_ Type: ~/sb-impl:print-type-specifier/~]~
425 ~@[~@:_ Allocation: ~S~]~
426 ~@[~@:_ Initargs: ~{~S~^, ~}~]~
427 ~@[~@:_ Initform: ~S~]~
428 ~@[~@:_ Readers: ~{~S~^, ~}~]~
429 ~@[~@:_ Writers: ~{~S~^, ~}~]~
430 ~@[~@:_ Documentation:~@:_ ~@<~@;~A~:>~]~}"
431 (mapcar (lambda (slotd)
432 (list (sb-mop:slot-definition-name slotd)
433 (let ((type (sb-mop:slot-definition-type slotd)))
434 (unless (eq t type) type))
435 (let ((alloc (sb-mop:slot-definition-allocation slotd)))
436 (unless (eq :instance alloc) alloc))
437 (sb-mop:slot-definition-initargs slotd)
438 (sb-mop:slot-definition-initform slotd)
439 (sb-mop:slot-definition-readers slotd)
440 (sb-mop:slot-definition-writers slotd)
441 ;; FIXME: does this get the prefix right?
442 (quiet-doc slotd t)))
443 slots))
444 (format stream "~@:_No direct slots.")))))))))
446 (defun describe-instance (object stream)
447 (let* ((class (class-of object))
448 (slotds (sb-mop:class-slots class))
449 (max-slot-name-length 30)
450 (plist nil))
452 ;; Figure out a good width for the slot-name column.
453 (flet ((adjust-slot-name-length (name)
454 (setf max-slot-name-length
455 (max max-slot-name-length (length (symbol-name name))))))
456 (dolist (slotd slotds)
457 (adjust-slot-name-length (sb-mop:slot-definition-name slotd))
458 (push slotd (getf plist (sb-mop:slot-definition-allocation slotd)))))
460 ;; Now that we know the width, we can print.
461 (flet ((describe-slot (name value)
462 (format stream "~% ~VA = ~A"
463 max-slot-name-length name (prin1-to-line value))))
464 (doplist (allocation slots) plist
465 (format stream "~%Slots with ~S allocation:" allocation)
466 (dolist (slotd (nreverse slots))
467 (describe-slot
468 (sb-mop:slot-definition-name slotd)
469 (sb-pcl::slot-value-for-printing object (sb-mop:slot-definition-name slotd))))))
470 (unless slotds
471 (format stream "~@:_No slots."))
472 (terpri stream)))
474 (defun quiet-doc (object type)
475 (handler-bind ((warning #'muffle-warning))
476 (documentation object type)))
478 (defun describe-documentation (object type stream &optional undoc newline)
479 (let ((doc (quiet-doc object type)))
480 (cond (doc
481 (format stream "~@:_Documentation:~@:_")
482 (pprint-logical-block (stream nil :per-line-prefix " ")
483 (princ doc stream)))
484 (undoc
485 (format stream "~@:_(undocumented)")))
486 (when newline
487 (pprint-newline :mandatory stream))))
489 (defun describe-stuff (label list stream &key (escape t))
490 (when list
491 (if escape
492 (format stream "~@:_~A:~@<~;~{ ~S~^,~:_~}~;~:>" label list)
493 (format stream "~@:_~A:~@<~;~{ ~A~^,~:_~}~;~:>" label list))))
495 (defun describe-variable (name stream)
496 (let* ((kind (info :variable :kind name))
497 (wot (ecase kind
498 (:special "a special variable")
499 (:macro "a symbol macro")
500 (:constant "a constant variable")
501 (:global "a global variable")
502 (:unknown "an undefined variable")
503 (:alien "an alien variable"))))
504 (when (and (eq kind :unknown) (not (boundp name)))
505 (return-from describe-variable))
506 (describe-block (stream "~A names ~A:" name wot)
507 (describe-deprecation 'variable name stream)
508 (when (eq (info :variable :where-from name) :declared)
509 (format stream "~@:_Declared type: ~/sb-impl:print-type/"
510 (info :variable :type name)))
511 (when (info :variable :always-bound name)
512 (format stream "~@:_Declared always-bound."))
513 (cond
514 ((eq kind :alien)
515 (let ((info (info :variable :alien-info name)))
516 (format stream "~@:_Value: ~S" (eval name))
517 (format stream "~@:_Type: ~S"
518 (sb-alien-internals:unparse-alien-type
519 (sb-alien::heap-alien-info-type info)))
520 (format stream "~@:_Address: #x~8,'0X"
521 (sap-int (sb-alien::heap-alien-info-sap info)))))
522 ((eq kind :macro)
523 (let ((expansion (info :variable :macro-expansion name)))
524 (format stream "~@:_Expansion: ~S" expansion)))
525 ((boundp name)
526 (format stream "~:@_Value: ~S" (symbol-value name)))
527 ((not (eq kind :unknown))
528 (format stream "~:@_Currently unbound.")))
529 (describe-documentation name 'variable stream))))
531 (defun describe-lambda-list (lambda-list stream)
532 (let ((*print-circle* nil)
533 (*print-level* 24)
534 (*print-length* 24))
535 (format stream "~@:_Lambda-list: ~:S" lambda-list)))
537 (defun describe-argument-precedence-order (argument-list stream)
538 (let ((*print-circle* nil)
539 (*print-level* 24)
540 (*print-length* 24))
541 (format stream "~@:_Argument precedence order: ~:A" argument-list)))
543 (defun describe-function-source (function stream)
544 (if (compiled-function-p (the function function))
545 (let* ((code (fun-code-header (%fun-fun function)))
546 (info (sb-kernel:%code-debug-info code)))
547 (when info
548 (let ((source (sb-c::debug-info-source info)))
549 (when source
550 (let ((namestring (sb-c::debug-source-namestring source)))
551 ;; This used to also report the times the source was created
552 ;; and compiled, but that seems more like noise than useful
553 ;; information -- but FWIW that are to be had as
554 ;; SB-C::DEBUG-SOUCE-CREATED/COMPILED.
555 (cond (namestring
556 (format stream "~@:_Source file: ~A" namestring))
557 ((sb-di:debug-source-form source)
558 (format stream "~@:_Source form:~@:_ ~S"
559 (sb-di:debug-source-form source)))))))))
560 (let ((source
561 (typecase function
562 #+sb-eval
563 (sb-eval:interpreted-function
564 (sb-eval:interpreted-function-source-location function))
565 #+sb-fasteval
566 (sb-interpreter:interpreted-function
567 (sb-interpreter:fun-source-location function)))))
568 (when source
569 (let ((namestring (sb-c:definition-source-location-namestring source)))
570 (when namestring
571 (format stream "~@:_Source file: ~A" namestring)))))))
573 (defun describe-function (name function stream)
574 (let ((name (if function (%fun-name function) name)))
575 (if (not (or function (and (legal-fun-name-p name) (fboundp name))))
576 ;; Not defined, but possibly the type is declared, or we have
577 ;; compiled calls to it.
578 (when (legal-fun-name-p name)
579 (multiple-value-bind (from sure) (info :function :where-from name)
580 (when (or (eq :declared from) (and sure (eq :assumed from)))
581 (describe-block (stream "~A names an undefined function" name)
582 (format stream "~@:_~:(~A~) type: ~/sb-impl:print-type/"
583 from (proclaimed-ftype name))))))
584 ;; Defined.
585 (multiple-value-bind (fun what lambda-list derived-type declared-type
586 inline methods argument-precedence-order)
587 (cond ((and (not function) (symbolp name) (special-operator-p name))
588 ;; The function in the symbol is irrelevant.
589 ;; Use the def-ir1-translator function for source location.
590 (let ((fun (info :function :ir1-convert name)))
591 (values fun "a special operator" (%fun-lambda-list fun))))
592 ((and (not function) (symbolp name) (macro-function name))
593 (let ((fun (macro-function name)))
594 (values fun "a macro" (%fun-lambda-list fun))))
596 (let* ((fun (or function (fdefinition name)))
597 (derived-type (and function
598 (%fun-type function)))
599 (legal-name-p (legal-fun-name-p name))
600 (ctype (and legal-name-p
601 (proclaimed-ftype name)))
602 (type (and ctype (type-specifier ctype)))
603 (from (and legal-name-p
604 (info :function :where-from name)))
605 declared-type)
606 (cond ((not type))
607 ((eq from :declared)
608 (setf declared-type type))
609 ((and (not derived-type)
610 (member from '(:defined-method :defined)))
611 (setf derived-type type)))
612 (unless derived-type
613 (setf derived-type (%fun-type fun)))
614 (if (typep fun 'standard-generic-function)
615 (values fun
616 "a generic function"
617 (sb-mop:generic-function-lambda-list fun)
618 derived-type
619 declared-type
621 (or (sb-mop:generic-function-methods fun)
622 :none)
623 ;; Argument precedence order
624 ;; information is only interesting
625 ;; for two or more required
626 ;; parameters.
627 (let ((order (sb-mop:generic-function-argument-precedence-order
628 fun)))
629 (when (>= (length order) 2)
630 order)))
631 (values fun
632 (if (compiled-function-p fun)
633 "a compiled function"
634 "an interpreted function")
635 (%fun-lambda-list fun)
636 derived-type
637 declared-type
638 (cons
639 (info :function :inlinep name)
640 (info :function :inline-expansion-designator
641 name)))))))
642 (describe-block (stream (unless function "~A names ~A:") name what)
643 (describe-deprecation 'function name stream)
644 (describe-lambda-list lambda-list stream)
645 (when argument-precedence-order
646 (describe-argument-precedence-order argument-precedence-order stream))
647 (when declared-type
648 (format stream "~@:_Declared type: ~
649 ~/sb-impl:print-type-specifier/"
650 declared-type))
651 (when (and derived-type
652 (not (equal declared-type derived-type)))
653 (format stream "~@:_Derived type: ~
654 ~/sb-impl:print-type-specifier/"
655 derived-type))
656 (describe-documentation name 'function stream)
657 (when (car inline)
658 (format stream "~@:_Inline proclamation: ~
659 ~A (~:[no ~;~]inline expansion available)"
660 (car inline)
661 (cdr inline)))
662 (awhen (info :function :info name)
663 (awhen (sb-c::decode-ir1-attributes (sb-c::fun-info-attributes it))
664 (format stream "~@:_Known attributes: ~(~{~A~^, ~}~)" it)))
665 (when methods
666 (format stream "~@:_Method-combination: ~S"
667 (sb-pcl::method-combination-type-name
668 (sb-pcl:generic-function-method-combination fun)))
669 (cond ((eq :none methods)
670 (format stream "~@:_No methods."))
672 (pprint-newline :mandatory stream)
673 (pprint-logical-block (stream nil)
674 (format stream "Methods:")
675 (dolist (method methods)
676 (pprint-indent :block 2 stream)
677 (format stream "~@:_(~A ~{~S ~}~:S)"
678 name
679 (method-qualifiers method)
680 (sb-pcl::unparse-specializers
681 fun (sb-mop:method-specializers method)))
682 (pprint-indent :block 4 stream)
683 (describe-documentation method t stream nil))))))
684 (describe-function-source fun stream)))))
685 (unless function
686 (awhen (and (legal-fun-name-p name) (compiler-macro-function name))
687 (describe-block (stream "~A has a compiler-macro:" name)
688 (describe-documentation it t stream)
689 (describe-function-source it stream)))
690 (when (and (consp name) (eq 'setf (car name)) (not (cddr name)))
691 (let* ((name2 (second name))
692 (expander (info :setf :expander name2)))
693 (cond ((typep expander '(and symbol (not null)))
694 (describe-block (stream "~A has setf-expansion: ~S"
695 name expander)
696 (describe-documentation name2 'setf stream)))
697 (expander
698 (when (listp expander)
699 (setq expander (cdr expander)))
700 (describe-block (stream "~A has a complex setf-expansion:"
701 name)
702 (describe-lambda-list (%fun-lambda-list expander) stream)
703 (describe-documentation name2 'setf stream t)
704 (describe-function-source expander stream))))))
705 (when (symbolp name)
706 (describe-function `(setf ,name) nil stream))))
708 (defun describe-type (name stream)
709 (let* ((kind (info :type :kind name))
710 (fun (and kind (info :type :expander name)))
711 (fun (if (listp fun) (car fun) fun)))
712 (when fun
713 (describe-block (stream "~A names a ~@[primitive~* ~]type-specifier:"
714 name (eq kind :primitive))
715 (describe-deprecation 'type name stream)
716 (describe-documentation name 'type stream (eq t fun))
717 (when (functionp fun)
718 (describe-lambda-list (%fun-lambda-list fun) stream)
719 (multiple-value-bind (expansion ok)
720 (handler-case (typexpand-1 name)
721 (error () (values nil nil)))
722 (when ok
723 (format stream "~@:_Expansion: ~S" expansion))))))))
725 (defun describe-declaration (name stream)
726 (let ((kind (cond
727 ((member name '(ignore ignorable
728 dynamic-extent
729 special
730 type ftype
731 optimize
732 inline notineline
733 declaration))
734 "a standard")
735 ((member name '(global always-bound
736 freeze-type
737 muffle-conditions unmuffle-conditions
738 disable-package-locks enable-package-locks
739 maybe-inline
740 deprecated))
741 "an SBCL-specific")
742 ((info :declaration :recognized name)
743 "a user-defined"))))
744 (when kind
745 (describe-block (stream "~A names ~A declaration." name kind)))))