(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)
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)))))
+ (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 "~@<The generic function ~S takes ~D required argument~:P; ~
- was asked to find a method with specializers ~S~@:>"
- generic-function nreq specializers))))
+ (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)))
(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))
(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)