-(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
- &body body)
- `(macrolet ((narrowed-emf (emf)
- ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to
- ;; dispatch on the possibility that EMF might be of
- ;; type FIXNUM (as an optimized representation of a
- ;; slot accessor). But as far as I (WHN 2002-06-11)
- ;; can tell, it's impossible for such a representation
- ;; to end up as .NEXT-METHOD-CALL. By reassuring
- ;; INVOKE-E-M-F that when called from this context
- ;; it needn't worry about the FIXNUM case, we can
- ;; keep those cases from being compiled, which is
- ;; good both because it saves bytes and because it
- ;; avoids annoying type mismatch compiler warnings.
- ;;
- ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type
- ;; system isn't smart enough about NOT and intersection
- ;; types to benefit from a (NOT FIXNUM) declaration
- ;; here. -- WHN 2002-06-12
- ;;
- ;; FIXME: Might the FUNCTION type be omittable here,
- ;; leaving only METHOD-CALLs? Failing that, could this
- ;; be documented somehow? (It'd be nice if the types
- ;; involved could be understood without solving the
- ;; halting problem.)
- `(the (or function method-call fast-method-call)
- ,emf))
- (call-next-method-bind (&body body)
- `(let () ,@body))
- (call-next-method-body (method-name-declaration cnm-args)
- `(if ,',next-method-call
- ,(locally
- ;; This declaration suppresses a "deleting
- ;; unreachable code" note for the following IF when
- ;; REST-ARG is NIL. It is not nice for debugging
- ;; SBCL itself, but at least it keeps us from
- ;; annoying users.
- (declare (optimize (inhibit-warnings 3)))
- (if (and (null ',rest-arg)
- (consp cnm-args)
- (eq (car cnm-args) 'list))
- `(invoke-effective-method-function
- (narrowed-emf ,',next-method-call)
- nil
- ,@(cdr cnm-args))
- (let ((call `(invoke-effective-method-function
- (narrowed-emf ,',next-method-call)
- ,',(not (null rest-arg))
- ,@',args
- ,@',(when rest-arg `(,rest-arg)))))
- `(if ,cnm-args
- (bind-args ((,@',args
- ,@',(when rest-arg
- `(&rest ,rest-arg)))
- ,cnm-args)
- ,call)
- ,call))))
- ,(locally
- ;; As above, this declaration suppresses code
- ;; deletion notes.
- (declare (optimize (inhibit-warnings 3)))
- (if (and (null ',rest-arg)
- (consp cnm-args)
- (eq (car cnm-args) 'list))
- `(call-no-next-method ',method-name-declaration
- ,@(cdr cnm-args))
- `(call-no-next-method ',method-name-declaration
- ,@',args
- ,@',(when rest-arg
- `(,rest-arg)))))))
- (next-method-p-body ()
- `(not (null ,',next-method-call))))
- ,@body))
-
-(defmacro bind-lexical-method-functions
- ((&key call-next-method-p next-method-p-p
- closurep applyp method-name-declaration)
- &body body)
- (cond ((and (null call-next-method-p) (null next-method-p-p)
- (null closurep)
- (null applyp))
- `(let () ,@body))
- (t
- `(call-next-method-bind
- (flet (,@(and call-next-method-p
- `((call-next-method (&rest cnm-args)
- (call-next-method-body
- ,method-name-declaration
- cnm-args))))
- ,@(and next-method-p-p
- '((next-method-p ()
- (next-method-p-body)))))
- ,@body)))))
+
+(defmacro fast-narrowed-emf (emf)
+ ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to dispatch on
+ ;; the possibility that EMF might be of type FIXNUM (as an optimized
+ ;; representation of a slot accessor). But as far as I (WHN
+ ;; 2002-06-11) can tell, it's impossible for such a representation
+ ;; to end up as .NEXT-METHOD-CALL. By reassuring INVOKE-E-M-F that
+ ;; when called from this context it needn't worry about the FIXNUM
+ ;; case, we can keep those cases from being compiled, which is good
+ ;; both because it saves bytes and because it avoids annoying type
+ ;; mismatch compiler warnings.
+ ;;
+ ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type system isn't smart
+ ;; enough about NOT and intersection types to benefit from a (NOT
+ ;; FIXNUM) declaration here. -- WHN 2002-06-12 (FIXME: maybe it is
+ ;; now... -- CSR, 2003-06-07)
+ ;;
+ ;; FIXME: Might the FUNCTION type be omittable here, leaving only
+ ;; METHOD-CALLs? Failing that, could this be documented somehow?
+ ;; (It'd be nice if the types involved could be understood without
+ ;; solving the halting problem.)
+ `(the (or function method-call fast-method-call)
+ ,emf))
+
+(defmacro fast-call-next-method-body ((args next-method-call rest-arg)
+ method-name-declaration
+ cnm-args)
+ `(if ,next-method-call
+ ,(let ((call `(invoke-effective-method-function
+ (fast-narrowed-emf ,next-method-call)
+ ,(not (null rest-arg))
+ ,@args
+ ,@(when rest-arg `(,rest-arg)))))
+ `(if ,cnm-args
+ (bind-args ((,@args
+ ,@(when rest-arg
+ `(&rest ,rest-arg)))
+ ,cnm-args)
+ ,call)
+ ,call))
+ (call-no-next-method ',method-name-declaration
+ ,@args
+ ,@(when rest-arg
+ `(,rest-arg)))))
+
+(defmacro bind-fast-lexical-method-functions
+ ((args rest-arg next-method-call (&key
+ call-next-method-p
+ setq-p
+ method-name-declaration
+ next-method-p-p
+ closurep
+ applyp))
+ &body body
+ &environment env)
+ (let* ((all-params (append args (when rest-arg (list rest-arg))))
+ (rebindings (when (or setq-p call-next-method-p)
+ (mapcar (lambda (x) (list x x)) all-params))))
+ (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
+ `(locally
+ ,@body)
+ `(flet (,@(when call-next-method-p
+ `((call-next-method (&rest cnm-args)
+ (declare (muffle-conditions code-deletion-note))
+ ,@(if (safe-code-p env)
+ `((%check-cnm-args cnm-args (list ,@args)
+ ',method-name-declaration))
+ nil)
+ (fast-call-next-method-body (,args
+ ,next-method-call
+ ,rest-arg)
+ ,method-name-declaration
+ cnm-args))))
+ ,@(when next-method-p-p
+ `((next-method-p
+ ()
+ (not (null ,next-method-call))))))
+ (let ,rebindings
+ ,@(when rebindings `((declare (ignorable ,@all-params))))
+ ,@body)))))
+
+;;; CMUCL comment (Gerd Moellmann):
+;;;
+;;; The standard says it's an error if CALL-NEXT-METHOD is called with
+;;; arguments, and the set of methods applicable to those arguments is
+;;; different from the set of methods applicable to the original
+;;; method arguments. (According to Barry Margolin, this rule was
+;;; probably added to ensure that before and around methods are always
+;;; run before primary methods.)
+;;;
+;;; This could be optimized for the case that the generic function
+;;; doesn't have hairy methods, does have standard method combination,
+;;; is a standard generic function, there are no methods defined on it
+;;; for COMPUTE-APPLICABLE-METHODS and probably a lot more of such
+;;; 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-name-declaration)
+ (when cnm-args
+ (let* ((gf (fdefinition (caar method-name-declaration)))
+ (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)))))