[Emacs-diffs] master aa1c4ae: * lisp/emacs-lisp/cl-generic.el: Accomodate future changes

[Stefan Monnier]

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

    * lisp/emacs-lisp/cl-generic.el: Accomodate future changes
    
    (cl--generic-generalizer): Add `name' field.
    (cl-generic-make-generalizer): Add corresponding `name' argument.
    (cl-generic-define-generalizer): New macro.
    (cl--generic-head-generalizer, cl--generic-eql-generalizer)
    (cl--generic-struct-generalizer, cl--generic-typeof-generalizer)
    (cl--generic-t-generalizer): Use it.
    (cl-generic-ensure-function): Add `noerror' argument.
    (cl-generic-define): Use it so we don't follow aliases.
    (cl-generic-define-method): Preserve pre-existing ordering of methods.
    (cl--generic-arg-specializer): New function.
    (cl--generic-cache-miss): Use it.
    (cl-generic-generalizers): Only fset a temporary definition
    during bootstrap.
    (cl--generic-struct-tag, cl--generic-struct-specializers):
    Allow extra arguments.
    
    * lisp/emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-generalizer)
    (eieio--generic-static-object-generalizer): Use 
cl-generic-define-generalizer.
    (eieio--generic-static-symbol-specializers): Allow extra arguments.
    
    * lisp/emacs-lisp/eieio-core.el (eieio--generic-generalizer)
    (eieio--generic-subclass-generalizer): Use cl-generic-define-generalizer.
    (eieio--generic-subclass-specializers): Allow extra arguments.
---
 lisp/emacs-lisp/cl-generic.el   |  105 ++++++++++++++++++++++++--------------
 lisp/emacs-lisp/eieio-compat.el |   42 +++++++--------
 lisp/emacs-lisp/eieio-core.el   |   30 +++++------
 3 files changed, 100 insertions(+), 77 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index dd01ebe..0d7ef5b 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -80,7 +80,7 @@
 
 ;; TODO:
 ;;
-;; - A generic "filter" generalizer (e.g. could be used to cleanly adds methods
+;; - A generic "filter" generalizer (e.g. could be used to cleanly add methods
 ;;   to cl-generic-combine-methods with a specializer that says it applies only
 ;;   when some particular qualifier is used).
 ;; - A way to dispatch on the context (e.g. the major-mode, some global
@@ -101,14 +101,33 @@
 (cl-defstruct (cl--generic-generalizer
                (:constructor nil)
                (:constructor cl-generic-make-generalizer
-                (priority tagcode-function specializers-function)))
+                (name priority tagcode-function specializers-function)))
+  (name nil :type string)
   (priority nil :type integer)
   tagcode-function
   specializers-function)
 
-(defconst cl--generic-t-generalizer
-  (cl-generic-make-generalizer
-   0 (lambda (_name) nil) (lambda (_tag) '(t))))
+
+(defmacro cl-generic-define-generalizer
+    (name priority tagcode-function specializers-function)
+  "Define a new kind of generalizer.
+NAME is the name of the variable that will hold it.
+PRIORITY defines which generalizer takes precedence.
+  The catch-all generalizer has priority 0.
+  Then `eql' generalizer has priority 100.
+TAGCODE-FUNCTION takes as first argument a varname and should return
+  a chunk of code that computes the tag of the value held in that variable.
+  Further arguments are reserved for future use.
+SPECIALIZERS-FUNCTION takes as first argument a tag value TAG
+  and should return a list of specializers that match TAG.
+  Further arguments are reserved for future use."
+  (declare (indent 1) (debug (symbolp body)))
+  `(defconst ,name
+     (cl-generic-make-generalizer
+      ',name ,priority ,tagcode-function ,specializers-function)))
+
+(cl-generic-define-generalizer cl--generic-t-generalizer
+   0 (lambda (_name &rest _) nil) (lambda (_tag &rest _) '(t)))
 
 (cl-defstruct (cl--generic-method
                (:constructor nil)
@@ -144,16 +163,18 @@
 (defmacro cl--generic (name)
   `(get ,name 'cl--generic))
 
-(defun cl-generic-ensure-function (name)
+(defun cl-generic-ensure-function (name &optional noerror)
   (let (generic
         (origname name))
     (while (and (null (setq generic (cl--generic name)))
                 (fboundp name)
+                (null noerror)
                 (symbolp (symbol-function name)))
       (setq name (symbol-function name)))
     (unless (or (not (fboundp name))
                 (autoloadp (symbol-function name))
-                (and (functionp name) generic))
+                (and (functionp name) generic)
+                noerror)
       (error "%s is already defined as something else than a generic function"
              origname))
     (if generic
@@ -220,7 +241,7 @@ BODY, if present, is used as the body of a default method.
 
 ;;;###autoload
 (defun cl-generic-define (name args options)
-  (pcase-let* ((generic (cl-generic-ensure-function name))
+  (pcase-let* ((generic (cl-generic-ensure-function name 'noerror))
                (`(,spec-args . ,_) (cl--generic-split-args args))
                (mandatory (mapcar #'car spec-args))
                (apo (assq :argument-precedence-order options)))
@@ -418,8 +439,12 @@ which case this method will be invoked when the argument 
is `eql' to VAL.
         (setq i (1+ i))))
     ;; We used to (setcar me method), but that can cause false positives in
     ;; the hash-consing table of the method-builder (bug#20644).
-    ;; See the related FIXME in cl--generic-build-combined-method.
-    (setf (cl--generic-method-table generic) (cons method (delq (car me) mt)))
+    ;; See also the related FIXME in cl--generic-build-combined-method.
+    (setf (cl--generic-method-table generic)
+          (if (null me)
+              (cons method mt)
+            ;; Keep the ordering; important for methods with :extra qualifiers.
+            (mapcar (lambda (x) (if (eq x (car me)) method x)) mt)))
     (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
                 current-load-list :test #'equal)
     ;; FIXME: Try to avoid re-constructing a new function if the old one
@@ -623,16 +648,19 @@ FUN is the function that should be called when METHOD 
calls
           (setq fun (cl-generic-call-method generic method fun)))
         fun)))))
 
+(defun cl--generic-arg-specializer (method dispatch-arg)
+  (or (if (integerp dispatch-arg)
+          (nth dispatch-arg
+               (cl--generic-method-specializers method))
+        (cdr (assoc dispatch-arg
+                    (cl--generic-method-specializers method))))
+      t))
+
 (defun cl--generic-cache-miss (generic
                                dispatch-arg dispatches-left methods-left types)
   (let ((methods '()))
     (dolist (method methods-left)
-      (let* ((specializer (or (if (integerp dispatch-arg)
-                                  (nth dispatch-arg
-                                       (cl--generic-method-specializers 
method))
-                                (cdr (assoc dispatch-arg
-                                            (cl--generic-method-specializers 
method))))
-                              t))
+      (let* ((specializer (cl--generic-arg-specializer method dispatch-arg))
              (m (member specializer types)))
         (when m
           (push (cons (length m) method) methods))))
@@ -682,10 +710,12 @@ The METHODS list is sorted from most specific first to 
most generic last.
 The function can use `cl-generic-call-method' to create functions that call 
those
 methods.")
 
-;; Temporary definition to let the next defmethod succeed.
-(fset 'cl-generic-generalizers
-      (lambda (_specializer) (list cl--generic-t-generalizer)))
-(fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination)
+(unless (ignore-errors (cl-generic-generalizers t))
+  ;; Temporary definition to let the next defmethod succeed.
+  (fset 'cl-generic-generalizers
+        (lambda (specializer)
+          (if (eq t specializer) (list cl--generic-t-generalizer))))
+  (fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination))
 
 (cl-defmethod cl-generic-generalizers (specializer)
   "Support for the catch-all t specializer."
@@ -940,10 +970,9 @@ The value returned is a list of elements of the form
 
 (defvar cl--generic-head-used (make-hash-table :test #'eql))
 
-(defconst cl--generic-head-generalizer
-  (cl-generic-make-generalizer
-   80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used))
-   (lambda (tag) (if (eq (car-safe tag) 'head) (list tag)))))
+(cl-generic-define-generalizer cl--generic-head-generalizer
+  80 (lambda (name &rest _) `(gethash (car-safe ,name) cl--generic-head-used))
+  (lambda (tag &rest _) (if (eq (car-safe tag) 'head) (list tag))))
 
 (cl-defmethod cl-generic-generalizers :extra "head" (specializer)
   "Support for the `(head VAL)' specializers."
@@ -961,10 +990,9 @@ The value returned is a list of elements of the form
 
 (defvar cl--generic-eql-used (make-hash-table :test #'eql))
 
-(defconst cl--generic-eql-generalizer
-  (cl-generic-make-generalizer
-   100 (lambda (name) `(gethash ,name cl--generic-eql-used))
-   (lambda (tag) (if (eq (car-safe tag) 'eql) (list tag)))))
+(cl-generic-define-generalizer cl--generic-eql-generalizer
+  100 (lambda (name &rest _) `(gethash ,name cl--generic-eql-used))
+  (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag))))
 
 (cl-defmethod cl-generic-generalizers ((specializer (head eql)))
   "Support for the `(eql VAL)' specializers."
@@ -976,7 +1004,7 @@ The value returned is a list of elements of the form
 
 ;;; Support for cl-defstructs specializers.
 
-(defun cl--generic-struct-tag (name)
+(defun cl--generic-struct-tag (name &rest _)
   ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
   ;; but that would suffer from some problems:
   ;; - the vector may have size 0.
@@ -1007,16 +1035,15 @@ The value returned is a list of elements of the form
                            (cl--class-parents class)))))
     (nreverse parents)))
 
-(defun cl--generic-struct-specializers (tag)
+(defun cl--generic-struct-specializers (tag &rest _)
   (and (symbolp tag) (boundp tag)
        (let ((class (symbol-value tag)))
          (when (cl-typep class 'cl-structure-class)
            (cl--generic-class-parents class)))))
 
-(defconst cl--generic-struct-generalizer
-  (cl-generic-make-generalizer
-   50 #'cl--generic-struct-tag
-   #'cl--generic-struct-specializers))
+(cl-generic-define-generalizer cl--generic-struct-generalizer
+  50 #'cl--generic-struct-tag
+  #'cl--generic-struct-specializers)
 
 (cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
   "Support for dispatch on cl-struct types."
@@ -1056,11 +1083,11 @@ The value returned is a list of elements of the form
     (sequence)
     (number)))
 
-(defconst cl--generic-typeof-generalizer
-  (cl-generic-make-generalizer
-   ;; FIXME: We could also change `type-of' to return `null' for nil.
-   10 (lambda (name) `(if ,name (type-of ,name) 'null))
-   (lambda (tag) (and (symbolp tag) (assq tag cl--generic-typeof-types)))))
+(cl-generic-define-generalizer cl--generic-typeof-generalizer
+  ;; FIXME: We could also change `type-of' to return `null' for nil.
+  10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null))
+  (lambda (tag &rest _)
+    (and (symbolp tag) (assq tag cl--generic-typeof-types))))
 
 (cl-defmethod cl-generic-generalizers :extra "typeof" (type)
   "Support for dispatch on builtin types."
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index 386ff2f..638c475 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -124,7 +124,7 @@ Summary:
        (defgeneric ,method ,args)
        (eieio--defmethod ',method ',key ',class #',code))))
 
-(defun eieio--generic-static-symbol-specializers (tag)
+(defun eieio--generic-static-symbol-specializers (tag &rest _)
   (cl-assert (or (null tag) (eieio--class-p tag)))
   (when (eieio--class-p tag)
     (let ((superclasses (eieio--generic-subclass-specializers tag))
@@ -134,27 +134,25 @@ Summary:
        (push `(eieio--static ,(cadr superclass)) specializers))
       (nreverse specializers))))
 
-(defconst eieio--generic-static-symbol-generalizer
-  (cl-generic-make-generalizer
-   ;; Give it a slightly higher priority than `subclass' so that the
-   ;; interleaved list comes before subclass's non-interleaved list.
-   61 (lambda (name) `(and (symbolp ,name) (cl--find-class ,name)))
-   #'eieio--generic-static-symbol-specializers))
-(defconst eieio--generic-static-object-generalizer
-  (cl-generic-make-generalizer
-   ;; Give it a slightly higher priority than `class' so that the
-   ;; interleaved list comes before the class's non-interleaved list.
-   51 #'cl--generic-struct-tag
-   (lambda (tag)
-     (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag))
-          (eieio--class-p tag)
-          (let ((superclasses (eieio--class-precedence-list tag))
-                (specializers ()))
-            (dolist (superclass superclasses)
-              (setq superclass (eieio--class-name superclass))
-              (push superclass specializers)
-              (push `(eieio--static ,superclass) specializers))
-            (nreverse specializers))))))
+(cl-generic-define-generalizer eieio--generic-static-symbol-generalizer
+  ;; Give it a slightly higher priority than `subclass' so that the
+  ;; interleaved list comes before subclass's non-interleaved list.
+  61 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name)))
+  #'eieio--generic-static-symbol-specializers)
+(cl-generic-define-generalizer eieio--generic-static-object-generalizer
+  ;; Give it a slightly higher priority than `class' so that the
+  ;; interleaved list comes before the class's non-interleaved list.
+  51 #'cl--generic-struct-tag
+  (lambda (tag _targets)
+    (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag))
+         (eieio--class-p tag)
+         (let ((superclasses (eieio--class-precedence-list tag))
+               (specializers ()))
+           (dolist (superclass superclasses)
+             (setq superclass (eieio--class-name superclass))
+             (push superclass specializers)
+             (push `(eieio--static ,superclass) specializers))
+           (nreverse specializers)))))
 
 (cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static)))
   (list eieio--generic-static-symbol-generalizer
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index e3f7b11..7011a30 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -1059,16 +1059,15 @@ method invocation orders of the involved classes."
 
 ;;;; General support to dispatch based on the type of the argument.
 
-(defconst eieio--generic-generalizer
-  (cl-generic-make-generalizer
-   ;; Use the exact same tagcode as for cl-struct, so that methods
-   ;; that dispatch on both kinds of objects get to share this
-   ;; part of the dispatch code.
-   50 #'cl--generic-struct-tag
-   (lambda (tag)
-        (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
-             (mapcar #'eieio--class-name
-                     (eieio--class-precedence-list (symbol-value tag)))))))
+(cl-generic-define-generalizer eieio--generic-generalizer
+  ;; Use the exact same tagcode as for cl-struct, so that methods
+  ;; that dispatch on both kinds of objects get to share this
+  ;; part of the dispatch code.
+  50 #'cl--generic-struct-tag
+  (lambda (tag &rest _)
+    (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
+         (mapcar #'eieio--class-name
+                 (eieio--class-precedence-list (symbol-value tag))))))
 
 (cl-defmethod cl-generic-generalizers :extra "class" (specializer)
   ;; CLHS says:
@@ -1088,22 +1087,21 @@ method invocation orders of the involved classes."
 ;; would not make much sense (e.g. to which argument should it apply?).
 ;; Instead, we add a new "subclass" specializer.
 
-(defun eieio--generic-subclass-specializers (tag)
+(defun eieio--generic-subclass-specializers (tag &rest _)
   (when (eieio--class-p tag)
     (mapcar (lambda (class)
               `(subclass ,(eieio--class-name class)))
             (eieio--class-precedence-list tag))))
 
-(defconst eieio--generic-subclass-generalizer
-  (cl-generic-make-generalizer
-   60 (lambda (name) `(and (symbolp ,name) (cl--find-class ,name)))
-   #'eieio--generic-subclass-specializers))
+(cl-generic-define-generalizer eieio--generic-subclass-generalizer
+  60 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name)))
+  #'eieio--generic-subclass-specializers)
 
 (cl-defmethod cl-generic-generalizers ((_specializer (head subclass)))
   (list eieio--generic-subclass-generalizer))
 
 
-;;;### (autoloads nil "eieio-compat" "eieio-compat.el" 
"ea8c7f24ed47c6b71ac37cbdae1c9931")
+;;;### (autoloads nil "eieio-compat" "eieio-compat.el" 
"bd51800d7de6429a2c9a6a600ba2dc52")
 ;;; Generated autoloads from eieio-compat.el
 
 (autoload 'eieio--defalias "eieio-compat" "\