"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)
(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))
+
+(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))
- (let ((hit
- (dolist (method (generic-function-methods generic-function))
- (let ((mspecializers (method-specializers method)))
- (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"
- generic-function qualifiers specializers)))))
-\f
+ &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))
- (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*))
(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))
(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
(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)
(defvar *standard-slot-value-using-class-method* nil)
(defvar *standard-setf-slot-value-using-class-method* nil)
(defvar *standard-slot-boundp-using-class-method* nil)
+(defvar *condition-slot-value-using-class-method* nil)
+(defvar *condition-setf-slot-value-using-class-method* nil)
+(defvar *condition-slot-boundp-using-class-method* nil)
(defvar *structure-slot-value-using-class-method* nil)
(defvar *structure-setf-slot-value-using-class-method* nil)
(defvar *structure-slot-boundp-using-class-method* nil)
(writer (setq *standard-setf-slot-value-using-class-method* method))
(boundp (setq *standard-slot-boundp-using-class-method* method))))
+(defun condition-svuc-method (type)
+ (case type
+ (reader *condition-slot-value-using-class-method*)
+ (writer *condition-setf-slot-value-using-class-method*)
+ (boundp *condition-slot-boundp-using-class-method*)))
+
+(defun set-condition-svuc-method (type method)
+ (case type
+ (reader (setq *condition-slot-value-using-class-method* method))
+ (writer (setq *condition-setf-slot-value-using-class-method* method))
+ (boundp (setq *condition-slot-boundp-using-class-method* method))))
+
(defun structure-svuc-method (type)
(case type
(reader *structure-slot-value-using-class-method*)
(when (and (or (not (eq type 'writer))
(eq (pop specls) *the-class-t*))
(every #'classp specls))
- (cond ((and (eq (class-name (car specls))
- 'std-class)
- (eq (class-name (cadr specls))
- 'std-object)
+ (cond ((and (eq (class-name (car specls)) 'std-class)
+ (eq (class-name (cadr specls)) 'std-object)
(eq (class-name (caddr specls))
'standard-effective-slot-definition))
(set-standard-svuc-method type method))
- ((and (eq (class-name (car specls))
- 'structure-class)
- (eq (class-name (cadr specls))
- 'structure-object)
+ ((and (eq (class-name (car specls)) 'condition-class)
+ (eq (class-name (cadr specls)) 'condition)
+ (eq (class-name (caddr specls))
+ 'condition-effective-slot-definition))
+ (set-condition-svuc-method type method))
+ ((and (eq (class-name (car specls)) 'structure-class)
+ (eq (class-name (cadr specls)) 'structure-object)
(eq (class-name (caddr specls))
'structure-effective-slot-definition))
(set-structure-svuc-method type method)))))))
(defmacro mlookup (key info default &optional eq-p type)
(unless (or (eq eq-p t) (null eq-p))
- (error "Invalid eq-p argument"))
+ (bug "Invalid eq-p argument: ~S" eq-p))
(ecase type
(:simple
- `(if (,(if eq-p 'eq 'eql) ,key (car ,info))
+ `(if (locally
+ (declare (optimize (inhibit-warnings 3)))
+ (,(if eq-p 'eq 'eql) ,key (car ,info)))
(cdr ,info)
,default))
(:assoc
`(dolist (e ,info ,default)
- (when (,(if eq-p 'eq 'eql) (car e) ,key)
+ (when (locally
+ (declare (optimize (inhibit-warnings 3)))
+ (,(if eq-p 'eq 'eql) (car e) ,key))
(return (cdr e)))))
(:hash-table
`(gethash ,key ,info ,default))))
(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