* lisp/emacs-lisp/cl-generic.el: Add a method-combination hook.

(cl-generic-method-combination-function): New var.
(cl--generic-lambda): Remove `with-cnm' arg.
(cl-defmethod): Change accordingly.
(cl-generic-define-method): Don't check qualifiers validity.
Preserve all qualifiers in `method-table'.
(cl-generic-call-method): New function.
(cl--generic-nest): Remove (morph into cl-generic-call-method).
(cl--generic-build-combined-method): Adjust to new format of method-table
and use cl-generic-method-combination-function.
(cl--generic-standard-method-combination): New function, extracted from
cl--generic-build-combined-method.
(cl--generic-cnm-sample): Adjust to new format of method-table.

* lisp/emacs-lisp/eieio-compat.el (eieio--defmethod): Use () qualifiers
instead of :primary.

* lisp/emacs-lisp/eieio-datadebug.el (eieio-debug-methodinvoke):
Remove obsolete function.

* test/automated/cl-generic-tests.el (cl-generic-test-11-next-method-p):
New test.

6 files changed, 155 insertions, 107 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 8af0ec46cad..0bdf4e275fa 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,25 @@
+2015-01-26  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * emacs-lisp/cl-generic.el: Add a method-combination hook.
+        (cl-generic-method-combination-function): New var.
+        (cl--generic-lambda): Remove `with-cnm' arg.
+        (cl-defmethod): Change accordingly.
+        (cl-generic-define-method): Don't check qualifiers validity.
+        Preserve all qualifiers in `method-table'.
+        (cl-generic-call-method): New function.
+        (cl--generic-nest): Remove (morph into cl-generic-call-method).
+        (cl--generic-build-combined-method): Adjust to new format of method-table
+        and use cl-generic-method-combination-function.
+        (cl--generic-standard-method-combination): New function, extracted from
+        cl--generic-build-combined-method.
+        (cl--generic-cnm-sample): Adjust to new format of method-table.
+
+        * emacs-lisp/eieio-compat.el (eieio--defmethod): Use () qualifiers
+        instead of :primary.
+
+        * emacs-lisp/eieio-datadebug.el (eieio-debug-methodinvoke):
+        Remove obsolete function.
+
 2015-01-26  Lars Ingebrigtsen  <larsi@gnus.org>
 
         * net/shr.el (shr-make-table-1): Fix colspan typo.
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 02a43514019..4245959c8a4 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -30,7 +30,9 @@
 ;;   CLOS's define-method-combination is IMO overly complicated, and it suffers
 ;;   from a significant problem: the method-combination code returns a sexp
 ;;   that needs to be `eval'uated or compiled.  IOW it requires run-time
-;;   code generation.
+;;   code generation.  Given how rarely method-combinations are used,
+;;   I just provided a cl-generic-method-combination-function, which
+;;   people can use if they are really desperate for such functionality.
 ;; - Method and generic function objects: CLOS defines methods as objects
 ;;   (same for generic functions), whereas we don't offer such an abstraction.
 ;; - `no-next-method' should receive the "calling method" object, but since we
@@ -115,10 +117,10 @@ They should be sorted from most specific to least specific.")
   ;; The most important dispatch is last in the list (and the least is first).
   (dispatches nil :type (list-of (cons natnum (list-of tagcode))))
   ;; `method-table' is a list of
-  ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where
+  ;; ((SPECIALIZERS . QUALIFIERS) USES-CNM . FUNCTION), where
   ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method'
   ;; (and hence expects an extra argument holding the next-method).
-  (method-table nil :type (list-of (cons (cons (list-of type) keyword)
+  (method-table nil :type (list-of (cons (cons (list-of type) (list-of atom))
                                          (cons boolean function)))))
 
 (defmacro cl--generic (name)
@@ -232,7 +234,7 @@ This macro can only be used within the lexical scope of a cl-generic method."
       (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
       res))
 
-  (defun cl--generic-lambda (args body with-cnm)
+  (defun cl--generic-lambda (args body)
     "Make the lambda expression for a method with ARGS and BODY."
     (let ((plain-args ())
           (specializers nil)
@@ -255,36 +257,34 @@ This macro can only be used within the lexical scope of a cl-generic method."
                               . ,(lambda () specializers))
                             macroexpand-all-environment)))
         (require 'cl-lib)        ;Needed to expand `cl-flet' and `cl-function'.
-        (if (not with-cnm)
-            (cons nil (macroexpand-all fun macroenv))
-          ;; First macroexpand away the cl-function stuff (e.g. &key and
-          ;; destructuring args, `declare' and whatnot).
-          (pcase (macroexpand fun macroenv)
-            (`#'(lambda ,args . ,body)
-             (let* ((doc-string (and doc-string (stringp (car body)) (cdr body)
-                                     (pop body)))
-                    (cnm (make-symbol "cl--cnm"))
-                    (nmp (make-symbol "cl--nmp"))
-                    (nbody (macroexpand-all
-                            `(cl-flet ((cl-call-next-method ,cnm)
-                                       (cl-next-method-p ,nmp))
-                               ,@body)
-                            macroenv))
-                    ;; FIXME: Rather than `grep' after the fact, the
-                    ;; macroexpansion should directly set some flag when cnm
-                    ;; is used.
-                    ;; FIXME: Also, optimize the case where call-next-method is
-                    ;; only called with explicit arguments.
-                    (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
-               (cons (not (not uses-cnm))
-                     `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
-                          ,@(if doc-string (list doc-string))
-                          ,(if (not (memq nmp uses-cnm))
-                               nbody
-                             `(let ((,nmp (lambda ()
-                                            (cl--generic-isnot-nnm-p ,cnm))))
-                                ,nbody))))))
-            (f (error "Unexpected macroexpansion result: %S" f))))))))
+        ;; First macroexpand away the cl-function stuff (e.g. &key and
+        ;; destructuring args, `declare' and whatnot).
+        (pcase (macroexpand fun macroenv)
+          (`#'(lambda ,args . ,body)
+           (let* ((doc-string (and doc-string (stringp (car body)) (cdr body)
+                                   (pop body)))
+                  (cnm (make-symbol "cl--cnm"))
+                  (nmp (make-symbol "cl--nmp"))
+                  (nbody (macroexpand-all
+                          `(cl-flet ((cl-call-next-method ,cnm)
+                                     (cl-next-method-p ,nmp))
+                             ,@body)
+                          macroenv))
+                  ;; FIXME: Rather than `grep' after the fact, the
+                  ;; macroexpansion should directly set some flag when cnm
+                  ;; is used.
+                  ;; FIXME: Also, optimize the case where call-next-method is
+                  ;; only called with explicit arguments.
+                  (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
+             (cons (not (not uses-cnm))
+                   `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
+                        ,@(if doc-string (list doc-string))
+                        ,(if (not (memq nmp uses-cnm))
+                             nbody
+                           `(let ((,nmp (lambda ()
+                                          (cl--generic-isnot-nnm-p ,cnm))))
+                              ,nbody))))))
+          (f (error "Unexpected macroexpansion result: %S" f)))))))
 
 
 ;;;###autoload
@@ -324,8 +324,7 @@ which case this method will be invoked when the argument is `eql' to VAL.
     (while (not (listp args))
       (push args qualifiers)
       (setq args (pop body)))
-    (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after))))
-                 (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm)))
+    (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
       `(progn
          ,(when setfizer
             (setq name (car setfizer))
@@ -347,15 +346,11 @@ which case this method will be invoked when the argument is `eql' to VAL.
 
 ;;;###autoload
 (defun cl-generic-define-method (name qualifiers args uses-cnm function)
-  (when (> (length qualifiers) 1)
-    (error "We only support a single qualifier per method: %S" qualifiers))
-  (unless (memq (car qualifiers) '(nil :primary :around :after :before))
-    (error "Unsupported qualifier in: %S" qualifiers))
   (let* ((generic (cl-generic-ensure-function name))
          (mandatory (cl--generic-mandatory-args args))
          (specializers
           (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory))
-         (key (cons specializers (or (car qualifiers) ':primary)))
+         (key (cons specializers qualifiers))
          (mt (cl--generic-method-table generic))
          (me (assoc key mt))
          (dispatches (cl--generic-dispatches generic))
@@ -438,22 +433,19 @@ which case this method will be invoked when the argument is `eql' to VAL.
                          (cdr dispatch) (car dispatch))))
         (funcall dispatcher generic dispatches)))))
 
-(defun cl--generic-nest (fun methods)
-  (pcase-dolist (`(,uses-cnm . ,method) methods)
-    (setq fun
-          (if (not uses-cnm) method
-            (let ((next fun))
-              (lambda (&rest args)
-                (apply method
-                       ;; 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))))))
-  fun)
+(defvar cl-generic-method-combination-function
+  #'cl--generic-standard-method-combination
+  "Function to build the effective method.
+Called with 2 arguments: NAME and METHOD-ALIST.
+It should return an effective method, i.e. a function that expects the same
+arguments as the methods, and calls those methods in some appropriate order.
+NAME is the name (a symbol) of the corresponding generic function.
+METHOD-ALIST is a list of elements (QUALIFIERS . METHODS) where
+QUALIFIERS is a list of qualifiers, and METHODS is a list of the selected
+methods for that qualifier list.
+The METHODS lists are sorted from most generic first to most specific last.
+The function can use `cl-generic-call-method' to create functions that call those
+methods.")
 
 (defvar cl--generic-combined-method-memoization
   (make-hash-table :test #'equal :weakness 'value)
@@ -462,6 +454,22 @@ This is particularly useful when many different tags select the same set
 of methods, since this table then allows us to share a single combined-method
 for all those different tags in the method-cache.")
 
+(defun cl--generic-build-combined-method (generic-name methods)
+  (cl--generic-with-memoization
+      (gethash (cons generic-name methods)
+               cl--generic-combined-method-memoization)
+    (let ((mets-by-qual ()))
+      (dolist (qm methods)
+        (let* ((qualifiers (cdar qm))
+               (x (assoc qualifiers mets-by-qual)))
+          ;; FIXME: sadly, alist-get only uses `assq' and we need `assoc'.
+          ;;(push (cdr qm) (alist-get qualifiers mets-by-qual)))
+          (if x
+              (push (cdr qm) (cdr x))
+            (push (list qualifiers (cdr qm)) mets-by-qual))))
+      (funcall cl-generic-method-combination-function
+               generic-name mets-by-qual))))
+
 (defun cl--generic-no-next-method-function (generic)
   (lambda (&rest args)
     ;; FIXME: CLOS passes as second arg the "calling method".
@@ -474,42 +482,61 @@ for all those different tags in the method-cache.")
     ;; it anyway.  So we pass nil for now.
     (apply #'cl-no-next-method generic nil args)))
 
-(defun cl--generic-build-combined-method (generic-name methods)
-  (let ((mets-by-qual ()))
-    (dolist (qm methods)
-      (push (cdr qm) (alist-get (cdar qm) mets-by-qual)))
-    (cl--generic-with-memoization
-        (gethash (cons generic-name mets-by-qual)
-                 cl--generic-combined-method-memoization)
-      (cond
-       ((null mets-by-qual)
-        (lambda (&rest args)
-          (apply #'cl-no-applicable-method generic-name args)))
-       ((null (alist-get :primary mets-by-qual))
-        (lambda (&rest args)
-          (apply #'cl-no-primary-method generic-name args)))
-       (t
-        (let* ((fun (cl--generic-no-next-method-function generic-name))
-               ;; We use `cdr' to drop the `uses-cnm' annotations.
-               (before
-                (mapcar #'cdr (reverse (alist-get :before mets-by-qual))))
-               (after (mapcar #'cdr (alist-get :after mets-by-qual))))
-          (setq fun (cl--generic-nest fun (alist-get :primary mets-by-qual)))
-          (when (or after before)
-            (let ((next fun))
-              (setq fun (lambda (&rest args)
-                          (dolist (bf before)
-                            (apply bf args))
-                          (prog1
-                              (apply next args)
-                            (dolist (af after)
-                              (apply af args)))))))
-          (cl--generic-nest fun (alist-get :around mets-by-qual))))))))
+(defun cl-generic-call-method (generic-name method &optional fun)
+  "Return a function that calls METHOD.
+FUN is the function that should be called when METHOD calls
+`call-next-method'."
+  (pcase method
+    (`(nil . ,method) method)
+    (`(,_uses-cnm . ,method)
+     (let ((next (or fun (cl--generic-no-next-method-function generic-name))))
+       (lambda (&rest args)
+         (apply method
+                ;; 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))))))
+
+(defun cl--generic-standard-method-combination (generic-name mets-by-qual)
+  (dolist (x mets-by-qual)
+    (unless (member (car x) '(() (:after) (:before) (:around)))
+      (error "Unsupported qualifiers in function %S: %S" generic-name (car x))))
+  (cond
+   ((null mets-by-qual)
+    (lambda (&rest args)
+      (apply #'cl-no-applicable-method generic-name args)))
+   ((null (alist-get nil mets-by-qual))
+    (lambda (&rest args)
+      (apply #'cl-no-primary-method generic-name args)))
+   (t
+    (let* ((fun nil)
+           (ab-call (lambda (m) (cl-generic-call-method generic-name m)))
+           (before
+            (mapcar ab-call (reverse (cdr (assoc '(:before) mets-by-qual)))))
+           (after (mapcar ab-call (cdr (assoc '(:after) mets-by-qual)))))
+      (dolist (method (cdr (assoc nil mets-by-qual)))
+        (setq fun (cl-generic-call-method generic-name method fun)))
+      (when (or after before)
+        (let ((next fun))
+          (setq fun (lambda (&rest args)
+                      (dolist (bf before)
+                        (apply bf args))
+                      (prog1
+                          (apply next args)
+                        (dolist (af after)
+                          (apply af args)))))))
+      (dolist (method (cdr (assoc '(:around) mets-by-qual)))
+        (setq fun (cl-generic-call-method generic-name method fun)))
+      fun))))
 
 (defconst cl--generic-nnm-sample (cl--generic-no-next-method-function 'dummy))
 (defconst cl--generic-cnm-sample
   (funcall (cl--generic-build-combined-method
-            nil `(((specializer . :primary) t . ,#'identity)))))
+            nil `(((specializer . nil) t . ,#'identity)))))
 
 (defun cl--generic-isnot-nnm-p (cnm)
   "Return non-nil if CNM is the function that calls `cl-no-next-method'."
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index c2dabf7f446..30bb5cee994 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -181,7 +181,8 @@ Summary:
              (lambda (generic arg &rest args) (apply code arg generic args)))
             (_ code))))
     (cl-generic-define-method
-     method (if kind (list kind)) specializers uses-cnm
+     method (unless (memq kind '(nil :primary)) (list kind))
+     specializers uses-cnm
      (if uses-cnm
          (let* ((docstring (documentation code 'raw))
                 (args (help-function-arglist code 'preserve-names))
@@ -201,10 +202,11 @@ Summary:
     ;; applicable but only of the before/after kind.  So if we add a :before
     ;; or :after, make sure there's a matching dummy primary.
     (when (and (memq kind '(:before :after))
+               ;; FIXME: Use `cl-find-method'?
                (not (assoc (cons (mapcar (lambda (arg)
                                            (if (consp arg) (nth 1 arg) t))
                                          specializers)
-                                 :primary)
+                                 nil)
                            (cl--generic-method-table (cl--generic method)))))
       (cl-generic-define-method method () specializers t
                                 (lambda (cnm &rest args)
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el
index 6534bd0fecf..119f7cce038 100644
--- a/lisp/emacs-lisp/eieio-datadebug.el
+++ b/lisp/emacs-lisp/eieio-datadebug.el
@@ -129,22 +129,6 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
   (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj)))
   (data-debug-insert-object-slots obj "]"))
 
-;;; DEBUG FUNCTIONS
-;;
-(defun eieio-debug-methodinvoke (method class)
-  "Show the method invocation order for METHOD with CLASS object."
-  (interactive "aMethod: \nXClass Expression: ")
-  (let* ((eieio-pre-method-execution-functions
-          (lambda (l) (throw 'moose l) ))
-         (data
-          (catch 'moose (eieio--generic-call
-                         method (list class))))
-         (_buf (data-debug-new-buffer "*Method Invocation*"))
-         (data2 (mapcar (lambda (sym)
-                          (symbol-function (car sym)))
-                          data)))
-    (data-debug-insert-thing data2 ">" "")))
-
 (provide 'eieio-datadebug)
 
 ;;; eieio-datadebug.el ends here
diff --git a/test/ChangeLog b/test/ChangeLog
index d8cd36790f2..9a31da45416 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,8 @@
+2015-01-26  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * automated/cl-generic-tests.el (cl-generic-test-11-next-method-p):
+        New test.
+
 2015-01-25  Paul Eggert  <eggert@cs.ucla.edu>
 
         * indent/shell.sh (bar): Use '[ $# -eq 0 ]', not '[ $# == 0 ]'.
diff --git a/test/automated/cl-generic-tests.el b/test/automated/cl-generic-tests.el
index bc9a1ece423..5b3a9fdc2a1 100644
--- a/test/automated/cl-generic-tests.el
+++ b/test/automated/cl-generic-tests.el
@@ -171,5 +171,13 @@
   (should (equal (cl--generic-1 'a 'b) '(a b)))
   (should (equal (cl--generic-1 1 2) '("integer" 2 1))))
 
+(ert-deftest cl-generic-test-11-next-method-p ()
+  (cl-defgeneric cl--generic-1 (x y))
+  (cl-defmethod cl--generic-1 ((x t) y)
+    (list x y (cl-next-method-p)))
+  (cl-defmethod cl--generic-1 ((_x (eql 4)) _y)
+    (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method)))
+  (should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil))))
+
 (provide 'cl-generic-tests)
 ;;; cl-generic-tests.el ends here