X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=9bf5e04747cb26cc0945fcc9de21f13ad838f8b9;hb=cf0b72cd4052a09b9a305081524bd44e2948c1e5;hp=92e94b83f221d2e52660660e331294d766a7dcd5;hpb=bb8121bf453353ce2cadc85d9be7be05ca6248ff;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 92e94b8..9bf5e04 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) @@ -647,7 +610,7 @@ )) (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer)) - nil) + (eql specl1 specl2)) (defmethod same-specializer-p ((specl1 class) (specl2 class)) (eq specl1 specl2)) @@ -666,14 +629,23 @@ (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)))) - +;;; KLUDGE: this is needed to allow for user-defined specializers in +;;; RAISE-METATYPE; however, the list of methods is maintained by +;;; hand, which is error-prone. We can't just add a method to +;;; SPECIALIZER-CLASS, or at least not with confidence, as that +;;; function is used elsewhere in PCL. `STANDARD' here is used in the +;;; sense of `comes with PCL' rather than `blessed by the +;;; authorities'. -- CSR, 2007-05-10 +(defmethod standard-specializer-p ((specializer class)) t) +(defmethod standard-specializer-p ((specializer eql-specializer)) t) +(defmethod standard-specializer-p ((specializer class-eq-specializer)) t) +(defmethod standard-specializer-p ((specializer class-prototype-specializer)) + t) +(defmethod standard-specializer-p ((specializer specializer)) nil) + +(defun specializer-class-or-nil (specializer) + (and (standard-specializer-p specializer) + (specializer-class specializer))) (defun error-need-at-least-n-args (function n) (error 'simple-program-error @@ -720,9 +692,7 @@ (defun value-for-caching (gf classes) (let ((methods (compute-applicable-methods-using-types gf (mapcar #'class-eq-type classes)))) - (method-function-get (or (safe-method-fast-function (car methods)) - (safe-method-function (car methods))) - :constant-value))) + (method-plist-value (car methods) :constant-value))) (defun default-secondary-dispatch-function (generic-function) (lambda (&rest args) @@ -872,13 +842,13 @@ (unless *new-class* (update-std-or-str-methods gf type)) (when (and (standard-svuc-method type) (structure-svuc-method type)) - (flet ((update-class (class) + (flet ((update-accessor-info (class) (when (class-finalized-p class) (dolist (slotd (class-slots class)) (compute-slot-accessor-info slotd type gf))))) (if *new-class* - (update-class *new-class*) - (map-all-classes #'update-class 'slot-object))))) + (update-accessor-info *new-class*) + (map-all-classes #'update-accessor-info 'slot-object))))) (defvar *standard-slot-value-using-class-method* nil) (defvar *standard-setf-slot-value-using-class-method* nil) @@ -995,14 +965,12 @@ (nkeys (arg-info-nkeys arg-info)) (metatypes (arg-info-metatypes arg-info)) (wrappers (unless (eq nkeys 1) (make-list nkeys))) - (precompute-p (gf-precompute-dfun-and-emf-p arg-info)) - (default '(default))) + (precompute-p (gf-precompute-dfun-and-emf-p arg-info))) (flet ((add-class-list (classes) (when (or (null new-class) (memq new-class classes)) (let ((%wrappers (get-wrappers-from-classes nkeys wrappers classes metatypes))) - (when (and %wrappers - (eq default (probe-cache cache %wrappers default))) + (when (and %wrappers (not (probe-cache cache %wrappers))) (let ((value (cond ((eq valuep t) (sdfun-for-caching generic-function classes)) @@ -1291,7 +1259,8 @@ (if (atom form) (default-test-converter form) (case (car form) - ((invoke-effective-method-function invoke-fast-method-call) + ((invoke-effective-method-function invoke-fast-method-call + invoke-effective-narrow-method-function) '.call.) (methods '.methods.) @@ -1384,20 +1353,20 @@ (let* ((name (generic-function-name generic-function)) (arg-info (gf-arg-info generic-function)) (metatypes (arg-info-metatypes arg-info)) + (nargs (length metatypes)) (applyp (arg-info-applyp arg-info)) - (fmc-arg-info (cons (length metatypes) applyp)) + (fmc-arg-info (cons nargs applyp)) (arglist (if function-p - (make-dfun-lambda-list metatypes applyp) - (make-fast-method-call-lambda-list metatypes applyp)))) + (make-dfun-lambda-list nargs applyp) + (make-fast-method-call-lambda-list nargs applyp)))) (multiple-value-bind (cfunction constants) (get-fun1 `(lambda ,arglist ,@(unless function-p - `((declare (ignore .pv-cell. - .next-method-call.)))) + `((declare (ignore .pv-cell. .next-method-call.)))) (locally (declare #.*optimize-speed*) (let ((emf ,net)) - ,(make-emf-call metatypes applyp 'emf)))) + ,(make-emf-call nargs applyp 'emf)))) #'net-test-converter #'net-code-converter (lambda (form) @@ -1570,11 +1539,10 @@ ((gf-precompute-dfun-and-emf-p arg-info) (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf) - (set-dfun gf dfun cache info) ; lest the cache be freed twice (update-dfun gf dfun cache info)))))) (defmethod (setf class-name) (new-value class) - (let ((classoid (%wrapper-classoid (class-wrapper class)))) + (let ((classoid (wrapper-classoid (class-wrapper class)))) (if (and new-value (symbolp new-value)) (setf (classoid-name classoid) new-value) (setf (classoid-name classoid) nil)))