Function: cl--generic-get-dispatcher

cl--generic-get-dispatcher is a byte-compiled function defined in cl-generic.el.gz.

Signature

(cl--generic-get-dispatcher DISPATCH)

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/cl-generic.el.gz
(defun cl--generic-get-dispatcher (dispatch)
  (cl--generic-with-memoization
      ;; We need `copy-sequence` here because this `dispatch' object might be
      ;; modified by side-effect in `cl-generic-define-method' (bug#46722).
      (gethash (copy-sequence dispatch) cl--generic-dispatchers)
    ;; (message "cl--generic-get-dispatcher (%S)" dispatch)
    (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)))
           (fixedargs '(arg))
           (dispatch-idx dispatch-arg)
           (bindings nil))
      (when (eq '&context (car-safe dispatch-arg))
        (setq bindings `((arg ,(cdr dispatch-arg))))
        (setq fixedargs nil)
        (setq dispatch-idx 0))
      (dotimes (i dispatch-idx)
        (push (make-symbol (format "arg%d" (- dispatch-idx i 1))) fixedargs))
      ;; 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.
      (byte-compile
       `(lambda (generic dispatches-left methods)
          (let ((method-cache (make-hash-table :test #'eql)))
            (lambda (,@fixedargs &rest args)
              (let ,bindings
                (apply (cl--generic-with-memoization
                           (gethash ,tag-exp method-cache)
                         (cl--generic-cache-miss
                          generic ',dispatch-arg dispatches-left methods
                          ,(if (cdr typescodes)
                               `(append ,@typescodes) (car typescodes))))
                       ,@fixedargs args)))))))))