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 adds 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 'pcase))
100 (cl-defstruct (cl--generic-generalizer
102 (:constructor cl-generic-make-generalizer
103 (priority tagcode-function specializers-function)))
104 (priority nil :type integer)
106 specializers-function)
108 (defconst cl--generic-t-generalizer
109 (cl-generic-make-generalizer
110 0 (lambda (_name) nil) (lambda (_tag) '(t))))
112 (cl-defstruct (cl--generic-method
114 (:constructor cl--generic-make-method
115 (specializers qualifiers uses-cnm function))
117 (specializers nil :read-only t :type list)
118 (qualifiers nil :read-only t :type (list-of atom))
119 ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument
120 ;; holding the next-method.
121 (uses-cnm nil :read-only t :type boolean)
122 (function nil :read-only t :type function))
124 (cl-defstruct (cl--generic
126 (:constructor cl--generic-make (name))
128 (name nil :type symbol :read-only t) ;Pointer back to the symbol.
129 ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
130 ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
131 ;; where the EXPs are expressions (to be `or'd together) to compute the tag
132 ;; on which to dispatch and PRIORITY is the priority of each expression to
133 ;; decide in which order to sort them.
134 ;; The most important dispatch is last in the list (and the least is first).
135 (dispatches nil :type (list-of (cons natnum (list-of generalizers))))
136 (method-table nil :type (list-of cl--generic-method))
137 (options nil :type list))
139 (defun cl-generic-function-options (generic)
140 "Return the options of the generic function GENERIC."
141 (cl--generic-options generic))
143 (defmacro cl--generic (name)
144 `(get ,name 'cl--generic))
146 (defun cl-generic-ensure-function (name)
149 (while (and (null (setq generic (cl--generic name)))
151 (symbolp (symbol-function name)))
152 (setq name (symbol-function name)))
153 (unless (or (not (fboundp name))
154 (autoloadp (symbol-function name))
155 (and (functionp name) generic))
156 (error "%s is already defined as something else than a generic function"
159 (cl-assert (eq name (cl--generic-name generic)))
160 (setf (cl--generic name) (setq generic (cl--generic-make name)))
161 (defalias name (cl--generic-make-function generic)))
164 (defun cl--generic-setf-rewrite (name)
165 (let* ((setter (intern (format "cl-generic-setter--%s" name)))
166 (exp `(unless (eq ',setter (get ',name 'cl-generic-setter))
167 ;; (when (get ',name 'gv-expander)
168 ;; (error "gv-expander conflicts with (setf %S)" ',name))
169 (setf (get ',name 'cl-generic-setter) ',setter)
170 (gv-define-setter ,name (val &rest args)
171 (cons ',setter (cons val args))))))
172 ;; Make sure `setf' can be used right away, e.g. in the body of the method.
177 (defmacro cl-defgeneric (name args &rest options-and-methods)
178 "Create a generic function NAME.
179 DOC-STRING is the base documentation for this class. A generic
180 function has no body, as its purpose is to decide which method body
181 is appropriate to use. Specific methods are defined with `cl-defmethod'.
182 With this implementation the ARGS are currently ignored.
183 OPTIONS-AND-METHODS currently understands:
184 - (:documentation DOCSTRING)
185 - (declare DECLARATIONS)
186 - (:argument-precedence-order &rest ARGS)
187 - (:method [QUALIFIERS...] ARGS &rest BODY)
188 BODY, if present, is used as the body of a default method.
190 \(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)"
191 (declare (indent 2) (doc-string 3))
192 (let* ((doc (if (stringp (car-safe options-and-methods))
193 (pop options-and-methods)))
198 (while (progn (setq next-head (car-safe (car options-and-methods)))
199 (or (keywordp next-head)
200 (eq next-head 'declare)))
203 (when doc (error "Multiple doc strings for %S" name))
204 (setq doc (cadr (pop options-and-methods))))
206 (when declarations (error "Multiple `declare' for %S" name))
207 (setq declarations (pop options-and-methods)))
208 (`:method (push (cdr (pop options-and-methods)) methods))
209 (_ (push (pop options-and-methods) options))))
210 (when options-and-methods
211 ;; Anything remaining is assumed to be a default method body.
212 (push `(,args ,@options-and-methods) methods))
214 ,(when (eq 'setf (car-safe name))
215 (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
219 ,@(mapcar (lambda (declaration)
220 (let ((f (cdr (assq (car declaration)
221 defun-declarations-alist))))
223 (f (apply (car f) name args (cdr declaration)))
224 (t (message "Warning: Unknown defun property `%S' in %S"
225 (car declaration) name)
229 (cl-generic-define ',name ',args ',(nreverse options))
230 ,(help-add-fundoc-usage doc args))
231 ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
232 (nreverse methods)))))
235 (defun cl-generic-define (name args options)
236 (pcase-let* ((generic (cl-generic-ensure-function name))
237 (`(,spec-args . ,_) (cl--generic-split-args args))
238 (mandatory (mapcar #'car spec-args))
239 (apo (assq :argument-precedence-order options)))
240 (setf (cl--generic-dispatches generic) nil)
242 (dolist (arg (cdr apo))
243 (let ((pos (memq arg mandatory)))
244 (unless pos (error "%S is not a mandatory argument" arg))
245 (push (list (- (length mandatory) (length pos)))
246 (cl--generic-dispatches generic)))))
247 (setf (cl--generic-method-table generic) nil)
248 (setf (cl--generic-options generic) options)
249 (cl--generic-make-function generic)))
251 (defmacro cl-generic-current-method-specializers ()
252 "List of (VAR . TYPE) where TYPE is var's specializer.
253 This macro can only be used within the lexical scope of a cl-generic method."
254 (error "cl-generic-current-method-specializers used outside of a method"))
256 (eval-and-compile ;Needed while compiling the cl-defmethod calls below!
257 (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el.
258 "Check which of the symbols VARS appear in SEXP."
261 (dolist (var (cl--generic-fgrep vars (pop sexp)))
262 (unless (memq var res) (push var res))))
263 (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
266 (defun cl--generic-split-args (args)
267 "Return (SPEC-ARGS . PLAIN-ARGS)."
268 (let ((plain-args ())
273 ((or '&optional '&rest '&key) (setq mandatory nil) arg)
276 (error "&context not immediately after mandatory args"))
277 (setq mandatory 'context) nil)
278 ((let 'nil mandatory) arg)
279 ((let 'context mandatory)
281 (error "Invalid &context arg: %S" arg))
282 (push `((&context . ,(car arg)) . ,(cadr arg)) specializers)
285 (push (cons name (car type)) specializers)
288 (push (cons arg t) specializers)
291 (cons (nreverse specializers)
292 (nreverse (delq nil plain-args)))))
294 (defun cl--generic-lambda (args body)
295 "Make the lambda expression for a method with ARGS and BODY."
296 (pcase-let* ((`(,spec-args . ,plain-args)
297 (cl--generic-split-args args))
298 (fun `(cl-function (lambda ,plain-args ,@body)))
299 (macroenv (cons `(cl-generic-current-method-specializers
300 . ,(lambda () spec-args))
301 macroexpand-all-environment)))
302 (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'.
303 ;; First macroexpand away the cl-function stuff (e.g. &key and
304 ;; destructuring args, `declare' and whatnot).
305 (pcase (macroexpand fun macroenv)
306 (`#'(lambda ,args . ,body)
307 (let* ((parsed-body (macroexp-parse-body body))
308 (cnm (make-symbol "cl--cnm"))
309 (nmp (make-symbol "cl--nmp"))
310 (nbody (macroexpand-all
311 `(cl-flet ((cl-call-next-method ,cnm)
312 (cl-next-method-p ,nmp))
315 ;; FIXME: Rather than `grep' after the fact, the
316 ;; macroexpansion should directly set some flag when cnm
318 ;; FIXME: Also, optimize the case where call-next-method is
319 ;; only called with explicit arguments.
320 (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
321 (cons (not (not uses-cnm))
322 `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
324 ,(if (not (memq nmp uses-cnm))
326 `(let ((,nmp (lambda ()
327 (cl--generic-isnot-nnm-p ,cnm))))
329 (f (error "Unexpected macroexpansion result: %S" f))))))
333 (defmacro cl-defmethod (name args &rest body)
334 "Define a new method for generic function NAME.
335 I.e. it defines the implementation of NAME to use for invocations where the
336 value of the dispatch argument matches the specified TYPE.
337 The dispatch argument has to be one of the mandatory arguments, and
338 all methods of NAME have to use the same argument for dispatch.
339 The dispatch argument and TYPE are specified in ARGS where the corresponding
340 formal argument appears as (VAR TYPE) rather than just VAR.
342 The optional second argument QUALIFIER is a specifier that
343 modifies how the method is combined with other methods, including:
344 :before - Method will be called before the primary
345 :after - Method will be called after the primary
346 :around - Method will be called around everything else
347 The absence of QUALIFIER means this is a \"primary\" method.
349 Other than a type, TYPE can also be of the form `(eql VAL)' in
350 which case this method will be invoked when the argument is `eql' to VAL.
352 \(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
353 (declare (doc-string 3) (indent 2)
355 (&define ; this means we are defining something
356 [&or name ("setf" :name setf name)]
357 ;; ^^ This is the methods symbol
358 [ &optional keywordp ] ; this is key :before etc
360 [ &optional stringp ] ; documentation string
361 def-body))) ; part to be debugged
362 (let ((qualifiers nil)
363 (setfizer (if (eq 'setf (car-safe name))
364 ;; Call it before we call cl--generic-lambda.
365 (cl--generic-setf-rewrite (cadr name)))))
366 (while (not (listp args))
367 (push args qualifiers)
368 (setq args (pop body)))
369 (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
372 (setq name (car setfizer))
374 ,(and (get name 'byte-obsolete-info)
375 (or (not (fboundp 'byte-compile-warning-enabled-p))
376 (byte-compile-warning-enabled-p 'obsolete))
377 (let* ((obsolete (get name 'byte-obsolete-info)))
378 (macroexp--warn-and-return
379 (macroexp--obsolete-warning name obsolete "generic function")
381 ;; You could argue that `defmethod' modifies rather than defines the
382 ;; function, so warnings like "not known to be defined" are fair game.
383 ;; But in practice, it's common to use `cl-defmethod'
384 ;; without a previous `cl-defgeneric'.
385 (declare-function ,name "")
386 (cl-generic-define-method ',name ',(nreverse qualifiers) ',args
389 (defun cl--generic-member-method (specializers qualifiers methods)
392 (let ((m (car methods)))
393 (not (and (equal (cl--generic-method-specializers m) specializers)
394 (equal (cl--generic-method-qualifiers m) qualifiers)))))
395 (setq methods (cdr methods)))
399 (defun cl-generic-define-method (name qualifiers args uses-cnm function)
401 ((generic (cl-generic-ensure-function name))
402 (`(,spec-args . ,_) (cl--generic-split-args args))
403 (specializers (mapcar (lambda (spec-arg)
404 (if (eq '&context (car-safe (car spec-arg)))
405 spec-arg (cdr spec-arg)))
407 (method (cl--generic-make-method
408 specializers qualifiers uses-cnm function))
409 (mt (cl--generic-method-table generic))
410 (me (cl--generic-member-method specializers qualifiers mt))
411 (dispatches (cl--generic-dispatches generic))
413 (dolist (spec-arg spec-args)
414 (let* ((key (if (eq '&context (car-safe (car spec-arg)))
416 (generalizers (cl-generic-generalizers (cdr spec-arg)))
417 (x (assoc key dispatches)))
419 (setq x (cons key (cl-generic-generalizers t)))
420 (setf (cl--generic-dispatches generic)
421 (setq dispatches (cons x dispatches))))
422 (dolist (generalizer generalizers)
423 (unless (member generalizer (cdr x))
425 (sort (cons generalizer (cdr x))
427 (> (cl--generic-generalizer-priority x)
428 (cl--generic-generalizer-priority y)))))))
430 (if me (setcar me method)
431 (setf (cl--generic-method-table generic) (cons method mt)))
432 (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
433 current-load-list :test #'equal)
434 ;; FIXME: Try to avoid re-constructing a new function if the old one
435 ;; is still valid (e.g. still empty method cache)?
436 (let ((gfun (cl--generic-make-function generic))
437 ;; Prevent `defalias' from recording this as the definition site of
438 ;; the generic function.
440 ;; For aliases, cl--generic-name gives us the actual name.
441 (defalias (cl--generic-name generic) gfun))))
443 (defmacro cl--generic-with-memoization (place &rest code)
444 (declare (indent 1) (debug t))
445 (gv-letplace (getter setter) place
447 ,(macroexp-let2 nil val (macroexp-progn code)
449 ,(funcall setter val)
452 (defvar cl--generic-dispatchers (make-hash-table :test #'equal))
454 (defun cl--generic-get-dispatcher (dispatch)
455 (cl--generic-with-memoization
456 (gethash dispatch cl--generic-dispatchers)
457 ;; (message "cl--generic-get-dispatcher (%S)" dispatch)
458 (let* ((dispatch-arg (car dispatch))
459 (generalizers (cdr dispatch))
462 (mapcar (lambda (generalizer)
463 (funcall (cl--generic-generalizer-tagcode-function
469 (lambda (generalizer)
470 `(funcall ',(cl--generic-generalizer-specializers-function
472 ,(funcall (cl--generic-generalizer-tagcode-function
477 ;; Minor optimization: since this tag-exp is
478 ;; only used to lookup the method-cache, it
479 ;; doesn't matter if the default value is some
481 `(or ,@(if (macroexp-const-p (car (last tagcodes)))
485 (dispatch-idx dispatch-arg)
487 (when (eq '&context (car-safe dispatch-arg))
488 (setq bindings `((arg ,(cdr dispatch-arg))))
490 (setq dispatch-idx 0))
491 (dotimes (i dispatch-idx)
492 (push (make-symbol (format "arg%d" (- dispatch-idx i 1))) fixedargs))
493 ;; FIXME: For generic functions with a single method (or with 2 methods,
494 ;; one of which always matches), using a tagcode + hash-table is
495 ;; overkill: better just use a `cl-typep' test.
497 `(lambda (generic dispatches-left methods)
498 (let ((method-cache (make-hash-table :test #'eql)))
499 (lambda (,@fixedargs &rest args)
501 (apply (cl--generic-with-memoization
502 (gethash ,tag-exp method-cache)
503 (cl--generic-cache-miss
504 generic ',dispatch-arg dispatches-left methods
505 ,(if (cdr typescodes)
506 `(append ,@typescodes) (car typescodes))))
507 ,@fixedargs args)))))))))
509 (defun cl--generic-make-function (generic)
510 (cl--generic-make-next-function generic
511 (cl--generic-dispatches generic)
512 (cl--generic-method-table generic)))
514 (defun cl--generic-make-next-function (generic dispatches methods)
517 (while (and dispatches
518 (let ((x (nth 1 (car dispatches))))
519 ;; No need to dispatch for `t' specializers.
520 (or (null x) (equal x cl--generic-t-generalizer))))
521 (setq dispatches (cdr dispatches)))
523 (if (not (and dispatch
524 ;; If there's no method left, there's no point checking
525 ;; further arguments.
527 (cl--generic-build-combined-method generic methods)
528 (let ((dispatcher (cl--generic-get-dispatcher dispatch)))
529 (funcall dispatcher generic dispatches methods)))))
531 (defvar cl--generic-combined-method-memoization
532 (make-hash-table :test #'equal :weakness 'value)
533 "Table storing previously built combined-methods.
534 This is particularly useful when many different tags select the same set
535 of methods, since this table then allows us to share a single combined-method
536 for all those different tags in the method-cache.")
538 (define-error 'cl--generic-cyclic-definition "Cyclic definition: %S")
540 (defun cl--generic-build-combined-method (generic methods)
542 ;; Special case needed to fix a circularity during bootstrap.
543 (cl--generic-standard-method-combination generic methods)
545 (cl--generic-with-memoization
546 ;; FIXME: Since the fields of `generic' are modified, this
547 ;; hash-table won't work right, because the hashes will change!
548 ;; It's not terribly serious, but reduces the effectiveness of
550 (gethash (cons generic methods)
551 cl--generic-combined-method-memoization)
552 (puthash (cons generic methods) :cl--generic--under-construction
553 cl--generic-combined-method-memoization)
555 (cl-generic-combine-methods generic methods)
556 ;; Special case needed to fix a circularity during bootstrap.
557 (cl--generic-cyclic-definition
558 (cl--generic-standard-method-combination generic methods))))))
559 (if (eq f :cl--generic--under-construction)
560 (signal 'cl--generic-cyclic-definition
561 (list (cl--generic-name generic)))
564 (defun cl--generic-no-next-method-function (generic method)
566 (apply #'cl-no-next-method generic method args)))
568 (defun cl-generic-call-method (generic method &optional fun)
569 "Return a function that calls METHOD.
570 FUN is the function that should be called when METHOD calls
572 (if (not (cl--generic-method-uses-cnm method))
573 (cl--generic-method-function method)
574 (let ((met-fun (cl--generic-method-function method))
575 (next (or fun (cl--generic-no-next-method-function
579 ;; FIXME: This sucks: passing just `next' would
580 ;; be a lot more efficient than the lambda+apply
581 ;; quasi-η, but we need this to implement the
582 ;; "if call-next-method is called with no
583 ;; arguments, then use the previous arguments".
584 (lambda (&rest cnm-args)
585 (apply next (or cnm-args args)))
588 ;; Standard CLOS name.
589 (defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers)
591 (defun cl--generic-standard-method-combination (generic methods)
592 (let ((mets-by-qual ()))
593 (dolist (method methods)
594 (let ((qualifiers (cl-method-qualifiers method)))
595 (if (eq (car qualifiers) :extra) (setq qualifiers (cddr qualifiers)))
596 (unless (member qualifiers '(() (:after) (:before) (:around)))
597 (error "Unsupported qualifiers in function %S: %S"
598 (cl--generic-name generic) qualifiers))
599 (push method (alist-get (car qualifiers) mets-by-qual))))
603 (apply #'cl-no-applicable-method generic args)))
604 ((null (alist-get nil mets-by-qual))
606 (apply #'cl-no-primary-method generic args)))
609 (ab-call (lambda (m) (cl-generic-call-method generic m)))
611 (mapcar ab-call (reverse (cdr (assoc :before mets-by-qual)))))
612 (after (mapcar ab-call (cdr (assoc :after mets-by-qual)))))
613 (dolist (method (cdr (assoc nil mets-by-qual)))
614 (setq fun (cl-generic-call-method generic method fun)))
615 (when (or after before)
617 (setq fun (lambda (&rest args)
623 (apply af args)))))))
624 (dolist (method (cdr (assoc :around mets-by-qual)))
625 (setq fun (cl-generic-call-method generic method fun)))
628 (defun cl--generic-cache-miss (generic
629 dispatch-arg dispatches-left methods-left types)
631 (dolist (method methods-left)
632 (let* ((specializer (or (if (integerp dispatch-arg)
634 (cl--generic-method-specializers method))
635 (cdr (assoc dispatch-arg
636 (cl--generic-method-specializers method))))
638 (m (member specializer types)))
640 (push (cons (length m) method) methods))))
641 ;; Sort the methods, most specific first.
642 ;; It would be tempting to sort them once and for all in the method-table
643 ;; rather than here, but the order might depend on the actual argument
644 ;; (e.g. for multiple inheritance with defclass).
645 (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
646 (cl--generic-make-next-function generic dispatches-left methods)))
648 (cl-defgeneric cl-generic-generalizers (specializer)
649 "Return a list of generalizers for a given SPECIALIZER.
650 To each kind of `specializer', corresponds a `generalizer' which describes
651 how to extract a \"tag\" from an object which will then let us check if this
652 object matches the specializer. A typical example of a \"tag\" would be the
653 type of an object. It's called a `generalizer' because it
654 takes a specific object and returns a more general approximation,
655 denoting a set of objects to which it belongs.
656 A generalizer gives us the chunk of code which the
657 dispatch function needs to use to extract the \"tag\" of an object, as well
658 as a function which turns this tag into an ordered list of
659 `specializers' that this object matches.
660 The code which extracts the tag should be as fast as possible.
661 The tags should be chosen according to the following rules:
662 - The tags should not be too specific: similar objects which match the
663 same list of specializers should ideally use the same (`eql') tag.
664 This insures that the cached computation of the applicable
665 methods for one object can be reused for other objects.
666 - Corollary: objects which don't match any of the relevant specializers
667 should ideally all use the same tag (typically nil).
668 This insures that this cache does not grow unnecessarily large.
669 - Two different generalizers G1 and G2 should not use the same tag
670 unless they use it for the same set of objects. IOW, if G1.tag(X1) =
671 G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2).
672 - If G1.priority > G2.priority and G1.tag(X1) = G1.tag(X2) and this tag is
673 non-nil, then you have to make sure that the G2.tag(X1) = G2.tag(X2).
674 This is because the method-cache is only indexed with the first non-nil
675 tag (by order of decreasing priority).")
678 (cl-defgeneric cl-generic-combine-methods (generic methods)
679 "Build the effective method made of METHODS.
680 It should return a function that expects the same arguments as the methods, and
681 calls those methods in some appropriate order.
682 GENERIC is the generic function (mostly used for its name).
683 METHODS is the list of the selected methods.
684 The METHODS list is sorted from most specific first to most generic last.
685 The function can use `cl-generic-call-method' to create functions that call those
688 ;; Temporary definition to let the next defmethod succeed.
689 (fset 'cl-generic-generalizers
690 (lambda (_specializer) (list cl--generic-t-generalizer)))
691 (fset 'cl-generic-combine-methods
692 #'cl--generic-standard-method-combination)
694 (cl-defmethod cl-generic-generalizers (specializer)
695 "Support for the catch-all `t' specializer."
696 (if (eq specializer t) (list cl--generic-t-generalizer)
697 (error "Unknown specializer %S" specializer)))
699 (cl-defmethod cl-generic-combine-methods (generic methods)
700 "Standard support for :after, :before, :around, and `:extra NAME' qualifiers."
701 (cl--generic-standard-method-combination generic methods))
703 (defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t))
704 (defconst cl--generic-cnm-sample
705 (funcall (cl--generic-build-combined-method
706 nil (list (cl--generic-make-method () () t #'identity)))))
708 (defun cl--generic-isnot-nnm-p (cnm)
709 "Return non-nil if CNM is the function that calls `cl-no-next-method'."
710 ;; ¡Big Gross Ugly Hack!
711 ;; `next-method-p' just sucks, we should let it die. But EIEIO did support
712 ;; it, and some packages use it, so we need to support it.
714 (cl-assert (function-equal cnm cl--generic-cnm-sample))
715 (if (byte-code-function-p cnm)
716 (let ((cnm-constants (aref cnm 2))
717 (sample-constants (aref cl--generic-cnm-sample 2)))
718 (dotimes (i (length sample-constants))
719 (when (function-equal (aref sample-constants i)
720 cl--generic-nnm-sample)
722 (not (function-equal (aref cnm-constants i)
723 cl--generic-nnm-sample))))))
724 (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample)))
725 (let ((cnm-env (cadr cnm)))
726 (dolist (vb (cadr cl--generic-cnm-sample))
727 (when (function-equal (cdr vb) cl--generic-nnm-sample)
729 (not (function-equal (cdar cnm-env)
730 cl--generic-nnm-sample))))
731 (setq cnm-env (cdr cnm-env)))))
732 (error "Haven't found no-next-method-sample in cnm-sample")))
734 ;;; Define some pre-defined generic functions, used internally.
736 (define-error 'cl-no-method "No method for %S")
737 (define-error 'cl-no-next-method "No next method for %S" 'cl-no-method)
738 (define-error 'cl-no-primary-method "No primary method for %S" 'cl-no-method)
739 (define-error 'cl-no-applicable-method "No applicable method for %S"
742 (cl-defgeneric cl-no-next-method (generic method &rest args)
743 "Function called when `cl-call-next-method' finds no next method."
744 (signal 'cl-no-next-method `(,(cl--generic-name generic) ,method ,@args)))
746 (cl-defgeneric cl-no-applicable-method (generic &rest args)
747 "Function called when a method call finds no applicable method."
748 (signal 'cl-no-applicable-method `(,(cl--generic-name generic) ,@args)))
750 (cl-defgeneric cl-no-primary-method (generic &rest args)
751 "Function called when a method call finds no primary method."
752 (signal 'cl-no-primary-method `(,(cl--generic-name generic) ,@args)))
754 (defun cl-call-next-method (&rest _args)
755 "Function to call the next applicable method.
756 Can only be used from within the lexical body of a primary or around method."
757 (error "cl-call-next-method only allowed inside primary and around methods"))
759 (defun cl-next-method-p ()
760 "Return non-nil if there is a next method.
761 Can only be used from within the lexical body of a primary or around method."
762 (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1"))
763 (error "cl-next-method-p only allowed inside primary and around methods"))
766 (defun cl-find-method (generic qualifiers specializers)
767 (car (cl--generic-member-method
768 specializers qualifiers
769 (cl--generic-method-table (cl--generic generic)))))
771 (defalias 'cl-method-qualifiers 'cl--generic-method-qualifiers)
773 ;;; Add support for describe-function
775 (defun cl--generic-search-method (met-name)
776 (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+"
777 (regexp-quote (format "%s" (car met-name)))
781 (concat base-re "[^&\"\n]*"
782 (mapconcat (lambda (specializer)
784 (format "%S" (if (consp specializer)
785 (nth 1 specializer) specializer))))
786 (remq t (cdr met-name))
787 "[ \t\n]*)[^&\"\n]*"))
789 (re-search-forward base-re nil t))))
792 (with-eval-after-load 'find-func
793 (defvar find-function-regexp-alist)
794 (add-to-list 'find-function-regexp-alist
795 `(cl-defmethod . ,#'cl--generic-search-method)))
797 (defun cl--generic-method-info (method)
798 (let* ((specializers (cl--generic-method-specializers method))
799 (qualifiers (cl--generic-method-qualifiers method))
800 (uses-cnm (cl--generic-method-uses-cnm method))
801 (function (cl--generic-method-function method))
802 (args (help-function-arglist function 'names))
803 (docstring (documentation function))
805 (if (null qualifiers) ""
806 (cl-assert (consp qualifiers))
807 (let ((s (prin1-to-string qualifiers)))
808 (concat (substring s 1 -1) " "))))
809 (doconly (if docstring
810 (let ((split (help-split-fundoc docstring nil)))
811 (if split (cdr split) docstring))))
813 (if uses-cnm (setq args (cdr args)))
814 (dolist (specializer specializers)
815 (let ((arg (if (eq '&rest (car args))
816 (intern (format "arg%d" (length combined-args)))
818 (push (if (eq specializer t) arg (list arg specializer))
820 (setq combined-args (append (nreverse combined-args) args))
821 (list qual-string combined-args doconly)))
823 (add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
824 (defun cl--generic-describe (function)
825 (let ((generic (if (symbolp function) (cl--generic function))))
827 (require 'help-mode) ;Needed for `help-function-def' button!
829 (insert "\n\nThis is a generic function.\n\n")
830 (insert (propertize "Implementations:\n\n" 'face 'bold))
831 ;; Loop over fanciful generics
832 (dolist (method (cl--generic-method-table generic))
833 (let* ((info (cl--generic-method-info method)))
834 ;; FIXME: Add hyperlinks for the types as well.
835 (insert (format "%s%S" (nth 0 info) (nth 1 info)))
836 (let* ((met-name (cons function
837 (cl--generic-method-specializers method)))
838 (file (find-lisp-object-file-name met-name 'cl-defmethod)))
841 (help-insert-xref-button (help-fns-short-filename file)
842 'help-function-def met-name file
845 (insert "\n" (or (nth 2 info) "Undocumented") "\n\n")))))))
847 ;;; Support for (head <val>) specializers.
849 ;; For both the `eql' and the `head' specializers, the dispatch
850 ;; is unsatisfactory. Basically, in the "common&fast case", we end up doing
852 ;; (let ((tag (gethash value <tagcode-hashtable>)))
853 ;; (funcall (gethash tag <method-cache>)))
855 ;; whereas we'd like to just do
857 ;; (funcall (gethash value <method-cache>)))
859 ;; but the problem is that the method-cache is normally "open ended", so
860 ;; a nil means "not computed yet" and if we bump into it, we dutifully fill the
861 ;; corresponding entry, whereas we'd want to just fallback on some default
862 ;; effective method (so as not to fill the cache with lots of redundant
865 (defvar cl--generic-head-used (make-hash-table :test #'eql))
867 (defconst cl--generic-head-generalizer
868 (cl-generic-make-generalizer
869 80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used))
870 (lambda (tag) (if (eq (car-safe tag) 'head) (list tag)))))
872 ;; Pre-fill the cl--generic-dispatchers table.
873 ;; We have two copies of `(0 ...)' but we can't share them via `let' because
874 ;; they're not used at the same time (one is compile-time, one is run-time).
875 (puthash `(0 ,cl--generic-head-generalizer ,cl--generic-t-generalizer)
877 (unless (fboundp 'cl--generic-get-dispatcher)
878 (require 'cl-generic))
879 (cl--generic-get-dispatcher
880 `(0 ,cl--generic-head-generalizer ,cl--generic-t-generalizer)))
881 cl--generic-dispatchers)
883 (cl-defmethod cl-generic-generalizers :extra "head" (specializer)
884 "Support for the `(head VAL)' specializers."
885 ;; We have to implement `head' here using the :extra qualifier,
886 ;; since we can't use the `head' specializer to implement itself.
887 (if (not (eq (car-safe specializer) 'head))
888 (cl-call-next-method)
889 (cl--generic-with-memoization
890 (gethash (cadr specializer) cl--generic-head-used) specializer)
891 (list cl--generic-head-generalizer)))
893 ;;; Support for (eql <val>) specializers.
895 (defvar cl--generic-eql-used (make-hash-table :test #'eql))
897 (defconst cl--generic-eql-generalizer
898 (cl-generic-make-generalizer
899 100 (lambda (name) `(gethash ,name cl--generic-eql-used))
900 (lambda (tag) (if (eq (car-safe tag) 'eql) (list tag)))))
902 (cl-defmethod cl-generic-generalizers ((specializer (head eql)))
903 "Support for the `(eql VAL)' specializers."
904 (puthash (cadr specializer) specializer cl--generic-eql-used)
905 (list cl--generic-eql-generalizer))
907 ;;; Support for cl-defstructs specializers.
909 (defun cl--generic-struct-tag (name)
910 ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
911 ;; but that would suffer from some problems:
912 ;; - the vector may have size 0.
913 ;; - when called on an actual vector (rather than an object), we'd
914 ;; end up returning an arbitrary value, possibly colliding with
915 ;; other tagcode's values.
916 ;; - it can also result in returning all kinds of irrelevant
917 ;; values which would end up filling up the method-cache with
918 ;; lots of irrelevant/redundant entries.
919 ;; FIXME: We could speed this up by introducing a dedicated
920 ;; vector type at the C level, so we could do something like
921 ;; (and (vector-objectp ,name) (aref ,name 0))
922 `(and (vectorp ,name)
924 (let ((tag (aref ,name 0)))
925 (if (eq (symbol-function tag) :quick-object-witness-check)
928 (defun cl--generic-struct-specializers (tag)
929 (and (symbolp tag) (boundp tag)
930 (let ((class (symbol-value tag)))
931 (when (cl-typep class 'cl-structure-class)
933 (classes (list class)))
935 (while (let ((class (pop classes)))
936 (push (cl--class-name class) types)
939 (cl--class-parents class)))))
940 (nreverse types))))))
942 (defconst cl--generic-struct-generalizer
943 (cl-generic-make-generalizer
944 50 #'cl--generic-struct-tag
945 #'cl--generic-struct-specializers))
947 (cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
948 "Support for dispatch on cl-struct types."
951 ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
952 ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
953 ;; take place without requiring cl-lib.
954 (let ((class (cl--find-class type)))
955 (and (cl-typep class 'cl-structure-class)
956 (or (null (cl--struct-class-type class))
957 (error "Can't dispatch on cl-struct %S: type is %S"
958 type (cl--struct-class-type class)))
959 (progn (cl-assert (null (cl--struct-class-named class))) t)
960 (list cl--generic-struct-generalizer))))
961 (cl-call-next-method)))
963 ;;; Dispatch on "system types".
965 (defconst cl--generic-typeof-types
966 ;; Hand made from the source code of `type-of'.
967 '((integer number) (symbol) (string array sequence) (cons list sequence)
968 ;; Markers aren't `numberp', yet they are accepted wherever integers are
969 ;; accepted, pretty much.
970 (marker) (overlay) (float number) (window-configuration)
971 (process) (window) (subr) (compiled-function) (buffer)
972 (char-table array sequence)
973 (bool-vector array sequence)
974 (frame) (hash-table) (font-spec) (font-entity) (font-object)
975 (vector array sequence)
977 (null symbol list sequence)
983 (defconst cl--generic-typeof-generalizer
984 (cl-generic-make-generalizer
985 ;; FIXME: We could also change `type-of' to return `null' for nil.
986 10 (lambda (name) `(if ,name (type-of ,name) 'null))
987 (lambda (tag) (and (symbolp tag) (assq tag cl--generic-typeof-types)))))
989 (cl-defmethod cl-generic-generalizers :extra "typeof" (type)
990 "Support for dispatch on builtin types."
991 ;; FIXME: Add support for other types accepted by `cl-typep' such
992 ;; as `character', `atom', `face', `function', ...
994 (and (assq type cl--generic-typeof-types)
996 (if (memq type '(vector array sequence))
997 (message "`%S' also matches CL structs and EIEIO classes" type))
998 (list cl--generic-typeof-generalizer)))
999 (cl-call-next-method)))
1002 ;; generated-autoload-file: "cl-loaddefs.el"
1005 (provide 'cl-generic)
1006 ;;; cl-generic.el ends here