(check-slot-name method slot-name)))
(defmethod shared-initialize :after ((method standard-method) slot-names
- &rest initargs &key)
- (declare (ignore slot-names))
+ &rest initargs &key ((method-cell method-cell)))
+ (declare (ignore slot-names method-cell))
(initialize-method-function initargs method))
-
\f
(defvar *the-class-generic-function*
(find-class 'generic-function))
(errorp (error "No generic function named ~S." name))
(t nil))))
-(defun real-add-named-method (generic-function-name
- qualifiers
- specializers
- lambda-list
- &rest other-initargs)
+(defun real-add-named-method (generic-function-name qualifiers
+ specializers lambda-list &rest other-initargs)
(unless (and (fboundp generic-function-name)
(typep (fdefinition generic-function-name) 'generic-function))
(style-warn "implicitly creating new generic function ~S"
generic-function-name
:generic-function-class (class-of existing-gf))
(ensure-generic-function generic-function-name)))
- (specs (parse-specializers specializers))
- (proto (method-prototype-for-gf generic-function-name))
- (new (apply #'make-instance (class-of proto)
- :qualifiers qualifiers
- :specializers specs
- :lambda-list lambda-list
- other-initargs)))
- (add-method generic-function new)
- new))
+ (proto (method-prototype-for-gf generic-function-name)))
+ ;; FIXME: Destructive modification of &REST list.
+ (setf (getf (getf other-initargs 'plist) :name)
+ (make-method-spec generic-function qualifiers specializers))
+ (let ((new (apply #'make-instance (class-of proto)
+ :qualifiers qualifiers :specializers specializers
+ :lambda-list lambda-list other-initargs)))
+ (add-method generic-function new)
+ new)))
(define-condition find-method-length-mismatch
(reference-condition simple-error)
;; 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))
+ (real-get-method
+ generic-function qualifiers
+ ;; ANSI for FIND-METHOD seems to imply that in fact specializers
+ ;; should always be passed in parsed form instead of being parsed
+ ;; at this point. Since there's no ANSI-blessed way of getting an
+ ;; EQL specializer, that seems unnecessarily painful, so we are
+ ;; nice to our users. -- CSR, 2007-06-01
+ (parse-specializers generic-function 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
(= 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))
- (existing (get-method generic-function
- qualifiers
- 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 (and existing (similar-lambda-lists-p existing method))
- (remove-method generic-function existing))
-
- ;; KLUDGE: We have a special case here, as we disallow
- ;; specializations of the NEW-VALUE argument to (SETF
- ;; SLOT-VALUE-USING-CLASS). GET-ACCESSOR-METHOD-FUNCTION is
- ;; the optimizing function here: it precomputes the effective
- ;; method, assuming that there is no dispatch to be done on
- ;; the new-value argument.
- (when (and (eq generic-function #'(setf slot-value-using-class))
- (not (eq *the-class-t* (first specializers))))
- (error 'new-value-specialization
- :method method))
-
- (setf (method-generic-function method) generic-function)
- (pushnew method (generic-function-methods generic-function))
- (dolist (specializer specializers)
- (add-direct-method specializer 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 "~@<Invalid qualifiers for standard method combination ~
- in method ~S:~2I~_~S.~@:>"
- method qualifiers)))
- ((short-method-combination-p mc)
- (let ((mc-name (method-combination-type-name 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))
- (map-dependents generic-function
- (lambda (dep)
- (update-dependent generic-function
- dep 'add-method method)))
- generic-function)))
+ (let ((lock (gf-lock generic-function)))
+ ;; HANDLER-CASE takes care of releasing the lock and enabling
+ ;; interrupts before going forth with the error.
+ (handler-case
+ ;; System lock because interrupts need to be disabled as
+ ;; well: it would be bad to unwind and leave the gf in an
+ ;; inconsistent state.
+ (sb-thread::with-recursive-system-spinlock (lock)
+ (let* ((qualifiers (method-qualifiers method))
+ (specializers (method-specializers method))
+ (existing (get-method generic-function
+ qualifiers
+ 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 (and existing (similar-lambda-lists-p existing method))
+ (remove-method generic-function existing))
+
+ ;; KLUDGE: We have a special case here, as we disallow
+ ;; specializations of the NEW-VALUE argument to (SETF
+ ;; SLOT-VALUE-USING-CLASS). GET-ACCESSOR-METHOD-FUNCTION is
+ ;; the optimizing function here: it precomputes the effective
+ ;; method, assuming that there is no dispatch to be done on
+ ;; the new-value argument.
+ (when (and (eq generic-function #'(setf slot-value-using-class))
+ (not (eq *the-class-t* (first specializers))))
+ (error 'new-value-specialization :method method))
+
+ (setf (method-generic-function method) generic-function)
+ (pushnew method (generic-function-methods generic-function))
+ (dolist (specializer specializers)
+ (add-direct-method specializer 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 "~@<Invalid qualifiers for standard method ~
+ combination in method ~S:~2I~_~S.~@:>"
+ method qualifiers)))
+ ((short-method-combination-p mc)
+ (let ((mc-name (method-combination-type-name 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))
+ (map-dependents generic-function
+ (lambda (dep)
+ (update-dependent generic-function
+ dep 'add-method method)))))
+ (serious-condition (c)
+ (error c)))))
+ generic-function)
(defun real-remove-method (generic-function method)
(when (eq generic-function (method-generic-function method))
- (let* ((name (generic-function-name generic-function))
- (specializers (method-specializers method))
- (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)
- (update-ctors 'remove-method
- :generic-function generic-function
- :method method)
- (update-dfun generic-function)
- (map-dependents generic-function
- (lambda (dep)
- (update-dependent generic-function
- dep 'remove-method method)))))
+ (let ((lock (gf-lock generic-function)))
+ ;; System lock because interrupts need to be disabled as well:
+ ;; it would be bad to unwind and leave the gf in an inconsistent
+ ;; state.
+ (sb-thread::with-recursive-system-spinlock (lock)
+ (let* ((specializers (method-specializers method))
+ (methods (generic-function-methods generic-function))
+ (new-methods (remove method methods)))
+ (setf (method-generic-function method) nil
+ (generic-function-methods generic-function) new-methods)
+ (dolist (specializer (method-specializers method))
+ (remove-direct-method specializer method))
+ (set-arg-info generic-function)
+ (update-ctors 'remove-method
+ :generic-function generic-function
+ :method method)
+ (update-dfun generic-function)
+ (map-dependents generic-function
+ (lambda (dep)
+ (update-dependent generic-function
+ dep 'remove-method method)))))))
generic-function)
\f
(defun compute-applicable-methods-function (generic-function arguments)
(defmethod specializer-class ((specializer eql-specializer))
(class-of (slot-value specializer 'object)))
-;;; KLUDGE: this is needed to allow for user-defined specializers in
-;;; RAISE-METATYPE; however, the list of methods is maintained by
-;;; hand, which is error-prone. We can't just add a method to
-;;; SPECIALIZER-CLASS, or at least not with confidence, as that
-;;; function is used elsewhere in PCL. `STANDARD' here is used in the
-;;; sense of `comes with PCL' rather than `blessed by the
-;;; authorities'. -- CSR, 2007-05-10
-(defmethod standard-specializer-p ((specializer class)) t)
-(defmethod standard-specializer-p ((specializer eql-specializer)) t)
-(defmethod standard-specializer-p ((specializer class-eq-specializer)) t)
-(defmethod standard-specializer-p ((specializer class-prototype-specializer))
- t)
-(defmethod standard-specializer-p ((specializer specializer)) nil)
-
(defun specializer-class-or-nil (specializer)
(and (standard-specializer-p specializer)
(specializer-class specializer)))
(nkeys (arg-info-nkeys arg-info))
(metatypes (arg-info-metatypes arg-info))
(wrappers (unless (eq nkeys 1) (make-list nkeys)))
- (precompute-p (gf-precompute-dfun-and-emf-p arg-info))
- (default '(default)))
+ (precompute-p (gf-precompute-dfun-and-emf-p arg-info)))
(flet ((add-class-list (classes)
(when (or (null new-class) (memq new-class classes))
(let ((%wrappers (get-wrappers-from-classes
nkeys wrappers classes metatypes)))
- (when (and %wrappers
- (eq default (probe-cache cache %wrappers default)))
+ (when (and %wrappers (not (probe-cache cache %wrappers)))
(let ((value (cond ((eq valuep t)
(sdfun-for-caching generic-function
classes))
(eq gf #'slot-boundp-using-class)))
(defmethod compute-discriminating-function ((gf standard-generic-function))
- (with-slots (dfun-state arg-info) gf
+ (let ((dfun-state (slot-value gf 'dfun-state)))
(when (special-case-for-compute-discriminating-function-p gf)
;; if we have a special case for
;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
((eq gf #'slot-boundp-using-class)
(update-slot-value-gf-info gf 'boundp)
#'slot-boundp-using-class-dfun)
- ((gf-precompute-dfun-and-emf-p arg-info)
+ ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info))
(make-final-dfun gf))
(t
(make-initial-dfun gf))))
((gf-precompute-dfun-and-emf-p arg-info)
(multiple-value-bind (dfun cache info)
(make-final-dfun-internal gf)
- (set-dfun gf dfun cache info) ; lest the cache be freed twice
(update-dfun gf dfun cache info))))))
\f
(defmethod (setf class-name) (new-value class)
projects / sbcl.git / blobdiff