X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=db593a5dd54f4a5c0d152266d743b7011ded3273;hb=2912f5f6c2acb2da3b9fcc0f5afd1ca89782a9f8;hp=9f43912edef5246e960ef919c442091a68c77904;hpb=1234f4cd25b2d50dfa2645d66757116e64b7aae2;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 9f43912..db593a5 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 @@ -297,8 +271,8 @@ &rest other-initargs) (unless (and (fboundp generic-function-name) (typep (fdefinition generic-function-name) 'generic-function)) - (sb-kernel::style-warn "implicitly creating new generic function ~S" - generic-function-name)) + (style-warn "implicitly creating new generic function ~S" + generic-function-name)) ;; XXX What about changing the class of the generic function if ;; there is one? Whose job is that, anyway? Do we need something ;; kind of like CLASS-FOR-REDEFINITION? @@ -311,26 +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)) - (when (and (equal qualifiers (method-qualifiers method)) - (every #'same-specializer-p specializers - (method-specializers method))) - (return method))))) + (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 "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 @@ -420,8 +409,7 @@ (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 @@ -430,25 +418,25 @@ (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*)) @@ -458,12 +446,20 @@ (real-add-method gf (pop methods) methods))) (defun real-add-method (generic-function method &optional skip-dfun-update-p) - (if (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." - method (method-generic-function method)) - + (when (method-generic-function method) + (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) + (analyze-lambda-list (method-lambda-list method-a)) + (multiple-value-bind (b-nreq b-nopt b-keyp b-restp) + (analyze-lambda-list (method-lambda-list method-b)) + (and (= a-nreq b-nreq) + (= a-nopt b-nopt) + (eq (or a-keyp a-restp) + (or b-keyp b-restp))))))) (let* ((name (generic-function-name generic-function)) (qualifiers (method-qualifiers method)) (specializers (method-specializers method)) @@ -472,46 +468,81 @@ specializers nil))) - ;; If there is already a method like this one then we must - ;; get rid of it before proceeding. Note that we call the - ;; generic function remove-method to remove it rather than - ;; doing it in some internal way. - (when existing (remove-method generic-function existing)) + ;; If there is already a method like this one then we must get + ;; rid of it before proceeding. Note that we call the generic + ;; function REMOVE-METHOD to remove it rather than doing it in + ;; some internal way. + (when (and existing (similar-lambda-lists-p existing method)) + (remove-method generic-function existing)) (setf (method-generic-function method) generic-function) (pushnew method (generic-function-methods generic-function)) (dolist (specializer specializers) (add-direct-method specializer method)) - (set-arg-info generic-function :new-method method) + + ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for + ;; detecting attempts to add methods with incongruent lambda + ;; lists. However, according to Gerd Moellmann on cmucl-imp, + ;; it also depends on the new method already having been added + ;; to the generic function. Therefore, we need to remove it + ;; again on error: + (let ((remove-again-p t)) + (unwind-protect + (progn + (set-arg-info generic-function :new-method method) + (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 "~@" + 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 "~@" + mc-name method qualifiers)))))) + (unless skip-dfun-update-p - (when (member name - '(make-instance default-initargs - allocate-instance shared-initialize - initialize-instance)) - (update-make-instance-function-table (type-class - (car specializers)))) + (update-ctors 'add-method + :generic-function generic-function + :method method) (update-dfun generic-function)) - method))) + generic-function))) (defun real-remove-method (generic-function method) - ;; Note: Error check prohibited by ANSI spec removed. (when (eq generic-function (method-generic-function method)) - (let* ((name (generic-function-name generic-function)) + (let* ((name (generic-function-name generic-function)) (specializers (method-specializers method)) - (methods (generic-function-methods generic-function)) - (new-methods (remove method methods))) + (methods (generic-function-methods generic-function)) + (new-methods (remove method methods))) (setf (method-generic-function method) nil) (setf (generic-function-methods generic-function) new-methods) (dolist (specializer (method-specializers method)) (remove-direct-method specializer method)) (set-arg-info generic-function) - (when (member name - '(make-instance - default-initargs - allocate-instance shared-initialize initialize-instance)) - (update-make-instance-function-table (type-class (car specializers)))) - (update-dfun generic-function) - generic-function))) + (update-ctors 'remove-method + :generic-function generic-function + :method method) + (update-dfun generic-function))) + generic-function) (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types @@ -542,8 +573,8 @@ (pushnew other-class (class-incompatible-superclass-list class)))))) (defun superclasses-compatible-p (class1 class2) - (let ((cpl1 (class-precedence-list class1)) - (cpl2 (class-precedence-list class2))) + (let ((cpl1 (cpl-or-nil class1)) + (cpl2 (cpl-or-nil class2))) (dolist (sc1 cpl1 t) (dolist (ic (class-incompatible-superclass-list sc1)) (when (memq ic cpl2) @@ -634,9 +665,10 @@ (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 @@ -739,6 +771,22 @@ *standard-method-combination*)) type))))) + +;;; CMUCL (Gerd's PCL, 2002-04-25) comment: +;;; +;;; Return two values. First value is a function to be stored in +;;; effective slot definition SLOTD for reading it with +;;; SLOT-VALUE-USING-CLASS, setting it with (SETF +;;; SLOT-VALUE-USING-CLASS) or testing it with +;;; SLOT-BOUNDP-USING-CLASS. GF is one of these generic functions, +;;; TYPE is one of the symbols READER, WRITER, BOUNDP. CLASS is +;;; SLOTD's class. +;;; +;;; Second value is true if the function returned is one of the +;;; optimized standard functions for the purpose, which are used +;;; when only standard methods are applicable. +;;; +;;; FIXME: Change all these wacky function names to something sane. (defun get-accessor-method-function (gf type class slotd) (let* ((std-method (standard-svuc-method type)) (str-method (structure-svuc-method type)) @@ -749,27 +797,25 @@ (values (if std-p (get-optimized-std-accessor-method-function class slotd type) - (get-accessor-from-svuc-method-function - class slotd - (get-secondary-dispatch-function - gf methods types - `((,(car (or (member std-method methods) - (member str-method methods) - (error "error in get-accessor-method-function"))) - ,(get-optimized-std-slot-value-using-class-method-function - class slotd type))) - (unless (and (eq type 'writer) - (dolist (method methods t) - (unless (eq (car (method-specializers method)) - *the-class-t*) - (return nil)))) - (let ((wrappers (list (wrapper-of class) - (class-wrapper class) - (wrapper-of slotd)))) - (if (eq type 'writer) - (cons (class-wrapper *the-class-t*) wrappers) - wrappers)))) - type)) + (let* ((optimized-std-fun + (get-optimized-std-slot-value-using-class-method-function + class slotd type)) + (method-alist + `((,(car (or (member std-method methods) + (member str-method methods) + (bug "error in ~S" + 'get-accessor-method-function))) + ,optimized-std-fun))) + (wrappers + (let ((wrappers (list (wrapper-of class) + (class-wrapper class) + (wrapper-of slotd)))) + (if (eq type 'writer) + (cons (class-wrapper *the-class-t*) wrappers) + wrappers))) + (sdfun (get-secondary-dispatch-function + gf methods types method-alist wrappers))) + (get-accessor-from-svuc-method-function class slotd sdfun type))) std-p))) ;;; used by OPTIMIZE-SLOT-VALUE-BY-CLASS-P (vector.lisp) @@ -788,6 +834,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) @@ -804,6 +853,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*) @@ -822,17 +883,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))))))) @@ -897,7 +959,7 @@ ((eq valuep :constant-value) (value-for-caching generic-function classes))))) - (setq cache (fill-cache cache wrappers value t)))))))) + (setq cache (fill-cache cache wrappers value)))))))) (if classes-list (mapc #'add-class-list classes-list) (dolist (method (generic-function-methods generic-function)) @@ -910,7 +972,8 @@ (cond ((eq class *the-class-t*) t) ((eq class *the-class-slot-object*) - `(not (cl:typep (cl:class-of ,arg) 'cl:built-in-class))) + `(not (typep (classoid-of ,arg) + 'built-in-classoid))) ((eq class *the-class-std-object*) `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) ((eq class *the-class-standard-object*) @@ -1149,15 +1212,19 @@ (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)))) @@ -1266,7 +1333,7 @@ (make-fast-method-call-lambda-list metatypes applyp)))) (multiple-value-bind (cfunction constants) (get-fun1 `(,(if function-p - 'sb-kernel:instance-lambda + 'instance-lambda 'lambda) ,arglist ,@(unless function-p @@ -1325,12 +1392,12 @@ ;;; the funcallable instance function of the generic function for which ;;; it was computed. ;;; -;;; More precisely, if compute-discriminating-function is called with an -;;; argument , and returns a result , that result must not be -;;; passed to apply or funcall directly. Rather, must be stored as -;;; the funcallable instance function of the same generic function -;;; (using set-funcallable-instance-fun). Then the generic function -;;; can be passed to funcall or apply. +;;; More precisely, if compute-discriminating-function is called with +;;; an argument , and returns a result , that result must +;;; not be passed to apply or funcall directly. Rather, must be +;;; stored as the funcallable instance function of the same generic +;;; function (using SET-FUNCALLABLE-INSTANCE-FUNCTION). Then the +;;; generic function can be passed to funcall or apply. ;;; ;;; An important exception is that methods on this generic function are ;;; permitted to return a function which itself ends up calling the value @@ -1371,7 +1438,7 @@ ;;; (lambda (arg) ;;; (cond ( ;;; -;;; (set-funcallable-instance-fun +;;; (set-funcallable-instance-function ;;; gf ;;; (compute-discriminating-function gf)) ;;; (funcall gf arg)) @@ -1383,7 +1450,7 @@ ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; (lambda (arg) ;;; (cond ( -;;; (set-funcallable-instance-fun +;;; (set-funcallable-instance-function ;;; gf ;;; (lambda (a) ..)) ;;; (funcall gf arg)) @@ -1445,6 +1512,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)