X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=d0e5c0484b3bf1f583e3bde17b6462d2cdf0c8d8;hb=447477e72bd4fe54e678a28bdcc4a2802797d6ed;hp=92e94b83f221d2e52660660e331294d766a7dcd5;hpb=bb8121bf453353ce2cadc85d9be7be05ca6248ff;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 92e94b8..d0e5c04 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -23,23 +23,13 @@ (in-package "SB-PCL") - ;;; methods ;;; ;;; Methods themselves are simple inanimate objects. Most properties of ;;; methods are immutable, methods cannot be reinitialized. The following ;;; properties of methods can be changed: ;;; METHOD-GENERIC-FUNCTION -;;; METHOD-FUNCTION ?? - -(defmethod method-function ((method standard-method)) - (or (slot-value method '%function) - (let ((fmf (slot-value method 'fast-function))) - (unless fmf ; The :BEFORE SHARED-INITIALIZE method prevents this. - (error "~S doesn't seem to have a METHOD-FUNCTION." method)) - (setf (slot-value method '%function) - (method-function-from-fast-function fmf))))) - + ;;; initialization ;;; ;;; Error checking is done in before methods. Because of the simplicity of @@ -139,7 +129,7 @@ (defmethod shared-initialize :before ((method standard-method) slot-names &key - qualifiers lambda-list specializers function fast-function documentation) + qualifiers lambda-list specializers function documentation) (declare (ignore slot-names)) ;; FIXME: it's not clear to me (CSR, 2006-08-09) why methods get ;; this extra paranoia and nothing else does; either everything @@ -151,7 +141,7 @@ (check-qualifiers method qualifiers) (check-lambda-list method lambda-list) (check-specializers method specializers) - (check-method-function method (or function fast-function)) + (check-method-function method function) (check-documentation method documentation)) (defmethod shared-initialize :before @@ -162,17 +152,10 @@ (check-slot-name method slot-name))) (defmethod shared-initialize :after ((method standard-method) slot-names - &rest initargs - &key qualifiers method-spec plist) - (declare (ignore slot-names method-spec plist)) - (initialize-method-function initargs nil method) - (setf (plist-value method 'qualifiers) qualifiers) - #+ignore - (setf (slot-value method 'closure-generator) - (method-function-closure-generator (slot-value method '%function)))) - -(defmethod method-qualifiers ((method standard-method)) - (plist-value method 'qualifiers)) + &rest initargs &key) + (declare (ignore slot-names)) + (initialize-method-function initargs method)) + (defvar *the-class-generic-function* (find-class 'generic-function)) @@ -226,36 +209,14 @@ (initarg-error :method-combination "not supplied" "a method combination object"))))) - -#|| -(defmethod reinitialize-instance ((generic-function standard-generic-function) - &rest initargs - &key name - lambda-list - argument-precedence-order - declarations - documentation - method-class - method-combination) - (declare (ignore documentation declarations argument-precedence-order - lambda-list name method-class method-combination)) - (macrolet ((add-initarg (check name slot-name) - `(unless ,check - (push (slot-value generic-function ,slot-name) initargs) - (push ,name initargs)))) -; (add-initarg name :name 'name) -; (add-initarg lambda-list :lambda-list 'lambda-list) -; (add-initarg argument-precedence-order -; :argument-precedence-order -; 'argument-precedence-order) -; (add-initarg declarations :declarations 'declarations) -; (add-initarg documentation :documentation '%documentation) -; (add-initarg method-class :method-class 'method-class) -; (add-initarg method-combination :method-combination '%method-combination) - (apply #'call-next-method generic-function initargs))) -||# -;;; These two are scheduled for demolition. +(defun find-generic-function (name &optional (errorp t)) + (let ((fun (and (fboundp name) (fdefinition name)))) + (cond + ((and fun (typep fun 'generic-function)) fun) + (errorp (error "No generic function named ~S." name)) + (t nil)))) + (defun real-add-named-method (generic-function-name qualifiers specializers @@ -265,11 +226,13 @@ (typep (fdefinition generic-function-name) 'generic-function)) (style-warn "implicitly creating new generic function ~S" generic-function-name)) - ;; XXX What about changing the class of the generic function if - ;; there is one? Whose job is that, anyway? Do we need something - ;; kind of like CLASS-FOR-REDEFINITION? - (let* ((generic-function - (ensure-generic-function generic-function-name)) + (let* ((existing-gf (find-generic-function generic-function-name nil)) + (generic-function + (if existing-gf + (ensure-generic-function + generic-function-name + :generic-function-class (class-of existing-gf)) + (ensure-generic-function generic-function-name))) (specs (parse-specializers specializers)) (proto (method-prototype-for-gf generic-function-name)) (new (apply #'make-instance (class-of proto) @@ -666,15 +629,6 @@ (defmethod specializer-class ((specializer eql-specializer)) (class-of (slot-value specializer 'object))) -(defvar *in-gf-arg-info-p* nil) -(setf (gdefinition 'arg-info-reader) - (let ((mf (initialize-method-function - (make-internal-reader-method-function - 'standard-generic-function 'arg-info) - t))) - (lambda (&rest args) (funcall mf args nil)))) - - (defun error-need-at-least-n-args (function n) (error 'simple-program-error :format-control "~@