(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))
(initarg-error :method-combination
"not supplied"
"a method combination object")))))
-
-#||
-(defmethod reinitialize-instance ((generic-function standard-generic-function)
- &rest initargs
- &key name
- lambda-list
- argument-precedence-order
- declarations
- documentation
- method-class
- method-combination)
- (declare (ignore documentation declarations argument-precedence-order
- lambda-list name method-class method-combination))
- (macrolet ((add-initarg (check name slot-name)
- `(unless ,check
- (push (slot-value generic-function ,slot-name) initargs)
- (push ,name initargs))))
-; (add-initarg name :name 'name)
-; (add-initarg lambda-list :lambda-list 'lambda-list)
-; (add-initarg argument-precedence-order
-; :argument-precedence-order
-; 'argument-precedence-order)
-; (add-initarg declarations :declarations 'declarations)
-; (add-initarg documentation :documentation '%documentation)
-; (add-initarg method-class :method-class 'method-class)
-; (add-initarg method-combination :method-combination '%method-combination)
- (apply #'call-next-method generic-function initargs)))
-||#
\f
-;;; These two are scheduled for demolition.
-(defun real-add-named-method (generic-function-name
- qualifiers
- specializers
- lambda-list
- &rest other-initargs)
+(defun find-generic-function (name &optional (errorp t))
+ (let ((fun (and (fboundp name) (fdefinition name))))
+ (cond
+ ((and fun (typep fun 'generic-function)) fun)
+ (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)
(unless (and (fboundp generic-function-name)
(typep (fdefinition generic-function-name) 'generic-function))
(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?
- (let* ((generic-function
- (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))
+ (let* ((existing-gf (find-generic-function generic-function-name nil))
+ (generic-function
+ (if existing-gf
+ (ensure-generic-function
+ generic-function-name
+ :generic-function-class (class-of existing-gf))
+ (ensure-generic-function generic-function-name)))
+ (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)
))
\f
(defmethod same-specializer-p ((specl1 specializer) (specl2 specializer))
- nil)
+ (eql specl1 specl2))
(defmethod same-specializer-p ((specl1 class) (specl2 class))
(eq specl1 specl2))
(defmethod specializer-class ((specializer eql-specializer))
(class-of (slot-value specializer 'object)))
+(defun specializer-class-or-nil (specializer)
+ (and (standard-specializer-p specializer)
+ (specializer-class specializer)))
+
(defun error-need-at-least-n-args (function n)
(error 'simple-program-error
:format-control "~@<The function ~2I~_~S ~I~_requires ~
(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))
(if (atom form)
(default-test-converter form)
(case (car form)
- ((invoke-effective-method-function invoke-fast-method-call)
+ ((invoke-effective-method-function invoke-fast-method-call
+ invoke-effective-narrow-method-function)
'.call.)
(methods
'.methods.)
(let* ((name (generic-function-name generic-function))
(arg-info (gf-arg-info generic-function))
(metatypes (arg-info-metatypes arg-info))
+ (nargs (length metatypes))
(applyp (arg-info-applyp arg-info))
- (fmc-arg-info (cons (length metatypes) applyp))
+ (fmc-arg-info (cons nargs applyp))
(arglist (if function-p
- (make-dfun-lambda-list metatypes applyp)
- (make-fast-method-call-lambda-list metatypes applyp))))
+ (make-dfun-lambda-list nargs applyp)
+ (make-fast-method-call-lambda-list nargs applyp))))
(multiple-value-bind (cfunction constants)
(get-fun1 `(lambda
,arglist
,@(unless function-p
- `((declare (ignore .pv-cell.
- .next-method-call.))))
+ `((declare (ignore .pv-cell. .next-method-call.))))
(locally (declare #.*optimize-speed*)
(let ((emf ,net))
- ,(make-emf-call metatypes applyp 'emf))))
+ ,(make-emf-call nargs applyp 'emf))))
#'net-test-converter
#'net-code-converter
(lambda (form)
(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)
- (let ((classoid (%wrapper-classoid (class-wrapper class))))
+ (let ((classoid (wrapper-classoid (class-wrapper class))))
(if (and new-value (symbolp new-value))
(setf (classoid-name classoid) new-value)
(setf (classoid-name classoid) nil)))