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 (unless (fboundp name
)
241 ;; If the generic function was fmakunbound, throw away previous methods.
242 (setf (cl--generic-dispatches generic
) nil
)
243 (setf (cl--generic-method-table generic
) nil
))
245 (dolist (arg (cdr apo
))
246 (let ((pos (memq arg mandatory
)))
247 (unless pos
(error "%S is not a mandatory argument" arg
))
248 (let* ((argno (- (length mandatory
) (length pos
)))
249 (dispatches (cl--generic-dispatches generic
))
250 (dispatch (or (assq argno dispatches
) (list argno
))))
251 (setf (cl--generic-dispatches generic
)
252 (cons dispatch
(delq dispatch dispatches
)))))))
253 (setf (cl--generic-options generic
) options
)
254 (cl--generic-make-function generic
)))
256 (defmacro cl-generic-current-method-specializers
()
257 "List of (VAR . TYPE) where TYPE is var's specializer.
258 This macro can only be used within the lexical scope of a cl-generic method."
259 (error "cl-generic-current-method-specializers used outside of a method"))
261 (eval-and-compile ;Needed while compiling the cl-defmethod calls below!
262 (defun cl--generic-fgrep (vars sexp
) ;Copied from pcase.el.
263 "Check which of the symbols VARS appear in SEXP."
266 (dolist (var (cl--generic-fgrep vars
(pop sexp
)))
267 (unless (memq var res
) (push var res
))))
268 (and (memq sexp vars
) (not (memq sexp res
)) (push sexp res
))
271 (defun cl--generic-split-args (args)
272 "Return (SPEC-ARGS . PLAIN-ARGS)."
273 (let ((plain-args ())
278 ((or '&optional
'&rest
'&key
) (setq mandatory nil
) arg
)
281 (error "&context not immediately after mandatory args"))
282 (setq mandatory
'context
) nil
)
283 ((let 'nil mandatory
) arg
)
284 ((let 'context mandatory
)
286 (error "Invalid &context arg: %S" arg
))
287 (push `((&context .
,(car arg
)) .
,(cadr arg
)) specializers
)
290 (push (cons name
(car type
)) specializers
)
293 (push (cons arg t
) specializers
)
296 (cons (nreverse specializers
)
297 (nreverse (delq nil plain-args
)))))
299 (defun cl--generic-lambda (args body
)
300 "Make the lambda expression for a method with ARGS and BODY."
301 (pcase-let* ((`(,spec-args .
,plain-args
)
302 (cl--generic-split-args args
))
303 (fun `(cl-function (lambda ,plain-args
,@body
)))
304 (macroenv (cons `(cl-generic-current-method-specializers
305 .
,(lambda () spec-args
))
306 macroexpand-all-environment
)))
307 (require 'cl-lib
) ;Needed to expand `cl-flet' and `cl-function'.
308 ;; First macroexpand away the cl-function stuff (e.g. &key and
309 ;; destructuring args, `declare' and whatnot).
310 (pcase (macroexpand fun macroenv
)
311 (`#'(lambda ,args .
,body
)
312 (let* ((parsed-body (macroexp-parse-body body
))
313 (cnm (make-symbol "cl--cnm"))
314 (nmp (make-symbol "cl--nmp"))
315 (nbody (macroexpand-all
316 `(cl-flet ((cl-call-next-method ,cnm
)
317 (cl-next-method-p ,nmp
))
320 ;; FIXME: Rather than `grep' after the fact, the
321 ;; macroexpansion should directly set some flag when cnm
323 ;; FIXME: Also, optimize the case where call-next-method is
324 ;; only called with explicit arguments.
325 (uses-cnm (cl--generic-fgrep (list cnm nmp
) nbody
)))
326 (cons (not (not uses-cnm
))
327 `#'(lambda (,@(if uses-cnm
(list cnm
)) ,@args
)
329 ,(if (not (memq nmp uses-cnm
))
331 `(let ((,nmp
(lambda ()
332 (cl--generic-isnot-nnm-p ,cnm
))))
334 (f (error "Unexpected macroexpansion result: %S" f
))))))
338 (defmacro cl-defmethod
(name args
&rest body
)
339 "Define a new method for generic function NAME.
340 I.e. it defines the implementation of NAME to use for invocations where the
341 value of the dispatch argument matches the specified TYPE.
342 The dispatch argument has to be one of the mandatory arguments, and
343 all methods of NAME have to use the same argument for dispatch.
344 The dispatch argument and TYPE are specified in ARGS where the corresponding
345 formal argument appears as (VAR TYPE) rather than just VAR.
347 The optional second argument QUALIFIER is a specifier that
348 modifies how the method is combined with other methods, including:
349 :before - Method will be called before the primary
350 :after - Method will be called after the primary
351 :around - Method will be called around everything else
352 The absence of QUALIFIER means this is a \"primary\" method.
354 Other than a type, TYPE can also be of the form `(eql VAL)' in
355 which case this method will be invoked when the argument is `eql' to VAL.
357 \(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
358 (declare (doc-string 3) (indent 2)
360 (&define
; this means we are defining something
361 [&or name
("setf" :name setf name
)]
362 ;; ^^ This is the methods symbol
363 [ &optional keywordp
] ; this is key :before etc
365 [ &optional stringp
] ; documentation string
366 def-body
))) ; part to be debugged
367 (let ((qualifiers nil
)
368 (setfizer (if (eq 'setf
(car-safe name
))
369 ;; Call it before we call cl--generic-lambda.
370 (cl--generic-setf-rewrite (cadr name
)))))
371 (while (not (listp args
))
372 (push args qualifiers
)
373 (setq args
(pop body
)))
374 (pcase-let* ((`(,uses-cnm .
,fun
) (cl--generic-lambda args body
)))
377 (setq name
(car setfizer
))
379 ,(and (get name
'byte-obsolete-info
)
380 (or (not (fboundp 'byte-compile-warning-enabled-p
))
381 (byte-compile-warning-enabled-p 'obsolete
))
382 (let* ((obsolete (get name
'byte-obsolete-info
)))
383 (macroexp--warn-and-return
384 (macroexp--obsolete-warning name obsolete
"generic function")
386 ;; You could argue that `defmethod' modifies rather than defines the
387 ;; function, so warnings like "not known to be defined" are fair game.
388 ;; But in practice, it's common to use `cl-defmethod'
389 ;; without a previous `cl-defgeneric'.
390 (declare-function ,name
"")
391 (cl-generic-define-method ',name
',(nreverse qualifiers
) ',args
394 (defun cl--generic-member-method (specializers qualifiers methods
)
397 (let ((m (car methods
)))
398 (not (and (equal (cl--generic-method-specializers m
) specializers
)
399 (equal (cl--generic-method-qualifiers m
) qualifiers
)))))
400 (setq methods
(cdr methods
)))
404 (defun cl-generic-define-method (name qualifiers args uses-cnm function
)
406 ((generic (cl-generic-ensure-function name
))
407 (`(,spec-args .
,_
) (cl--generic-split-args args
))
408 (specializers (mapcar (lambda (spec-arg)
409 (if (eq '&context
(car-safe (car spec-arg
)))
410 spec-arg
(cdr spec-arg
)))
412 (method (cl--generic-make-method
413 specializers qualifiers uses-cnm function
))
414 (mt (cl--generic-method-table generic
))
415 (me (cl--generic-member-method specializers qualifiers mt
))
416 (dispatches (cl--generic-dispatches generic
))
418 (dolist (spec-arg spec-args
)
419 (let* ((key (if (eq '&context
(car-safe (car spec-arg
)))
421 (generalizers (cl-generic-generalizers (cdr spec-arg
)))
422 (x (assoc key dispatches
)))
424 (setq x
(cons key
(cl-generic-generalizers t
)))
425 (setf (cl--generic-dispatches generic
)
426 (setq dispatches
(cons x dispatches
))))
427 (dolist (generalizer generalizers
)
428 (unless (member generalizer
(cdr x
))
430 (sort (cons generalizer
(cdr x
))
432 (> (cl--generic-generalizer-priority x
)
433 (cl--generic-generalizer-priority y
)))))))
435 ;; We used to (setcar me method), but that can cause false positives in
436 ;; the hash-consing table of the method-builder (bug#20644).
437 ;; See the related FIXME in cl--generic-build-combined-method.
438 (setf (cl--generic-method-table generic
) (cons method
(delq (car me
) mt
)))
439 (cl-pushnew `(cl-defmethod .
(,(cl--generic-name generic
) .
,specializers
))
440 current-load-list
:test
#'equal
)
441 ;; FIXME: Try to avoid re-constructing a new function if the old one
442 ;; is still valid (e.g. still empty method cache)?
443 (let ((gfun (cl--generic-make-function generic
))
444 ;; Prevent `defalias' from recording this as the definition site of
445 ;; the generic function.
447 ;; For aliases, cl--generic-name gives us the actual name.
449 ;; BEWARE! Don't purify this function definition, since that leads
450 ;; to memory corruption if the hash-tables it holds are modified
451 ;; (the GC doesn't trace those pointers).
453 ;; But do use `defalias', so that it interacts properly with nadvice,
454 ;; e.g. for tracing/debug-on-entry.
455 (defalias (cl--generic-name generic
) gfun
)))))
457 (defmacro cl--generic-with-memoization
(place &rest code
)
458 (declare (indent 1) (debug t
))
459 (gv-letplace (getter setter
) place
461 ,(macroexp-let2 nil val
(macroexp-progn code
)
463 ,(funcall setter val
)
466 (defvar cl--generic-dispatchers
(make-hash-table :test
#'equal
))
468 (defun cl--generic-get-dispatcher (dispatch)
469 (cl--generic-with-memoization
470 (gethash dispatch cl--generic-dispatchers
)
471 ;; (message "cl--generic-get-dispatcher (%S)" dispatch)
472 (let* ((dispatch-arg (car dispatch
))
473 (generalizers (cdr dispatch
))
476 (mapcar (lambda (generalizer)
477 (funcall (cl--generic-generalizer-tagcode-function
483 (lambda (generalizer)
484 `(funcall ',(cl--generic-generalizer-specializers-function
486 ,(funcall (cl--generic-generalizer-tagcode-function
491 ;; Minor optimization: since this tag-exp is
492 ;; only used to lookup the method-cache, it
493 ;; doesn't matter if the default value is some
495 `(or ,@(if (macroexp-const-p (car (last tagcodes
)))
499 (dispatch-idx dispatch-arg
)
501 (when (eq '&context
(car-safe dispatch-arg
))
502 (setq bindings
`((arg ,(cdr dispatch-arg
))))
504 (setq dispatch-idx
0))
505 (dotimes (i dispatch-idx
)
506 (push (make-symbol (format "arg%d" (- dispatch-idx i
1))) fixedargs
))
507 ;; FIXME: For generic functions with a single method (or with 2 methods,
508 ;; one of which always matches), using a tagcode + hash-table is
509 ;; overkill: better just use a `cl-typep' test.
511 `(lambda (generic dispatches-left methods
)
512 (let ((method-cache (make-hash-table :test
#'eql
)))
513 (lambda (,@fixedargs
&rest args
)
515 (apply (cl--generic-with-memoization
516 (gethash ,tag-exp method-cache
)
517 (cl--generic-cache-miss
518 generic
',dispatch-arg dispatches-left methods
519 ,(if (cdr typescodes
)
520 `(append ,@typescodes
) (car typescodes
))))
521 ,@fixedargs args
)))))))))
523 (defun cl--generic-make-function (generic)
524 (cl--generic-make-next-function generic
525 (cl--generic-dispatches generic
)
526 (cl--generic-method-table generic
)))
528 (defun cl--generic-make-next-function (generic dispatches methods
)
531 (while (and dispatches
532 (let ((x (nth 1 (car dispatches
))))
533 ;; No need to dispatch for t specializers.
534 (or (null x
) (equal x cl--generic-t-generalizer
))))
535 (setq dispatches
(cdr dispatches
)))
537 (if (not (and dispatch
538 ;; If there's no method left, there's no point checking
539 ;; further arguments.
541 (cl--generic-build-combined-method generic methods
)
542 (let ((dispatcher (cl--generic-get-dispatcher dispatch
)))
543 (funcall dispatcher generic dispatches methods
)))))
545 (defvar cl--generic-combined-method-memoization
546 (make-hash-table :test
#'equal
:weakness
'value
)
547 "Table storing previously built combined-methods.
548 This is particularly useful when many different tags select the same set
549 of methods, since this table then allows us to share a single combined-method
550 for all those different tags in the method-cache.")
552 (define-error 'cl--generic-cyclic-definition
"Cyclic definition: %S")
554 (defun cl--generic-build-combined-method (generic methods
)
556 ;; Special case needed to fix a circularity during bootstrap.
557 (cl--generic-standard-method-combination generic methods
)
559 (cl--generic-with-memoization
560 ;; FIXME: Since the fields of `generic' are modified, this
561 ;; hash-table won't work right, because the hashes will change!
562 ;; It's not terribly serious, but reduces the effectiveness of
564 (gethash (cons generic methods
)
565 cl--generic-combined-method-memoization
)
566 (puthash (cons generic methods
) :cl--generic--under-construction
567 cl--generic-combined-method-memoization
)
569 (cl-generic-combine-methods generic methods
)
570 ;; Special case needed to fix a circularity during bootstrap.
571 (cl--generic-cyclic-definition
572 (cl--generic-standard-method-combination generic methods
))))))
573 (if (eq f
:cl--generic--under-construction
)
574 (signal 'cl--generic-cyclic-definition
575 (list (cl--generic-name generic
)))
578 (defun cl--generic-no-next-method-function (generic method
)
580 (apply #'cl-no-next-method generic method args
)))
582 (defun cl-generic-call-method (generic method
&optional fun
)
583 "Return a function that calls METHOD.
584 FUN is the function that should be called when METHOD calls
586 (if (not (cl--generic-method-uses-cnm method
))
587 (cl--generic-method-function method
)
588 (let ((met-fun (cl--generic-method-function method
))
589 (next (or fun
(cl--generic-no-next-method-function
593 ;; FIXME: This sucks: passing just `next' would
594 ;; be a lot more efficient than the lambda+apply
595 ;; quasi-η, but we need this to implement the
596 ;; "if call-next-method is called with no
597 ;; arguments, then use the previous arguments".
598 (lambda (&rest cnm-args
)
599 (apply next
(or cnm-args args
)))
602 ;; Standard CLOS name.
603 (defalias 'cl-method-qualifiers
#'cl--generic-method-qualifiers
)
605 (defun cl--generic-standard-method-combination (generic methods
)
606 (let ((mets-by-qual ()))
607 (dolist (method methods
)
608 (let ((qualifiers (cl-method-qualifiers method
)))
609 (if (eq (car qualifiers
) :extra
) (setq qualifiers
(cddr qualifiers
)))
610 (unless (member qualifiers
'(() (:after
) (:before
) (:around
)))
611 (error "Unsupported qualifiers in function %S: %S"
612 (cl--generic-name generic
) qualifiers
))
613 (push method
(alist-get (car qualifiers
) mets-by-qual
))))
617 (apply #'cl-no-applicable-method generic args
)))
618 ((null (alist-get nil mets-by-qual
))
620 (apply #'cl-no-primary-method generic args
)))
623 (ab-call (lambda (m) (cl-generic-call-method generic m
)))
625 (mapcar ab-call
(reverse (cdr (assoc :before mets-by-qual
)))))
626 (after (mapcar ab-call
(cdr (assoc :after mets-by-qual
)))))
627 (dolist (method (cdr (assoc nil mets-by-qual
)))
628 (setq fun
(cl-generic-call-method generic method fun
)))
629 (when (or after before
)
631 (setq fun
(lambda (&rest args
)
637 (apply af args
)))))))
638 (dolist (method (cdr (assoc :around mets-by-qual
)))
639 (setq fun
(cl-generic-call-method generic method fun
)))
642 (defun cl--generic-cache-miss (generic
643 dispatch-arg dispatches-left methods-left types
)
645 (dolist (method methods-left
)
646 (let* ((specializer (or (if (integerp dispatch-arg
)
648 (cl--generic-method-specializers method
))
649 (cdr (assoc dispatch-arg
650 (cl--generic-method-specializers method
))))
652 (m (member specializer types
)))
654 (push (cons (length m
) method
) methods
))))
655 ;; Sort the methods, most specific first.
656 ;; It would be tempting to sort them once and for all in the method-table
657 ;; rather than here, but the order might depend on the actual argument
658 ;; (e.g. for multiple inheritance with defclass).
659 (setq methods
(nreverse (mapcar #'cdr
(sort methods
#'car-less-than-car
))))
660 (cl--generic-make-next-function generic dispatches-left methods
)))
662 (cl-defgeneric cl-generic-generalizers
(specializer)
663 "Return a list of generalizers for a given SPECIALIZER.
664 To each kind of `specializer', corresponds a `generalizer' which describes
665 how to extract a \"tag\" from an object which will then let us check if this
666 object matches the specializer. A typical example of a \"tag\" would be the
667 type of an object. It's called a `generalizer' because it
668 takes a specific object and returns a more general approximation,
669 denoting a set of objects to which it belongs.
670 A generalizer gives us the chunk of code which the
671 dispatch function needs to use to extract the \"tag\" of an object, as well
672 as a function which turns this tag into an ordered list of
673 `specializers' that this object matches.
674 The code which extracts the tag should be as fast as possible.
675 The tags should be chosen according to the following rules:
676 - The tags should not be too specific: similar objects which match the
677 same list of specializers should ideally use the same (`eql') tag.
678 This insures that the cached computation of the applicable
679 methods for one object can be reused for other objects.
680 - Corollary: objects which don't match any of the relevant specializers
681 should ideally all use the same tag (typically nil).
682 This insures that this cache does not grow unnecessarily large.
683 - Two different generalizers G1 and G2 should not use the same tag
684 unless they use it for the same set of objects. IOW, if G1.tag(X1) =
685 G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2).
686 - If G1.priority > G2.priority and G1.tag(X1) = G1.tag(X2) and this tag is
687 non-nil, then you have to make sure that the G2.tag(X1) = G2.tag(X2).
688 This is because the method-cache is only indexed with the first non-nil
689 tag (by order of decreasing priority).")
692 (cl-defgeneric cl-generic-combine-methods
(generic methods
)
693 "Build the effective method made of METHODS.
694 It should return a function that expects the same arguments as the methods, and
695 calls those methods in some appropriate order.
696 GENERIC is the generic function (mostly used for its name).
697 METHODS is the list of the selected methods.
698 The METHODS list is sorted from most specific first to most generic last.
699 The function can use `cl-generic-call-method' to create functions that call those
702 ;; Temporary definition to let the next defmethod succeed.
703 (fset 'cl-generic-generalizers
704 (lambda (_specializer) (list cl--generic-t-generalizer
)))
705 (fset 'cl-generic-combine-methods
706 #'cl--generic-standard-method-combination
)
708 (cl-defmethod cl-generic-generalizers (specializer)
709 "Support for the catch-all t specializer."
710 (if (eq specializer t
) (list cl--generic-t-generalizer
)
711 (error "Unknown specializer %S" specializer
)))
714 ;; This macro is brittle and only really important in order to be
715 ;; able to preload cl-generic without also preloading the byte-compiler,
716 ;; So we use `eval-when-compile' so as not keep it available longer than
718 (defmacro cl--generic-prefill-dispatchers
(arg-or-context specializer
)
719 (unless (integerp arg-or-context
)
720 (setq arg-or-context
`(&context .
,arg-or-context
)))
721 (unless (fboundp 'cl--generic-get-dispatcher
)
722 (require 'cl-generic
))
723 (let ((fun (cl--generic-get-dispatcher
724 `(,arg-or-context
,@(cl-generic-generalizers specializer
)
725 ,cl--generic-t-generalizer
))))
726 ;; Recompute dispatch at run-time, since the generalizers may be slightly
727 ;; different (e.g. byte-compiled rather than interpreted).
728 ;; FIXME: There is a risk that the run-time generalizer is not equivalent
729 ;; to the compile-time one, in which case `fun' may not be correct
731 `(let ((dispatch `(,',arg-or-context
732 ,@(cl-generic-generalizers ',specializer
)
733 ,cl--generic-t-generalizer
)))
734 ;; (message "Prefilling for %S with \n%S" dispatch ',fun)
735 (puthash dispatch
',fun cl--generic-dispatchers
)))))
737 (cl-defmethod cl-generic-combine-methods (generic methods
)
738 "Standard support for :after, :before, :around, and `:extra NAME' qualifiers."
739 (cl--generic-standard-method-combination generic methods
))
741 (defconst cl--generic-nnm-sample
(cl--generic-no-next-method-function t t
))
742 (defconst cl--generic-cnm-sample
743 (funcall (cl--generic-build-combined-method
744 nil
(list (cl--generic-make-method () () t
#'identity
)))))
746 (defun cl--generic-isnot-nnm-p (cnm)
747 "Return non-nil if CNM is the function that calls `cl-no-next-method'."
748 ;; ¡Big Gross Ugly Hack!
749 ;; `next-method-p' just sucks, we should let it die. But EIEIO did support
750 ;; it, and some packages use it, so we need to support it.
752 (cl-assert (function-equal cnm cl--generic-cnm-sample
))
753 (if (byte-code-function-p cnm
)
754 (let ((cnm-constants (aref cnm
2))
755 (sample-constants (aref cl--generic-cnm-sample
2)))
756 (dotimes (i (length sample-constants
))
757 (when (function-equal (aref sample-constants i
)
758 cl--generic-nnm-sample
)
760 (not (function-equal (aref cnm-constants i
)
761 cl--generic-nnm-sample
))))))
762 (cl-assert (eq 'closure
(car-safe cl--generic-cnm-sample
)))
763 (let ((cnm-env (cadr cnm
)))
764 (dolist (vb (cadr cl--generic-cnm-sample
))
765 (when (function-equal (cdr vb
) cl--generic-nnm-sample
)
767 (not (function-equal (cdar cnm-env
)
768 cl--generic-nnm-sample
))))
769 (setq cnm-env
(cdr cnm-env
)))))
770 (error "Haven't found no-next-method-sample in cnm-sample")))
772 ;;; Define some pre-defined generic functions, used internally.
774 (define-error 'cl-no-method
"No method for %S")
775 (define-error 'cl-no-next-method
"No next method for %S" 'cl-no-method
)
776 (define-error 'cl-no-primary-method
"No primary method for %S" 'cl-no-method
)
777 (define-error 'cl-no-applicable-method
"No applicable method for %S"
780 (cl-defgeneric cl-no-next-method
(generic method
&rest args
)
781 "Function called when `cl-call-next-method' finds no next method."
782 (signal 'cl-no-next-method
`(,(cl--generic-name generic
) ,method
,@args
)))
784 (cl-defgeneric cl-no-applicable-method
(generic &rest args
)
785 "Function called when a method call finds no applicable method."
786 (signal 'cl-no-applicable-method
`(,(cl--generic-name generic
) ,@args
)))
788 (cl-defgeneric cl-no-primary-method
(generic &rest args
)
789 "Function called when a method call finds no primary method."
790 (signal 'cl-no-primary-method
`(,(cl--generic-name generic
) ,@args
)))
792 (defun cl-call-next-method (&rest _args
)
793 "Function to call the next applicable method.
794 Can only be used from within the lexical body of a primary or around method."
795 (error "cl-call-next-method only allowed inside primary and around methods"))
797 (defun cl-next-method-p ()
798 "Return non-nil if there is a next method.
799 Can only be used from within the lexical body of a primary or around method."
800 (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1"))
801 (error "cl-next-method-p only allowed inside primary and around methods"))
804 (defun cl-find-method (generic qualifiers specializers
)
805 (car (cl--generic-member-method
806 specializers qualifiers
807 (cl--generic-method-table (cl--generic generic
)))))
809 ;;; Add support for describe-function
811 (defun cl--generic-search-method (met-name)
812 (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+"
813 (regexp-quote (format "%s" (car met-name
)))
817 (concat base-re
"[^&\"\n]*"
818 (mapconcat (lambda (specializer)
820 (format "%S" (if (consp specializer
)
821 (nth 1 specializer
) specializer
))))
822 (remq t
(cdr met-name
))
823 "[ \t\n]*)[^&\"\n]*"))
825 (re-search-forward base-re nil t
))))
828 (with-eval-after-load 'find-func
829 (defvar find-function-regexp-alist
)
830 (add-to-list 'find-function-regexp-alist
831 `(cl-defmethod .
,#'cl--generic-search-method
)))
833 (defun cl--generic-method-info (method)
834 (let* ((specializers (cl--generic-method-specializers method
))
835 (qualifiers (cl--generic-method-qualifiers method
))
836 (uses-cnm (cl--generic-method-uses-cnm method
))
837 (function (cl--generic-method-function method
))
838 (args (help-function-arglist function
'names
))
839 (docstring (documentation function
))
841 (if (null qualifiers
) ""
842 (cl-assert (consp qualifiers
))
843 (let ((s (prin1-to-string qualifiers
)))
844 (concat (substring s
1 -
1) " "))))
845 (doconly (if docstring
846 (let ((split (help-split-fundoc docstring nil
)))
847 (if split
(cdr split
) docstring
))))
849 (if uses-cnm
(setq args
(cdr args
)))
850 (dolist (specializer specializers
)
851 (let ((arg (if (eq '&rest
(car args
))
852 (intern (format "arg%d" (length combined-args
)))
854 (push (if (eq specializer t
) arg
(list arg specializer
))
856 (setq combined-args
(append (nreverse combined-args
) args
))
857 (list qual-string combined-args doconly
)))
859 (add-hook 'help-fns-describe-function-functions
#'cl--generic-describe
)
860 (defun cl--generic-describe (function)
861 ;; Supposedly this is called from help-fns, so help-fns should be loaded at
863 (declare-function help-fns-short-filename
"help-fns" (filename))
864 (let ((generic (if (symbolp function
) (cl--generic function
))))
866 (require 'help-mode
) ;Needed for `help-function-def' button!
868 (insert "\n\nThis is a generic function.\n\n")
869 (insert (propertize "Implementations:\n\n" 'face
'bold
))
870 ;; Loop over fanciful generics
871 (dolist (method (cl--generic-method-table generic
))
872 (let* ((info (cl--generic-method-info method
)))
873 ;; FIXME: Add hyperlinks for the types as well.
874 (insert (format "%s%S" (nth 0 info
) (nth 1 info
)))
875 (let* ((met-name (cons function
876 (cl--generic-method-specializers method
)))
877 (file (find-lisp-object-file-name met-name
'cl-defmethod
)))
879 (insert (substitute-command-keys " in ‘"))
880 (help-insert-xref-button (help-fns-short-filename file
)
881 'help-function-def met-name file
883 (insert (substitute-command-keys "’.\n"))))
884 (insert "\n" (or (nth 2 info
) "Undocumented") "\n\n")))))))
886 ;;; Support for (head <val>) specializers.
888 ;; For both the `eql' and the `head' specializers, the dispatch
889 ;; is unsatisfactory. Basically, in the "common&fast case", we end up doing
891 ;; (let ((tag (gethash value <tagcode-hashtable>)))
892 ;; (funcall (gethash tag <method-cache>)))
894 ;; whereas we'd like to just do
896 ;; (funcall (gethash value <method-cache>)))
898 ;; but the problem is that the method-cache is normally "open ended", so
899 ;; a nil means "not computed yet" and if we bump into it, we dutifully fill the
900 ;; corresponding entry, whereas we'd want to just fallback on some default
901 ;; effective method (so as not to fill the cache with lots of redundant
904 (defvar cl--generic-head-used
(make-hash-table :test
#'eql
))
906 (defconst cl--generic-head-generalizer
907 (cl-generic-make-generalizer
908 80 (lambda (name) `(gethash (car-safe ,name
) cl--generic-head-used
))
909 (lambda (tag) (if (eq (car-safe tag
) 'head
) (list tag
)))))
911 (cl-defmethod cl-generic-generalizers :extra
"head" (specializer)
912 "Support for the `(head VAL)' specializers."
913 ;; We have to implement `head' here using the :extra qualifier,
914 ;; since we can't use the `head' specializer to implement itself.
915 (if (not (eq (car-safe specializer
) 'head
))
916 (cl-call-next-method)
917 (cl--generic-with-memoization
918 (gethash (cadr specializer
) cl--generic-head-used
) specializer
)
919 (list cl--generic-head-generalizer
)))
921 (cl--generic-prefill-dispatchers 0 (head eql
))
923 ;;; Support for (eql <val>) specializers.
925 (defvar cl--generic-eql-used
(make-hash-table :test
#'eql
))
927 (defconst cl--generic-eql-generalizer
928 (cl-generic-make-generalizer
929 100 (lambda (name) `(gethash ,name cl--generic-eql-used
))
930 (lambda (tag) (if (eq (car-safe tag
) 'eql
) (list tag
)))))
932 (cl-defmethod cl-generic-generalizers ((specializer (head eql
)))
933 "Support for the `(eql VAL)' specializers."
934 (puthash (cadr specializer
) specializer cl--generic-eql-used
)
935 (list cl--generic-eql-generalizer
))
937 (cl--generic-prefill-dispatchers 0 (eql nil
))
938 (cl--generic-prefill-dispatchers window-system
(eql nil
))
940 ;;; Support for cl-defstructs specializers.
942 (defun cl--generic-struct-tag (name)
943 ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
944 ;; but that would suffer from some problems:
945 ;; - the vector may have size 0.
946 ;; - when called on an actual vector (rather than an object), we'd
947 ;; end up returning an arbitrary value, possibly colliding with
948 ;; other tagcode's values.
949 ;; - it can also result in returning all kinds of irrelevant
950 ;; values which would end up filling up the method-cache with
951 ;; lots of irrelevant/redundant entries.
952 ;; FIXME: We could speed this up by introducing a dedicated
953 ;; vector type at the C level, so we could do something like
954 ;; (and (vector-objectp ,name) (aref ,name 0))
955 `(and (vectorp ,name
)
957 (let ((tag (aref ,name
0)))
958 (if (eq (symbol-function tag
) :quick-object-witness-check
)
961 (defun cl--generic-struct-specializers (tag)
962 (and (symbolp tag
) (boundp tag
)
963 (let ((class (symbol-value tag
)))
964 (when (cl-typep class
'cl-structure-class
)
966 (classes (list class
)))
968 (while (let ((class (pop classes
)))
969 (push (cl--class-name class
) types
)
972 (cl--class-parents class
)))))
973 (nreverse types
))))))
975 (defconst cl--generic-struct-generalizer
976 (cl-generic-make-generalizer
977 50 #'cl--generic-struct-tag
978 #'cl--generic-struct-specializers
))
980 (cl-defmethod cl-generic-generalizers :extra
"cl-struct" (type)
981 "Support for dispatch on cl-struct types."
984 ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
985 ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
986 ;; take place without requiring cl-lib.
987 (let ((class (cl--find-class type
)))
988 (and (cl-typep class
'cl-structure-class
)
989 (or (null (cl--struct-class-type class
))
990 (error "Can't dispatch on cl-struct %S: type is %S"
991 type
(cl--struct-class-type class
)))
992 (progn (cl-assert (null (cl--struct-class-named class
))) t
)
993 (list cl--generic-struct-generalizer
))))
994 (cl-call-next-method)))
996 (cl--generic-prefill-dispatchers 0 cl--generic-generalizer
)
998 ;;; Dispatch on "system types".
1000 (defconst cl--generic-typeof-types
1001 ;; Hand made from the source code of `type-of'.
1002 '((integer number
) (symbol) (string array sequence
) (cons list sequence
)
1003 ;; Markers aren't `numberp', yet they are accepted wherever integers are
1004 ;; accepted, pretty much.
1005 (marker) (overlay) (float number
) (window-configuration)
1006 (process) (window) (subr) (compiled-function) (buffer)
1007 (char-table array sequence
)
1008 (bool-vector array sequence
)
1009 (frame) (hash-table) (font-spec) (font-entity) (font-object)
1010 (vector array sequence
)
1012 (null symbol list sequence
)
1018 (defconst cl--generic-typeof-generalizer
1019 (cl-generic-make-generalizer
1020 ;; FIXME: We could also change `type-of' to return `null' for nil.
1021 10 (lambda (name) `(if ,name
(type-of ,name
) 'null
))
1022 (lambda (tag) (and (symbolp tag
) (assq tag cl--generic-typeof-types
)))))
1024 (cl-defmethod cl-generic-generalizers :extra
"typeof" (type)
1025 "Support for dispatch on builtin types."
1026 ;; FIXME: Add support for other types accepted by `cl-typep' such
1027 ;; as `character', `atom', `face', `function', ...
1029 (and (assq type cl--generic-typeof-types
)
1031 (if (memq type
'(vector array sequence
))
1032 (message "`%S' also matches CL structs and EIEIO classes" type
))
1033 (list cl--generic-typeof-generalizer
)))
1034 (cl-call-next-method)))
1036 (cl--generic-prefill-dispatchers 0 integer
)
1039 ;; generated-autoload-file: "cl-loaddefs.el"
1042 (provide 'cl-generic
)
1043 ;;; cl-generic.el ends here