(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))
(defun error-need-at-least-n-args (function n)
- (error "~@<The function ~2I~_~S ~I~_requires at least ~W argument~:P.~:>"
- function
- n))
+ (error 'simple-program-error
+ :format-control "~@<The function ~2I~_~S ~I~_requires ~
+ at least ~W argument~:P.~:>"
+ :format-arguments (list function n)))
(defun types-from-args (generic-function arguments &optional type-modifier)
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
(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)