/[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.1.1.1 by ram, Sat Oct 19 16:44:42 1991 UTC revision 1.27 by rtoy, Fri Mar 19 15:19:03 2010 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    (file-comment
29      "$Header$")
30    ;;;
31  ;;; Basic environmental stuff.  ;;; Basic environmental stuff.
32  ;;;  ;;;
33    
34  (in-package 'pcl)  (in-package :pcl)
35    (intl:textdomain "cmucl")
 #+Lucid  
 (progn  
   
 (defvar *old-arglist*)  
   
 (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 *old-arglist* function other-args)))))  
   
 (eval-when (eval load)  
   (unless (boundp '*old-arglist*)  
     (setq *old-arglist* (symbol-function 'sys::arglist))  
     (setf (symbol-function 'sys::arglist) #'pcl-arglist)))  
   
 )  
36    
   
37  ;;;  ;;;
38  ;;;  ;;;
39  ;;;  ;;;
40    
41  (defgeneric describe-object (object stream))  ;;; ANSI compliance wants default structure printer to use #S(...) format.
42    (defmethod print-object ((object structure-object) stream)
43  #-Genera (progn    (lisp::default-structure-print object stream 0))
44    
45  (defvar *old-describe* ())  ;;; Condition printing
46    (defmethod print-object ((object condition) stream)
47      (conditions::real-print-condition object stream))
48    
49  (eval-when (load)  (defgeneric describe-object (object stream))
   (unless *old-describe* (setq *old-describe* (symbol-function 'describe)))  
   (setf (symbol-function 'describe)  
         #+Lispm  
         #'(lambda (object &optional no-complaints)  
             (let ((*describe-no-complaints* no-complaints))  
               (declare (special *describe-no-complaints*))  
               (describe-object object *standard-output*)  
               (values)))  
         #-Lispm  
         #'(lambda (object)  
             (describe-object object *standard-output*)  
             (values))))  
50    
51  (defmethod describe-object (object stream)  (defmethod describe-object (object stream)
52    (let ((*standard-output* stream))    (describe object stream))
     (funcall *old-describe* object)))  
 )  
53    
54  (defmethod describe-object ((object standard-object) stream)  (defmethod describe-object ((object slot-object) stream)
55    (let* ((class (class-of object))    (let* ((class (class-of object))
56           (slotds (slots-to-inspect class object))           (slotds (slots-to-inspect class object))
57           (max-slot-name-length 0)           (max-slot-name-length 0)
# Line 105  Line 72 
72                           name max-slot-name-length value))))                           name max-slot-name-length value))))
73        ;; Figure out a good width for the slot-name column.        ;; Figure out a good width for the slot-name column.
74        (dolist (slotd slotds)        (dolist (slotd slotds)
75          (adjust-slot-name-length (slotd-name slotd))          (adjust-slot-name-length (slot-definition-name slotd))
76          (case (slotd-allocation slotd)          (case (slot-definition-allocation slotd)
77            (:instance (push slotd instance-slotds))            (:instance (push slotd instance-slotds))
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 (slotd-name slotd)            (describe-slot (slot-definition-name slotd)
87                           (slot-value-or-default object (slotd-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 (slotd-name slotd)            (describe-slot (slot-definition-name slotd)
93                           (slot-value-or-default object (slotd-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 (slotd-name slotd)            (describe-slot (slot-definition-name slotd)
99                           (slot-value-or-default object (slotd-name slotd))                           (slot-value-or-default object (slot-definition-name slotd))
100                           (slotd-allocation slotd))))                           (slot-definition-allocation slotd))))
101        (values))))        (values))))
102    
103  (defmethod slots-to-inspect ((class std-class) (object standard-object))  (defmethod slots-to-inspect ((class slot-class) (object slot-object))
104    (class-slots class))    (class-slots class))
105    
106    (defvar *describe-metaobjects-as-objects-p* nil)
107    
108    (defun method-specialized-lambda-list (method)
109      (loop with specializers = (unparse-specializers method)
110            for elt in (method-lambda-list method)
111            collect (if specializers
112                        (list elt (pop specializers))
113                        elt)))
114    
115    (defmethod describe-object ((gf standard-generic-function) stream)
116      (format stream _"~A is a generic function.~%" gf)
117      (let* ((gf-name (generic-function-name gf))
118             (doc (documentation gf-name 'function)))
119        (format stream _"Its lambda-list is:~%  ~S~%"
120                (generic-function-lambda-list gf))
121        (when doc
122          (format stream _"Generic function documentation:~%  ~s~%" doc))
123        (format stream _"Its methods are:~%")
124        (loop for method in (generic-function-methods gf) and i from 1
125              as doc = (plist-value method 'documentation) do
126                (format stream "  ~d: ~a ~@[~{~s ~}~]~:s~%"
127                        i gf-name (method-qualifiers method)
128                        (method-specialized-lambda-list method))
129                (when doc
130                  (format stream _"    Method documentation: ~s~%" doc)))
131        (when *describe-metaobjects-as-objects-p*
132          (call-next-method))))
133    
134  ;;;  ;;;
135  ;;;  ;;;
136  ;;;  ;;;
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 precedence list is:~%~S~%~             subclasses are: ~:S.  The class is ~:[not ~;~]finalized.  ~
150               The class precedence list is:~%~S~%~
151             There are ~D methods specialized for this class."             There are ~D methods specialized for this class."
152            (mapcar #'pretty-class (class-direct-superclasses class))            (mapcar #'pretty-class (class-direct-superclasses class))
153            (mapcar #'pretty-class (class-direct-subclasses class))            (mapcar #'pretty-class (class-direct-subclasses class))
154            (mapcar #'pretty-class (class-precedence-list class))            (class-finalized-p class)
155            (length (specializer-methods class))))))            (mapcar #'pretty-class (cpl-or-nil class))
156              (length (specializer-direct-methods class)))
157          (unless (typep class 'condition-class)
158            (loop initially (ft _"~&Its direct slots are:~%")
159                  for slotd in (class-direct-slots class)
160                  as name = (slot-definition-name slotd)
161                  as doc = (slot-value slotd 'documentation) do
162                    (ft _"  ~a, documentation ~s~%" name doc)))))
163      (when *describe-metaobjects-as-objects-p*
164        (call-next-method)))
165    
166    (defun describe-package (object stream)
167      (unless (packagep object) (setq object (find-package object)))
168      (format stream _"~&~S is a ~S.~%" object (type-of object))
169      (let ((nick (package-nicknames object)))
170        (when nick
171          (format stream _"You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
172                  (butlast nick) (first (last nick)))))
173      (let* ((internal (lisp::package-internal-symbols object))
174             (internal-count (- (lisp::package-hashtable-size internal)
175                                      (lisp::package-hashtable-free internal)))
176             (external (lisp::package-external-symbols object))
177             (external-count (- (lisp::package-hashtable-size external)
178                                      (lisp::package-hashtable-free external))))
179        (format stream _"It has ~D internal and ~D external symbols (~D total).~%"
180                internal-count external-count (+ internal-count external-count)))
181      (let ((used (package-use-list object)))
182        (when used
183          (format stream _"It uses the packages ~{~S~^, ~}.~%"
184                  (mapcar #'package-name used))))
185      (let ((users (package-used-by-list object)))
186        (when users
187          (format stream _"It is used by the packages ~{~S~^, ~}.~%"
188                  (mapcar #'package-name users)))))
189    
190    (defmethod describe-object ((object package) stream)
191      (describe-package object stream))
192    
193    (defmethod describe-object ((object hash-table) stream)
194      (format stream _"~&~S is an ~a hash table."
195              object
196              (lisp::hash-table-test object))
197      (format stream _"~&Its size is ~d buckets."
198              (lisp::hash-table-size object))
199      (format stream _"~&Its rehash-size is ~d."
200              (lisp::hash-table-rehash-size object))
201      (format stream _"~&Its rehash-threshold is ~d."
202              (hash-table-rehash-threshold object))
203      (format stream _"~&It currently holds ~d entries."
204              (lisp::hash-table-number-entries object)))
205    
206    
207    
208  ;;;  ;;;
209  ;;; trace-method and untrace-method accept method specs as arguments.  A  ;;; Value is a list of all (possible) method function names of
210  ;;; method-spec should be a list like:  ;;; generic function GF.
211  ;;;   (<generic-function-spec> qualifiers* (specializers*))  ;;;
212  ;;; where <generic-function-spec> should be either a symbol or a list  (defun debug::all-method-function-names (gf)
213  ;;; of (SETF <symbol>).    (loop with gf = (if (symbolp gf) (gdefinition gf) gf)
214  ;;;          for method in (generic-function-methods gf)
215  ;;;   For example, to trace the method defined by:          as name = (nth-value 2 (parse-method-or-spec method))
216  ;;;          collect name
217  ;;;     (defmethod foo ((x spaceship)) 'ss)          collect (list* 'fast-method (cdr name))))
218  ;;;  
219  ;;;   You should say:  (defun debug::all-method-functions-in-package (pkg)
220  ;;;    (let ((gfs ()))
221  ;;;     (trace-method '(foo (spaceship)))      (map-all-generic-functions
222  ;;;       (lambda (gf)
223  ;;;   You can also provide a method object in the place of the method         (multiple-value-bind (valid base)
224  ;;;   spec, in which case that method object will be traced.             (valid-function-name-p (generic-function-name gf))
225  ;;;           (declare (ignore valid))
226  ;;; For untrace-method, if an argument is given, that method is untraced.           (when (and (symbolp base)
227  ;;; If no argument is given, all traced methods are untraced.                      (eq (symbol-package base) pkg))
228  ;;;             (push gf gfs)))))
229  (defclass traced-method (method)      (loop for gf in gfs nconc (debug::all-method-function-names gf))))
230       ((method :initarg :method)  
231        (function :initarg :function  ;;;
232                  :reader method-function)  ;;; Reinitialize method function NAME from its fdefinitions.
233        (generic-function :initform nil  ;;;
234                          :accessor method-generic-function)))  (defun profile::reinitialize-method-function (name)
235      (multiple-value-bind (gf method method-name)
236  (defmethod method-lambda-list ((m traced-method))        (parse-method-or-spec (cdr name))
237    (with-slots (method) m (method-lambda-list method)))      (declare (ignore gf method-name))
238        (with-slots (function fast-function) method
239  (defmethod method-specializers ((m traced-method))        (ecase (car name)
240    (with-slots (method) m (method-specializers method)))          (method
241             (when function
242  (defmethod method-qualifiers ((m traced-method))             (setq function (fdefinition name))))
243    (with-slots (method) m (method-qualifiers method)))          (fast-method
244             (when fast-function
245  (defmethod method-qualifiers ((m traced-method))             (let* ((new (fdefinition name))
246    (with-slots (method) m (method-qualifiers method)))                    (plist (method-function-plist new)))
247                 ;;
248  (defmethod accessor-method-slot-name ((m traced-method))               ;; This is necessary so that, for instance, the arg-info of
249    (with-slots (method) m (accessor-method-slot-name method)))               ;; the function can be determined.
250                 (unless plist
251  (defvar *traced-methods* ())                 (setf (method-function-plist new)
252                         (method-function-plist fast-function)))
253  (defun trace-method (spec &rest options)               (setq fast-function new))))))))
   (multiple-value-bind (gf omethod name)  
       (parse-method-or-spec spec)  
     (let* ((tfunction (trace-method-internal (method-function omethod)  
                                              name  
                                              options))  
            (tmethod (make-instance 'traced-method  
                                    :method omethod  
                                    :function tfunction)))  
       (remove-method gf omethod)  
       (add-method gf tmethod)  
       (pushnew tmethod *traced-methods*)  
       tmethod)))  
   
 (defun untrace-method (&optional spec)  
   (flet ((untrace-1 (m)  
            (let ((gf (method-generic-function m)))  
              (when gf  
                (remove-method gf m)  
                (add-method gf (slot-value m 'method))  
                (setq *traced-methods* (remove m *traced-methods*))))))  
     (if (not (null spec))  
         (multiple-value-bind (gf method)  
             (parse-method-or-spec spec)  
           (declare (ignore gf))  
           (if (memq method *traced-methods*)  
               (untrace-1 method)  
               (error "~S is not a traced method?" method)))  
         (dolist (m *traced-methods*) (untrace-1 m)))))  
   
 (defun trace-method-internal (ofunction name options)  
   (eval `(untrace ,name))  
   (setf (symbol-function name) ofunction)  
   (eval `(trace ,name ,@options))  
   (symbol-function name))  
   
   
254    
   
 ;(defun compile-method (spec)  
 ;  (multiple-value-bind (gf method name)  
 ;      (parse-method-or-spec spec)  
 ;    (declare (ignore gf))  
 ;    (compile name (method-function method))  
 ;    (setf (method-function method) (symbol-function name))))  
   
255  (defmacro undefmethod (&rest args)  (defmacro undefmethod (&rest args)
   #+(or (not :lucid) :lcl3.0)  
   (declare (arglist name {method-qualifier}* specializers))  
256    `(undefmethod-1 ',args))    `(undefmethod-1 ',args))
257    
258  (defun undefmethod-1 (args)  (defun undefmethod-1 (args)
# Line 264  Line 263 
263        method)))        method)))
264    
265    
266    (pushnew :pcl *features*)
267    (pushnew :portable-commonloops *features*)
268    (pushnew :pcl-structures *features*)
269    (pushnew :gerds-pcl *features*)
270    
271    (when (find-package "OLD-PCL")
272      (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
273            (symbol-function 'pcl::print-object)))
274    
275    
276    ;;;; MAKE-LOAD-FORM
277    
278    (export '(lisp::make-load-form lisp::make-load-form-saving-slots) "CL")
279    
280    (defgeneric make-load-form (object &optional environment))
281    
282    (macrolet ((define-default-method (class)
283                 `(defmethod make-load-form ((object ,class) &optional env)
284                    (declare (ignore env))
285                    (error _"~@<Default ~s method for ~s called.~@>"
286                           'make-load-form object))))
287      (define-default-method condition)
288      (define-default-method standard-object))
289    
290    (defmethod make-load-form ((object structure-object) &optional environment)
291      (declare (ignore environment))
292      (kernel:make-structure-load-form object))
293    
294    (defmethod make-load-form ((object wrapper) &optional env)
295      (declare (ignore env))
296      (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
297        (unless pname
298          (error _"~@<Can't dump wrapper for anonymous class ~S.~@:>"
299                 (kernel:layout-class object)))
300        `(kernel:%class-layout (kernel::find-class ',pname))))
301    
302    (defmethod make-load-form ((class class) &optional env)
303      (declare (ignore env))
304      (let ((name (class-name class)))
305        (unless (and name (eq (find-class name nil) class))
306          (error _"~@<Can't use anonymous or undefined class as constant: ~S~:@>"
307                 class))
308        `(find-class ',name)))
309    
310    (defun make-load-form-saving-slots (object &key slot-names environment)
311      (declare (ignore environment))
312      (let ((class (class-of object)))
313        (collect ((inits))
314          (dolist (slot (class-slots class))
315            (let ((slot-name (slot-definition-name slot)))
316              (when (or (memq slot-name slot-names)
317                        (and (null slot-names)
318                             (eq :instance (slot-definition-allocation slot))))
319                (if (slot-boundp-using-class class object slot)
320                    (let ((value (slot-value-using-class class object slot)))
321                      (inits `(setf (slot-value ,object ',slot-name) ',value)))
322                    (inits `(slot-makunbound ,object ',slot-name))))))
323          (values `(allocate-instance (find-class ',(class-name class)))
324                  `(progn .,(inits))))))
325    

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.27

  ViewVC Help
Powered by ViewVC 1.1.5