X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdescribe.lisp;h=9cfc4d8df67c983871eb169b6525178013bb9f49;hb=b14a61c6af3e3005c94e633e727177346240066e;hp=ddff8758ab60db3c82125864db18236575a793f3;hpb=9033eb6759e57f21e26e82bf63142152080108f4;p=sbcl.git diff --git a/src/code/describe.lisp b/src/code/describe.lisp index ddff875..9cfc4d8 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)) @@ -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))) @@ -548,7 +594,8 @@ 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)))) @@ -556,54 +603,62 @@ (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) @@ -624,7 +679,8 @@ (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)