Function: cl--generic-lambda

cl--generic-lambda is a function defined in cl-generic.el.gz.

Signature

(cl--generic-lambda ARGS BODY)

Documentation

Make the lambda expression for a method with ARGS and BODY.

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 (assq 'interactive body)
        (message "Interactive forms not supported in generic functions: %S"
                 (assq 'interactive body)))
      ;; 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))
                (nm (make-symbol "cl--nm"))
                (arglist (make-symbol "cl--args"))
                (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))
                (λ-lift (mapcar #'car uses-cnm)))
           (cond
            ((not uses-cnm)
             (cons nil
                   `#'(lambda (,@args)
                        ,@(car parsed-body)
                        ,nbody)))
            (lexical-binding
             (cons 'curried
                   `#'(lambda (,nm) ;Called when constructing the effective method.
                        (let ((,nmp (if (cl--generic-isnot-nnm-p ,nm)
                                        #'always #'ignore)))
                          ;; This `(λ (&rest x) .. (apply (λ (args) ..) x))'
                          ;; dance is needed because we need to get the original
                          ;; args as a list when `cl-call-next-method' is
                          ;; called with no arguments.  It's important to
                          ;; capture it as a list since it needs to distinguish
                          ;; the nil case from the absent case in optional
                          ;; arguments and it needs to properly remember the
                          ;; original value if `nbody' mutates some of its
                          ;; formal args.
                          ;; FIXME: This `(λ (&rest ,arglist)' could be skipped
                          ;; when we know `cnm' is always called with args, and
                          ;; it could be implemented more efficiently if `cnm'
                          ;; is always called directly and there are no
                          ;; `&optional' args.
                          (lambda (&rest ,arglist)
                            ,@(let* ((prebody (car parsed-body))
                                     (ds (if (stringp (car prebody))
                                             prebody
                                           (setq prebody (cons nil prebody))))
                                     (usage (help-split-fundoc (car ds) nil)))
                                (unless usage
                                  (setcar ds (help-add-fundoc-usage (car ds)
                                                                    args)))
                                prebody)
                            (let ((,cnm (lambda (&rest args)
                                          (apply ,nm (or args ,arglist)))))
                              ;; This `apply+lambda' basically parses
                              ;; `arglist' according to `args'.
                              ;; A destructuring-bind would do the trick
                              ;; as well when/if it's more efficient.
                              (apply (lambda (,@λ-lift ,@args) ,nbody)
                                     ,@λ-lift ,arglist)))))))
            (t
             (cons t
                 `#'(lambda (,cnm ,@args)
                      ,@(car parsed-body)
                      ,(macroexp-warn-and-return
                        "cl-defmethod used without lexical-binding"
                        (if (not (assq nmp uses-cnm))
                            nbody
                          `(let ((,nmp (lambda ()
                                         (cl--generic-isnot-nnm-p ,cnm))))
                             ,nbody))
                        'lexical t)))))
           ))
        (f (error "Unexpected macroexpansion result: %S" f))))))