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 by gerd, Wed Mar 12 18:24:53 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 149  Line 149 
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)))
# Line 196  Line 196 
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*)  
 (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))  
 ;(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))
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*)
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 (lisp:find-class ',pname))))
284  (defun make-load-form-saving-slots (object &key slot-names environment)  (defun make-load-form-saving-slots (object &key slot-names environment)
285    (declare (ignore environment))    (declare (ignore environment))
286    (when slot-names    (when slot-names
287      (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~      (warn "~@<~s ~s option not implemented, dumping all slots: ~S~@:>"
288             slots:~%  ~S"            :slot-names 'make-load-form object))
289    :just-dump-it-normally)    :just-dump-it-normally)
# Line 340  Line 298 
298            (find-structure-class (lisp:class-name class)))            (find-structure-class (lisp:class-name class)))
299        class))        class))
301    (eval-when (compile)
302      (setq *inhibit-class-name-canonicalization* t))
304  (defmethod make-instance ((class lisp:class) &rest stuff)  (defmethod make-instance ((class lisp:class) &rest stuff)
305    (apply #'make-instance (coerce-to-pcl-class class) stuff))    (apply #'make-instance (coerce-to-pcl-class class) stuff))
306  (defmethod change-class (instance (class lisp:class) &rest initargs)  (defmethod change-class (instance (class lisp:class) &rest initargs)
# Line 349  Line 310 
310               `(progn               `(progn
311                  ,@(mapcar (lambda (name)                  ,@(mapcar (lambda (name)
312                              `(defmethod ,name ((class lisp:class))                              `(defmethod ,name ((class lisp:class))
313                                (funcall #',name                                 (funcall #',name
314                                 (coerce-to-pcl-class class))))                                          (coerce-to-pcl-class class))))
315                            names))))                            names))))
316    (frob    (frob class-direct-slots
317      class-direct-slots          class-prototype
318      class-prototype          class-precedence-list
319      class-precedence-list          class-direct-default-initargs
320      class-direct-default-initargs          class-direct-superclasses
321      class-direct-superclasses          compute-class-precedence-list
322      compute-class-precedence-list          class-default-initargs class-finalized-p
323      class-default-initargs class-finalized-p          class-direct-subclasses class-slots
324      class-direct-subclasses class-slots          make-instances-obsolete))
325      make-instances-obsolete))  
326    (eval-when (compile)
327      (setq *inhibit-class-name-canonicalization* nil))

Removed from v.1.18  
changed lines
  Added in v.

  ViewVC Help
Powered by ViewVC 1.1.5