X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fenv.lisp;h=f1cf98f59fa45a2614806a82e117c4013ae46803;hb=1737fb209e154d5590223c592a12f540fa0f8cff;hp=d793f9a528c9928d7057198cc4f6d7c86f4a3c97;hpb=9719063b661a99d2cc2a1d9b2ea7dd81145ded59;p=sbcl.git diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp index d793f9a..f1cf98f 100644 --- a/src/pcl/env.lisp +++ b/src/pcl/env.lisp @@ -31,6 +31,34 @@ ;;; 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)))) + (multiple-value-bind (gf-spec quals specls) + (parse-defmethod 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 +81,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 +103,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 +115,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 +136,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,7 +160,7 @@ ;; 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))) @@ -126,39 +168,48 @@ (defmethod make-load-form ((object wrapper) &optional env) (declare (ignore env)) (let ((pname (classoid-proper-name - (layout-classoid object)))) + (layout-classoid object)))) (unless pname (error "can't dump wrapper for anonymous class:~% ~S" - (layout-classoid object))) + (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)) + object 'make-load-form)) (defmethod make-load-form ((object standard-object) &optional env) (declare (ignore env)) (error "~@" - object 'make-load-form)) + object 'make-load-form)) (defmethod make-load-form ((object condition) &optional env) (declare (ignore env)) (error "~@" - object 'make-load-form)) + object 'make-load-form)) -(defun make-load-form-saving-slots (object &key slot-names environment) +(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 (null 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))) - (inits `(setf (slot-value ,object ',slot-name) ',value))) + (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))))))