X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=8cd94face4954b81fa5749366d0d5fb149e7a4d9;hb=3a618201c9f2370bb8784217a866d000371769e5;hp=437e1466a1d368183d69e343187f12e8157cdfb0;hpb=3cc4b17d770f3fe95e5e94f6ac39820784968c4d;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 437e146..8cd94fa 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -289,37 +289,48 @@ new)) (defun real-get-method (generic-function qualifiers specializers - &optional (errorp t)) - (let* ((lspec (length specializers)) - (hit - (dolist (method (generic-function-methods generic-function)) - (let ((mspecializers (method-specializers method))) - (aver (= lspec (length mspecializers))) - (when (and (equal qualifiers (method-qualifiers method)) - (every #'same-specializer-p specializers - (method-specializers method))) - (return method)))))) - (cond (hit hit) - ((null errorp) nil) - (t - (error "~@" - generic-function qualifiers specializers))))) + &optional (errorp t) + always-check-specializers) + (let ((lspec (length specializers)) + (methods (generic-function-methods generic-function))) + (when (or methods always-check-specializers) + (let ((nreq (length (arg-info-metatypes (gf-arg-info generic-function))))) + ;; Since we internally bypass FIND-METHOD by using GET-METHOD + ;; instead we need to to this here or users may get hit by a + ;; failed AVER instead of a sensible error message. + (when (/= lspec nreq) + (error "~@" + generic-function nreq specializers)))) + (let ((hit + (dolist (method methods) + (let ((mspecializers (method-specializers method))) + (aver (= lspec (length mspecializers))) + (when (and (equal qualifiers (method-qualifiers method)) + (every #'same-specializer-p specializers + (method-specializers method))) + (return method)))))) + (cond (hit hit) + ((null errorp) nil) + (t + (error "~@" + generic-function qualifiers specializers)))))) (defmethod find-method ((generic-function standard-generic-function) qualifiers specializers &optional (errorp t)) - (let ((nreq (length (arg-info-metatypes (gf-arg-info generic-function))))) - ;; ANSI: "The specializers argument contains the parameter - ;; specializers for the method. It must correspond in length to - ;; the number of required arguments of the generic function, or an - ;; error is signaled." - (when (/= (length specializers) nreq) - (error "~@" - generic-function nreq specializers)) - (real-get-method generic-function qualifiers - (parse-specializers specializers) errorp))) + ;; ANSI about FIND-METHOD: "The specializers argument contains the + ;; parameter specializers for the method. It must correspond in + ;; length to the number of required arguments of the generic + ;; function, or an error is signaled." + ;; + ;; This error checking is done by REAL-GET-METHOD. + (real-get-method generic-function + qualifiers + (parse-specializers specializers) + errorp + t)) ;;; Compute various information about a generic-function's arglist by looking ;;; at the argument lists of the methods. The hair for trying not to use @@ -409,8 +420,7 @@ (defmethod initialize-instance :after ((gf standard-generic-function) &key (lambda-list nil lambda-list-p) argument-precedence-order) - (with-slots (arg-info) - gf + (with-slots (arg-info) gf (if lambda-list-p (set-arg-info gf :lambda-list lambda-list @@ -419,25 +429,25 @@ (when (arg-info-valid-p arg-info) (update-dfun gf)))) -(defmethod reinitialize-instance :after ((gf standard-generic-function) - &rest args - &key (lambda-list nil lambda-list-p) - (argument-precedence-order - nil argument-precedence-order-p)) - (with-slots (arg-info) - gf - (if lambda-list-p - (if argument-precedence-order-p - (set-arg-info gf - :lambda-list lambda-list - :argument-precedence-order argument-precedence-order) - (set-arg-info gf - :lambda-list lambda-list)) - (set-arg-info gf)) - (when (and (arg-info-valid-p arg-info) - args - (or lambda-list-p (cddr args))) - (update-dfun gf)))) +(defmethod reinitialize-instance :around + ((gf standard-generic-function) &rest args &key + (lambda-list nil lambda-list-p) (argument-precedence-order nil apo-p)) + (let ((old-mc (generic-function-method-combination gf))) + (prog1 (call-next-method) + ;; KLUDGE: EQ is too strong a test. + (unless (eq old-mc (generic-function-method-combination gf)) + (flush-effective-method-cache gf)) + (cond + ((and lambda-list-p apo-p) + (set-arg-info gf + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order)) + (lambda-list-p (set-arg-info gf :lambda-list lambda-list)) + (t (set-arg-info gf))) + (when (and (arg-info-valid-p (gf-arg-info gf)) + (not (null args)) + (or lambda-list-p (cddr args))) + (update-dfun gf))))) (declaim (special *lazy-dfun-compute-p*)) @@ -494,6 +504,33 @@ (setq remove-again-p nil)) (when remove-again-p (remove-method generic-function method)))) + + ;; KLUDGE II: ANSI saith that it is not an error to add a + ;; method with invalid qualifiers to a generic function of the + ;; wrong kind; it's only an error at generic function + ;; invocation time; I dunno what the rationale was, and it + ;; sucks. Nevertheless, it's probably a programmer error, so + ;; let's warn anyway. -- CSR, 2003-08-20 + (let ((mc (generic-function-method-combination generic-functioN))) + (cond + ((eq mc *standard-method-combination*) + (when (and qualifiers + (or (cdr qualifiers) + (not (memq (car qualifiers) + '(:around :before :after))))) + (warn "~@" + method qualifiers))) + ((short-method-combination-p mc) + (let ((mc-name (method-combination-type mc))) + (when (or (null qualifiers) + (cdr qualifiers) + (and (neq (car qualifiers) :around) + (neq (car qualifiers) mc-name))) + (warn "~@" + mc-name method qualifiers)))))) + (unless skip-dfun-update-p (update-ctors 'add-method :generic-function generic-function @@ -639,9 +676,10 @@ (let ((types (mapcar #'class-eq-type classes))) (multiple-value-bind (methods all-applicable-and-sorted-p) (compute-applicable-methods-using-types gf types) - (function-funcall (get-secondary-dispatch-function1 - gf methods types nil t all-applicable-and-sorted-p) - nil (mapcar #'class-wrapper classes))))) + (let ((generator (get-secondary-dispatch-function1 + gf methods types nil t all-applicable-and-sorted-p))) + (make-callable gf methods generator + nil (mapcar #'class-wrapper classes)))))) (defun value-for-caching (gf classes) (let ((methods (compute-applicable-methods-using-types @@ -1485,6 +1523,10 @@ (set-dfun gf dfun cache info) ; lest the cache be freed twice (update-dfun gf dfun cache info)))))) +(defmethod (setf class-name) :before (new-value (class class)) + (let ((classoid (find-classoid (class-name class)))) + (setf (classoid-name classoid) new-value))) + (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list (if (consp method)