Commit f1b7ad19 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* lisp/emacs-lisp/cl-generic.el: Add a calling convention

Introduce a new calling convention for the methods, which should
make `cl-call-next-method` a bit less costly.

(cl--generic-method): Rename `uses-cnm` slot to `call-con`.
(cl-defmethod): Adjust accordingly.
(cl--generic-lambda): Use the new `curried` calling convention.
(cl-generic-call-method): Implement the new `curried` calling convention.
(cl--generic-method-info): Adjust to the new `curried` calling convention.

* lisp/org/org-attach.el (org-attach): Silence warning.
parent f75ee15e
......@@ -144,13 +144,20 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG
(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
......@@ -389,6 +396,8 @@ the specializer used will be the one returned by BODY."
(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
......@@ -401,15 +410,41 @@ the specializer used will be the one returned by BODY."
;; 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)))
;; The `(λ (&rest x) .. (apply (λ (args) ..) x))'
;; dance is needed because we need to 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)
,@(car parsed-body)
(let ((,cnm (lambda (&rest args)
(apply ,nm (or args ,arglist)))))
;; This `apply+lambda' basically parses
;; `the `arglist' accordingly to `args'.
;; FIXME: 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
......@@ -507,7 +542,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(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)
(let* ((obsolete (get name 'byte-obsolete-info)))
......@@ -523,7 +558,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
;; 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
......@@ -541,7 +576,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
`(,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))
......@@ -550,7 +585,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
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))
......@@ -735,23 +770,30 @@ for all those different tags in the method-cache.")
"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)))
(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".
(if fun
(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)))))
(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 old `.elc' files.
(_
(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".
(if fun
(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)
......@@ -995,9 +1037,13 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
(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
;; FIXME: that just gives us "&rest args"!!!
(funcall function #'ignore))
'names))
(docstring (documentation function))
(qual-string
(if (null qualifiers) ""
......@@ -1008,7 +1054,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
(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)))
......
......@@ -307,7 +307,7 @@
(copiers (funcall get-opt :copier 'all))
(mixin (car (funcall get-opt :mixin))))
`(progn
,(when options (macroexp-warn-and-return
,(when options (macroexp-warn-and-return name
(format "Ignored options: %S" options)
nil))
(eval-and-compile
......
......@@ -314,14 +314,14 @@ Shows a list of commands and prompts for another key to execute a command."
(concat (mapcar #'caar org-attach-commands)))))
(message msg)
(while (and (setq c (read-char-exclusive))
(memq c '(14 16 22 134217846)))
(memq c '(?\C-n ?\C-p ?\C-v ?\M-v)))
(org-scroll c t)))
(and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*"))))
(let ((command (cl-some (lambda (entry)
(and (memq c (nth 0 entry)) (nth 1 entry)))
org-attach-commands)))
(if (commandp command t)
(call-interactively command)
(if (commandp command)
(command-execute command)
(error "No such attachment command: %c" c))))))
(defun org-attach-dir (&optional create-if-not-exists-p no-fs-check)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment