Function: cl--generic-split-args

cl--generic-split-args is a function defined in cl-generic.el.gz.

Signature

(cl--generic-split-args ARGS)

Documentation

Return (SPEC-ARGS . PLAIN-ARGS).

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/cl-generic.el.gz
(eval-and-compile         ;Needed while compiling the cl-defmethod calls below!
  (defun cl--generic-split-args (args)
    "Return (SPEC-ARGS . PLAIN-ARGS)."
    (let ((plain-args ())
          (specializers nil)
          (mandatory t))
      (dolist (arg args)
        (push (pcase arg
                ((or '&optional '&rest '&key) (setq mandatory nil) arg)
                ('&context
                 (unless mandatory
                   (error "&context not immediately after mandatory args"))
                 (setq mandatory 'context) nil)
                ((let 'nil mandatory) arg)
                ((let 'context mandatory)
                 (unless (consp arg)
                   (error "Invalid &context arg: %S" arg))
                 (let* ((name (car arg))
                        (rewriter
                         (and (symbolp name)
                              (get name 'cl-generic--context-rewriter))))
                   (if rewriter (setq arg (apply rewriter (cdr arg)))))
                 (push `((&context . ,(car arg)) . ,(cadr arg)) specializers)
                 nil)
                (`(,name . ,type)
                 (push (cons name (car type)) specializers)
                 name)
                (_
                 (push (cons arg t) specializers)
                 arg))
              plain-args))
      (cons (nreverse specializers)
            (nreverse (delq nil plain-args)))))

  (defun cl--generic-lambda (args body)
    "Make the lambda expression for a method with ARGS and BODY."
    (pcase-let* ((`(,spec-args . ,plain-args)
                  (cl--generic-split-args args))
                 (fun `(cl-function (lambda ,plain-args ,@body)))
                 (macroenv (cons `(cl-generic-current-method-specializers
                                   . ,(lambda () spec-args))
                                 macroexpand-all-environment)))
      (require 'cl-lib)        ;Needed to expand `cl-flet' and `cl-function'.
      (when (interactive-form (cadr fun))
        (message "Interactive forms unsupported in generic functions: %S"
                 (interactive-form (cadr fun))))
      ;; First macroexpand away the cl-function stuff (e.g. &key and
      ;; destructuring args, `declare' and whatnot).
      (pcase (macroexpand fun macroenv)
        (`#'(lambda ,args . ,body)
         (let* ((parsed-body (macroexp-parse-body body))
                (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))
                           ,@(cdr parsed-body))
                        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 (macroexp--fgrep `((,cnm) (,nmp)) nbody)))
           (cons (not (not uses-cnm))
                 `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
                      ,@(car parsed-body)
                      ,(if (not (assq nmp uses-cnm))
                           nbody
                         `(let ((,nmp (lambda ()
                                        (cl--generic-isnot-nnm-p ,cnm))))
                            ,nbody))))))
        (f (error "Unexpected macroexpansion result: %S" f))))))