/[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.9 by pw, Fri May 30 18:39:12 1997 UTC revision 1.9.2.1 by pw, Tue May 23 16:38:50 2000 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    
28    (ext:file-comment
29      "$Header$")
30    ;;;
31  ;;; Basic environmental stuff.  ;;; Basic environmental stuff.
32  ;;;  ;;;
33    
34  (in-package :pcl)  (in-package :pcl)
35    
 #+Lucid  
 (progn  
   
 (defun pcl-arglist (function &rest other-args)  
   (let ((defn nil))  
     (cond ((and (fsc-instance-p function)  
                 (generic-function-p function))  
            (generic-function-pretty-arglist function))  
           ((and (symbolp function)  
                 (fboundp function)  
                 (setq defn (symbol-function function))  
                 (fsc-instance-p defn)  
                 (generic-function-p defn))  
            (generic-function-pretty-arglist defn))  
           (t (apply (original-definition 'sys::arglist)  
                     function other-args)))))  
   
 (redefine-function 'sys::arglist 'pcl-arglist)  
   
 )  
   
   
36  ;;;  ;;;
37  ;;;  ;;;
38  ;;;  ;;;
39    
40  (defgeneric describe-object (object stream))  (defgeneric describe-object (object stream))
41    
 #-Genera  
 (progn  
   
 (defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints)  
   (let (#+Lispm (*describe-no-complaints* no-complaints))  
     #+Lispm (declare (special *describe-no-complaints*))  
     (describe-object object *standard-output*)  
     (values)))  
   
42  (defmethod describe-object (object stream)  (defmethod describe-object (object stream)
   #-cmu  
     (cond ((or #+kcl (packagep object))  
            (describe-package object stream))  
           (t  
            (funcall (original-definition 'describe) object)))  
   #+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 180  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 206  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 317  Line 267 
267  ;    (setf (method-function method) (symbol-function name))))  ;    (setf (method-function method) (symbol-function name))))
268    
269  (defmacro undefmethod (&rest args)  (defmacro undefmethod (&rest args)
   #+(or (not :lucid) :lcl3.0)  
270    (declare (arglist name {method-qualifier}* specializers))    (declare (arglist name {method-qualifier}* specializers))
271    `(undefmethod-1 ',args))    `(undefmethod-1 ',args))
272    
# Line 333  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 341  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.9  
changed lines
  Added in v.1.9.2.1

  ViewVC Help
Powered by ViewVC 1.1.5