(apply #'call-next-method generic-function initargs)))
||#
\f
-;;; 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
: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 "~@<There is no method on ~S with ~
+ ~:[no qualifiers~;~:*qualifiers ~S~] ~
+ and specializers ~S.~@:>"
generic-function qualifiers specializers)))))
-\f
+
(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 "~@<The generic function ~S takes ~D required argument~:P; ~
+ was asked to find a method with specializers ~S~@:>"
+ generic-function nreq specializers))
+ (real-get-method generic-function qualifiers
+ (parse-specializers specializers) errorp)))
\f
;;; 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
(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
(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*))
(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 "~@<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.~@:>"
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)
(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 "~@<Invalid qualifiers for standard method combination ~
+ in method ~S:~2I~_~S.~@:>"
+ 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 "~@<Invalid qualifiers for ~S method combination ~
+ in method ~S:~2I~_~S.~@:>"
+ 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))
(set-dfun gf dfun cache info) ; lest the cache be freed twice
(update-dfun gf dfun cache info))))))
\f
+(defmethod (setf class-name) :before (new-value (class class))
+ (let ((classoid (find-classoid (class-name class))))
+ (setf (classoid-name classoid) new-value)))
+\f
(defmethod function-keywords ((method standard-method))
(multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
(analyze-lambda-list (if (consp method)
projects / sbcl.git / blobdiff