- (let* ((create-cnm-macros (apply #'create-call-next-method-macros-p
- lmf-options))
- (all-params (append args (when rest-arg (list rest-arg))))
- (rebindings (mapcar (lambda (x) (list x x)) all-params)))
- (if (not create-cnm-macros)
- `(locally ,@body)
- (let ((narrowed-emf
- `(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)))
- (bind `(call-next-method-bind
- (&body body)
- `(let () ,@body)))
- (check `(check-cnm-args-body
- (&environment env method-name-declaration cnm-args)
- (if (safe-code-p env)
- `(%check-cnm-args ,cnm-args (list ,@',args)
- ',method-name-declaration)
- nil)))
- (call-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-body `(next-method-p-body
+ (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