X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=db593a5dd54f4a5c0d152266d743b7011ded3273;hb=2912f5f6c2acb2da3b9fcc0f5afd1ca89782a9f8;hp=5a57f24887041c69f845d2a4b04f64022d2bddb8;hpb=83e5661ae59addac315e6754013b3887b477570f;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 5a57f24..db593a5 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -89,10 +89,7 @@ "is not a non-null atom")) (defmethod legal-slot-name-p ((object standard-method) x) - (cond ((not (symbolp x)) "is not a symbol and so cannot be bound") - ((keywordp x) "is a keyword and so cannot be bound") - ((memq x '(t nil)) "cannot be bound") - ((constantp x) "is a constant and so cannot be bound") + (cond ((not (symbolp x)) "is not a symbol") (t t))) (defmethod legal-specializers-p ((object standard-method) x) @@ -266,30 +263,7 @@ (apply #'call-next-method generic-function initargs))) ||# -;;; These three are scheduled for demolition. - -(defmethod remove-named-method (generic-function-name argument-specifiers - &optional extra) - (let ((generic-function ()) - (method ())) - (cond ((or (null (fboundp generic-function-name)) - (not (generic-function-p - (setq generic-function - (fdefinition generic-function-name))))) - (error "~S does not name a generic function." - generic-function-name)) - ((null (setq method (get-method generic-function - extra - (parse-specializers - argument-specifiers) - nil))) - (error "There is no method for the generic function ~S~%~ - which matches the ARGUMENT-SPECIFIERS ~S." - generic-function - argument-specifiers)) - (t - (remove-method generic-function method))))) - +;;; These two are scheduled for demolition. (defun real-add-named-method (generic-function-name qualifiers specializers @@ -311,28 +285,41 @@ :specializers specs :lambda-list lambda-list other-initargs))) - (add-method generic-function new))) + (add-method generic-function new) + new)) (defun real-get-method (generic-function qualifiers specializers &optional (errorp t)) - (let ((hit + (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)) - (= (length specializers) (length mspecializers)) (every #'same-specializer-p specializers (method-specializers method))) (return method)))))) (cond (hit hit) ((null errorp) nil) (t - (error "no method on ~S with qualifiers ~:S and specializers ~:S" + (error "~@" generic-function qualifiers specializers))))) - + (defmethod find-method ((generic-function standard-generic-function) qualifiers specializers &optional (errorp t)) - (real-get-method generic-function qualifiers - (parse-specializers specializers) errorp)) + (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))) ;;; 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 @@ -422,8 +409,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 @@ -432,25 +418,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*)) @@ -461,9 +447,9 @@ (defun real-add-method (generic-function method &optional skip-dfun-update-p) (when (method-generic-function method) - (error "The method ~S is already part of the generic~@ - function ~S. It can't be added to another generic~@ - function until it is removed from the first one." + (error "~@" method (method-generic-function method))) (flet ((similar-lambda-lists-p (method-a method-b) (multiple-value-bind (a-nreq a-nopt a-keyp a-restp) @@ -507,12 +493,39 @@ (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 :method method) (update-dfun generic-function)) - method))) + generic-function))) (defun real-remove-method (generic-function method) (when (eq generic-function (method-generic-function method)) @@ -652,9 +665,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 @@ -1498,6 +1512,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)