(cl-defstruct (cl--generic-method
(:constructor nil)
(:constructor cl--generic-make-method
- (specializers qualifiers uses-cnm function))
+ (specializers qualifiers call-con function))
(:predicate nil))
(specializers nil :read-only t :type list)
(qualifiers nil :read-only t :type (list-of atom))
- ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument
- ;; holding the next-method.
- (uses-cnm nil :read-only t :type boolean)
+ ;; CALL-CON indicates the calling convention expected by FUNCTION:
+ ;; - nil: FUNCTION is just a normal function with no extra arguments for
+ ;; `call-next-method' or `next-method-p' (which it hence can't use).
+ ;; - `curried': FUNCTION is a curried function that first takes the
+ ;; "next combined method" and return the resulting combined method.
+ ;; It can distinguish `next-method-p' by checking if that next method
+ ;; is `cl--generic-isnot-nnm-p'.
+ ;; - t: FUNCTION takes the `call-next-method' function as its first (extra)
+ ;; argument.
+ (call-con nil :read-only t :type symbol)
(function nil :read-only t :type function))
(cl-defstruct (cl--generic
(pcase (macroexpand fun macroenv)
(`#'(lambda ,args . ,body)
(let* ((parsed-body (macroexp-parse-body body))
+ (nm (make-symbol "cl--nm"))
+ (arglist (make-symbol "cl--args"))
(cnm (make-symbol "cl--cnm"))
(nmp (make-symbol "cl--nmp"))
(nbody (macroexpand-all
;; is used.
;; FIXME: Also, optimize the case where call-next-method is
;; only called with explicit arguments.
- (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody)))
- (cons (not (not uses-cnm))
- `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
- ,@(car parsed-body)
- ,(if (not (assq nmp uses-cnm))
- nbody
- `(let ((,nmp (lambda ()
- (cl--generic-isnot-nnm-p ,cnm))))
- ,nbody))))))
+ (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody))
+ (λ-lift (mapcar #'car uses-cnm)))
+ (if (not uses-cnm)
+ (cons nil
+ `#'(lambda (,@args)
+ ,@(car parsed-body)
+ ,nbody))
+ (cons 'curried
+ `#'(lambda (,nm) ;Called when constructing the effective method.
+ (let ((,nmp (if (cl--generic-isnot-nnm-p ,nm)
+ #'always #'ignore)))
+ ;; This `(λ (&rest x) .. (apply (λ (args) ..) x))'
+ ;; dance is needed because we need to get the original
+ ;; args as a list when `cl-call-next-method' is
+ ;; called with no arguments. It's important to
+ ;; capture it as a list since it needs to distinguish
+ ;; the nil case from the absent case in optional
+ ;; arguments and it needs to properly remember the
+ ;; original value if `nbody' mutates some of its
+ ;; formal args.
+ ;; FIXME: This `(λ (&rest ,arglist)' could be skipped
+ ;; when we know `cnm' is always called with args, and
+ ;; it could be implemented more efficiently if `cnm'
+ ;; is always called directly and there are no
+ ;; `&optional' args.
+ (lambda (&rest ,arglist)
+ ,@(let* ((prebody (car parsed-body))
+ (ds (if (stringp (car prebody))
+ prebody
+ (setq prebody (cons nil prebody))))
+ (usage (help-split-fundoc (car ds) nil)))
+ (unless usage
+ (setcar ds (help-add-fundoc-usage (car ds)
+ args)))
+ prebody)
+ (let ((,cnm (lambda (&rest args)
+ (apply ,nm (or args ,arglist)))))
+ ;; This `apply+lambda' basically parses
+ ;; `arglist' according to `args'.
+ ;; A destructuring-bind would do the trick
+ ;; as well when/if it's more efficient.
+ (apply (lambda (,@λ-lift ,@args) ,nbody)
+ ,@λ-lift ,arglist)))))))))
(f (error "Unexpected macroexpansion result: %S" f))))))
(put 'cl-defmethod 'function-documentation
(require 'gv)
(declare-function gv-setter "gv" (name))
(setq name (gv-setter (cadr name))))
- (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
+ (pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda args body)))
`(progn
,(and (get name 'byte-obsolete-info)
- (or (not (fboundp 'byte-compile-warning-enabled-p))
- (byte-compile-warning-enabled-p 'obsolete name))
(let* ((obsolete (get name 'byte-obsolete-info)))
(macroexp-warn-and-return
(macroexp--obsolete-warning name obsolete "generic function")
;; The ",'" is a no-op that pacifies check-declare.
(,'declare-function ,name "")
(cl-generic-define-method ',name ',(nreverse qualifiers) ',args
- ,uses-cnm ,fun)))))
+ ',call-con ,fun)))))
(defun cl--generic-member-method (specializers qualifiers methods)
(while
`(,name ,qualifiers . ,specializers))
;;;###autoload
-(defun cl-generic-define-method (name qualifiers args uses-cnm function)
+(defun cl-generic-define-method (name qualifiers args call-con function)
(pcase-let*
((generic (cl-generic-ensure-function name))
(`(,spec-args . ,_) (cl--generic-split-args args))
spec-arg (cdr spec-arg)))
spec-args))
(method (cl--generic-make-method
- specializers qualifiers uses-cnm function))
+ specializers qualifiers call-con function))
(mt (cl--generic-method-table generic))
(me (cl--generic-member-method specializers qualifiers mt))
(dispatches (cl--generic-dispatches generic))
(list (cl--generic-name generic)))
f))))
-(defun cl--generic-no-next-method-function (generic method)
- (lambda (&rest args)
- (apply #'cl-no-next-method generic method args)))
+(oclosure-define (cl--generic-nnm)
+ "Special type for `call-next-method's that just call `no-next-method'.")
(defun cl-generic-call-method (generic method &optional fun)
"Return a function that calls METHOD.
FUN is the function that should be called when METHOD calls
`call-next-method'."
- (if (not (cl--generic-method-uses-cnm method))
- (cl--generic-method-function method)
- (let ((met-fun (cl--generic-method-function method))
- (next (or fun (cl--generic-no-next-method-function
- generic method))))
- (lambda (&rest args)
- (apply met-fun
- ;; FIXME: This sucks: passing just `next' would
- ;; be a lot more efficient than the lambda+apply
- ;; quasi-η, but we need this to implement the
- ;; "if call-next-method is called with no
- ;; arguments, then use the previous arguments".
- (lambda (&rest cnm-args)
- (apply next (or cnm-args args)))
- args)))))
+ (let ((met-fun (cl--generic-method-function method)))
+ (pcase (cl--generic-method-call-con method)
+ ('nil met-fun)
+ ('curried
+ (funcall met-fun (or fun
+ (oclosure-lambda (cl--generic-nnm) (&rest args)
+ (apply #'cl-no-next-method generic method
+ args)))))
+ ;; FIXME: backward compatibility with old convention for `.elc' files
+ ;; compiled before the `curried' convention.
+ (_
+ (lambda (&rest args)
+ (apply met-fun
+ (if fun
+ ;; FIXME: This sucks: passing just `next' would
+ ;; be a lot more efficient than the lambda+apply
+ ;; quasi-η, but we need this to implement the
+ ;; "if call-next-method is called with no
+ ;; arguments, then use the previous arguments".
+ (lambda (&rest cnm-args)
+ (apply fun (or cnm-args args)))
+ (oclosure-lambda (cl--generic-nnm) (&rest cnm-args)
+ (apply #'cl-no-next-method generic method
+ (or cnm-args args))))
+ args))))))
;; Standard CLOS name.
(defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers)
"Standard support for :after, :before, :around, and `:extra NAME' qualifiers."
(cl--generic-standard-method-combination generic methods))
-(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t))
-(defconst cl--generic-cnm-sample
- (funcall (cl--generic-build-combined-method
- nil (list (cl--generic-make-method () () t #'identity)))))
-
(defun cl--generic-isnot-nnm-p (cnm)
"Return non-nil if CNM is the function that calls `cl-no-next-method'."
- ;; ¡Big Gross Ugly Hack!
- ;; `next-method-p' just sucks, we should let it die. But EIEIO did support
- ;; it, and some packages use it, so we need to support it.
- (catch 'found
- (cl-assert (function-equal cnm cl--generic-cnm-sample))
- (if (byte-code-function-p cnm)
- (let ((cnm-constants (aref cnm 2))
- (sample-constants (aref cl--generic-cnm-sample 2)))
- (dotimes (i (length sample-constants))
- (when (function-equal (aref sample-constants i)
- cl--generic-nnm-sample)
- (throw 'found
- (not (function-equal (aref cnm-constants i)
- cl--generic-nnm-sample))))))
- (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample)))
- (let ((cnm-env (cadr cnm)))
- (dolist (vb (cadr cl--generic-cnm-sample))
- (when (function-equal (cdr vb) cl--generic-nnm-sample)
- (throw 'found
- (not (function-equal (cdar cnm-env)
- cl--generic-nnm-sample))))
- (setq cnm-env (cdr cnm-env)))))
- (error "Haven't found no-next-method-sample in cnm-sample")))
+ (not (eq (oclosure-type cnm) 'cl--generic-nnm)))
;;; Define some pre-defined generic functions, used internally.
(defun cl--generic-method-info (method)
(let* ((specializers (cl--generic-method-specializers method))
(qualifiers (cl--generic-method-qualifiers method))
- (uses-cnm (cl--generic-method-uses-cnm method))
+ (call-con (cl--generic-method-call-con method))
(function (cl--generic-method-function method))
- (args (help-function-arglist function 'names))
+ (args (help-function-arglist (if (not (eq call-con 'curried))
+ function
+ (funcall function #'ignore))
+ 'names))
(docstring (documentation function))
(qual-string
(if (null qualifiers) ""
(let ((split (help-split-fundoc docstring nil)))
(if split (cdr split) docstring))))
(combined-args ()))
- (if uses-cnm (setq args (cdr args)))
+ (if (eq t call-con) (setq args (cdr args)))
(dolist (specializer specializers)
(let ((arg (if (eq '&rest (car args))
(intern (format "arg%d" (length combined-args)))
projects / emacs.git / commitdiff