(add-method generic-function new)
new))
+(define-condition find-method-length-mismatch
+ (reference-condition simple-error)
+ ()
+ (:default-initargs :references '(: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 "~@<There is no method on ~S with ~
- ~:[no qualifiers~;~:*qualifiers ~S~] ~
- and specializers ~S.~@:>"
- 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
+ "~@<The generic function ~S takes ~D required argument~:P; ~
+ was asked to find a method with specializers ~S~@:>"
+ :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 "~@<There is no method on ~S with ~
+ ~:[no qualifiers~;~:*qualifiers ~S~] ~
+ and specializers ~S.~@:>"
+ 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 "~@<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)))
+ ;; 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))
\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
(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")))))
\f
(defmethod generic-function-argument-precedence-order
((gf standard-generic-function))
(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*))
(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
projects / sbcl.git / blobdiff