;; Copyright (C) 2015 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Version: 1.0
;; This file is part of GNU Emacs.
;; 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.
-;; - 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.
+;; 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 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-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.
+;; - Methods can dispatch on the context. For that, a method needs to specify
+;; context arguments, introduced by `&context' (which need to come right
+;; after the mandatory arguments and before anything like
+;; &optional/&rest/&key). Each context argument is given as (EXP SPECIALIZER)
+;; which means that EXP is taken as an expression which computes some context
+;; and this value is then used to dispatch.
+;; E.g. (foo &context (major-mode (eql c-mode))) is an arglist specifying
+;; that this method will only be applicable when `major-mode' has value
+;; `c-mode'.
;; 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
;; 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-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 :type symbol :read-only t) ;Pointer back to the symbol.
;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
;; 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' 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 nil :type (list-of (cons (cons (list-of type) keyword)
- (cons boolean function)))))
+ (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))
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
nil))))
(cdr declarations))
(defalias ',name
- (cl-generic-define ',name ',args ',options-and-methods)
- ,(help-add-fundoc-usage doc args)))))
-
-(defun cl--generic-mandatory-args (args)
- (let ((res ()))
- (while (not (memq (car args) '(nil &rest &optional &key)))
- (push (pop args) res))
- (nreverse res)))
+ (cl-generic-define ',name ',args ',(nreverse options))
+ ,(help-add-fundoc-usage doc args))
+ ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
+ (nreverse methods)))))
;;;###autoload
-(defun cl-generic-define (name args options-and-methods)
- (let ((generic (cl-generic-ensure-function name))
- (mandatory (cl--generic-mandatory-args args))
- (apo (assq :argument-precedence-order options-and-methods)))
- (setf (cl--generic-dispatches generic) nil)
+(defun cl-generic-define (name args options)
+ (pcase-let* ((generic (cl-generic-ensure-function name))
+ (`(,spec-args . ,_) (cl--generic-split-args args))
+ (mandatory (mapcar #'car spec-args))
+ (apo (assq :argument-precedence-order options)))
+ (unless (fboundp name)
+ ;; If the generic function was fmakunbound, throw away previous methods.
+ (setf (cl--generic-dispatches generic) nil)
+ (setf (cl--generic-method-table generic) nil))
(when apo
(dolist (arg (cdr apo))
(let ((pos (memq arg mandatory)))
(unless pos (error "%S is not a mandatory argument" arg))
- (push (list (- (length mandatory) (length pos)))
- (cl--generic-dispatches generic)))))
- (setf (cl--generic-method-table generic) nil)
+ (let* ((argno (- (length mandatory) (length pos)))
+ (dispatches (cl--generic-dispatches generic))
+ (dispatch (or (assq argno dispatches) (list argno))))
+ (setf (cl--generic-dispatches generic)
+ (cons dispatch (delq dispatch dispatches)))))))
+ (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)
- "Make the lambda expression for a method with ARGS and BODY."
+ (defun cl--generic-split-args (args)
+ "Return (SPEC-ARGS . PLAIN-ARGS)."
(let ((plain-args ())
(specializers nil)
- (doc-string (if (and (stringp (car-safe body)) (cdr body))
- (pop body)))
(mandatory t))
(dolist (arg args)
(push (pcase arg
((or '&optional '&rest '&key) (setq mandatory nil) arg)
- ((and `(,name . ,type) (guard mandatory))
+ ('&context
+ (unless mandatory
+ (error "&context not immediately after mandatory args"))
+ (setq mandatory 'context) nil)
+ ((let 'nil mandatory) arg)
+ ((let 'context mandatory)
+ (unless (consp arg)
+ (error "Invalid &context arg: %S" arg))
+ (push `((&context . ,(car arg)) . ,(cadr arg)) specializers)
+ nil)
+ (`(,name . ,type)
(push (cons name (car type)) specializers)
name)
- (_ arg))
+ (_
+ (push (cons arg t) specializers)
+ arg))
plain-args))
- (setq plain-args (nreverse plain-args))
- (let ((fun `(cl-function (lambda ,plain-args
- ,@(if doc-string (list doc-string))
- ,@body)))
- (macroenv (cons `(cl-generic-current-method-specializers
- . ,(lambda () specializers))
- macroexpand-all-environment)))
- (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'.
- (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)
- (let* ((doc-string (and doc-string (stringp (car body)) (cdr 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))))))))
+ (cons (nreverse specializers)
+ (nreverse (delq nil plain-args)))))
+
+ (defun cl--generic-lambda (args body)
+ "Make the lambda expression for a method with ARGS and BODY."
+ (pcase-let* ((`(,spec-args . ,plain-args)
+ (cl--generic-split-args args))
+ (fun `(cl-function (lambda ,plain-args ,@body)))
+ (macroenv (cons `(cl-generic-current-method-specializers
+ . ,(lambda () spec-args))
+ macroexpand-all-environment)))
+ (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
(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 setfizer
(setq name (car setfizer))
;; 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)
+ (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)))
- (mt (cl--generic-method-table generic))
- (me (assoc key mt))
- (dispatches (cl--generic-dispatches generic))
- (i 0))
- (dolist (specializer specializers)
- (let* ((tagcode (funcall cl-generic-tagcode-function specializer 'arg))
- (x (assq i dispatches)))
+ (pcase-let*
+ ((generic (cl-generic-ensure-function name))
+ (`(,spec-args . ,_) (cl--generic-split-args args))
+ (specializers (mapcar (lambda (spec-arg)
+ (if (eq '&context (car-safe (car spec-arg)))
+ spec-arg (cdr spec-arg)))
+ spec-args))
+ (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 (spec-arg spec-args)
+ (let* ((key (if (eq '&context (car-safe (car spec-arg)))
+ (car spec-arg) i))
+ (generalizers (cl-generic-generalizers (cdr spec-arg)))
+ (x (assoc key dispatches)))
(unless x
- (setq x (list i (funcall cl-generic-tagcode-function t 'arg)))
+ (setq x (cons key (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 (setcdr me (cons uses-cnm function))
- (setf (cl--generic-method-table generic)
- (cons `(,key ,uses-cnm . ,function) mt)))
+ ;; 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)))
(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)
;; For aliases, cl--generic-name gives us the actual name.
- (defalias (cl--generic-name generic) gfun))))
+ (let ((purify-flag
+ ;; BEWARE! Don't purify this function definition, since that leads
+ ;; to memory corruption if the hash-tables it holds are modified
+ ;; (the GC doesn't trace those pointers).
+ nil))
+ ;; But do use `defalias', so that it interacts properly with nadvice,
+ ;; e.g. for tracing/debug-on-entry.
+ (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 ()))
- (dotimes (_ dispatch-arg)
- (push (make-symbol "arg") extraargs))
+ (gethash dispatch cl--generic-dispatchers)
+ ;; (message "cl--generic-get-dispatcher (%S)" dispatch)
+ (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)))
+ (fixedargs '(arg))
+ (dispatch-idx dispatch-arg)
+ (bindings nil))
+ (when (eq '&context (car-safe dispatch-arg))
+ (setq bindings `((arg ,(cdr dispatch-arg))))
+ (setq fixedargs nil)
+ (setq dispatch-idx 0))
+ (dotimes (i dispatch-idx)
+ (push (make-symbol (format "arg%d" (- dispatch-idx i 1))) fixedargs))
+ ;; 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))))
- ,@extraargs arg args))))))))
+ (lambda (,@fixedargs &rest args)
+ (let ,bindings
+ (apply (cl--generic-with-memoization
+ (gethash ,tag-exp method-cache)
+ (cl--generic-cache-miss
+ generic ',dispatch-arg dispatches-left methods
+ ,(if (cdr typescodes)
+ `(append ,@typescodes) (car typescodes))))
+ ,@fixedargs 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-no-next-method-function (generic)
+(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)
- ;; 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, or maybe the ((SPECIALIZERS
- ;; . QUALIFIER) USE-CNM . FUNCTION) entry from the method
- ;; table, 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 nil args)))
-
-(defun cl--generic-build-combined-method (generic-name methods)
+ (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)))
- ((null (alist-get :primary mets-by-qual))
- (lambda (&rest args)
- (apply #'cl-no-primary-method generic-name args)))
- (t
- (let* ((fun (cl--generic-no-next-method-function generic-name))
- ;; 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-no-next-method-function 'dummy))
+ (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 (if (integerp dispatch-arg)
+ (nth dispatch-arg
+ (cl--generic-method-specializers method))
+ (cdr (assoc 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)))
+
+(eval-when-compile
+ ;; This macro is brittle and only really important in order to be
+ ;; able to preload cl-generic without also preloading the byte-compiler,
+ ;; So we use `eval-when-compile' so as not keep it available longer than
+ ;; strictly needed.
+(defmacro cl--generic-prefill-dispatchers (arg-or-context specializer)
+ (unless (integerp arg-or-context)
+ (setq arg-or-context `(&context . ,arg-or-context)))
+ (unless (fboundp 'cl--generic-get-dispatcher)
+ (require 'cl-generic))
+ (let ((fun (cl--generic-get-dispatcher
+ `(,arg-or-context ,@(cl-generic-generalizers specializer)
+ ,cl--generic-t-generalizer))))
+ ;; Recompute dispatch at run-time, since the generalizers may be slightly
+ ;; different (e.g. byte-compiled rather than interpreted).
+ ;; FIXME: There is a risk that the run-time generalizer is not equivalent
+ ;; to the compile-time one, in which case `fun' may not be correct
+ ;; any more!
+ `(let ((dispatch `(,',arg-or-context
+ ,@(cl-generic-generalizers ',specializer)
+ ,cl--generic-t-generalizer)))
+ ;; (message "Prefilling for %S with \n%S" dispatch ',fun)
+ (puthash dispatch ',fun cl--generic-dispatchers)))))
+
+(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* ((specializer (or (nth dispatch-arg (caar method-desc)) t))
- (m (member specializer 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")
'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.
(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)))))
+
;;; 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]*"
`(cl-defmethod . ,#'cl--generic-search-method)))
(defun cl--generic-method-info (method)
- (pcase-let ((`((,specializers . ,qualifier) ,uses-cnm . ,function) method))
- (let* ((args (help-function-arglist function 'names))
- (docstring (documentation function))
- (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 qualifier combined-args doconly))))
+ (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)
+ ;; Supposedly this is called from help-fns, so help-fns should be loaded at
+ ;; this point.
+ (declare-function help-fns-short-filename "help-fns" (filename))
(let ((generic (if (symbolp function) (cl--generic function))))
(when generic
(require 'help-mode) ;Needed for `help-function-def' button!
(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" (nth 0 info) (nth 1 info)))
- (let* ((met-name (cons function (caar method)))
+ (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 `")
(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)))
+
+(cl--generic-prefill-dispatchers 0 (head eql))
+
;;; 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)))))
+
+(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))
-(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--generic-prefill-dispatchers 0 (eql nil))
+(cl--generic-prefill-dispatchers window-system (eql nil))
;;; 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))))
+(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)))
+
+(cl--generic-prefill-dispatchers 0 cl--generic-generalizer)
;;; Dispatch on "system types".
(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)))
-
-;;; Just for kicks: dispatch on major-mode
-;;
-;; Here's how you'd use it:
-;; (cl-defmethod foo ((x (major-mode text-mode)) y z) ...)
-;; And then
-;; (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
-;; #'cl--generic-major-mode-tagcode)
-;; (defun cl--generic-major-mode-tagcode (type name)
-;; (if (eq 'major-mode (car-safe type))
-;; `(50 . (if (eq ,name 'major-mode)
-;; (cl--generic-with-memoization
-;; (gethash major-mode cl--generic-major-modes)
-;; `(cl--generic-major-mode . ,major-mode))))))
-;;
-;; (add-function :before-until cl-generic-tag-types-function
-;; #'cl--generic-major-mode-types)
-;; (defun cl--generic-major-mode-types (tag)
-;; (when (eq (car-safe tag) 'cl--generic-major-mode)
-;; (if (eq tag 'fundamental-mode) '(fundamental-mode t)
-;; (let ((types `((major-mode ,(cdr tag)))))
-;; (while (get (car types) 'derived-mode-parent)
-;; (push (list 'major-mode (get (car types) 'derived-mode-parent))
-;; types))
-;; (unless (eq 'fundamental-mode (car types))
-;; (push '(major-mode fundamental-mode) types))
-;; (nreverse 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)))
+
+(cl--generic-prefill-dispatchers 0 integer)
;; Local variables:
;; generated-autoload-file: "cl-loaddefs.el"