;; Copyright (C) 2015 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Version: 1.0
;; This file is part of GNU Emacs.
;; Missing elements:
;; - 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
-;; don't have such a thing, we pass nil instead.
+;; CLOS's define-method-combination is IMO overly complicated, and it suffers
+;; 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-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 (eql <val>) dispatch as well as dispatch
-;; on the type of CL structs, and eieio-core.el adds support for EIEIO
-;; defclass objects.
+;; - 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-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 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.
+;; - 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:
(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-make-method
+ (specializers qualifiers uses-cnm function))
+ (:predicate nil))
+ (specializers nil :read-only t :type list)
+ (qualifiers nil :read-only t :type (list-of atom))
+ ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument
+ ;; holding the next-method.
+ (uses-cnm nil :read-only t :type boolean)
+ (function nil :read-only t :type function))
(cl-defstruct (cl--generic
(:constructor nil)
- (:constructor cl--generic-make
- (name &optional dispatches method-table))
+ (:constructor cl--generic-make (name))
(:predicate nil))
- (name nil :read-only t) ;Pointer back to the symbol.
+ (name nil :type symbol :read-only t) ;Pointer back to the symbol.
;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
;; where the EXPs are expressions (to be `or'd together) to compute the tag
;; 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
- ;; `method-table' is a list of
- ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where
- ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method'
- ;; (and hence expects an extra argument holding the next-method).
- method-table)
+ (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))
generic))
(defun cl--generic-setf-rewrite (name)
- (let ((setter (intern (format "cl-generic-setter--%s" name))))
- (cons setter
- `(eval-and-compile
- (unless (eq ',setter (get ',name 'cl-generic-setter))
- ;; (when (get ',name 'gv-expander)
- ;; (error "gv-expander conflicts with (setf %S)" ',name))
- (setf (get ',name 'cl-generic-setter) ',setter)
- (gv-define-setter ,name (val &rest args)
- (cons ',setter (cons val args))))))))
+ (let* ((setter (intern (format "cl-generic-setter--%s" name)))
+ (exp `(unless (eq ',setter (get ',name 'cl-generic-setter))
+ ;; (when (get ',name 'gv-expander)
+ ;; (error "gv-expander conflicts with (setf %S)" ',name))
+ (setf (get ',name 'cl-generic-setter) ',setter)
+ (gv-define-setter ,name (val &rest args)
+ (cons ',setter (cons val args))))))
+ ;; Make sure `setf' can be used right away, e.g. in the body of the method.
+ (eval exp t)
+ (cons setter exp)))
;;;###autoload
(defmacro cl-defgeneric (name args &rest options-and-methods)
function has no body, as its purpose is to decide which method body
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)."
+OPTIONS-AND-METHODS currently understands:
+- (:documentation DOCSTRING)
+- (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)))))))
+ (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
(cadr name))))
(setq name setter)
code))
+ ,@(mapcar (lambda (declaration)
+ (let ((f (cdr (assq (car declaration)
+ defun-declarations-alist))))
+ (cond
+ (f (apply (car f) name args (cdr declaration)))
+ (t (message "Warning: Unknown defun property `%S' in %S"
+ (car declaration) name)
+ 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 ()))
(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))
(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 ()
(and (memq sexp vars) (not (memq sexp res)) (push sexp res))
res))
- (defun cl--generic-lambda (args body with-cnm)
+ (defun cl--generic-lambda (args body)
"Make the lambda expression for a method with ARGS and BODY."
(let ((plain-args ())
(specializers nil)
- (doc-string (if (stringp (car-safe body)) (pop body)))
(mandatory t))
(dolist (arg args)
(push (pcase arg
(_ arg))
plain-args))
(setq plain-args (nreverse plain-args))
- (let ((fun `(cl-function (lambda ,plain-args
- ,@(if doc-string (list doc-string))
- ,@body)))
+ (let ((fun `(cl-function (lambda ,plain-args ,@body)))
(macroenv (cons `(cl-generic-current-method-specializers
. ,(lambda () specializers))
macroexpand-all-environment)))
- (if (not with-cnm)
- (cons nil (macroexpand-all fun macroenv))
- ;; First macroexpand away the cl-function stuff (e.g. &key and
- ;; destructuring args, `declare' and whatnot).
- (pcase (macroexpand fun macroenv)
- (`#'(lambda ,args . ,body)
- (require 'cl-lib) ;Needed to expand `cl-flet'.
- (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-next-method-p ,nmp))
- ,@body)
- macroenv))
- ;; FIXME: Rather than `grep' after the fact, the
- ;; macroexpansion should directly set some flag when cnm
- ;; is used.
- ;; FIXME: Also, optimize the case where call-next-method is
- ;; only called with explicit arguments.
- (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))
- ,(if (not (memq nmp uses-cnm))
- nbody
- `(let ((,nmp (lambda ()
- (cl--generic-isnot-nnm-p ,cnm))))
- ,nbody))))))
- (f (error "Unexpected macroexpansion result: %S" f))))))))
+ (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'.
+ ;; First macroexpand away the cl-function stuff (e.g. &key and
+ ;; destructuring args, `declare' and whatnot).
+ (pcase (macroexpand fun macroenv)
+ (`#'(lambda ,args . ,body)
+ (let* ((parsed-body (macroexp-parse-body body))
+ (cnm (make-symbol "cl--cnm"))
+ (nmp (make-symbol "cl--nmp"))
+ (nbody (macroexpand-all
+ `(cl-flet ((cl-call-next-method ,cnm)
+ (cl-next-method-p ,nmp))
+ ,@(cdr parsed-body))
+ macroenv))
+ ;; FIXME: Rather than `grep' after the fact, the
+ ;; macroexpansion should directly set some flag when cnm
+ ;; is used.
+ ;; FIXME: Also, optimize the case where call-next-method is
+ ;; only called with explicit arguments.
+ (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
+ (cons (not (not uses-cnm))
+ `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
+ ,@(car parsed-body)
+ ,(if (not (memq nmp uses-cnm))
+ nbody
+ `(let ((,nmp (lambda ()
+ (cl--generic-isnot-nnm-p ,cnm))))
+ ,nbody))))))
+ (f (error "Unexpected macroexpansion result: %S" f)))))))
;;;###autoload
list ; arguments
[ &optional stringp ] ; documentation string
def-body))) ; part to be debugged
- (let ((qualifiers nil))
- (while (keywordp args)
+ (let ((qualifiers nil)
+ (setfizer (if (eq 'setf (car-safe name))
+ ;; Call it before we call cl--generic-lambda.
+ (cl--generic-setf-rewrite (cadr name)))))
+ (while (not (listp args))
(push args qualifiers)
(setq args (pop body)))
- (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after))))
- (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm)))
+ (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
`(progn
- ,(when (eq 'setf (car-safe name))
- (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
- (cadr name))))
- (setq name setter)
- code))
- (cl-generic-define-method ',name ',qualifiers ',args
+ ,(when setfizer
+ (setq name (car setfizer))
+ (cdr setfizer))
+ ,(and (get name 'byte-obsolete-info)
+ (or (not (fboundp 'byte-compile-warning-enabled-p))
+ (byte-compile-warning-enabled-p 'obsolete))
+ (let* ((obsolete (get name 'byte-obsolete-info)))
+ (macroexp--warn-and-return
+ (macroexp--obsolete-warning name obsolete "generic function")
+ nil)))
+ ;; You could argue that `defmethod' modifies rather than defines the
+ ;; function, so warnings like "not known to be defined" are fair game.
+ ;; But in practice, it's common to use `cl-defmethod'
+ ;; without a previous `cl-defgeneric'.
+ (declare-function ,name "")
+ (cl-generic-define-method ',name ',(nreverse qualifiers) ',args
,uses-cnm ,fun)))))
+(defun cl--generic-member-method (specializers qualifiers methods)
+ (while
+ (and methods
+ (let ((m (car methods)))
+ (not (and (equal (cl--generic-method-specializers m) specializers)
+ (equal (cl--generic-method-qualifiers m) qualifiers)))))
+ (setq methods (cdr methods)))
+ methods)
+
;;;###autoload
(defun cl-generic-define-method (name qualifiers args uses-cnm function)
- (when (> (length qualifiers) 1)
- (error "We only support a single qualifier per method: %S" qualifiers))
- (unless (memq (car qualifiers) '(nil :primary :around :after :before))
- (error "Unsupported qualifier in: %S" qualifiers))
(let* ((generic (cl-generic-ensure-function name))
(mandatory (cl--generic-mandatory-args args))
(specializers
(mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory))
- (key (cons specializers (or (car qualifiers) ':primary)))
+ (method (cl--generic-make-method
+ specializers qualifiers uses-cnm function))
(mt (cl--generic-method-table generic))
- (me (assoc key mt))
+ (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)))
- (if (not x)
- (setf (cl--generic-dispatches generic)
- (setq dispatches (cons (list i tagcode) dispatches)))
- (unless (member tagcode (cdr x))
+ (unless x
+ (setq x (cons i (cl-generic-generalizers t)))
+ (setf (cl--generic-dispatches generic)
+ (setq dispatches (cons x dispatches))))
+ (dolist (generalizer generalizers)
+ (unless (member generalizer (cdr x))
(setf (cdr x)
- (nreverse (sort (cons tagcode (cdr x))
- #'car-less-than-car)))))
+ (sort (cons generalizer (cdr x))
+ (lambda (x y)
+ (> (cl--generic-generalizer-priority x)
+ (cl--generic-generalizer-priority y)))))))
(setq i (1+ i))))
- (if me (setcdr me (cons uses-cnm function))
- (setf (cl--generic-method-table generic)
- (cons `(,key ,uses-cnm . ,function) mt)))
- ;; For aliases, cl--generic-name gives us the actual name.
+ (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.
current-load-list)
- (defalias (cl--generic-name generic) gfun))
- (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
- current-load-list :test #'equal)))
+ ;; For aliases, cl--generic-name gives us the actual name.
+ (defalias (cl--generic-name generic) gfun))))
(defmacro cl--generic-with-memoization (place &rest code)
(declare (indent 1) (debug t))
(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)))))
-
-(defun cl--generic-nest (fun methods)
- (pcase-dolist (`(,uses-cnm . ,method) methods)
- (setq fun
- (if (not uses-cnm) method
- (let ((next fun))
- (lambda (&rest args)
- (apply method
- ;; FIXME: This sucks: passing just `next' would
- ;; be a lot more efficient than the lambda+apply
- ;; quasi-η, but we need this to implement the
- ;; "if call-next-method is called with no
- ;; arguments, then use the previous arguments".
- (lambda (&rest cnm-args)
- (apply next (or cnm-args args)))
- args))))))
- fun)
+ (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)
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)
+(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 method &optional fun)
+ "Return a function that calls METHOD.
+FUN is the function that should be called when METHOD calls
+`call-next-method'."
+ (if (not (cl--generic-method-uses-cnm method))
+ (cl--generic-method-function method)
+ (let ((met-fun (cl--generic-method-function method))
+ (next (or fun (cl--generic-no-next-method-function
+ generic method))))
+ (lambda (&rest args)
+ (apply met-fun
+ ;; FIXME: This sucks: passing just `next' would
+ ;; be a lot more efficient than the lambda+apply
+ ;; quasi-η, but we need this to implement the
+ ;; "if call-next-method is called with no
+ ;; arguments, then use the previous arguments".
+ (lambda (&rest cnm-args)
+ (apply next (or cnm-args args)))
+ args)))))
+
+;; Standard CLOS name.
+(defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers)
+
+(defun cl--generic-standard-method-combination (generic methods)
(let ((mets-by-qual ()))
- (dolist (qm methods)
- (push (cdr qm) (alist-get (cdar qm) mets-by-qual)))
- (cl--generic-with-memoization
- (gethash (cons generic-name mets-by-qual)
- cl--generic-combined-method-memoization)
- (cond
- ((null mets-by-qual) (lambda (&rest args)
- (apply #'cl-no-applicable-method
- generic-name args)))
- (t
- (let* ((fun (lambda (&rest args)
- ;; FIXME: CLOS passes as second arg the "calling method".
- ;; We don't currently have "method objects" like CLOS
- ;; does so we can't really do it the CLOS way.
- ;; The closest would be to pass the lambda corresponding
- ;; to the method, but the caller wouldn't be able to do
- ;; much with it anyway. So we pass nil for now.
- (apply #'cl-no-next-method generic-name nil args)))
- ;; We use `cdr' to drop the `uses-cnm' annotations.
- (before
- (mapcar #'cdr (reverse (alist-get :before mets-by-qual))))
- (after (mapcar #'cdr (alist-get :after mets-by-qual))))
- (setq fun (cl--generic-nest fun (alist-get :primary mets-by-qual)))
- (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)))))))
- (cl--generic-nest fun (alist-get :around mets-by-qual))))))))
-
-(defconst cl--generic-nnm-sample
- (cl--generic-build-combined-method nil '(((specializer . :qualifier)))))
+ (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 `(((specializer . :primary) 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'."
(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-desc (cl--generic-method-table generic))
- (let ((m (member (nth dispatch-arg (caar method-desc)) types)))
- (when m
- (push (cons (length m) method-desc) 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")
(define-error 'cl-no-next-method "No next method for %S" 'cl-no-method)
+(define-error 'cl-no-primary-method "No primary method for %S" 'cl-no-method)
(define-error 'cl-no-applicable-method "No applicable method for %S"
'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."
+ (signal 'cl-no-primary-method `(,(cl--generic-name generic) ,@args)))
(defun cl-call-next-method (&rest _args)
"Function to call the next applicable 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"))
+;;;###autoload
+(defun cl-find-method (generic qualifiers specializers)
+ (car (cl--generic-member-method
+ specializers qualifiers
+ (cl--generic-method-table (cl--generic generic)))))
+
+(defalias 'cl-method-qualifiers 'cl--generic-method-qualifiers)
+
;;; Add support for describe-function
(defun cl--generic-search-method (met-name)
(let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+"
- (regexp-quote (format "%s\\_>" (car met-name))))))
+ (regexp-quote (format "%s" (car met-name)))
+ "\\_>")))
(or
(re-search-forward
(concat base-re "[^&\"\n]*"
(add-to-list 'find-function-regexp-alist
`(cl-defmethod . ,#'cl--generic-search-method)))
+(defun cl--generic-method-info (method)
+ (let* ((specializers (cl--generic-method-specializers method))
+ (qualifiers (cl--generic-method-qualifiers method))
+ (uses-cnm (cl--generic-method-uses-cnm method))
+ (function (cl--generic-method-function method))
+ (args (help-function-arglist function 'names))
+ (docstring (documentation function))
+ (qual-string
+ (if (null qualifiers) ""
+ (cl-assert (consp qualifiers))
+ (let ((s (prin1-to-string qualifiers)))
+ (concat (substring s 1 -1) " "))))
+ (doconly (if docstring
+ (let ((split (help-split-fundoc docstring nil)))
+ (if split (cdr split) docstring))))
+ (combined-args ()))
+ (if uses-cnm (setq args (cdr args)))
+ (dolist (specializer specializers)
+ (let ((arg (if (eq '&rest (car args))
+ (intern (format "arg%d" (length combined-args)))
+ (pop args))))
+ (push (if (eq specializer t) arg (list arg specializer))
+ combined-args)))
+ (setq combined-args (append (nreverse combined-args) args))
+ (list qual-string combined-args doconly)))
+
(add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
(defun cl--generic-describe (function)
(let ((generic (if (symbolp function) (cl--generic function))))
(insert "\n\nThis is a generic function.\n\n")
(insert (propertize "Implementations:\n\n" 'face 'bold))
;; Loop over fanciful generics
- (pcase-dolist (`((,specializers . ,qualifier) ,uses-cnm . ,method)
- (cl--generic-method-table generic))
- (let* ((args (help-function-arglist method 'names))
- (docstring (documentation method))
- (doconly (if docstring
- (let ((split (help-split-fundoc docstring nil)))
- (if split (cdr split) docstring))))
- (combined-args ()))
- (if uses-cnm (setq args (cdr args)))
- (dolist (specializer specializers)
- (let ((arg (if (eq '&rest (car args))
- (intern (format "arg%d" (length combined-args)))
- (pop args))))
- (push (if (eq specializer t) arg (list arg specializer))
- combined-args)))
- (setq combined-args (append (nreverse combined-args) args))
+ (dolist (method (cl--generic-method-table generic))
+ (let* ((info (cl--generic-method-info method)))
;; FIXME: Add hyperlinks for the types as well.
- (insert (format "%S %S" qualifier combined-args))
- (let* ((met-name (cons function specializers))
+ (insert (format "%s%S" (nth 0 info) (nth 1 info)))
+ (let* ((met-name (cons function
+ (cl--generic-method-specializers method)))
(file (find-lisp-object-file-name met-name 'cl-defmethod)))
(when file
(insert " in `")
'help-function-def met-name file
'cl-defmethod)
(insert "'.\n")))
- (insert "\n" (or doconly "Undocumented") "\n\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-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))
- ;; We could/should check the vector has length >0,
- ;; but really, mixing vectors and structs is a bad idea,
- ;; so let's not waste time trying to handle the case
- ;; of an empty vector.
- ;; BEWARE: this returns a bogus tag for non-struct vectors.
- `(50 . (and (vectorp ,name) (aref ,name 0)))))
-
-(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))))
-
-;;; Dispatch on "old-style types".
+(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-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".
(defconst cl--generic-typeof-types
;; Hand made from the source code of `type-of'.
- '((integer number) (symbol) (string array) (cons list)
+ '((integer number) (symbol) (string array sequence) (cons list sequence)
;; Markers aren't `numberp', yet they are accepted wherever integers are
;; accepted, pretty much.
(marker) (overlay) (float number) (window-configuration)
- (process) (window) (subr) (compiled-function) (buffer) (char-table array)
- (bool-vector array)
+ (process) (window) (subr) (compiled-function) (buffer)
+ (char-table array sequence)
+ (bool-vector array sequence)
(frame) (hash-table) (font-spec) (font-entity) (font-object)
- (vector array)
+ (vector array sequence)
;; Plus, hand made:
- (null list symbol)
- (list)
- (array)
+ (null symbol list sequence)
+ (list sequence)
+ (array sequence)
+ (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))
- (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
;;
;; (foo 'major-mode toto titi)
;;
;; FIXME: Better would be to do that via dispatch on an "implicit argument".
+;; E.g. (cl-defmethod foo (y z &context (major-mode text-mode)) ...)
;; (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))