(defun load-defgeneric (fun-name lambda-list source-location &rest initargs)
(when (fboundp fun-name)
+ (warn 'sb-kernel:redefinition-with-defgeneric
+ :name fun-name
+ :new-location source-location)
(let ((fun (fdefinition fun-name)))
- (warn 'sb-kernel:redefinition-with-defgeneric :name fun-name
- :old fun :new-location source-location)
(when (generic-function-p fun)
(loop for method in (generic-function-initial-methods fun)
do (remove-method fun method))
(simple-lexical-method-functions
(,lambda-list .method-args. .next-methods.
:call-next-method-p
- ,call-next-method-p
+ ,(when call-next-method-p t)
:next-method-p-p ,next-method-p-p
:setq-p ,setq-p
:parameters-setqd ,parameters-setqd
%parameter-binding-modified))
,@walked-lambda-body))))
`(,@(when call-next-method-p `(method-cell ,method-cell))
+ ,@(when (member call-next-method-p '(:simple nil))
+ '(simple-next-method-call t))
,@(when plist `(plist ,plist))
,@(when documentation `(:documentation ,documentation)))))))))))
(,next-methods (cdr ,next-methods)))
(declare (ignorable .next-method. ,next-methods))
(flet (,@(and call-next-method-p
- `((call-next-method
- (&rest cnm-args)
- ,@(if (safe-code-p env)
- `((%check-cnm-args cnm-args
- ,method-args
- ',method-cell))
- nil)
- (if .next-method.
- (funcall (if (std-instance-p .next-method.)
- (method-function .next-method.)
- .next-method.) ; for early methods
- (or cnm-args ,method-args)
- ,next-methods)
- (apply #'call-no-next-method
- ',method-cell
- (or cnm-args ,method-args))))))
+ `((call-next-method (&rest cnm-args)
+ (declare (dynamic-extent cnm-args))
+ ,@(if (safe-code-p env)
+ `((%check-cnm-args cnm-args
+ ,method-args
+ ',method-cell))
+ nil)
+ (if .next-method.
+ (funcall (if (std-instance-p .next-method.)
+ (method-function .next-method.)
+ .next-method.) ; for early methods
+ (or cnm-args ,method-args)
+ ,next-methods)
+ (apply #'call-no-next-method
+ ',method-cell
+ (or cnm-args ,method-args))))))
,@(and next-method-p-p
- '((next-method-p ()
- (not (null .next-method.))))))
+ '((next-method-p ()
+ (not (null .next-method.))))))
,@body))))
(defun call-no-next-method (method-cell &rest args)
`(locally
,@body)
`(flet (,@(when call-next-method-p
- `((call-next-method (&rest cnm-args)
- (declare (muffle-conditions code-deletion-note)
- (optimize (sb-c:insert-step-conditions 0)))
- ,@(if (safe-code-p env)
- `((%check-cnm-args cnm-args (list ,@args)
- ',method-cell))
- nil)
- (fast-call-next-method-body (,args
- ,next-method-call
- ,rest-arg)
+ `((call-next-method (&rest cnm-args)
+ (declare (dynamic-extent cnm-args)
+ (muffle-conditions code-deletion-note)
+ (optimize (sb-c:insert-step-conditions 0)))
+ ,@(if (safe-code-p env)
+ `((%check-cnm-args cnm-args (list ,@args)
+ ',method-cell))
+ nil)
+ (fast-call-next-method-body (,args
+ ,next-method-call
+ ,rest-arg)
,method-cell
cnm-args))))
- ,@(when next-method-p-p
- `((next-method-p ()
- (declare (optimize (sb-c:insert-step-conditions 0)))
- (not (null ,next-method-call))))))
+ ,@(when next-method-p-p
+ `((next-method-p ()
+ (declare (optimize (sb-c:insert-step-conditions 0)))
+ (not (null ,next-method-call))))))
(let ,rebindings
,@(when rebindings `((declare (ignorable ,@all-params))))
,@body)))))
;;; preconditions. That looks hairy and is probably not worth it,
;;; because this check will never be fast.
(defun %check-cnm-args (cnm-args orig-args method-cell)
+ ;; 1. Check for no arguments.
(when cnm-args
(let* ((gf (method-generic-function (car method-cell)))
- (omethods (compute-applicable-methods gf orig-args))
- (nmethods (compute-applicable-methods gf cnm-args)))
- (unless (equal omethods nmethods)
- (error "~@<The set of methods ~S applicable to argument~P ~
- ~{~S~^, ~} to call-next-method is different from ~
- the set of methods ~S applicable to the original ~
- method argument~P ~{~S~^, ~}.~@:>"
- nmethods (length cnm-args) cnm-args omethods
- (length orig-args) orig-args)))))
+ (nreq (generic-function-nreq gf)))
+ (declare (fixnum nreq))
+ ;; 2. Requirement arguments pairwise: if all are EQL, the applicable
+ ;; methods must be the same. This takes care of the relatively common
+ ;; case of twiddling with &KEY arguments without being horribly
+ ;; expensive.
+ (unless (do ((orig orig-args (cdr orig))
+ (args cnm-args (cdr args))
+ (n nreq (1- nreq)))
+ ((zerop n) t)
+ (unless (and orig args (eql (car orig) (car args)))
+ (return nil)))
+ ;; 3. Only then do the full check.
+ (let ((omethods (compute-applicable-methods gf orig-args))
+ (nmethods (compute-applicable-methods gf cnm-args)))
+ (unless (equal omethods nmethods)
+ (error "~@<The set of methods ~S applicable to argument~P ~
+ ~{~S~^, ~} to call-next-method is different from ~
+ the set of methods ~S applicable to the original ~
+ method argument~P ~{~S~^, ~}.~@:>"
+ nmethods (length cnm-args) cnm-args omethods
+ (length orig-args) orig-args)))))))
(defmacro bind-args ((lambda-list args) &body body)
(let ((args-tail '.args-tail.)
;; like :LOAD-TOPLEVEL.
((not (listp form)) form)
((eq (car form) 'call-next-method)
- (setq call-next-method-p t)
+ (setq call-next-method-p (if (cdr form)
+ t
+ :simple))
form)
((eq (car form) 'next-method-p)
(setq next-method-p-p t)
(generic-function-methods gf)
(find-method gf qualifiers specializers nil))))
(when method
- (style-warn 'sb-kernel:redefinition-with-defmethod
- :generic-function gf-spec :old-method method
- :qualifiers qualifiers :specializers specializers
- :new-location source-location))))
+ (warn 'sb-kernel:redefinition-with-defmethod
+ :name gf-spec
+ :new-location source-location
+ :old-method method
+ :qualifiers qualifiers :specializers specializers))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
:definition-source source-location
(values (arg-info-applyp arg-info)
metatypes
arg-info))
- (values (length metatypes) applyp metatypes
- (count-if (lambda (x) (neq x t)) metatypes)
- arg-info)))
+ (let ((nreq 0)
+ (nkeys 0))
+ (declare (fixnum nreq nkeys))
+ (dolist (x metatypes)
+ (incf nreq)
+ (unless (eq x t)
+ (incf nkeys)))
+ (values nreq applyp metatypes
+ nkeys
+ arg-info))))
+
+(defun generic-function-nreq (gf)
+ (let* ((arg-info (if (early-gf-p gf)
+ (early-gf-arg-info gf)
+ (safe-gf-arg-info gf)))
+ (metatypes (arg-info-metatypes arg-info)))
+ (declare (list metatypes))
+ (length metatypes)))
(defun early-make-a-method (class qualifiers arglist specializers initargs doc
&key slot-name object-class method-class-function
projects / sbcl.git / blobdiff