X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=855c9076893e2cfcf36917e204ce9265d242bb91;hb=22c1de0a40df83bb5628974010a879cb2c17ff53;hp=66d873ef404390d428ca08f9fd3af54420f6488c;hpb=2c668ec79541ced67b8771dc7f41f6028d1f1c43;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 66d873e..855c907 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -89,10 +89,7 @@ "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) @@ -266,30 +263,7 @@ (apply #'call-next-method generic-function initargs))) ||# -;;; 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 @@ -311,28 +285,41 @@ :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 "~@" 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)) + (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 "~@" + generic-function nreq specializers)) + (real-get-method generic-function qualifiers + (parse-specializers specializers) errorp))) ;;; 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 @@ -461,9 +448,9 @@ (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 "~@" 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) @@ -512,7 +499,7 @@ :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)) @@ -820,6 +807,9 @@ (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) @@ -836,6 +826,18 @@ (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*) @@ -854,17 +856,18 @@ (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))))))) @@ -1482,6 +1485,10 @@ (set-dfun gf dfun cache info) ; lest the cache be freed twice (update-dfun gf dfun cache info)))))) +(defmethod (setf class-name) :before (new-value (class class)) + (let ((classoid (find-classoid (class-name class)))) + (setf (classoid-name classoid) new-value))) + (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list (if (consp method)