(defmethod describe-object ((x array) s)
(fresh-line s)
(pprint-logical-block (s nil)
- (let ((rank (array-rank x)))
- (cond ((= rank 1)
- (format s
- "~S is a ~:[~;displaced ~]vector of length ~S." x
- (and (array-header-p x)
- (%array-displaced-p x)
- ) (length x))
- (when (array-has-fill-pointer-p x)
- (format s "~@:_It has a fill pointer, currently ~S."
- (fill-pointer x))))
- (t
- (format s "~S ~_is " x)
- (write-string (if (%array-displaced-p x) "a displaced" "an") s)
- (format s " array of rank ~S." rank)
- (format s "~@:_Its dimensions are ~S." (array-dimensions x)))))
+ (cond
+ ((= 1 (array-rank x))
+ (format s "~S is a vector with ~D elements."
+ x (car (array-dimensions x)))
+ (when (array-has-fill-pointer-p x)
+ (format s "~@:_It has a fill pointer value of ~S."
+ (fill-pointer x))))
+ (t
+ (format s "~S is an array of dimension ~:S."
+ x (array-dimensions x))))
(let ((array-element-type (array-element-type x)))
(unless (eq array-element-type t)
(format s
"~@:_Its element type is specialized to ~S."
- array-element-type))))
+ array-element-type)))
+ (if (and (array-header-p x) (%array-displaced-p x))
+ (format s "~@:_The array is displaced with offset ~S."
+ (%array-displacement x))))
(terpri s))
(defmethod describe-object ((x hash-table) s)
"~&~@<Its REHASH-SIZE is ~S. ~_Its REHASH-THRESHOLD is ~S.~:>"
(hash-table-rehash-size x)
(hash-table-rehash-threshold x))
- (fresh-line)
+ (fresh-line s)
(pprint-logical-block (s nil)
(let ((count (hash-table-count x)))
(format s "It holds ~S key/value pair~:P~:[: ~2I~_~;.~]"
(declare (type stream s))
(let ((info (sb-kernel:%code-debug-info code-obj)))
(when info
- (let ((sources (sb-c::debug-info-source info)))
- (when sources
+ (let ((source (sb-c::debug-info-source info)))
+ (when source
(format s "~&On ~A it was compiled from:"
;; FIXME: The FORMAT-UNIVERSAL-TIME calls in the system
;; should become more consistent, probably not using
;; any nondefault options.
- (format-universal-time nil
- (sb-c::debug-source-compiled
- (first sources))
+ (format-universal-time nil (sb-c::debug-source-compiled source)
:style :abbreviated))
- (dolist (source sources)
- (let ((name (sb-c::debug-source-name source)))
- (ecase (sb-c::debug-source-from source)
- (:file
- (format s "~&~A~@:_ Created: " (namestring name))
- (format-universal-time s (sb-c::debug-source-created
- source)))
- (:lisp (format s "~&~S" name))))))))))
+ (let ((name (sb-c::debug-source-name source)))
+ (ecase (sb-c::debug-source-from source)
+ (:file
+ (format s "~&~A~@:_ Created: " (namestring name))
+ (format-universal-time s (sb-c::debug-source-created source)))
+ (:lisp (format s "~&~S" name)))))))))
;;; Describe a compiled function. The closure case calls us to print
;;; the guts.
(pprint-indent :current 8)
(dotimes (i (- (get-closure-length x) (1- sb-vm:closure-info-offset)))
(format s "~@:_~S: ~S" i (%closure-index-ref x i)))))
- ((#.sb-vm:simple-fun-header-widetag #.sb-vm:closure-fun-header-widetag)
+ (#.sb-vm:simple-fun-header-widetag
(%describe-fun-compiled x s kind name))
(#.sb-vm:funcallable-instance-header-widetag
;; Only STANDARD-GENERIC-FUNCTION would be handled here, but
;; * NIL, in which case there's nothing to see here, move along.
(when (eq (info :type :kind x) :defined)
(format s "~&It names a type specifier."))
- (let ((symbol-named-class (find-classoid x nil)))
+ (let ((symbol-named-class (find-class x nil)))
(when symbol-named-class
(format s "~&It names a class ~A." symbol-named-class)
(describe symbol-named-class s)))