cl-generic.el 43.7 KB
Newer Older
1 2
;;; cl-generic.el --- CLOS-style generic functions for Elisp  -*- lexical-binding: t; -*-

3
;; Copyright (C) 2015 Free Software Foundation, Inc.
4 5 6

;; Author: Stefan Monnier <monnier@iro.umontreal.ca>

7 8 9
;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
10 11 12 13
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

14
;; GNU Emacs is distributed in the hope that it will be useful,
15 16 17 18 19
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; 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/>.
21 22 23 24 25 26 27 28

;;; Commentary:

;; This implements the most of CLOS's multiple-dispatch generic functions.
;; To use it you need either (require 'cl-generic) or (require 'cl-lib).
;; The main entry points are: `cl-defgeneric' and `cl-defmethod'.

;; Missing elements:
29
;; - We don't support make-method, call-method, define-method-combination.
30 31 32
;;   CLOS's define-method-combination is IMO overly complicated, and it suffers
;;   from a significant problem: the method-combination code returns a sexp
;;   that needs to be `eval'uated or compiled.  IOW it requires run-time
33
;;   code generation.  Given how rarely method-combinations are used,
34 35
;;   I just provided a cl-generic-combine-methods generic function, to which
;;   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.
38 39
;; Added elements:
;; - We support aliases to generic functions.
40 41 42
;; - cl-generic-generalizers.  This generic function lets you extend the kind
;;   of thing on which to dispatch.  There is support in this file for
;;   dispatch on:
43
;;   - (eql <val>)
44
;;   - (head <val>) which checks that the arg is a cons with <val> as its head.
45 46 47 48 49
;;   - plain old types
;;   - type of CL structs
;;   eieio-core adds dispatch on:
;;   - class of eieio objects
;;   - actual class argument, using the syntax (subclass <class>).
50 51
;; - cl-generic-combine-methods (i.s.o define-method-combination and
;;   compute-effective-method).
52
;; - cl-generic-call-method (which replaces make-method and call-method).
53 54 55
;; - The standard method combination supports ":extra STRING" qualifiers
;;   which simply allows adding more methods for the same
;;   specializers&qualifiers.
56 57 58 59 60 61

;; Efficiency considerations: overall, I've made an effort to make this fairly
;; efficient for the expected case (e.g. no constant redefinition of methods).
;; - Generic functions which do not dispatch on any argument are implemented
;;   optimally (just as efficient as plain old functions).
;; - Generic functions which only dispatch on one argument are fairly efficient
62 63
;;   (not a lot of room for improvement without changes to the byte-compiler,
;;   I think).
64 65 66
;; - Multiple dispatch is implemented rather naively.  There's an extra `apply'
;;   function call for every dispatch; we don't optimize each dispatch
;;   based on the set of candidate methods remaining; we don't optimize the
67 68
;;   order in which we performs the dispatches either;
;;   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.
70

71 72 73 74 75 76 77 78
;; TODO:
;;
;; - A generic "filter" generalizer (e.g. could be used to cleanly adds methods
;;   to cl-generic-combine-methods with a specializer that says it applies only
;;   when some particular qualifier is used).
;; - A way to dispatch on the context (e.g. the major-mode, some global
;;   variable, you name it).

79 80 81 82 83 84 85 86 87 88 89
;;; Code:

;; Note: For generic functions that dispatch on several arguments (i.e. those
;; which use the multiple-dispatch feature), we always use the same "tagcodes"
;; and the same set of arguments on which to dispatch.  This works, but is
;; often suboptimal since after one dispatch, the remaining dispatches can
;; usually be simplified, or even completely skipped.

(eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'pcase))

90 91 92 93 94 95 96 97 98 99 100
(cl-defstruct (cl--generic-generalizer
               (:constructor nil)
               (:constructor cl-generic-make-generalizer
                (priority tagcode-function specializers-function)))
  (priority nil :type integer)
  tagcode-function
  specializers-function)

(defconst cl--generic-t-generalizer
  (cl-generic-make-generalizer
   0 (lambda (_name) nil) (lambda (_tag) '(t))))
101

102 103
(cl-defstruct (cl--generic-method
               (:constructor nil)
104
               (:constructor cl--generic-make-method
105 106 107 108 109 110 111 112 113
                (specializers qualifiers uses-cnm function))
               (:predicate nil))
  (specializers nil :read-only t :type list)
  (qualifiers   nil :read-only t :type (list-of atom))
  ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument
  ;; holding the next-method.
  (uses-cnm     nil :read-only t :type boolean)
  (function     nil :read-only t :type function))

114 115
(cl-defstruct (cl--generic
               (:constructor nil)
116
               (:constructor cl--generic-make (name))
117
               (:predicate nil))
118
  (name nil :type symbol :read-only t)  ;Pointer back to the symbol.
119 120 121 122 123 124
  ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
  ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
  ;; where the EXPs are expressions (to be `or'd together) to compute the tag
  ;; on which to dispatch and PRIORITY is the priority of each expression to
  ;; decide in which order to sort them.
  ;; The most important dispatch is last in the list (and the least is first).
125 126 127 128 129 130 131
  (dispatches nil :type (list-of (cons natnum (list-of generalizers))))
  (method-table nil :type (list-of cl--generic-method))
  (options nil :type list))

(defun cl-generic-function-options (generic)
  "Return the options of the generic function GENERIC."
  (cl--generic-options generic))
132 133 134 135 136 137 138 139 140 141 142 143

(defmacro cl--generic (name)
  `(get ,name 'cl--generic))

(defun cl-generic-ensure-function (name)
  (let (generic
        (origname name))
    (while (and (null (setq generic (cl--generic name)))
                (fboundp name)
                (symbolp (symbol-function name)))
      (setq name (symbol-function name)))
    (unless (or (not (fboundp name))
144
                (autoloadp (symbol-function name))
145 146 147 148 149 150 151 152 153 154
                (and (functionp name) generic))
      (error "%s is already defined as something else than a generic function"
             origname))
    (if generic
        (cl-assert (eq name (cl--generic-name generic)))
      (setf (cl--generic name) (setq generic (cl--generic-make name)))
      (defalias name (cl--generic-make-function generic)))
    generic))

(defun cl--generic-setf-rewrite (name)
155 156 157 158 159 160 161 162 163 164
  (let* ((setter (intern (format "cl-generic-setter--%s" name)))
         (exp `(unless (eq ',setter (get ',name 'cl-generic-setter))
                 ;; (when (get ',name 'gv-expander)
                 ;;   (error "gv-expander conflicts with (setf %S)" ',name))
                 (setf (get ',name 'cl-generic-setter) ',setter)
                 (gv-define-setter ,name (val &rest args)
                   (cons ',setter (cons val args))))))
    ;; Make sure `setf' can be used right away, e.g. in the body of the method.
    (eval exp t)
    (cons setter exp)))
165 166 167 168 169 170

;;;###autoload
(defmacro cl-defgeneric (name args &rest options-and-methods)
  "Create a generic function NAME.
DOC-STRING is the base documentation for this class.  A generic
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 174
OPTIONS-AND-METHODS currently understands:
- (:documentation DOCSTRING)
175 176 177 178 179 180
- (declare DECLARATIONS)
- (:argument-precedence-order &rest ARGS)
- (:method [QUALIFIERS...] ARGS &rest BODY)
BODY, if present, is used as the body of a default method.

\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)"
181
  (declare (indent 2) (doc-string 3))
182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
  (let* ((doc (if (stringp (car-safe options-and-methods))
                  (pop options-and-methods)))
         (declarations nil)
         (methods ())
         (options ())
         next-head)
    (while (progn (setq next-head (car-safe (car options-and-methods)))
                  (or (keywordp next-head)
                      (eq next-head 'declare)))
      (pcase next-head
        (`:documentation
         (when doc (error "Multiple doc strings for %S" name))
         (setq doc (cadr (pop options-and-methods))))
        (`declare
         (when declarations (error "Multiple `declare' for %S" name))
         (setq declarations (pop options-and-methods)))
        (`:method (push (cdr (pop options-and-methods)) methods))
        (_ (push (pop options-and-methods) options))))
    (when options-and-methods
      ;; Anything remaining is assumed to be a default method body.
      (push `(,args ,@options-and-methods) methods))
203 204 205 206 207 208
    `(progn
       ,(when (eq 'setf (car-safe name))
          (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
                                           (cadr name))))
            (setq name setter)
            code))
209 210 211 212 213 214 215 216 217
       ,@(mapcar (lambda (declaration)
                   (let ((f (cdr (assq (car declaration)
                                       defun-declarations-alist))))
                     (cond
                      (f (apply (car f) name args (cdr declaration)))
                      (t (message "Warning: Unknown defun property `%S' in %S"
                                  (car declaration) name)
                         nil))))
                 (cdr declarations))
218
       (defalias ',name
219 220 221 222
         (cl-generic-define ',name ',args ',(nreverse options))
         ,(help-add-fundoc-usage doc args))
       ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
                 (nreverse methods)))))
223 224 225 226 227 228 229 230

(defun cl--generic-mandatory-args (args)
  (let ((res ()))
    (while (not (memq (car args) '(nil &rest &optional &key)))
      (push (pop args) res))
    (nreverse res)))

;;;###autoload
231
(defun cl-generic-define (name args options)
232 233
  (let ((generic (cl-generic-ensure-function name))
        (mandatory (cl--generic-mandatory-args args))
234
        (apo (assq :argument-precedence-order options)))
235 236 237 238 239 240 241 242
    (setf (cl--generic-dispatches generic) nil)
    (when apo
      (dolist (arg (cdr apo))
        (let ((pos (memq arg mandatory)))
          (unless pos (error "%S is not a mandatory argument" arg))
          (push (list (- (length mandatory) (length pos)))
                (cl--generic-dispatches generic)))))
    (setf (cl--generic-method-table generic) nil)
243
    (setf (cl--generic-options generic) options)
244 245
    (cl--generic-make-function generic)))

246 247 248 249
(defmacro cl-generic-current-method-specializers ()
  "List of (VAR . TYPE) where TYPE is var's specializer.
This macro can only be used within the lexical scope of a cl-generic method."
  (error "cl-generic-current-method-specializers used outside of a method"))
250 251 252 253 254 255 256 257 258 259 260

(eval-and-compile         ;Needed while compiling the cl-defmethod calls below!
  (defun cl--generic-fgrep (vars sexp)    ;Copied from pcase.el.
    "Check which of the symbols VARS appear in SEXP."
    (let ((res '()))
      (while (consp sexp)
        (dolist (var (cl--generic-fgrep vars (pop sexp)))
          (unless (memq var res) (push var res))))
      (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
      res))

261
  (defun cl--generic-lambda (args body)
262 263
    "Make the lambda expression for a method with ARGS and BODY."
    (let ((plain-args ())
264
          (specializers nil)
265 266 267 268 269
          (mandatory t))
      (dolist (arg args)
        (push (pcase arg
                ((or '&optional '&rest '&key) (setq mandatory nil) arg)
                ((and `(,name . ,type) (guard mandatory))
270
                 (push (cons name (car type)) specializers)
271 272 273 274
                 name)
                (_ arg))
              plain-args))
      (setq plain-args (nreverse plain-args))
275
      (let ((fun `(cl-function (lambda ,plain-args ,@body)))
276 277 278
            (macroenv (cons `(cl-generic-current-method-specializers
                              . ,(lambda () specializers))
                            macroexpand-all-environment)))
279
        (require 'cl-lib)        ;Needed to expand `cl-flet' and `cl-function'.
280 281 282 283
        ;; First macroexpand away the cl-function stuff (e.g. &key and
        ;; destructuring args, `declare' and whatnot).
        (pcase (macroexpand fun macroenv)
          (`#'(lambda ,args . ,body)
284
           (let* ((parsed-body (macroexp-parse-body body))
285 286 287 288 289
                  (cnm (make-symbol "cl--cnm"))
                  (nmp (make-symbol "cl--nmp"))
                  (nbody (macroexpand-all
                          `(cl-flet ((cl-call-next-method ,cnm)
                                     (cl-next-method-p ,nmp))
290
                             ,@(cdr parsed-body))
291 292 293 294 295 296 297 298 299
                          macroenv))
                  ;; FIXME: Rather than `grep' after the fact, the
                  ;; macroexpansion should directly set some flag when cnm
                  ;; is used.
                  ;; FIXME: Also, optimize the case where call-next-method is
                  ;; only called with explicit arguments.
                  (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
             (cons (not (not uses-cnm))
                   `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
300
                        ,@(car parsed-body)
301 302 303 304 305 306
                        ,(if (not (memq nmp uses-cnm))
                             nbody
                           `(let ((,nmp (lambda ()
                                          (cl--generic-isnot-nnm-p ,cnm))))
                              ,nbody))))))
          (f (error "Unexpected macroexpansion result: %S" f)))))))
307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329


;;;###autoload
(defmacro cl-defmethod (name args &rest body)
  "Define a new method for generic function NAME.
I.e. it defines the implementation of NAME to use for invocations where the
value of the dispatch argument matches the specified TYPE.
The dispatch argument has to be one of the mandatory arguments, and
all methods of NAME have to use the same argument for dispatch.
The dispatch argument and TYPE are specified in ARGS where the corresponding
formal argument appears as (VAR TYPE) rather than just VAR.

The optional second argument QUALIFIER is a specifier that
modifies how the method is combined with other methods, including:
   :before  - Method will be called before the primary
   :after   - Method will be called after the primary
   :around  - Method will be called around everything else
The absence of QUALIFIER means this is a \"primary\" method.

Other than a type, TYPE can also be of the form `(eql VAL)' in
which case this method will be invoked when the argument is `eql' to VAL.

\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
330 331 332 333 334 335 336 337 338
  (declare (doc-string 3) (indent 2)
           (debug
            (&define                    ; this means we are defining something
             [&or name ("setf" :name setf name)]
             ;; ^^ This is the methods symbol
             [ &optional keywordp ]     ; this is key :before etc
             list                       ; arguments
             [ &optional stringp ]      ; documentation string
             def-body)))                ; part to be debugged
339 340 341 342
  (let ((qualifiers nil)
        (setfizer (if (eq 'setf (car-safe name))
                      ;; Call it before we call cl--generic-lambda.
                      (cl--generic-setf-rewrite (cadr name)))))
343
    (while (not (listp args))
344 345
      (push args qualifiers)
      (setq args (pop body)))
346
    (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
347
      `(progn
348 349 350
         ,(when setfizer
            (setq name (car setfizer))
            (cdr setfizer))
351 352 353 354 355 356 357
         ,(and (get name 'byte-obsolete-info)
               (or (not (fboundp 'byte-compile-warning-enabled-p))
                   (byte-compile-warning-enabled-p 'obsolete))
               (let* ((obsolete (get name 'byte-obsolete-info)))
                 (macroexp--warn-and-return
                  (macroexp--obsolete-warning name obsolete "generic function")
                  nil)))
358 359 360 361 362
         ;; You could argue that `defmethod' modifies rather than defines the
         ;; function, so warnings like "not known to be defined" are fair game.
         ;; But in practice, it's common to use `cl-defmethod'
         ;; without a previous `cl-defgeneric'.
         (declare-function ,name "")
363
         (cl-generic-define-method ',name ',(nreverse qualifiers) ',args
364 365
                                   ,uses-cnm ,fun)))))

366 367 368 369 370 371
(defun cl--generic-member-method (specializers qualifiers methods)
  (while
      (and methods
           (let ((m (car methods)))
             (not (and (equal (cl--generic-method-specializers m) specializers)
                       (equal (cl--generic-method-qualifiers m) qualifiers)))))
372 373
    (setq methods (cdr methods)))
  methods)
374

375 376 377 378 379 380
;;;###autoload
(defun cl-generic-define-method (name qualifiers args uses-cnm function)
  (let* ((generic (cl-generic-ensure-function name))
         (mandatory (cl--generic-mandatory-args args))
         (specializers
          (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 386 387
         (dispatches (cl--generic-dispatches generic))
         (i 0))
    (dolist (specializer specializers)
388
      (let* ((generalizers (cl-generic-generalizers specializer))
389
             (x (assq i dispatches)))
390
        (unless x
391
          (setq x (cons i (cl-generic-generalizers t)))
392 393
          (setf (cl--generic-dispatches generic)
                (setq dispatches (cons x dispatches))))
394 395 396 397 398 399 400
        (dolist (generalizer generalizers)
          (unless (member generalizer (cdr x))
            (setf (cdr x)
                  (sort (cons generalizer (cdr x))
                        (lambda (x y)
                          (> (cl--generic-generalizer-priority x)
                             (cl--generic-generalizer-priority y)))))))
401
        (setq i (1+ i))))
402 403
    (if me (setcar me method)
      (setf (cl--generic-method-table generic) (cons method mt)))
404 405
    (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
                current-load-list :test #'equal)
406 407
    ;; FIXME: Try to avoid re-constructing a new function if the old one
    ;; is still valid (e.g. still empty method cache)?
408 409 410 411
    (let ((gfun (cl--generic-make-function generic))
          ;; Prevent `defalias' from recording this as the definition site of
          ;; the generic function.
          current-load-list)
412 413
      ;; For aliases, cl--generic-name gives us the actual name.
      (defalias (cl--generic-name generic) gfun))))
414 415 416 417 418 419 420 421 422 423 424 425

(defmacro cl--generic-with-memoization (place &rest code)
  (declare (indent 1) (debug t))
  (gv-letplace (getter setter) place
    `(or ,getter
         ,(macroexp-let2 nil val (macroexp-progn code)
            `(progn
               ,(funcall setter val)
               ,val)))))

(defvar cl--generic-dispatchers (make-hash-table :test #'equal))

426
(defun cl--generic-get-dispatcher (dispatch)
427
  (cl--generic-with-memoization
428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454
      (gethash dispatch cl--generic-dispatchers)
    (let* ((dispatch-arg (car dispatch))
           (generalizers (cdr dispatch))
           (lexical-binding t)
           (tagcodes
            (mapcar (lambda (generalizer)
                      (funcall (cl--generic-generalizer-tagcode-function
                                generalizer)
                               'arg))
                    generalizers))
           (typescodes
            (mapcar (lambda (generalizer)
                      `(funcall ',(cl--generic-generalizer-specializers-function
                                   generalizer)
                                ,(funcall (cl--generic-generalizer-tagcode-function
                                           generalizer)
                                          'arg)))
                    generalizers))
           (tag-exp
            ;; Minor optimization: since this tag-exp is
            ;; only used to lookup the method-cache, it
            ;; doesn't matter if the default value is some
            ;; constant or nil.
            `(or ,@(if (macroexp-const-p (car (last tagcodes)))
                       (butlast tagcodes)
                     tagcodes)))
           (extraargs ()))
455 456
      (dotimes (_ dispatch-arg)
        (push (make-symbol "arg") extraargs))
457 458 459
      ;; FIXME: For generic functions with a single method (or with 2 methods,
      ;; one of which always matches), using a tagcode + hash-table is
      ;; overkill: better just use a `cl-typep' test.
460
      (byte-compile
461
       `(lambda (generic dispatches-left methods)
462 463 464
          (let ((method-cache (make-hash-table :test #'eql)))
            (lambda (,@extraargs arg &rest args)
              (apply (cl--generic-with-memoization
465
                         (gethash ,tag-exp method-cache)
466
                       (cl--generic-cache-miss
467 468 469
                        generic ',dispatch-arg dispatches-left methods
                        ,(if (cdr typescodes)
                             `(append ,@typescodes) (car typescodes))))
470 471 472
                     ,@extraargs arg args))))))))

(defun cl--generic-make-function (generic)
473 474 475 476 477 478
  (cl--generic-make-next-function generic
                                  (cl--generic-dispatches generic)
                                  (cl--generic-method-table generic)))

(defun cl--generic-make-next-function (generic dispatches methods)
  (let* ((dispatch
479 480
          (progn
            (while (and dispatches
481 482 483
                        (let ((x (nth 1 (car dispatches))))
                          ;; No need to dispatch for `t' specializers.
                          (or (null x) (equal x cl--generic-t-generalizer))))
484 485
              (setq dispatches (cdr dispatches)))
            (pop dispatches))))
486 487 488 489 490 491 492
    (if (not (and dispatch
                  ;; If there's no method left, there's no point checking
                  ;; further arguments.
                  methods))
        (cl--generic-build-combined-method generic methods)
      (let ((dispatcher (cl--generic-get-dispatcher dispatch)))
        (funcall dispatcher generic dispatches methods)))))
493 494 495 496 497 498 499 500

(defvar cl--generic-combined-method-memoization
  (make-hash-table :test #'equal :weakness 'value)
  "Table storing previously built combined-methods.
This is particularly useful when many different tags select the same set
of methods, since this table then allows us to share a single combined-method
for all those different tags in the method-cache.")

501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525
(define-error 'cl--generic-cyclic-definition "Cyclic definition: %S")

(defun cl--generic-build-combined-method (generic methods)
  (if (null methods)
      ;; Special case needed to fix a circularity during bootstrap.
      (cl--generic-standard-method-combination generic methods)
    (let ((f
           (cl--generic-with-memoization
               ;; FIXME: Since the fields of `generic' are modified, this
               ;; hash-table won't work right, because the hashes will change!
               ;; It's not terribly serious, but reduces the effectiveness of
               ;; the table.
               (gethash (cons generic methods)
                        cl--generic-combined-method-memoization)
             (puthash (cons generic methods) :cl--generic--under-construction
                      cl--generic-combined-method-memoization)
             (condition-case nil
                 (cl-generic-combine-methods generic methods)
               ;; Special case needed to fix a circularity during bootstrap.
               (cl--generic-cyclic-definition
                (cl--generic-standard-method-combination generic methods))))))
      (if (eq f :cl--generic--under-construction)
          (signal 'cl--generic-cyclic-definition
                  (list (cl--generic-name generic)))
        f))))
526

527
(defun cl--generic-no-next-method-function (generic method)
528
  (lambda (&rest args)
529
    (apply #'cl-no-next-method generic method args)))
530

531
(defun cl-generic-call-method (generic method &optional fun)
532 533 534
  "Return a function that calls METHOD.
FUN is the function that should be called when METHOD calls
`call-next-method'."
535 536 537 538
  (if (not (cl--generic-method-uses-cnm method))
      (cl--generic-method-function method)
    (let ((met-fun (cl--generic-method-function method))
          (next (or fun (cl--generic-no-next-method-function
539
                         generic method))))
540 541 542 543 544 545 546 547 548 549
      (lambda (&rest args)
        (apply met-fun
               ;; FIXME: This sucks: passing just `next' would
               ;; be a lot more efficient than the lambda+apply
               ;; quasi-η, but we need this to implement the
               ;; "if call-next-method is called with no
               ;; arguments, then use the previous arguments".
               (lambda (&rest cnm-args)
                 (apply next (or cnm-args args)))
               args)))))
550

551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661
;; Standard CLOS name.
(defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers)

(defun cl--generic-standard-method-combination (generic methods)
  (let ((mets-by-qual ()))
    (dolist (method methods)
      (let ((qualifiers (cl-method-qualifiers method)))
        (if (eq (car qualifiers) :extra) (setq qualifiers (cddr qualifiers)))
        (unless (member qualifiers '(() (:after) (:before) (:around)))
          (error "Unsupported qualifiers in function %S: %S"
                 (cl--generic-name generic) qualifiers))
        (push method (alist-get (car qualifiers) mets-by-qual))))
    (cond
     ((null mets-by-qual)
      (lambda (&rest args)
        (apply #'cl-no-applicable-method generic args)))
     ((null (alist-get nil mets-by-qual))
      (lambda (&rest args)
        (apply #'cl-no-primary-method generic args)))
     (t
      (let* ((fun nil)
             (ab-call (lambda (m) (cl-generic-call-method generic m)))
             (before
              (mapcar ab-call (reverse (cdr (assoc :before mets-by-qual)))))
             (after (mapcar ab-call (cdr (assoc :after mets-by-qual)))))
        (dolist (method (cdr (assoc nil mets-by-qual)))
          (setq fun (cl-generic-call-method generic method fun)))
        (when (or after before)
          (let ((next fun))
            (setq fun (lambda (&rest args)
                        (dolist (bf before)
                          (apply bf args))
                        (prog1
                            (apply next args)
                          (dolist (af after)
                            (apply af args)))))))
        (dolist (method (cdr (assoc :around mets-by-qual)))
          (setq fun (cl-generic-call-method generic method fun)))
        fun)))))

(defun cl--generic-cache-miss (generic
                               dispatch-arg dispatches-left methods-left types)
  (let ((methods '()))
    (dolist (method methods-left)
      (let* ((specializer (or (nth dispatch-arg
                                   (cl--generic-method-specializers method))
                              t))
             (m (member specializer types)))
        (when m
          (push (cons (length m) method) methods))))
    ;; Sort the methods, most specific first.
    ;; It would be tempting to sort them once and for all in the method-table
    ;; rather than here, but the order might depend on the actual argument
    ;; (e.g. for multiple inheritance with defclass).
    (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
    (cl--generic-make-next-function generic dispatches-left methods)))

(cl-defgeneric cl-generic-generalizers (specializer)
  "Return a list of generalizers for a given SPECIALIZER.
To each kind of `specializer', corresponds a `generalizer' which describes
how to extract a \"tag\" from an object which will then let us check if this
object matches the specializer.  A typical example of a \"tag\" would be the
type of an object.  It's called a `generalizer' because it
takes a specific object and returns a more general approximation,
denoting a set of objects to which it belongs.
A generalizer gives us the chunk of code which the
dispatch function needs to use to extract the \"tag\" of an object, as well
as a function which turns this tag into an ordered list of
`specializers' that this object matches.
The code which extracts the tag should be as fast as possible.
The tags should be chosen according to the following rules:
- The tags should not be too specific: similar objects which match the
  same list of specializers should ideally use the same (`eql') tag.
  This insures that the cached computation of the applicable
  methods for one object can be reused for other objects.
- Corollary: objects which don't match any of the relevant specializers
  should ideally all use the same tag (typically nil).
  This insures that this cache does not grow unnecessarily large.
- Two different generalizers G1 and G2 should not use the same tag
  unless they use it for the same set of objects.  IOW, if G1.tag(X1) =
  G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2).
- If G1.priority > G2.priority and G1.tag(X1) = G1.tag(X2) and this tag is
  non-nil, then you have to make sure that the G2.tag(X1) = G2.tag(X2).
  This is because the method-cache is only indexed with the first non-nil
  tag (by order of decreasing priority).")


(cl-defgeneric cl-generic-combine-methods (generic methods)
  "Build the effective method made of METHODS.
It should return a function that expects the same arguments as the methods, and
 calls those methods in some appropriate order.
GENERIC is the generic function (mostly used for its name).
METHODS is the list of the selected methods.
The METHODS list is sorted from most specific first to most generic last.
The function can use `cl-generic-call-method' to create functions that call those
methods.")

;; Temporary definition to let the next defmethod succeed.
(fset 'cl-generic-generalizers
      (lambda (_specializer) (list cl--generic-t-generalizer)))
(fset 'cl-generic-combine-methods
      #'cl--generic-standard-method-combination)

(cl-defmethod cl-generic-generalizers (specializer)
  "Support for the catch-all `t' specializer."
  (if (eq specializer t) (list cl--generic-t-generalizer)
    (error "Unknown specializer %S" specializer)))

(cl-defmethod cl-generic-combine-methods (generic methods)
  "Standard support for :after, :before, :around, and `:extra NAME' qualifiers."
  (cl--generic-standard-method-combination generic methods))
662

663
(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t))
664 665
(defconst cl--generic-cnm-sample
  (funcall (cl--generic-build-combined-method
666
            nil (list (cl--generic-make-method () () t #'identity)))))
667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693

(defun cl--generic-isnot-nnm-p (cnm)
  "Return non-nil if CNM is the function that calls `cl-no-next-method'."
  ;; ¡Big Gross Ugly Hack!
  ;; `next-method-p' just sucks, we should let it die.  But EIEIO did support
  ;; it, and some packages use it, so we need to support it.
  (catch 'found
    (cl-assert (function-equal cnm cl--generic-cnm-sample))
    (if (byte-code-function-p cnm)
        (let ((cnm-constants (aref cnm 2))
              (sample-constants (aref cl--generic-cnm-sample 2)))
          (dotimes (i (length sample-constants))
            (when (function-equal (aref sample-constants i)
                                  cl--generic-nnm-sample)
              (throw 'found
                     (not (function-equal (aref cnm-constants i)
                                          cl--generic-nnm-sample))))))
      (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample)))
      (let ((cnm-env (cadr cnm)))
        (dolist (vb (cadr cl--generic-cnm-sample))
          (when (function-equal (cdr vb) cl--generic-nnm-sample)
            (throw 'found
                   (not (function-equal (cdar cnm-env)
                                        cl--generic-nnm-sample))))
          (setq cnm-env (cdr cnm-env)))))
    (error "Haven't found no-next-method-sample in cnm-sample")))

694 695 696 697
;;; Define some pre-defined generic functions, used internally.

(define-error 'cl-no-method "No method for %S")
(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 700 701 702
(define-error 'cl-no-applicable-method "No applicable method for %S"
  'cl-no-method)

(cl-defgeneric cl-no-next-method (generic method &rest args)
703 704
  "Function called when `cl-call-next-method' finds no next method."
  (signal 'cl-no-next-method `(,(cl--generic-name generic) ,method ,@args)))
705 706

(cl-defgeneric cl-no-applicable-method (generic &rest args)
707 708
  "Function called when a method call finds no applicable method."
  (signal 'cl-no-applicable-method `(,(cl--generic-name generic) ,@args)))
709

710
(cl-defgeneric cl-no-primary-method (generic &rest args)
711 712
  "Function called when a method call finds no primary method."
  (signal 'cl-no-primary-method `(,(cl--generic-name generic) ,@args)))
713

714 715 716 717 718
(defun cl-call-next-method (&rest _args)
  "Function to call the next applicable method.
Can only be used from within the lexical body of a primary or around method."
  (error "cl-call-next-method only allowed inside primary and around methods"))

719 720 721 722 723 724
(defun cl-next-method-p ()
  "Return non-nil if there is a next method.
Can only be used from within the lexical body of a primary or around method."
  (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1"))
  (error "cl-next-method-p only allowed inside primary and around methods"))

725 726 727 728 729 730 731 732
;;;###autoload
(defun cl-find-method (generic qualifiers specializers)
  (car (cl--generic-member-method
        specializers qualifiers
        (cl--generic-method-table (cl--generic generic)))))

(defalias 'cl-method-qualifiers 'cl--generic-method-qualifiers)

733 734
;;; Add support for describe-function

735 736
(defun cl--generic-search-method (met-name)
  (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+"
737 738
                         (regexp-quote (format "%s" (car met-name)))
			 "\\_>")))
739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756
    (or
     (re-search-forward
      (concat base-re "[^&\"\n]*"
              (mapconcat (lambda (specializer)
                           (regexp-quote
                            (format "%S" (if (consp specializer)
                                             (nth 1 specializer) specializer))))
                         (remq t (cdr met-name))
                         "[ \t\n]*)[^&\"\n]*"))
      nil t)
     (re-search-forward base-re nil t))))


(with-eval-after-load 'find-func
  (defvar find-function-regexp-alist)
  (add-to-list 'find-function-regexp-alist
               `(cl-defmethod . ,#'cl--generic-search-method)))

757
(defun cl--generic-method-info (method)
758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781
  (let* ((specializers (cl--generic-method-specializers method))
         (qualifiers   (cl--generic-method-qualifiers method))
         (uses-cnm     (cl--generic-method-uses-cnm method))
         (function     (cl--generic-method-function method))
         (args (help-function-arglist function 'names))
         (docstring (documentation function))
         (qual-string
          (if (null qualifiers) ""
            (cl-assert (consp qualifiers))
            (let ((s (prin1-to-string qualifiers)))
              (concat (substring s 1 -1) " "))))
         (doconly (if docstring
                      (let ((split (help-split-fundoc docstring nil)))
                        (if split (cdr split) docstring))))
         (combined-args ()))
    (if uses-cnm (setq args (cdr args)))
    (dolist (specializer specializers)
      (let ((arg (if (eq '&rest (car args))
                     (intern (format "arg%d" (length combined-args)))
                   (pop args))))
        (push (if (eq specializer t) arg (list arg specializer))
              combined-args)))
    (setq combined-args (append (nreverse combined-args) args))
    (list qual-string combined-args doconly)))
782

783
(add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
784 785 786
(defun cl--generic-describe (function)
  (let ((generic (if (symbolp function) (cl--generic function))))
    (when generic
787
      (require 'help-mode)              ;Needed for `help-function-def' button!
788 789 790 791
      (save-excursion
        (insert "\n\nThis is a generic function.\n\n")
        (insert (propertize "Implementations:\n\n" 'face 'bold))
        ;; Loop over fanciful generics
792 793
        (dolist (method (cl--generic-method-table generic))
          (let* ((info (cl--generic-method-info method)))
794
            ;; FIXME: Add hyperlinks for the types as well.
795 796 797
            (insert (format "%s%S" (nth 0 info) (nth 1 info)))
            (let* ((met-name (cons function
                                   (cl--generic-method-specializers method)))
798 799 800 801 802 803 804
                   (file (find-lisp-object-file-name met-name 'cl-defmethod)))
              (when file
                (insert " in `")
                (help-insert-xref-button (help-fns-short-filename file)
                                         'help-function-def met-name file
                                         'cl-defmethod)
                (insert "'.\n")))
805
            (insert "\n" (or (nth 2 info) "Undocumented") "\n\n")))))))
806

807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841
;;; Support for (head <val>) specializers.

;; For both the `eql' and the `head' specializers, the dispatch
;; is unsatisfactory.  Basically, in the "common&fast case", we end up doing
;;
;;    (let ((tag (gethash value <tagcode-hashtable>)))
;;      (funcall (gethash tag <method-cache>)))
;;
;; whereas we'd like to just do
;;
;;      (funcall (gethash value <method-cache>)))
;;
;; but the problem is that the method-cache is normally "open ended", so
;; a nil means "not computed yet" and if we bump into it, we dutifully fill the
;; corresponding entry, whereas we'd want to just fallback on some default
;; effective method (so as not to fill the cache with lots of redundant
;; entries).

(defvar cl--generic-head-used (make-hash-table :test #'eql))

(defconst cl--generic-head-generalizer
  (cl-generic-make-generalizer
   80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used))
   (lambda (tag) (if (eq (car-safe tag) 'head) (list tag)))))

(cl-defmethod cl-generic-generalizers :extra "head" (specializer)
  "Support for the `(head VAL)' specializers."
  ;; We have to implement `head' here using the :extra qualifier,
  ;; since we can't use the `head' specializer to implement itself.
  (if (not (eq (car-safe specializer) 'head))
      (cl-call-next-method)
    (cl--generic-with-memoization
        (gethash (cadr specializer) cl--generic-head-used) specializer)
    (list cl--generic-head-generalizer)))

842 843 844 845
;;; Support for (eql <val>) specializers.

(defvar cl--generic-eql-used (make-hash-table :test #'eql))

846 847 848 849
(defconst cl--generic-eql-generalizer
  (cl-generic-make-generalizer
   100 (lambda (name) `(gethash ,name cl--generic-eql-used))
   (lambda (tag) (if (eq (car-safe tag) 'eql) (list tag)))))
850

851 852 853 854
(cl-defmethod cl-generic-generalizers ((specializer (head eql)))
  "Support for the `(eql VAL)' specializers."
  (puthash (cadr specializer) specializer cl--generic-eql-used)
  (list cl--generic-eql-generalizer))
855 856 857

;;; Support for cl-defstructs specializers.

858 859 860 861 862 863 864
(defun cl--generic-struct-tag (name)
  `(and (vectorp ,name)
        (> (length ,name) 0)
        (let ((tag (aref ,name 0)))
          (if (eq (symbol-function tag) :quick-object-witness-check)
              tag))))

865
(defun cl--generic-struct-specializers (tag)
866 867 868 869
  (and (symbolp tag)
       ;; A method call shouldn't itself mess with the match-data.
       (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag))
       (let ((types (list (intern (substring (symbol-name tag) 10)))))
870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904
	 (while (get (car types) 'cl-struct-include)
	   (push (get (car types) 'cl-struct-include) types))
	 (push 'cl-structure-object types) ;The "parent type" of all cl-structs.
	 (nreverse types))))

(defconst cl--generic-struct-generalizer
  (cl-generic-make-generalizer
   50 #'cl--generic-struct-tag
   #'cl--generic-struct-specializers))

(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
  "Support for dispatch on cl-struct types."
  (or
   (and (symbolp type)
        (get type 'cl-struct-type)
        (or (null (car (get type 'cl-struct-type)))
            (error "Can't dispatch on cl-struct %S: type is %S"
                   type (car (get type 'cl-struct-type))))
        (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots)))
            (error "Can't dispatch on cl-struct %S: no tag in slot 0"
                   type))
        ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
        ;; but that would suffer from some problems:
        ;; - the vector may have size 0.
        ;; - when called on an actual vector (rather than an object), we'd
        ;;   end up returning an arbitrary value, possibly colliding with
        ;;   other tagcode's values.
        ;; - it can also result in returning all kinds of irrelevant
        ;;   values which would end up filling up the method-cache with
        ;;   lots of irrelevant/redundant entries.
        ;; FIXME: We could speed this up by introducing a dedicated
        ;; vector type at the C level, so we could do something like
        ;; (and (vector-objectp ,name) (aref ,name 0))
        (list cl--generic-struct-generalizer))
   (cl-call-next-method)))
905

906
;;; Dispatch on "system types".
907 908 909

(defconst cl--generic-typeof-types
  ;; Hand made from the source code of `type-of'.
910
  '((integer number) (symbol) (string array sequence) (cons list sequence)
911 912 913
    ;; Markers aren't `numberp', yet they are accepted wherever integers are
    ;; accepted, pretty much.
    (marker) (overlay) (float number) (window-configuration)
914 915 916
    (process) (window) (subr) (compiled-function) (buffer)
    (char-table array sequence)
    (bool-vector array sequence)
917
    (frame) (hash-table) (font-spec) (font-entity) (font-object)
918
    (vector array sequence)
919
    ;; Plus, hand made:
920 921 922 923
    (null symbol list sequence)
    (list sequence)
    (array sequence)
    (sequence)
924 925
    (number)))

926 927 928 929 930 931 932 933
(defconst cl--generic-typeof-generalizer
  (cl-generic-make-generalizer
   ;; FIXME: We could also change `type-of' to return `null' for nil.
   10 (lambda (name) `(if ,name (type-of ,name) 'null))
   (lambda (tag) (and (symbolp tag) (assq tag cl--generic-typeof-types)))))

(cl-defmethod cl-generic-generalizers :extra "typeof" (type)
  "Support for dispatch on builtin types."
934 935
  ;; FIXME: Add support for other types accepted by `cl-typep' such
  ;; as `character', `atom', `face', `function', ...
936 937 938 939 940 941 942
  (or
   (and (assq type cl--generic-typeof-types)
        (progn
          (if (memq type '(vector array sequence))
              (message "`%S' also matches CL structs and EIEIO classes" type))
          (list cl--generic-typeof-generalizer)))
   (cl-call-next-method)))
943 944 945 946 947 948 949 950 951

;;; Just for kicks: dispatch on major-mode
;;
;; Here's how you'd use it:
;;   (cl-defmethod foo ((x (major-mode text-mode)) y z) ...)
;; And then
;;     (foo 'major-mode toto titi)
;;
;; 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)) ...)
953 954 955

;; (defvar cl--generic-major-modes (make-hash-table :test #'eq))
;;
956
;; (add-function :before-until cl-generic-generalizer-function
957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983
;;               #'cl--generic-major-mode-tagcode)
;; (defun cl--generic-major-mode-tagcode (type name)
;;   (if (eq 'major-mode (car-safe type))
;;       `(50 . (if (eq ,name 'major-mode)
;;                  (cl--generic-with-memoization
;;                      (gethash major-mode cl--generic-major-modes)
;;                    `(cl--generic-major-mode . ,major-mode))))))
;;
;; (add-function :before-until cl-generic-tag-types-function
;;               #'cl--generic-major-mode-types)
;; (defun cl--generic-major-mode-types (tag)
;;   (when (eq (car-safe tag) 'cl--generic-major-mode)
;;     (if (eq tag 'fundamental-mode) '(fundamental-mode t)
;;       (let ((types `((major-mode ,(cdr tag)))))
;;         (while (get (car types) 'derived-mode-parent)
;;           (push (list 'major-mode (get (car types) 'derived-mode-parent))
;;                 types))
;;         (unless (eq 'fundamental-mode (car types))
;;           (push '(major-mode fundamental-mode) types))
;;         (nreverse types)))))

;; Local variables:
;; generated-autoload-file: "cl-loaddefs.el"
;; End:

(provide 'cl-generic)
;;; cl-generic.el ends here