Function: cl-generic-define-method

cl-generic-define-method is a byte-compiled function defined in cl-generic.el.gz.

Signature

(cl-generic-define-method NAME QUALIFIERS ARGS CALL-CON FUNCTION)

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/cl-generic.el.gz
;;;###autoload
(defun cl-generic-define-method (name qualifiers args call-con function)
  (pcase-let*
      ((generic (cl-generic-ensure-function name))
       (`(,spec-args . ,_) (cl--generic-split-args args))
       (specializers (mapcar (lambda (spec-arg)
                               (if (eq '&context (car-safe (car spec-arg)))
                                   spec-arg (cdr spec-arg)))
                             spec-args))
       (method (cl--generic-make-method
                specializers qualifiers call-con function))
       (mt (cl--generic-method-table generic))
       (me (cl--generic-member-method specializers qualifiers mt))
       (dispatches (cl--generic-dispatches generic))
       (i 0))
    (dolist (spec-arg spec-args)
      (let* ((key (if (eq '&context (car-safe (car spec-arg)))
                      (car spec-arg) i))
             (generalizers (cl-generic-generalizers (cdr spec-arg)))
             (x (assoc key dispatches)))
        (unless x
          (setq x (cons key (cl-generic-generalizers t)))
          (setf (cl--generic-dispatches generic)
                (setq dispatches (cons x dispatches))))
        (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)))))))
        (setq i (1+ i))))
    ;; We used to (setcar me method), but that can cause false positives in
    ;; the hash-consing table of the method-builder (bug#20644).
    ;; See also the related FIXME in cl--generic-build-combined-method.
    (setf (cl--generic-method-table generic)
          (if (null me)
              (cons method mt)
            ;; Keep the ordering; important for methods with :extra qualifiers.
            (mapcar (lambda (x) (if (eq x (car me)) method x)) mt)))
    (let ((sym (cl--generic-name generic)) ; Actual name (for aliases).
          ;; FIXME: Try to avoid re-constructing a new function if the old one
          ;; is still valid (e.g. still empty method cache)?
          (gfun (cl--generic-make-function generic)))
      (unless (symbol-function sym)
        (defalias sym 'dummy))   ;Record definition into load-history.
      (cl-pushnew `(cl-defmethod . ,(cl--generic-load-hist-format
                                     (cl--generic-name generic)
                                     qualifiers specializers))
                  current-load-list :test #'equal)
      (let ((old-adv-cc (get-advertised-calling-convention
                         (symbol-function sym)))
            ;; Prevent `defalias' from recording this as the definition site of
            ;; the generic function.
            current-load-list
            ;; BEWARE!  Don't purify this function definition, since that leads
            ;; to memory corruption if the hash-tables it holds are modified
            ;; (the GC doesn't trace those pointers).
            (purify-flag nil))
        (when (listp old-adv-cc)
          (set-advertised-calling-convention gfun old-adv-cc nil))
        ;; But do use `defalias', so that it interacts properly with nadvice,
        ;; e.g. for tracing/debug-on-entry.
        (defalias sym gfun)))))