X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=8d0f176410967f77193f7f6e4e5e5e05e7263874;hb=4cb22853031c89db0da148d16c60d917102a57ed;hp=9f43912edef5246e960ef919c442091a68c77904;hpb=1234f4cd25b2d50dfa2645d66757116e64b7aae2;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 9f43912..8d0f176 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -297,8 +297,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? @@ -317,10 +317,12 @@ &optional (errorp t)) (let ((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))) + (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 @@ -458,12 +460,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 "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) + (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,24 +482,35 @@ 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)))) (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))) @@ -505,11 +526,9 @@ (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-ctors 'remove-method + :generic-function generic-function + :method method) (update-dfun generic-function) generic-function))) @@ -542,8 +561,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) @@ -739,6 +758,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 +784,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) @@ -897,7 +930,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 +943,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*) @@ -1266,7 +1300,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 +1359,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 +1405,7 @@ ;;; (lambda (arg) ;;; (cond ( ;;; -;;; (set-funcallable-instance-fun +;;; (set-funcallable-instance-function ;;; gf ;;; (compute-discriminating-function gf)) ;;; (funcall gf arg)) @@ -1383,7 +1417,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))