* lisp/emacs-lisp/cl-generic.el: Add support for cl-next-method-p.

(cl-defmethod): Add edebug spec.
(cl--generic-build-combined-method): Fix call to
cl-no-applicable-method.
(cl--generic-nnm-sample, cl--generic-cnm-sample): New constant.
(cl--generic-isnot-nnm-p): New function.
(cl--generic-lambda): Use it to add support for cl-next-method-p.
(cl-no-next-method, cl-no-applicable-method): Simplify arg list.
(cl-next-method-p): New function.

lisp/emacs-lisp/cl-generic.el

@@ -26,8 +26,7 @@
 ;; The main entry points are: `cl-defgeneric' and `cl-defmethod'.
 
 ;; Missing elements:
-;; - We don't support next-method-p, make-method, call-method,
-;;   define-method-combination.
+;; - We don't support make-method, call-method, define-method-combination.
 ;; - 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
@@ -133,7 +132,7 @@ They should be sorted from most specific to least specific.")
   "Create a generic function NAME.
 DOC-STRING is the base documentation for this class.  A generic
 function has no body, as its purpose is to decide which method body
-is appropriate to use.  Specific methods are defined with `defmethod'.
+is appropriate to use.  Specific methods are defined with `cl-defmethod'.
 With this implementation the ARGS are currently ignored.
 OPTIONS-AND-METHODS is currently only used to specify the docstring,
 via (:documentation DOCSTRING)."
@@ -223,8 +222,10 @@ This macro can only be used within the lexical scope of a cl-generic method."
              (let* ((doc-string (and doc-string (stringp (car body))
                                      (pop body)))
                     (cnm (make-symbol "cl--cnm"))
+                    (nmp (make-symbol "cl--nmp"))
                     (nbody (macroexpand-all
-                            `(cl-flet ((cl-call-next-method ,cnm))
+                            `(cl-flet ((cl-call-next-method ,cnm)
+                                       (cl-next-method-p ,nmp))
                                ,@body)
                             macroenv))
                     ;; FIXME: Rather than `grep' after the fact, the
@@ -232,11 +233,15 @@ This macro can only be used within the lexical scope of a cl-generic method."
                     ;; is used.
                     ;; FIXME: Also, optimize the case where call-next-method is
                     ;; only called with explicit arguments.
-                    (uses-cnm (cl--generic-fgrep (list cnm) nbody)))
+                    (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))
-                          ,nbody))))
+                          ,(if (not (memq nmp uses-cnm))
+                               nbody
+                             `(let ((,nmp (lambda ()
+                                            (cl--generic-isnot-nnm-p ,cnm))))
+                                ,nbody))))))
             (f (error "Unexpected macroexpansion result: %S" f))))))))
 
 
@@ -261,7 +266,15 @@ Other than a type, TYPE can also be of the form `(eql VAL)' in
 which case this method will be invoked when the argument is `eql' to VAL.
 
 \(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
-  (declare (doc-string 3) (indent 2))
+  (declare (doc-string 3) (indent 2)
+           (debug
+            (&define                    ; this means we are defining something
+             [&or name ("setf" :name setf name)]
+             ;; ^^ This is the methods symbol
+             [ &optional keywordp ]     ; this is key :before etc
+             list                       ; arguments
+             [ &optional stringp ]      ; documentation string
+             def-body)))                ; part to be debugged
   (let ((qualifiers nil))
     (while (keywordp args)
       (push args qualifiers)
@@ -402,7 +415,8 @@ for all those different tags in the method-cache.")
                  cl--generic-combined-method-memoization)
       (cond
        ((null mets-by-qual) (lambda (&rest args)
-                             (cl-no-applicable-method generic-name args)))
+                              (apply #'cl-no-applicable-method
+                                     generic-name args)))
        (t
         (let* ((fun (lambda (&rest args)
                       ;; FIXME: CLOS passes as second arg the "calling method".
@@ -428,6 +442,38 @@ for all those different tags in the method-cache.")
                               (apply af args)))))))
           (cl--generic-nest fun (alist-get :around mets-by-qual))))))))
 
+(defconst cl--generic-nnm-sample
+  (cl--generic-build-combined-method nil '(((specializer . :qualifier)))))
+(defconst cl--generic-cnm-sample
+  (funcall (cl--generic-build-combined-method
+            nil `(((specializer . :primary) 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")))
+
 (defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags)
   (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags)))
         (methods '()))
@@ -452,12 +498,12 @@ for all those different tags in the method-cache.")
 
 (cl-defgeneric cl-no-next-method (generic method &rest args)
   "Function called when `cl-call-next-method' finds no next method.")
-(cl-defmethod cl-no-next-method ((generic t) method &rest args)
+(cl-defmethod cl-no-next-method (generic method &rest args)
   (signal 'cl-no-next-method `(,generic ,method ,@args)))
 
 (cl-defgeneric cl-no-applicable-method (generic &rest args)
   "Function called when a method call finds no applicable method.")
-(cl-defmethod cl-no-applicable-method ((generic t) &rest args)
+(cl-defmethod cl-no-applicable-method (generic &rest args)
   (signal 'cl-no-applicable-method `(,generic ,@args)))
 
 (defun cl-call-next-method (&rest _args)
@@ -465,6 +511,12 @@ for all those different tags in the method-cache.")
 Can only be used from within the lexical body of a primary or around method."
   (error "cl-call-next-method only allowed inside primary and around methods"))
 
+(defun cl-next-method-p ()
+  "Return non-nil if there is a next method.
+Can only be used from within the lexical body of a primary or around method."
+  (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1"))
+  (error "cl-next-method-p only allowed inside primary and around methods"))
+
 ;;; Add support for describe-function
 
 (defun cl--generic-search-method (met-name)