[Emacs-diffs] master 909126d: * lisp/emacs-lisp/cl-generic.el: Add support for cl-next-method-p.

[Stefan Monnier]

branch: master
commit 909126de0f6d2e53aec44c97abccee5b32b25f28
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    * 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/ChangeLog                |   20 ++++++++++-
 lisp/emacs-lisp/cl-generic.el |   72 +++++++++++++++++++++++++++++++++++------
 lisp/emacs-lisp/eieio.el      |    8 ++--
 3 files changed, 84 insertions(+), 16 deletions(-)

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index cce686b..ace8d22 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,19 @@
+2015-01-18  Stefan Monnier  <address@hidden>
+
+       * emacs-lisp/cl-macs.el (cl-defstruct): Minor optimization when include
+       or print is nil.
+       (cl-struct-type-p): New function.
+
+       * 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.
+
 2015-01-17  Ulrich Müller  <address@hidden>
 
        * version.el (emacs-repository-get-version): Update docstring.
@@ -14,8 +30,8 @@
        in place of the file name while working on non-file buffers, just
        like hack-dir-local-variables already does.  (Bug#19140)
 
-       * textmodes/enriched.el (enriched-encode): Use
-       inhibit-point-motion-hooks in addition to inhibit-read-only.
+       * textmodes/enriched.el (enriched-encode):
+       Use inhibit-point-motion-hooks in addition to inhibit-read-only.
        (Bug#18246)
 
        * desktop.el (desktop-read): Do not call desktop-clear when no
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index ae0f129..819e2e9 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/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)
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index cda0c97..c5597b8 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -36,12 +36,12 @@
 ;;   Retrieved from:
 ;;   http://192.220.96.201/dylan/linearization-oopsla96.html
 
-;; There is funny stuff going on with typep and deftype.  This
-;; is the only way I seem to be able to make this stuff load properly.
-
 ;; @TODO - fix :initform to be a form, not a quoted value
 ;; @TODO - Prefix non-clos functions with `eieio-'.
 
+;; TODO: better integrate CL's defstructs and classes.  E.g. make it possible
+;; to create a new class that inherits from a struct.
+
 ;;; Code:
 
 (defvar eieio-version "1.4"
@@ -924,7 +924,7 @@ variable PRINT-FUNCTION.  Optional argument NOESCAPE is 
passed to
 
 ;;; Start of automatically extracted autoloads.
 
-;;;### (autoloads nil "eieio-custom" "eieio-custom.el" 
"9a908efef1720439feb6323c1dd01770")
+;;;### (autoloads nil "eieio-custom" "eieio-custom.el" 
"6baa78cfc590cc0422e12b7eb55abf24")
 ;;; Generated autoloads from eieio-custom.el
 
 (autoload 'customize-object "eieio-custom" "\