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))