projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Windows console I/O overhaul
[sbcl.git]
/
src
/
code
/
describe.lisp
diff --git
a/src/code/describe.lisp
b/src/code/describe.lisp
index
cfee036
..
17dc2fb
100644
(file)
--- a/
src/code/describe.lisp
+++ b/
src/code/describe.lisp
@@
-49,7
+49,12
@@
#+sb-doc
"Print a description of OBJECT to STREAM-DESIGNATOR."
(let ((stream (out-synonym-of stream-designator))
#+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)
;; Until sbcl-0.8.0.x, we did
;; (FRESH-LINE STREAM)
;; (PPRINT-LOGICAL-BLOCK (STREAM NIL)
@@
-65,7
+70,8
@@
;; 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.)
;; 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.
;; 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.
@@
-249,7
+255,7
@@
(:alien "an alien variable"))))
(when (or (not (eq :unknown kind)) (boundp symbol))
(pprint-logical-block (stream nil)
(: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"
(pprint-indent :block 2 stream)
(when (eq (info :variable :where-from symbol) :declared)
(format stream "~@:_Declared type: ~S"
@@
-264,7
+270,7
@@
(sb-alien-internals:unparse-alien-type
(sb-alien::heap-alien-info-type info)))
(format stream "~@:_Address: #x~8,'0X"
(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)))
((eq kind :macro)
(let ((expansion (info :variable :macro-expansion symbol)))
(format stream "~@:_Expansion: ~S" expansion)))
@@
-296,18
+302,21
@@
(when fun
(pprint-newline :mandatory stream)
(pprint-logical-block (stream nil)
(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))
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)
(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*)
(terpri stream)))
(when (or (member symbol sb-c::*policy-qualities*)
@@
-382,7
+391,7
@@
(let ((metaclass-name (class-name (class-of class))))
(pprint-logical-block (stream nil)
(when by-name
(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)
name
metaclass-name
class)
@@
-441,6
+450,7
@@
(quiet-doc slotd t)))
slots))
(format stream "~@:_No direct slots."))))
(quiet-doc slotd t)))
slots))
(format stream "~@:_No direct slots."))))
+ (pprint-indent :block 0 stream)
(pprint-newline :mandatory stream))))))
(defun describe-instance (object stream)
(pprint-newline :mandatory stream))))))
(defun describe-instance (object stream)
@@
-494,7
+504,10
@@
(format stream "~@:_~A:~@<~;~{ ~A~^,~:_~}~;~:>" label list))))
(defun describe-lambda-list (lambda-list 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)
(defun describe-function-source (function stream)
(if (compiled-function-p function)
@@
-512,9
+525,7
@@
(format stream "~@:_Source file: ~A" namestring))
((sb-di:debug-source-form source)
(format stream "~@:_Source form:~@:_ ~S"
(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
#+sb-eval
(let ((source (sb-eval:interpreted-function-source-location function)))
(when source
@@
-537,8
+548,7
@@
from
(type-specifier (info :function :type name)))))))
;; Defined.
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 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))))
(cond ((and (not function) (symbolp name) (special-operator-p name))
(let ((fun (symbol-function name)))
(values fun "a special operator" (%fun-lambda-list fun))))
@@
-549,7
+559,7
@@
(let ((fun (or function (fdefinition name))))
(multiple-value-bind (ftype from)
(if function
(let ((fun (or function (fdefinition name))))
(multiple-value-bind (ftype from)
(if function
- (values (%fun-type function) "Derived")
+ (values (%fun-type function) :derived)
(let ((ctype (info :function :type name)))
(values (when ctype (type-specifier ctype))
(when ctype
(let ((ctype (info :function :type name)))
(values (when ctype (type-specifier ctype))
(when ctype
@@
-557,9
+567,9
@@
;; from methods.
(sb-c::maybe-update-info-for-gf name)
(ecase (info :function :where-from name)
;; from methods.
(sb-c::maybe-update-info-for-gf name)
(ecase (info :function :where-from name)
- (:declared "Declared")
+ (:declared :declared)
;; This is hopefully clearer to users
;; This is hopefully clearer to users
- ((:defined-method :defined) "Derived"))))))
+ ((:defined-method :defined) :derived))))))
(if (typep fun 'generic-function)
(values fun
"a generic function"
(if (typep fun 'generic-function)
(values fun
"a generic function"
@@
-586,12
+596,19
@@
(pprint-indent :block 2 stream))
(describe-lambda-list lambda-list stream)
(when (and ftype from)
(pprint-indent :block 2 stream))
(describe-lambda-list lambda-list stream)
(when (and ftype from)
- (format stream "~@:_~A type: ~S" from ftype))
+ (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))))
(describe-documentation name 'function stream)
(when (car inline)
(format stream "~@:_Inline proclamation: ~A (~:[no ~;~]inline expansion available)"
(car inline)
(cdr inline)))
(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
(when methods
(format stream "~@:_Method-combination: ~S"
(sb-pcl::method-combination-type-name
@@
-636,7
+653,9
@@
(format stream "~&~A has a complex setf-expansion:"
name)
(pprint-indent :block 2 stream)
(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))))
(terpri stream)))))
(when (symbolp name)
(describe-function `(setf ,name) nil stream))))