X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdescribe.lisp;h=50f45ac0780277d53d6073b812b73bdc5fc8a808;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=b66fffd62c3d880ead6773645ea1fe1df114c31d;hpb=6dc30bee17d029acf6bb6da730f03e63b2a01948;p=sbcl.git

diff --git a/src/code/describe.lisp b/src/code/describe.lisp
index b66fffd..50f45ac 100644
--- a/src/code/describe.lisp
+++ b/src/code/describe.lisp
@@ -21,10 +21,56 @@
         class)))
 
 (defun fun-name (x)
-  (if (typep x 'generic-function)
+  (if (typep x 'standard-generic-function)
       (sb-pcl:generic-function-name x)
       (%fun-name x)))
 
+;;;; the ANSI interface to function names (and to other stuff too)
+;;; Note: this function gets called by the compiler (as of 1.0.17.x,
+;;; in MAYBE-INLINE-SYNTACTIC-CLOSURE), and so although ANSI says
+;;; we're allowed to return NIL here freely, it seems plausible that
+;;; small changes to the circumstances under which this function
+;;; returns non-NIL might have subtle consequences on the compiler.
+;;; So it might be desirable to have the compiler not rely on this
+;;; function, eventually.
+(defun function-lambda-expression (fun)
+  #+sb-doc
+  "Return (VALUES DEFINING-LAMBDA-EXPRESSION CLOSURE-P NAME), where
+  DEFINING-LAMBDA-EXPRESSION is NIL if unknown, or a suitable argument
+  to COMPILE otherwise, CLOSURE-P is non-NIL if the function's definition
+  might have been enclosed in some non-null lexical environment, and
+  NAME is some name (for debugging only) or NIL if there is no name."
+  (declare (type function fun))
+  (etypecase fun
+    #+sb-eval
+    (sb-eval:interpreted-function
+     (let ((name (sb-eval:interpreted-function-name fun))
+           (lambda-list (sb-eval:interpreted-function-lambda-list fun))
+           (declarations (sb-eval:interpreted-function-declarations fun))
+           (body (sb-eval:interpreted-function-body fun)))
+       (values `(lambda ,lambda-list
+                  ,@(when declarations `((declare ,@declarations)))
+                  ,@body)
+               t name)))
+    (function
+     (let* ((name (fun-name fun))
+            (fun (%simple-fun-self (%fun-fun fun)))
+            (code (sb-di::fun-code-header fun))
+            (info (sb-kernel:%code-debug-info code)))
+       (if info
+           (let ((source (sb-c::debug-info-source info)))
+             (cond ((and (sb-c::debug-source-form source)
+                         (eq (sb-c::debug-source-function source) fun))
+                    (values (sb-c::debug-source-form source)
+                            nil
+                            name))
+                   ((legal-fun-name-p name)
+                    (let ((exp (fun-name-inline-expansion name)))
+                      (values exp (not exp) name)))
+                   (t
+                    (values nil t name))))
+           (values nil t name))))))
+
 ;;; Prints X on a single line, limiting output length by *PRINT-RIGHT-MARGIN*
 ;;; -- good for printing object parts, etc.
 (defun prin1-to-line (x &key (columns 1) (reserve 0))
@@ -49,7 +95,12 @@
   #+sb-doc
   "Print a description of OBJECT to STREAM-DESIGNATOR."
   (let ((stream (out-synonym-of stream-designator))
-        (*print-right-margin* (or *print-right-margin* 72)))
+        (*print-right-margin* (or *print-right-margin* 72))
+        (*print-circle* t)
+        (*suppress-print-errors*
+          (if (subtypep 'serious-condition *suppress-print-errors*)
+              *suppress-print-errors*
+              'serious-condition)))
     ;; Until sbcl-0.8.0.x, we did
     ;;   (FRESH-LINE STREAM)
     ;;   (PPRINT-LOGICAL-BLOCK (STREAM NIL)
@@ -65,7 +116,8 @@
     ;; here. (The example method for DESCRIBE-OBJECT does its own
     ;; FRESH-LINEing, which is a physical directive which works poorly
     ;; inside a pretty-printer logical block.)
-    (describe-object object stream)
+    (handler-bind ((print-not-readable #'print-unreadably))
+      (describe-object object stream))
     ;; We don't TERPRI here either (any more since sbcl-0.8.0.x), because
     ;; again ANSI's specification of DESCRIBE doesn't mention it and
     ;; ANSI's example of DESCRIBE-OBJECT does its own final TERPRI.
@@ -167,43 +219,42 @@
     (base-char "base-char")
     (t "character")))
 
-(declaim (ftype (function (t stream)) describe-object))
-(defgeneric describe-object (x stream))
-
-(defvar *in-describe* nil)
+(defun print-standard-describe-header (x stream)
+  (format stream "~&~A~%  [~A]~%"
+          (object-self-string x)
+          (object-type-string x)))
 
-(defmethod describe-object :around (x s)
-  (cond (*in-describe*
-         (call-next-method))
-        (t
-         (format s "~&~A~%  [~A]~%"
-                 (object-self-string x)
-                 (object-type-string x))
-         (pprint-logical-block (s nil)
-           (call-next-method x s)))))
+(defgeneric describe-object (x stream))
 
 ;;; Catch-all.
+
 (defmethod describe-object ((x t) s)
-  (values))
+  (print-standard-describe-header x s))
 
 (defmethod describe-object ((x cons) s)
+  (print-standard-describe-header x s)
   (describe-function x nil s))
 
 (defmethod describe-object ((x function) s)
+  (print-standard-describe-header x s)
   (describe-function nil x s))
 
 (defmethod describe-object ((x class) s)
+  (print-standard-describe-header x s)
   (describe-class nil x s)
   (describe-instance x s))
 
 (defmethod describe-object ((x sb-pcl::slot-object) s)
+  (print-standard-describe-header x s)
   (describe-instance x s))
 
 (defmethod describe-object ((x character) s)
-  (format s "~%:_Char-code: ~S" (char-code x))
-  (format s "~%:_Char-name: ~A~%_" (char-name x)))
+  (print-standard-describe-header x s)
+  (format s "~%Char-code: ~S" (char-code x))
+  (format s "~%Char-name: ~A" (char-name x)))
 
 (defmethod describe-object ((x array) s)
+  (print-standard-describe-header x s)
   (format s "~%Element-type: ~S" (array-element-type x))
   (if (vectorp x)
       (if (array-has-fill-pointer-p x)
@@ -226,9 +277,11 @@
     (terpri s)))
 
 (defmethod describe-object ((x hash-table) s)
-  ;; Don't print things which are already apparent from the printed representation
-  ;; -- COUNT, TEST, and WEAKNESS
-  (format s "~%Occupancy: ~,1F" (float (/ (hash-table-count x) (hash-table-size x))))
+  (print-standard-describe-header x s)
+  ;; Don't print things which are already apparent from the printed
+  ;; representation -- COUNT, TEST, and WEAKNESS
+  (format s "~%Occupancy: ~,1F" (float (/ (hash-table-count x)
+                                          (hash-table-size x))))
   (format s "~%Rehash-threshold: ~S" (hash-table-rehash-threshold x))
   (format s "~%Rehash-size: ~S" (hash-table-rehash-size x))
   (format s "~%Size: ~S" (hash-table-size x))
@@ -236,6 +289,7 @@
   (terpri s))
 
 (defmethod describe-object ((symbol symbol) stream)
+  (print-standard-describe-header symbol stream)
   ;; Describe the value cell.
   (let* ((kind (info :variable :kind symbol))
          (wot (ecase kind
@@ -247,11 +301,13 @@
                 (:alien "an alien variable"))))
     (when (or (not (eq :unknown kind)) (boundp symbol))
       (pprint-logical-block (stream nil)
-        (format stream "~%~A names ~A:" symbol wot)
+        (format stream "~@:_~A names ~A:" symbol wot)
         (pprint-indent :block 2 stream)
         (when (eq (info :variable :where-from symbol) :declared)
           (format stream "~@:_Declared type: ~S"
                   (type-specifier (info :variable :type symbol))))
+        (when (info :variable :always-bound symbol)
+          (format stream "~@:_Declared always-bound."))
         (cond
           ((eq kind :alien)
            (let ((info (info :variable :alien-info symbol)))
@@ -260,7 +316,7 @@
                      (sb-alien-internals:unparse-alien-type
                       (sb-alien::heap-alien-info-type info)))
              (format stream "~@:_Address: #x~8,'0X"
-                     (sap-int (eval (sb-alien::heap-alien-info-sap-form info))))))
+                     (sap-int (sb-alien::heap-alien-info-sap info)))))
           ((eq kind :macro)
            (let ((expansion (info :variable :macro-expansion symbol)))
              (format stream "~@:_Expansion: ~S" expansion)))
@@ -292,20 +348,34 @@
     (when fun
       (pprint-newline :mandatory stream)
       (pprint-logical-block (stream nil)
-        (pprint-indent :block 2 stream)
-        (format stream "~A names a ~@[primitive~* ~]type-specifier:"
+        (format stream "~@:_~A names a ~@[primitive~* ~]type-specifier:"
                 symbol
                 (eq kind :primitive))
+        (pprint-indent :block 2 stream)
         (describe-documentation symbol 'type stream (eq t fun))
         (unless (eq t fun)
           (describe-lambda-list (if (eq :primitive kind)
                                     (%fun-lambda-list fun)
                                     (info :type :lambda-list symbol))
                                 stream)
-          (when (eq (%fun-fun fun) (%fun-fun (constant-type-expander t)))
-            (format stream "~@:_Expansion: ~S" (funcall fun (list symbol))))))
+          (multiple-value-bind (expansion ok)
+              (handler-case (typexpand-1 symbol)
+                (error () (values nil nil)))
+            (when ok
+              (format stream "~@:_Expansion: ~S" expansion)))))
       (terpri stream)))
 
+  (when (or (member symbol sb-c::*policy-qualities*)
+            (assoc symbol sb-c::*policy-dependent-qualities*))
+    (pprint-logical-block (stream nil)
+      (pprint-newline :mandatory stream)
+      (pprint-indent :block 2 stream)
+      (format stream "~A names a~:[ dependent~;n~] optimization policy quality:"
+              symbol
+              (member symbol sb-c::*policy-qualities*))
+      (describe-documentation symbol 'optimize stream t))
+    (terpri stream))
+
   ;; Print out properties.
   (let ((plist (symbol-plist symbol)))
     (when plist
@@ -319,41 +389,43 @@
       (terpri stream))))
 
 (defmethod describe-object ((package package) stream)
-  (describe-documentation package t stream)
-  (flet ((humanize (list)
-           (sort (mapcar (lambda (x)
-                           (if (packagep x)
-                               (package-name x)
-                               x))
-                         list)
-                 #'string<))
-         (out (label list)
-           (describe-stuff label list stream :escape nil)))
-    (let ((implemented (humanize (package-implemented-by-list package)))
-          (implements (humanize (package-implements-list package)))
-          (nicks (humanize (package-nicknames package)))
-          (uses (humanize (package-use-list package)))
-          (used (humanize (package-used-by-list package)))
-          (shadows (humanize (package-shadowing-symbols package)))
-          (this (list (package-name package)))
-          (exports nil))
-      (do-external-symbols (ext package)
-        (push ext exports))
-      (setf exports (humanize exports))
-      (when (package-locked-p package)
-        (format stream "~@:_Locked."))
-      (when (set-difference implemented this :test #'string=)
-        (out "Implemented-by-list" implemented))
-      (when (set-difference implements this :test #'string=)
-        (out "Implements-list" implements))
-      (out "Nicknames" nicks)
-      (out "Use-list" uses)
-      (out "Used-by-list" used)
-      (out "Shadows" shadows)
-      (out "Exports" exports)
-      (format stream "~@:_~S internal symbols."
-              (package-internal-symbol-count package))))
-  (terpri stream))
+  (print-standard-describe-header package stream)
+  (pprint-logical-block (stream nil)
+    (describe-documentation package t stream)
+    (flet ((humanize (list)
+             (sort (mapcar (lambda (x)
+                             (if (packagep x)
+                                 (package-name x)
+                                 x))
+                           list)
+                   #'string<))
+           (out (label list)
+             (describe-stuff label list stream :escape nil)))
+      (let ((implemented (humanize (package-implemented-by-list package)))
+            (implements (humanize (package-implements-list package)))
+            (nicks (humanize (package-nicknames package)))
+            (uses (humanize (package-use-list package)))
+            (used (humanize (package-used-by-list package)))
+            (shadows (humanize (package-shadowing-symbols package)))
+            (this (list (package-name package)))
+            (exports nil))
+        (do-external-symbols (ext package)
+          (push ext exports))
+        (setf exports (humanize exports))
+        (when (package-locked-p package)
+          (format stream "~@:_Locked."))
+        (when (set-difference implemented this :test #'string=)
+          (out "Implemented-by-list" implemented))
+        (when (set-difference implements this :test #'string=)
+          (out "Implements-list" implements))
+        (out "Nicknames" nicks)
+        (out "Use-list" uses)
+        (out "Used-by-list" used)
+        (out "Shadows" shadows)
+        (out "Exports" exports)
+        (format stream "~@:_~S internal symbols."
+                (package-internal-symbol-count package))))
+    (terpri stream)))
 
 ;;;; Helpers to deal with shared functionality
 
@@ -365,7 +437,7 @@
       (let ((metaclass-name (class-name (class-of class))))
         (pprint-logical-block (stream nil)
           (when by-name
-            (format stream "~%~A names the ~(~A~) ~S:"
+            (format stream "~@:_~A names the ~(~A~) ~S:"
                     name
                     metaclass-name
                     class)
@@ -424,6 +496,7 @@
                                             (quiet-doc slotd t)))
                                     slots))
                     (format stream "~@:_No direct slots."))))
+          (pprint-indent :block 0 stream)
           (pprint-newline :mandatory stream))))))
 
 (defun describe-instance (object stream)
@@ -477,7 +550,10 @@
         (format stream "~@:_~A:~@<~;~{ ~A~^,~:_~}~;~:>" label list))))
 
 (defun describe-lambda-list (lambda-list stream)
-  (format stream "~@:_Lambda-list: ~:A" lambda-list))
+  (let ((*print-circle* nil)
+        (*print-level* 24)
+        (*print-length* 24))
+    (format stream "~@:_Lambda-list: ~:A" lambda-list)))
 
 (defun describe-function-source (function stream)
   (if (compiled-function-p function)
@@ -495,9 +571,7 @@
                        (format stream "~@:_Source file: ~A" namestring))
                       ((sb-di:debug-source-form source)
                        (format stream "~@:_Source form:~@:_  ~S"
-                               (sb-di:debug-source-form source)))
-                      (t (bug "Don't know how to use a DEBUG-SOURCE without ~
-                               a namestring or a form."))))))))
+                               (sb-di:debug-source-form source)))))))))
       #+sb-eval
       (let ((source (sb-eval:interpreted-function-source-location function)))
         (when source
@@ -507,79 +581,100 @@
 
 (defun describe-function (name function stream)
   (let ((name (if function (fun-name function) name)))
-    (when (or function (and (legal-fun-name-p name) (fboundp name)))
-      (multiple-value-bind (fun what lambda-list ftype from inline
-                                methods)
-          (cond ((and (not function) (symbolp name) (special-operator-p name))
-                 (let ((fun (symbol-function name)))
-                   (values fun "a special operator" (%fun-lambda-list fun))))
-                ((and (not function) (symbolp name) (macro-function name))
-                 (let ((fun (macro-function name)))
-                   (values fun "a macro" (%fun-lambda-list fun))))
-                (t
-                 (let ((fun (or function (fdefinition name))))
-                   (multiple-value-bind (ftype from)
-                       (if function
-                           (values (%fun-type function) "Derived")
-                           (let ((ctype (info :function :type name)))
-                             (values (when ctype (type-specifier ctype))
-                                     (when ctype
-                                       (ecase (info :function :where-from name)
-                                         (:declared "Declared")
-                                         ;; This is hopefully clearer to users
-                                         ((:defined-method :defined) "Derived"))))))
-                     (if (typep fun 'generic-function)
-                         (values fun
-                                 "a generic function"
-                                 (sb-mop:generic-function-lambda-list fun)
-                                 ftype
-                                 from
-                                 nil
-                                 (or (sb-mop:generic-function-methods fun)
-                                     :none))
-                         (values fun
-                                 (if (compiled-function-p fun)
-                                     "a compiled function"
-                                     "an interpreted function")
-                                 (%fun-lambda-list fun)
-                                 ftype
-                                 from
-                                 (unless function
-                                   (cons
-                                    (info :function :inlinep name)
-                                    (info :function :inline-expansion-designator name)))))))))
-        (pprint-logical-block (stream nil)
-          (unless function
-            (format stream "~%~A names ~A:" name what)
-            (pprint-indent :block 2 stream))
-          (describe-lambda-list lambda-list stream)
-          (when ftype
-            (format stream "~@:_~A type: ~S" from ftype))
-          (describe-documentation name 'function stream)
-          (when (car inline)
-            (format stream "~@:_Inline proclamation: ~A (~:[no ~;~]inline expansion available)"
-                    (car inline)
-                    (cdr inline)))
-          (when methods
-            (format stream "~@:_Method-combination: ~S"
-                    (sb-pcl::method-combination-type-name
-                     (sb-pcl:generic-function-method-combination fun)))
-            (cond ((eq :none methods)
-                   (format stream "~@:_No methods."))
+    (if (not (or function (and (legal-fun-name-p name) (fboundp name))))
+        ;; Not defined, but possibly the type is declared, or we have
+        ;; compiled calls to it.
+        (when (legal-fun-name-p name)
+          (multiple-value-bind (from sure) (info :function :where-from name)
+            (when (or (eq :declared from) (and sure (eq :assumed from)))
+              (pprint-logical-block (stream nil)
+                (format stream "~%~A names an undefined function" name)
+                (pprint-indent :block 2 stream)
+                (format stream "~@:_~:(~A~) type: ~S"
+                        from
+                        (type-specifier (info :function :type name)))))))
+        ;; Defined.
+        (multiple-value-bind (fun what lambda-list ftype from inline methods)
+            (cond ((and (not function) (symbolp name) (special-operator-p name))
+                   (let ((fun (symbol-function name)))
+                     (values fun "a special operator" (%fun-lambda-list fun))))
+                  ((and (not function) (symbolp name) (macro-function name))
+                   (let ((fun (macro-function name)))
+                     (values fun "a macro" (%fun-lambda-list fun))))
                   (t
-                   (pprint-newline :mandatory stream)
-                   (pprint-logical-block (stream nil)
-                     (format stream "Methods:")
-                     (dolist (method methods)
-                       (pprint-indent :block 2 stream)
-                       (format stream "~@:_(~A ~{~S ~}~:S)"
-                               name
-                               (method-qualifiers method)
-                               (sb-pcl::unparse-specializers fun (sb-mop:method-specializers method)))
-                       (pprint-indent :block 4 stream)
-                       (describe-documentation method t stream nil))))))
-          (describe-function-source fun stream)
-          (terpri stream)))))
+                   (let ((fun (or function (fdefinition name))))
+                     (multiple-value-bind (ftype from)
+                         (if function
+                             (values (%fun-type function) :derived)
+                             (let ((ctype (info :function :type name)))
+                               (values (when ctype (type-specifier ctype))
+                                       (when ctype
+                                         ;; Ensure lazy pickup of information
+                                         ;; from methods.
+                                         (sb-c::maybe-update-info-for-gf name)
+                                         (ecase (info :function :where-from name)
+                                           (:declared :declared)
+                                           ;; This is hopefully clearer to users
+                                           ((:defined-method :defined) :derived))))))
+                       (if (typep fun 'standard-generic-function)
+                           (values fun
+                                   "a generic function"
+                                   (sb-mop:generic-function-lambda-list fun)
+                                   ftype
+                                   from
+                                   nil
+                                   (or (sb-mop:generic-function-methods fun)
+                                       :none))
+                           (values fun
+                                   (if (compiled-function-p fun)
+                                       "a compiled function"
+                                       "an interpreted function")
+                                   (%fun-lambda-list fun)
+                                   ftype
+                                   from
+                                   (unless function
+                                     (cons
+                                      (info :function :inlinep name)
+                                      (info :function :inline-expansion-designator name)))))))))
+          (pprint-logical-block (stream nil)
+            (unless function
+              (format stream "~%~A names ~A:" name what)
+              (pprint-indent :block 2 stream))
+            (describe-lambda-list lambda-list stream)
+            (when (and ftype from)
+              (format stream "~@:_~:(~A~) type: ~S" from ftype))
+            (when (eq :declared from)
+              (let ((derived-ftype (%fun-type fun)))
+                (unless (equal derived-ftype ftype)
+                  (format stream "~@:_Derived type: ~S" derived-ftype))))
+            (describe-documentation name 'function stream)
+            (when (car inline)
+              (format stream "~@:_Inline proclamation: ~A (~:[no ~;~]inline expansion available)"
+                      (car inline)
+                      (cdr inline)))
+            (awhen (info :function :info name)
+              (awhen (sb-c::decode-ir1-attributes (sb-c::fun-info-attributes it))
+                  (format stream "~@:_Known attributes: ~(~{~A~^, ~}~)" it)))
+            (when methods
+              (format stream "~@:_Method-combination: ~S"
+                      (sb-pcl::method-combination-type-name
+                       (sb-pcl:generic-function-method-combination fun)))
+              (cond ((eq :none methods)
+                     (format stream "~@:_No methods."))
+                    (t
+                     (pprint-newline :mandatory stream)
+                     (pprint-logical-block (stream nil)
+                       (format stream "Methods:")
+                       (dolist (method methods)
+                         (pprint-indent :block 2 stream)
+                         (format stream "~@:_(~A ~{~S ~}~:S)"
+                                 name
+                                 (method-qualifiers method)
+                                 (sb-pcl::unparse-specializers fun (sb-mop:method-specializers method)))
+                         (pprint-indent :block 4 stream)
+                         (describe-documentation method t stream nil))))))
+            (describe-function-source fun stream)
+            (terpri stream)))))
   (unless function
     (awhen (and (legal-fun-name-p name) (compiler-macro-function name))
       (pprint-logical-block (stream nil)
@@ -604,7 +699,9 @@
                  (format stream "~&~A has a complex setf-expansion:"
                          name)
                  (pprint-indent :block 2 stream)
-                 (describe-documentation name2 'setf stream t))
+                 (describe-lambda-list (%fun-lambda-list expander) stream)
+                 (describe-documentation name2 'setf stream t)
+                 (describe-function-source expander stream))
                (terpri stream)))))
     (when (symbolp name)
       (describe-function `(setf ,name) nil stream))))