X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fenv.lisp;h=3182342bd68e91b78dab746ba0c82aac2b7e47ce;hb=54da325f13fb41669869aea688ae195426c0e231;hp=8018e812f90a751a30888cdaf15a4be3c6f4ccbe;hpb=372989d837526e3100b364153d58181a2a563351;p=sbcl.git diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp index 8018e81..3182342 100644 --- a/src/pcl/env.lisp +++ b/src/pcl/env.lisp @@ -31,6 +31,35 @@ ;;; a "contrib" directory eventually? #| +(defun parse-method-or-spec (spec &optional (errorp t)) + (let (gf method name temp) + (if (method-p spec) + (setq method spec + gf (method-generic-function method) + temp (and gf (generic-function-name gf)) + name (if temp + (make-method-spec temp + (method-qualifiers method) + (unparse-specializers + (method-specializers method))) + (make-symbol (format nil "~S" method)))) + (let ((gf-spec (car spec))) + (multiple-value-bind (quals specls) + (parse-defmethod (cdr spec)) + (and (setq gf (and (or errorp (fboundp gf-spec)) + (gdefinition gf-spec))) + (let ((nreq (compute-discriminating-function-arglist-info gf))) + (setq specls (append (parse-specializers specls) + (make-list (- nreq (length specls)) + :initial-element + *the-class-t*))) + (and + (setq method (get-method gf quals specls errorp)) + (setq name + (make-method-spec + gf-spec quals (unparse-specializers specls))))))))) + (values gf method name))) + ;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A ;;; method-spec should be a list like: ;;; ( qualifiers* (specializers*)) @@ -53,9 +82,9 @@ (defclass traced-method (method) ((method :initarg :method) (function :initarg :function - :reader method-function) + :reader method-function) (generic-function :initform nil - :accessor method-generic-function))) + :accessor method-generic-function))) (defmethod method-lambda-list ((m traced-method)) (with-slots (method) m (method-lambda-list method))) @@ -75,11 +104,11 @@ (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))) + name + options)) + (tmethod (make-instance 'traced-method + :method omethod + :function tfunction))) (remove-method gf omethod) (add-method gf tmethod) (pushnew tmethod *traced-methods*) @@ -87,19 +116,19 @@ (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*)))))) + (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))))) + (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)) @@ -108,6 +137,20 @@ (fdefinition name)) |# +#| +;;;; Helper for slightly newer trace implementation, based on +;;;; breakpoint stuff. The above is potentially still useful, so it's +;;;; left in, commented. + +;;; (this turned out to be a roundabout way of doing things) +(defun list-all-maybe-method-names (gf) + (let (result) + (dolist (method (generic-function-methods gf) (nreverse result)) + (let ((spec (nth-value 2 (parse-method-or-spec method)))) + (push spec result) + (push (list* 'fast-method (cdr spec)) result))))) +|# + ;;;; MAKE-LOAD-FORM ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a @@ -118,47 +161,56 @@ ;; Link bootstrap-time how-to-dump-it information into the shiny new ;; CLOS system. (defmethod make-load-form ((obj sb-sys:structure!object) - &optional (env nil env-p)) + &optional (env nil env-p)) (if env-p (sb-sys:structure!object-make-load-form obj env) (sb-sys:structure!object-make-load-form obj))) (defmethod make-load-form ((object wrapper) &optional env) (declare (ignore env)) - (let ((pname (sb-kernel:class-proper-name (sb-kernel:layout-class object)))) + (let ((pname (classoid-proper-name + (layout-classoid object)))) (unless pname (error "can't dump wrapper for anonymous class:~% ~S" - (sb-kernel:layout-class object))) - `(sb-kernel:class-layout (cl:find-class ',pname)))) - -;;;; The following are hacks to deal with CMU CL having two different CLASS -;;;; classes. - -(defun coerce-to-pcl-class (class) - (if (typep class 'cl:class) - (or (sb-kernel:class-pcl-class class) - (find-structure-class (cl:class-name class))) - class)) - -(defmethod make-instance ((class cl:class) &rest stuff) - (apply #'make-instance (coerce-to-pcl-class class) stuff)) -(defmethod change-class (instance (class cl:class) &rest initargs) - (apply #'change-class instance (coerce-to-pcl-class class) initargs)) - -(macrolet ((frob (&rest names) - `(progn - ,@(mapcar (lambda (name) - `(defmethod ,name ((class cl: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)) + (layout-classoid object))) + `(classoid-layout (find-classoid ',pname)))) + +(defmethod make-load-form ((object structure-object) &optional env) + (declare (ignore env)) + (error "~@" + object 'make-load-form)) + +(defmethod make-load-form ((object standard-object) &optional env) + (declare (ignore env)) + (error "~@" + object 'make-load-form)) + +(defmethod make-load-form ((object condition) &optional env) + (declare (ignore env)) + (error "~@" + object 'make-load-form)) + +(defun make-load-form-saving-slots (object &key (slot-names nil slot-names-p) environment) + (declare (ignore environment)) + (let ((class (class-of object))) + (collect ((inits)) + (dolist (slot (class-slots class)) + (let ((slot-name (slot-definition-name slot))) + (when (or (memq slot-name slot-names) + (and (not slot-names-p) + (eq :instance (slot-definition-allocation slot)))) + (if (slot-boundp-using-class class object slot) + (let ((value (slot-value-using-class class object slot))) + (if (typep object 'structure-object) + ;; low-level but less noisy initializer form + ;; FIXME: why not go class->layout->info == dd? + (let* ((dd (find-defstruct-description + (class-name class))) + (dsd (find slot-name (dd-slots dd) + :key #'dsd-name))) + (inits `(,(slot-setter-lambda-form dd dsd) + ',value ,object))) + (inits `(setf (slot-value ,object ',slot-name) ',value)))) + (inits `(slot-makunbound ,object ',slot-name)))))) + (values `(allocate-instance (find-class ',(class-name class))) + `(progn ,@(inits))))))