From: William Harold Newman Date: Mon, 2 Jun 2003 22:12:04 +0000 (+0000) Subject: 0.8.0.27: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=648b48d2406f6d6f2bf341bf8ed350aac85398d0;p=sbcl.git 0.8.0.27: redid DESCRIBE and DESCRIBE-OBJECT newlining/freshlining to be consistent with each other (so e.g. we don't get multiple leading newlines when DESCRIBEing an instance of STRUCTURE-OBJECT) and to conform to ANSI spec with minimal surprise: ...DEFUN DESCRIBE now longer FRESH-LINEs. ...DEFUN DESCRIBE no longer does PPRINT-LOGICAL-BLOCK, either, since FRESH-LINE inside PP-L-B can make a mess. ...DESCRIBE-OBJECT methods consistently do FRESH-LINEs, as in the spec example, and if they use the prettyprinter, they create their own PPRINT-LOGICAL-BLOCKs. (No, this style -- coders paid by the line, mixing high level CLOS dispatch with low-level physical output bypassing the pretty-printer -- is not the way that I would have specified the behavior, but I was still programming in C and C++ when the spec was written, and no one asked me.) deleted *DESCRIBE-METAOBJECTS-AS-OBJECTS-P*, since its output is so messy I doubt people want to use it (and if I'm wrong the implementation is trivial to restore, with the only trickiness being figuring out a decent interface to support) added warning for the unwary/unwise in SB-BSD-SOCKETS docs --- diff --git a/NEWS b/NEWS index 06d28cf..b8d55ae 100644 --- a/NEWS +++ b/NEWS @@ -1766,7 +1766,7 @@ changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0 not a COMPILER-ERROR (followed by some other strange error on choosing the CONTINUE restart). * bug fix: make.sh and friends are now more consistent in the way that - they for GNU "make". + they look for GNU "make". changes in sbcl-0.8.1 relative to sbcl-0.8.0: * minor incompatible change: some nonsensical specialized lambda @@ -1787,6 +1787,10 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: * STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE now have methods defined on the relevant FUNDAMENTAL-BINARY-{INPUT,OUTPUT}-STREAM classes. (thanks to Antonio Martinez) + * improved ANSIness in DESCRIBE: The DESCRIBE function no longer + outputs FRESH-LINE or TERPRI, and no longer converts its stream + argument to a pretty-print stream. Instead, it leaves any such + operations to DESCRIBE-OBJECT methods. * bug fix: APROPOS now respects the EXTERNAL-ONLY flag. (reported by Teemu Kalvas) * bug fix: NIL is now a valid destructuring argument in DEFMACRO diff --git a/contrib/sb-bsd-sockets/api-reference.html b/contrib/sb-bsd-sockets/api-reference.html index 3651a60..94bb89d 100644 --- a/contrib/sb-bsd-sockets/api-reference.html +++ b/contrib/sb-bsd-sockets/api-reference.html @@ -1,4 +1,15 @@ db-sockets API Reference + + +

Package SOCKETS

diff --git a/contrib/sb-bsd-sockets/doc.lisp b/contrib/sb-bsd-sockets/doc.lisp index fa7a482..b4ecd69 100644 --- a/contrib/sb-bsd-sockets/doc.lisp +++ b/contrib/sb-bsd-sockets/doc.lisp @@ -219,7 +219,13 @@ symbols exported from PACKAGE" (defun start () (with-open-file (*standard-output* "index.html" :direction :output) (format t "SBCL BSD-Sockets API Reference~%") - (asdf:operate 'asdf:load-op 'sb-bsd-sockets) - (document-system 'sb-bsd-sockets :package :sb-bsd-sockets))) + (format t +" +") + (asdf:operate 'asdf:load-op 'sb-bsd-sockets) + (document-system 'sb-bsd-sockets :package :sb-bsd-sockets))) (start) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index d76500f..257360b 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -526,7 +526,7 @@ ;;; methods) (defun describe-condition (condition stream) (format stream - "~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>" + "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%" condition (type-of condition) (concatenate 'list diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 252f264..cdbfb36 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -1,4 +1,4 @@ -;;;; most of the DESCRIBE mechanism -- that part which isn't derived +;;;; most of the DESCRIBE system -- that part which isn't derived ;;;; from PCL code ;;;; This software is part of the SBCL system. See the README file for @@ -19,16 +19,32 @@ #+sb-doc "Print a description of the object X." (let ((stream (out-synonym-of stream-designator))) - (fresh-line stream) - (pprint-logical-block (stream nil) - (describe-object x stream) - (pprint-newline :mandatory stream))) + ;; Until sbcl-0.8.0.x, we did + ;; (FRESH-LINE STREAM) + ;; (PPRINT-LOGICAL-BLOCK (STREAM NIL) + ;; ... + ;; here. However, ANSI's specification of DEFUN DESCRIBE, + ;; DESCRIBE exists as an interface primarily to manage argument + ;; defaulting (including conversion of arguments T and NIL into + ;; stream objects) and to inhibit any return values from + ;; DESCRIBE-OBJECT. + ;; doesn't mention either FRESH-LINEing or PPRINT-LOGICAL-BLOCKing, + ;; and the example of typical DESCRIBE-OBJECT behavior in ANSI's + ;; specification of DESCRIBE-OBJECT will work poorly if we do them + ;; 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) + ;; 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)) ;;;; miscellaneous DESCRIBE-OBJECT methods (defmethod describe-object ((x t) s) - (format s "~@<~S ~_is a ~S.~:>" x (type-of x))) + (format s "~&~@<~S ~_is a ~S.~:>~%" x (type-of x))) (defmethod describe-object ((x cons) s) (call-next-method) @@ -42,53 +58,61 @@ )) (defmethod describe-object ((x array) s) - (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))))) - (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)))) + (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))))) + (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)))) + (terpri s)) (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 "~&~@<~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)) - (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) - (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))))) + (fresh-line) + (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) + (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)) (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.. +;;;; 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. @@ -97,7 +121,7 @@ (when (and name (typep name '(or symbol cons))) (let ((doc (fdocumentation name kind))) (when doc - (format s "~_~@(~A documentation:~)~@:_ ~A" + (format s "~&~@(~A documentation:~)~% ~A" (or kind-doc kind) doc)))) (values)) @@ -115,13 +139,13 @@ (info :function :where-from name)) (values type-spec :defined)) (when (consp type) - (format s "~@:_Its ~(~A~) argument types are:~@:_ ~S" + (format s "~&Its ~(~A~) argument types are:~% ~S" where (second type)) - (format s "~@:_Its result type is:~@:_ ~S" (third 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~);~ + "~&It is currently declared ~(~A~);~ ~:[no~;~] expansion is available." inlinep (info :function :inline-expansion-designator name)))))) @@ -133,7 +157,7 @@ (when info (let ((sources (sb-c::debug-info-source info))) (when sources - (format s "~@:_On ~A it was compiled from:" + (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. @@ -145,10 +169,10 @@ (let ((name (sb-c::debug-source-name source))) (ecase (sb-c::debug-source-from source) (:file - (format s "~@:_~A~@:_ Created: " (namestring name)) + (format s "~&~A~@:_ Created: " (namestring name)) (format-universal-time s (sb-c::debug-source-created source))) - (:lisp (format s "~@:_~S" name)))))))))) + (:lisp (format s "~&~S" name)))))))))) ;;; Describe a compiled function. The closure case calls us to print ;;; the guts. @@ -158,7 +182,7 @@ (cond ((not args) (write-string " There are no arguments." s)) (t - (format s "~@:_~@(The ~@[~A's ~]arguments are:~@:_~)" kind) + (format s "~&~@(The ~@[~A's ~]arguments are:~@:_~)" kind) (write-string " " s) (let ((*print-pretty* t) (*print-escape* t) @@ -180,31 +204,33 @@ (declare (type stream s)) (declare (type (member :macro :function) kind)) (fresh-line s) - (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 - (%fun-name x)) - (case (widetag-of x) - (#.sb-vm:closure-header-widetag - (%describe-fun-compiled (%closure-fun x) s kind name) - (format s "~@:_Its closure environment is:") - (pprint-logical-block (s nil) - (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) - (%describe-fun-compiled x s kind name)) - (#.sb-vm:funcallable-instance-header-widetag - ;; 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.")))) + (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 + (%fun-name x)) + (case (widetag-of x) + (#.sb-vm:closure-header-widetag + (%describe-fun-compiled (%closure-fun x) s kind name) + (format s "~@:_Its closure environment is:") + (pprint-logical-block (s nil) + (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) + (%describe-fun-compiled x s kind name)) + (#.sb-vm:funcallable-instance-header-widetag + ;; 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)) (defmethod describe-object ((x function) s) (%describe-fun x s :function)) @@ -217,7 +243,7 @@ (defmethod describe-symbol-fdefinition ((fun standard-generic-function) stream &key name) (declare (ignore name)) - ;; just delegate + ;; Just delegate. (describe-object fun stream)) (defmethod describe-object ((x symbol) s) @@ -229,9 +255,9 @@ (multiple-value-bind (symbol status) (find-symbol (symbol-name x) package) (declare (ignore symbol)) - (format s "~@<~S is ~_an ~(~A~) symbol ~_in ~S.~:>" + (format s "~&~@<~S is ~_an ~(~A~) symbol ~_in ~S.~:>" x status (symbol-package x))) - (format s "~@<~S is ~_an uninterned symbol.~:>" 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 @@ -241,36 +267,37 @@ (let* ((kind (info :variable :kind x)) (wot (ecase kind (:special "special variable") - (:macro "symbol macro") + (:macro "symbol macro") (:constant "constant") (:global "undefined variable") (:alien 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 :global)) - (format s "~@:_~@" wot))) + (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 :global)) + (format s "~&~@" wot))) - (when (eq (info :variable :where-from x) :declared) - (format s "~@:_~@" - (type-specifier (info :variable :type x)))) + (when (eq (info :variable :where-from x) :declared) + (format s "~&~@" + (type-specifier (info :variable :type x))))) (%describe-doc x s 'variable kind)) ;; Print out properties. - (format s "~@[~@:_Its SYMBOL-PLIST is ~@<~2I~_~S~:>.~]" (symbol-plist x)) + (format s "~@[~&Its SYMBOL-PLIST is ~@<~2I~_~S~:>.~]" (symbol-plist x)) ;; Describe the function cell. (cond ((macro-function x) @@ -278,7 +305,7 @@ ((special-operator-p x) (%describe-doc x s :function "Special form")) ((fboundp x) - (describe-symbol-fdefinition (fdefinition x) s :name x))) + (describe-symbol-fdefinition (fdefinition x) s :name x))) ;; Print other documentation. (%describe-doc x s 'structure "Structure") @@ -286,7 +313,7 @@ (%describe-doc x s 'setf "Setf macro") (dolist (assoc (info :random-documentation :stuff x)) (format s - "~@:_Documentation on the ~(~A~):~@:_~A" + "~&~@" (car assoc) (cdr assoc))) @@ -300,8 +327,10 @@ ;; 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.")) + (format s "~&It names a type specifier.")) (let ((symbol-named-class (find-classoid x nil))) (when symbol-named-class - (format s "~@:_It names a class ~A." symbol-named-class) - (describe symbol-named-class s)))) + (format s "~&It names a class ~A." symbol-named-class) + (describe symbol-named-class s))) + + (terpri s)) diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp index dc49e92..e9ae2a4 100644 --- a/src/pcl/describe.lisp +++ b/src/pcl/describe.lisp @@ -31,6 +31,8 @@ (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) @@ -38,118 +40,114 @@ (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)))))) - (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)))) - - ;; Figure out a good width for the slot-name column. + (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)) - (format stream "~&~@<~S ~_is an instance of class ~S.~:>" object class) + (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))) - ;; Now that we know the width, we can print. + ;; 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:") + (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:") + (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:") + (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))))))) + (slot-definition-allocation slotd)))))) -(defvar *describe-metaobjects-as-objects-p* nil) + (terpri stream)) (defmethod describe-object ((fun standard-generic-function) stream) - (format stream "~&~A is a generic function.~%" fun) - (format stream "Its arguments are:~% ~S~%" + (format stream "~&~A is a generic function." fun) + (format stream "~&Its arguments are:~& ~S" (generic-function-pretty-arglist fun)) (let ((methods (generic-function-methods fun))) (if (null methods) - (format stream "It has no methods.~%") + (format stream "~&It has no methods.~%") (let ((gf-name (generic-function-name fun))) (format stream "Its methods are:") (dolist (method methods) - (format stream "~2% (~A ~{~S ~}~:S) =>~%" + (format stream "~2% (~A ~{~S ~}~:S) =>" gf-name (method-qualifiers method) (unparse-specializers method)) - (describe-object (or (method-fast-function method) - (method-function method)) - stream))))) - (when *describe-metaobjects-as-objects-p* - (call-next-method))) + (describe (or (method-fast-function method) + (method-function method)) + stream)))))) (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.~%" + (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 "Its proper name is ~S.~%" name) - (ft "Its name is ~S, but this is not a proper name.~%" name)) + (ft "~&Its proper name is ~S." name) + (ft "~&Its name is ~S, but this is not a proper name." name)) (ft "It has no name (the name is NIL).~%"))) - (ft "The direct superclasses are: ~:S, and the direct~%~ - subclasses are: ~:S. The class precedence list is:~%~S~%~ - There are ~W methods specialized for this class." + (ft "~&~@~%" (mapcar #'pretty-class (class-direct-superclasses class)) (mapcar #'pretty-class (class-direct-subclasses class)) (mapcar #'pretty-class (class-precedence-list class)) - (length (specializer-direct-methods class))))) - (when *describe-metaobjects-as-objects-p* - (call-next-method))) + (length (specializer-direct-methods class)))))) (defmethod describe-object ((package package) stream) - (pprint-logical-block (stream nil) - (format stream "~&~S is a ~S." package (type-of package)) + (format stream "~&~S is a ~S." package (type-of package)) + (format stream + "~@[~&~@~]" + (package-nicknames package)) + (let* ((internal (package-internal-symbols package)) + (internal-count (- (package-hashtable-size internal) + (package-hashtable-free internal))) + (external (package-external-symbols package)) + (external-count (- (package-hashtable-size external) + (package-hashtable-free external)))) + (format stream + "~&It has ~S internal and ~S external symbols." + internal-count external-count)) + (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 - "~@[~&It has nicknames ~2I~{~:_~S~^ ~}~]" - (package-nicknames package)) - (let* ((internal (package-internal-symbols package)) - (internal-count (- (package-hashtable-size internal) - (package-hashtable-free internal))) - (external (package-external-symbols package)) - (external-count (- (package-hashtable-size external) - (package-hashtable-free external)))) - (format stream - "~&It has ~S internal and ~S external symbols." - internal-count external-count)) - (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 - "~@[~&It uses packages named ~2I~{~:_~S~^ ~}~]" - (humanize (package-use-list package))) - (format stream - "~@[~&It is used by packages named ~2I~{~:_~S~^ ~}~]" - (humanize (package-used-by-list package)))))) + "~@[~&~@~]" + (humanize (package-used-by-list package)))) + (terpri stream)) diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp index c84cc63..76171e0 100644 --- a/tests/interface.pure.lisp +++ b/tests/interface.pure.lisp @@ -42,6 +42,47 @@ (describe #(1 2 3)) (describe #2a((1 2) (3 4))) +;;; support for DESCRIBE tests +(defstruct to-be-described a b) + +;;; DESCRIBE should run without signalling an error. +(describe (make-to-be-described)) +(describe 12) +(describe "a string") +(describe 'symbolism) +(describe (find-package :cl)) +(describe '(a list)) +(describe #(a vector)) + +;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do +;;; FRESH-LINE and TERPRI neatly. +(dolist (i (list (make-to-be-described :a 14) 12 "a string" + #0a0 #(1 2 3) #2a((1 2) (3 4)) 'sym :keyword + (find-package :keyword) (list 1 2 3) + nil (cons 1 2) (make-hash-table) + (let ((h (make-hash-table))) + (setf (gethash 10 h) 100 + (gethash 11 h) 121) + h) + (make-condition 'simple-error) + (make-condition 'simple-error :format-control "fc") + #'car #'make-to-be-described (lambda (x) (+ x 11)) + (constantly 'foo) #'(setf to-be-described-a) + #'describe-object (find-class 'to-be-described) + (find-class 'cons))) + (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)))) + ;;; TYPEP, SUBTYPEP, UPGRADED-ARRAY-ELEMENT-TYPE and ;;; UPGRADED-COMPLEX-PART-TYPE should be able to deal with NIL as an ;;; environment argument @@ -55,3 +96,4 @@ ;;; DECLARE should not be a special operator (assert (not (special-operator-p 'declare))) + diff --git a/tests/smoke.impure.lisp b/tests/smoke.impure.lisp index b155ff7..ee750cd 100644 --- a/tests/smoke.impure.lisp +++ b/tests/smoke.impure.lisp @@ -19,16 +19,6 @@ (room t) (room nil) -;;; DESCRIBE should run without signalling an error. -(defstruct to-be-described a b) -(describe (make-to-be-described)) -(describe 12) -(describe "a string") -(describe 'symbolism) -(describe (find-package :cl)) -(describe '(a list)) -(describe #(a vector)) - ;;; COPY-SYMBOL should work without signalling an error, even if the ;;; symbol is unbound. (copy-symbol 'foo)