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 next-method-p, make-method, call-method,
30 ;; define-method-combination.
31 ;; - Method and generic function objects: CLOS defines methods as objects
32 ;; (same for generic functions), whereas we don't offer such an abstraction.
33 ;; - `no-next-method' should receive the "calling method" object, but since we
34 ;; don't have such a thing, we pass nil instead.
35 ;; - In defgeneric we don't support the options:
36 ;; declare, :method-combination, :generic-function-class, :method-class,
39 ;; - We support aliases to generic functions.
40 ;; - The kind of thing on which to dispatch can be extended.
41 ;; There is support in this file for (eql <val>) dispatch as well as dispatch
42 ;; on the type of CL structs, and eieio-core.el adds support for EIEIO
47 ;; Note: For generic functions that dispatch on several arguments (i.e. those
48 ;; which use the multiple-dispatch feature), we always use the same "tagcodes"
49 ;; and the same set of arguments on which to dispatch. This works, but is
50 ;; often suboptimal since after one dispatch, the remaining dispatches can
51 ;; usually be simplified, or even completely skipped.
53 (eval-when-compile (require 'cl-lib))
54 (eval-when-compile (require 'pcase))
56 (defvar cl-generic-tagcode-function
58 (if (eq type t) '(0 . 'cl--generic-type)
59 (error "Unknown specializer %S" type)))
60 "Function to get the Elisp code to extract the tag on which we dispatch.
61 Takes a \"parameter-specializer-name\" and a variable name, and returns
62 a pair (PRIORITY . CODE) where CODE is an Elisp expression that should be
63 used to extract the \"tag\" (from the object held in the named variable)
64 that should uniquely determine if we have a match
65 \(i.e. the \"tag\" is the value that will be used to dispatch to the proper
67 Such \"tagcodes\" will be or'd together.
68 PRIORITY is an integer from 0 to 100 which is used to sort the tagcodes
69 in the `or'. The higher the priority, the more specific the tag should be.
70 More specifically, if PRIORITY is N and we have two objects X and Y
71 whose tag (according to TAGCODE) is `eql', then it should be the case
72 that for all other (PRIORITY . TAGCODE) where PRIORITY ≤ N, then
73 \(eval TAGCODE) for X is `eql' to (eval TAGCODE) for Y.")
75 (defvar cl-generic-tag-types-function
76 (lambda (tag) (if (eq tag 'cl--generic-type) '(t)))
77 "Function to get the list of types that a given \"tag\" matches.
78 They should be sorted from most specific to least specific.")
80 (cl-defstruct (cl--generic
82 (:constructor cl--generic-make
83 (name &optional dispatches method-table))
85 (name nil :read-only t) ;Pointer back to the symbol.
86 ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
87 ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
88 ;; where the EXPs are expressions (to be `or'd together) to compute the tag
89 ;; on which to dispatch and PRIORITY is the priority of each expression to
90 ;; decide in which order to sort them.
91 ;; The most important dispatch is last in the list (and the least is first).
93 ;; `method-table' is a list of
94 ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where
95 ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method'
96 ;; (and hence expects an extra argument holding the next-method).
99 (defmacro cl--generic (name)
100 `(get ,name 'cl--generic))
102 (defun cl-generic-ensure-function (name)
105 (while (and (null (setq generic (cl--generic name)))
107 (symbolp (symbol-function name)))
108 (setq name (symbol-function name)))
109 (unless (or (not (fboundp name))
110 (and (functionp name) generic))
111 (error "%s is already defined as something else than a generic function"
114 (cl-assert (eq name (cl--generic-name generic)))
115 (setf (cl--generic name) (setq generic (cl--generic-make name)))
116 (defalias name (cl--generic-make-function generic)))
119 (defun cl--generic-setf-rewrite (name)
120 (let ((setter (intern (format "cl-generic-setter--%s" name))))
123 (unless (eq ',setter (get ',name 'cl-generic-setter))
124 ;; (when (get ',name 'gv-expander)
125 ;; (error "gv-expander conflicts with (setf %S)" ',name))
126 (setf (get ',name 'cl-generic-setter) ',setter)
127 (gv-define-setter ,name (val &rest args)
128 (cons ',setter (cons val args))))))))
131 (defmacro cl-defgeneric (name args &rest options-and-methods)
132 "Create a generic function NAME.
133 DOC-STRING is the base documentation for this class. A generic
134 function has no body, as its purpose is to decide which method body
135 is appropriate to use. Specific methods are defined with `defmethod'.
136 With this implementation the ARGS are currently ignored.
137 OPTIONS-AND-METHODS is currently only used to specify the docstring,
138 via (:documentation DOCSTRING)."
139 (declare (indent 2) (doc-string 3))
140 (let* ((docprop (assq :documentation options-and-methods))
141 (doc (cond ((stringp (car-safe options-and-methods))
142 (pop options-and-methods))
146 (setq options-and-methods
147 (delq docprop options-and-methods)))))))
149 ,(when (eq 'setf (car-safe name))
150 (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
155 (cl-generic-define ',name ',args ',options-and-methods)
158 (defun cl--generic-mandatory-args (args)
160 (while (not (memq (car args) '(nil &rest &optional &key)))
161 (push (pop args) res))
165 (defun cl-generic-define (name args options-and-methods)
166 (let ((generic (cl-generic-ensure-function name))
167 (mandatory (cl--generic-mandatory-args args))
168 (apo (assq :argument-precedence-order options-and-methods)))
169 (setf (cl--generic-dispatches generic) nil)
171 (dolist (arg (cdr apo))
172 (let ((pos (memq arg mandatory)))
173 (unless pos (error "%S is not a mandatory argument" arg))
174 (push (list (- (length mandatory) (length pos)))
175 (cl--generic-dispatches generic)))))
176 (setf (cl--generic-method-table generic) nil)
177 (cl--generic-make-function generic)))
179 (defvar cl-generic-current-method-specializers nil
180 ;; This is let-bound during macro-expansion of method bodies, so that those
181 ;; bodies can be optimized knowing that the specializers have matched.
182 ;; FIXME: This presumes the formal arguments aren't modified via `setq' and
183 ;; aren't shadowed either ;-(
184 ;; FIXME: This might leak outside the scope of the method if, during
185 ;; macroexpansion of the method, something causes some other macroexpansion
186 ;; (e.g. an autoload).
187 "List of (VAR . TYPE) where TYPE is var's specializer.")
189 (eval-and-compile ;Needed while compiling the cl-defmethod calls below!
190 (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el.
191 "Check which of the symbols VARS appear in SEXP."
194 (dolist (var (cl--generic-fgrep vars (pop sexp)))
195 (unless (memq var res) (push var res))))
196 (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
199 (defun cl--generic-lambda (args body with-cnm)
200 "Make the lambda expression for a method with ARGS and BODY."
201 (let ((plain-args ())
202 (cl-generic-current-method-specializers nil)
203 (doc-string (if (stringp (car-safe body)) (pop body)))
207 ((or '&optional '&rest '&key) (setq mandatory nil) arg)
208 ((and `(,name . ,type) (guard mandatory))
209 (push (cons name (car type))
210 cl-generic-current-method-specializers)
214 (setq plain-args (nreverse plain-args))
215 (let ((fun `(cl-function (lambda ,plain-args
216 ,@(if doc-string (list doc-string))
220 ;; First macroexpand away the cl-function stuff (e.g. &key and
221 ;; destructuring args, `declare' and whatnot).
222 (pcase (macroexpand fun macroexpand-all-environment)
223 (`#'(lambda ,args . ,body)
224 (require 'cl-lib) ;Needed to expand `cl-flet'.
225 (let* ((doc-string (and doc-string (stringp (car body))
227 (cnm (make-symbol "cl--cnm"))
228 (nbody (macroexpand-all
229 `(cl-flet ((cl-call-next-method ,cnm))
231 macroexpand-all-environment))
232 ;; FIXME: Rather than `grep' after the fact, the
233 ;; macroexpansion should directly set some flag when cnm
235 ;; FIXME: Also, optimize the case where call-next-method is
236 ;; only called with explicit arguments.
237 (uses-cnm (cl--generic-fgrep (list cnm) nbody)))
238 (cons (not (not uses-cnm))
239 `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
240 ,@(if doc-string (list doc-string))
242 (f (error "Unexpected macroexpansion result: %S" f))))))))
246 (defmacro cl-defmethod (name args &rest body)
247 "Define a new method for generic function NAME.
248 I.e. it defines the implementation of NAME to use for invocations where the
249 value of the dispatch argument matches the specified TYPE.
250 The dispatch argument has to be one of the mandatory arguments, and
251 all methods of NAME have to use the same argument for dispatch.
252 The dispatch argument and TYPE are specified in ARGS where the corresponding
253 formal argument appears as (VAR TYPE) rather than just VAR.
255 The optional second argument QUALIFIER is a specifier that
256 modifies how the method is combined with other methods, including:
257 :before - Method will be called before the primary
258 :after - Method will be called after the primary
259 :around - Method will be called around everything else
260 The absence of QUALIFIER means this is a \"primary\" method.
262 Other than a type, TYPE can also be of the form `(eql VAL)' in
263 which case this method will be invoked when the argument is `eql' to VAL.
265 \(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
266 (declare (doc-string 3) (indent 2))
267 (let ((qualifiers nil))
268 (while (keywordp args)
269 (push args qualifiers)
270 (setq args (pop body)))
271 (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after))))
272 (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm)))
274 ,(when (eq 'setf (car-safe name))
275 (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
279 (cl-generic-define-method ',name ',qualifiers ',args
283 (defun cl-generic-define-method (name qualifiers args uses-cnm function)
284 (when (> (length qualifiers) 1)
285 (error "We only support a single qualifier per method: %S" qualifiers))
286 (unless (memq (car qualifiers) '(nil :primary :around :after :before))
287 (error "Unsupported qualifier in: %S" qualifiers))
288 (let* ((generic (cl-generic-ensure-function name))
289 (mandatory (cl--generic-mandatory-args args))
291 (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory))
292 (key (cons specializers (or (car qualifiers) ':primary)))
293 (mt (cl--generic-method-table generic))
295 (dispatches (cl--generic-dispatches generic))
297 (dolist (specializer specializers)
298 (let* ((tagcode (funcall cl-generic-tagcode-function specializer 'arg))
299 (x (assq i dispatches)))
301 (setf (cl--generic-dispatches generic)
302 (setq dispatches (cons (list i tagcode) dispatches)))
303 (unless (member tagcode (cdr x))
305 (nreverse (sort (cons tagcode (cdr x))
306 #'car-less-than-car)))))
308 (if me (setcdr me (cons uses-cnm function))
309 (setf (cl--generic-method-table generic)
310 (cons `(,key ,uses-cnm . ,function) mt)))
311 ;; For aliases, cl--generic-name gives us the actual name.
312 (defalias (cl--generic-name generic)
313 (cl--generic-make-function generic))))
315 (defmacro cl--generic-with-memoization (place &rest code)
316 (declare (indent 1) (debug t))
317 (gv-letplace (getter setter) place
319 ,(macroexp-let2 nil val (macroexp-progn code)
321 ,(funcall setter val)
324 (defvar cl--generic-dispatchers (make-hash-table :test #'equal))
326 (defun cl--generic-get-dispatcher (tagcodes dispatch-arg)
327 (cl--generic-with-memoization
328 (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers)
329 (let ((lexical-binding t)
331 (dotimes (_ dispatch-arg)
332 (push (make-symbol "arg") extraargs))
334 `(lambda (generic dispatches-left)
335 (let ((method-cache (make-hash-table :test #'eql)))
336 (lambda (,@extraargs arg &rest args)
337 (apply (cl--generic-with-memoization
338 (gethash (or ,@(mapcar #'cdr tagcodes)) method-cache)
339 (cl--generic-cache-miss
340 generic ',dispatch-arg dispatches-left
341 (list ,@(mapcar #'cdr tagcodes))))
342 ,@extraargs arg args))))))))
344 (defun cl--generic-make-function (generic)
345 (let* ((dispatches (cl--generic-dispatches generic))
348 (while (and dispatches
349 (member (cdar dispatches)
350 '(nil ((0 . 'cl--generic-type)))))
351 (setq dispatches (cdr dispatches)))
354 (cl--generic-build-combined-method
355 (cl--generic-name generic)
356 (cl--generic-method-table generic))
357 (let ((dispatcher (cl--generic-get-dispatcher
358 (cdr dispatch) (car dispatch))))
359 (funcall dispatcher generic dispatches)))))
361 (defun cl--generic-nest (fun methods)
362 (pcase-dolist (`(,uses-cnm . ,method) methods)
364 (if (not uses-cnm) method
368 ;; FIXME: This sucks: passing just `next' would
369 ;; be a lot more efficient than the lambda+apply
370 ;; quasi-η, but we need this to implement the
371 ;; "if call-next-method is called with no
372 ;; arguments, then use the previous arguments".
373 (lambda (&rest cnm-args)
374 (apply next (or cnm-args args)))
378 (defvar cl--generic-combined-method-memoization
379 (make-hash-table :test #'equal :weakness 'value)
380 "Table storing previously built combined-methods.
381 This is particularly useful when many different tags select the same set
382 of methods, since this table then allows us to share a single combined-method
383 for all those different tags in the method-cache.")
385 (defun cl--generic-build-combined-method (generic-name methods)
386 (let ((mets-by-qual ()))
388 (push (cdr qm) (alist-get (cdar qm) mets-by-qual)))
389 (cl--generic-with-memoization
390 (gethash (cons generic-name mets-by-qual)
391 cl--generic-combined-method-memoization)
393 ((null mets-by-qual) (lambda (&rest args)
394 (cl-no-applicable-method generic-name args)))
396 (let* ((fun (lambda (&rest args)
397 ;; FIXME: CLOS passes as second arg the "calling method".
398 ;; We don't currently have "method objects" like CLOS
399 ;; does so we can't really do it the CLOS way.
400 ;; The closest would be to pass the lambda corresponding
401 ;; to the method, but the caller wouldn't be able to do
402 ;; much with it anyway. So we pass nil for now.
403 (apply #'cl-no-next-method generic-name nil args)))
404 ;; We use `cdr' to drop the `uses-cnm' annotations.
406 (mapcar #'cdr (reverse (alist-get :before mets-by-qual))))
407 (after (mapcar #'cdr (alist-get :after mets-by-qual))))
408 (setq fun (cl--generic-nest fun (alist-get :primary mets-by-qual)))
409 (when (or after before)
411 (setq fun (lambda (&rest args)
417 (apply af args)))))))
418 (cl--generic-nest fun (alist-get :around mets-by-qual))))))))
420 (defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags)
421 (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags)))
423 (dolist (method-desc (cl--generic-method-table generic))
424 (let ((m (member (nth dispatch-arg (caar method-desc)) types)))
426 (push (cons (length m) method-desc) methods))))
427 ;; Sort the methods, most specific first.
428 ;; It would be tempting to sort them once and for all in the method-table
429 ;; rather than here, but the order might depend on the actual argument
430 ;; (e.g. for multiple inheritance with defclass).
431 (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
432 (cl--generic-make-function (cl--generic-make (cl--generic-name generic)
433 dispatches-left methods))))
435 ;;; Define some pre-defined generic functions, used internally.
437 (define-error 'cl-no-method "No method for %S")
438 (define-error 'cl-no-next-method "No next method for %S" 'cl-no-method)
439 (define-error 'cl-no-applicable-method "No applicable method for %S"
442 (cl-defgeneric cl-no-next-method (generic method &rest args)
443 "Function called when `cl-call-next-method' finds no next method.")
444 (cl-defmethod cl-no-next-method ((generic t) method &rest args)
445 (signal 'cl-no-next-method `(,generic ,method ,@args)))
447 (cl-defgeneric cl-no-applicable-method (generic &rest args)
448 "Function called when a method call finds no applicable method.")
449 (cl-defmethod cl-no-applicable-method ((generic t) &rest args)
450 (signal 'cl-no-applicable-method `(,generic ,@args)))
452 (defun cl-call-next-method (&rest _args)
453 "Function to call the next applicable method.
454 Can only be used from within the lexical body of a primary or around method."
455 (error "cl-call-next-method only allowed inside primary and around methods"))
457 ;;; Add support for describe-function
459 (add-hook 'help-fns-describe-function-functions 'cl--generic-describe)
460 (defun cl--generic-describe (function)
461 ;; FIXME: Fix up the main "in `<file>'" hyperlink, and add such hyperlinks
463 (let ((generic (if (symbolp function) (cl--generic function))))
466 (insert "\n\nThis is a generic function.\n\n")
467 (insert (propertize "Implementations:\n\n" 'face 'bold))
468 ;; Loop over fanciful generics
469 (pcase-dolist (`((,type . ,qualifier) . ,method)
470 (cl--generic-method-table generic))
473 ;; FIXME: Add support for cl-structs in help-variable.
474 (help-insert-xref-button (symbol-name type)
476 (insert (format "%S" type)))
477 (insert (format "' %S %S\n"
479 (let ((args (help-function-arglist method)))
480 ;; Drop cl--generic-next arg if present.
481 (if (memq (car qualifier) '(:after :before))
483 (insert (or (documentation method) "Undocumented") "\n\n"))))))
485 ;;; Support for (eql <val>) specializers.
487 (defvar cl--generic-eql-used (make-hash-table :test #'eql))
489 (add-function :before-until cl-generic-tagcode-function
490 #'cl--generic-eql-tagcode)
491 (defun cl--generic-eql-tagcode (type name)
492 (when (eq (car-safe type) 'eql)
493 (puthash (cadr type) type cl--generic-eql-used)
494 `(100 . (gethash ,name cl--generic-eql-used))))
496 (add-function :before-until cl-generic-tag-types-function
497 #'cl--generic-eql-tag-types)
498 (defun cl--generic-eql-tag-types (tag)
499 (if (eq (car-safe tag) 'eql) (list tag)))
501 ;;; Support for cl-defstructs specializers.
503 (add-function :before-until cl-generic-tagcode-function
504 #'cl--generic-struct-tagcode)
505 (defun cl--generic-struct-tagcode (type name)
507 (get type 'cl-struct-type)
508 (or (eq 'vector (car (get type 'cl-struct-type)))
509 (error "Can't dispatch on cl-struct %S: type is %S"
510 type (car (get type 'cl-struct-type))))
511 (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots)))
512 (error "Can't dispatch on cl-struct %S: no tag in slot 0"
514 ;; We could/should check the vector has length >0,
515 ;; but really, mixing vectors and structs is a bad idea,
516 ;; so let's not waste time trying to handle the case
517 ;; of an empty vector.
518 ;; BEWARE: this returns a bogus tag for non-struct vectors.
519 `(50 . (and (vectorp ,name) (aref ,name 0)))))
521 (add-function :before-until cl-generic-tag-types-function
522 #'cl--generic-struct-tag-types)
523 (defun cl--generic-struct-tag-types (tag)
524 ;; FIXME: cl-defstruct doesn't make it easy for us.
526 ;; A method call shouldn't itself mess with the match-data.
527 (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag))
528 (let ((types (list (intern (substring (symbol-name tag) 10)))))
529 (while (get (car types) 'cl-struct-include)
530 (push (get (car types) 'cl-struct-include) types))
531 (push 'cl-struct types) ;The "parent type" of all cl-structs.
534 ;;; Dispatch on "old-style types".
536 (defconst cl--generic-typeof-types
537 ;; Hand made from the source code of `type-of'.
538 '((integer number) (symbol) (string array) (cons list)
539 ;; Markers aren't `numberp', yet they are accepted wherever integers are
540 ;; accepted, pretty much.
541 (marker) (overlay) (float number) (window-configuration)
542 (process) (window) (subr) (compiled-function) (buffer) (char-table array)
544 (frame) (hash-table) (font-spec) (font-entity) (font-object)
552 (add-function :before-until cl-generic-tagcode-function
553 #'cl--generic-typeof-tagcode)
554 (defun cl--generic-typeof-tagcode (type name)
555 ;; FIXME: Add support for other types accepted by `cl-typep' such
556 ;; as `character', `atom', `face', `function', ...
557 (and (assq type cl--generic-typeof-types)
559 (if (memq type '(vector array))
560 (message "`%S' also matches CL structs and EIEIO classes" type))
561 ;; FIXME: We could also change `type-of' to return `null' for nil.
562 `(10 . (if ,name (type-of ,name) 'null)))))
564 (add-function :before-until cl-generic-tag-types-function
565 #'cl--generic-typeof-types)
566 (defun cl--generic-typeof-types (tag)
568 (assq tag cl--generic-typeof-types)))
570 ;;; Just for kicks: dispatch on major-mode
572 ;; Here's how you'd use it:
573 ;; (cl-defmethod foo ((x (major-mode text-mode)) y z) ...)
575 ;; (foo 'major-mode toto titi)
577 ;; FIXME: Better would be to do that via dispatch on an "implicit argument".
579 ;; (defvar cl--generic-major-modes (make-hash-table :test #'eq))
581 ;; (add-function :before-until cl-generic-tagcode-function
582 ;; #'cl--generic-major-mode-tagcode)
583 ;; (defun cl--generic-major-mode-tagcode (type name)
584 ;; (if (eq 'major-mode (car-safe type))
585 ;; `(50 . (if (eq ,name 'major-mode)
586 ;; (cl--generic-with-memoization
587 ;; (gethash major-mode cl--generic-major-modes)
588 ;; `(cl--generic-major-mode . ,major-mode))))))
590 ;; (add-function :before-until cl-generic-tag-types-function
591 ;; #'cl--generic-major-mode-types)
592 ;; (defun cl--generic-major-mode-types (tag)
593 ;; (when (eq (car-safe tag) 'cl--generic-major-mode)
594 ;; (if (eq tag 'fundamental-mode) '(fundamental-mode t)
595 ;; (let ((types `((major-mode ,(cdr tag)))))
596 ;; (while (get (car types) 'derived-mode-parent)
597 ;; (push (list 'major-mode (get (car types) 'derived-mode-parent))
599 ;; (unless (eq 'fundamental-mode (car types))
600 ;; (push '(major-mode fundamental-mode) types))
601 ;; (nreverse types)))))
604 ;; generated-autoload-file: "cl-loaddefs.el"
607 (provide 'cl-generic)
608 ;;; cl-generic.el ends here