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 describe (object &optional (stream-designator *standard-output*))
  88   "Print a description of OBJECT to STREAM-DESIGNATOR."
  89   (let ((stream (out-stream-from-designator stream-designator))
  90         (*print-right-margin* (or *print-right-margin* 72))
  91         (*print-circle* t)
  92         (*print-pretty* t)
  93         (*suppress-print-errors*
  94           (if (subtypep 'serious-condition *suppress-print-errors*)
  95               *suppress-print-errors*
  96               'serious-condition)))
  97     ;; Until sbcl-0.8.0.x, we did
  98     ;;   (FRESH-LINE STREAM)
  99     ;;   (PPRINT-LOGICAL-BLOCK (STREAM NIL)
 100     ;;     ...
 101     ;; here. However, ANSI's specification of DEFUN DESCRIBE,
 102     ;;   DESCRIBE exists as an interface primarily to manage argument
 103     ;;   defaulting (including conversion of arguments T and NIL into
 104     ;;   stream objects) and to inhibit any return values from
 105     ;;   DESCRIBE-OBJECT.
 106     ;; doesn't mention either FRESH-LINEing or PPRINT-LOGICAL-BLOCKing,
 107     ;; and the example of typical DESCRIBE-OBJECT behavior in ANSI's
 108     ;; specification of DESCRIBE-OBJECT will work poorly if we do them
 109     ;; here. (The example method for DESCRIBE-OBJECT does its own
 110     ;; FRESH-LINEing, which is a physical directive which works poorly
 111     ;; inside a pretty-printer logical block.)
 112     (handler-bind ((print-not-readable #'print-unreadably))
 113       (describe-object object stream))
 114     ;; We don't TERPRI here either (any more since sbcl-0.8.0.x), because
 115     ;; again ANSI's specification of DESCRIBE doesn't mention it and
 116     ;; ANSI's example of DESCRIBE-OBJECT does its own final TERPRI.
 117     (values)))
 118 \f
 119 ;;;; DESCRIBE-OBJECT
 120 ;;;;
 121 ;;;; Style guide:
 122 ;;;;
 123 ;;;; * Each interesting class has a primary method of its own.
 124 ;;;;
 125 ;;;; * Output looks like
 126 ;;;;
 127 ;;;;    object-self-string
 128 ;;;;      [object-type-string]
 129 ;;;;
 130 ;;;;    Block1:
 131 ;;;;      Sublabel1: text
 132 ;;;;      Sublabel2: text
 133 ;;;;
 134 ;;;;    Block2:
 135 ;;;;      ...
 136 ;;;;
 137 ;;;; * The newline policy that gets the whitespace right is for
 138 ;;;;   each block to both start and end with a newline.
 139
 140 (defgeneric object-self-string (x))
 141
 142 (defmethod object-self-string (x)
 143   (prin1-to-line x))
 144
 145 (defmethod object-self-string ((x symbol))
 146   (let ((*package* (find-package :keyword)))
 147     (prin1-to-string x)))
 148
 149 (defgeneric object-type-string (x))
 150
 151 (defmethod object-type-string (x)
 152   (let ((type (class-name-or-class (class-of x))))
 153     (if (symbolp type)
 154         (string-downcase type)
 155         (prin1-to-string type))))
 156
 157 (defmethod object-type-string ((x cons))
 158   (if (listp (cdr x)) "list" "cons"))
 159
 160 (defmethod object-type-string ((x hash-table))
 161   "hash-table")
 162
 163 (defmethod object-type-string ((x condition))
 164   "condition")
 165
 166 (defmethod object-type-string ((x structure-object))
 167   "structure-object")
 168
 169 (defmethod object-type-string ((x standard-object))
 170   "standard-object")
 171
 172 (defmethod object-type-string ((x function))
 173   (typecase x
 174     (simple-fun "compiled function")
 175     (closure "compiled closure")
 176     ((or #+sb-fasteval sb-interpreter:interpreted-function
 177          #+sb-eval sb-eval:interpreted-function) "interpreted function")
 178     (generic-function "generic-function")
 179     (t "funcallable-instance")))
 180
 181 (defmethod object-type-string ((x stream))
 182   "stream")
 183
 184 (defmethod object-type-string ((x sb-gray:fundamental-stream))
 185   "gray stream")
 186
 187 (defmethod object-type-string ((x package))
 188   "package")
 189
 190 (defmethod object-type-string ((x array))
 191   (cond ((or (stringp x) (bit-vector-p x))
 192          (format nil "~@[simple-~*~]~A"
 193                  (typep x 'simple-array)
 194                  (typecase x
 195                    (base-string "base-string")
 196                    (string "string")
 197                    (t "bit-vector"))))
 198         (t
 199          (if (simple-vector-p x)
 200              "simple-vector"
 201              (format nil "~@[simple ~*~]~@[specialized ~*~]~:[array~;vector~]"
 202                      (typep x 'simple-array)
 203                      (neq t (array-element-type x))
 204                      (vectorp x))))))
 205
 206 (defmethod object-type-string ((x character))
 207   (typecase x
 208     (standard-char "standard-char")
 209     (base-char "base-char")
 210     #+sb-unicode (t "character"))) ; unreachable if no unicode
 211
 212 (defun print-standard-describe-header (x stream)
 213   (format stream "~&~A~%  [~A]~%"
 214           (object-self-string x)
 215           (object-type-string x)))
 216
 217 (defgeneric describe-object (x stream))
 218
 219 ;;; Catch-all.
 220
 221 (defmethod describe-object ((x t) s)
 222   (print-standard-describe-header x s))
 223
 224 (defmethod describe-object ((x cons) s)
 225   (print-standard-describe-header x s)
 226   (describe-function x nil s))
 227
 228 (defmethod describe-object ((x function) s)
 229   (print-standard-describe-header x s)
 230   (describe-function nil x s)
 231   (when (funcallable-instance-p x)
 232     (describe-instance x s)))
 233
 234 (defmethod describe-object ((x class) s)
 235   (print-standard-describe-header x s)
 236   (describe-class nil x s)
 237   (describe-instance x s))
 238
 239 (defmethod describe-object ((x sb-pcl::slot-object) s)
 240   (print-standard-describe-header x s)
 241   (describe-instance x s))
 242
 243 (defmethod describe-object ((x character) s)
 244   (print-standard-describe-header x s)
 245   (format s "~%Char-code: ~S" (char-code x))
 246   (format s "~%Char-name: ~A" (char-name x)))
 247
 248 (defmethod describe-object ((x array) s)
 249   (print-standard-describe-header x s)
 250   (format s "~%Element-type: ~/sb-impl:print-type-specifier/"
 251           (array-element-type x))
 252   (if (vectorp x)
 253       (if (array-has-fill-pointer-p x)
 254           (format s "~%Fill-pointer: ~S~%Size: ~S"
 255                   (fill-pointer x)
 256                   (array-total-size x))
 257           (format s "~%Length: ~S" (length x)))
 258       (format s "~%Dimensions: ~S" (array-dimensions x)))
 259   (let ((*print-array* nil))
 260     (unless (typep x 'simple-array)
 261       (format s "~%Adjustable: ~A" (if (adjustable-array-p x) "yes" "no"))
 262       (multiple-value-bind (to offset) (array-displacement x)
 263         (if (format s "~%Displaced-to: ~A~%Displaced-offset: ~S"
 264                     (prin1-to-line to)
 265                     offset)
 266             (format s "~%Displaced: no"))))
 267     (when (and (not (array-displacement x)) (array-header-p x))
 268       (format s "~%Storage vector: ~A"
 269               (prin1-to-line (array-storage-vector x))))
 270     (terpri s)))
 271
 272 (defmethod describe-object ((x hash-table) s)
 273   (print-standard-describe-header x s)
 274   ;; Don't print things which are already apparent from the printed
 275   ;; representation -- COUNT, TEST, and WEAKNESS
 276   (format s "~%Occupancy: ~,1F" (float (/ (hash-table-count x)
 277                                           (hash-table-size x))))
 278   (format s "~%Rehash-threshold: ~S" (hash-table-rehash-threshold x))
 279   (format s "~%Rehash-size: ~S" (hash-table-rehash-size x))
 280   (format s "~%Size: ~S" (hash-table-size x))
 281   (format s "~%Synchronized: ~A" (if (hash-table-synchronized-p x) "yes" "no"))
 282   (terpri s))
 283
 284 (defmethod describe-object ((symbol symbol) stream)
 285   (print-standard-describe-header symbol stream)
 286
 287   ;; Describe the value cell.
 288   (describe-variable symbol stream)
 289
 290   ;; TODO: We could grovel over all packages looking for and
 291   ;; reporting other phenomena, e.g. IMPORT and SHADOW, or
 292   ;; availability in some package even after (SYMBOL-PACKAGE SYMBOL) has
 293   ;; been set to NIL.
 294   ;;
 295   ;; TODO: It might also be nice to describe (find-package symbol)
 296   ;; if one exists. Maybe not all the exports, etc, but the package
 297   ;; documentation.
 298   (describe-function symbol nil stream)
 299   (describe-class symbol nil stream)
 300
 301   ;; Type specifier
 302   (describe-type symbol stream)
 303
 304   (awhen (sb-c::policy-quality-name-p symbol)
 305     (pprint-logical-block (stream nil)
 306       (pprint-newline :mandatory stream)
 307       (pprint-indent :block 2 stream)
 308       (format stream "~A names a~:[ dependent~;n~] optimization policy quality:"
 309               symbol (minusp it))
 310       (describe-documentation symbol 'optimize stream t))
 311     (terpri stream))
 312
 313   ;; Print out properties.
 314   (let ((plist (symbol-plist symbol)))
 315     (when plist
 316       (pprint-logical-block (stream nil)
 317         (format stream "~%Symbol-plist:")
 318         (pprint-indent :block 2 stream)
 319         (doplist (key value) plist
 320           (format stream "~@:_~A -> ~A"
 321                   (prin1-to-line key :columns 2 :reserve 5)
 322                   (prin1-to-line value :columns 2 :reserve 5))))
 323       (terpri stream))))
 324
 325 (defmethod describe-object ((package package) stream)
 326   (print-standard-describe-header package stream)
 327   (pprint-logical-block (stream nil)
 328     (describe-documentation package t stream)
 329     (flet ((humanize (list)
 330              (sort (mapcar (lambda (x)
 331                              (if (packagep x)
 332                                  (package-name x)
 333                                  x))
 334                            list)
 335                    #'string<))
 336            (out (label list)
 337              (describe-stuff label list stream :escape nil)))
 338       (let ((exports nil))
 339         (do-external-symbols (ext package)
 340           (push ext exports))
 341         #+sb-package-locks
 342         (let ((implemented (humanize (package-implemented-by-list package)))
 343               (implements (humanize (package-implements-list package)))
 344               (this (list (package-name package))))
 345           (when (package-locked-p package)
 346             (format stream "~@:_Locked."))
 347           (when (set-difference implemented this :test #'string=)
 348             (out "Implemented-by-list" implemented))
 349           (when (set-difference implements this :test #'string=)
 350             (out "Implements-list" implements)))
 351         (out "Nicknames" (humanize (package-nicknames package)))
 352         (out "Use-list" (humanize (package-use-list package)))
 353         (out "Used-by-list" (humanize (package-used-by-list package)))
 354         (out "Shadows" (humanize (package-shadowing-symbols package)))
 355         (out "Exports" (humanize exports))
 356         (format stream "~@:_~S internal symbols."
 357                 (package-internal-symbol-count package))))
 358     (terpri stream)))
 359 \f
 360 ;;;; Helpers to deal with shared functionality
 361
 362 (defun describe-deprecation (namespace name stream)
 363   (multiple-value-bind (state since replacements)
 364       (deprecated-thing-p namespace name)
 365     (when state
 366       (destructuring-bind (software version) since
 367         (format stream "~@:_In ~A deprecation since ~@[~A ~]version ~A.~
 368                         ~@[ ~/sb-impl::print-deprecation-replacements/~]"
 369                 state software version replacements)))))
 370
 371 (defun describe-class (name class stream)
 372   (binding* ((by-name (not class))
 373              ((name class) (if class
 374                                (values (class-name class) name)
 375                                (values name (find-class name nil)))))
 376     (when class
 377       (let ((metaclass-name (class-name (class-of class))))
 378         (pprint-logical-block (stream nil)
 379           (when by-name
 380             (format stream "~@:_~A names the ~(~A~) ~S:"
 381                     name metaclass-name class)
 382             (pprint-indent :block 2 stream))
 383           (describe-deprecation 'type name stream)
 384           (describe-documentation class t stream)
 385           (when (sb-mop:class-finalized-p class)
 386             (describe-stuff "Class precedence-list"
 387                             (mapcar #'class-name-or-class (sb-mop:class-precedence-list class))
 388                             stream))
 389           (describe-stuff "Direct superclasses"
 390                           (mapcar #'class-name-or-class (sb-mop:class-direct-superclasses class))
 391                           stream)
 392           (let ((subs (mapcar #'class-name-or-class (sb-mop:class-direct-subclasses class))))
 393             (if subs
 394                 (describe-stuff "Direct subclasses" subs stream)
 395                 (format stream "~@:_No subclasses.")))
 396           (unless (sb-mop:class-finalized-p class)
 397             (format stream "~@:_Not yet finalized."))
 398           (if (eq 'structure-class metaclass-name)
 399               (let* ((dd (find-defstruct-description name))
 400                      (slots (dd-slots dd)))
 401                 (if slots
 402                     (format stream "~@:_Slots:~:{~@:_  ~S~
 403                                     ~@:_    Type: ~/sb-impl:print-type-specifier/ ~@[~A~]~
 404                                     ~@:_    Initform: ~S~}"
 405                             (mapcar (lambda (dsd)
 406                                       (list
 407                                        (dsd-name dsd)
 408                                        (dsd-type dsd)
 409                                        (unless (eq t (dsd-raw-type dsd))
 410                                          "(unboxed)")
 411                                        (dsd-default dsd)))
 412                                     slots))
 413                     (format stream "~@:_No slots.")))
 414               (let ((slots (sb-mop:class-direct-slots class)))
 415                 (if slots
 416                     (format stream "~@:_Direct slots:~:{~@:_  ~S~
 417                                     ~@[~@:_    Type: ~/sb-impl:print-type-specifier/~]~
 418                                     ~@[~@:_    Allocation: ~S~]~
 419                                     ~@[~@:_    Initargs: ~{~S~^, ~}~]~
 420                                     ~@[~@:_    Initform: ~S~]~
 421                                     ~@[~@:_    Readers: ~{~S~^, ~}~]~
 422                                     ~@[~@:_    Writers: ~{~S~^, ~}~]~
 423                                     ~@[~@:_    Documentation:~@:_     ~@<~@;~A~:>~]~}"
 424                             (mapcar (lambda (slotd)
 425                                       (list (sb-mop:slot-definition-name slotd)
 426                                             (let ((type (sb-mop:slot-definition-type slotd)))
 427                                               (unless (eq t type) type))
 428                                             (let ((alloc (sb-mop:slot-definition-allocation slotd)))
 429                                               (unless (eq :instance alloc) alloc))
 430                                             (sb-mop:slot-definition-initargs slotd)
 431                                             (sb-mop:slot-definition-initform slotd)
 432                                             (sb-mop:slot-definition-readers slotd)
 433                                             (sb-mop:slot-definition-writers slotd)
 434                                             ;; FIXME: does this get the prefix right?
 435                                             (quiet-doc slotd t)))
 436                                     slots))
 437                     (format stream "~@:_No direct slots."))))
 438           (pprint-indent :block 0 stream)
 439           (pprint-newline :mandatory stream))))))
 440
 441 (defun describe-instance (object stream)
 442   (let* ((class (class-of object))
 443          (slotds (sb-mop:class-slots class))
 444          (max-slot-name-length 0)
 445          (plist nil))
 446
 447     ;; Figure out a good width for the slot-name column.
 448     (flet ((adjust-slot-name-length (name)
 449              (setf max-slot-name-length
 450                    (max max-slot-name-length (length (symbol-name name))))))
 451       (dolist (slotd slotds)
 452         (adjust-slot-name-length (sb-mop:slot-definition-name slotd))
 453         (push slotd (getf plist (sb-mop:slot-definition-allocation slotd))))
 454       (setf max-slot-name-length  (min (+ max-slot-name-length 3) 30)))
 455
 456     ;; Now that we know the width, we can print.
 457     (flet ((describe-slot (name value)
 458              (format stream "~%  ~A~VT = ~A" name max-slot-name-length
 459                      (prin1-to-line value))))
 460       (doplist (allocation slots) plist
 461         (format stream "~%Slots with ~S allocation:" allocation)
 462         (dolist (slotd (nreverse slots))
 463           (describe-slot
 464            (sb-mop:slot-definition-name slotd)
 465            (sb-pcl::slot-value-for-printing object (sb-mop:slot-definition-name slotd))))))
 466     (unless slotds
 467       (format stream "~@:_No slots."))
 468     (terpri stream)))
 469
 470 (defun quiet-doc (object type)
 471   (handler-bind ((warning #'muffle-warning))
 472     (documentation object type)))
 473
 474 (defun describe-documentation (object type stream &optional undoc newline)
 475   (let ((doc (quiet-doc object type)))
 476     (cond (doc
 477            (format stream "~@:_Documentation:~@:_")
 478            (pprint-logical-block (stream nil :per-line-prefix "  ")
 479              (princ doc stream)))
 480           (undoc
 481            (format stream "~@:_(undocumented)")))
 482     (when newline
 483       (pprint-newline :mandatory stream))))
 484
 485 (defun describe-stuff (label list stream &key (escape t))
 486   (when list
 487     (if escape
 488         (format stream "~@:_~A:~@<~;~{ ~S~^,~:_~}~;~:>" label list)
 489         (format stream "~@:_~A:~@<~;~{ ~A~^,~:_~}~;~:>" label list))))
 490
 491 (defun describe-variable (name stream)
 492   (let* ((kind (info :variable :kind name))
 493          (wot (ecase kind
 494                 (:special "a special variable")
 495                 (:macro "a symbol macro")
 496                 (:constant "a constant variable")
 497                 (:global "a global variable")
 498                 (:unknown "an undefined variable")
 499                 (:alien "an alien variable"))))
 500     (when (and (eq kind :unknown) (not (boundp name)))
 501       (return-from describe-variable))
 502     (pprint-logical-block (stream nil)
 503       (format stream "~@:_~A names ~A:" name wot)
 504       (pprint-indent :block 2 stream)
 505       (describe-deprecation 'variable name stream)
 506       (when (eq (info :variable :where-from name) :declared)
 507         (format stream "~@:_Declared type: ~/sb-impl:print-type/"
 508                 (info :variable :type name)))
 509       (when (info :variable :always-bound name)
 510         (format stream "~@:_Declared always-bound."))
 511       (cond
 512         ((eq kind :alien)
 513          (let ((info (info :variable :alien-info name)))
 514            (format stream "~@:_Value: ~S" (eval name))
 515            (format stream "~@:_Type: ~S"
 516                    (sb-alien-internals:unparse-alien-type
 517                     (sb-alien::heap-alien-info-type info)))
 518            (format stream "~@:_Address: #x~8,'0X"
 519                    (sap-int (sb-alien::heap-alien-info-sap info)))))
 520         ((eq kind :macro)
 521          (let ((expansion (info :variable :macro-expansion name)))
 522            (format stream "~@:_Expansion: ~S" expansion)))
 523         ((boundp name)
 524          (format stream "~:@_Value: ~S" (symbol-value name)))
 525         ((not (eq kind :unknown))
 526          (format stream "~:@_Currently unbound.")))
 527       (describe-documentation name 'variable stream)
 528       (terpri 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: ~:A" 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               (pprint-logical-block (stream nil)
 581                 (format stream "~%~A names an undefined function" name)
 582                 (pprint-indent :block 2 stream)
 583                 (format stream "~@:_~:(~A~) type: ~/sb-impl:print-type/"
 584                         from (proclaimed-ftype name))))))
 585         ;; Defined.
 586         (multiple-value-bind (fun what lambda-list derived-type declared-type
 587                               inline methods argument-precedence-order)
 588             (cond ((and (not function) (symbolp name) (special-operator-p name))
 589                    ;; The function in the symbol is irrelevant.
 590                    ;; Use the def-ir1-translator function for source location.
 591                    (let ((fun (info :function :ir1-convert name)))
 592                      (values fun "a special operator" (%fun-lambda-list fun))))
 593                   ((and (not function) (symbolp name) (macro-function name))
 594                    (let ((fun (macro-function name)))
 595                      (values fun "a macro" (%fun-lambda-list fun))))
 596                   (t
 597                    (let* ((fun (or function (fdefinition name)))
 598                           (derived-type (and function
 599                                              (%fun-type function)))
 600                           (legal-name-p (legal-fun-name-p name))
 601                           (ctype (and legal-name-p
 602                                       (proclaimed-ftype name)))
 603                           (type (and ctype (type-specifier ctype)))
 604                           (from (and legal-name-p
 605                                      (info :function :where-from name)))
 606                           declared-type)
 607                      (cond ((not type))
 608                            ((eq from :declared)
 609                             (setf declared-type type))
 610                            ((and (not derived-type)
 611                                  (member from '(:defined-method :defined)))
 612                             (setf derived-type type)))
 613                      (unless derived-type
 614                        (setf derived-type (%fun-type fun)))
 615                      (if (typep fun 'standard-generic-function)
 616                          (values fun
 617                                  "a generic function"
 618                                  (sb-mop:generic-function-lambda-list fun)
 619                                  derived-type
 620                                  declared-type
 621                                  nil
 622                                  (or (sb-mop:generic-function-methods fun)
 623                                      :none)
 624                                  ;; Argument precedence order
 625                                  ;; information is only interesting
 626                                  ;; for two or more required
 627                                  ;; parameters.
 628                                  (let ((order (sb-mop:generic-function-argument-precedence-order
 629                                                fun)))
 630                                    (when (>= (length order) 2)
 631                                      order)))
 632                          (values fun
 633                                  (if (compiled-function-p fun)
 634                                      "a compiled function"
 635                                      "an interpreted function")
 636                                  (%fun-lambda-list fun)
 637                                  derived-type
 638                                  declared-type
 639                                  (cons
 640                                   (info :function :inlinep name)
 641                                   (info :function :inline-expansion-designator
 642                                         name)))))))
 643           (pprint-logical-block (stream nil)
 644             (unless function
 645               (format stream "~%~A names ~A:" name what)
 646               (pprint-indent :block 2 stream))
 647             (describe-deprecation 'function name stream)
 648             (describe-lambda-list lambda-list stream)
 649             (when argument-precedence-order
 650               (describe-argument-precedence-order argument-precedence-order stream))
 651             (when declared-type
 652               (format stream "~@:_Declared type: ~
 653                               ~/sb-impl:print-type-specifier/"
 654                       declared-type))
 655             (when (and derived-type
 656                        (not (equal declared-type derived-type)))
 657               (format stream "~@:_Derived type: ~
 658                               ~/sb-impl:print-type-specifier/"
 659                       derived-type))
 660             (describe-documentation name 'function stream)
 661             (when (car inline)
 662               (format stream "~@:_Inline proclamation: ~
 663                               ~A (~:[no ~;~]inline expansion available)"
 664                       (car inline)
 665                       (cdr inline)))
 666             (awhen (info :function :info name)
 667               (awhen (sb-c::decode-ir1-attributes (sb-c::fun-info-attributes it))
 668                   (format stream "~@:_Known attributes: ~(~{~A~^, ~}~)" it)))
 669             (when methods
 670               (format stream "~@:_Method-combination: ~S"
 671                       (sb-pcl::method-combination-type-name
 672                        (sb-pcl:generic-function-method-combination fun)))
 673               (cond ((eq :none methods)
 674                      (format stream "~@:_No methods."))
 675                     (t
 676                      (pprint-newline :mandatory stream)
 677                      (pprint-logical-block (stream nil)
 678                        (format stream "Methods:")
 679                        (dolist (method methods)
 680                          (pprint-indent :block 2 stream)
 681                          (format stream "~@:_(~A ~{~S ~}~:S)"
 682                                  name
 683                                  (method-qualifiers method)
 684                                  (sb-pcl::unparse-specializers
 685                                   fun (sb-mop:method-specializers method)))
 686                          (pprint-indent :block 4 stream)
 687                          (describe-documentation method t stream nil))))))
 688             (describe-function-source fun stream)
 689             (terpri stream)))))
 690   (unless function
 691     (awhen (and (legal-fun-name-p name) (compiler-macro-function name))
 692       (pprint-logical-block (stream nil)
 693         (format stream "~@:_~A has a compiler-macro:" name)
 694         (pprint-indent :block 2 stream)
 695         (describe-documentation it t stream)
 696         (describe-function-source it stream))
 697       (terpri stream))
 698     (when (and (consp name) (eq 'setf (car name)) (not (cddr name)))
 699       (let* ((name2 (second name))
 700              (expander (info :setf :expander name2)))
 701         (cond ((typep expander '(and symbol (not null)))
 702                (pprint-logical-block (stream nil)
 703                  (format stream "~&~A has setf-expansion: ~S"
 704                          name expander)
 705                  (pprint-indent :block 2 stream)
 706                  (describe-documentation name2 'setf stream))
 707                (terpri stream))
 708               (expander
 709                (when (listp expander)
 710                  (setq expander (cdr expander)))
 711                (pprint-logical-block (stream nil)
 712                  (format stream "~&~A has a complex setf-expansion:"
 713                          name)
 714                  (pprint-indent :block 2 stream)
 715                  (describe-lambda-list (%fun-lambda-list expander) stream)
 716                  (describe-documentation name2 'setf stream t)
 717                  (describe-function-source expander stream))
 718                (terpri stream)))))
 719     (when (symbolp name)
 720       (describe-function `(setf ,name) nil stream))))
 721
 722 (defun describe-type (name stream)
 723   (let* ((kind (info :type :kind name))
 724          (fun (and kind (info :type :expander name)))
 725          (fun (if (listp fun) (car fun) fun)))
 726     (when fun
 727       (pprint-newline :mandatory stream)
 728       (pprint-logical-block (stream nil)
 729         (format stream "~@:_~A names a ~@[primitive~* ~]type-specifier:"
 730                 name (eq kind :primitive))
 731         (pprint-indent :block 2 stream)
 732         (describe-deprecation 'type name stream)
 733         (describe-documentation name 'type stream (eq t fun))
 734         (when (functionp fun)
 735           (describe-lambda-list (%fun-lambda-list fun) stream)
 736           (multiple-value-bind (expansion ok)
 737               (handler-case (typexpand-1 name)
 738                 (error () (values nil nil)))
 739             (when ok
 740               (format stream "~@:_Expansion: ~S" expansion)))))
 741       (terpri stream))))