/[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.18 by pmai, Sat Feb 15 23:41:31 2003 UTC revision 1.18.2.5 by gerd, Sat Mar 22 12:28:19 2003 UTC
# Line 74  Line 74 
74          (adjust-slot-name-length (slot-definition-name slotd))          (adjust-slot-name-length (slot-definition-name slotd))
75          (case (slot-definition-allocation slotd)          (case (slot-definition-allocation slotd)
76            (:instance (push slotd instance-slotds))            (:instance (push slotd instance-slotds))
77            (:class  (push slotd class-slotds))            (:class    (push slotd class-slotds))
78            (otherwise (push slotd other-slotds))))            (otherwise (push slotd other-slotds))))
79        (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))        (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
80        (format stream "~%~S is an instance of class ~S:" object class)        (format stream "~%~S is an instance of class ~S:" object class)
# Line 144  Line 144 
144            (mapcar #'pretty-class (class-direct-subclasses class))            (mapcar #'pretty-class (class-direct-subclasses class))
145            (mapcar #'pretty-class (class-precedence-list class))            (mapcar #'pretty-class (class-precedence-list class))
146            (length (specializer-direct-methods class)))            (length (specializer-direct-methods class)))
147        (loop initially        (unless (typep class 'condition-class)
148                (ft "~&Its direct slots are:~%")          (loop initially (ft "~&Its direct slots are:~%")
149              for slotd in (class-direct-slots class)                for slotd in (class-direct-slots class)
150              as name = (slot-definition-name slotd)                as name = (slot-definition-name slotd)
151              as doc = (slot-value slotd 'documentation) do                as doc = (slot-value slotd 'documentation) do
152                (ft "  ~a~@[, documentation ~s~]~%" name doc))))                  (ft "  ~a, documentation ~s~%" name doc)))))
153    (when *describe-metaobjects-as-objects-p*    (when *describe-metaobjects-as-objects-p*
154      (call-next-method)))      (call-next-method)))
155    
# Line 196  Line 196 
196    
197    
198  ;;;  ;;;
199  ;;; trace-method and untrace-method accept method specs as arguments.  A  ;;; Value is a list of all (possible) method function names of
200  ;;; method-spec should be a list like:  ;;; generic function GF.
 ;;;   (<generic-function-spec> qualifiers* (specializers*))  
 ;;; where <generic-function-spec> should be either a symbol or a list  
 ;;; of (SETF <symbol>).  
201  ;;;  ;;;
202  ;;;   For example, to trace the method defined by:  (defun debug::all-method-function-names (gf)
203  ;;;    (loop with gf = (if (symbolp gf) (gdefinition gf) gf)
204  ;;;     (defmethod foo ((x spaceship)) 'ss)          for method in (generic-function-methods gf)
205  ;;;          as name = (nth-value 2 (parse-method-or-spec method))
206  ;;;   You should say:          collect name
207  ;;;          collect (list* 'fast-method (cdr name))))
208  ;;;     (trace-method '(foo (spaceship)))  
209  ;;;  (defun debug::all-method-functions-in-package (pkg)
210  ;;;   You can also provide a method object in the place of the method    (let ((gfs ()))
211  ;;;   spec, in which case that method object will be traced.      (map-all-generic-functions
212  ;;;       (lambda (gf)
213  ;;; For untrace-method, if an argument is given, that method is untraced.         (multiple-value-bind (valid base)
214  ;;; If no argument is given, all traced methods are untraced.             (ext:valid-function-name-p (generic-function-name gf))
215  ;;;           (declare (ignore valid))
216  (defclass traced-method (method)           (when (and (symbolp base)
217       ((method :initarg :method)                      (eq (symbol-package base) pkg))
218        (function :initarg :function             (push gf gfs)))))
219                  :reader method-function)      (loop for gf in gfs nconc (debug::all-method-function-names gf))))
220        (generic-function :initform nil  
221                          :accessor method-generic-function)))  ;;;
222    ;;; Reinitialize method function NAME from its fdefinitions.
223  (defmethod method-lambda-list ((m traced-method))  ;;;
224    (with-slots (method) m (method-lambda-list method)))  (defun profile::reinitialize-method-function (name)
225      (multiple-value-bind (gf method method-name)
226  (defmethod method-specializers ((m traced-method))        (parse-method-or-spec (cdr name))
227    (with-slots (method) m (method-specializers method)))      (declare (ignore gf method-name))
228        (with-slots (function fast-function) method
229  (defmethod method-qualifiers ((m traced-method))        (ecase (car name)
230    (with-slots (method) m (method-qualifiers method)))          (method
231             (when function
232  (defmethod accessor-method-slot-name ((m traced-method))             (setq function (fdefinition name))))
233    (with-slots (method) m (accessor-method-slot-name method)))          (fast-method
234             (when fast-function
235  (defvar *traced-methods* ())             (let* ((new (fdefinition name))
236                      (plist (method-function-plist new)))
237  (defun trace-method (spec &rest options)               ;;
238    (multiple-value-bind (gf omethod name)               ;; This is necessary so that, for instance, the arg-info of
239        (parse-method-or-spec spec)               ;; the function can be determined.
240      (let* ((tfunction (trace-method-internal (method-function omethod)               (unless plist
241                                               name                 (setf (method-function-plist new)
242                                               options))                       (method-function-plist fast-function)))
243             (tmethod (make-instance 'traced-method               (setq fast-function new))))))))
                                    :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))  
   
   
244    
   
 ;(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))))  
   
245  (defmacro undefmethod (&rest args)  (defmacro undefmethod (&rest args)
   (declare (arglist name {method-qualifier}* specializers))  
246    `(undefmethod-1 ',args))    `(undefmethod-1 ',args))
247    
248  (defun undefmethod-1 (args)  (defun undefmethod-1 (args)
# Line 298  Line 256 
256  (pushnew :pcl *features*)  (pushnew :pcl *features*)
257  (pushnew :portable-commonloops *features*)  (pushnew :portable-commonloops *features*)
258  (pushnew :pcl-structures *features*)  (pushnew :pcl-structures *features*)
259    (pushnew :gerds-pcl *features*)
260    
261  (when (find-package "OLD-PCL")  (when (find-package "OLD-PCL")
262    (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))    (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
# Line 318  Line 277 
277    (declare (ignore env))    (declare (ignore env))
278    (let ((pname (kernel:class-proper-name (kernel:layout-class object))))    (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
279      (unless pname      (unless pname
280        (error "Can't dump wrapper for anonymous class:~%  ~S"        (error "~@<Can't dump wrapper for anonymous class ~S.~@:>"
281               (kernel:layout-class object)))               (kernel:layout-class object)))
282      `(kernel:class-layout (lisp:find-class ',pname))))      `(kernel:%class-layout (kernel::find-class ',pname))))
283    
284    (defmethod make-load-form ((class class) &optional env)
285      (declare (ignore env))
286      (let ((name (class-name class)))
287        (unless (and name (eq (find-class name nil) class))
288          (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
289                 class))
290        `(find-class ',name)))
291    
292  (defun make-load-form-saving-slots (object &key slot-names environment)  (defun make-load-form-saving-slots (object &key slot-names environment)
293    (declare (ignore environment))    (declare (ignore environment))
294    (when slot-names    (when slot-names
295      (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~      (warn "~@<~s ~s option not implemented, dumping all slots: ~S~@:>"
296             slots:~%  ~S"            :slot-names 'make-load-form object))
           object))  
297    :just-dump-it-normally)    :just-dump-it-normally)
298    
   
 ;;; The following are hacks to deal with CMU CL having two different CLASS  
 ;;; classes.  
 ;;;  
 (defun coerce-to-pcl-class (class)  
   (if (typep class 'lisp:class)  
       (or (kernel:class-pcl-class class)  
           (find-structure-class (lisp:class-name class)))  
       class))  
   
 (defmethod make-instance ((class lisp:class) &rest stuff)  
   (apply #'make-instance (coerce-to-pcl-class class) stuff))  
 (defmethod change-class (instance (class lisp:class) &rest initargs)  
   (apply #'change-class instance (coerce-to-pcl-class class) initargs))  
   
 (macrolet ((frob (&rest names)  
              `(progn  
                 ,@(mapcar (lambda (name)  
                             `(defmethod ,name ((class lisp:class))  
                               (funcall #',name  
                                (coerce-to-pcl-class class))))  
                           names))))  
   (frob  
     class-direct-slots  
     class-prototype  
     class-precedence-list  
     class-direct-default-initargs  
     class-direct-superclasses  
     compute-class-precedence-list  
     class-default-initargs class-finalized-p  
     class-direct-subclasses class-slots  
     make-instances-obsolete))  

Legend:
Removed from v.1.18  
changed lines
  Added in v.1.18.2.5

  ViewVC Help
Powered by ViewVC 1.1.5