Remove duplicate implementations of (setf aref/sbit/bit).

[sbcl.git] / src / code / describe.lisp

diff --git a/src/code/describe.lisp b/src/code/describe.lisp
index ddff875..50f45ac 100644 (file)
--- 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))
@@ -204,8 +250,8 @@
 
 (defmethod describe-object ((x character) s)
   (print-standard-describe-header x s)
-  (format s "~%:_Char-code: ~S" (char-code x))
-  (format s "~%:_Char-name: ~A~%_" (char-name x)))
+  (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)
@@ -270,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)))
@@ -570,7 +616,7 @@
                                            (:declared :declared)
                                            ;; This is hopefully clearer to users
                                            ((:defined-method :defined) :derived))))))
-                       (if (typep fun 'generic-function)
+                       (if (typep fun 'standard-generic-function)
                            (values fun
                                    "a generic function"
                                    (sb-mop:generic-function-lambda-list fun)