src/code/describe.lisp

   1 ;;;; the DESCRIBE system
   2
   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.
  11
  12 ;;; SB-IMPL, not SB!IMPL, since we're built in warm load.
  13 (in-package "SB-IMPL")
  14
  15 ;;;; Utils, move elsewhere.
  16
  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)))
  22
  23 (defun fun-name (x)
  24   (if (typep x 'standard-generic-function)
  25       (sb-pcl:generic-function-name x)
  26       (%fun-name x)))
  27
  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)
  37   #+sb-doc
  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))
  44   (etypecase fun
  45     #+sb-eval
  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)))
  53                   ,@body)
  54                t name)))
  55     (function
  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)))
  67              (t
  68               (values nil t name)))))))
  69
  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
  80                                                (min end line-end)
  81                                                line-end))
  82                  (write-string ".." s)))))
  83       (cond (p
  84              (trunc p))
  85             ((> (length line) limit)
  86              (trunc))
  87             (t
  88              line)))))
  89
  90 (defun describe (object &optional (stream-designator *standard-output*))
  91   #+sb-doc
  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))
  95         (*print-circle* t)
  96         (*suppress-print-errors*
  97           (if (subtypep 'serious-condition *suppress-print-errors*)
  98               *suppress-print-errors*
  99               'serious-condition)))
 100     ;; Until sbcl-0.8.0.x, we did
 101     ;;   (FRESH-LINE STREAM)
 102     ;;   (PPRINT-LOGICAL-BLOCK (STREAM NIL)
 103     ;;     ...
 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
 108     ;;   DESCRIBE-OBJECT.
 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.
 120     (values)))
 121 \f
 122 ;;;; DESCRIBE-OBJECT
 123 ;;;;
 124 ;;;; Style guide:
 125 ;;;;
 126 ;;;; * Each interesting class has a primary method of its own.
 127 ;;;;
 128 ;;;; * Output looks like
 129 ;;;;
 130 ;;;;    object-self-string
 131 ;;;;      [object-type-string]
 132 ;;;;
 133 ;;;;    Block1:
 134 ;;;;      Sublabel1: text
 135 ;;;;      Sublabel2: text
 136 ;;;;
 137 ;;;;    Block2:
 138 ;;;;      ...
 139 ;;;;
 140 ;;;; * The newline policy that gets the whitespace right is for
 141 ;;;;   each block to both start and end with a newline.
 142
 143 (defgeneric object-self-string (x))
 144
 145 (defmethod object-self-string (x)
 146   (prin1-to-line x))
 147
 148 (defmethod object-self-string ((x symbol))
 149   (let ((*package* (find-package :keyword)))
 150     (prin1-to-string x)))
 151
 152 (defgeneric object-type-string (x))
 153
 154 (defmethod object-type-string (x)
 155   (let ((type (class-name-or-class (class-of x))))
 156     (if (symbolp type)
 157         (string-downcase type)
 158         (prin1-to-string type))))
 159
 160 (defmethod object-type-string ((x cons))
 161   (if (listp (cdr x)) "list" "cons"))
 162
 163 (defmethod object-type-string ((x hash-table))
 164   "hash-table")
 165
 166 (defmethod object-type-string ((x condition))
 167   "condition")
 168
 169 (defmethod object-type-string ((x structure-object))
 170   "structure-object")
 171
 172 (defmethod object-type-string ((x standard-object))
 173   "standard-object")
 174
 175 (defmethod object-type-string ((x function))
 176   (typecase x
 177     (simple-fun "compiled function")
 178     (closure "compiled closure")
 179     #+sb-eval
 180     (sb-eval:interpreted-function
 181      "interpreted function")
 182     (generic-function
 183      "generic-function")
 184     (t
 185      "funcallable-instance")))
 186
 187 (defmethod object-type-string ((x stream))
 188   "stream")
 189
 190 (defmethod object-type-string ((x sb-gray:fundamental-stream))
 191   "gray stream")
 192
 193 (defmethod object-type-string ((x package))
 194   "package")
 195
 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)
 200                  (typecase x
 201                    (base-string "base-string")
 202                    (string "string")
 203                    (t "bit-vector"))))
 204         (t
 205          (if (simple-vector-p x)
 206              "simple-vector"
 207              (format nil "~@[simple ~*~]~@[specialized ~*~]~:[array~;vector~]"
 208                      (typep x 'simple-array)
 209                      (neq t (array-element-type x))
 210                      (vectorp x))))))
 211
 212 (defmethod object-type-string ((x character))
 213   (typecase x
 214     (standard-char "standard-char")
 215     (base-char "base-char")
 216     (t "character")))
 217
 218 (defun print-standard-describe-header (x stream)
 219   (format stream "~&~A~%  [~A]~%"
 220           (object-self-string x)
 221           (object-type-string x)))
 222
 223 (defgeneric describe-object (x stream))
 224
 225 ;;; Catch-all.
 226
 227 (defmethod describe-object ((x t) s)
 228   (print-standard-describe-header x s))
 229
 230 (defmethod describe-object ((x cons) s)
 231   (print-standard-describe-header x s)
 232   (describe-function x nil s))
 233
 234 (defmethod describe-object ((x function) s)
 235   (print-standard-describe-header x s)
 236   (describe-function nil x s))
 237
 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))
 242
 243 (defmethod describe-object ((x sb-pcl::slot-object) s)
 244   (print-standard-describe-header x s)
 245   (describe-instance x s))
 246
 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)))
 251
 252 (defmethod describe-object ((x array) s)
 253   (print-standard-describe-header x s)
 254   (format s "~%Element-type: ~S" (array-element-type x))
 255   (if (vectorp x)
 256       (if (array-has-fill-pointer-p x)
 257           (format s "~%Fill-pointer: ~S~%Size: ~S"
 258                   (fill-pointer x)
 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"
 267                     (prin1-to-line to)
 268                     offset)
 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))))
 273     (terpri s)))
 274
 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"))
 285   (terpri s))
 286
 287 (defmethod describe-object ((symbol symbol) stream)
 288   (print-standard-describe-header symbol stream)
 289
 290   ;; Describe the value cell.
 291   (describe-variable symbol stream)
 292
 293   ;; TODO: We could grovel over all packages looking for and
 294   ;; reporting other phenomena, e.g. IMPORT and SHADOW, or
 295   ;; availability in some package even after (SYMBOL-PACKAGE SYMBOL) has
 296   ;; been set to NIL.
 297   ;;
 298   ;; TODO: It might also be nice to describe (find-package symbol)
 299   ;; if one exists. Maybe not all the exports, etc, but the package
 300   ;; documentation.
 301   (describe-function symbol nil stream)
 302   (describe-class symbol nil stream)
 303
 304   ;; Type specifier
 305   (describe-type symbol stream)
 306
 307   (awhen (sb-c::policy-quality-name-p symbol)
 308     (pprint-logical-block (stream nil)
 309       (pprint-newline :mandatory stream)
 310       (pprint-indent :block 2 stream)
 311       (format stream "~A names a~:[ dependent~;n~] optimization policy quality:"
 312               symbol (minusp it))
 313       (describe-documentation symbol 'optimize stream t))
 314     (terpri stream))
 315
 316   ;; Print out properties.
 317   (let ((plist (symbol-plist symbol)))
 318     (when plist
 319       (pprint-logical-block (stream nil)
 320         (format stream "~%Symbol-plist:")
 321         (pprint-indent :block 2 stream)
 322         (sb-pcl::doplist (key value) plist
 323           (format stream "~@:_~A -> ~A"
 324                   (prin1-to-line key :columns 2 :reserve 5)
 325                   (prin1-to-line value :columns 2 :reserve 5))))
 326       (terpri stream))))
 327
 328 (defmethod describe-object ((package package) stream)
 329   (print-standard-describe-header package stream)
 330   (pprint-logical-block (stream nil)
 331     (describe-documentation package t stream)
 332     (flet ((humanize (list)
 333              (sort (mapcar (lambda (x)
 334                              (if (packagep x)
 335                                  (package-name x)
 336                                  x))
 337                            list)
 338                    #'string<))
 339            (out (label list)
 340              (describe-stuff label list stream :escape nil)))
 341       (let ((exports nil))
 342         (do-external-symbols (ext package)
 343           (push ext exports))
 344         #+sb-package-locks
 345         (let ((implemented (humanize (package-implemented-by-list package)))
 346               (implements (humanize (package-implements-list package)))
 347               (this (list (package-name package))))
 348           (when (package-locked-p package)
 349             (format stream "~@:_Locked."))
 350           (when (set-difference implemented this :test #'string=)
 351             (out "Implemented-by-list" implemented))
 352           (when (set-difference implements this :test #'string=)
 353             (out "Implements-list" implements)))
 354         (out "Nicknames" (humanize (package-nicknames package)))
 355         (out "Use-list" (humanize (package-use-list package)))
 356         (out "Used-by-list" (humanize (package-used-by-list package)))
 357         (out "Shadows" (humanize (package-shadowing-symbols package)))
 358         (out "Exports" (humanize exports))
 359         (format stream "~@:_~S internal symbols."
 360                 (package-internal-symbol-count package))))
 361     (terpri stream)))
 362 \f
 363 ;;;; Helpers to deal with shared functionality
 364
 365 (defun describe-deprecation (namespace name stream)
 366   (multiple-value-bind (state since replacements)
 367       (deprecated-thing-p namespace name)
 368     (when state
 369       (destructuring-bind (software version) since
 370         (format stream "~@:_In ~A deprecation since ~@[~A ~]version ~A.~
 371                         ~@[ ~/sb-impl::print-deprecation-replacements/~]"
 372                 state software version replacements)))))
 373
 374 (defun describe-class (name class stream)
 375   (binding* ((by-name (not class))
 376              ((name class) (if class
 377                                (values (class-name class) name)
 378                                (values name (find-class name nil)))))
 379     (when class
 380       (let ((metaclass-name (class-name (class-of class))))
 381         (pprint-logical-block (stream nil)
 382           (when by-name
 383             (format stream "~@:_~A names the ~(~A~) ~S:"
 384                     name metaclass-name class)
 385             (pprint-indent :block 2 stream))
 386           (describe-deprecation 'type name stream)
 387           (describe-documentation class t stream)
 388           (when (sb-mop:class-finalized-p class)
 389             (describe-stuff "Class precedence-list"
 390                             (mapcar #'class-name-or-class (sb-mop:class-precedence-list class))
 391                             stream))
 392           (describe-stuff "Direct superclasses"
 393                           (mapcar #'class-name-or-class (sb-mop:class-direct-superclasses class))
 394                           stream)
 395           (let ((subs (mapcar #'class-name-or-class (sb-mop:class-direct-subclasses class))))
 396             (if subs
 397                 (describe-stuff "Direct subclasses" subs stream)
 398                 (format stream "~@:_No subclasses.")))
 399           (unless (sb-mop:class-finalized-p class)
 400             (format stream "~@:_Not yet finalized."))
 401           (if (eq 'structure-class metaclass-name)
 402               (let* ((dd (find-defstruct-description name))
 403                      (slots (dd-slots dd)))
 404                 (if slots
 405                     (format stream "~@:_Slots:~:{~@:_  ~S~
 406                                     ~@:_    Type: ~A ~@[~A~]~
 407                                     ~@:_    Initform: ~S~}"
 408                             (mapcar (lambda (dsd)
 409                                       (list
 410                                        (dsd-name dsd)
 411                                        (dsd-type dsd)
 412                                        (unless (eq t (dsd-raw-type dsd))
 413                                          "(unboxed)")
 414                                        (dsd-default dsd)))
 415                                     slots))
 416                     (format stream "~@:_No slots.")))
 417               (let ((slots (sb-mop:class-direct-slots class)))
 418                 (if slots
 419                     (format stream "~@:_Direct slots:~:{~@:_  ~S~
 420                                     ~@[~@:_    Type: ~S~]~
 421                                     ~@[~@:_    Allocation: ~S~]~
 422                                     ~@[~@:_    Initargs: ~{~S~^, ~}~]~
 423                                     ~@[~@:_    Initform: ~S~]~
 424                                     ~@[~@:_    Readers: ~{~S~^, ~}~]~
 425                                     ~@[~@:_    Writers: ~{~S~^, ~}~]~
 426                                     ~@[~@:_    Documentation:~@:_     ~@<~@;~A~:>~]~}"
 427                             (mapcar (lambda (slotd)
 428                                       (list (sb-mop:slot-definition-name slotd)
 429                                             (let ((type (sb-mop:slot-definition-type slotd)))
 430                                               (unless (eq t type) type))
 431                                             (let ((alloc (sb-mop:slot-definition-allocation slotd)))
 432                                               (unless (eq :instance alloc) alloc))
 433                                             (sb-mop:slot-definition-initargs slotd)
 434                                             (sb-mop:slot-definition-initform slotd)
 435                                             (sb-mop:slot-definition-readers slotd)
 436                                             (sb-mop:slot-definition-writers slotd)
 437                                             ;; FIXME: does this get the prefix right?
 438                                             (quiet-doc slotd t)))
 439                                     slots))
 440                     (format stream "~@:_No direct slots."))))
 441           (pprint-indent :block 0 stream)
 442           (pprint-newline :mandatory stream))))))
 443
 444 (defun describe-instance (object stream)
 445   (let* ((class (class-of object))
 446          (slotds (sb-mop:class-slots class))
 447          (max-slot-name-length 0)
 448          (plist nil))
 449
 450     ;; Figure out a good width for the slot-name column.
 451     (flet ((adjust-slot-name-length (name)
 452              (setf max-slot-name-length
 453                    (max max-slot-name-length (length (symbol-name name))))))
 454       (dolist (slotd slotds)
 455         (adjust-slot-name-length (sb-mop:slot-definition-name slotd))
 456         (push slotd (getf plist (sb-mop:slot-definition-allocation slotd))))
 457       (setf max-slot-name-length  (min (+ max-slot-name-length 3) 30)))
 458
 459     ;; Now that we know the width, we can print.
 460     (flet ((describe-slot (name value)
 461              (format stream "~%  ~A~VT = ~A" name max-slot-name-length
 462                      (prin1-to-line value))))
 463       (sb-pcl::doplist (allocation slots) plist
 464         (format stream "~%Slots with ~S allocation:" allocation)
 465         (dolist (slotd (nreverse slots))
 466           (describe-slot
 467            (sb-mop:slot-definition-name slotd)
 468            (sb-pcl::slot-value-or-default object (sb-mop:slot-definition-name slotd))))))
 469     (unless slotds
 470       (format stream "~@:_No slots."))
 471     (terpri stream)))
 472
 473 (defun quiet-doc (object type)
 474   (handler-bind ((warning #'muffle-warning))
 475     (documentation object type)))
 476
 477 (defun describe-documentation (object type stream &optional undoc newline)
 478   (let ((doc (quiet-doc object type)))
 479     (cond (doc
 480            (format stream "~@:_Documentation:~@:_")
 481            (pprint-logical-block (stream nil :per-line-prefix "  ")
 482              (princ doc stream)))
 483           (undoc
 484            (format stream "~@:_(undocumented)")))
 485     (when newline
 486       (pprint-newline :mandatory stream))))
 487
 488 (defun describe-stuff (label list stream &key (escape t))
 489   (when list
 490     (if escape
 491         (format stream "~@:_~A:~@<~;~{ ~S~^,~:_~}~;~:>" label list)
 492         (format stream "~@:_~A:~@<~;~{ ~A~^,~:_~}~;~:>" label list))))
 493
 494 (defun describe-variable (name stream)
 495   (let* ((kind (info :variable :kind name))
 496          (wot (ecase kind
 497                 (:special "a special variable")
 498                 (:macro "a symbol macro")
 499                 (:constant "a constant variable")
 500                 (:global "a global variable")
 501                 (:unknown "an undefined variable")
 502                 (:alien "an alien variable"))))
 503     (when (and (eq kind :unknown) (not (boundp name)))
 504       (return-from describe-variable))
 505     (pprint-logical-block (stream nil)
 506       (format stream "~@:_~A names ~A:" name wot)
 507       (pprint-indent :block 2 stream)
 508       (describe-deprecation 'variable name stream)
 509       (when (eq (info :variable :where-from name) :declared)
 510         (format stream "~@:_Declared type: ~S"
 511                 (type-specifier (info :variable :type name))))
 512       (when (info :variable :always-bound name)
 513         (format stream "~@:_Declared always-bound."))
 514       (cond
 515         ((eq kind :alien)
 516          (let ((info (info :variable :alien-info name)))
 517            (format stream "~@:_Value: ~S" (eval name))
 518            (format stream "~@:_Type: ~S"
 519                    (sb-alien-internals:unparse-alien-type
 520                     (sb-alien::heap-alien-info-type info)))
 521            (format stream "~@:_Address: #x~8,'0X"
 522                    (sap-int (sb-alien::heap-alien-info-sap info)))))
 523         ((eq kind :macro)
 524          (let ((expansion (info :variable :macro-expansion name)))
 525            (format stream "~@:_Expansion: ~S" expansion)))
 526         ((boundp name)
 527          (format stream "~:@_Value: ~S" (symbol-value name)))
 528         ((not (eq kind :unknown))
 529          (format stream "~:@_Currently unbound.")))
 530       (describe-documentation name 'variable stream)
 531       (terpri stream))))
 532
 533 (defun describe-lambda-list (lambda-list stream)
 534   (let ((*print-circle* nil)
 535         (*print-level* 24)
 536         (*print-length* 24))
 537     (format stream "~@:_Lambda-list: ~:A" lambda-list)))
 538
 539 (defun describe-function-source (function stream)
 540   (if (compiled-function-p function)
 541       (let* ((code (fun-code-header (%fun-fun function)))
 542              (info (sb-kernel:%code-debug-info code)))
 543         (when info
 544           (let ((source (sb-c::debug-info-source info)))
 545             (when source
 546               (let ((namestring (sb-c::debug-source-namestring source)))
 547                 ;; This used to also report the times the source was created
 548                 ;; and compiled, but that seems more like noise than useful
 549                 ;; information -- but FWIW that are to be had as
 550                 ;; SB-C::DEBUG-SOUCE-CREATED/COMPILED.
 551                 (cond (namestring
 552                        (format stream "~@:_Source file: ~A" namestring))
 553                       ((sb-di:debug-source-form source)
 554                        (format stream "~@:_Source form:~@:_  ~S"
 555                                (sb-di:debug-source-form source)))))))))
 556       #+sb-eval
 557       (let ((source (sb-eval:interpreted-function-source-location function)))
 558         (when source
 559           (let ((namestring (sb-c:definition-source-location-namestring source)))
 560             (when namestring
 561               (format stream "~@:_Source file: ~A" namestring)))))))
 562
 563 (defun describe-function (name function stream)
 564   (let ((name (if function (fun-name function) name)))
 565     (if (not (or function (and (legal-fun-name-p name) (fboundp name))))
 566         ;; Not defined, but possibly the type is declared, or we have
 567         ;; compiled calls to it.
 568         (when (legal-fun-name-p name)
 569           (multiple-value-bind (from sure) (info :function :where-from name)
 570             (when (or (eq :declared from) (and sure (eq :assumed from)))
 571               (pprint-logical-block (stream nil)
 572                 (format stream "~%~A names an undefined function" name)
 573                 (pprint-indent :block 2 stream)
 574                 (format stream "~@:_~:(~A~) type: ~S"
 575                         from
 576                         (type-specifier (info :function :type name)))))))
 577         ;; Defined.
 578         (multiple-value-bind (fun what lambda-list derived-type declared-type
 579                               inline methods)
 580             (cond ((and (not function) (symbolp name) (special-operator-p name))
 581                    ;; The function in the symbol is irrelevant.
 582                    ;; Use the def-ir1-translator function for source location.
 583                    (let ((fun (info :function :ir1-convert name)))
 584                      (values fun "a special operator" (%fun-lambda-list fun))))
 585                   ((and (not function) (symbolp name) (macro-function name))
 586                    (let ((fun (macro-function name)))
 587                      (values fun "a macro" (%fun-lambda-list fun))))
 588                   (t
 589                    (let* ((fun (or function (fdefinition name)))
 590                           (derived-type (and function
 591                                              (%fun-type function)))
 592                           (legal-name-p (legal-fun-name-p name))
 593                           (ctype (and legal-name-p
 594                                       (info :function :type name)))
 595                           (type (and ctype (type-specifier ctype)))
 596                           (from (and legal-name-p
 597                                      (info :function :where-from name)))
 598                           declared-type)
 599                      ;; Ensure lazy pickup of information
 600                      ;; from methods.
 601                      (when legal-name-p
 602                        (sb-c::maybe-update-info-for-gf name))
 603                      (cond ((not type))
 604                            ((eq from :declared)
 605                             (setf declared-type type))
 606                            ((and (not derived-type)
 607                                  (member from '(:defined-method :defined)))
 608                             (setf derived-type type)))
 609                      (unless derived-type
 610                        (setf derived-type (%fun-type fun)))
 611                      (if (typep fun 'standard-generic-function)
 612                          (values fun
 613                                  "a generic function"
 614                                  (sb-mop:generic-function-lambda-list fun)
 615                                  derived-type
 616                                  declared-type
 617                                  nil
 618                                  (or (sb-mop:generic-function-methods fun)
 619                                      :none))
 620                          (values fun
 621                                  (if (compiled-function-p fun)
 622                                      "a compiled function"
 623                                      "an interpreted function")
 624                                  (%fun-lambda-list fun)
 625                                  derived-type
 626                                  declared-type
 627                                  (cons
 628                                   (info :function :inlinep name)
 629                                   (info :function :inline-expansion-designator
 630                                         name)))))))
 631           (pprint-logical-block (stream nil)
 632             (unless function
 633               (format stream "~%~A names ~A:" name what)
 634               (pprint-indent :block 2 stream))
 635             (describe-deprecation 'function name stream)
 636             (describe-lambda-list lambda-list stream)
 637             (when declared-type
 638               (format stream "~@:_Declared type: ~S" declared-type))
 639             (when (and derived-type
 640                        (not (equal declared-type derived-type)))
 641               (format stream "~@:_Derived type: ~S" derived-type))
 642             (describe-documentation name 'function stream)
 643             (when (car inline)
 644               (format stream "~@:_Inline proclamation: ~
 645                               ~A (~:[no ~;~]inline expansion available)"
 646                       (car inline)
 647                       (cdr inline)))
 648             (awhen (info :function :info name)
 649               (awhen (sb-c::decode-ir1-attributes (sb-c::fun-info-attributes it))
 650                   (format stream "~@:_Known attributes: ~(~{~A~^, ~}~)" it)))
 651             (when methods
 652               (format stream "~@:_Method-combination: ~S"
 653                       (sb-pcl::method-combination-type-name
 654                        (sb-pcl:generic-function-method-combination fun)))
 655               (cond ((eq :none methods)
 656                      (format stream "~@:_No methods."))
 657                     (t
 658                      (pprint-newline :mandatory stream)
 659                      (pprint-logical-block (stream nil)
 660                        (format stream "Methods:")
 661                        (dolist (method methods)
 662                          (pprint-indent :block 2 stream)
 663                          (format stream "~@:_(~A ~{~S ~}~:S)"
 664                                  name
 665                                  (method-qualifiers method)
 666                                  (sb-pcl::unparse-specializers
 667                                   fun (sb-mop:method-specializers method)))
 668                          (pprint-indent :block 4 stream)
 669                          (describe-documentation method t stream nil))))))
 670             (describe-function-source fun stream)
 671             (terpri stream)))))
 672   (unless function
 673     (awhen (and (legal-fun-name-p name) (compiler-macro-function name))
 674       (pprint-logical-block (stream nil)
 675         (format stream "~@:_~A has a compiler-macro:" name)
 676         (pprint-indent :block 2 stream)
 677         (describe-documentation it t stream)
 678         (describe-function-source it stream))
 679       (terpri stream))
 680     (when (and (consp name) (eq 'setf (car name)) (not (cddr name)))
 681       (let* ((name2 (second name))
 682              (inverse (info :setf :inverse name2))
 683              (expander (info :setf :expander name2)))
 684         (cond (inverse
 685                (pprint-logical-block (stream nil)
 686                  (format stream "~&~A has setf-expansion: ~S"
 687                          name inverse)
 688                  (pprint-indent :block 2 stream)
 689                  (describe-documentation name2 'setf stream))
 690                (terpri stream))
 691               (expander
 692                (when (listp expander)
 693                  (setq expander (cdr expander)))
 694                (pprint-logical-block (stream nil)
 695                  (format stream "~&~A has a complex setf-expansion:"
 696                          name)
 697                  (pprint-indent :block 2 stream)
 698                  (describe-lambda-list (%fun-lambda-list expander) stream)
 699                  (describe-documentation name2 'setf stream t)
 700                  (describe-function-source expander stream))
 701                (terpri stream)))))
 702     (when (symbolp name)
 703       (describe-function `(setf ,name) nil stream))))
 704
 705 (defun describe-type (name stream)
 706   (let* ((kind (info :type :kind name))
 707          (fun (case kind
 708                 (:defined
 709                  (or (info :type :expander name) t))
 710                 (:primitive
 711                  (or (info :type :translator name) t)))))
 712     (when fun
 713       (pprint-newline :mandatory stream)
 714       (pprint-logical-block (stream nil)
 715         (format stream "~@:_~A names a ~@[primitive~* ~]type-specifier:"
 716                 name (eq kind :primitive))
 717         (pprint-indent :block 2 stream)
 718         (describe-deprecation 'type name stream)
 719         (describe-documentation name 'type stream (eq t fun))
 720         (unless (eq t fun)
 721           ;; even though :translator can store a CTYPE, this is safe
 722           ;; because a symbol can't have a non-FUNCTIONP translator.
 723           (describe-lambda-list (%fun-lambda-list fun) stream)
 724           (multiple-value-bind (expansion ok)
 725               (handler-case (typexpand-1 name)
 726                 (error () (values nil nil)))
 727             (when ok
 728               (format stream "~@:_Expansion: ~S" expansion)))))
 729       (terpri stream))))