1 ;;; cl-generic.el --- CLOS-style generic functions for Elisp -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; This implements the most of CLOS's multiple-dispatch generic functions.
26 ;; To use it you need either (require 'cl-generic) or (require 'cl-lib).
27 ;; The main entry points are: `cl-defgeneric' and `cl-defmethod'.
30 ;; - We don't support make-method, call-method, define-method-combination.
31 ;; CLOS's define-method-combination is IMO overly complicated, and it suffers
32 ;; from a significant problem: the method-combination code returns a sexp
33 ;; that needs to be `eval'uated or compiled. IOW it requires run-time
34 ;; code generation. Given how rarely method-combinations are used,
35 ;; I just provided a cl-generic-combine-methods generic function, to which
36 ;; people can add methods if they are really desperate for such functionality.
37 ;; - In defgeneric we don't support the options:
38 ;; declare, :method-combination, :generic-function-class, :method-class.
40 ;; - We support aliases to generic functions.
41 ;; - cl-generic-generalizers. This generic function lets you extend the kind
42 ;; of thing on which to dispatch. There is support in this file for
45 ;; - (head <val>) which checks that the arg is a cons with <val> as its head.
47 ;; - type of CL structs
48 ;; eieio-core adds dispatch on:
49 ;; - class of eieio objects
50 ;; - actual class argument, using the syntax (subclass <class>).
51 ;; - cl-generic-combine-methods (i.s.o define-method-combination and
52 ;; compute-effective-method).
53 ;; - cl-generic-call-method (which replaces make-method and call-method).
54 ;; - The standard method combination supports ":extra STRING" qualifiers
55 ;; which simply allows adding more methods for the same
56 ;; specializers&qualifiers.
57 ;; - Methods can dispatch on the context. For that, a method needs to specify
58 ;; context arguments, introduced by `&context' (which need to come right
59 ;; after the mandatory arguments and before anything like
60 ;; &optional/&rest/&key). Each context argument is given as (EXP SPECIALIZER)
61 ;; which means that EXP is taken as an expression which computes some context
62 ;; and this value is then used to dispatch.
63 ;; E.g. (foo &context (major-mode (eql c-mode))) is an arglist specifying
64 ;; that this method will only be applicable when `major-mode' has value
67 ;; Efficiency considerations: overall, I've made an effort to make this fairly
68 ;; efficient for the expected case (e.g. no constant redefinition of methods).
69 ;; - Generic functions which do not dispatch on any argument are implemented
70 ;; optimally (just as efficient as plain old functions).
71 ;; - Generic functions which only dispatch on one argument are fairly efficient
72 ;; (not a lot of room for improvement without changes to the byte-compiler,
74 ;; - Multiple dispatch is implemented rather naively. There's an extra `apply'
75 ;; function call for every dispatch; we don't optimize each dispatch
76 ;; based on the set of candidate methods remaining; we don't optimize the
77 ;; order in which we performs the dispatches either;
78 ;; If/when this becomes a problem, we can try and optimize it.
79 ;; - call-next-method could be made more efficient, but isn't too terrible.
83 ;; - A generic "filter" generalizer (e.g. could be used to cleanly add methods
84 ;; to cl-generic-combine-methods with a specializer that says it applies only
85 ;; when some particular qualifier is used).
86 ;; - A way to dispatch on the context (e.g. the major-mode, some global
87 ;; variable, you name it).
91 ;; Note: For generic functions that dispatch on several arguments (i.e. those
92 ;; which use the multiple-dispatch feature), we always use the same "tagcodes"
93 ;; and the same set of arguments on which to dispatch. This works, but is
94 ;; often suboptimal since after one dispatch, the remaining dispatches can
95 ;; usually be simplified, or even completely skipped.
97 (eval-when-compile (require 'cl-lib))
98 (eval-when-compile (require 'cl-macs)) ;For cl--find-class.
99 (eval-when-compile (require 'pcase))
101 (cl-defstruct (cl--generic-generalizer
103 (:constructor cl-generic-make-generalizer
104 (name priority tagcode-function specializers-function)))
105 (name nil :type string)
106 (priority nil :type integer)
108 specializers-function)
111 (defmacro cl-generic-define-generalizer
112 (name priority tagcode-function specializers-function)
113 "Define a new kind of generalizer.
114 NAME is the name of the variable that will hold it.
115 PRIORITY defines which generalizer takes precedence.
116 The catch-all generalizer has priority 0.
117 Then `eql' generalizer has priority 100.
118 TAGCODE-FUNCTION takes as first argument a varname and should return
119 a chunk of code that computes the tag of the value held in that variable.
120 Further arguments are reserved for future use.
121 SPECIALIZERS-FUNCTION takes as first argument a tag value TAG
122 and should return a list of specializers that match TAG.
123 Further arguments are reserved for future use."
124 (declare (indent 1) (debug (symbolp body)))
126 (cl-generic-make-generalizer
127 ',name ,priority ,tagcode-function ,specializers-function)))
129 (cl-generic-define-generalizer cl--generic-t-generalizer
130 0 (lambda (_name &rest _) nil) (lambda (_tag &rest _) '(t)))
132 (cl-defstruct (cl--generic-method
134 (:constructor cl--generic-make-method
135 (specializers qualifiers uses-cnm function))
137 (specializers nil :read-only t :type list)
138 (qualifiers nil :read-only t :type (list-of atom))
139 ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument
140 ;; holding the next-method.
141 (uses-cnm nil :read-only t :type boolean)
142 (function nil :read-only t :type function))
144 (cl-defstruct (cl--generic
146 (:constructor cl--generic-make (name))
148 (name nil :type symbol :read-only t) ;Pointer back to the symbol.
149 ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
150 ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
151 ;; where the EXPs are expressions (to be `or'd together) to compute the tag
152 ;; on which to dispatch and PRIORITY is the priority of each expression to
153 ;; decide in which order to sort them.
154 ;; The most important dispatch is last in the list (and the least is first).
155 (dispatches nil :type (list-of (cons natnum (list-of generalizers))))
156 (method-table nil :type (list-of cl--generic-method))
157 (options nil :type list))
159 (defun cl-generic-function-options (generic)
160 "Return the options of the generic function GENERIC."
161 (cl--generic-options generic))
163 (defmacro cl--generic (name)
164 `(get ,name 'cl--generic))
166 (defun cl-generic-ensure-function (name &optional noerror)
169 (while (and (null (setq generic (cl--generic name)))
172 (symbolp (symbol-function name)))
173 (setq name (symbol-function name)))
174 (unless (or (not (fboundp name))
175 (autoloadp (symbol-function name))
176 (and (functionp name) generic)
178 (error "%s is already defined as something else than a generic function"
181 (cl-assert (eq name (cl--generic-name generic)))
182 (setf (cl--generic name) (setq generic (cl--generic-make name)))
183 (defalias name (cl--generic-make-function generic)))
187 (defmacro cl-defgeneric (name args &rest options-and-methods)
188 "Create a generic function NAME.
189 DOC-STRING is the base documentation for this class. A generic
190 function has no body, as its purpose is to decide which method body
191 is appropriate to use. Specific methods are defined with `cl-defmethod'.
192 With this implementation the ARGS are currently ignored.
193 OPTIONS-AND-METHODS currently understands:
194 - (:documentation DOCSTRING)
195 - (declare DECLARATIONS)
196 - (:argument-precedence-order &rest ARGS)
197 - (:method [QUALIFIERS...] ARGS &rest BODY)
198 BODY, if present, is used as the body of a default method.
200 \(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)"
201 (declare (indent 2) (doc-string 3))
202 (let* ((doc (if (stringp (car-safe options-and-methods))
203 (pop options-and-methods)))
208 (while (progn (setq next-head (car-safe (car options-and-methods)))
209 (or (keywordp next-head)
210 (eq next-head 'declare)))
213 (when doc (error "Multiple doc strings for %S" name))
214 (setq doc (cadr (pop options-and-methods))))
216 (when declarations (error "Multiple `declare' for %S" name))
217 (setq declarations (pop options-and-methods)))
218 (`:method (push (cdr (pop options-and-methods)) methods))
219 (_ (push (pop options-and-methods) options))))
220 (when options-and-methods
221 ;; Anything remaining is assumed to be a default method body.
222 (push `(,args ,@options-and-methods) methods))
223 (when (eq 'setf (car-safe name))
225 (setq name (gv-setter (cadr name))))
227 ,@(mapcar (lambda (declaration)
228 (let ((f (cdr (assq (car declaration)
229 defun-declarations-alist))))
231 (f (apply (car f) name args (cdr declaration)))
232 (t (message "Warning: Unknown defun property `%S' in %S"
233 (car declaration) name)
237 (cl-generic-define ',name ',args ',(nreverse options))
238 ,(help-add-fundoc-usage doc args))
239 ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
240 (nreverse methods)))))
243 (defun cl-generic-define (name args options)
244 (pcase-let* ((generic (cl-generic-ensure-function name 'noerror))
245 (`(,spec-args . ,_) (cl--generic-split-args args))
246 (mandatory (mapcar #'car spec-args))
247 (apo (assq :argument-precedence-order options)))
248 (unless (fboundp name)
249 ;; If the generic function was fmakunbound, throw away previous methods.
250 (setf (cl--generic-dispatches generic) nil)
251 (setf (cl--generic-method-table generic) nil))
253 (dolist (arg (cdr apo))
254 (let ((pos (memq arg mandatory)))
255 (unless pos (error "%S is not a mandatory argument" arg))
256 (let* ((argno (- (length mandatory) (length pos)))
257 (dispatches (cl--generic-dispatches generic))
258 (dispatch (or (assq argno dispatches) (list argno))))
259 (setf (cl--generic-dispatches generic)
260 (cons dispatch (delq dispatch dispatches)))))))
261 (setf (cl--generic-options generic) options)
262 (cl--generic-make-function generic)))
264 (defmacro cl-generic-current-method-specializers ()
265 "List of (VAR . TYPE) where TYPE is var's specializer.
266 This macro can only be used within the lexical scope of a cl-generic method."
267 (error "cl-generic-current-method-specializers used outside of a method"))
269 (defmacro cl-generic-define-context-rewriter (name args &rest body)
270 "Define a special kind of context named NAME.
271 Whenever a context specializer of the form (NAME . ARGS) appears,
272 the specializer used will be the one returned by BODY."
273 (declare (debug (&define name lambda-list def-body)) (indent defun))
275 (put ',name 'cl-generic--context-rewriter
276 (lambda ,args ,@body))))
278 (eval-and-compile ;Needed while compiling the cl-defmethod calls below!
279 (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el.
280 "Check which of the symbols VARS appear in SEXP."
283 (dolist (var (cl--generic-fgrep vars (pop sexp)))
284 (unless (memq var res) (push var res))))
285 (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
288 (defun cl--generic-split-args (args)
289 "Return (SPEC-ARGS . PLAIN-ARGS)."
290 (let ((plain-args ())
295 ((or '&optional '&rest '&key) (setq mandatory nil) arg)
298 (error "&context not immediately after mandatory args"))
299 (setq mandatory 'context) nil)
300 ((let 'nil mandatory) arg)
301 ((let 'context mandatory)
303 (error "Invalid &context arg: %S" arg))
304 (let* ((name (car arg))
307 (get name 'cl-generic--context-rewriter))))
308 (if rewriter (setq arg (apply rewriter (cdr arg)))))
309 (push `((&context . ,(car arg)) . ,(cadr arg)) specializers)
312 (push (cons name (car type)) specializers)
315 (push (cons arg t) specializers)
318 (cons (nreverse specializers)
319 (nreverse (delq nil plain-args)))))
321 (defun cl--generic-lambda (args body)
322 "Make the lambda expression for a method with ARGS and BODY."
323 (pcase-let* ((`(,spec-args . ,plain-args)
324 (cl--generic-split-args args))
325 (fun `(cl-function (lambda ,plain-args ,@body)))
326 (macroenv (cons `(cl-generic-current-method-specializers
327 . ,(lambda () spec-args))
328 macroexpand-all-environment)))
329 (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'.
330 ;; First macroexpand away the cl-function stuff (e.g. &key and
331 ;; destructuring args, `declare' and whatnot).
332 (pcase (macroexpand fun macroenv)
333 (`#'(lambda ,args . ,body)
334 (let* ((parsed-body (macroexp-parse-body body))
335 (cnm (make-symbol "cl--cnm"))
336 (nmp (make-symbol "cl--nmp"))
337 (nbody (macroexpand-all
338 `(cl-flet ((cl-call-next-method ,cnm)
339 (cl-next-method-p ,nmp))
342 ;; FIXME: Rather than `grep' after the fact, the
343 ;; macroexpansion should directly set some flag when cnm
345 ;; FIXME: Also, optimize the case where call-next-method is
346 ;; only called with explicit arguments.
347 (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
348 (cons (not (not uses-cnm))
349 `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
351 ,(if (not (memq nmp uses-cnm))
353 `(let ((,nmp (lambda ()
354 (cl--generic-isnot-nnm-p ,cnm))))
356 (f (error "Unexpected macroexpansion result: %S" f))))))
360 (defmacro cl-defmethod (name args &rest body)
361 "Define a new method for generic function NAME.
362 I.e. it defines the implementation of NAME to use for invocations where the
363 value of the dispatch argument matches the specified TYPE.
364 The dispatch argument has to be one of the mandatory arguments, and
365 all methods of NAME have to use the same argument for dispatch.
366 The dispatch argument and TYPE are specified in ARGS where the corresponding
367 formal argument appears as (VAR TYPE) rather than just VAR.
369 The optional second argument QUALIFIER is a specifier that
370 modifies how the method is combined with other methods, including:
371 :before - Method will be called before the primary
372 :after - Method will be called after the primary
373 :around - Method will be called around everything else
374 The absence of QUALIFIER means this is a \"primary\" method.
376 Other than a type, TYPE can also be of the form `(eql VAL)' in
377 which case this method will be invoked when the argument is `eql' to VAL.
379 \(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
380 (declare (doc-string 3) (indent 2)
382 (&define ; this means we are defining something
383 [&or name ("setf" :name setf name)]
384 ;; ^^ This is the methods symbol
385 [ &optional keywordp ] ; this is key :before etc
387 [ &optional stringp ] ; documentation string
388 def-body))) ; part to be debugged
389 (let ((qualifiers nil))
390 (while (not (listp args))
391 (push args qualifiers)
392 (setq args (pop body)))
393 (when (eq 'setf (car-safe name))
395 (setq name (gv-setter (cadr name))))
396 (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
398 ,(and (get name 'byte-obsolete-info)
399 (or (not (fboundp 'byte-compile-warning-enabled-p))
400 (byte-compile-warning-enabled-p 'obsolete))
401 (let* ((obsolete (get name 'byte-obsolete-info)))
402 (macroexp--warn-and-return
403 (macroexp--obsolete-warning name obsolete "generic function")
405 ;; You could argue that `defmethod' modifies rather than defines the
406 ;; function, so warnings like "not known to be defined" are fair game.
407 ;; But in practice, it's common to use `cl-defmethod'
408 ;; without a previous `cl-defgeneric'.
409 (declare-function ,name "")
410 (cl-generic-define-method ',name ',(nreverse qualifiers) ',args
413 (defun cl--generic-member-method (specializers qualifiers methods)
416 (let ((m (car methods)))
417 (not (and (equal (cl--generic-method-specializers m) specializers)
418 (equal (cl--generic-method-qualifiers m) qualifiers)))))
419 (setq methods (cdr methods)))
423 (defun cl-generic-define-method (name qualifiers args uses-cnm function)
425 ((generic (cl-generic-ensure-function name))
426 (`(,spec-args . ,_) (cl--generic-split-args args))
427 (specializers (mapcar (lambda (spec-arg)
428 (if (eq '&context (car-safe (car spec-arg)))
429 spec-arg (cdr spec-arg)))
431 (method (cl--generic-make-method
432 specializers qualifiers uses-cnm function))
433 (mt (cl--generic-method-table generic))
434 (me (cl--generic-member-method specializers qualifiers mt))
435 (dispatches (cl--generic-dispatches generic))
437 (dolist (spec-arg spec-args)
438 (let* ((key (if (eq '&context (car-safe (car spec-arg)))
440 (generalizers (cl-generic-generalizers (cdr spec-arg)))
441 (x (assoc key dispatches)))
443 (setq x (cons key (cl-generic-generalizers t)))
444 (setf (cl--generic-dispatches generic)
445 (setq dispatches (cons x dispatches))))
446 (dolist (generalizer generalizers)
447 (unless (member generalizer (cdr x))
449 (sort (cons generalizer (cdr x))
451 (> (cl--generic-generalizer-priority x)
452 (cl--generic-generalizer-priority y)))))))
454 ;; We used to (setcar me method), but that can cause false positives in
455 ;; the hash-consing table of the method-builder (bug#20644).
456 ;; See also the related FIXME in cl--generic-build-combined-method.
457 (setf (cl--generic-method-table generic)
460 ;; Keep the ordering; important for methods with :extra qualifiers.
461 (mapcar (lambda (x) (if (eq x (car me)) method x)) mt)))
462 (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
463 current-load-list :test #'equal)
464 ;; FIXME: Try to avoid re-constructing a new function if the old one
465 ;; is still valid (e.g. still empty method cache)?
466 (let ((gfun (cl--generic-make-function generic))
467 ;; Prevent `defalias' from recording this as the definition site of
468 ;; the generic function.
470 ;; For aliases, cl--generic-name gives us the actual name.
472 ;; BEWARE! Don't purify this function definition, since that leads
473 ;; to memory corruption if the hash-tables it holds are modified
474 ;; (the GC doesn't trace those pointers).
476 ;; But do use `defalias', so that it interacts properly with nadvice,
477 ;; e.g. for tracing/debug-on-entry.
478 (defalias (cl--generic-name generic) gfun)))))
480 (defmacro cl--generic-with-memoization (place &rest code)
481 (declare (indent 1) (debug t))
482 (gv-letplace (getter setter) place
484 ,(macroexp-let2 nil val (macroexp-progn code)
486 ,(funcall setter val)
489 (defvar cl--generic-dispatchers (make-hash-table :test #'equal))
491 (defun cl--generic-get-dispatcher (dispatch)
492 (cl--generic-with-memoization
493 (gethash dispatch cl--generic-dispatchers)
494 ;; (message "cl--generic-get-dispatcher (%S)" dispatch)
495 (let* ((dispatch-arg (car dispatch))
496 (generalizers (cdr dispatch))
499 (mapcar (lambda (generalizer)
500 (funcall (cl--generic-generalizer-tagcode-function
506 (lambda (generalizer)
507 `(funcall ',(cl--generic-generalizer-specializers-function
509 ,(funcall (cl--generic-generalizer-tagcode-function
514 ;; Minor optimization: since this tag-exp is
515 ;; only used to lookup the method-cache, it
516 ;; doesn't matter if the default value is some
518 `(or ,@(if (macroexp-const-p (car (last tagcodes)))
522 (dispatch-idx dispatch-arg)
524 (when (eq '&context (car-safe dispatch-arg))
525 (setq bindings `((arg ,(cdr dispatch-arg))))
527 (setq dispatch-idx 0))
528 (dotimes (i dispatch-idx)
529 (push (make-symbol (format "arg%d" (- dispatch-idx i 1))) fixedargs))
530 ;; FIXME: For generic functions with a single method (or with 2 methods,
531 ;; one of which always matches), using a tagcode + hash-table is
532 ;; overkill: better just use a `cl-typep' test.
534 `(lambda (generic dispatches-left methods)
535 (let ((method-cache (make-hash-table :test #'eql)))
536 (lambda (,@fixedargs &rest args)
538 (apply (cl--generic-with-memoization
539 (gethash ,tag-exp method-cache)
540 (cl--generic-cache-miss
541 generic ',dispatch-arg dispatches-left methods
542 ,(if (cdr typescodes)
543 `(append ,@typescodes) (car typescodes))))
544 ,@fixedargs args)))))))))
546 (defun cl--generic-make-function (generic)
547 (cl--generic-make-next-function generic
548 (cl--generic-dispatches generic)
549 (cl--generic-method-table generic)))
551 (defun cl--generic-make-next-function (generic dispatches methods)
554 (while (and dispatches
555 (let ((x (nth 1 (car dispatches))))
556 ;; No need to dispatch for t specializers.
557 (or (null x) (equal x cl--generic-t-generalizer))))
558 (setq dispatches (cdr dispatches)))
560 (if (not (and dispatch
561 ;; If there's no method left, there's no point checking
562 ;; further arguments.
564 (cl--generic-build-combined-method generic methods)
565 (let ((dispatcher (cl--generic-get-dispatcher dispatch)))
566 (funcall dispatcher generic dispatches methods)))))
568 (defvar cl--generic-combined-method-memoization
569 (make-hash-table :test #'equal :weakness 'value)
570 "Table storing previously built combined-methods.
571 This is particularly useful when many different tags select the same set
572 of methods, since this table then allows us to share a single combined-method
573 for all those different tags in the method-cache.")
575 (define-error 'cl--generic-cyclic-definition "Cyclic definition: %S")
577 (defun cl--generic-build-combined-method (generic methods)
579 ;; Special case needed to fix a circularity during bootstrap.
580 (cl--generic-standard-method-combination generic methods)
582 (cl--generic-with-memoization
583 ;; FIXME: Since the fields of `generic' are modified, this
584 ;; hash-table won't work right, because the hashes will change!
585 ;; It's not terribly serious, but reduces the effectiveness of
587 (gethash (cons generic methods)
588 cl--generic-combined-method-memoization)
589 (puthash (cons generic methods) :cl--generic--under-construction
590 cl--generic-combined-method-memoization)
592 (cl-generic-combine-methods generic methods)
593 ;; Special case needed to fix a circularity during bootstrap.
594 (cl--generic-cyclic-definition
595 (cl--generic-standard-method-combination generic methods))))))
596 (if (eq f :cl--generic--under-construction)
597 (signal 'cl--generic-cyclic-definition
598 (list (cl--generic-name generic)))
601 (defun cl--generic-no-next-method-function (generic method)
603 (apply #'cl-no-next-method generic method args)))
605 (defun cl-generic-call-method (generic method &optional fun)
606 "Return a function that calls METHOD.
607 FUN is the function that should be called when METHOD calls
609 (if (not (cl--generic-method-uses-cnm method))
610 (cl--generic-method-function method)
611 (let ((met-fun (cl--generic-method-function method))
612 (next (or fun (cl--generic-no-next-method-function
616 ;; FIXME: This sucks: passing just `next' would
617 ;; be a lot more efficient than the lambda+apply
618 ;; quasi-η, but we need this to implement the
619 ;; "if call-next-method is called with no
620 ;; arguments, then use the previous arguments".
621 (lambda (&rest cnm-args)
622 (apply next (or cnm-args args)))
625 ;; Standard CLOS name.
626 (defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers)
628 (defun cl--generic-standard-method-combination (generic methods)
629 (let ((mets-by-qual ()))
630 (dolist (method methods)
631 (let ((qualifiers (cl-method-qualifiers method)))
632 (if (eq (car qualifiers) :extra) (setq qualifiers (cddr qualifiers)))
633 (unless (member qualifiers '(() (:after) (:before) (:around)))
634 (error "Unsupported qualifiers in function %S: %S"
635 (cl--generic-name generic) qualifiers))
636 (push method (alist-get (car qualifiers) mets-by-qual))))
640 (apply #'cl-no-applicable-method generic args)))
641 ((null (alist-get nil mets-by-qual))
643 (apply #'cl-no-primary-method generic args)))
646 (ab-call (lambda (m) (cl-generic-call-method generic m)))
648 (mapcar ab-call (reverse (cdr (assoc :before mets-by-qual)))))
649 (after (mapcar ab-call (cdr (assoc :after mets-by-qual)))))
650 (dolist (method (cdr (assoc nil mets-by-qual)))
651 (setq fun (cl-generic-call-method generic method fun)))
652 (when (or after before)
654 (setq fun (lambda (&rest args)
660 (apply af args)))))))
661 (dolist (method (cdr (assoc :around mets-by-qual)))
662 (setq fun (cl-generic-call-method generic method fun)))
665 (defun cl--generic-arg-specializer (method dispatch-arg)
666 (or (if (integerp dispatch-arg)
668 (cl--generic-method-specializers method))
669 (cdr (assoc dispatch-arg
670 (cl--generic-method-specializers method))))
673 (defun cl--generic-cache-miss (generic
674 dispatch-arg dispatches-left methods-left types)
676 (dolist (method methods-left)
677 (let* ((specializer (cl--generic-arg-specializer method dispatch-arg))
678 (m (member specializer types)))
680 (push (cons (length m) method) methods))))
681 ;; Sort the methods, most specific first.
682 ;; It would be tempting to sort them once and for all in the method-table
683 ;; rather than here, but the order might depend on the actual argument
684 ;; (e.g. for multiple inheritance with defclass).
685 (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
686 (cl--generic-make-next-function generic dispatches-left methods)))
688 (cl-defgeneric cl-generic-generalizers (specializer)
689 "Return a list of generalizers for a given SPECIALIZER.
690 To each kind of `specializer', corresponds a `generalizer' which describes
691 how to extract a \"tag\" from an object which will then let us check if this
692 object matches the specializer. A typical example of a \"tag\" would be the
693 type of an object. It's called a `generalizer' because it
694 takes a specific object and returns a more general approximation,
695 denoting a set of objects to which it belongs.
696 A generalizer gives us the chunk of code which the
697 dispatch function needs to use to extract the \"tag\" of an object, as well
698 as a function which turns this tag into an ordered list of
699 `specializers' that this object matches.
700 The code which extracts the tag should be as fast as possible.
701 The tags should be chosen according to the following rules:
702 - The tags should not be too specific: similar objects which match the
703 same list of specializers should ideally use the same (`eql') tag.
704 This insures that the cached computation of the applicable
705 methods for one object can be reused for other objects.
706 - Corollary: objects which don't match any of the relevant specializers
707 should ideally all use the same tag (typically nil).
708 This insures that this cache does not grow unnecessarily large.
709 - Two different generalizers G1 and G2 should not use the same tag
710 unless they use it for the same set of objects. IOW, if G1.tag(X1) =
711 G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2).
712 - If G1.priority > G2.priority and G1.tag(X1) = G1.tag(X2) and this tag is
713 non-nil, then you have to make sure that the G2.tag(X1) = G2.tag(X2).
714 This is because the method-cache is only indexed with the first non-nil
715 tag (by order of decreasing priority).")
717 (cl-defgeneric cl-generic-combine-methods (generic methods)
718 "Build the effective method made of METHODS.
719 It should return a function that expects the same arguments as the methods, and
720 calls those methods in some appropriate order.
721 GENERIC is the generic function (mostly used for its name).
722 METHODS is the list of the selected methods.
723 The METHODS list is sorted from most specific first to most generic last.
724 The function can use `cl-generic-call-method' to create functions that call those
727 (unless (ignore-errors (cl-generic-generalizers t))
728 ;; Temporary definition to let the next defmethod succeed.
729 (fset 'cl-generic-generalizers
730 (lambda (specializer)
731 (if (eq t specializer) (list cl--generic-t-generalizer))))
732 (fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination))
734 (cl-defmethod cl-generic-generalizers (specializer)
735 "Support for the catch-all t specializer."
736 (if (eq specializer t) (list cl--generic-t-generalizer)
737 (error "Unknown specializer %S" specializer)))
740 ;; This macro is brittle and only really important in order to be
741 ;; able to preload cl-generic without also preloading the byte-compiler,
742 ;; So we use `eval-when-compile' so as not keep it available longer than
744 (defmacro cl--generic-prefill-dispatchers (arg-or-context specializer)
745 (unless (integerp arg-or-context)
746 (setq arg-or-context `(&context . ,arg-or-context)))
747 (unless (fboundp 'cl--generic-get-dispatcher)
748 (require 'cl-generic))
749 (let ((fun (cl--generic-get-dispatcher
750 `(,arg-or-context ,@(cl-generic-generalizers specializer)
751 ,cl--generic-t-generalizer))))
752 ;; Recompute dispatch at run-time, since the generalizers may be slightly
753 ;; different (e.g. byte-compiled rather than interpreted).
754 ;; FIXME: There is a risk that the run-time generalizer is not equivalent
755 ;; to the compile-time one, in which case `fun' may not be correct
757 `(let ((dispatch `(,',arg-or-context
758 ,@(cl-generic-generalizers ',specializer)
759 ,cl--generic-t-generalizer)))
760 ;; (message "Prefilling for %S with \n%S" dispatch ',fun)
761 (puthash dispatch ',fun cl--generic-dispatchers)))))
763 (cl-defmethod cl-generic-combine-methods (generic methods)
764 "Standard support for :after, :before, :around, and `:extra NAME' qualifiers."
765 (cl--generic-standard-method-combination generic methods))
767 (defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t))
768 (defconst cl--generic-cnm-sample
769 (funcall (cl--generic-build-combined-method
770 nil (list (cl--generic-make-method () () t #'identity)))))
772 (defun cl--generic-isnot-nnm-p (cnm)
773 "Return non-nil if CNM is the function that calls `cl-no-next-method'."
774 ;; ¡Big Gross Ugly Hack!
775 ;; `next-method-p' just sucks, we should let it die. But EIEIO did support
776 ;; it, and some packages use it, so we need to support it.
778 (cl-assert (function-equal cnm cl--generic-cnm-sample))
779 (if (byte-code-function-p cnm)
780 (let ((cnm-constants (aref cnm 2))
781 (sample-constants (aref cl--generic-cnm-sample 2)))
782 (dotimes (i (length sample-constants))
783 (when (function-equal (aref sample-constants i)
784 cl--generic-nnm-sample)
786 (not (function-equal (aref cnm-constants i)
787 cl--generic-nnm-sample))))))
788 (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample)))
789 (let ((cnm-env (cadr cnm)))
790 (dolist (vb (cadr cl--generic-cnm-sample))
791 (when (function-equal (cdr vb) cl--generic-nnm-sample)
793 (not (function-equal (cdar cnm-env)
794 cl--generic-nnm-sample))))
795 (setq cnm-env (cdr cnm-env)))))
796 (error "Haven't found no-next-method-sample in cnm-sample")))
798 ;;; Define some pre-defined generic functions, used internally.
800 (define-error 'cl-no-method "No method")
801 (define-error 'cl-no-next-method "No next method" 'cl-no-method)
802 (define-error 'cl-no-primary-method "No primary method" 'cl-no-method)
803 (define-error 'cl-no-applicable-method "No applicable method"
806 (cl-defgeneric cl-no-next-method (generic method &rest args)
807 "Function called when `cl-call-next-method' finds no next method."
808 (signal 'cl-no-next-method `(,(cl--generic-name generic) ,method ,@args)))
810 (cl-defgeneric cl-no-applicable-method (generic &rest args)
811 "Function called when a method call finds no applicable method."
812 (signal 'cl-no-applicable-method `(,(cl--generic-name generic) ,@args)))
814 (cl-defgeneric cl-no-primary-method (generic &rest args)
815 "Function called when a method call finds no primary method."
816 (signal 'cl-no-primary-method `(,(cl--generic-name generic) ,@args)))
818 (defun cl-call-next-method (&rest _args)
819 "Function to call the next applicable method.
820 Can only be used from within the lexical body of a primary or around method."
821 (error "cl-call-next-method only allowed inside primary and around methods"))
823 (defun cl-next-method-p ()
824 "Return non-nil if there is a next method.
825 Can only be used from within the lexical body of a primary or around method."
826 (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1"))
827 (error "cl-next-method-p only allowed inside primary and around methods"))
830 (defun cl-find-method (generic qualifiers specializers)
831 (car (cl--generic-member-method
832 specializers qualifiers
833 (cl--generic-method-table (cl--generic generic)))))
835 ;;; Add support for describe-function
837 (defun cl--generic-search-method (met-name)
838 "For `find-function-regexp-alist'. Searches for a cl-defmethod.
839 MET-NAME is a cons (SYMBOL . SPECIALIZERS)."
840 (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+"
841 (regexp-quote (format "%s" (car met-name)))
845 (concat base-re "[^&\"\n]*"
846 (mapconcat (lambda (specializer)
848 (format "%S" (if (consp specializer)
849 (nth 1 specializer) specializer))))
850 (remq t (cdr met-name))
851 "[ \t\n]*)[^&\"\n]*"))
853 (re-search-forward base-re nil t))))
855 ;; WORKAROUND: This can't be a defconst due to bug#21237.
856 (defvar cl--generic-find-defgeneric-regexp "(\\(?:cl-\\)?defgeneric[ \t]+%s\\>")
858 (with-eval-after-load 'find-func
859 (defvar find-function-regexp-alist)
860 (add-to-list 'find-function-regexp-alist
861 `(cl-defmethod . ,#'cl--generic-search-method))
862 (add-to-list 'find-function-regexp-alist
863 `(cl-defgeneric . cl--generic-find-defgeneric-regexp)))
865 (defun cl--generic-method-info (method)
866 (let* ((specializers (cl--generic-method-specializers method))
867 (qualifiers (cl--generic-method-qualifiers method))
868 (uses-cnm (cl--generic-method-uses-cnm method))
869 (function (cl--generic-method-function method))
870 (args (help-function-arglist function 'names))
871 (docstring (documentation function))
873 (if (null qualifiers) ""
874 (cl-assert (consp qualifiers))
875 (let ((s (prin1-to-string qualifiers)))
876 (concat (substring s 1 -1) " "))))
877 (doconly (if docstring
878 (let ((split (help-split-fundoc docstring nil)))
879 (if split (cdr split) docstring))))
881 (if uses-cnm (setq args (cdr args)))
882 (dolist (specializer specializers)
883 (let ((arg (if (eq '&rest (car args))
884 (intern (format "arg%d" (length combined-args)))
886 (push (if (eq specializer t) arg (list arg specializer))
888 (setq combined-args (append (nreverse combined-args) args))
889 (list qual-string combined-args doconly)))
891 (add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
892 (defun cl--generic-describe (function)
893 ;; Supposedly this is called from help-fns, so help-fns should be loaded at
895 (declare-function help-fns-short-filename "help-fns" (filename))
896 (let ((generic (if (symbolp function) (cl--generic function))))
898 (require 'help-mode) ;Needed for `help-function-def' button!
900 (insert "\n\nThis is a generic function.\n\n")
901 (insert (propertize "Implementations:\n\n" 'face 'bold))
902 ;; Loop over fanciful generics
903 (dolist (method (cl--generic-method-table generic))
904 (let* ((info (cl--generic-method-info method)))
905 ;; FIXME: Add hyperlinks for the types as well.
906 (insert (format "%s%S" (nth 0 info) (nth 1 info)))
907 (let* ((met-name (cons function
908 (cl--generic-method-specializers method)))
909 (file (find-lisp-object-file-name met-name 'cl-defmethod)))
911 (insert (substitute-command-keys " in `"))
912 (help-insert-xref-button (help-fns-short-filename file)
913 'help-function-def met-name file
915 (insert (substitute-command-keys "'.\n"))))
916 (insert "\n" (or (nth 2 info) "Undocumented") "\n\n")))))))
918 (defun cl--generic-specializers-apply-to-type-p (specializers type)
919 "Return non-nil if a method with SPECIALIZERS applies to TYPE."
921 (dolist (specializer specializers)
922 (if (memq (car-safe specializer) '(subclass eieio--static))
923 (setq specializer (nth 1 specializer)))
924 ;; Don't include the methods that are "too generic", such as those
925 ;; applying to `eieio-default-superclass'.
926 (and (not (memq specializer '(t eieio-default-superclass)))
927 (or (equal type specializer)
928 (when (symbolp specializer)
929 (let ((sclass (cl--find-class specializer))
930 (tclass (cl--find-class type)))
931 (when (and sclass tclass)
932 (member specializer (cl--generic-class-parents tclass))))))
936 (defun cl--generic-all-functions (&optional type)
937 "Return a list of all generic functions.
938 Optional TYPE argument returns only those functions that contain
943 (let ((generic (and (fboundp symbol) (cl--generic symbol))))
946 (if (null type) (throw 'found t))
947 (dolist (method (cl--generic-method-table generic))
948 (if (cl--generic-specializers-apply-to-type-p
949 (cl--generic-method-specializers method) type)
954 (defun cl--generic-method-documentation (function type)
955 "Return info for all methods of FUNCTION (a symbol) applicable to TYPE.
956 The value returned is a list of elements of the form
957 \(QUALIFIERS ARGS DOC)."
958 (let ((generic (cl--generic function))
961 (dolist (method (cl--generic-method-table generic))
962 (when (cl--generic-specializers-apply-to-type-p
963 (cl--generic-method-specializers method) type)
964 (push (cl--generic-method-info method) docs))))
967 ;;; Support for (head <val>) specializers.
969 ;; For both the `eql' and the `head' specializers, the dispatch
970 ;; is unsatisfactory. Basically, in the "common&fast case", we end up doing
972 ;; (let ((tag (gethash value <tagcode-hashtable>)))
973 ;; (funcall (gethash tag <method-cache>)))
975 ;; whereas we'd like to just do
977 ;; (funcall (gethash value <method-cache>)))
979 ;; but the problem is that the method-cache is normally "open ended", so
980 ;; a nil means "not computed yet" and if we bump into it, we dutifully fill the
981 ;; corresponding entry, whereas we'd want to just fallback on some default
982 ;; effective method (so as not to fill the cache with lots of redundant
985 (defvar cl--generic-head-used (make-hash-table :test #'eql))
987 (cl-generic-define-generalizer cl--generic-head-generalizer
988 80 (lambda (name &rest _) `(gethash (car-safe ,name) cl--generic-head-used))
989 (lambda (tag &rest _) (if (eq (car-safe tag) 'head) (list tag))))
991 (cl-defmethod cl-generic-generalizers :extra "head" (specializer)
992 "Support for the `(head VAL)' specializers."
993 ;; We have to implement `head' here using the :extra qualifier,
994 ;; since we can't use the `head' specializer to implement itself.
995 (if (not (eq (car-safe specializer) 'head))
996 (cl-call-next-method)
997 (cl--generic-with-memoization
998 (gethash (cadr specializer) cl--generic-head-used) specializer)
999 (list cl--generic-head-generalizer)))
1001 (cl--generic-prefill-dispatchers 0 (head eql))
1003 ;;; Support for (eql <val>) specializers.
1005 (defvar cl--generic-eql-used (make-hash-table :test #'eql))
1007 (cl-generic-define-generalizer cl--generic-eql-generalizer
1008 100 (lambda (name &rest _) `(gethash ,name cl--generic-eql-used))
1009 (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag))))
1011 (cl-defmethod cl-generic-generalizers ((specializer (head eql)))
1012 "Support for the `(eql VAL)' specializers."
1013 (puthash (cadr specializer) specializer cl--generic-eql-used)
1014 (list cl--generic-eql-generalizer))
1016 (cl--generic-prefill-dispatchers 0 (eql nil))
1017 (cl--generic-prefill-dispatchers window-system (eql nil))
1019 ;;; Support for cl-defstructs specializers.
1021 (defun cl--generic-struct-tag (name &rest _)
1022 ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
1023 ;; but that would suffer from some problems:
1024 ;; - the vector may have size 0.
1025 ;; - when called on an actual vector (rather than an object), we'd
1026 ;; end up returning an arbitrary value, possibly colliding with
1027 ;; other tagcode's values.
1028 ;; - it can also result in returning all kinds of irrelevant
1029 ;; values which would end up filling up the method-cache with
1030 ;; lots of irrelevant/redundant entries.
1031 ;; FIXME: We could speed this up by introducing a dedicated
1032 ;; vector type at the C level, so we could do something like
1033 ;; (and (vector-objectp ,name) (aref ,name 0))
1034 `(and (vectorp ,name)
1035 (> (length ,name) 0)
1036 (let ((tag (aref ,name 0)))
1038 (eq (symbol-function tag) :quick-object-witness-check)
1041 (defun cl--generic-class-parents (class)
1043 (classes (list class)))
1044 ;; BFS precedence. FIXME: Use a topological sort.
1045 (while (let ((class (pop classes)))
1046 (cl-pushnew (cl--class-name class) parents)
1049 (cl--class-parents class)))))
1050 (nreverse parents)))
1052 (defun cl--generic-struct-specializers (tag &rest _)
1053 (and (symbolp tag) (boundp tag)
1054 (let ((class (symbol-value tag)))
1055 (when (cl-typep class 'cl-structure-class)
1056 (cl--generic-class-parents class)))))
1058 (cl-generic-define-generalizer cl--generic-struct-generalizer
1059 50 #'cl--generic-struct-tag
1060 #'cl--generic-struct-specializers)
1062 (cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
1063 "Support for dispatch on cl-struct types."
1065 (when (symbolp type)
1066 ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
1067 ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
1068 ;; take place without requiring cl-lib.
1069 (let ((class (cl--find-class type)))
1070 (and (cl-typep class 'cl-structure-class)
1071 (or (null (cl--struct-class-type class))
1072 (error "Can't dispatch on cl-struct %S: type is %S"
1073 type (cl--struct-class-type class)))
1074 (progn (cl-assert (null (cl--struct-class-named class))) t)
1075 (list cl--generic-struct-generalizer))))
1076 (cl-call-next-method)))
1078 (cl--generic-prefill-dispatchers 0 cl--generic-generalizer)
1080 ;;; Dispatch on "system types".
1082 (defconst cl--generic-typeof-types
1083 ;; Hand made from the source code of `type-of'.
1084 '((integer number) (symbol) (string array sequence) (cons list sequence)
1085 ;; Markers aren't `numberp', yet they are accepted wherever integers are
1086 ;; accepted, pretty much.
1087 (marker) (overlay) (float number) (window-configuration)
1088 (process) (window) (subr) (compiled-function) (buffer)
1089 (char-table array sequence)
1090 (bool-vector array sequence)
1091 (frame) (hash-table) (font-spec) (font-entity) (font-object)
1092 (vector array sequence)
1094 (null symbol list sequence)
1100 (cl-generic-define-generalizer cl--generic-typeof-generalizer
1101 ;; FIXME: We could also change `type-of' to return `null' for nil.
1102 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null))
1103 (lambda (tag &rest _)
1104 (and (symbolp tag) (assq tag cl--generic-typeof-types))))
1106 (cl-defmethod cl-generic-generalizers :extra "typeof" (type)
1107 "Support for dispatch on builtin types."
1108 ;; FIXME: Add support for other types accepted by `cl-typep' such
1109 ;; as `character', `atom', `face', `function', ...
1111 (and (assq type cl--generic-typeof-types)
1113 ;; FIXME: While this wrinkle in the semantics can be occasionally
1114 ;; problematic, this warning is more often annoying than helpful.
1115 ;;(if (memq type '(vector array sequence))
1116 ;; (message "`%S' also matches CL structs and EIEIO classes"
1118 (list cl--generic-typeof-generalizer)))
1119 (cl-call-next-method)))
1121 (cl--generic-prefill-dispatchers 0 integer)
1123 ;;; Dispatch on major mode.
1126 ;; - first define a specializer (derived-mode <mode>) to match symbols
1127 ;; representing major modes, while obeying the major mode hierarchy.
1128 ;; - then define a context-rewriter so you can write
1129 ;; "&context (major-mode c-mode)" rather than
1130 ;; "&context (major-mode (derived-mode c-mode))".
1132 (defun cl--generic-derived-specializers (mode &rest _)
1133 ;; FIXME: Handle (derived-mode <mode1> ... <modeN>)
1134 (let ((specializers ()))
1136 (push `(derived-mode ,mode) specializers)
1137 (setq mode (get mode 'derived-mode-parent)))
1138 (nreverse specializers)))
1140 (cl-generic-define-generalizer cl--generic-derived-generalizer
1141 90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name))
1142 #'cl--generic-derived-specializers)
1144 (cl-defmethod cl-generic-generalizers ((_specializer (head derived-mode)))
1145 "Support for the `(derived-mode MODE)' specializers."
1146 (list cl--generic-derived-generalizer))
1148 (cl-generic-define-context-rewriter major-mode (mode &rest modes)
1149 `(major-mode ,(if (consp mode)
1150 ;;E.g. could be (eql ...)
1151 (progn (cl-assert (null modes)) mode)
1152 `(derived-mode ,mode . ,modes))))
1155 ;; generated-autoload-file: "cl-loaddefs.el"
1158 (provide 'cl-generic)
1159 ;;; cl-generic.el ends here