* 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.

1 files changed, 66 insertions, 39 deletions

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index dd01ebe9dd8..0d7ef5b2e61 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."