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)
  (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)

    (when (and purify-flag ;FIXME: Is this a reliable test of the final dump?
               (eq cl--generic-compiler #'byte-compile))
      ;; We don't want to preload the byte-compiler!!
      (error
       "Missing cl-generic dispatcher in the prefilled cache!
Missing for: %S
You might need to add: %S"
       (mapcar (lambda (x) (if (cl--generic-generalizer-p x)
                          (cl--generic-generalizer-name x)
                        x))
               dispatch)
       `(cl--generic-prefill-dispatchers
         ,@(delq nil (mapcar #'cl--generic-prefill-generalizer-sample
                             dispatch)))))

    ;; (message "cl--generic-get-dispatcher (%S)" dispatch)
    (let* ((dispatch-arg (car dispatch))
           (generalizers (cdr dispatch))
           (lexical-binding t)
           (outer-bindings nil)
           (tagcodes
            (mapcar (lambda (generalizer)
                      (let ((code (funcall
                                   (cl--generic-generalizer-tagcode-function
                                    generalizer)
                                   'arg))
                            (extra-args nil))
                        (when (eq code :need-specializers)
                          (let* ((binding+code
                                  (cl--generic--tagcode-with-specializers
                                   generalizer dispatch-arg outer-bindings)))
                            (setq outer-bindings (car binding+code))
                            (setq code (cdr binding+code))
                            ;; Pass the most recent binding (which defaults to
                            ;; the list of specializers of interest) to the
                            ;; function that recovers the types from the tag,
                            ;; in case it helps.
                            (setq extra-args (list (caar outer-bindings)))))
                        `(,generalizer ,code ,@extra-args)))
                    generalizers))
           (typescodes
            (mapcar
             (lambda (gen+code+args)
               `(funcall ',(cl--generic-generalizer-specializers-function
                            (car gen+code+args))
                         ,@(cdr gen+code+args)))
             tagcodes))
           (tagcodes (mapcar #'cadr tagcodes))
           (tag-exp
            ;; Minor optimization: since this tag-exp is used only 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.
      (funcall
       cl--generic-compiler
       `(lambda (generic dispatches-left methods)
          (let* ((method-cache (make-hash-table :test #'eql))
                 ,@(nreverse outer-bindings))
            (lambda (,@fixedargs &rest args)
              (let ,bindings
                (apply (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)))))))))