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))
#+sb-doc
"Print a description of OBJECT to STREAM-DESIGNATOR."
(let ((stream (out-synonym-of stream-designator))
- (*print-right-margin* (or *print-right-margin* 72)))
+ (*print-right-margin* (or *print-right-margin* 72))
+ (*print-circle* t)
+ (*suppress-print-errors*
+ (if (subtypep 'serious-condition *suppress-print-errors*)
+ *suppress-print-errors*
+ 'serious-condition)))
;; Until sbcl-0.8.0.x, we did
;; (FRESH-LINE STREAM)
;; (PPRINT-LOGICAL-BLOCK (STREAM NIL)
;; here. (The example method for DESCRIBE-OBJECT does its own
;; FRESH-LINEing, which is a physical directive which works poorly
;; inside a pretty-printer logical block.)
- (describe-object object stream)
+ (handler-bind ((print-not-readable #'print-unreadably))
+ (describe-object object stream))
;; We don't TERPRI here either (any more since sbcl-0.8.0.x), because
;; again ANSI's specification of DESCRIBE doesn't mention it and
;; ANSI's example of DESCRIBE-OBJECT does its own final TERPRI.
(base-char "base-char")
(t "character")))
-(declaim (ftype (function (t stream)) describe-object))
-(defgeneric describe-object (x stream))
+(defun print-standard-describe-header (x stream)
+ (format stream "~&~A~% [~A]~%"
+ (object-self-string x)
+ (object-type-string x)))
-(defvar *in-describe* nil)
-
-(defmethod describe-object :around (x s)
- (cond (*in-describe*
- (call-next-method))
- (t
- (format s "~&~A~% [~A]~%"
- (object-self-string x)
- (object-type-string x))
- (pprint-logical-block (s nil)
- (call-next-method x s)))))
+(defgeneric describe-object (x stream))
;;; Catch-all.
+
(defmethod describe-object ((x t) s)
- (values))
+ (print-standard-describe-header x s))
(defmethod describe-object ((x cons) s)
+ (print-standard-describe-header x s)
(describe-function x nil s))
(defmethod describe-object ((x function) s)
+ (print-standard-describe-header x s)
(describe-function nil x s))
(defmethod describe-object ((x class) s)
+ (print-standard-describe-header x s)
(describe-class nil x s)
(describe-instance x s))
(defmethod describe-object ((x sb-pcl::slot-object) s)
+ (print-standard-describe-header x s)
(describe-instance x s))
(defmethod describe-object ((x character) s)
- (format s "~%:_Char-code: ~S" (char-code x))
- (format s "~%:_Char-name: ~A~%_" (char-name x)))
+ (print-standard-describe-header x s)
+ (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)
(format s "~%Element-type: ~S" (array-element-type x))
(if (vectorp x)
(if (array-has-fill-pointer-p x)
(terpri s)))
(defmethod describe-object ((x hash-table) s)
- ;; Don't print things which are already apparent from the printed representation
- ;; -- COUNT, TEST, and WEAKNESS
- (format s "~%Occupancy: ~,1F" (float (/ (hash-table-count x) (hash-table-size x))))
+ (print-standard-describe-header x s)
+ ;; Don't print things which are already apparent from the printed
+ ;; representation -- COUNT, TEST, and WEAKNESS
+ (format s "~%Occupancy: ~,1F" (float (/ (hash-table-count x)
+ (hash-table-size x))))
(format s "~%Rehash-threshold: ~S" (hash-table-rehash-threshold x))
(format s "~%Rehash-size: ~S" (hash-table-rehash-size x))
(format s "~%Size: ~S" (hash-table-size x))
(terpri s))
(defmethod describe-object ((symbol symbol) stream)
+ (print-standard-describe-header symbol stream)
;; Describe the value cell.
(let* ((kind (info :variable :kind symbol))
(wot (ecase kind
(:alien "an alien variable"))))
(when (or (not (eq :unknown kind)) (boundp symbol))
(pprint-logical-block (stream nil)
- (format stream "~%~A names ~A:" symbol wot)
+ (format stream "~@:_~A names ~A:" symbol wot)
(pprint-indent :block 2 stream)
(when (eq (info :variable :where-from symbol) :declared)
(format stream "~@:_Declared type: ~S"
(type-specifier (info :variable :type symbol))))
+ (when (info :variable :always-bound symbol)
+ (format stream "~@:_Declared always-bound."))
(cond
((eq kind :alien)
(let ((info (info :variable :alien-info symbol)))
(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)))
(when fun
(pprint-newline :mandatory stream)
(pprint-logical-block (stream nil)
- (pprint-indent :block 2 stream)
- (format stream "~A names a ~@[primitive~* ~]type-specifier:"
+ (format stream "~@:_~A names a ~@[primitive~* ~]type-specifier:"
symbol
(eq kind :primitive))
+ (pprint-indent :block 2 stream)
(describe-documentation symbol 'type stream (eq t fun))
(unless (eq t fun)
(describe-lambda-list (if (eq :primitive kind)
(%fun-lambda-list fun)
(info :type :lambda-list symbol))
stream)
- (when (eq (%fun-fun fun) (%fun-fun (constant-type-expander t)))
- (format stream "~@:_Expansion: ~S" (funcall fun (list symbol))))))
+ (multiple-value-bind (expansion ok)
+ (handler-case (typexpand-1 symbol)
+ (error () (values nil nil)))
+ (when ok
+ (format stream "~@:_Expansion: ~S" expansion)))))
(terpri stream)))
+ (when (or (member symbol sb-c::*policy-qualities*)
+ (assoc symbol sb-c::*policy-dependent-qualities*))
+ (pprint-logical-block (stream nil)
+ (pprint-newline :mandatory stream)
+ (pprint-indent :block 2 stream)
+ (format stream "~A names a~:[ dependent~;n~] optimization policy quality:"
+ symbol
+ (member symbol sb-c::*policy-qualities*))
+ (describe-documentation symbol 'optimize stream t))
+ (terpri stream))
+
;; Print out properties.
(let ((plist (symbol-plist symbol)))
(when plist
(terpri stream))))
(defmethod describe-object ((package package) stream)
- (describe-documentation package t stream)
- (flet ((humanize (list)
- (sort (mapcar (lambda (x)
- (if (packagep x)
- (package-name x)
- x))
- list)
- #'string<))
- (out (label list)
- (describe-stuff label list stream :escape nil)))
- (let ((implemented (humanize (package-implemented-by-list package)))
- (implements (humanize (package-implements-list package)))
- (nicks (humanize (package-nicknames package)))
- (uses (humanize (package-use-list package)))
- (used (humanize (package-used-by-list package)))
- (shadows (humanize (package-shadowing-symbols package)))
- (this (list (package-name package)))
- (exports nil))
- (do-external-symbols (ext package)
- (push ext exports))
- (setf exports (humanize exports))
- (when (package-locked-p package)
- (format stream "~@:_Locked."))
- (when (set-difference implemented this :test #'string=)
- (out "Implemented-by-list" implemented))
- (when (set-difference implements this :test #'string=)
- (out "Implements-list" implements))
- (out "Nicknames" nicks)
- (out "Use-list" uses)
- (out "Used-by-list" used)
- (out "Shadows" shadows)
- (out "Exports" exports)
- (format stream "~@:_~S internal symbols."
- (package-internal-symbol-count package))))
- (terpri stream))
+ (print-standard-describe-header package stream)
+ (pprint-logical-block (stream nil)
+ (describe-documentation package t stream)
+ (flet ((humanize (list)
+ (sort (mapcar (lambda (x)
+ (if (packagep x)
+ (package-name x)
+ x))
+ list)
+ #'string<))
+ (out (label list)
+ (describe-stuff label list stream :escape nil)))
+ (let ((implemented (humanize (package-implemented-by-list package)))
+ (implements (humanize (package-implements-list package)))
+ (nicks (humanize (package-nicknames package)))
+ (uses (humanize (package-use-list package)))
+ (used (humanize (package-used-by-list package)))
+ (shadows (humanize (package-shadowing-symbols package)))
+ (this (list (package-name package)))
+ (exports nil))
+ (do-external-symbols (ext package)
+ (push ext exports))
+ (setf exports (humanize exports))
+ (when (package-locked-p package)
+ (format stream "~@:_Locked."))
+ (when (set-difference implemented this :test #'string=)
+ (out "Implemented-by-list" implemented))
+ (when (set-difference implements this :test #'string=)
+ (out "Implements-list" implements))
+ (out "Nicknames" nicks)
+ (out "Use-list" uses)
+ (out "Used-by-list" used)
+ (out "Shadows" shadows)
+ (out "Exports" exports)
+ (format stream "~@:_~S internal symbols."
+ (package-internal-symbol-count package))))
+ (terpri stream)))
\f
;;;; Helpers to deal with shared functionality
(let ((metaclass-name (class-name (class-of class))))
(pprint-logical-block (stream nil)
(when by-name
- (format stream "~%~A names the ~(~A~) ~S:"
+ (format stream "~@:_~A names the ~(~A~) ~S:"
name
metaclass-name
class)
(quiet-doc slotd t)))
slots))
(format stream "~@:_No direct slots."))))
+ (pprint-indent :block 0 stream)
(pprint-newline :mandatory stream))))))
(defun describe-instance (object stream)
(format stream "~@:_~A:~@<~;~{ ~A~^,~:_~}~;~:>" label list))))
(defun describe-lambda-list (lambda-list stream)
- (format stream "~@:_Lambda-list: ~:A" lambda-list))
+ (let ((*print-circle* nil)
+ (*print-level* 24)
+ (*print-length* 24))
+ (format stream "~@:_Lambda-list: ~:A" lambda-list)))
(defun describe-function-source (function stream)
(if (compiled-function-p function)
(format stream "~@:_Source file: ~A" namestring))
((sb-di:debug-source-form source)
(format stream "~@:_Source form:~@:_ ~S"
- (sb-di:debug-source-form source)))
- (t (bug "Don't know how to use a DEBUG-SOURCE without ~
- a namestring or a form."))))))))
+ (sb-di:debug-source-form source)))))))))
#+sb-eval
(let ((source (sb-eval:interpreted-function-source-location function)))
(when source
(defun describe-function (name function stream)
(let ((name (if function (fun-name function) name)))
- (when (or function (and (legal-fun-name-p name) (fboundp name)))
- (multiple-value-bind (fun what lambda-list ftype from 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))))
- ((and (not function) (symbolp name) (macro-function name))
- (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
- (ecase (info :function :where-from name)
- (:declared "Declared")
- ;; This is hopefully clearer to users
- ((:defined-method :defined) "Derived"))))))
- (if (typep fun 'generic-function)
+ (if (not (or function (and (legal-fun-name-p name) (fboundp name))))
+ ;; Not defined, but possibly the type is declared, or we have
+ ;; compiled calls to it.
+ (when (legal-fun-name-p name)
+ (multiple-value-bind (from sure) (info :function :where-from name)
+ (when (or (eq :declared from) (and sure (eq :assumed from)))
+ (pprint-logical-block (stream nil)
+ (format stream "~%~A names an undefined function" name)
+ (pprint-indent :block 2 stream)
+ (format stream "~@:_~:(~A~) type: ~S"
+ from
+ (type-specifier (info :function :type name)))))))
+ ;; Defined.
+ (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))))
+ ((and (not function) (symbolp name) (macro-function name))
+ (let ((fun (macro-function name)))
+ (values fun "a macro" (%fun-lambda-list fun))))
+ (t
+ (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)
- ftype
- from
+ derived-type
+ declared-type
nil
(or (sb-mop:generic-function-methods fun)
:none))
"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)))))))))
- (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 ftype
- (format stream "~@:_~A type: ~S" from ftype))
- (describe-documentation name 'function stream)
- (when (car inline)
- (format stream "~@:_Inline proclamation: ~A (~:[no ~;~]inline expansion available)"
- (car inline)
- (cdr inline)))
- (when methods
- (format stream "~@:_Method-combination: ~S"
- (sb-pcl::method-combination-type-name
- (sb-pcl:generic-function-method-combination fun)))
- (cond ((eq :none methods)
- (format stream "~@:_No methods."))
- (t
- (pprint-newline :mandatory stream)
- (pprint-logical-block (stream nil)
- (format stream "Methods:")
- (dolist (method methods)
- (pprint-indent :block 2 stream)
- (format stream "~@:_(~A ~{~S ~}~:S)"
- name
- (method-qualifiers 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)
- (terpri stream)))))
+ 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 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)"
+ (car inline)
+ (cdr inline)))
+ (awhen (info :function :info name)
+ (awhen (sb-c::decode-ir1-attributes (sb-c::fun-info-attributes it))
+ (format stream "~@:_Known attributes: ~(~{~A~^, ~}~)" it)))
+ (when methods
+ (format stream "~@:_Method-combination: ~S"
+ (sb-pcl::method-combination-type-name
+ (sb-pcl:generic-function-method-combination fun)))
+ (cond ((eq :none methods)
+ (format stream "~@:_No methods."))
+ (t
+ (pprint-newline :mandatory stream)
+ (pprint-logical-block (stream nil)
+ (format stream "Methods:")
+ (dolist (method methods)
+ (pprint-indent :block 2 stream)
+ (format stream "~@:_(~A ~{~S ~}~:S)"
+ name
+ (method-qualifiers 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)
+ (terpri stream)))))
(unless function
(awhen (and (legal-fun-name-p name) (compiler-macro-function name))
(pprint-logical-block (stream nil)
(format stream "~&~A has a complex setf-expansion:"
name)
(pprint-indent :block 2 stream)
- (describe-documentation name2 'setf stream t))
+ (describe-lambda-list (%fun-lambda-list expander) stream)
+ (describe-documentation name2 'setf stream t)
+ (describe-function-source expander stream))
(terpri stream)))))
(when (symbolp name)
(describe-function `(setf ,name) nil stream))))