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

[Stefan Monnier]

branch: scratch/oclosure
commit f1b7ad1973a88d8efa9e2da9ac3cbbfddc2d6207
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * 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.
---
 lisp/emacs-lisp/cl-generic.el | 120 +++++++++++++++++++++++++++++-------------
 lisp/emacs-lisp/oclosure.el   |   2 +-
 lisp/org/org-attach.el        |   6 +--
 3 files changed, 87 insertions(+), 41 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index a0a0691442..650068ea67 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -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)))
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index c53182fccd..fd994e2345 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -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
diff --git a/lisp/org/org-attach.el b/lisp/org/org-attach.el
index 36c21b7021..bba7fd7690 100644
--- a/lisp/org/org-attach.el
+++ b/lisp/org/org-attach.el
@@ -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)