Merge branch 'master' into cairo

1 files changed, 394 insertions, 248 deletions

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index c4232863cfc..fb11a3e25a1 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -3,6 +3,7 @@
 ;; Copyright (C) 2015 Free Software Foundation, Inc.
 
 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Version: 1.0
 
 ;; This file is part of GNU Emacs.
 
@@ -31,37 +32,51 @@
 ;;   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.  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.
+;;   I just provided a cl-generic-combine-methods generic function, to which
+;;   people can add methods if they are really desperate for such functionality.
 ;; - In defgeneric we don't support the options:
-;;   declare, :method-combination, :generic-function-class, :method-class,
-;;   :method.
+;;   declare, :method-combination, :generic-function-class, :method-class.
 ;; Added elements:
 ;; - We support aliases to generic functions.
-;; - The kind of thing on which to dispatch can be extended.
-;;   There is support in this file for dispatch on:
+;; - cl-generic-generalizers.  This generic function lets you extend the kind
+;;   of thing on which to dispatch.  There is support in this file for
+;;   dispatch on:
 ;;   - (eql <val>)
+;;   - (head <val>) which checks that the arg is a cons with <val> as its head.
 ;;   - plain old types
 ;;   - type of CL structs
 ;;   eieio-core adds dispatch on:
 ;;   - class of eieio objects
 ;;   - actual class argument, using the syntax (subclass <class>).
-;; - cl-generic-method-combination-function (i.s.o define-method-combination).
+;; - cl-generic-combine-methods (i.s.o define-method-combination and
+;;   compute-effective-method).
 ;; - cl-generic-call-method (which replaces make-method and call-method).
+;; - The standard method combination supports ":extra STRING" qualifiers
+;;   which simply allows adding more methods for the same
+;;   specializers&qualifiers.
 
 ;; Efficiency considerations: overall, I've made an effort to make this fairly
 ;; efficient for the expected case (e.g. no constant redefinition of methods).
 ;; - Generic functions which do not dispatch on any argument are implemented
 ;;   optimally (just as efficient as plain old functions).
 ;; - Generic functions which only dispatch on one argument are fairly efficient
-;;   (not a lot of room for improvement, I think).
+;;   (not a lot of room for improvement without changes to the byte-compiler,
+;;   I think).
 ;; - Multiple dispatch is implemented rather naively.  There's an extra `apply'
 ;;   function call for every dispatch; we don't optimize each dispatch
 ;;   based on the set of candidate methods remaining; we don't optimize the
-;;   order in which we performs the dispatches either;  If/when this
-;;   becomes a problem, we can try and optimize it.
+;;   order in which we performs the dispatches either;
+;;   If/when this becomes a problem, we can try and optimize it.
 ;; - call-next-method could be made more efficient, but isn't too terrible.
 
+;; TODO:
+;;
+;; - A generic "filter" generalizer (e.g. could be used to cleanly adds 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
+;;   variable, you name it).
+
 ;;; Code:
 
 ;; Note: For generic functions that dispatch on several arguments (i.e. those
@@ -70,40 +85,24 @@
 ;; often suboptimal since after one dispatch, the remaining dispatches can
 ;; usually be simplified, or even completely skipped.
 
-;; TODO/FIXME:
-;; - WIBNI we could use something like
-;;   (add-function :before (cl-method-function (cl-find-method ...)) ...)
-
 (eval-when-compile (require 'cl-lib))
 (eval-when-compile (require 'pcase))
 
-(defvar cl-generic-tagcode-function
-  (lambda (type _name)
-    (if (eq type t) '(0 . 'cl--generic-type)
-      (error "Unknown specializer %S" type)))
-  "Function to get the Elisp code to extract the tag on which we dispatch.
-Takes a \"parameter-specializer-name\" and a variable name, and returns
-a pair (PRIORITY . CODE) where CODE is an Elisp expression that should be
-used to extract the \"tag\" (from the object held in the named variable)
-that should uniquely determine if we have a match
-\(i.e. the \"tag\" is the value that will be used to dispatch to the proper
-method(s)).
-Such \"tagcodes\" will be or'd together.
-PRIORITY is an integer from 0 to 100 which is used to sort the tagcodes
-in the `or'.  The higher the priority, the more specific the tag should be.
-More specifically, if PRIORITY is N and we have two objects X and Y
-whose tag (according to TAGCODE) is `eql', then it should be the case
-that for all other (PRIORITY . TAGCODE) where PRIORITY ≤ N, then
-\(eval TAGCODE) for X is `eql' to (eval TAGCODE) for Y.")
-
-(defvar cl-generic-tag-types-function
-  (lambda (tag) (if (eq tag 'cl--generic-type) '(t)))
-  "Function to get the list of types that a given \"tag\" matches.
-They should be sorted from most specific to least specific.")
+(cl-defstruct (cl--generic-generalizer
+               (:constructor nil)
+               (:constructor cl-generic-make-generalizer
+                (priority tagcode-function specializers-function)))
+  (priority nil :type integer)
+  tagcode-function
+  specializers-function)
+
+(defconst cl--generic-t-generalizer
+  (cl-generic-make-generalizer
+   0 (lambda (_name) nil) (lambda (_tag) '(t))))
 
 (cl-defstruct (cl--generic-method
                (:constructor nil)
-               (:constructor cl--generic-method-make
+               (:constructor cl--generic-make-method
                 (specializers qualifiers uses-cnm function))
                (:predicate nil))
   (specializers nil :read-only t :type list)
@@ -115,8 +114,7 @@ They should be sorted from most specific to least specific.")
 
 (cl-defstruct (cl--generic
                (:constructor nil)
-               (:constructor cl--generic-make
-                (name &optional dispatches method-table))
+               (:constructor cl--generic-make (name))
                (:predicate nil))
   (name nil :type symbol :read-only t)  ;Pointer back to the symbol.
   ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
@@ -125,8 +123,13 @@ They should be sorted from most specific to least specific.")
   ;; on which to dispatch and PRIORITY is the priority of each expression to
   ;; decide in which order to sort them.
   ;; 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 nil :type (list-of cl--generic-method)))
+  (dispatches nil :type (list-of (cons natnum (list-of generalizers))))
+  (method-table nil :type (list-of cl--generic-method))
+  (options nil :type list))
+
+(defun cl-generic-function-options (generic)
+  "Return the options of the generic function GENERIC."
+  (cl--generic-options generic))
 
 (defmacro cl--generic (name)
   `(get ,name 'cl--generic))
@@ -170,20 +173,34 @@ is appropriate to use.  Specific methods are defined with `cl-defmethod'.
 With this implementation the ARGS are currently ignored.
 OPTIONS-AND-METHODS currently understands:
 - (:documentation DOCSTRING)
-- (declare DECLARATIONS)"
+- (declare DECLARATIONS)
+- (:argument-precedence-order &rest ARGS)
+- (:method [QUALIFIERS...] ARGS &rest BODY)
+BODY, if present, is used as the body of a default method.
+
+\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)"
   (declare (indent 2) (doc-string 3))
-  (let* ((docprop (assq :documentation options-and-methods))
-         (doc (cond ((stringp (car-safe options-and-methods))
-                     (pop options-and-methods))
-                    (docprop
-                     (prog1
-                         (cadr docprop)
-                       (setq options-and-methods
-                             (delq docprop options-and-methods))))))
-         (declarations (assq 'declare options-and-methods)))
-    (when declarations
-      (setq options-and-methods
-            (delq declarations options-and-methods)))
+  (let* ((doc (if (stringp (car-safe options-and-methods))
+                  (pop options-and-methods)))
+         (declarations nil)
+         (methods ())
+         (options ())
+         next-head)
+    (while (progn (setq next-head (car-safe (car options-and-methods)))
+                  (or (keywordp next-head)
+                      (eq next-head 'declare)))
+      (pcase next-head
+        (`:documentation
+         (when doc (error "Multiple doc strings for %S" name))
+         (setq doc (cadr (pop options-and-methods))))
+        (`declare
+         (when declarations (error "Multiple `declare' for %S" name))
+         (setq declarations (pop options-and-methods)))
+        (`:method (push (cdr (pop options-and-methods)) methods))
+        (_ (push (pop options-and-methods) options))))
+    (when options-and-methods
+      ;; Anything remaining is assumed to be a default method body.
+      (push `(,args ,@options-and-methods) methods))
     `(progn
        ,(when (eq 'setf (car-safe name))
           (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
@@ -200,8 +217,10 @@ OPTIONS-AND-METHODS currently understands:
                          nil))))
                  (cdr declarations))
        (defalias ',name
-         (cl-generic-define ',name ',args ',options-and-methods)
-         ,(help-add-fundoc-usage doc args)))))
+         (cl-generic-define ',name ',args ',(nreverse options))
+         ,(help-add-fundoc-usage doc args))
+       ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
+                 (nreverse methods)))))
 
 (defun cl--generic-mandatory-args (args)
   (let ((res ()))
@@ -210,10 +229,10 @@ OPTIONS-AND-METHODS currently understands:
     (nreverse res)))
 
 ;;;###autoload
-(defun cl-generic-define (name args options-and-methods)
+(defun cl-generic-define (name args options)
   (let ((generic (cl-generic-ensure-function name))
         (mandatory (cl--generic-mandatory-args args))
-        (apo (assq :argument-precedence-order options-and-methods)))
+        (apo (assq :argument-precedence-order options)))
     (setf (cl--generic-dispatches generic) nil)
     (when apo
       (dolist (arg (cdr apo))
@@ -222,6 +241,7 @@ OPTIONS-AND-METHODS currently understands:
           (push (list (- (length mandatory) (length pos)))
                 (cl--generic-dispatches generic)))))
     (setf (cl--generic-method-table generic) nil)
+    (setf (cl--generic-options generic) options)
     (cl--generic-make-function generic)))
 
 (defmacro cl-generic-current-method-specializers ()
@@ -278,7 +298,7 @@ This macro can only be used within the lexical scope of a cl-generic method."
                   (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
              (cons (not (not uses-cnm))
                    `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
-                        ,@(delq nil (car parsed-body))
+                        ,@(car parsed-body)
                         ,(if (not (memq nmp uses-cnm))
                              nbody
                            `(let ((,nmp (lambda ()
@@ -341,7 +361,7 @@ which case this method will be invoked when the argument is `eql' to VAL.
          ;; But in practice, it's common to use `cl-defmethod'
          ;; without a previous `cl-defgeneric'.
          (declare-function ,name "")
-         (cl-generic-define-method ',name ',qualifiers ',args
+         (cl-generic-define-method ',name ',(nreverse qualifiers) ',args
                                    ,uses-cnm ,fun)))))
 
 (defun cl--generic-member-method (specializers qualifiers methods)
@@ -359,28 +379,33 @@ which case this method will be invoked when the argument is `eql' to VAL.
          (mandatory (cl--generic-mandatory-args args))
          (specializers
           (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory))
-         (method (cl--generic-method-make
+         (method (cl--generic-make-method
                   specializers qualifiers uses-cnm function))
          (mt (cl--generic-method-table generic))
          (me (cl--generic-member-method specializers qualifiers mt))
          (dispatches (cl--generic-dispatches generic))
          (i 0))
     (dolist (specializer specializers)
-      (let* ((tagcode (funcall cl-generic-tagcode-function specializer 'arg))
+      (let* ((generalizers (cl-generic-generalizers specializer))
              (x (assq i dispatches)))
         (unless x
-          (setq x (list i (funcall cl-generic-tagcode-function t 'arg)))
+          (setq x (cons i (cl-generic-generalizers t)))
           (setf (cl--generic-dispatches generic)
                 (setq dispatches (cons x dispatches))))
-        (unless (member tagcode (cdr x))
-          (setf (cdr x)
-                (nreverse (sort (cons tagcode (cdr x))
-                                #'car-less-than-car))))
+        (dolist (generalizer generalizers)
+          (unless (member generalizer (cdr x))
+            (setf (cdr x)
+                  (sort (cons generalizer (cdr x))
+                        (lambda (x y)
+                          (> (cl--generic-generalizer-priority x)
+                             (cl--generic-generalizer-priority y)))))))
         (setq i (1+ i))))
     (if me (setcar me method)
       (setf (cl--generic-method-table generic) (cons method 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
+    ;; is still valid (e.g. still empty method cache)?
     (let ((gfun (cl--generic-make-function generic))
           ;; Prevent `defalias' from recording this as the definition site of
           ;; the generic function.
@@ -399,62 +424,73 @@ which case this method will be invoked when the argument is `eql' to VAL.
 
 (defvar cl--generic-dispatchers (make-hash-table :test #'equal))
 
-(defun cl--generic-get-dispatcher (tagcodes dispatch-arg)
+(defun cl--generic-get-dispatcher (dispatch)
   (cl--generic-with-memoization
-      (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers)
-    (let ((lexical-binding t)
-          (tag-exp `(or ,@(mapcar #'cdr
-				  ;; Minor optimization: since this tag-exp is
-				  ;; only used to lookup the method-cache, it
-				  ;; doesn't matter if the default value is some
-				  ;; constant or nil.
-				  (if (macroexp-const-p (car (last tagcodes)))
-				      (butlast tagcodes)
-				    tagcodes))))
-          (extraargs ()))
+      (gethash dispatch cl--generic-dispatchers)
+    (let* ((dispatch-arg (car dispatch))
+           (generalizers (cdr dispatch))
+           (lexical-binding t)
+           (tagcodes
+            (mapcar (lambda (generalizer)
+                      (funcall (cl--generic-generalizer-tagcode-function
+                                generalizer)
+                               'arg))
+                    generalizers))
+           (typescodes
+            (mapcar (lambda (generalizer)
+                      `(funcall ',(cl--generic-generalizer-specializers-function
+                                   generalizer)
+                                ,(funcall (cl--generic-generalizer-tagcode-function
+                                           generalizer)
+                                          'arg)))
+                    generalizers))
+           (tag-exp
+            ;; Minor optimization: since this tag-exp is
+            ;; only used to lookup the method-cache, it
+            ;; doesn't matter if the default value is some
+            ;; constant or nil.
+            `(or ,@(if (macroexp-const-p (car (last tagcodes)))
+                       (butlast tagcodes)
+                     tagcodes)))
+           (extraargs ()))
       (dotimes (_ dispatch-arg)
         (push (make-symbol "arg") extraargs))
+      ;; FIXME: For generic functions with a single method (or with 2 methods,
+      ;; one of which always matches), using a tagcode + hash-table is
+      ;; overkill: better just use a `cl-typep' test.
       (byte-compile
-       `(lambda (generic dispatches-left)
+       `(lambda (generic dispatches-left methods)
           (let ((method-cache (make-hash-table :test #'eql)))
             (lambda (,@extraargs arg &rest args)
               (apply (cl--generic-with-memoization
                          (gethash ,tag-exp method-cache)
                        (cl--generic-cache-miss
-                        generic ',dispatch-arg dispatches-left
-                        (list ,@(mapcar #'cdr tagcodes))))
+                        generic ',dispatch-arg dispatches-left methods
+                        ,(if (cdr typescodes)
+                             `(append ,@typescodes) (car typescodes))))
                      ,@extraargs arg args))))))))
 
 (defun cl--generic-make-function (generic)
-  (let* ((dispatches (cl--generic-dispatches generic))
-         (dispatch
+  (cl--generic-make-next-function generic
+                                  (cl--generic-dispatches generic)
+                                  (cl--generic-method-table generic)))
+
+(defun cl--generic-make-next-function (generic dispatches methods)
+  (let* ((dispatch
           (progn
             (while (and dispatches
-                        (member (cdar dispatches)
-                                '(nil ((0 . 'cl--generic-type)))))
+                        (let ((x (nth 1 (car dispatches))))
+                          ;; No need to dispatch for `t' specializers.
+                          (or (null x) (equal x cl--generic-t-generalizer))))
               (setq dispatches (cdr dispatches)))
             (pop dispatches))))
-    (if (null dispatch)
-        (cl--generic-build-combined-method
-         (cl--generic-name generic)
-	 (cl--generic-method-table generic))
-      (let ((dispatcher (cl--generic-get-dispatcher
-                         (cdr dispatch) (car dispatch))))
-        (funcall dispatcher generic dispatches)))))
-
-(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.")
+    (if (not (and dispatch
+                  ;; If there's no method left, there's no point checking
+                  ;; further arguments.
+                  methods))
+        (cl--generic-build-combined-method generic methods)
+      (let ((dispatcher (cl--generic-get-dispatcher dispatch)))
+        (funcall dispatcher generic dispatches methods)))))
 
 (defvar cl--generic-combined-method-memoization
   (make-hash-table :test #'equal :weakness 'value)
@@ -463,27 +499,37 @@ 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 (method methods)
-        (let* ((qualifiers (cl--generic-method-qualifiers method))
-               (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 method (cdr x))
-            (push (list qualifiers method) mets-by-qual))))
-      (funcall cl-generic-method-combination-function
-               generic-name mets-by-qual))))
+(define-error 'cl--generic-cyclic-definition "Cyclic definition: %S")
+
+(defun cl--generic-build-combined-method (generic methods)
+  (if (null methods)
+      ;; Special case needed to fix a circularity during bootstrap.
+      (cl--generic-standard-method-combination generic methods)
+    (let ((f
+           (cl--generic-with-memoization
+               ;; FIXME: Since the fields of `generic' are modified, this
+               ;; hash-table won't work right, because the hashes will change!
+               ;; It's not terribly serious, but reduces the effectiveness of
+               ;; the table.
+               (gethash (cons generic methods)
+                        cl--generic-combined-method-memoization)
+             (puthash (cons generic methods) :cl--generic--under-construction
+                      cl--generic-combined-method-memoization)
+             (condition-case nil
+                 (cl-generic-combine-methods generic methods)
+               ;; Special case needed to fix a circularity during bootstrap.
+               (cl--generic-cyclic-definition
+                (cl--generic-standard-method-combination generic methods))))))
+      (if (eq f :cl--generic--under-construction)
+          (signal 'cl--generic-cyclic-definition
+                  (list (cl--generic-name generic)))
+        f))))
 
 (defun cl--generic-no-next-method-function (generic method)
   (lambda (&rest args)
     (apply #'cl-no-next-method generic method args)))
 
-(defun cl-generic-call-method (generic-name method &optional fun)
+(defun cl-generic-call-method (generic method &optional fun)
   "Return a function that calls METHOD.
 FUN is the function that should be called when METHOD calls
 `call-next-method'."
@@ -491,7 +537,7 @@ FUN is the function that should be called when METHOD calls
       (cl--generic-method-function method)
     (let ((met-fun (cl--generic-method-function method))
           (next (or fun (cl--generic-no-next-method-function
-                         generic-name method))))
+                         generic method))))
       (lambda (&rest args)
         (apply met-fun
                ;; FIXME: This sucks: passing just `next' would
@@ -503,42 +549,122 @@ FUN is the function that should be called when METHOD calls
                  (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))))
+;; Standard CLOS name.
+(defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers)
+
+(defun cl--generic-standard-method-combination (generic methods)
+  (let ((mets-by-qual ()))
+    (dolist (method methods)
+      (let ((qualifiers (cl-method-qualifiers method)))
+        (if (eq (car qualifiers) :extra) (setq qualifiers (cddr qualifiers)))
+        (unless (member qualifiers '(() (:after) (:before) (:around)))
+          (error "Unsupported qualifiers in function %S: %S"
+                 (cl--generic-name generic) qualifiers))
+        (push method (alist-get (car qualifiers) mets-by-qual))))
+    (cond
+     ((null mets-by-qual)
+      (lambda (&rest args)
+        (apply #'cl-no-applicable-method generic args)))
+     ((null (alist-get nil mets-by-qual))
+      (lambda (&rest args)
+        (apply #'cl-no-primary-method generic args)))
+     (t
+      (let* ((fun nil)
+             (ab-call (lambda (m) (cl-generic-call-method generic 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 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 method fun)))
+        fun)))))
+
+(defun cl--generic-cache-miss (generic
+                               dispatch-arg dispatches-left methods-left types)
+  (let ((methods '()))
+    (dolist (method methods-left)
+      (let* ((specializer (or (nth dispatch-arg
+                                   (cl--generic-method-specializers method))
+                              t))
+             (m (member specializer types)))
+        (when m
+          (push (cons (length m) method) methods))))
+    ;; Sort the methods, most specific first.
+    ;; It would be tempting to sort them once and for all in the method-table
+    ;; rather than here, but the order might depend on the actual argument
+    ;; (e.g. for multiple inheritance with defclass).
+    (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
+    (cl--generic-make-next-function generic dispatches-left methods)))
+
+(cl-defgeneric cl-generic-generalizers (specializer)
+  "Return a list of generalizers for a given SPECIALIZER.
+To each kind of `specializer', corresponds a `generalizer' which describes
+how to extract a \"tag\" from an object which will then let us check if this
+object matches the specializer.  A typical example of a \"tag\" would be the
+type of an object.  It's called a `generalizer' because it
+takes a specific object and returns a more general approximation,
+denoting a set of objects to which it belongs.
+A generalizer gives us the chunk of code which the
+dispatch function needs to use to extract the \"tag\" of an object, as well
+as a function which turns this tag into an ordered list of
+`specializers' that this object matches.
+The code which extracts the tag should be as fast as possible.
+The tags should be chosen according to the following rules:
+- The tags should not be too specific: similar objects which match the
+  same list of specializers should ideally use the same (`eql') tag.
+  This insures that the cached computation of the applicable
+  methods for one object can be reused for other objects.
+- Corollary: objects which don't match any of the relevant specializers
+  should ideally all use the same tag (typically nil).
+  This insures that this cache does not grow unnecessarily large.
+- Two different generalizers G1 and G2 should not use the same tag
+  unless they use it for the same set of objects.  IOW, if G1.tag(X1) =
+  G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2).
+- If G1.priority > G2.priority and G1.tag(X1) = G1.tag(X2) and this tag is
+  non-nil, then you have to make sure that the G2.tag(X1) = G2.tag(X2).
+  This is because the method-cache is only indexed with the first non-nil
+  tag (by order of decreasing priority).")
+
+
+(cl-defgeneric cl-generic-combine-methods (generic methods)
+  "Build the effective method made of METHODS.
+It should return a function that expects the same arguments as the methods, and
+ calls those methods in some appropriate order.
+GENERIC is the generic function (mostly used for its name).
+METHODS is the list of the selected methods.
+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)
+
+(cl-defmethod cl-generic-generalizers (specializer)
+  "Support for the catch-all `t' specializer."
+  (if (eq specializer t) (list cl--generic-t-generalizer)
+    (error "Unknown specializer %S" specializer)))
+
+(cl-defmethod cl-generic-combine-methods (generic methods)
+  "Standard support for :after, :before, :around, and `:extra NAME' qualifiers."
+  (cl--generic-standard-method-combination generic methods))
 
 (defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t))
 (defconst cl--generic-cnm-sample
   (funcall (cl--generic-build-combined-method
-            nil (list (cl--generic-method-make () () t #'identity)))))
+            nil (list (cl--generic-make-method () () t #'identity)))))
 
 (defun cl--generic-isnot-nnm-p (cnm)
   "Return non-nil if CNM is the function that calls `cl-no-next-method'."
@@ -566,24 +692,6 @@ FUN is the function that should be called when METHOD calls
           (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 '()))
-    (dolist (method (cl--generic-method-table generic))
-      (let* ((specializer (or (nth dispatch-arg
-                                   (cl--generic-method-specializers method))
-                              t))
-             (m (member specializer types)))
-        (when m
-          (push (cons (length m) method) methods))))
-    ;; Sort the methods, most specific first.
-    ;; It would be tempting to sort them once and for all in the method-table
-    ;; rather than here, but the order might depend on the actual argument
-    ;; (e.g. for multiple inheritance with defclass).
-    (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
-    (cl--generic-make-function (cl--generic-make (cl--generic-name generic)
-                                                 dispatches-left methods))))
-
 ;;; Define some pre-defined generic functions, used internally.
 
 (define-error 'cl-no-method "No method for %S")
@@ -593,19 +701,16 @@ FUN is the function that should be called when METHOD calls
   'cl-no-method)
 
 (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 method &rest args)
-  (signal 'cl-no-next-method `(,generic ,method ,@args)))
+  "Function called when `cl-call-next-method' finds no next method."
+  (signal 'cl-no-next-method `(,(cl--generic-name 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 &rest args)
-  (signal 'cl-no-applicable-method `(,generic ,@args)))
+  "Function called when a method call finds no applicable method."
+  (signal 'cl-no-applicable-method `(,(cl--generic-name generic) ,@args)))
 
 (cl-defgeneric cl-no-primary-method (generic &rest args)
-  "Function called when a method call finds no primary method.")
-(cl-defmethod cl-no-primary-method (generic &rest args)
-  (signal 'cl-no-primary-method `(,generic ,@args)))
+  "Function called when a method call finds no primary method."
+  (signal 'cl-no-primary-method `(,(cl--generic-name generic) ,@args)))
 
 (defun cl-call-next-method (&rest _args)
   "Function to call the next applicable method.
@@ -700,69 +805,110 @@ Can only be used from within the lexical body of a primary or around method."
                 (insert "'.\n")))
             (insert "\n" (or (nth 2 info) "Undocumented") "\n\n")))))))
 
+;;; Support for (head <val>) specializers.
+
+;; For both the `eql' and the `head' specializers, the dispatch
+;; is unsatisfactory.  Basically, in the "common&fast case", we end up doing
+;;
+;;    (let ((tag (gethash value <tagcode-hashtable>)))
+;;      (funcall (gethash tag <method-cache>)))
+;;
+;; whereas we'd like to just do
+;;
+;;      (funcall (gethash value <method-cache>)))
+;;
+;; but the problem is that the method-cache is normally "open ended", so
+;; a nil means "not computed yet" and if we bump into it, we dutifully fill the
+;; corresponding entry, whereas we'd want to just fallback on some default
+;; effective method (so as not to fill the cache with lots of redundant
+;; entries).
+
+(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-defmethod cl-generic-generalizers :extra "head" (specializer)
+  "Support for the `(head VAL)' specializers."
+  ;; We have to implement `head' here using the :extra qualifier,
+  ;; since we can't use the `head' specializer to implement itself.
+  (if (not (eq (car-safe specializer) 'head))
+      (cl-call-next-method)
+    (cl--generic-with-memoization
+        (gethash (cadr specializer) cl--generic-head-used) specializer)
+    (list cl--generic-head-generalizer)))
+
 ;;; Support for (eql <val>) specializers.
 
 (defvar cl--generic-eql-used (make-hash-table :test #'eql))
 
-(add-function :before-until cl-generic-tagcode-function
-              #'cl--generic-eql-tagcode)
-(defun cl--generic-eql-tagcode (type name)
-  (when (eq (car-safe type) 'eql)
-    (puthash (cadr type) type cl--generic-eql-used)
-    `(100 . (gethash ,name cl--generic-eql-used))))
+(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)))))
 
-(add-function :before-until cl-generic-tag-types-function
-              #'cl--generic-eql-tag-types)
-(defun cl--generic-eql-tag-types (tag)
-  (if (eq (car-safe tag) 'eql) (list tag)))
+(cl-defmethod cl-generic-generalizers ((specializer (head eql)))
+  "Support for the `(eql VAL)' specializers."
+  (puthash (cadr specializer) specializer cl--generic-eql-used)
+  (list cl--generic-eql-generalizer))
 
 ;;; Support for cl-defstructs specializers.
 
-(add-function :before-until cl-generic-tagcode-function
-              #'cl--generic-struct-tagcode)
-
 (defun cl--generic-struct-tag (name)
+  ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
+  ;; but that would suffer from some problems:
+  ;; - the vector may have size 0.
+  ;; - when called on an actual vector (rather than an object), we'd
+  ;;   end up returning an arbitrary value, possibly colliding with
+  ;;   other tagcode's values.
+  ;; - it can also result in returning all kinds of irrelevant
+  ;;   values which would end up filling up the method-cache with
+  ;;   lots of irrelevant/redundant entries.
+  ;; FIXME: We could speed this up by introducing a dedicated
+  ;; vector type at the C level, so we could do something like
+  ;; (and (vector-objectp ,name) (aref ,name 0))
   `(and (vectorp ,name)
         (> (length ,name) 0)
         (let ((tag (aref ,name 0)))
           (if (eq (symbol-function tag) :quick-object-witness-check)
               tag))))
 
-(defun cl--generic-struct-tagcode (type name)
-  (and (symbolp type)
-       (get type 'cl-struct-type)
-       (or (eq 'vector (car (get type 'cl-struct-type)))
-           (error "Can't dispatch on cl-struct %S: type is %S"
-                  type (car (get type 'cl-struct-type))))
-       (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots)))
-           (error "Can't dispatch on cl-struct %S: no tag in slot 0"
-                  type))
-       ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
-       ;; but that would suffer from some problems:
-       ;; - the vector may have size 0.
-       ;; - when called on an actual vector (rather than an object), we'd
-       ;;   end up returning an arbitrary value, possibly colliding with
-       ;;   other tagcode's values.
-       ;; - it can also result in returning all kinds of irrelevant
-       ;;   values which would end up filling up the method-cache with
-       ;;   lots of irrelevant/redundant entries.
-       ;; FIXME: We could speed this up by introducing a dedicated
-       ;; vector type at the C level, so we could do something like
-       ;; (and (vector-objectp ,name) (aref ,name 0))
-       `(50 . ,(cl--generic-struct-tag name))))
-
-(add-function :before-until cl-generic-tag-types-function
-              #'cl--generic-struct-tag-types)
-(defun cl--generic-struct-tag-types (tag)
-  ;; FIXME: cl-defstruct doesn't make it easy for us.
-  (and (symbolp tag)
-       ;; A method call shouldn't itself mess with the match-data.
-       (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag))
-       (let ((types (list (intern (substring (symbol-name tag) 10)))))
-         (while (get (car types) 'cl-struct-include)
-           (push (get (car types) 'cl-struct-include) types))
-         (push 'cl-struct types)        ;The "parent type" of all cl-structs.
-         (nreverse types))))
+(defun cl--generic-struct-specializers (tag)
+  (and (symbolp tag) (boundp tag)
+       (let ((class (symbol-value tag)))
+         (when (cl-typep class 'cl-structure-class)
+           (let ((types ())
+                 (classes (list class)))
+             ;; BFS precedence.
+             (while (let ((class (pop classes)))
+                      (push (cl--class-name class) types)
+                      (setq classes
+                            (append classes
+                                    (cl--class-parents class)))))
+             (nreverse types))))))
+
+(defconst cl--generic-struct-generalizer
+  (cl-generic-make-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."
+  (or
+   (when (symbolp type)
+     ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
+     ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
+     ;; take place without requiring cl-lib.
+     (let ((class (cl--find-class type)))
+       (and (cl-typep class 'cl-structure-class)
+            (or (null (cl--struct-class-type class))
+		(error "Can't dispatch on cl-struct %S: type is %S"
+                     type (cl--struct-class-type class)))
+            (progn (cl-assert (null (cl--struct-class-named class))) t)
+            (list cl--generic-struct-generalizer))))
+   (cl-call-next-method)))
 
 ;;; Dispatch on "system types".
 
@@ -784,23 +930,23 @@ Can only be used from within the lexical body of a primary or around method."
     (sequence)
     (number)))
 
-(add-function :before-until cl-generic-tagcode-function
-              #'cl--generic-typeof-tagcode)
-(defun cl--generic-typeof-tagcode (type name)
+(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-defmethod cl-generic-generalizers :extra "typeof" (type)
+  "Support for dispatch on builtin types."
   ;; FIXME: Add support for other types accepted by `cl-typep' such
   ;; as `character', `atom', `face', `function', ...
-  (and (assq type cl--generic-typeof-types)
-       (progn
-         (if (memq type '(vector array sequence))
-             (message "`%S' also matches CL structs and EIEIO classes" type))
-         ;; FIXME: We could also change `type-of' to return `null' for nil.
-         `(10 . (if ,name (type-of ,name) 'null)))))
-
-(add-function :before-until cl-generic-tag-types-function
-              #'cl--generic-typeof-types)
-(defun cl--generic-typeof-types (tag)
-  (and (symbolp tag)
-       (assq tag cl--generic-typeof-types)))
+  (or
+   (and (assq type cl--generic-typeof-types)
+        (progn
+          (if (memq type '(vector array sequence))
+              (message "`%S' also matches CL structs and EIEIO classes" type))
+          (list cl--generic-typeof-generalizer)))
+   (cl-call-next-method)))
 
 ;;; Just for kicks: dispatch on major-mode
 ;;
@@ -814,7 +960,7 @@ Can only be used from within the lexical body of a primary or around method."
 
 ;; (defvar cl--generic-major-modes (make-hash-table :test #'eq))
 ;;
-;; (add-function :before-until cl-generic-tagcode-function
+;; (add-function :before-until cl-generic-generalizer-function
 ;;               #'cl--generic-major-mode-tagcode)
 ;; (defun cl--generic-major-mode-tagcode (type name)
 ;;   (if (eq 'major-mode (car-safe type))