/[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.11 by pw, Thu Mar 11 16:51:05 1999 UTC revision 1.12 by pw, Sun May 30 23:13:58 1999 UTC
# Line 24  Line 24 
24  ;;; Suggestions, comments and requests for improvements are also welcome.  ;;; Suggestions, comments and requests for improvements are also welcome.
25  ;;; *************************************************************************  ;;; *************************************************************************
26  ;;;  ;;;
27  #+cmu  
28  (ext:file-comment  (ext:file-comment
29    "$Header$")    "$Header$")
30  ;;;  ;;;
# Line 39  Line 39 
39    
40  (defgeneric describe-object (object stream))  (defgeneric describe-object (object stream))
41    
 #-cmu  
 (defun pcl-describe (object)  
   (describe-object object *standard-output*)  
   (values))  
   
42  (defmethod describe-object (object stream)  (defmethod describe-object (object stream)
   #+cmu  
43    (describe object stream))    (describe object stream))
44    
 #-cmu  
 (redefine-function 'describe 'pcl-describe)  
   
45  (defmethod describe-object ((object slot-object) stream)  (defmethod describe-object ((object slot-object) stream)
46    (let* ((class (class-of object))    (let* ((class (class-of object))
47           (slotds (slots-to-inspect class object))           (slotds (slots-to-inspect class object))
# Line 151  Line 142 
142      (when nick      (when nick
143        (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"        (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
144                (butlast nick) (first (last nick)))))                (butlast nick) (first (last nick)))))
145    (let* (#+cmu (internal (lisp::package-internal-symbols object))    (let* ((internal (lisp::package-internal-symbols object))
146           (internal-count #+cmu (- (lisp::package-hashtable-size internal)           (internal-count (- (lisp::package-hashtable-size internal)
147                                    (lisp::package-hashtable-free internal))                                    (lisp::package-hashtable-free internal)))
148                           #-cmu 0)           (external (lisp::package-external-symbols object))
149           #+cmu (external (lisp::package-external-symbols object))           (external-count (- (lisp::package-hashtable-size external)
150           (external-count #+cmu (- (lisp::package-hashtable-size external)                                    (lisp::package-hashtable-free external))))
                                   (lisp::package-hashtable-free external))  
                          #-cmu 0))  
     #-cmu (do-external-symbols (sym object)  
             (declare (ignore sym))  
             (incf external-count))  
     #-cmu (do-symbols (sym object)  
             (declare (ignore sym))  
             (incf internal-count))  
     #-cmu (decf internal-count external-count)  
151      (format stream "It has ~D internal and ~D external symbols (~D total).~%"      (format stream "It has ~D internal and ~D external symbols (~D total).~%"
152              internal-count external-count (+ internal-count external-count)))              internal-count external-count (+ internal-count external-count)))
153    (let ((used (package-use-list object)))    (let ((used (package-use-list object)))
# Line 177  Line 159 
159        (format stream "It is used by the packages ~{~S~^, ~}.~%"        (format stream "It is used by the packages ~{~S~^, ~}.~%"
160                (mapcar #'package-name users)))))                (mapcar #'package-name users)))))
161    
 #+cmu  
162  (defmethod describe-object ((object package) stream)  (defmethod describe-object ((object package) stream)
163    (describe-package object stream))    (describe-package object stream))
164    
 #+cmu  
165  (defmethod describe-object ((object hash-table) stream)  (defmethod describe-object ((object hash-table) stream)
166    (format stream "~&~S is an ~a hash table."    (format stream "~&~S is an ~a hash table."
167            object            object
168            #-cmu17 (lisp::hash-table-kind object)            (lisp::hash-table-test object))
           #+cmu17 (lisp::hash-table-test object))  
169    (format stream "~&Its size is ~d buckets."    (format stream "~&Its size is ~d buckets."
170            (lisp::hash-table-size object))            (lisp::hash-table-size object))
171    (format stream "~&Its rehash-size is ~d."    (format stream "~&Its rehash-size is ~d."
# Line 303  Line 282 
282  (pushnew :portable-commonloops *features*)  (pushnew :portable-commonloops *features*)
283  (pushnew :pcl-structures *features*)  (pushnew :pcl-structures *features*)
284    
 #+cmu  
285  (when (find-package "OLD-PCL")  (when (find-package "OLD-PCL")
286    (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))    (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
287          (symbol-function 'pcl::print-object)))          (symbol-function 'pcl::print-object)))
# Line 311  Line 289 
289    
290  ;;;; MAKE-LOAD-FORM  ;;;; MAKE-LOAD-FORM
291    
 #+cmu17  
292  (export '(cl::make-load-form cl::make-load-form-saving-slots) "CL")  (export '(cl::make-load-form cl::make-load-form-saving-slots) "CL")
293    
294  #+cmu17  (defgeneric make-load-form (object &optional environment))
295  (progn  
296    (defgeneric make-load-form (object &optional environment))  (defmethod make-load-form ((object structure-object) &optional environment)
297      (declare (ignore environment))
298    (defmethod make-load-form ((object structure-object) &optional environment)    (kernel:make-structure-load-form object))
299      (declare (ignore environment))  
300      (kernel:make-structure-load-form object))  (defmethod make-load-form ((object wrapper) &optional env)
301      (declare (ignore env))
302    (defmethod make-load-form ((object wrapper) &optional env)    (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
303      (declare (ignore env))      (unless pname
304      (let ((pname (kernel:class-proper-name (kernel:layout-class object))))        (error "Can't dump wrapper for anonymous class:~%  ~S"
305        (unless pname               (kernel:layout-class object)))
306          (error "Can't dump wrapper for anonymous class:~%  ~S"      `(kernel:class-layout (lisp:find-class ',pname))))
307                 (kernel:layout-class object)))  
308        `(kernel:class-layout (lisp:find-class ',pname))))  (defun make-load-form-saving-slots (object &key slot-names environment)
309      (declare (ignore environment))
310    (defun make-load-form-saving-slots (object &key slot-names environment)    (when slot-names
311      (declare (ignore environment))      (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~
312      (when slot-names             slots:~%  ~S"
313        (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~            object))
314               slots:~%  ~S"    :just-dump-it-normally)
             object))  
     :just-dump-it-normally))  
315    
316    
317  ;;; The following are hacks to deal with CMU CL having two different CLASS  ;;; The following are hacks to deal with CMU CL having two different CLASS
318  ;;; classes.  ;;; classes.
319  ;;;  ;;;
 #+cmu17  
320  (defun coerce-to-pcl-class (class)  (defun coerce-to-pcl-class (class)
321    (if (typep class 'lisp:class)    (if (typep class 'lisp:class)
322        (or (kernel:class-pcl-class class)        (or (kernel:class-pcl-class class)
323            (find-structure-class (lisp:class-name class)))            (find-structure-class (lisp:class-name class)))
324        class))        class))
325    
326  #+cmu17  (defmethod make-instance ((class lisp:class) &rest stuff)
327  (progn    (apply #'make-instance (coerce-to-pcl-class class) stuff))
328    (defmethod make-instance ((class lisp:class) &rest stuff)  (defmethod change-class (instance (class lisp:class))
329      (apply #'make-instance (coerce-to-pcl-class class) stuff))    (apply #'change-class instance (coerce-to-pcl-class class)))
   (defmethod change-class (instance (class lisp:class))  
     (apply #'change-class instance (coerce-to-pcl-class class))))  
330    
 #+cmu17  
331  (macrolet ((frob (&rest names)  (macrolet ((frob (&rest names)
332               `(progn               `(progn
333                  ,@(mapcar #'(lambda (name)                  ,@(mapcar #'(lambda (name)

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

  ViewVC Help
Powered by ViewVC 1.1.5