(base-char "base-char")
(t "character")))
-(defgeneric describe-object (x stream))
-
-(defvar *in-describe* nil)
+(defun print-standard-describe-header (x stream)
+ (format stream "~&~A~% [~A]~%"
+ (object-self-string x)
+ (object-type-string x)))
-(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)
+ (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
(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)))
(format stream "~@:_Expansion: ~S" (funcall fun (list symbol))))))
(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
projects / sbcl.git / blobdiff