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>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;; This implements the most of CLOS's multiple-dispatch generic functions.
25 ;; To use it you need either (require 'cl-generic) or (require 'cl-lib).
26 ;; The main entry points are: `cl-defgeneric' and `cl-defmethod'.
29 ;; - We don't support make-method, call-method, define-method-combination.
30 ;; CLOS's define-method-combination is IMO overly complicated, and it suffers
31 ;; from a significant problem: the method-combination code returns a sexp
32 ;; that needs to be `eval'uated or compiled. IOW it requires run-time
33 ;; code generation. Given how rarely method-combinations are used,
34 ;; I just provided a cl-generic-combine-methods generic function, to which
35 ;; people can add methods if they are really desperate for such functionality.
36 ;; - In defgeneric we don't support the options:
37 ;; declare, :method-combination, :generic-function-class, :method-class.
39 ;; - We support aliases to generic functions.
40 ;; - cl-generic-generalizers. This generic function lets you extend the kind
41 ;; of thing on which to dispatch. There is support in this file for
44 ;; - (head <val>) which checks that the arg is a cons with <val> as its head.
46 ;; - type of CL structs
47 ;; eieio-core adds dispatch on:
48 ;; - class of eieio objects
49 ;; - actual class argument, using the syntax (subclass <class>).
50 ;; - cl-generic-combine-methods (i.s.o define-method-combination and
51 ;; compute-effective-method).
52 ;; - cl-generic-call-method (which replaces make-method and call-method).
53 ;; - The standard method combination supports ":extra STRING" qualifiers
54 ;; which simply allows adding more methods for the same
55 ;; specializers&qualifiers.
57 ;; Efficiency considerations: overall, I've made an effort to make this fairly
58 ;; efficient for the expected case (e.g. no constant redefinition of methods).
59 ;; - Generic functions which do not dispatch on any argument are implemented
60 ;; optimally (just as efficient as plain old functions).
61 ;; - Generic functions which only dispatch on one argument are fairly efficient
62 ;; (not a lot of room for improvement without changes to the byte-compiler,
64 ;; - Multiple dispatch is implemented rather naively. There's an extra `apply'
65 ;; function call for every dispatch; we don't optimize each dispatch
66 ;; based on the set of candidate methods remaining; we don't optimize the
67 ;; order in which we performs the dispatches either;
68 ;; If/when this becomes a problem, we can try and optimize it.
69 ;; - call-next-method could be made more efficient, but isn't too terrible.
73 ;; - A generic "filter" generalizer (e.g. could be used to cleanly adds methods
74 ;; to cl-generic-combine-methods with a specializer that says it applies only
75 ;; when some particular qualifier is used).
76 ;; - A way to dispatch on the context (e.g. the major-mode, some global
77 ;; variable, you name it).
81 ;; Note: For generic functions that dispatch on several arguments (i.e. those
82 ;; which use the multiple-dispatch feature), we always use the same "tagcodes"
83 ;; and the same set of arguments on which to dispatch. This works, but is
84 ;; often suboptimal since after one dispatch, the remaining dispatches can
85 ;; usually be simplified, or even completely skipped.
87 (eval-when-compile (require 'cl-lib))
88 (eval-when-compile (require 'pcase))
90 (cl-defstruct (cl--generic-generalizer
92 (:constructor cl-generic-make-generalizer
93 (priority tagcode-function specializers-function)))
94 (priority nil :type integer)
96 specializers-function)
98 (defconst cl--generic-t-generalizer
99 (cl-generic-make-generalizer
100 0 (lambda (_name) nil) (lambda (_tag) '(t))))
102 (cl-defstruct (cl--generic-method
104 (:constructor cl--generic-make-method
105 (specializers qualifiers uses-cnm function))
107 (specializers nil :read-only t :type list)
108 (qualifiers nil :read-only t :type (list-of atom))
109 ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument
110 ;; holding the next-method.
111 (uses-cnm nil :read-only t :type boolean)
112 (function nil :read-only t :type function))
114 (cl-defstruct (cl--generic
116 (:constructor cl--generic-make (name))
118 (name nil :type symbol :read-only t) ;Pointer back to the symbol.
119 ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
120 ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
121 ;; where the EXPs are expressions (to be `or'd together) to compute the tag
122 ;; on which to dispatch and PRIORITY is the priority of each expression to
123 ;; decide in which order to sort them.
124 ;; The most important dispatch is last in the list (and the least is first).
125 (dispatches nil :type (list-of (cons natnum (list-of generalizers))))
126 (method-table nil :type (list-of cl--generic-method))
127 (options nil :type list))
129 (defun cl-generic-function-options (generic)
130 "Return the options of the generic function GENERIC."
131 (cl--generic-options generic))
133 (defmacro cl--generic (name)
134 `(get ,name 'cl--generic))
136 (defun cl-generic-ensure-function (name)
139 (while (and (null (setq generic (cl--generic name)))
141 (symbolp (symbol-function name)))
142 (setq name (symbol-function name)))
143 (unless (or (not (fboundp name))
144 (autoloadp (symbol-function name))
145 (and (functionp name) generic))
146 (error "%s is already defined as something else than a generic function"
149 (cl-assert (eq name (cl--generic-name generic)))
150 (setf (cl--generic name) (setq generic (cl--generic-make name)))
151 (defalias name (cl--generic-make-function generic)))
154 (defun cl--generic-setf-rewrite (name)
155 (let* ((setter (intern (format "cl-generic-setter--%s" name)))
156 (exp `(unless (eq ',setter (get ',name 'cl-generic-setter))
157 ;; (when (get ',name 'gv-expander)
158 ;; (error "gv-expander conflicts with (setf %S)" ',name))
159 (setf (get ',name 'cl-generic-setter) ',setter)
160 (gv-define-setter ,name (val &rest args)
161 (cons ',setter (cons val args))))))
162 ;; Make sure `setf' can be used right away, e.g. in the body of the method.
167 (defmacro cl-defgeneric (name args &rest options-and-methods)
168 "Create a generic function NAME.
169 DOC-STRING is the base documentation for this class. A generic
170 function has no body, as its purpose is to decide which method body
171 is appropriate to use. Specific methods are defined with `cl-defmethod'.
172 With this implementation the ARGS are currently ignored.
173 OPTIONS-AND-METHODS currently understands:
174 - (:documentation DOCSTRING)
175 - (declare DECLARATIONS)
176 - (:argument-precedence-order &rest ARGS)
177 - (:method [QUALIFIERS...] ARGS &rest BODY)
178 BODY, if present, is used as the body of a default method.
180 \(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)"
181 (declare (indent 2) (doc-string 3))
182 (let* ((doc (if (stringp (car-safe options-and-methods))
183 (pop options-and-methods)))
188 (while (progn (setq next-head (car-safe (car options-and-methods)))
189 (or (keywordp next-head)
190 (eq next-head 'declare)))
193 (when doc (error "Multiple doc strings for %S" name))
194 (setq doc (cadr (pop options-and-methods))))
196 (when declarations (error "Multiple `declare' for %S" name))
197 (setq declarations (pop options-and-methods)))
198 (`:method (push (cdr (pop options-and-methods)) methods))
199 (_ (push (pop options-and-methods) options))))
200 (when options-and-methods
201 ;; Anything remaining is assumed to be a default method body.
202 (push `(,args ,@options-and-methods) methods))
204 ,(when (eq 'setf (car-safe name))
205 (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
209 ,@(mapcar (lambda (declaration)
210 (let ((f (cdr (assq (car declaration)
211 defun-declarations-alist))))
213 (f (apply (car f) name args (cdr declaration)))
214 (t (message "Warning: Unknown defun property `%S' in %S"
215 (car declaration) name)
219 (cl-generic-define ',name ',args ',(nreverse options))
220 ,(help-add-fundoc-usage doc args))
221 ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
222 (nreverse methods)))))
224 (defun cl--generic-mandatory-args (args)
226 (while (not (memq (car args) '(nil &rest &optional &key)))
227 (push (pop args) res))
231 (defun cl-generic-define (name args options)
232 (let ((generic (cl-generic-ensure-function name))
233 (mandatory (cl--generic-mandatory-args args))
234 (apo (assq :argument-precedence-order options)))
235 (setf (cl--generic-dispatches generic) nil)
237 (dolist (arg (cdr apo))
238 (let ((pos (memq arg mandatory)))
239 (unless pos (error "%S is not a mandatory argument" arg))
240 (push (list (- (length mandatory) (length pos)))
241 (cl--generic-dispatches generic)))))
242 (setf (cl--generic-method-table generic) nil)
243 (setf (cl--generic-options generic) options)
244 (cl--generic-make-function generic)))
246 (defmacro cl-generic-current-method-specializers ()
247 "List of (VAR . TYPE) where TYPE is var's specializer.
248 This macro can only be used within the lexical scope of a cl-generic method."
249 (error "cl-generic-current-method-specializers used outside of a method"))
251 (eval-and-compile ;Needed while compiling the cl-defmethod calls below!
252 (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el.
253 "Check which of the symbols VARS appear in SEXP."
256 (dolist (var (cl--generic-fgrep vars (pop sexp)))
257 (unless (memq var res) (push var res))))
258 (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
261 (defun cl--generic-lambda (args body)
262 "Make the lambda expression for a method with ARGS and BODY."
263 (let ((plain-args ())
268 ((or '&optional '&rest '&key) (setq mandatory nil) arg)
269 ((and `(,name . ,type) (guard mandatory))
270 (push (cons name (car type)) specializers)
274 (setq plain-args (nreverse plain-args))
275 (let ((fun `(cl-function (lambda ,plain-args ,@body)))
276 (macroenv (cons `(cl-generic-current-method-specializers
277 . ,(lambda () specializers))
278 macroexpand-all-environment)))
279 (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'.
280 ;; First macroexpand away the cl-function stuff (e.g. &key and
281 ;; destructuring args, `declare' and whatnot).
282 (pcase (macroexpand fun macroenv)
283 (`#'(lambda ,args . ,body)
284 (let* ((parsed-body (macroexp-parse-body body))
285 (cnm (make-symbol "cl--cnm"))
286 (nmp (make-symbol "cl--nmp"))
287 (nbody (macroexpand-all
288 `(cl-flet ((cl-call-next-method ,cnm)
289 (cl-next-method-p ,nmp))
292 ;; FIXME: Rather than `grep' after the fact, the
293 ;; macroexpansion should directly set some flag when cnm
295 ;; FIXME: Also, optimize the case where call-next-method is
296 ;; only called with explicit arguments.
297 (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
298 (cons (not (not uses-cnm))
299 `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
301 ,(if (not (memq nmp uses-cnm))
303 `(let ((,nmp (lambda ()
304 (cl--generic-isnot-nnm-p ,cnm))))
306 (f (error "Unexpected macroexpansion result: %S" f)))))))
310 (defmacro cl-defmethod (name args &rest body)
311 "Define a new method for generic function NAME.
312 I.e. it defines the implementation of NAME to use for invocations where the
313 value of the dispatch argument matches the specified TYPE.
314 The dispatch argument has to be one of the mandatory arguments, and
315 all methods of NAME have to use the same argument for dispatch.
316 The dispatch argument and TYPE are specified in ARGS where the corresponding
317 formal argument appears as (VAR TYPE) rather than just VAR.
319 The optional second argument QUALIFIER is a specifier that
320 modifies how the method is combined with other methods, including:
321 :before - Method will be called before the primary
322 :after - Method will be called after the primary
323 :around - Method will be called around everything else
324 The absence of QUALIFIER means this is a \"primary\" method.
326 Other than a type, TYPE can also be of the form `(eql VAL)' in
327 which case this method will be invoked when the argument is `eql' to VAL.
329 \(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
330 (declare (doc-string 3) (indent 2)
332 (&define ; this means we are defining something
333 [&or name ("setf" :name setf name)]
334 ;; ^^ This is the methods symbol
335 [ &optional keywordp ] ; this is key :before etc
337 [ &optional stringp ] ; documentation string
338 def-body))) ; part to be debugged
339 (let ((qualifiers nil)
340 (setfizer (if (eq 'setf (car-safe name))
341 ;; Call it before we call cl--generic-lambda.
342 (cl--generic-setf-rewrite (cadr name)))))
343 (while (not (listp args))
344 (push args qualifiers)
345 (setq args (pop body)))
346 (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
349 (setq name (car setfizer))
351 ,(and (get name 'byte-obsolete-info)
352 (or (not (fboundp 'byte-compile-warning-enabled-p))
353 (byte-compile-warning-enabled-p 'obsolete))
354 (let* ((obsolete (get name 'byte-obsolete-info)))
355 (macroexp--warn-and-return
356 (macroexp--obsolete-warning name obsolete "generic function")
358 ;; You could argue that `defmethod' modifies rather than defines the
359 ;; function, so warnings like "not known to be defined" are fair game.
360 ;; But in practice, it's common to use `cl-defmethod'
361 ;; without a previous `cl-defgeneric'.
362 (declare-function ,name "")
363 (cl-generic-define-method ',name ',(nreverse qualifiers) ',args
366 (defun cl--generic-member-method (specializers qualifiers methods)
369 (let ((m (car methods)))
370 (not (and (equal (cl--generic-method-specializers m) specializers)
371 (equal (cl--generic-method-qualifiers m) qualifiers)))))
372 (setq methods (cdr methods)))
376 (defun cl-generic-define-method (name qualifiers args uses-cnm function)
377 (let* ((generic (cl-generic-ensure-function name))
378 (mandatory (cl--generic-mandatory-args args))
380 (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory))
381 (method (cl--generic-make-method
382 specializers qualifiers uses-cnm function))
383 (mt (cl--generic-method-table generic))
384 (me (cl--generic-member-method specializers qualifiers mt))
385 (dispatches (cl--generic-dispatches generic))
387 (dolist (specializer specializers)
388 (let* ((generalizers (cl-generic-generalizers specializer))
389 (x (assq i dispatches)))
391 (setq x (cons i (cl-generic-generalizers t)))
392 (setf (cl--generic-dispatches generic)
393 (setq dispatches (cons x dispatches))))
394 (dolist (generalizer generalizers)
395 (unless (member generalizer (cdr x))
397 (sort (cons generalizer (cdr x))
399 (> (cl--generic-generalizer-priority x)
400 (cl--generic-generalizer-priority y)))))))
402 (if me (setcar me method)
403 (setf (cl--generic-method-table generic) (cons method mt)))
404 (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
405 current-load-list :test #'equal)
406 ;; FIXME: Try to avoid re-constructing a new function if the old one
407 ;; is still valid (e.g. still empty method cache)?
408 (let ((gfun (cl--generic-make-function generic))
409 ;; Prevent `defalias' from recording this as the definition site of
410 ;; the generic function.
412 ;; For aliases, cl--generic-name gives us the actual name.
413 (defalias (cl--generic-name generic) gfun))))
415 (defmacro cl--generic-with-memoization (place &rest code)
416 (declare (indent 1) (debug t))
417 (gv-letplace (getter setter) place
419 ,(macroexp-let2 nil val (macroexp-progn code)
421 ,(funcall setter val)
424 (defvar cl--generic-dispatchers (make-hash-table :test #'equal))
426 (defun cl--generic-get-dispatcher (dispatch)
427 (cl--generic-with-memoization
428 (gethash dispatch cl--generic-dispatchers)
429 (let* ((dispatch-arg (car dispatch))
430 (generalizers (cdr dispatch))
433 (mapcar (lambda (generalizer)
434 (funcall (cl--generic-generalizer-tagcode-function
439 (mapcar (lambda (generalizer)
440 `(funcall ',(cl--generic-generalizer-specializers-function
442 ,(funcall (cl--generic-generalizer-tagcode-function
447 ;; Minor optimization: since this tag-exp is
448 ;; only used to lookup the method-cache, it
449 ;; doesn't matter if the default value is some
451 `(or ,@(if (macroexp-const-p (car (last tagcodes)))
455 (dotimes (_ dispatch-arg)
456 (push (make-symbol "arg") extraargs))
457 ;; FIXME: For generic functions with a single method (or with 2 methods,
458 ;; one of which always matches), using a tagcode + hash-table is
459 ;; overkill: better just use a `cl-typep' test.
461 `(lambda (generic dispatches-left methods)
462 (let ((method-cache (make-hash-table :test #'eql)))
463 (lambda (,@extraargs arg &rest args)
464 (apply (cl--generic-with-memoization
465 (gethash ,tag-exp method-cache)
466 (cl--generic-cache-miss
467 generic ',dispatch-arg dispatches-left methods
468 ,(if (cdr typescodes)
469 `(append ,@typescodes) (car typescodes))))
470 ,@extraargs arg args))))))))
472 (defun cl--generic-make-function (generic)
473 (cl--generic-make-next-function generic
474 (cl--generic-dispatches generic)
475 (cl--generic-method-table generic)))
477 (defun cl--generic-make-next-function (generic dispatches methods)
480 (while (and dispatches
481 (let ((x (nth 1 (car dispatches))))
482 ;; No need to dispatch for `t' specializers.
483 (or (null x) (equal x cl--generic-t-generalizer))))
484 (setq dispatches (cdr dispatches)))
486 (if (not (and dispatch
487 ;; If there's no method left, there's no point checking
488 ;; further arguments.
490 (cl--generic-build-combined-method generic methods)
491 (let ((dispatcher (cl--generic-get-dispatcher dispatch)))
492 (funcall dispatcher generic dispatches methods)))))
494 (defvar cl--generic-combined-method-memoization
495 (make-hash-table :test #'equal :weakness 'value)
496 "Table storing previously built combined-methods.
497 This is particularly useful when many different tags select the same set
498 of methods, since this table then allows us to share a single combined-method
499 for all those different tags in the method-cache.")
501 (define-error 'cl--generic-cyclic-definition "Cyclic definition: %S")
503 (defun cl--generic-build-combined-method (generic methods)
505 ;; Special case needed to fix a circularity during bootstrap.
506 (cl--generic-standard-method-combination generic methods)
508 (cl--generic-with-memoization
509 ;; FIXME: Since the fields of `generic' are modified, this
510 ;; hash-table won't work right, because the hashes will change!
511 ;; It's not terribly serious, but reduces the effectiveness of
513 (gethash (cons generic methods)
514 cl--generic-combined-method-memoization)
515 (puthash (cons generic methods) :cl--generic--under-construction
516 cl--generic-combined-method-memoization)
518 (cl-generic-combine-methods generic methods)
519 ;; Special case needed to fix a circularity during bootstrap.
520 (cl--generic-cyclic-definition
521 (cl--generic-standard-method-combination generic methods))))))
522 (if (eq f :cl--generic--under-construction)
523 (signal 'cl--generic-cyclic-definition
524 (list (cl--generic-name generic)))
527 (defun cl--generic-no-next-method-function (generic method)
529 (apply #'cl-no-next-method generic method args)))
531 (defun cl-generic-call-method (generic method &optional fun)
532 "Return a function that calls METHOD.
533 FUN is the function that should be called when METHOD calls
535 (if (not (cl--generic-method-uses-cnm method))
536 (cl--generic-method-function method)
537 (let ((met-fun (cl--generic-method-function method))
538 (next (or fun (cl--generic-no-next-method-function
542 ;; FIXME: This sucks: passing just `next' would
543 ;; be a lot more efficient than the lambda+apply
544 ;; quasi-η, but we need this to implement the
545 ;; "if call-next-method is called with no
546 ;; arguments, then use the previous arguments".
547 (lambda (&rest cnm-args)
548 (apply next (or cnm-args args)))
551 ;; Standard CLOS name.
552 (defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers)
554 (defun cl--generic-standard-method-combination (generic methods)
555 (let ((mets-by-qual ()))
556 (dolist (method methods)
557 (let ((qualifiers (cl-method-qualifiers method)))
558 (if (eq (car qualifiers) :extra) (setq qualifiers (cddr qualifiers)))
559 (unless (member qualifiers '(() (:after) (:before) (:around)))
560 (error "Unsupported qualifiers in function %S: %S"
561 (cl--generic-name generic) qualifiers))
562 (push method (alist-get (car qualifiers) mets-by-qual))))
566 (apply #'cl-no-applicable-method generic args)))
567 ((null (alist-get nil mets-by-qual))
569 (apply #'cl-no-primary-method generic args)))
572 (ab-call (lambda (m) (cl-generic-call-method generic m)))
574 (mapcar ab-call (reverse (cdr (assoc :before mets-by-qual)))))
575 (after (mapcar ab-call (cdr (assoc :after mets-by-qual)))))
576 (dolist (method (cdr (assoc nil mets-by-qual)))
577 (setq fun (cl-generic-call-method generic method fun)))
578 (when (or after before)
580 (setq fun (lambda (&rest args)
586 (apply af args)))))))
587 (dolist (method (cdr (assoc :around mets-by-qual)))
588 (setq fun (cl-generic-call-method generic method fun)))
591 (defun cl--generic-cache-miss (generic
592 dispatch-arg dispatches-left methods-left types)
594 (dolist (method methods-left)
595 (let* ((specializer (or (nth dispatch-arg
596 (cl--generic-method-specializers method))
598 (m (member specializer types)))
600 (push (cons (length m) method) methods))))
601 ;; Sort the methods, most specific first.
602 ;; It would be tempting to sort them once and for all in the method-table
603 ;; rather than here, but the order might depend on the actual argument
604 ;; (e.g. for multiple inheritance with defclass).
605 (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
606 (cl--generic-make-next-function generic dispatches-left methods)))
608 (cl-defgeneric cl-generic-generalizers (specializer)
609 "Return a list of generalizers for a given SPECIALIZER.
610 To each kind of `specializer', corresponds a `generalizer' which describes
611 how to extract a \"tag\" from an object which will then let us check if this
612 object matches the specializer. A typical example of a \"tag\" would be the
613 type of an object. It's called a `generalizer' because it
614 takes a specific object and returns a more general approximation,
615 denoting a set of objects to which it belongs.
616 A generalizer gives us the chunk of code which the
617 dispatch function needs to use to extract the \"tag\" of an object, as well
618 as a function which turns this tag into an ordered list of
619 `specializers' that this object matches.
620 The code which extracts the tag should be as fast as possible.
621 The tags should be chosen according to the following rules:
622 - The tags should not be too specific: similar objects which match the
623 same list of specializers should ideally use the same (`eql') tag.
624 This insures that the cached computation of the applicable
625 methods for one object can be reused for other objects.
626 - Corollary: objects which don't match any of the relevant specializers
627 should ideally all use the same tag (typically nil).
628 This insures that this cache does not grow unnecessarily large.
629 - Two different generalizers G1 and G2 should not use the same tag
630 unless they use it for the same set of objects. IOW, if G1.tag(X1) =
631 G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2).
632 - If G1.priority > G2.priority and G1.tag(X1) = G1.tag(X2) and this tag is
633 non-nil, then you have to make sure that the G2.tag(X1) = G2.tag(X2).
634 This is because the method-cache is only indexed with the first non-nil
635 tag (by order of decreasing priority).")
638 (cl-defgeneric cl-generic-combine-methods (generic methods)
639 "Build the effective method made of METHODS.
640 It should return a function that expects the same arguments as the methods, and
641 calls those methods in some appropriate order.
642 GENERIC is the generic function (mostly used for its name).
643 METHODS is the list of the selected methods.
644 The METHODS list is sorted from most specific first to most generic last.
645 The function can use `cl-generic-call-method' to create functions that call those
648 ;; Temporary definition to let the next defmethod succeed.
649 (fset 'cl-generic-generalizers
650 (lambda (_specializer) (list cl--generic-t-generalizer)))
651 (fset 'cl-generic-combine-methods
652 #'cl--generic-standard-method-combination)
654 (cl-defmethod cl-generic-generalizers (specializer)
655 "Support for the catch-all `t' specializer."
656 (if (eq specializer t) (list cl--generic-t-generalizer)
657 (error "Unknown specializer %S" specializer)))
659 (cl-defmethod cl-generic-combine-methods (generic methods)
660 "Standard support for :after, :before, :around, and `:extra NAME' qualifiers."
661 (cl--generic-standard-method-combination generic methods))
663 (defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t))
664 (defconst cl--generic-cnm-sample
665 (funcall (cl--generic-build-combined-method
666 nil (list (cl--generic-make-method () () t #'identity)))))
668 (defun cl--generic-isnot-nnm-p (cnm)
669 "Return non-nil if CNM is the function that calls `cl-no-next-method'."
670 ;; ¡Big Gross Ugly Hack!
671 ;; `next-method-p' just sucks, we should let it die. But EIEIO did support
672 ;; it, and some packages use it, so we need to support it.
674 (cl-assert (function-equal cnm cl--generic-cnm-sample))
675 (if (byte-code-function-p cnm)
676 (let ((cnm-constants (aref cnm 2))
677 (sample-constants (aref cl--generic-cnm-sample 2)))
678 (dotimes (i (length sample-constants))
679 (when (function-equal (aref sample-constants i)
680 cl--generic-nnm-sample)
682 (not (function-equal (aref cnm-constants i)
683 cl--generic-nnm-sample))))))
684 (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample)))
685 (let ((cnm-env (cadr cnm)))
686 (dolist (vb (cadr cl--generic-cnm-sample))
687 (when (function-equal (cdr vb) cl--generic-nnm-sample)
689 (not (function-equal (cdar cnm-env)
690 cl--generic-nnm-sample))))
691 (setq cnm-env (cdr cnm-env)))))
692 (error "Haven't found no-next-method-sample in cnm-sample")))
694 ;;; Define some pre-defined generic functions, used internally.
696 (define-error 'cl-no-method "No method for %S")
697 (define-error 'cl-no-next-method "No next method for %S" 'cl-no-method)
698 (define-error 'cl-no-primary-method "No primary method for %S" 'cl-no-method)
699 (define-error 'cl-no-applicable-method "No applicable method for %S"
702 (cl-defgeneric cl-no-next-method (generic method &rest args)
703 "Function called when `cl-call-next-method' finds no next method."
704 (signal 'cl-no-next-method `(,(cl--generic-name generic) ,method ,@args)))
706 (cl-defgeneric cl-no-applicable-method (generic &rest args)
707 "Function called when a method call finds no applicable method."
708 (signal 'cl-no-applicable-method `(,(cl--generic-name generic) ,@args)))
710 (cl-defgeneric cl-no-primary-method (generic &rest args)
711 "Function called when a method call finds no primary method."
712 (signal 'cl-no-primary-method `(,(cl--generic-name generic) ,@args)))
714 (defun cl-call-next-method (&rest _args)
715 "Function to call the next applicable method.
716 Can only be used from within the lexical body of a primary or around method."
717 (error "cl-call-next-method only allowed inside primary and around methods"))
719 (defun cl-next-method-p ()
720 "Return non-nil if there is a next method.
721 Can only be used from within the lexical body of a primary or around method."
722 (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1"))
723 (error "cl-next-method-p only allowed inside primary and around methods"))
726 (defun cl-find-method (generic qualifiers specializers)
727 (car (cl--generic-member-method
728 specializers qualifiers
729 (cl--generic-method-table (cl--generic generic)))))
731 (defalias 'cl-method-qualifiers 'cl--generic-method-qualifiers)
733 ;;; Add support for describe-function
735 (defun cl--generic-search-method (met-name)
736 (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+"
737 (regexp-quote (format "%s" (car met-name)))
741 (concat base-re "[^&\"\n]*"
742 (mapconcat (lambda (specializer)
744 (format "%S" (if (consp specializer)
745 (nth 1 specializer) specializer))))
746 (remq t (cdr met-name))
747 "[ \t\n]*)[^&\"\n]*"))
749 (re-search-forward base-re nil t))))
752 (with-eval-after-load 'find-func
753 (defvar find-function-regexp-alist)
754 (add-to-list 'find-function-regexp-alist
755 `(cl-defmethod . ,#'cl--generic-search-method)))
757 (defun cl--generic-method-info (method)
758 (let* ((specializers (cl--generic-method-specializers method))
759 (qualifiers (cl--generic-method-qualifiers method))
760 (uses-cnm (cl--generic-method-uses-cnm method))
761 (function (cl--generic-method-function method))
762 (args (help-function-arglist function 'names))
763 (docstring (documentation function))
765 (if (null qualifiers) ""
766 (cl-assert (consp qualifiers))
767 (let ((s (prin1-to-string qualifiers)))
768 (concat (substring s 1 -1) " "))))
769 (doconly (if docstring
770 (let ((split (help-split-fundoc docstring nil)))
771 (if split (cdr split) docstring))))
773 (if uses-cnm (setq args (cdr args)))
774 (dolist (specializer specializers)
775 (let ((arg (if (eq '&rest (car args))
776 (intern (format "arg%d" (length combined-args)))
778 (push (if (eq specializer t) arg (list arg specializer))
780 (setq combined-args (append (nreverse combined-args) args))
781 (list qual-string combined-args doconly)))
783 (add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
784 (defun cl--generic-describe (function)
785 (let ((generic (if (symbolp function) (cl--generic function))))
787 (require 'help-mode) ;Needed for `help-function-def' button!
789 (insert "\n\nThis is a generic function.\n\n")
790 (insert (propertize "Implementations:\n\n" 'face 'bold))
791 ;; Loop over fanciful generics
792 (dolist (method (cl--generic-method-table generic))
793 (let* ((info (cl--generic-method-info method)))
794 ;; FIXME: Add hyperlinks for the types as well.
795 (insert (format "%s%S" (nth 0 info) (nth 1 info)))
796 (let* ((met-name (cons function
797 (cl--generic-method-specializers method)))
798 (file (find-lisp-object-file-name met-name 'cl-defmethod)))
801 (help-insert-xref-button (help-fns-short-filename file)
802 'help-function-def met-name file
805 (insert "\n" (or (nth 2 info) "Undocumented") "\n\n")))))))
807 ;;; Support for (head <val>) specializers.
809 ;; For both the `eql' and the `head' specializers, the dispatch
810 ;; is unsatisfactory. Basically, in the "common&fast case", we end up doing
812 ;; (let ((tag (gethash value <tagcode-hashtable>)))
813 ;; (funcall (gethash tag <method-cache>)))
815 ;; whereas we'd like to just do
817 ;; (funcall (gethash value <method-cache>)))
819 ;; but the problem is that the method-cache is normally "open ended", so
820 ;; a nil means "not computed yet" and if we bump into it, we dutifully fill the
821 ;; corresponding entry, whereas we'd want to just fallback on some default
822 ;; effective method (so as not to fill the cache with lots of redundant
825 (defvar cl--generic-head-used (make-hash-table :test #'eql))
827 (defconst cl--generic-head-generalizer
828 (cl-generic-make-generalizer
829 80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used))
830 (lambda (tag) (if (eq (car-safe tag) 'head) (list tag)))))
832 (cl-defmethod cl-generic-generalizers :extra "head" (specializer)
833 "Support for the `(head VAL)' specializers."
834 ;; We have to implement `head' here using the :extra qualifier,
835 ;; since we can't use the `head' specializer to implement itself.
836 (if (not (eq (car-safe specializer) 'head))
837 (cl-call-next-method)
838 (cl--generic-with-memoization
839 (gethash (cadr specializer) cl--generic-head-used) specializer)
840 (list cl--generic-head-generalizer)))
842 ;;; Support for (eql <val>) specializers.
844 (defvar cl--generic-eql-used (make-hash-table :test #'eql))
846 (defconst cl--generic-eql-generalizer
847 (cl-generic-make-generalizer
848 100 (lambda (name) `(gethash ,name cl--generic-eql-used))
849 (lambda (tag) (if (eq (car-safe tag) 'eql) (list tag)))))
851 (cl-defmethod cl-generic-generalizers ((specializer (head eql)))
852 "Support for the `(eql VAL)' specializers."
853 (puthash (cadr specializer) specializer cl--generic-eql-used)
854 (list cl--generic-eql-generalizer))
856 ;;; Support for cl-defstructs specializers.
858 (defun cl--generic-struct-tag (name)
859 `(and (vectorp ,name)
861 (let ((tag (aref ,name 0)))
862 (if (eq (symbol-function tag) :quick-object-witness-check)
865 (defun cl--generic-struct-specializers (tag)
867 ;; A method call shouldn't itself mess with the match-data.
868 (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag))
869 (let ((types (list (intern (substring (symbol-name tag) 10)))))
870 (while (get (car types) 'cl-struct-include)
871 (push (get (car types) 'cl-struct-include) types))
872 (push 'cl-structure-object types) ;The "parent type" of all cl-structs.
875 (defconst cl--generic-struct-generalizer
876 (cl-generic-make-generalizer
877 50 #'cl--generic-struct-tag
878 #'cl--generic-struct-specializers))
880 (cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
881 "Support for dispatch on cl-struct types."
884 (get type 'cl-struct-type)
885 (or (null (car (get type 'cl-struct-type)))
886 (error "Can't dispatch on cl-struct %S: type is %S"
887 type (car (get type 'cl-struct-type))))
888 (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots)))
889 (error "Can't dispatch on cl-struct %S: no tag in slot 0"
891 ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
892 ;; but that would suffer from some problems:
893 ;; - the vector may have size 0.
894 ;; - when called on an actual vector (rather than an object), we'd
895 ;; end up returning an arbitrary value, possibly colliding with
896 ;; other tagcode's values.
897 ;; - it can also result in returning all kinds of irrelevant
898 ;; values which would end up filling up the method-cache with
899 ;; lots of irrelevant/redundant entries.
900 ;; FIXME: We could speed this up by introducing a dedicated
901 ;; vector type at the C level, so we could do something like
902 ;; (and (vector-objectp ,name) (aref ,name 0))
903 (list cl--generic-struct-generalizer))
904 (cl-call-next-method)))
906 ;;; Dispatch on "system types".
908 (defconst cl--generic-typeof-types
909 ;; Hand made from the source code of `type-of'.
910 '((integer number) (symbol) (string array sequence) (cons list sequence)
911 ;; Markers aren't `numberp', yet they are accepted wherever integers are
912 ;; accepted, pretty much.
913 (marker) (overlay) (float number) (window-configuration)
914 (process) (window) (subr) (compiled-function) (buffer)
915 (char-table array sequence)
916 (bool-vector array sequence)
917 (frame) (hash-table) (font-spec) (font-entity) (font-object)
918 (vector array sequence)
920 (null symbol list sequence)
926 (defconst cl--generic-typeof-generalizer
927 (cl-generic-make-generalizer
928 ;; FIXME: We could also change `type-of' to return `null' for nil.
929 10 (lambda (name) `(if ,name (type-of ,name) 'null))
930 (lambda (tag) (and (symbolp tag) (assq tag cl--generic-typeof-types)))))
932 (cl-defmethod cl-generic-generalizers :extra "typeof" (type)
933 "Support for dispatch on builtin types."
934 ;; FIXME: Add support for other types accepted by `cl-typep' such
935 ;; as `character', `atom', `face', `function', ...
937 (and (assq type cl--generic-typeof-types)
939 (if (memq type '(vector array sequence))
940 (message "`%S' also matches CL structs and EIEIO classes" type))
941 (list cl--generic-typeof-generalizer)))
942 (cl-call-next-method)))
944 ;;; Just for kicks: dispatch on major-mode
946 ;; Here's how you'd use it:
947 ;; (cl-defmethod foo ((x (major-mode text-mode)) y z) ...)
949 ;; (foo 'major-mode toto titi)
951 ;; FIXME: Better would be to do that via dispatch on an "implicit argument".
952 ;; E.g. (cl-defmethod foo (y z &context (major-mode text-mode)) ...)
954 ;; (defvar cl--generic-major-modes (make-hash-table :test #'eq))
956 ;; (add-function :before-until cl-generic-generalizer-function
957 ;; #'cl--generic-major-mode-tagcode)
958 ;; (defun cl--generic-major-mode-tagcode (type name)
959 ;; (if (eq 'major-mode (car-safe type))
960 ;; `(50 . (if (eq ,name 'major-mode)
961 ;; (cl--generic-with-memoization
962 ;; (gethash major-mode cl--generic-major-modes)
963 ;; `(cl--generic-major-mode . ,major-mode))))))
965 ;; (add-function :before-until cl-generic-tag-types-function
966 ;; #'cl--generic-major-mode-types)
967 ;; (defun cl--generic-major-mode-types (tag)
968 ;; (when (eq (car-safe tag) 'cl--generic-major-mode)
969 ;; (if (eq tag 'fundamental-mode) '(fundamental-mode t)
970 ;; (let ((types `((major-mode ,(cdr tag)))))
971 ;; (while (get (car types) 'derived-mode-parent)
972 ;; (push (list 'major-mode (get (car types) 'derived-mode-parent))
974 ;; (unless (eq 'fundamental-mode (car types))
975 ;; (push '(major-mode fundamental-mode) types))
976 ;; (nreverse types)))))
979 ;; generated-autoload-file: "cl-loaddefs.el"
982 (provide 'cl-generic)
983 ;;; cl-generic.el ends here