/[cmucl]/src/pcl/env.lisp
ViewVC logotype

Diff of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.26 by gerd, Wed Jun 18 09:23:09 2003 UTC revision 1.26.48.2 by rtoy, Sat Feb 13 01:28:04 2010 UTC
# Line 32  Line 32 
32  ;;;  ;;;
33    
34  (in-package :pcl)  (in-package :pcl)
35    (intl:textdomain "cmucl")
36    
37  ;;;  ;;;
38  ;;;  ;;;
# Line 77  Line 78 
78            (:class    (push slotd class-slotds))            (:class    (push slotd class-slotds))
79            (otherwise (push slotd other-slotds))))            (otherwise (push slotd other-slotds))))
80        (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))        (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
81        (format stream "~%~S is an instance of class ~S:" object class)        (format stream _"~%~S is an instance of class ~S:" object class)
82    
83        (when instance-slotds        (when instance-slotds
84          (format stream "~% The following slots have :INSTANCE allocation:")          (format stream _"~% The following slots have :INSTANCE allocation:")
85          (dolist (slotd (nreverse instance-slotds))          (dolist (slotd (nreverse instance-slotds))
86            (describe-slot (slot-definition-name slotd)            (describe-slot (slot-definition-name slotd)
87                           (slot-value-or-default object (slot-definition-name slotd)))))                           (slot-value-or-default object (slot-definition-name slotd)))))
88    
89        (when class-slotds        (when class-slotds
90          (format stream "~% The following slots have :CLASS allocation:")          (format stream _"~% The following slots have :CLASS allocation:")
91          (dolist (slotd (nreverse class-slotds))          (dolist (slotd (nreverse class-slotds))
92            (describe-slot (slot-definition-name slotd)            (describe-slot (slot-definition-name slotd)
93                           (slot-value-or-default object (slot-definition-name slotd)))))                           (slot-value-or-default object (slot-definition-name slotd)))))
94    
95        (when other-slotds        (when other-slotds
96          (format stream "~% The following slots have allocation as shown:")          (format stream _"~% The following slots have allocation as shown:")
97          (dolist (slotd (nreverse other-slotds))          (dolist (slotd (nreverse other-slotds))
98            (describe-slot (slot-definition-name slotd)            (describe-slot (slot-definition-name slotd)
99                           (slot-value-or-default object (slot-definition-name slotd))                           (slot-value-or-default object (slot-definition-name slotd))
# Line 112  Line 113 
113                      elt)))                      elt)))
114    
115  (defmethod describe-object ((gf standard-generic-function) stream)  (defmethod describe-object ((gf standard-generic-function) stream)
116    (format stream "~A is a generic function.~%" gf)    (format stream _"~A is a generic function.~%" gf)
117    (let* ((gf-name (generic-function-name gf))    (let* ((gf-name (generic-function-name gf))
118           (doc (documentation gf-name 'function)))           (doc (documentation gf-name 'function)))
119      (format stream "Its lambda-list is:~%  ~S~%"      (format stream _"Its lambda-list is:~%  ~S~%"
120              (generic-function-lambda-list gf))              (generic-function-lambda-list gf))
121      (when doc      (when doc
122        (format stream "Generic function documentation:~%  ~s~%" doc))        (format stream _"Generic function documentation:~%  ~s~%" doc))
123      (format stream "Its methods are:~%")      (format stream _"Its methods are:~%")
124      (loop for method in (generic-function-methods gf) and i from 1      (loop for method in (generic-function-methods gf) and i from 1
125            as doc = (plist-value method 'documentation) do            as doc = (plist-value method 'documentation) do
126              (format stream "  ~d: ~a ~@[~{~s ~}~]~:s~%"              (format stream "  ~d: ~a ~@[~{~s ~}~]~:s~%"
127                      i gf-name (method-qualifiers method)                      i gf-name (method-qualifiers method)
128                      (method-specialized-lambda-list method))                      (method-specialized-lambda-list method))
129              (when doc              (when doc
130                (format stream "    Method documentation: ~s~%" doc)))                (format stream _"    Method documentation: ~s~%" doc)))
131      (when *describe-metaobjects-as-objects-p*      (when *describe-metaobjects-as-objects-p*
132        (call-next-method))))        (call-next-method))))
133    
# Line 136  Line 137 
137  (defmethod describe-object ((class class) stream)  (defmethod describe-object ((class class) stream)
138    (flet ((pretty-class (c) (or (class-name c) c)))    (flet ((pretty-class (c) (or (class-name c) c)))
139      (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))      (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
140        (ft "~&~@<~S is a class, it is an instance of ~S.~@:>~%"        (ft _"~&~@<~S is a class, it is an instance of ~S.~@:>~%"
141            class (pretty-class (class-of class)))            class (pretty-class (class-of class)))
142        (let ((name (class-name class)))        (let ((name (class-name class)))
143          (if name          (if name
144              (if (eq class (find-class name nil))              (if (eq class (find-class name nil))
145                  (ft "Its proper name is ~S.~%" name)                  (ft _"Its proper name is ~S.~%" name)
146                  (ft "Its name is ~S, but this is not a proper name.~%" name))                  (ft _"Its name is ~S, but this is not a proper name.~%" name))
147              (ft "It has no name (the name is NIL).~%")))              (ft _"It has no name (the name is NIL).~%")))
148        (ft "The direct superclasses are: ~:S, and the direct~%~        (ft _"The direct superclasses are: ~:S, and the direct~%~
149             subclasses are: ~:S.  The class is ~:[not ~;~]finalized.  ~             subclasses are: ~:S.  The class is ~:[not ~;~]finalized.  ~
150             The class precedence list is:~%~S~%~             The class precedence list is:~%~S~%~
151             There are ~D methods specialized for this class."             There are ~D methods specialized for this class."
# Line 154  Line 155 
155            (mapcar #'pretty-class (cpl-or-nil class))            (mapcar #'pretty-class (cpl-or-nil class))
156            (length (specializer-direct-methods class)))            (length (specializer-direct-methods class)))
157        (unless (typep class 'condition-class)        (unless (typep class 'condition-class)
158          (loop initially (ft "~&Its direct slots are:~%")          (loop initially (ft _"~&Its direct slots are:~%")
159                for slotd in (class-direct-slots class)                for slotd in (class-direct-slots class)
160                as name = (slot-definition-name slotd)                as name = (slot-definition-name slotd)
161                as doc = (slot-value slotd 'documentation) do                as doc = (slot-value slotd 'documentation) do
162                  (ft "  ~a, documentation ~s~%" name doc)))))                  (ft _"  ~a, documentation ~s~%" name doc)))))
163    (when *describe-metaobjects-as-objects-p*    (when *describe-metaobjects-as-objects-p*
164      (call-next-method)))      (call-next-method)))
165    
166  (defun describe-package (object stream)  (defun describe-package (object stream)
167    (unless (packagep object) (setq object (find-package object)))    (unless (packagep object) (setq object (find-package object)))
168    (format stream "~&~S is a ~S.~%" object (type-of object))    (format stream _"~&~S is a ~S.~%" object (type-of object))
169    (let ((nick (package-nicknames object)))    (let ((nick (package-nicknames object)))
170      (when nick      (when nick
171        (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"        (format stream _"You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
172                (butlast nick) (first (last nick)))))                (butlast nick) (first (last nick)))))
173    (let* ((internal (lisp::package-internal-symbols object))    (let* ((internal (lisp::package-internal-symbols object))
174           (internal-count (- (lisp::package-hashtable-size internal)           (internal-count (- (lisp::package-hashtable-size internal)
# Line 175  Line 176 
176           (external (lisp::package-external-symbols object))           (external (lisp::package-external-symbols object))
177           (external-count (- (lisp::package-hashtable-size external)           (external-count (- (lisp::package-hashtable-size external)
178                                    (lisp::package-hashtable-free external))))                                    (lisp::package-hashtable-free external))))
179      (format stream "It has ~D internal and ~D external symbols (~D total).~%"      (format stream _"It has ~D internal and ~D external symbols (~D total).~%"
180              internal-count external-count (+ internal-count external-count)))              internal-count external-count (+ internal-count external-count)))
181    (let ((used (package-use-list object)))    (let ((used (package-use-list object)))
182      (when used      (when used
183        (format stream "It uses the packages ~{~S~^, ~}.~%"        (format stream _"It uses the packages ~{~S~^, ~}.~%"
184                (mapcar #'package-name used))))                (mapcar #'package-name used))))
185    (let ((users (package-used-by-list object)))    (let ((users (package-used-by-list object)))
186      (when users      (when users
187        (format stream "It is used by the packages ~{~S~^, ~}.~%"        (format stream _"It is used by the packages ~{~S~^, ~}.~%"
188                (mapcar #'package-name users)))))                (mapcar #'package-name users)))))
189    
190  (defmethod describe-object ((object package) stream)  (defmethod describe-object ((object package) stream)
191    (describe-package object stream))    (describe-package object stream))
192    
193  (defmethod describe-object ((object hash-table) stream)  (defmethod describe-object ((object hash-table) stream)
194    (format stream "~&~S is an ~a hash table."    (format stream _"~&~S is an ~a hash table."
195            object            object
196            (lisp::hash-table-test object))            (lisp::hash-table-test object))
197    (format stream "~&Its size is ~d buckets."    (format stream _"~&Its size is ~d buckets."
198            (lisp::hash-table-size object))            (lisp::hash-table-size object))
199    (format stream "~&Its rehash-size is ~d."    (format stream _"~&Its rehash-size is ~d."
200            (lisp::hash-table-rehash-size object))            (lisp::hash-table-rehash-size object))
201    (format stream "~&Its rehash-threshold is ~d."    (format stream _"~&Its rehash-threshold is ~d."
202            (hash-table-rehash-threshold object))            (hash-table-rehash-threshold object))
203    (format stream "~&It currently holds ~d entries."    (format stream _"~&It currently holds ~d entries."
204            (lisp::hash-table-number-entries object)))            (lisp::hash-table-number-entries object)))
205    
206    
# Line 281  Line 282 
282  (macrolet ((define-default-method (class)  (macrolet ((define-default-method (class)
283               `(defmethod make-load-form ((object ,class) &optional env)               `(defmethod make-load-form ((object ,class) &optional env)
284                  (declare (ignore env))                  (declare (ignore env))
285                  (error "~@<Default ~s method for ~s called.~@>"                  (error _"~@<Default ~s method for ~s called.~@>"
286                         'make-load-form object))))                         'make-load-form object))))
287    (define-default-method condition)    (define-default-method condition)
288    (define-default-method standard-object))    (define-default-method standard-object))
# Line 294  Line 295 
295    (declare (ignore env))    (declare (ignore env))
296    (let ((pname (kernel:class-proper-name (kernel:layout-class object))))    (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
297      (unless pname      (unless pname
298        (error "~@<Can't dump wrapper for anonymous class ~S.~@:>"        (error _"~@<Can't dump wrapper for anonymous class ~S.~@:>"
299               (kernel:layout-class object)))               (kernel:layout-class object)))
300      `(kernel:%class-layout (kernel::find-class ',pname))))      `(kernel:%class-layout (kernel::find-class ',pname))))
301    
# Line 302  Line 303 
303    (declare (ignore env))    (declare (ignore env))
304    (let ((name (class-name class)))    (let ((name (class-name class)))
305      (unless (and name (eq (find-class name nil) class))      (unless (and name (eq (find-class name nil) class))
306        (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"        (error _"~@<Can't use anonymous or undefined class as constant: ~S~:@>"
307               class))               class))
308      `(find-class ',name)))      `(find-class ',name)))
309    

Legend:
Removed from v.1.26  
changed lines
  Added in v.1.26.48.2

  ViewVC Help
Powered by ViewVC 1.1.5