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))
(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)
from
(type-specifier (info :function :type name)))))))
;; Defined.
- (multiple-value-bind (fun what lambda-list ftype from inline methods)
+ (multiple-value-bind (fun what lambda-list derived-type declared-type
+ 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))))
(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
- ;; 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 '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)))))))))
+ (let* ((fun (or function (fdefinition name)))
+ (derived-type (and function
+ (%fun-type function)))
+ (legal-name-p (legal-fun-name-p name))
+ (ctype (and legal-name-p
+ (info :function :type name)))
+ (type (and ctype (type-specifier ctype)))
+ (from (and legal-name-p
+ (info :function :where-from name)))
+ declared-type)
+ ;; Ensure lazy pickup of information
+ ;; from methods.
+ (when legal-name-p
+ (sb-c::maybe-update-info-for-gf name))
+ (cond ((not type))
+ ((eq from :declared)
+ (setf declared-type type))
+ ((and (not derived-type)
+ (member from '(:defined-method :defined)))
+ (setf derived-type type)))
+ (unless derived-type
+ (setf derived-type (%fun-type fun)))
+ (if (typep fun 'standard-generic-function)
+ (values fun
+ "a generic function"
+ (sb-mop:generic-function-lambda-list fun)
+ derived-type
+ declared-type
+ 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)
+ derived-type
+ declared-type
+ (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))))
+ (when declared-type
+ (format stream "~@:_Declared type: ~S" declared-type))
+ (when (and derived-type
+ (not (equal declared-type derived-type)))
+ (format stream "~@:_Derived type: ~S" derived-type))
(describe-documentation name 'function stream)
(when (car inline)
- (format stream "~@:_Inline proclamation: ~A (~:[no ~;~]inline expansion available)"
+ (format stream "~@:_Inline proclamation: ~
+ ~A (~:[no ~;~]inline expansion available)"
(car inline)
(cdr inline)))
(awhen (info :function :info name)
(format stream "~@:_(~A ~{~S ~}~:S)"
name
(method-qualifiers method)
- (sb-pcl::unparse-specializers fun (sb-mop:method-specializers 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)
projects / sbcl.git / blobdiff