From dfc9c3a9dde3ae21498ac1a184a6e56fd4e79eb0 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Thu, 17 Oct 2013 19:05:29 +0400 Subject: [PATCH] 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. --- NEWS | 4 ++++ src/code/describe.lisp | 48 ++++++++++++++++++++++++++++++++++++++++++- src/code/target-misc.lisp | 48 ------------------------------------------- tests/interface.impure.lisp | 32 ++++++++++++++--------------- 4 files changed, 67 insertions(+), 65 deletions(-) diff --git a/NEWS b/NEWS index bf335e6..64ec424 100644 --- 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 --- 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 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -13,54 +13,6 @@ ;;;; files for more information. (in-package "SB!IMPL") - -;;;; 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 --- 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)) ;;; support for DESCRIBE tests (defstruct to-be-described a b) -- 1.7.10.4