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 ;;;; 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)))
  64              (t
  65               (values nil t name)))))))
  66
  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))
  84             (t
  85              line)))))
  86
  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))
  96
  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)))
 105
 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)))
 137 \f
 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.
 158
 159 (defgeneric describe-object (object stream))
 160
 161 (defgeneric object-self-string (object))
 162
 163 (defgeneric object-type-string (object))
 164 \f
 165 ;;; Methods for builtin objects
 166
 167 (defmethod object-self-string ((object t))
 168   (prin1-to-line object))
 169
 170 (defmethod object-self-string ((object symbol))
 171   (let ((*package* (find-package :keyword)))
 172     (prin1-to-string object)))
 173
 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))))
 179
 180 (defmethod object-type-string ((object cons))
 181   (if (listp (cdr object)) "list" "cons"))
 182
 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")))
 191
 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")
 203     (t
 204      (format nil "~@[simple ~*~]~@[specialized ~*~]~:[array~;vector~]"
 205              (typep object 'simple-array)
 206              (neq t (array-element-type object))
 207              (vectorp object)))))
 208
 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
 214
 215 (macrolet ((def (class &optional (string (string-downcase (class-name (find-class class)))))
 216              `(defmethod object-type-string ((object ,class))
 217                 ,string)))
 218
 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))
 226
 227 (defun print-standard-describe-header (object stream)
 228   (format stream "~&~A~%  [~A]~%"
 229           (object-self-string object)
 230           (object-type-string object)))
 231
 232 ;;; Catch-all.
 233
 234 (defmethod describe-object ((object t) stream)
 235   (print-standard-describe-header object stream))
 236
 237 (defmethod describe-object ((object cons) stream)
 238   (print-standard-describe-header object stream)
 239   (describe-function object nil stream))
 240
 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)))
 246
 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))
 251
 252 (defmethod describe-object ((object sb-pcl::slot-object) stream)
 253   (print-standard-describe-header object stream)
 254   (describe-instance object stream))
 255
 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)))
 260
 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)))
 272     (t
 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)))
 286
 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))
 298
 299 (defmethod describe-object ((symbol symbol) stream)
 300   (print-standard-describe-header symbol stream)
 301
 302   ;; Describe the value cell.
 303   (describe-variable symbol stream)
 304
 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.
 309   ;;
 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)
 315
 316   ;; Type specifier
 317   (describe-type symbol stream)
 318
 319   ;; Declaration specifier
 320   (describe-declaration symbol stream)
 321
 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)))
 326
 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)))))))
 335
 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)
 344                                  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         (let ((implemented (humanize (package-implemented-by-list object)))
 353               (implements (humanize (package-implements-list object)))
 354               (this (list (package-name object))))
 355           (when (package-locked-p object)
 356             (format stream "~@:_Locked."))
 357           (when (set-difference implemented this :test #'string=)
 358             (out "Implemented-by-list" implemented))
 359           (when (set-difference implements this :test #'string=)
 360             (out "Implements-list" implements)))
 361         (out "Nicknames" (humanize (package-nicknames object)))
 362         (out "Use-list" (humanize (package-use-list object)))
 363         (out "Used-by-list" (humanize (package-used-by-list object)))
 364         (out "Shadows" (humanize (package-shadowing-symbols object)))
 365         (out "Exports" (humanize exports))
 366         (format stream "~@:_~S internal symbols."
 367                 (package-internal-symbol-count object))))))
 368 \f
 369 ;;;; Helpers to deal with shared functionality
 370
 371 (defun describe-deprecation (namespace name stream)
 372   (multiple-value-bind (state since replacements)
 373       (deprecated-thing-p namespace name)
 374     (when state
 375       (destructuring-bind (software version) since
 376         (format stream "~@:_In ~A deprecation since ~@[~A ~]version ~A.~
 377                         ~@[ ~/sb-impl::print-deprecation-replacements/~]"
 378                 state software version replacements)))))
 379
 380 (defun describe-class (name class stream)
 381   (binding* ((by-name (not class))
 382              ((name class) (if class
 383                                (values (class-name class) class)
 384                                (values name (find-class name nil)))))
 385     (when class
 386       (let ((metaclass-name (class-name (class-of class))))
 387         (describe-block (stream (when by-name "~A names the ~(~A~) ~S:")
 388                                 name metaclass-name class)
 389           (describe-deprecation 'type name stream)
 390           (describe-documentation class t stream)
 391           (when (sb-mop:class-finalized-p class)
 392             (describe-stuff "Class precedence-list"
 393                             (mapcar #'class-name-or-class (sb-mop:class-precedence-list class))
 394                             stream))
 395           (describe-stuff "Direct superclasses"
 396                           (mapcar #'class-name-or-class (sb-mop:class-direct-superclasses class))
 397                           stream)
 398           (let ((subs (mapcar #'class-name-or-class (sb-mop:class-direct-subclasses class))))
 399             (if subs
 400                 (describe-stuff "Direct subclasses" subs stream)
 401                 (format stream "~@:_No subclasses.")))
 402           (unless (sb-mop:class-finalized-p class)
 403             (format stream "~@:_Not yet finalized."))
 404           (if (eq 'structure-class metaclass-name)
 405               (let* ((dd (find-defstruct-description name))
 406                      (slots (dd-slots dd)))
 407                 (if slots
 408                     (format stream "~@:_Slots:~:{~@:_  ~S~
 409                                     ~@:_    Type: ~/sb-impl:print-type-specifier/ ~@[~A~]~
 410                                     ~@:_    Initform: ~S~}"
 411                             (mapcar (lambda (dsd)
 412                                       (list
 413                                        (dsd-name dsd)
 414                                        (dsd-type dsd)
 415                                        (unless (eq t (dsd-raw-type dsd))
 416                                          "(unboxed)")
 417                                        (dsd-default dsd)))
 418                                     slots))
 419                     (format stream "~@:_No slots.")))
 420               (let ((slots (sb-mop:class-direct-slots class)))
 421                 (if slots
 422                     (format stream "~@:_Direct slots:~:{~@:_  ~S~
 423                                     ~@[~@:_    Type: ~/sb-impl:print-type-specifier/~]~
 424                                     ~@[~@:_    Allocation: ~S~]~
 425                                     ~@[~@:_    Initargs: ~{~S~^, ~}~]~
 426                                     ~@[~@:_    Initform: ~S~]~
 427                                     ~@[~@:_    Readers: ~{~S~^, ~}~]~
 428                                     ~@[~@:_    Writers: ~{~S~^, ~}~]~
 429                                     ~@[~@:_    Documentation:~@:_     ~@<~@;~A~:>~]~}"
 430                             (mapcar (lambda (slotd)
 431                                       (list (sb-mop:slot-definition-name slotd)
 432                                             (let ((type (sb-mop:slot-definition-type slotd)))
 433                                               (unless (eq t type) type))
 434                                             (let ((alloc (sb-mop:slot-definition-allocation slotd)))
 435                                               (unless (eq :instance alloc) alloc))
 436                                             (sb-mop:slot-definition-initargs slotd)
 437                                             (sb-mop:slot-definition-initform slotd)
 438                                             (sb-mop:slot-definition-readers slotd)
 439                                             (sb-mop:slot-definition-writers slotd)
 440                                             ;; FIXME: does this get the prefix right?
 441                                             (quiet-doc slotd t)))
 442                                     slots))
 443                     (format stream "~@:_No direct slots.")))))))))
 444
 445 (defun describe-instance (object stream)
 446   (let* ((class (class-of object))
 447          (slotds (sb-mop:class-slots class))
 448          (max-slot-name-length 30)
 449          (plist nil))
 450
 451     ;; Figure out a good width for the slot-name column.
 452     (flet ((adjust-slot-name-length (name)
 453              (setf max-slot-name-length
 454                    (max max-slot-name-length (length (symbol-name name))))))
 455       (dolist (slotd slotds)
 456         (adjust-slot-name-length (sb-mop:slot-definition-name slotd))
 457         (push slotd (getf plist (sb-mop:slot-definition-allocation slotd)))))
 458
 459     ;; Now that we know the width, we can print.
 460     (flet ((describe-slot (name value)
 461              (format stream "~%  ~VA = ~A"
 462                      max-slot-name-length name (prin1-to-line value))))
 463       (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-for-printing 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     (describe-block (stream "~A names ~A:" name wot)
 506       (describe-deprecation 'variable name stream)
 507       (when (eq (info :variable :where-from name) :declared)
 508         (format stream "~@:_Declared type: ~/sb-impl:print-type/"
 509                 (info :variable :type name)))
 510       (when (info :variable :always-bound name)
 511         (format stream "~@:_Declared always-bound."))
 512       (cond
 513         ((eq kind :alien)
 514          (let ((info (info :variable :alien-info name)))
 515            (format stream "~@:_Value: ~S" (eval name))
 516            (format stream "~@:_Type: ~S"
 517                    (sb-alien-internals:unparse-alien-type
 518                     (sb-alien::heap-alien-info-type info)))
 519            (format stream "~@:_Address: #x~8,'0X"
 520                    (sap-int (sb-alien::heap-alien-info-sap info)))))
 521         ((eq kind :macro)
 522          (let ((expansion (info :variable :macro-expansion name)))
 523            (format stream "~@:_Expansion: ~S" expansion)))
 524         ((boundp name)
 525          (format stream "~:@_Value: ~S" (symbol-value name)))
 526         ((not (eq kind :unknown))
 527          (format stream "~:@_Currently unbound.")))
 528       (describe-documentation name 'variable stream))))
 529
 530 (defun describe-lambda-list (lambda-list stream)
 531   (let ((*print-circle* nil)
 532         (*print-level* 24)
 533         (*print-length* 24))
 534     (format stream "~@:_Lambda-list: ~:S" lambda-list)))
 535
 536 (defun describe-argument-precedence-order (argument-list stream)
 537   (let ((*print-circle* nil)
 538         (*print-level* 24)
 539         (*print-length* 24))
 540     (format stream "~@:_Argument precedence order: ~:A" argument-list)))
 541
 542 (defun describe-function-source (function stream)
 543   (if (compiled-function-p (the function function))
 544       (let* ((code (fun-code-header (%fun-fun function)))
 545              (info (sb-kernel:%code-debug-info code)))
 546         (when info
 547           (let ((source (sb-c::debug-info-source info)))
 548             (when source
 549               (let ((namestring (sb-c::debug-source-namestring source)))
 550                 ;; This used to also report the times the source was created
 551                 ;; and compiled, but that seems more like noise than useful
 552                 ;; information -- but FWIW that are to be had as
 553                 ;; SB-C::DEBUG-SOUCE-CREATED/COMPILED.
 554                 (cond (namestring
 555                        (format stream "~@:_Source file: ~A" namestring))
 556                       ((sb-di:debug-source-form source)
 557                        (format stream "~@:_Source form:~@:_  ~S"
 558                                (sb-di:debug-source-form source)))))))))
 559       (let ((source
 560              (typecase function
 561                #+sb-eval
 562                (sb-eval:interpreted-function
 563                 (sb-eval:interpreted-function-source-location function))
 564                #+sb-fasteval
 565                (sb-interpreter:interpreted-function
 566                 (sb-interpreter:fun-source-location function)))))
 567         (when source
 568           (let ((namestring (sb-c:definition-source-location-namestring source)))
 569             (when namestring
 570               (format stream "~@:_Source file: ~A" namestring)))))))
 571
 572 (defun describe-function (name function stream)
 573   (let ((name (if function (%fun-name function) name)))
 574     (if (not (or function (and (legal-fun-name-p name) (fboundp name))))
 575         ;; Not defined, but possibly the type is declared, or we have
 576         ;; compiled calls to it.
 577         (when (legal-fun-name-p name)
 578           (multiple-value-bind (from sure) (info :function :where-from name)
 579             (when (or (eq :declared from) (and sure (eq :assumed from)))
 580               (describe-block (stream "~A names an undefined function" name)
 581                 (format stream "~@:_~:(~A~) type: ~/sb-impl:print-type/"
 582                         from (proclaimed-ftype name))))))
 583         ;; Defined.
 584         (multiple-value-bind (fun what lambda-list derived-type declared-type
 585                               inline methods argument-precedence-order)
 586             (cond ((and (not function) (symbolp name) (special-operator-p name))
 587                    ;; The function in the symbol is irrelevant.
 588                    ;; Use the def-ir1-translator function for source location.
 589                    (let ((fun (info :function :ir1-convert name)))
 590                      (values fun "a special operator" (%fun-lambda-list fun))))
 591                   ((and (not function) (symbolp name) (macro-function name))
 592                    (let ((fun (macro-function name)))
 593                      (values fun "a macro" (%fun-lambda-list fun))))
 594                   (t
 595                    (let* ((fun (or function (fdefinition name)))
 596                           (derived-type (and function
 597                                              (%fun-type function)))
 598                           (legal-name-p (legal-fun-name-p name))
 599                           (ctype (and legal-name-p
 600                                       (proclaimed-ftype name)))
 601                           (type (and ctype (type-specifier ctype)))
 602                           (from (and legal-name-p
 603                                      (info :function :where-from name)))
 604                           declared-type)
 605                      (cond ((not type))
 606                            ((eq from :declared)
 607                             (setf declared-type type))
 608                            ((and (not derived-type)
 609                                  (member from '(:defined-method :defined)))
 610                             (setf derived-type type)))
 611                      (unless derived-type
 612                        (setf derived-type (%fun-type fun)))
 613                      (if (typep fun 'standard-generic-function)
 614                          (values fun
 615                                  "a generic function"
 616                                  (sb-mop:generic-function-lambda-list fun)
 617                                  derived-type
 618                                  declared-type
 619                                  nil
 620                                  (or (sb-mop:generic-function-methods fun)
 621                                      :none)
 622                                  ;; Argument precedence order
 623                                  ;; information is only interesting
 624                                  ;; for two or more required
 625                                  ;; parameters.
 626                                  (let ((order (sb-mop:generic-function-argument-precedence-order
 627                                                fun)))
 628                                    (when (>= (length order) 2)
 629                                      order)))
 630                          (values fun
 631                                  (if (compiled-function-p fun)
 632                                      "a compiled function"
 633                                      "an interpreted function")
 634                                  (%fun-lambda-list fun)
 635                                  derived-type
 636                                  declared-type
 637                                  (cons
 638                                   (info :function :inlinep name)
 639                                   (info :function :inline-expansion-designator
 640                                         name)))))))
 641           (describe-block (stream (unless function "~A names ~A:") name what)
 642             (describe-deprecation 'function name stream)
 643             (describe-lambda-list lambda-list stream)
 644             (when argument-precedence-order
 645               (describe-argument-precedence-order argument-precedence-order stream))
 646             (when declared-type
 647               (format stream "~@:_Declared type: ~
 648                               ~/sb-impl:print-type-specifier/"
 649                       declared-type))
 650             (when (and derived-type
 651                        (not (equal declared-type derived-type)))
 652               (format stream "~@:_Derived type: ~
 653                               ~/sb-impl:print-type-specifier/"
 654                       derived-type))
 655             (describe-documentation name 'function stream)
 656             (when (car inline)
 657               (format stream "~@:_Inline proclamation: ~
 658                               ~A (~:[no ~;~]inline expansion available)"
 659                       (car inline)
 660                       (cdr inline)))
 661             (awhen (info :function :info name)
 662               (awhen (sb-c::decode-ir1-attributes (sb-c::fun-info-attributes it))
 663                   (format stream "~@:_Known attributes: ~(~{~A~^, ~}~)" it)))
 664             (when methods
 665               (format stream "~@:_Method-combination: ~S"
 666                       (sb-pcl::method-combination-type-name
 667                        (sb-pcl:generic-function-method-combination fun)))
 668               (cond ((eq :none methods)
 669                      (format stream "~@:_No methods."))
 670                     (t
 671                      (pprint-newline :mandatory stream)
 672                      (pprint-logical-block (stream nil)
 673                        (format stream "Methods:")
 674                        (dolist (method methods)
 675                          (pprint-indent :block 2 stream)
 676                          (format stream "~@:_(~A ~{~S ~}~:S)"
 677                                  name
 678                                  (method-qualifiers method)
 679                                  (sb-pcl::unparse-specializers
 680                                   fun (sb-mop:method-specializers method)))
 681                          (pprint-indent :block 4 stream)
 682                          (describe-documentation method t stream nil))))))
 683             (describe-function-source fun stream)))))
 684   (unless function
 685     (awhen (and (legal-fun-name-p name) (compiler-macro-function name))
 686       (describe-block (stream "~A has a compiler-macro:" name)
 687         (describe-documentation it t stream)
 688         (describe-function-source it stream)))
 689     (when (and (consp name) (eq 'setf (car name)) (not (cddr name)))
 690       (let* ((name2 (second name))
 691              (expander (info :setf :expander name2)))
 692         (cond ((typep expander '(and symbol (not null)))
 693                (describe-block (stream "~A has setf-expansion: ~S"
 694                                        name expander)
 695                  (describe-documentation name2 'setf stream)))
 696               (expander
 697                (when (listp expander)
 698                  (setq expander (cdr expander)))
 699                (describe-block (stream "~A has a complex setf-expansion:"
 700                                        name)
 701                  (describe-lambda-list (%fun-lambda-list expander) stream)
 702                  (describe-documentation name2 'setf stream t)
 703                  (describe-function-source expander stream))))))
 704     (when (symbolp name)
 705       (describe-function `(setf ,name) nil stream))))
 706
 707 (defun describe-type (name stream)
 708   (let* ((kind (info :type :kind name))
 709          (fun (and kind (info :type :expander name)))
 710          (fun (if (listp fun) (car fun) fun)))
 711     (when fun
 712       (describe-block (stream "~A names a ~@[primitive~* ~]type-specifier:"
 713                               name (eq kind :primitive))
 714         (describe-deprecation 'type name stream)
 715         (describe-documentation name 'type stream (eq t fun))
 716         (when (functionp fun)
 717           (describe-lambda-list (%fun-lambda-list fun) stream)
 718           (multiple-value-bind (expansion ok)
 719               (handler-case (typexpand-1 name)
 720                 (error () (values nil nil)))
 721             (when ok
 722               (format stream "~@:_Expansion: ~S" expansion))))))))
 723
 724 (defun describe-declaration (name stream)
 725   (let ((kind (cond
 726                 ((member name '(ignore ignorable
 727                                 dynamic-extent
 728                                 special
 729                                 type ftype
 730                                 optimize
 731                                 inline notineline
 732                                 declaration))
 733                  "a standard")
 734                 ((member name '(global always-bound
 735                                 freeze-type
 736                                 muffle-conditions unmuffle-conditions
 737                                 disable-package-locks enable-package-locks
 738                                 maybe-inline
 739                                 deprecated))
 740                  "an SBCL-specific")
 741                 ((info :declaration :recognized name)
 742                  "a user-defined"))))
 743     (when kind
 744       (describe-block (stream "~A names ~A declaration." name kind)))))