1 ;;; cl-generic.el --- CLOS-style generic functions for Elisp -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2015-2016 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).
89 ;; Note: For generic functions that dispatch on several arguments (i.e. those
90 ;; which use the multiple-dispatch feature), we always use the same "tagcodes"
91 ;; and the same set of arguments on which to dispatch. This works, but is
92 ;; often suboptimal since after one dispatch, the remaining dispatches can
93 ;; usually be simplified, or even completely skipped.
95 (eval-when-compile (require 'cl-lib))
96 (eval-when-compile (require 'cl-macs)) ;For cl--find-class.
97 (eval-when-compile (require 'pcase))
99 (cl-defstruct (cl--generic-generalizer
101 (:constructor cl-generic-make-generalizer
102 (name priority tagcode-function specializers-function)))
103 (name nil :type string)
104 (priority nil :type integer)
106 specializers-function)
109 (defmacro cl-generic-define-generalizer
110 (name priority tagcode-function specializers-function)
111 "Define a new kind of generalizer.
112 NAME is the name of the variable that will hold it.
113 PRIORITY defines which generalizer takes precedence.
114 The catch-all generalizer has priority 0.
115 Then `eql' generalizer has priority 100.
116 TAGCODE-FUNCTION takes as first argument a varname and should return
117 a chunk of code that computes the tag of the value held in that variable.
118 Further arguments are reserved for future use.
119 SPECIALIZERS-FUNCTION takes as first argument a tag value TAG
120 and should return a list of specializers that match TAG.
121 Further arguments are reserved for future use."
122 (declare (indent 1) (debug (symbolp body)))
124 (cl-generic-make-generalizer
125 ',name ,priority ,tagcode-function ,specializers-function)))
127 (cl-generic-define-generalizer cl--generic-t-generalizer
128 0 (lambda (_name &rest _) nil) (lambda (_tag &rest _) '(t)))
130 (cl-defstruct (cl--generic-method
132 (:constructor cl--generic-make-method
133 (specializers qualifiers uses-cnm function))
135 (specializers nil :read-only t :type list)
136 (qualifiers nil :read-only t :type (list-of atom))
137 ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument
138 ;; holding the next-method.
139 (uses-cnm nil :read-only t :type boolean)
140 (function nil :read-only t :type function))
142 (cl-defstruct (cl--generic
144 (:constructor cl--generic-make (name))
146 (name nil :type symbol :read-only t) ;Pointer back to the symbol.
147 ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
148 ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
149 ;; where the EXPs are expressions (to be `or'd together) to compute the tag
150 ;; on which to dispatch and PRIORITY is the priority of each expression to
151 ;; decide in which order to sort them.
152 ;; The most important dispatch is last in the list (and the least is first).
153 (dispatches nil :type (list-of (cons natnum (list-of generalizers))))
154 (method-table nil :type (list-of cl--generic-method))
155 (options nil :type list))
157 (defun cl-generic-function-options (generic)
158 "Return the options of the generic function GENERIC."
159 (cl--generic-options generic))
161 (defmacro cl--generic (name)
162 `(get ,name 'cl--generic))
164 (defun cl-generic-ensure-function (name &optional noerror)
167 (while (and (null (setq generic (cl--generic name)))
170 (symbolp (symbol-function name)))
171 (setq name (symbol-function name)))
172 (unless (or (not (fboundp name))
173 (autoloadp (symbol-function name))
174 (and (functionp name) generic)
176 (error "%s is already defined as something else than a generic function"
179 (cl-assert (eq name (cl--generic-name generic)))
180 (setf (cl--generic name) (setq generic (cl--generic-make name)))
181 (defalias name (cl--generic-make-function generic)))
185 (defmacro cl-defgeneric (name args &rest options-and-methods)
186 "Create a generic function NAME.
187 DOC-STRING is the base documentation for this class. A generic
188 function has no body, as its purpose is to decide which method body
189 is appropriate to use. Specific methods are defined with `cl-defmethod'.
190 With this implementation the ARGS are currently ignored.
191 OPTIONS-AND-METHODS currently understands:
192 - (:documentation DOCSTRING)
193 - (declare DECLARATIONS)
194 - (:argument-precedence-order &rest ARGS)
195 - (:method [QUALIFIERS...] ARGS &rest BODY)
196 DEFAULT-BODY, if present, is used as the body of a default method.
198 \(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)"
199 (declare (indent 2) (doc-string 3))
200 (let* ((doc (if (stringp (car-safe options-and-methods))
201 (pop options-and-methods)))
206 (while (progn (setq next-head (car-safe (car options-and-methods)))
207 (or (keywordp next-head)
208 (eq next-head 'declare)))
211 (when doc (error "Multiple doc strings for %S" name))
212 (setq doc (cadr (pop options-and-methods))))
214 (when declarations (error "Multiple `declare' for %S" name))
215 (setq declarations (pop options-and-methods)))
216 (`:method (push (cdr (pop options-and-methods)) methods))
217 (_ (push (pop options-and-methods) options))))
218 (when options-and-methods
219 ;; Anything remaining is assumed to be a default method body.
220 (push `(,args ,@options-and-methods) methods))
221 (when (eq 'setf (car-safe name))
223 (setq name (gv-setter (cadr name))))
225 ,@(mapcar (lambda (declaration)
226 (let ((f (cdr (assq (car declaration)
227 defun-declarations-alist))))
229 (f (apply (car f) name args (cdr declaration)))
230 (t (message "Warning: Unknown defun property `%S' in %S"
231 (car declaration) name)
235 (cl-generic-define ',name ',args ',(nreverse options))
236 ,(help-add-fundoc-usage doc args))
237 ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
238 (nreverse methods)))))
241 (defun cl-generic-define (name args options)
242 (pcase-let* ((generic (cl-generic-ensure-function name 'noerror))
243 (`(,spec-args . ,_) (cl--generic-split-args args))
244 (mandatory (mapcar #'car spec-args))
245 (apo (assq :argument-precedence-order options)))
246 (unless (fboundp name)
247 ;; If the generic function was fmakunbound, throw away previous methods.
248 (setf (cl--generic-dispatches generic) nil)
249 (setf (cl--generic-method-table generic) nil))
251 (dolist (arg (cdr apo))
252 (let ((pos (memq arg mandatory)))
253 (unless pos (error "%S is not a mandatory argument" arg))
254 (let* ((argno (- (length mandatory) (length pos)))
255 (dispatches (cl--generic-dispatches generic))
256 (dispatch (or (assq argno dispatches) (list argno))))
257 (setf (cl--generic-dispatches generic)
258 (cons dispatch (delq dispatch dispatches)))))))
259 (setf (cl--generic-options generic) options)
260 (cl--generic-make-function generic)))
262 (defmacro cl-generic-current-method-specializers ()
263 "List of (VAR . TYPE) where TYPE is var's specializer.
264 This macro can only be used within the lexical scope of a cl-generic method."
265 (error "cl-generic-current-method-specializers used outside of a method"))
267 (defmacro cl-generic-define-context-rewriter (name args &rest body)
268 "Define a special kind of context named NAME.
269 Whenever a context specializer of the form (NAME . ARGS) appears,
270 the specializer used will be the one returned by BODY."
271 (declare (debug (&define name lambda-list def-body)) (indent defun))
273 (put ',name 'cl-generic--context-rewriter
274 (lambda ,args ,@body))))
276 (eval-and-compile ;Needed while compiling the cl-defmethod calls below!
277 (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el.
278 "Check which of the symbols VARS appear in SEXP."
281 (dolist (var (cl--generic-fgrep vars (pop sexp)))
282 (unless (memq var res) (push var res))))
283 (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
286 (defun cl--generic-split-args (args)
287 "Return (SPEC-ARGS . PLAIN-ARGS)."
288 (let ((plain-args ())
293 ((or '&optional '&rest '&key) (setq mandatory nil) arg)
296 (error "&context not immediately after mandatory args"))
297 (setq mandatory 'context) nil)
298 ((let 'nil mandatory) arg)
299 ((let 'context mandatory)
301 (error "Invalid &context arg: %S" arg))
302 (let* ((name (car arg))
305 (get name 'cl-generic--context-rewriter))))
306 (if rewriter (setq arg (apply rewriter (cdr arg)))))
307 (push `((&context . ,(car arg)) . ,(cadr arg)) specializers)
310 (push (cons name (car type)) specializers)
313 (push (cons arg t) specializers)
316 (cons (nreverse specializers)
317 (nreverse (delq nil plain-args)))))
319 (defun cl--generic-lambda (args body)
320 "Make the lambda expression for a method with ARGS and BODY."
321 (pcase-let* ((`(,spec-args . ,plain-args)
322 (cl--generic-split-args args))
323 (fun `(cl-function (lambda ,plain-args ,@body)))
324 (macroenv (cons `(cl-generic-current-method-specializers
325 . ,(lambda () spec-args))
326 macroexpand-all-environment)))
327 (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'.
328 ;; First macroexpand away the cl-function stuff (e.g. &key and
329 ;; destructuring args, `declare' and whatnot).
330 (pcase (macroexpand fun macroenv)
331 (`#'(lambda ,args . ,body)
332 (let* ((parsed-body (macroexp-parse-body body))
333 (cnm (make-symbol "cl--cnm"))
334 (nmp (make-symbol "cl--nmp"))
335 (nbody (macroexpand-all
336 `(cl-flet ((cl-call-next-method ,cnm)
337 (cl-next-method-p ,nmp))
340 ;; FIXME: Rather than `grep' after the fact, the
341 ;; macroexpansion should directly set some flag when cnm
343 ;; FIXME: Also, optimize the case where call-next-method is
344 ;; only called with explicit arguments.
345 (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
346 (cons (not (not uses-cnm))
347 `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
349 ,(if (not (memq nmp uses-cnm))
351 `(let ((,nmp (lambda ()
352 (cl--generic-isnot-nnm-p ,cnm))))
354 (f (error "Unexpected macroexpansion result: %S" f))))))
358 (defmacro cl-defmethod (name args &rest body)
359 "Define a new method for generic function NAME.
360 I.e. it defines the implementation of NAME to use for invocations where the
361 values of the dispatch arguments match the specified TYPEs.
362 The dispatch arguments have to be among the mandatory arguments, and
363 all methods of NAME have to use the same set of arguments for dispatch.
364 Each dispatch argument and TYPE are specified in ARGS where the corresponding
365 formal argument appears as (VAR TYPE) rather than just VAR.
367 The optional second argument QUALIFIER is a specifier that
368 modifies how the method is combined with other methods, including:
369 :before - Method will be called before the primary
370 :after - Method will be called after the primary
371 :around - Method will be called around everything else
372 The absence of QUALIFIER means this is a \"primary\" method.
374 TYPE can be one of the basic types (see the full list and their
375 hierarchy in `cl--generic-typeof-types'), CL struct type, or an
378 Other than that, TYPE can also be of the form `(eql VAL)' in
379 which case this method will be invoked when the argument is `eql'
380 to VAL, or `(head VAL)', in which case the argument is required
381 to be a cons with VAL as its head.
383 \(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
384 (declare (doc-string 3) (indent 2)
386 (&define ; this means we are defining something
387 [&or name ("setf" :name setf name)]
388 ;; ^^ This is the methods symbol
389 [ &optional keywordp ] ; this is key :before etc
391 [ &optional stringp ] ; documentation string
392 def-body))) ; part to be debugged
393 (let ((qualifiers nil))
394 (while (not (listp args))
395 (push args qualifiers)
396 (setq args (pop body)))
397 (when (eq 'setf (car-safe name))
399 (setq name (gv-setter (cadr name))))
400 (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
402 ,(and (get name 'byte-obsolete-info)
403 (or (not (fboundp 'byte-compile-warning-enabled-p))
404 (byte-compile-warning-enabled-p 'obsolete))
405 (let* ((obsolete (get name 'byte-obsolete-info)))
406 (macroexp--warn-and-return
407 (macroexp--obsolete-warning name obsolete "generic function")
409 ;; You could argue that `defmethod' modifies rather than defines the
410 ;; function, so warnings like "not known to be defined" are fair game.
411 ;; But in practice, it's common to use `cl-defmethod'
412 ;; without a previous `cl-defgeneric'.
413 (declare-function ,name "")
414 (cl-generic-define-method ',name ',(nreverse qualifiers) ',args
417 (defun cl--generic-member-method (specializers qualifiers methods)
420 (let ((m (car methods)))
421 (not (and (equal (cl--generic-method-specializers m) specializers)
422 (equal (cl--generic-method-qualifiers m) qualifiers)))))
423 (setq methods (cdr methods)))
427 (defun cl-generic-define-method (name qualifiers args uses-cnm function)
429 ((generic (cl-generic-ensure-function name))
430 (`(,spec-args . ,_) (cl--generic-split-args args))
431 (specializers (mapcar (lambda (spec-arg)
432 (if (eq '&context (car-safe (car spec-arg)))
433 spec-arg (cdr spec-arg)))
435 (method (cl--generic-make-method
436 specializers qualifiers uses-cnm function))
437 (mt (cl--generic-method-table generic))
438 (me (cl--generic-member-method specializers qualifiers mt))
439 (dispatches (cl--generic-dispatches generic))
441 (dolist (spec-arg spec-args)
442 (let* ((key (if (eq '&context (car-safe (car spec-arg)))
444 (generalizers (cl-generic-generalizers (cdr spec-arg)))
445 (x (assoc key dispatches)))
447 (setq x (cons key (cl-generic-generalizers t)))
448 (setf (cl--generic-dispatches generic)
449 (setq dispatches (cons x dispatches))))
450 (dolist (generalizer generalizers)
451 (unless (member generalizer (cdr x))
453 (sort (cons generalizer (cdr x))
455 (> (cl--generic-generalizer-priority x)
456 (cl--generic-generalizer-priority y)))))))
458 ;; We used to (setcar me method), but that can cause false positives in
459 ;; the hash-consing table of the method-builder (bug#20644).
460 ;; See also the related FIXME in cl--generic-build-combined-method.
461 (setf (cl--generic-method-table generic)
464 ;; Keep the ordering; important for methods with :extra qualifiers.
465 (mapcar (lambda (x) (if (eq x (car me)) method x)) mt)))
466 (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
467 current-load-list :test #'equal)
468 ;; FIXME: Try to avoid re-constructing a new function if the old one
469 ;; is still valid (e.g. still empty method cache)?
470 (let ((gfun (cl--generic-make-function generic))
471 ;; Prevent `defalias' from recording this as the definition site of
472 ;; the generic function.
474 ;; For aliases, cl--generic-name gives us the actual name.
476 ;; BEWARE! Don't purify this function definition, since that leads
477 ;; to memory corruption if the hash-tables it holds are modified
478 ;; (the GC doesn't trace those pointers).
480 ;; But do use `defalias', so that it interacts properly with nadvice,
481 ;; e.g. for tracing/debug-on-entry.
482 (defalias (cl--generic-name generic) gfun)))))
484 (defmacro cl--generic-with-memoization (place &rest code)
485 (declare (indent 1) (debug t))
486 (gv-letplace (getter setter) place
488 ,(macroexp-let2 nil val (macroexp-progn code)
490 ,(funcall setter val)
493 (defvar cl--generic-dispatchers (make-hash-table :test #'equal))
495 (defun cl--generic-get-dispatcher (dispatch)
496 (cl--generic-with-memoization
497 (gethash dispatch cl--generic-dispatchers)
498 ;; (message "cl--generic-get-dispatcher (%S)" dispatch)
499 (let* ((dispatch-arg (car dispatch))
500 (generalizers (cdr dispatch))
503 (mapcar (lambda (generalizer)
504 (funcall (cl--generic-generalizer-tagcode-function
510 (lambda (generalizer)
511 `(funcall ',(cl--generic-generalizer-specializers-function
513 ,(funcall (cl--generic-generalizer-tagcode-function
518 ;; Minor optimization: since this tag-exp is
519 ;; only used to lookup the method-cache, it
520 ;; doesn't matter if the default value is some
522 `(or ,@(if (macroexp-const-p (car (last tagcodes)))
526 (dispatch-idx dispatch-arg)
528 (when (eq '&context (car-safe dispatch-arg))
529 (setq bindings `((arg ,(cdr dispatch-arg))))
531 (setq dispatch-idx 0))
532 (dotimes (i dispatch-idx)
533 (push (make-symbol (format "arg%d" (- dispatch-idx i 1))) fixedargs))
534 ;; FIXME: For generic functions with a single method (or with 2 methods,
535 ;; one of which always matches), using a tagcode + hash-table is
536 ;; overkill: better just use a `cl-typep' test.
538 `(lambda (generic dispatches-left methods)
539 (let ((method-cache (make-hash-table :test #'eql)))
540 (lambda (,@fixedargs &rest args)
542 (apply (cl--generic-with-memoization
543 (gethash ,tag-exp method-cache)
544 (cl--generic-cache-miss
545 generic ',dispatch-arg dispatches-left methods
546 ,(if (cdr typescodes)
547 `(append ,@typescodes) (car typescodes))))
548 ,@fixedargs args)))))))))
550 (defun cl--generic-make-function (generic)
551 (cl--generic-make-next-function generic
552 (cl--generic-dispatches generic)
553 (cl--generic-method-table generic)))
555 (defun cl--generic-make-next-function (generic dispatches methods)
558 (while (and dispatches
559 (let ((x (nth 1 (car dispatches))))
560 ;; No need to dispatch for t specializers.
561 (or (null x) (equal x cl--generic-t-generalizer))))
562 (setq dispatches (cdr dispatches)))
564 (if (not (and dispatch
565 ;; If there's no method left, there's no point checking
566 ;; further arguments.
568 (cl--generic-build-combined-method generic methods)
569 (let ((dispatcher (cl--generic-get-dispatcher dispatch)))
570 (funcall dispatcher generic dispatches methods)))))
572 (defvar cl--generic-combined-method-memoization
573 (make-hash-table :test #'equal :weakness 'value)
574 "Table storing previously built combined-methods.
575 This is particularly useful when many different tags select the same set
576 of methods, since this table then allows us to share a single combined-method
577 for all those different tags in the method-cache.")
579 (define-error 'cl--generic-cyclic-definition "Cyclic definition: %S")
581 (defun cl--generic-build-combined-method (generic methods)
583 ;; Special case needed to fix a circularity during bootstrap.
584 (cl--generic-standard-method-combination generic methods)
586 (cl--generic-with-memoization
587 ;; FIXME: Since the fields of `generic' are modified, this
588 ;; hash-table won't work right, because the hashes will change!
589 ;; It's not terribly serious, but reduces the effectiveness of
591 (gethash (cons generic methods)
592 cl--generic-combined-method-memoization)
593 (puthash (cons generic methods) :cl--generic--under-construction
594 cl--generic-combined-method-memoization)
596 (cl-generic-combine-methods generic methods)
597 ;; Special case needed to fix a circularity during bootstrap.
598 (cl--generic-cyclic-definition
599 (cl--generic-standard-method-combination generic methods))))))
600 (if (eq f :cl--generic--under-construction)
601 (signal 'cl--generic-cyclic-definition
602 (list (cl--generic-name generic)))
605 (defun cl--generic-no-next-method-function (generic method)
607 (apply #'cl-no-next-method generic method args)))
609 (defun cl-generic-call-method (generic method &optional fun)
610 "Return a function that calls METHOD.
611 FUN is the function that should be called when METHOD calls
613 (if (not (cl--generic-method-uses-cnm method))
614 (cl--generic-method-function method)
615 (let ((met-fun (cl--generic-method-function method))
616 (next (or fun (cl--generic-no-next-method-function
620 ;; FIXME: This sucks: passing just `next' would
621 ;; be a lot more efficient than the lambda+apply
622 ;; quasi-η, but we need this to implement the
623 ;; "if call-next-method is called with no
624 ;; arguments, then use the previous arguments".
625 (lambda (&rest cnm-args)
626 (apply next (or cnm-args args)))
629 ;; Standard CLOS name.
630 (defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers)
632 (defun cl--generic-standard-method-combination (generic methods)
633 (let ((mets-by-qual ()))
634 (dolist (method methods)
635 (let ((qualifiers (cl-method-qualifiers method)))
636 (if (eq (car qualifiers) :extra) (setq qualifiers (cddr qualifiers)))
637 (unless (member qualifiers '(() (:after) (:before) (:around)))
638 (error "Unsupported qualifiers in function %S: %S"
639 (cl--generic-name generic) qualifiers))
640 (push method (alist-get (car qualifiers) mets-by-qual))))
644 (apply #'cl-no-applicable-method generic args)))
645 ((null (alist-get nil mets-by-qual))
647 (apply #'cl-no-primary-method generic args)))
650 (ab-call (lambda (m) (cl-generic-call-method generic m)))
652 (mapcar ab-call (reverse (cdr (assoc :before mets-by-qual)))))
653 (after (mapcar ab-call (cdr (assoc :after mets-by-qual)))))
654 (dolist (method (cdr (assoc nil mets-by-qual)))
655 (setq fun (cl-generic-call-method generic method fun)))
656 (when (or after before)
658 (setq fun (lambda (&rest args)
664 (apply af args)))))))
665 (dolist (method (cdr (assoc :around mets-by-qual)))
666 (setq fun (cl-generic-call-method generic method fun)))
669 (defun cl--generic-arg-specializer (method dispatch-arg)
670 (or (if (integerp dispatch-arg)
672 (cl--generic-method-specializers method))
673 (cdr (assoc dispatch-arg
674 (cl--generic-method-specializers method))))
677 (defun cl--generic-cache-miss (generic
678 dispatch-arg dispatches-left methods-left types)
680 (dolist (method methods-left)
681 (let* ((specializer (cl--generic-arg-specializer method dispatch-arg))
682 (m (member specializer types)))
684 (push (cons (length m) method) methods))))
685 ;; Sort the methods, most specific first.
686 ;; It would be tempting to sort them once and for all in the method-table
687 ;; rather than here, but the order might depend on the actual argument
688 ;; (e.g. for multiple inheritance with defclass).
689 (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
690 (cl--generic-make-next-function generic dispatches-left methods)))
692 (cl-defgeneric cl-generic-generalizers (specializer)
693 "Return a list of generalizers for a given SPECIALIZER.
694 To each kind of `specializer', corresponds a `generalizer' which describes
695 how to extract a \"tag\" from an object which will then let us check if this
696 object matches the specializer. A typical example of a \"tag\" would be the
697 type of an object. It's called a `generalizer' because it
698 takes a specific object and returns a more general approximation,
699 denoting a set of objects to which it belongs.
700 A generalizer gives us the chunk of code which the
701 dispatch function needs to use to extract the \"tag\" of an object, as well
702 as a function which turns this tag into an ordered list of
703 `specializers' that this object matches.
704 The code which extracts the tag should be as fast as possible.
705 The tags should be chosen according to the following rules:
706 - The tags should not be too specific: similar objects which match the
707 same list of specializers should ideally use the same (`eql') tag.
708 This insures that the cached computation of the applicable
709 methods for one object can be reused for other objects.
710 - Corollary: objects which don't match any of the relevant specializers
711 should ideally all use the same tag (typically nil).
712 This insures that this cache does not grow unnecessarily large.
713 - Two different generalizers G1 and G2 should not use the same tag
714 unless they use it for the same set of objects. IOW, if G1.tag(X1) =
715 G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2).
716 - If G1.priority > G2.priority and G1.tag(X1) = G1.tag(X2) and this tag is
717 non-nil, then you have to make sure that the G2.tag(X1) = G2.tag(X2).
718 This is because the method-cache is only indexed with the first non-nil
719 tag (by order of decreasing priority).")
721 (cl-defgeneric cl-generic-combine-methods (generic methods)
722 "Build the effective method made of METHODS.
723 It should return a function that expects the same arguments as the methods, and
724 calls those methods in some appropriate order.
725 GENERIC is the generic function (mostly used for its name).
726 METHODS is the list of the selected methods.
727 The METHODS list is sorted from most specific first to most generic last.
728 The function can use `cl-generic-call-method' to create functions that call those
731 (unless (ignore-errors (cl-generic-generalizers t))
732 ;; Temporary definition to let the next defmethod succeed.
733 (fset 'cl-generic-generalizers
734 (lambda (specializer)
735 (if (eq t specializer) (list cl--generic-t-generalizer))))
736 (fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination))
738 (cl-defmethod cl-generic-generalizers (specializer)
739 "Support for the catch-all t specializer."
740 (if (eq specializer t) (list cl--generic-t-generalizer)
741 (error "Unknown specializer %S" specializer)))
744 ;; This macro is brittle and only really important in order to be
745 ;; able to preload cl-generic without also preloading the byte-compiler,
746 ;; So we use `eval-when-compile' so as not keep it available longer than
748 (defmacro cl--generic-prefill-dispatchers (arg-or-context specializer)
749 (unless (integerp arg-or-context)
750 (setq arg-or-context `(&context . ,arg-or-context)))
751 (unless (fboundp 'cl--generic-get-dispatcher)
752 (require 'cl-generic))
753 (let ((fun (cl--generic-get-dispatcher
754 `(,arg-or-context ,@(cl-generic-generalizers specializer)
755 ,cl--generic-t-generalizer))))
756 ;; Recompute dispatch at run-time, since the generalizers may be slightly
757 ;; different (e.g. byte-compiled rather than interpreted).
758 ;; FIXME: There is a risk that the run-time generalizer is not equivalent
759 ;; to the compile-time one, in which case `fun' may not be correct
761 `(let ((dispatch `(,',arg-or-context
762 ,@(cl-generic-generalizers ',specializer)
763 ,cl--generic-t-generalizer)))
764 ;; (message "Prefilling for %S with \n%S" dispatch ',fun)
765 (puthash dispatch ',fun cl--generic-dispatchers)))))
767 (cl-defmethod cl-generic-combine-methods (generic methods)
768 "Standard support for :after, :before, :around, and `:extra NAME' qualifiers."
769 (cl--generic-standard-method-combination generic methods))
771 (defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t))
772 (defconst cl--generic-cnm-sample
773 (funcall (cl--generic-build-combined-method
774 nil (list (cl--generic-make-method () () t #'identity)))))
776 (defun cl--generic-isnot-nnm-p (cnm)
777 "Return non-nil if CNM is the function that calls `cl-no-next-method'."
778 ;; ¡Big Gross Ugly Hack!
779 ;; `next-method-p' just sucks, we should let it die. But EIEIO did support
780 ;; it, and some packages use it, so we need to support it.
782 (cl-assert (function-equal cnm cl--generic-cnm-sample))
783 (if (byte-code-function-p cnm)
784 (let ((cnm-constants (aref cnm 2))
785 (sample-constants (aref cl--generic-cnm-sample 2)))
786 (dotimes (i (length sample-constants))
787 (when (function-equal (aref sample-constants i)
788 cl--generic-nnm-sample)
790 (not (function-equal (aref cnm-constants i)
791 cl--generic-nnm-sample))))))
792 (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample)))
793 (let ((cnm-env (cadr cnm)))
794 (dolist (vb (cadr cl--generic-cnm-sample))
795 (when (function-equal (cdr vb) cl--generic-nnm-sample)
797 (not (function-equal (cdar cnm-env)
798 cl--generic-nnm-sample))))
799 (setq cnm-env (cdr cnm-env)))))
800 (error "Haven't found no-next-method-sample in cnm-sample")))
802 ;;; Define some pre-defined generic functions, used internally.
804 (define-error 'cl-no-method "No method")
805 (define-error 'cl-no-next-method "No next method" 'cl-no-method)
806 (define-error 'cl-no-primary-method "No primary method" 'cl-no-method)
807 (define-error 'cl-no-applicable-method "No applicable method"
810 (cl-defgeneric cl-no-next-method (generic method &rest args)
811 "Function called when `cl-call-next-method' finds no next method."
812 (signal 'cl-no-next-method `(,(cl--generic-name generic) ,method ,@args)))
814 (cl-defgeneric cl-no-applicable-method (generic &rest args)
815 "Function called when a method call finds no applicable method."
816 (signal 'cl-no-applicable-method `(,(cl--generic-name generic) ,@args)))
818 (cl-defgeneric cl-no-primary-method (generic &rest args)
819 "Function called when a method call finds no primary method."
820 (signal 'cl-no-primary-method `(,(cl--generic-name generic) ,@args)))
822 (defun cl-call-next-method (&rest _args)
823 "Function to call the next applicable method.
824 Can only be used from within the lexical body of a primary or around method."
825 (error "cl-call-next-method only allowed inside primary and around methods"))
827 (defun cl-next-method-p ()
828 "Return non-nil if there is a next method.
829 Can only be used from within the lexical body of a primary or around method."
830 (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1"))
831 (error "cl-next-method-p only allowed inside primary and around methods"))
834 (defun cl-find-method (generic qualifiers specializers)
835 (car (cl--generic-member-method
836 specializers qualifiers
837 (cl--generic-method-table (cl--generic generic)))))
839 ;;; Add support for describe-function
841 (defun cl--generic-search-method (met-name)
842 "For `find-function-regexp-alist'. Searches for a cl-defmethod.
843 MET-NAME is a cons (SYMBOL . SPECIALIZERS)."
844 (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+"
845 (regexp-quote (format "%s" (car met-name)))
849 (concat base-re "[^&\"\n]*"
850 (mapconcat (lambda (specializer)
852 (format "%S" (if (consp specializer)
853 (nth 1 specializer) specializer))))
854 (remq t (cdr met-name))
855 "[ \t\n]*)[^&\"\n]*"))
857 (re-search-forward base-re nil t))))
859 ;; WORKAROUND: This can't be a defconst due to bug#21237.
860 (defvar cl--generic-find-defgeneric-regexp "(\\(?:cl-\\)?defgeneric[ \t]+%s\\>")
862 (with-eval-after-load 'find-func
863 (defvar find-function-regexp-alist)
864 (add-to-list 'find-function-regexp-alist
865 `(cl-defmethod . ,#'cl--generic-search-method))
866 (add-to-list 'find-function-regexp-alist
867 `(cl-defgeneric . cl--generic-find-defgeneric-regexp)))
869 (defun cl--generic-method-info (method)
870 (let* ((specializers (cl--generic-method-specializers method))
871 (qualifiers (cl--generic-method-qualifiers method))
872 (uses-cnm (cl--generic-method-uses-cnm method))
873 (function (cl--generic-method-function method))
874 (args (help-function-arglist function 'names))
875 (docstring (documentation function))
877 (if (null qualifiers) ""
878 (cl-assert (consp qualifiers))
879 (let ((s (prin1-to-string qualifiers)))
880 (concat (substring s 1 -1) " "))))
881 (doconly (if docstring
882 (let ((split (help-split-fundoc docstring nil)))
883 (if split (cdr split) docstring))))
885 (if uses-cnm (setq args (cdr args)))
886 (dolist (specializer specializers)
887 (let ((arg (if (eq '&rest (car args))
888 (intern (format "arg%d" (length combined-args)))
890 (push (if (eq specializer t) arg (list arg specializer))
892 (setq combined-args (append (nreverse combined-args) args))
893 (list qual-string combined-args doconly)))
895 (add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
896 (defun cl--generic-describe (function)
897 ;; Supposedly this is called from help-fns, so help-fns should be loaded at
899 (declare-function help-fns-short-filename "help-fns" (filename))
900 (let ((generic (if (symbolp function) (cl--generic function))))
902 (require 'help-mode) ;Needed for `help-function-def' button!
904 (insert "\n\nThis is a generic function.\n\n")
905 (insert (propertize "Implementations:\n\n" 'face 'bold))
906 ;; Loop over fanciful generics
907 (dolist (method (cl--generic-method-table generic))
908 (let* ((info (cl--generic-method-info method)))
909 ;; FIXME: Add hyperlinks for the types as well.
910 (insert (format "%s%S" (nth 0 info) (nth 1 info)))
911 (let* ((met-name (cons function
912 (cl--generic-method-specializers method)))
913 (file (find-lisp-object-file-name met-name 'cl-defmethod)))
915 (insert (substitute-command-keys " in `"))
916 (help-insert-xref-button (help-fns-short-filename file)
917 'help-function-def met-name file
919 (insert (substitute-command-keys "'.\n"))))
920 (insert "\n" (or (nth 2 info) "Undocumented") "\n\n")))))))
922 (defun cl--generic-specializers-apply-to-type-p (specializers type)
923 "Return non-nil if a method with SPECIALIZERS applies to TYPE."
925 (dolist (specializer specializers)
926 (if (memq (car-safe specializer) '(subclass eieio--static))
927 (setq specializer (nth 1 specializer)))
928 ;; Don't include the methods that are "too generic", such as those
929 ;; applying to `eieio-default-superclass'.
930 (and (not (memq specializer '(t eieio-default-superclass)))
931 (or (equal type specializer)
932 (when (symbolp specializer)
933 (let ((sclass (cl--find-class specializer))
934 (tclass (cl--find-class type)))
935 (when (and sclass tclass)
936 (member specializer (cl--generic-class-parents tclass))))))
940 (defun cl--generic-all-functions (&optional type)
941 "Return a list of all generic functions.
942 Optional TYPE argument returns only those functions that contain
947 (let ((generic (and (fboundp symbol) (cl--generic symbol))))
950 (if (null type) (throw 'found t))
951 (dolist (method (cl--generic-method-table generic))
952 (if (cl--generic-specializers-apply-to-type-p
953 (cl--generic-method-specializers method) type)
958 (defun cl--generic-method-documentation (function type)
959 "Return info for all methods of FUNCTION (a symbol) applicable to TYPE.
960 The value returned is a list of elements of the form
961 \(QUALIFIERS ARGS DOC)."
962 (let ((generic (cl--generic function))
965 (dolist (method (cl--generic-method-table generic))
966 (when (cl--generic-specializers-apply-to-type-p
967 (cl--generic-method-specializers method) type)
968 (push (cl--generic-method-info method) docs))))
971 ;;; Support for (head <val>) specializers.
973 ;; For both the `eql' and the `head' specializers, the dispatch
974 ;; is unsatisfactory. Basically, in the "common&fast case", we end up doing
976 ;; (let ((tag (gethash value <tagcode-hashtable>)))
977 ;; (funcall (gethash tag <method-cache>)))
979 ;; whereas we'd like to just do
981 ;; (funcall (gethash value <method-cache>)))
983 ;; but the problem is that the method-cache is normally "open ended", so
984 ;; a nil means "not computed yet" and if we bump into it, we dutifully fill the
985 ;; corresponding entry, whereas we'd want to just fallback on some default
986 ;; effective method (so as not to fill the cache with lots of redundant
989 (defvar cl--generic-head-used (make-hash-table :test #'eql))
991 (cl-generic-define-generalizer cl--generic-head-generalizer
992 80 (lambda (name &rest _) `(gethash (car-safe ,name) cl--generic-head-used))
993 (lambda (tag &rest _) (if (eq (car-safe tag) 'head) (list tag))))
995 (cl-defmethod cl-generic-generalizers :extra "head" (specializer)
996 "Support for the `(head VAL)' specializers."
997 ;; We have to implement `head' here using the :extra qualifier,
998 ;; since we can't use the `head' specializer to implement itself.
999 (if (not (eq (car-safe specializer) 'head))
1000 (cl-call-next-method)
1001 (cl--generic-with-memoization
1002 (gethash (cadr specializer) cl--generic-head-used) specializer)
1003 (list cl--generic-head-generalizer)))
1005 (cl--generic-prefill-dispatchers 0 (head eql))
1007 ;;; Support for (eql <val>) specializers.
1009 (defvar cl--generic-eql-used (make-hash-table :test #'eql))
1011 (cl-generic-define-generalizer cl--generic-eql-generalizer
1012 100 (lambda (name &rest _) `(gethash ,name cl--generic-eql-used))
1013 (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag))))
1015 (cl-defmethod cl-generic-generalizers ((specializer (head eql)))
1016 "Support for the `(eql VAL)' specializers."
1017 (puthash (cadr specializer) specializer cl--generic-eql-used)
1018 (list cl--generic-eql-generalizer))
1020 (cl--generic-prefill-dispatchers 0 (eql nil))
1021 (cl--generic-prefill-dispatchers window-system (eql nil))
1023 ;;; Support for cl-defstructs specializers.
1025 (defun cl--generic-struct-tag (name &rest _)
1026 ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
1027 ;; but that would suffer from some problems:
1028 ;; - the vector may have size 0.
1029 ;; - when called on an actual vector (rather than an object), we'd
1030 ;; end up returning an arbitrary value, possibly colliding with
1031 ;; other tagcode's values.
1032 ;; - it can also result in returning all kinds of irrelevant
1033 ;; values which would end up filling up the method-cache with
1034 ;; lots of irrelevant/redundant entries.
1035 ;; FIXME: We could speed this up by introducing a dedicated
1036 ;; vector type at the C level, so we could do something like
1037 ;; (and (vector-objectp ,name) (aref ,name 0))
1038 `(and (vectorp ,name)
1039 (> (length ,name) 0)
1040 (let ((tag (aref ,name 0)))
1042 (eq (symbol-function tag) :quick-object-witness-check)
1045 (defun cl--generic-class-parents (class)
1047 (classes (list class)))
1048 ;; BFS precedence. FIXME: Use a topological sort.
1049 (while (let ((class (pop classes)))
1050 (cl-pushnew (cl--class-name class) parents)
1053 (cl--class-parents class)))))
1054 (nreverse parents)))
1056 (defun cl--generic-struct-specializers (tag &rest _)
1057 (and (symbolp tag) (boundp tag)
1058 (let ((class (symbol-value tag)))
1059 (when (cl-typep class 'cl-structure-class)
1060 (cl--generic-class-parents class)))))
1062 (cl-generic-define-generalizer cl--generic-struct-generalizer
1063 50 #'cl--generic-struct-tag
1064 #'cl--generic-struct-specializers)
1066 (cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
1067 "Support for dispatch on cl-struct types."
1069 (when (symbolp type)
1070 ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
1071 ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
1072 ;; take place without requiring cl-lib.
1073 (let ((class (cl--find-class type)))
1074 (and (cl-typep class 'cl-structure-class)
1075 (or (null (cl--struct-class-type class))
1076 (error "Can't dispatch on cl-struct %S: type is %S"
1077 type (cl--struct-class-type class)))
1078 (progn (cl-assert (null (cl--struct-class-named class))) t)
1079 (list cl--generic-struct-generalizer))))
1080 (cl-call-next-method)))
1082 (cl--generic-prefill-dispatchers 0 cl--generic-generalizer)
1084 ;;; Dispatch on "system types".
1086 (defconst cl--generic-typeof-types
1087 ;; Hand made from the source code of `type-of'.
1088 '((integer number) (symbol) (string array sequence) (cons list sequence)
1089 ;; Markers aren't `numberp', yet they are accepted wherever integers are
1090 ;; accepted, pretty much.
1091 (marker) (overlay) (float number) (window-configuration)
1092 (process) (window) (subr) (compiled-function) (buffer)
1093 (char-table array sequence)
1094 (bool-vector array sequence)
1095 (frame) (hash-table) (font-spec) (font-entity) (font-object)
1096 (vector array sequence)
1098 (null symbol list sequence)
1104 (cl-generic-define-generalizer cl--generic-typeof-generalizer
1105 ;; FIXME: We could also change `type-of' to return `null' for nil.
1106 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null))
1107 (lambda (tag &rest _)
1108 (and (symbolp tag) (assq tag cl--generic-typeof-types))))
1110 (cl-defmethod cl-generic-generalizers :extra "typeof" (type)
1111 "Support for dispatch on builtin types."
1112 ;; FIXME: Add support for other types accepted by `cl-typep' such
1113 ;; as `character', `atom', `face', `function', ...
1115 (and (assq type cl--generic-typeof-types)
1117 ;; FIXME: While this wrinkle in the semantics can be occasionally
1118 ;; problematic, this warning is more often annoying than helpful.
1119 ;;(if (memq type '(vector array sequence))
1120 ;; (message "`%S' also matches CL structs and EIEIO classes"
1122 (list cl--generic-typeof-generalizer)))
1123 (cl-call-next-method)))
1125 (cl--generic-prefill-dispatchers 0 integer)
1127 ;;; Dispatch on major mode.
1130 ;; - first define a specializer (derived-mode <mode>) to match symbols
1131 ;; representing major modes, while obeying the major mode hierarchy.
1132 ;; - then define a context-rewriter so you can write
1133 ;; "&context (major-mode c-mode)" rather than
1134 ;; "&context (major-mode (derived-mode c-mode))".
1136 (defun cl--generic-derived-specializers (mode &rest _)
1137 ;; FIXME: Handle (derived-mode <mode1> ... <modeN>)
1138 (let ((specializers ()))
1140 (push `(derived-mode ,mode) specializers)
1141 (setq mode (get mode 'derived-mode-parent)))
1142 (nreverse specializers)))
1144 (cl-generic-define-generalizer cl--generic-derived-generalizer
1145 90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name))
1146 #'cl--generic-derived-specializers)
1148 (cl-defmethod cl-generic-generalizers ((_specializer (head derived-mode)))
1149 "Support for the `(derived-mode MODE)' specializers."
1150 (list cl--generic-derived-generalizer))
1152 (cl-generic-define-context-rewriter major-mode (mode &rest modes)
1153 `(major-mode ,(if (consp mode)
1154 ;;E.g. could be (eql ...)
1155 (progn (cl-assert (null modes)) mode)
1156 `(derived-mode ,mode . ,modes))))
1159 ;; generated-autoload-file: "cl-loaddefs.el"
1162 (provide 'cl-generic)
1163 ;;; cl-generic.el ends here