From: Nikodemus Siivola Date: Thu, 25 Jun 2009 09:40:22 +0000 (+0000) Subject: 1.0.29.38: better DESCRIBE X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6dc30bee17d029acf6bb6da730f03e63b2a01948;p=sbcl.git 1.0.29.38: better DESCRIBE * Rework DESCRIBE for more comprehensive reporting and easier to read output. * Delete src/pcl/describe.lisp, no PCL leftovers in the new DESCRIBE except for some heritage in DESCRIBE-INSTANCE. * Fix COMPILED timestamps: we want both internal-real and universal time for different use-cases. (Though I'm not sure if we really care about the COMPILED timestamps that much, especially now that I unilaterally removed their printing from DESCRIBE.) * Give primitive type transform functions the lambda-list of the type. --- diff --git a/NEWS b/NEWS index b7c8756..219257d 100644 --- a/NEWS +++ b/NEWS @@ -13,6 +13,8 @@ is known to be a signed word on x86 and x86-64. * optimization: (EXPT -1 INTEGER) is compiled into (IF (EVENP INTEGER) 1 -1). (thanks to Stas Boukarev) + * improvement: DESCRIBE output has been reworked to be easier to read and + contains more pertinent information. * improvement: failure to provide requested stack allocation compiler notes provided in all cases (requested stack allocation not happening without a note being issued is now considered a bug.) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 7592df6..0e87f35 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -576,20 +576,6 @@ ',(all-writers) (sb!c:source-location))))))) -;;;; DESCRIBE on CONDITIONs - -;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T) -;;; eventually (once we get CLOS up and running so that we can define -;;; methods) -(defun describe-condition (condition stream) - (format stream - "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%" - condition - (type-of condition) - (concatenate 'list - (condition-actual-initargs condition) - (condition-assigned-slots condition)))) - ;;;; various CONDITIONs specified by ANSI (define-condition serious-condition (condition) ()) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 619b224..b66fffd 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -1,5 +1,4 @@ -;;;; most of the DESCRIBE system -- that part which isn't derived -;;;; from PCL code +;;;; the DESCRIBE system ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -10,15 +9,47 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.) - -(declaim (ftype (function (t stream)) describe-object)) -(defgeneric describe-object (x stream)) +;;; SB-IMPL, not SB!IMPL, since we're built in warm load. +(in-package "SB-IMPL") + +;;;; Utils, move elsewhere. + +(defun class-name-or-class (class) + (let ((name (class-name class))) + (if (eq class (find-class name nil)) + name + class))) -(defun describe (x &optional (stream-designator *standard-output*)) +(defun fun-name (x) + (if (typep x 'generic-function) + (sb-pcl:generic-function-name x) + (%fun-name x))) + +;;; 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)) + (let* ((line (write-to-string x :escape t :readably nil :lines 2 :circle t)) + (p (position #\newline line)) + (limit (truncate (- *print-right-margin* reserve) columns))) + (flet ((trunc (&optional end) + (let ((line-end (- limit 2))) + (with-output-to-string (s) + (write-string line s :end (if end + (min end line-end) + line-end)) + (write-string ".." s))))) + (cond (p + (trunc p)) + ((> (length line) limit) + (trunc)) + (t + line))))) + +(defun describe (object &optional (stream-designator *standard-output*)) #+sb-doc - "Print a description of the object X." - (let ((stream (out-synonym-of stream-designator))) + "Print a description of OBJECT to STREAM-DESIGNATOR." + (let ((stream (out-synonym-of stream-designator)) + (*print-right-margin* (or *print-right-margin* 72))) ;; Until sbcl-0.8.0.x, we did ;; (FRESH-LINE STREAM) ;; (PPRINT-LOGICAL-BLOCK (STREAM NIL) @@ -34,350 +65,546 @@ ;; 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 x stream) + (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. - ) - (values)) + (values))) -;;;; miscellaneous DESCRIBE-OBJECT methods +;;;; DESCRIBE-OBJECT +;;;; +;;;; Style guide: +;;;; +;;;; * Each interesting class has a primary method of its own. +;;;; +;;;; * Output looks like +;;;; +;;;; object-self-string +;;;; [object-type-string] +;;;; +;;;; Block1: +;;;; Sublabel1: text +;;;; Sublabel2: text +;;;; +;;;; Block2: +;;;; ... +;;;; +;;;; * The newline policy that gets the whitespace right is for +;;;; each block to both start and end with a newline. -(defmethod describe-object ((x t) s) - (format s "~&~@<~S ~_is a ~S.~:>~%" x (type-of x))) +(defgeneric object-self-string (x)) -(defmethod describe-object ((x cons) s) - (call-next-method) - (when (and (legal-fun-name-p x) - (fboundp x)) - (%describe-fun (fdefinition x) s :function x) - ;;was: (format s "~@:_Its FDEFINITION is ~S.~@:_" (fdefinition x)) - ;; TO DO: should check for SETF documentation. - ;; TO DO: should make it clear whether the definition is a - ;; DEFUN (SETF FOO) or DEFSETF FOO or what. - )) +(defmethod object-self-string (x) + (prin1-to-line x)) -(defmethod describe-object ((x array) s) - (fresh-line s) - (pprint-logical-block (s nil) - (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))) - (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 object-self-string ((x symbol)) + (let ((*package* (find-package :keyword))) + (prin1-to-string x))) -(defmethod describe-object ((x hash-table) s) - (declare (type stream s)) - (format s "~&~@<~S ~_is an ~S hash table.~:>" x (hash-table-test x)) - (format s "~&Its SIZE is ~S." (hash-table-size x)) - (format s - "~&~@" - (hash-table-rehash-size x) - (hash-table-rehash-threshold x)) - (fresh-line s) - (pprint-logical-block (s nil) - (let ((count (hash-table-count x))) - (format s "It holds ~S key/value pair~:P~:[: ~2I~_~;.~]" - count (zerop count)) - (let ((n 0)) - (declare (type index n)) - (dohash ((k v) x :locked t) - (unless (zerop n) - (write-char #\space s)) - (incf n) - (when (and *print-length* (> n *print-length*)) - (format s "~:_...") - (return)) - (format s "~:_(~@<~S ~:_~S~:>)" k v))))) - (terpri s)) +(defgeneric object-type-string (x)) -(defmethod describe-object ((condition condition) s) - (sb-kernel:describe-condition condition s)) - -;;;; DESCRIBE-OBJECT methods for symbols and functions, including all -;;;; sorts of messy stuff about documentation, type information, -;;;; packaging, function implementation, etc... - -;;; Print the specified kind of documentation about the given NAME. If -;;; NAME is null, or not a valid name, then don't print anything. -(declaim (ftype (function (t stream t t) (values)) %describe-doc)) -(defun %describe-doc (name s kind kind-doc) - (when (and name (typep name '(or symbol cons))) - (let ((doc (documentation name kind))) - (when doc - (format s "~&~@(~A documentation:~)~% ~A" - (or kind-doc kind) doc)))) - (values)) +(defmethod object-type-string (x) + (let ((type (class-name-or-class (class-of x)))) + (if (symbolp type) + (string-downcase type) + (prin1-to-string type)))) -;;; Describe various stuff about the functional semantics attached to -;;; the specified NAME, if NAME is the kind of thing you can look -;;; up as a name. (In the case of anonymous closures and other -;;; things, it might not be.) TYPE-SPEC is the function type specifier -;;; extracted from the definition, or NIL if none. -(declaim (ftype (function (t stream t)) %describe-fun-name)) -(defun %describe-fun-name (name s type-spec) - (when (and name (typep name '(or symbol cons))) - (multiple-value-bind (type where) - (if (legal-fun-name-p name) - (values (type-specifier (info :function :type name)) - (info :function :where-from name)) - (values type-spec :defined)) - (when (consp type) - (format s "~&Its ~(~A~) argument types are:~% ~S" - where (second type)) - (format s "~&Its result type is:~% ~S" (third type)))) - (let ((inlinep (info :function :inlinep name))) - (when inlinep - (format s - "~&It is currently declared ~(~A~);~ - ~:[no~;~] expansion is available." - inlinep (info :function :inline-expansion-designator name)))))) - -;;; Print information from the debug-info about where CODE-OBJ was -;;; compiled from. -(defun %describe-compiled-from (code-obj s) - (declare (type stream s)) - (let ((info (sb-kernel:%code-debug-info code-obj))) - (when info - (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 source) - :style :abbreviated)) - (let ((name (sb-c::debug-source-namestring source))) - (cond (name - (format s "~&~A~@:_ Created: " name) - (format-universal-time s (sb-c::debug-source-created source))) - ((sb-di:debug-source-form source) - (format s "~& ~S" (sb-di:debug-source-form source))) - (t (bug "Don't know how to use a DEBUG-SOURCE without ~ - a namestring or a form."))))))))) - -;;; Describe a compiled function. The closure case calls us to print -;;; the guts. -(defun %describe-fun-compiled (x s kind name) - (declare (type stream s)) - (let ((args (%simple-fun-arglist x))) - (cond ((not args) - (write-string " There are no arguments." s)) - (t - (format s "~&~@(The ~@[~A's ~]arguments are:~@:_~)" kind) - (write-string " " s) - (let ((*print-pretty* t) - (*print-escape* t) - (*print-base* 10) - (*print-radix* nil)) - (pprint-logical-block (s nil) - (pprint-indent :current 2) - (format s "~A" args)))))) - (let ((name (or name (%simple-fun-name x)))) - (%describe-doc name s 'function kind) - (unless (eq kind :macro) - (%describe-fun-name name s (%simple-fun-type x)))) - (%describe-compiled-from (sb-kernel:fun-code-header x) s)) - -(defun %describe-fun (x s &optional (kind :function) (name nil)) - (etypecase x +(defmethod object-type-string ((x cons)) + (if (listp (cdr x)) "list" "cons")) + +(defmethod object-type-string ((x hash-table)) + "hash-table") + +(defmethod object-type-string ((x condition)) + "condition") + +(defmethod object-type-string ((x structure-object)) + "structure-object") + +(defmethod object-type-string ((x standard-object)) + "standard-object") + +(defmethod object-type-string ((x function)) + (typecase x + (simple-fun "compiled function") + (closure "compiled closure") #+sb-eval (sb-eval:interpreted-function - (%describe-interpreted-fun x s kind name)) - (function - (%describe-compiled-fun x s kind name)))) - -;;; Describe a function object. KIND and NAME provide some information -;;; about where the function came from. -(defun %describe-compiled-fun (x s &optional (kind :function) (name nil)) - (declare (type function x)) - (declare (type stream s)) - (declare (type (member :macro :function) kind)) - (fresh-line s) - (pprint-logical-block (s nil) - (ecase kind - (:macro (format s "Macro-function: ~S" x)) - (:function (if name - (format s "Function: ~S" x) - (format s "~S is a function." x)))) - (format s "~@:_~@" - 'function-lambda-expression - (nth-value 2 (function-lambda-expression x))) - (typecase x - (closure - (%describe-fun-compiled (%closure-fun x) s kind name) - (format s "~&Its closure environment is:") - (let ((i -1)) - (do-closure-values (value x) - (format s "~& ~S: ~S" (incf i) value)))) - (simple-fun - (%describe-fun-compiled x s kind name)) - (funcallable-instance - ;; Only STANDARD-GENERIC-FUNCTION would be handled here, but - ;; since it has its own DESCRIBE-OBJECT method, it should've been - ;; picked off before getting here. So hopefully we never get here. - (format s "~@:_It is an unknown type of funcallable instance.")) - (t - (format s "~@:_It is an unknown type of function.")))) - (terpri s)) + "interpreted function") + (generic-function + "generic-function") + (t + "funcallable-instance"))) -;; Describe an interpreted function. -#+sb-eval -(defun %describe-interpreted-fun (x s &optional (kind :function) (name nil)) - (declare (type sb-eval:interpreted-function x)) - (declare (type stream s)) - (declare (type (member :macro :function) kind)) - (fresh-line s) - (pprint-logical-block (s nil) - (ecase kind - (:macro (format s "Macro-function: ~S" x)) - (:function (if name - (format s "Function: ~S" x) - (format s "~S is a function." x)))) - (format s "~@:_~@" - 'function-lambda-expression - (nth-value 2 (function-lambda-expression x))) - (format s "~&It is an interpreted function.~%") - (let ((args (sb-eval:interpreted-function-debug-lambda-list x))) - (format s "Its lambda-list is: ") - (let ((*print-pretty* t) - (*print-escape* t) - (*print-base* 10) - (*print-radix* nil)) - (pprint-logical-block (s nil) - (pprint-indent :current 2) - (format s "~A" args))) - (format s "~&It was defined as:~% ") - (let ((*print-pretty* t) - (*print-escape* t) - (*print-base* 10) - (*print-radix* nil)) - (pprint-logical-block (s nil) - (pprint-indent :current 2) - (format s "~S" (function-lambda-expression x)))))) - (terpri s)) +(defmethod object-type-string ((x stream)) + "stream") + +(defmethod object-type-string ((x sb-gray:fundamental-stream)) + "gray stream") + +(defmethod object-type-string ((x package)) + "package") + +(defmethod object-type-string ((x array)) + (cond ((or (stringp x) (bit-vector-p x)) + (format nil "~@[simple-~*~]~A" + (typep x 'simple-array) + (typecase x + (base-string "base-string") + (string "string") + (t "bit-vector")))) + (t + (if (simple-vector-p x) + "simple-vector" + (format nil "~@[simple ~*~]~@[specialized ~*~]~:[array~;vector~]" + (typep x 'simple-array) + (neq t (array-element-type x)) + (vectorp x)))))) + +(defmethod object-type-string ((x character)) + (typecase x + (standard-char "standard-char") + (base-char "base-char") + (t "character"))) + +(declaim (ftype (function (t stream)) describe-object)) +(defgeneric describe-object (x stream)) + +(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))))) + +;;; Catch-all. +(defmethod describe-object ((x t) s) + (values)) + +(defmethod describe-object ((x cons) s) + (describe-function x nil s)) (defmethod describe-object ((x function) s) - (%describe-fun x s :function)) - -(defgeneric describe-symbol-fdefinition (function stream &key name)) - -(defmethod describe-symbol-fdefinition ((fun function) stream &key name) - (%describe-fun fun stream :function name)) - -(defmethod describe-symbol-fdefinition ((fun standard-generic-function) stream - &key name) - (declare (ignore name)) - ;; Just delegate. - (describe-object fun stream)) - -(defmethod describe-object ((x symbol) s) - (declare (type stream s)) - - ;; Describe the packaging. - (let ((package (symbol-package x))) - (if package - (multiple-value-bind (symbol status) - (find-symbol (symbol-name x) package) - (declare (ignore symbol)) - (format s "~&~@<~S is ~_an ~(~A~) symbol ~_in ~S.~:>" - x status (symbol-package x))) - (format s "~&~@<~S is ~_an uninterned symbol.~:>" x))) - ;; TO DO: We could grovel over all packages looking for and - ;; reporting other phenomena, e.g. IMPORT and SHADOW, or - ;; availability in some package even after (SYMBOL-PACKAGE X) has - ;; been set to NIL. + (describe-function nil x s)) +(defmethod describe-object ((x class) s) + (describe-class nil x s) + (describe-instance x s)) + +(defmethod describe-object ((x sb-pcl::slot-object) 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))) + +(defmethod describe-object ((x array) s) + (format s "~%Element-type: ~S" (array-element-type x)) + (if (vectorp x) + (if (array-has-fill-pointer-p x) + (format s "~%Fill-pointer: ~S~%Size: ~S" + (fill-pointer x) + (array-total-size x)) + (format s "~%Length: ~S" (length x))) + (format s "~%Dimensions: ~S" (array-dimensions x))) + (let ((*print-array* nil)) + (unless (typep x 'simple-array) + (format s "~%Adjustable: ~A" (if (adjustable-array-p x) "yes" "no")) + (multiple-value-bind (to offset) (array-displacement x) + (if (format s "~%Displaced-to: ~A~%Displaced-offset: ~S" + (prin1-to-line to) + offset) + (format s "~%Displaced: no")))) + (when (and (not (array-displacement x)) (array-header-p x)) + (format s "~%Storage vector: ~A" + (prin1-to-line (array-storage-vector 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)))) + (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)) + (format s "~%Synchronized: ~A" (if (hash-table-synchronized-p x) "yes" "no")) + (terpri s)) + +(defmethod describe-object ((symbol symbol) stream) ;; Describe the value cell. - (let* ((kind (info :variable :kind x)) + (let* ((kind (info :variable :kind symbol)) (wot (ecase kind - (:special "special variable") - (:macro "symbol macro") - (:constant "constant") - (:global "global variable") - (:unknown "undefined variable") - (:alien nil)))) - (pprint-logical-block (s nil) - (cond - ((eq kind :alien) - (let ((info (info :variable :alien-info x))) - (format s "~&~@" - (sap-int (eval (sb-alien::heap-alien-info-sap-form info))) - (sb-alien-internals:unparse-alien-type - (sb-alien::heap-alien-info-type info))) - (format s "~&~@" - (eval x)))) - ((eq kind :macro) - (let ((expansion (info :variable :macro-expansion x))) - (format s "~&It is a ~A with expansion ~S." wot expansion))) - ((boundp x) - (format s "~&~@" - wot (symbol-value x))) - ((not (eq kind :unknown)) - (format s "~&~@" wot))) - - (when (eq (info :variable :where-from x) :declared) - (format s "~&~@" - (type-specifier (info :variable :type x))))) - - (%describe-doc x s 'variable kind)) + (:special "a special variable") + (:macro "a symbol macro") + (:constant "a constant variable") + (:global "a global variable") + (:unknown "an undefined variable") + (:alien "an alien variable")))) + (when (or (not (eq :unknown kind)) (boundp symbol)) + (pprint-logical-block (stream nil) + (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)))) + (cond + ((eq kind :alien) + (let ((info (info :variable :alien-info symbol))) + (format stream "~@:_Value: ~S" (eval symbol)) + (format stream "~@:_Type: ~S" + (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)))))) + ((eq kind :macro) + (let ((expansion (info :variable :macro-expansion symbol))) + (format stream "~@:_Expansion: ~S" expansion))) + ((boundp symbol) + (format stream "~:@_Value: ~S" (symbol-value symbol))) + ((not (eq kind :unknown)) + (format stream "~:@_Currently unbound."))) + (describe-documentation symbol 'variable stream) + (terpri stream)))) - ;; Print out properties. - (format s "~@[~&Its SYMBOL-PLIST is ~@<~2I~_~S~:>.~]" (symbol-plist x)) - - ;; Describe the function cell. - (cond ((macro-function x) - (%describe-fun (macro-function x) s :macro x)) - ((special-operator-p x) - (%describe-doc x s :function "Special form")) - ((fboundp x) - (describe-symbol-fdefinition (fdefinition x) s :name x))) - - ;; Describe deftype lambda-list and doc - (when (info :type :expander x) - (format s "~&DEFTYPE lambda-list: ~A" (info :type :lambda-list x)) - (%describe-doc x s 'type "Type")) - - ;; Print other documentation. - (%describe-doc x s 'structure "Structure") - (%describe-doc x s 'setf "Setf macro") - (dolist (assoc (info :random-documentation :stuff x)) - (let ((type (car assoc))) - (format s - "~&~@" - (case type - ((optimize) "optimize quality") - (t (car assoc))) - (cdr assoc)))) - - ;; Mention the associated type information, if any. + ;; TODO: We could grovel over all packages looking for and + ;; reporting other phenomena, e.g. IMPORT and SHADOW, or + ;; availability in some package even after (SYMBOL-PACKAGE SYMBOL) has + ;; been set to NIL. ;; - ;; As of sbcl-0.7.2, (INFO :TYPE :KIND X) might be - ;; * :PRIMITIVE, which is handled by the FIND-CLASS case. - ;; * :DEFINED, which is handled specially. - ;; * :INSTANCE, which is handled by the FIND-CLASS case. - ;; * :FORTHCOMING-DEFCLASS-TYPE, which is an internal-to-the-compiler - ;; note that we don't try to report. - ;; * 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-class x nil))) - (when symbol-named-class - (format s "~&It names a class ~A." symbol-named-class) - (describe symbol-named-class s))) + ;; TODO: It might also be nice to describe (find-package symbol) + ;; if one exists. Maybe not all the exports, etc, but the package + ;; documentation. + (describe-function symbol nil stream) + (describe-class symbol nil stream) - (terpri s)) + ;; Type specifier + (let* ((kind (info :type :kind symbol)) + (fun (case kind + (:defined + (or (info :type :expander symbol) t)) + (:primitive + (or (info :type :translator symbol) t))))) + (when fun + (pprint-newline :mandatory stream) + (pprint-logical-block (stream nil) + (pprint-indent :block 2 stream) + (format stream "~A names a ~@[primitive~* ~]type-specifier:" + symbol + (eq kind :primitive)) + (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)))))) + (terpri stream))) + + ;; Print out properties. + (let ((plist (symbol-plist symbol))) + (when plist + (pprint-logical-block (stream nil) + (format stream "~%Symbol-plist:") + (pprint-indent :block 2 stream) + (sb-pcl::doplist (key value) plist + (format stream "~@:_~A -> ~A" + (prin1-to-line key :columns 2 :reserve 5) + (prin1-to-line value :columns 2 :reserve 5)))) + (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)) + +;;;; Helpers to deal with shared functionality + +(defun describe-class (name class stream) + (let* ((by-name (not class)) + (name (if class (class-name class) name)) + (class (if class class (find-class name nil)))) + (when class + (let ((metaclass-name (class-name (class-of class)))) + (pprint-logical-block (stream nil) + (when by-name + (format stream "~%~A names the ~(~A~) ~S:" + name + metaclass-name + class) + (pprint-indent :block 2 stream)) + (describe-documentation class t stream) + (when (sb-mop:class-finalized-p class) + (describe-stuff "Class precedence-list" + (mapcar #'class-name-or-class (sb-mop:class-precedence-list class)) + stream)) + (describe-stuff "Direct superclasses" + (mapcar #'class-name-or-class (sb-mop:class-direct-superclasses class)) + stream) + (let ((subs (mapcar #'class-name-or-class (sb-mop:class-direct-subclasses class)))) + (if subs + (describe-stuff "Direct subclasses" subs stream) + (format stream "~@:_No subclasses."))) + (unless (sb-mop:class-finalized-p class) + (format stream "~@:_Not yet finalized.")) + (if (eq 'structure-class metaclass-name) + (let* ((dd (find-defstruct-description name)) + (slots (dd-slots dd))) + (if slots + (format stream "~@:_Slots:~:{~@:_ ~S~ + ~@:_ Type: ~A ~@[~A~]~ + ~@:_ Initform: ~S~}" + (mapcar (lambda (dsd) + (list + (dsd-name dsd) + (dsd-type dsd) + (unless (eq t (dsd-raw-type dsd)) + "(unboxed)") + (dsd-default dsd))) + slots)) + (format stream "~@:_No slots."))) + (let ((slots (sb-mop:class-direct-slots class))) + (if slots + (format stream "~@:_Direct slots:~:{~@:_ ~S~ + ~@[~@:_ Type: ~S~]~ + ~@[~@:_ Allocation: ~S~]~ + ~@[~@:_ Initargs: ~{~S~^, ~}~]~ + ~@[~@:_ Initform: ~S~]~ + ~@[~@:_ Readers: ~{~S~^, ~}~]~ + ~@[~@:_ Writers: ~{~S~^, ~}~]~ + ~@[~@:_ Documentation:~@:_ ~@<~@;~A~:>~]~}" + (mapcar (lambda (slotd) + (list (sb-mop:slot-definition-name slotd) + (let ((type (sb-mop:slot-definition-type slotd))) + (unless (eq t type) type)) + (let ((alloc (sb-mop:slot-definition-allocation slotd))) + (unless (eq :instance alloc) alloc)) + (sb-mop:slot-definition-initargs slotd) + (sb-mop:slot-definition-initform slotd) + (sb-mop:slot-definition-readers slotd) + (sb-mop:slot-definition-writers slotd) + ;; FIXME: does this get the prefix right? + (quiet-doc slotd t))) + slots)) + (format stream "~@:_No direct slots.")))) + (pprint-newline :mandatory stream)))))) + +(defun describe-instance (object stream) + (let* ((class (class-of object)) + (slotds (sb-mop:class-slots class)) + (max-slot-name-length 0) + (plist nil)) + + ;; Figure out a good width for the slot-name column. + (flet ((adjust-slot-name-length (name) + (setf max-slot-name-length + (max max-slot-name-length (length (symbol-name name)))))) + (dolist (slotd slotds) + (adjust-slot-name-length (sb-mop:slot-definition-name slotd)) + (push slotd (getf plist (sb-mop:slot-definition-allocation slotd)))) + (setf max-slot-name-length (min (+ max-slot-name-length 3) 30))) + + ;; Now that we know the width, we can print. + (flet ((describe-slot (name value) + (format stream "~% ~A~VT = ~A" name max-slot-name-length + (prin1-to-line value)))) + (sb-pcl::doplist (allocation slots) plist + (format stream "~%Slots with ~S allocation:" allocation) + (dolist (slotd (nreverse slots)) + (describe-slot + (sb-mop:slot-definition-name slotd) + (sb-pcl::slot-value-or-default object (sb-mop:slot-definition-name slotd)))))) + (unless slotds + (format stream "~@:_No slots.")) + (terpri stream))) + +(defun quiet-doc (object type) + (handler-bind ((warning #'muffle-warning)) + (documentation object type))) + +(defun describe-documentation (object type stream &optional undoc newline) + (let ((doc (quiet-doc object type))) + (cond (doc + (format stream "~@:_Documentation:~@:_") + (pprint-logical-block (stream nil :per-line-prefix " ") + (princ doc stream))) + (undoc + (format stream "~@:_(undocumented)"))) + (when newline + (pprint-newline :mandatory stream)))) + +(defun describe-stuff (label list stream &key (escape t)) + (when list + (if escape + (format stream "~@:_~A:~@<~;~{ ~S~^,~:_~}~;~:>" label list) + (format stream "~@:_~A:~@<~;~{ ~A~^,~:_~}~;~:>" label list)))) + +(defun describe-lambda-list (lambda-list stream) + (format stream "~@:_Lambda-list: ~:A" lambda-list)) + +(defun describe-function-source (function stream) + (if (compiled-function-p function) + (let* ((code (fun-code-header (%fun-fun function))) + (info (sb-kernel:%code-debug-info code))) + (when info + (let ((source (sb-c::debug-info-source info))) + (when source + (let ((namestring (sb-c::debug-source-namestring source))) + ;; This used to also report the times the source was created + ;; and compiled, but that seems more like noise than useful + ;; information -- but FWIW that are to be had as + ;; SB-C::DEBUG-SOUCE-CREATED/COMPILED. + (cond (namestring + (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-eval + (let ((source (sb-eval:interpreted-function-source-location function))) + (when source + (let ((namestring (sb-c:definition-source-location-namestring source))) + (when namestring + (format stream "~@:_Source file: ~A" namestring))))))) + +(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) + (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))))))))) + (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))))) + (unless function + (awhen (and (legal-fun-name-p name) (compiler-macro-function name)) + (pprint-logical-block (stream nil) + (format stream "~@:_~A has a compiler-macro:" name) + (pprint-indent :block 2 stream) + (describe-documentation it t stream) + (describe-function-source it stream)) + (terpri stream)) + (when (and (consp name) (eq 'setf (car name)) (not (cddr name))) + (let* ((name2 (second name)) + (inverse (info :setf :inverse name2)) + (expander (info :setf :expander name2))) + (cond (inverse + (pprint-logical-block (stream nil) + (format stream "~&~A has setf-expansion: ~S" + name inverse) + (pprint-indent :block 2 stream) + (describe-documentation name2 'setf stream)) + (terpri stream)) + (expander + (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)) + (terpri stream))))) + (when (symbolp name) + (describe-function `(setf ,name) nil stream)))) diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index d9403c2..e8480f1 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -47,13 +47,15 @@ (parse-body body :doc-string-allowed nil) `(progn (!cold-init-forms - (setf (info :type :translator ',name) - (lambda (,whole) - (block ,name - (destructuring-bind ,wholeless-arglist - (rest ,whole) ; discarding NAME - ,@decls - ,@forms))))) + (let ((fun (lambda (,whole) + (block ,name + (destructuring-bind ,wholeless-arglist + (rest ,whole) ; discarding NAME + ,@decls + ,@forms))))) + #-sb-xc-host + (setf (%simple-fun-arglist (the simple-fun fun)) ',wholeless-arglist) + (setf (info :type :translator ',name) fun))) ',name)))) ;;; DEFVARs for these come later, after we have enough stuff defined. diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 37149cf..fc6f1c4 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -159,13 +159,7 @@ "SRC;CODE;PROFILE" "SRC;CODE;NTRACE" "SRC;CODE;STEP" - "SRC;CODE;RUN-PROGRAM" - - ;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT - ;; facility is still used in our ANSI DESCRIBE - ;; facility, and should be compiled and loaded after - ;; our DESCRIBE facility is compiled and loaded. - "SRC;PCL;DESCRIBE")) + "SRC;CODE;RUN-PROGRAM")) (let ((fullname (concatenate 'string "SYS:" stem ".LISP"))) (sb-int:/show "about to compile" fullname) diff --git a/src/compiler/compiler-deftype.lisp b/src/compiler/compiler-deftype.lisp index 6427570..3e04e67 100644 --- a/src/compiler/compiler-deftype.lisp +++ b/src/compiler/compiler-deftype.lisp @@ -50,8 +50,8 @@ ;; ### Bootstrap hack -- we need to define types before %NOTE-TYPE-DEFINED ;; is defined. (FIXME: Do we still need to do this? -- WHN 19990310) (if (fboundp 'sb!c::%note-type-defined) - (sb!c::%note-type-defined name) - (warn "defining type before %NOTE-TYPE-DEFINED is defined")) + (sb!c::%note-type-defined name) + (warn "defining type before %NOTE-TYPE-DEFINED is defined")) name) (/show0 "compiler-deftype.lisp end of file") diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index b188592..00d78a0 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -778,7 +778,9 @@ (print-unreadable-object (s stream :type t)))) (:copier nil)) ;; the UT that compilation started at - (start-time (get-internal-real-time) :type unsigned-byte) + (start-time (get-internal-real) :type unsigned-byte) + ;; the IRT that compilation started at + (start-real-time (get-internal-real-time) :type unsigned-byte) ;; the FILE-INFO structure for this compilation (file-info nil :type (or file-info null)) ;; the stream that we are using to read the FILE-INFO, or NIL if @@ -1654,7 +1656,7 @@ won (elapsed-time-to-string (- (get-internal-real-time) - (source-info-start-time source-info)))) + (source-info-start-real-time source-info)))) (values)) ;;; Open some files and call SUB-COMPILE-FILE. If something unwinds diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp deleted file mode 100644 index c727c43..0000000 --- a/src/pcl/describe.lisp +++ /dev/null @@ -1,156 +0,0 @@ -;;;; that part of the DESCRIBE mechanism which is based on code from -;;;; PCL - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. - -;;;; This software is derived from software originally released by Xerox -;;;; Corporation. Copyright and release statements follow. Later modifications -;;;; to the software are in the public domain and are provided with -;;;; absolutely no warranty. See the COPYING and CREDITS files for more -;;;; information. - -;;;; copyright information from original PCL sources: -;;;; -;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. -;;;; All rights reserved. -;;;; -;;;; Use and copying of this software and preparation of derivative works based -;;;; upon this software are permitted. Any distribution of this software or -;;;; derivative works must comply with all applicable United States export -;;;; control laws. -;;;; -;;;; This software is made available AS IS, and Xerox Corporation makes no -;;;; warranty about the software, its performance or its conformity to any -;;;; specification. - -(in-package "SB-PCL") - -(defmethod slots-to-inspect ((class slot-class) (object slot-object)) - (class-slots class)) - -(defmethod describe-object ((object slot-object) stream) - - (fresh-line stream) - - (let* ((class (class-of object)) - (slotds (slots-to-inspect class object)) - (max-slot-name-length 0) - (instance-slotds ()) - (class-slotds ()) - (other-slotds ())) - - (format stream "~&~@<~S ~_is an instance of class ~S.~:>" object class) - - ;; Figure out a good width for the slot-name column. - (flet ((adjust-slot-name-length (name) - (setq max-slot-name-length - (max max-slot-name-length - (length (the string (symbol-name name))))))) - (dolist (slotd slotds) - (adjust-slot-name-length (slot-definition-name slotd)) - (case (slot-definition-allocation slotd) - (:instance (push slotd instance-slotds)) - (:class (push slotd class-slotds)) - (otherwise (push slotd other-slotds)))) - (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))) - - ;; Now that we know the width, we can print. - (flet ((describe-slot (name value &optional (allocation () alloc-p)) - (if alloc-p - (format stream - "~& ~A ~S ~VT ~S" - name allocation (+ max-slot-name-length 7) value) - (format stream - "~& ~A~VT ~S" - name max-slot-name-length value)))) - (when instance-slotds - (format stream "~&The following slots have :INSTANCE allocation:") - (dolist (slotd (nreverse instance-slotds)) - (describe-slot - (slot-definition-name slotd) - (slot-value-or-default object - (slot-definition-name slotd))))) - (when class-slotds - (format stream "~&The following slots have :CLASS allocation:") - (dolist (slotd (nreverse class-slotds)) - (describe-slot - (slot-definition-name slotd) - (slot-value-or-default object - (slot-definition-name slotd))))) - (when other-slotds - (format stream "~&The following slots have allocation as shown:") - (dolist (slotd (nreverse other-slotds)) - (describe-slot - (slot-definition-name slotd) - (slot-value-or-default object - (slot-definition-name slotd)) - (slot-definition-allocation slotd)))))) - - (terpri stream)) - -(defmethod describe-object ((fun standard-generic-function) stream) - (format stream "~&~A is a generic function." fun) - (when (documentation fun t) - (format stream "~&Its documentation is: ~A" (documentation fun t))) - (format stream "~&Its lambda-list is:~& ~S" - (generic-function-pretty-arglist fun)) - (format stream "~&Its method-combination is:~& ~S" - (generic-function-method-combination fun)) - (let ((methods (generic-function-methods fun))) - (if (null methods) - (format stream "~&It has no methods.~%") - (let ((gf-name (generic-function-name fun))) - (format stream "~&Its methods are:") - (dolist (method methods) - (format stream "~& (~A ~{~S ~}~:S)~%" - gf-name - (method-qualifiers method) - (unparse-specializers fun (method-specializers method))) - (when (documentation method t) - (format stream "~& Method documentation: ~A" - (documentation method t)))))))) - -(defmethod describe-object ((class class) stream) - (flet ((pretty-class (c) (or (class-name c) c))) - (macrolet ((ft (string &rest args) `(format stream ,string ,@args))) - (ft "~&~@<~S is a class. It is an instance of ~S.~:@>" - class (pretty-class (class-of class))) - (let ((name (class-name class))) - (if name - (if (eq class (find-class name nil)) - (ft "~&~@" name) - (ft "~&~@" - name)) - (ft "~&~@"))) - (ft "~&~@~%" - (mapcar #'pretty-class (class-direct-superclasses class)) - (mapcar #'pretty-class (class-direct-subclasses class)) - (class-finalized-p class) - (mapcar #'pretty-class (cpl-or-nil class)) - (length (specializer-direct-methods class)))))) - -(defmethod describe-object ((package package) stream) - (format stream "~&~S is a ~S." package (type-of package)) - (format stream - "~@[~&~@~]" - (package-nicknames package)) - (format stream - "~&It has ~S internal and ~S external symbols." - (package-internal-symbol-count package) - (package-external-symbol-count package)) - (flet (;; Turn a list of packages into something a human likes - ;; to read. - (humanize (package-list) - (sort (mapcar #'package-name package-list) #'string<))) - (format stream - "~@[~&~@~]" - (humanize (package-use-list package))) - (format stream - "~@[~&~@~]" - (humanize (package-used-by-list package)))) - (terpri stream)) diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp index e1b7b56..d5d4eb2 100644 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -205,7 +205,7 @@ ;;; default if DOC-TYPE doesn't match one of the specified types (defmethod documentation (object doc-type) - (warn "unsupported DOCUMENTATION: type ~S for object ~S" + (warn "unsupported DOCUMENTATION: type ~S for object of type ~S" doc-type (type-of object)) nil) diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp index cdec390..3be4ec4 100644 --- a/tests/interface.impure.lisp +++ b/tests/interface.impure.lisp @@ -113,15 +113,17 @@ (let ((s (with-output-to-string (s) (write-char #\x s) (describe i s)))) - (unless (and (char= #\x (char s 0)) - ;; one leading #\NEWLINE from FRESH-LINE or the like, no more - (char= #\newline (char s 1)) - (char/= #\newline (char s 2)) - ;; one trailing #\NEWLINE from TERPRI or the like, no more - (let ((n (length s))) - (and (char= #\newline (char s (- n 1))) - (char/= #\newline (char s (- n 2)))))) - (error "misbehavior in DESCRIBE of ~S" i)))) + (macrolet ((check (form) + `(or ,form + (error "misbehavior in DESCRIBE of ~S:~% ~S" i ',form)))) + (check (char= #\x (char s 0))) + ;; one leading #\NEWLINE from FRESH-LINE or the like, no more + (check (char= #\newline (char s 1))) + (check (char/= #\newline (char s 2))) + ;; one trailing #\NEWLINE from TERPRI or the like, no more + (let ((n (length s))) + (check (char= #\newline (char s (- n 1)))) + (check (char/= #\newline (char s (- n 2)))))))) ;;; Tests of documentation on types and classes diff --git a/version.lisp-expr b/version.lisp-expr index 1646dcc..467aa95 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.29.37" +"1.0.29.38"