function-lambda-expression: Return the name of a generic function.

The third value of
(function-lambda-expression (defgeneric foo ()))
is now FOO, and not
(LAMBDA (&REST SB-PCL::ARGS) :IN SB-PCL::MAKE-INITIAL-DFUN)
Reported by Marco Baringer.

diff --git a/NEWS b/NEWS
index bf335e6..64ec424 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,8 @@ changes relative to sbcl-1.1.12:
   * enhancement: The error message when calling an undefined alien function
     includes the name of the function on x86-64.
   * enhancement: sb-ext:run-program now supports :environment on Windows.
+  * enhancement: ASDF is no longer required to load contribs at runtime.
+    (lp#1132254)
   * bug fix: forward references to classes in fasls can now be loaded.
     (lp#746132)
   * bug fix: don't warn on a interpreted->compiled function redefinition
@@ -17,6 +19,8 @@ changes relative to sbcl-1.1.12:
     (Reported by Douglas Katzman)
   * bug fix: run-prorgram performs more correct escaping of arguments on
     Windows. (lp#1239242)
+  * bug fix: function-lambda-expression on generic functions returns the
+    actual name.
 
 changes in sbcl-1.1.12 relative to sbcl-1.1.11:
   * enhancement: Add sb-bsd-sockets:socket-shutdown, for calling

diff --git a/src/code/describe.lisp b/src/code/describe.lisp
index 8f64b6a..77f3c36 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))

diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp
index 5432cae..04b1012 100644 (file)
--- a/src/code/target-misc.lisp
+++ b/src/code/target-misc.lisp
@@ -13,54 +13,6 @@
 ;;;; files for more information.
 
 (in-package "SB!IMPL")
-\f
-;;;; function names and documentation
-
-;;;; 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)
-  "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* ((fun (%simple-fun-self (%fun-fun fun)))
-            (name (%fun-name 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))))))
-
 ;;;; Generalizing over SIMPLE-FUN, CLOSURE, and FUNCALLABLE-INSTANCEs
 
 ;;; Underlying SIMPLE-FUN

diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp
index 175edce..0838bdd 100644 (file)
--- a/tests/interface.impure.lisp
+++ b/tests/interface.impure.lisp
@@ -59,26 +59,26 @@
 ;;; while we're at it, much the same applies to
 ;;; FUNCTION-LAMBDA-EXPRESSION:
 (defun fle-fun (x) x)
-(function-lambda-expression #'fle-fun)
 
 (let ((x 1)) (defun fle-closure (y) (if y (setq x y) x)))
-(function-lambda-expression #'fle-closure)
 
-#+sb-eval
-(progn
-  ;; Nor should it fail on interpreted functions
-  (let ((sb-ext:*evaluator-mode* :interpret))
-    (eval `(defun fle-eval (x) x))
-    (function-lambda-expression #'fle-eval))
+(with-test (:name :function-lambda-expression)
+  (flet ((fle-name (x)
+           (nth-value 2 (function-lambda-expression x))))
+    (assert (eql (fle-name #'fle-fun) 'fle-fun))
+    (assert (eql (fle-name #'fle-closure) 'fle-closure))
+    (assert (eql (fle-name #'disassemble-generic) 'disassemble-generic))
+    (function-lambda-expression
+     (sb-mop:make-instance 'sb-mop:funcallable-standard-object))
+    #+sb-eval
+    (progn
+      (let ((sb-ext:*evaluator-mode* :interpret))
+        (eval `(defun fle-eval (x) x))
+        (assert (eql (fle-name #'fle-eval) 'fle-eval)))
+
+      ;; fle-eval should still be an interpreted function.
+      (assert (sb-eval:interpreted-function-p #'fle-eval)))))
 
-  ;; fle-eval should still be an interpreted function.
-  (assert (sb-eval:interpreted-function-p #'fle-eval)))
-
-;; nor should it fail on generic functions or other funcallable instances
-(defgeneric fle-generic (x))
-(function-lambda-expression #'fle-generic)
-(let ((fin (sb-mop:make-instance 'sb-mop:funcallable-standard-object)))
-  (function-lambda-expression fin))
 \f
 ;;; support for DESCRIBE tests
 (defstruct to-be-described a b)