X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fmethods.lisp;h=4b68b67f71a3cfe74c933c6bb6daa18050486cfc;hb=ae47ad0774edd8cb376772ae7e615428295f979e;hp=ab5110e8217289d35745032e9e572268d230a2bc;hpb=5b43e28a5a9f0fcdefc2132840492e2e382876c6;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index ab5110e..4b68b67 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -288,38 +288,58 @@ (add-method generic-function new) new)) +(define-condition find-method-length-mismatch + (reference-condition simple-error) + () + (:default-initargs :references (list '(:ansi-cl :function find-method)))) + (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 + 'find-method-length-mismatch + :format-control + "~@" + :format-arguments (list 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 @@ -386,11 +406,14 @@ (defun make-discriminating-function-arglist (number-required-arguments restp) (nconc (let ((args nil)) (dotimes (i number-required-arguments) - (push (intern (format nil "Discriminating Function Arg ~D" i)) + (push (format-symbol *package* ;; ! is this right? + "Discriminating Function Arg ~D" + i) args)) (nreverse args)) (when restp - `(&rest ,(intern "Discriminating Function &rest Arg"))))) + `(&rest ,(format-symbol *package* + "Discriminating Function &rest Arg"))))) (defmethod generic-function-argument-precedence-order ((gf standard-generic-function)) @@ -409,8 +432,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 +441,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*)) @@ -666,9 +688,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 @@ -690,7 +713,8 @@ (loop (when (atom x) (return (eq x y))) (when (atom y) (return nil)) (unless (eq (car x) (car y)) (return nil)) - (setq x (cdr x) y (cdr y)))) + (setq x (cdr x) + y (cdr y)))) (defvar *std-cam-methods* nil)