Function: cl--transform-lambda

cl--transform-lambda is a byte-compiled function defined in cl-macs.el.gz.

Signature

(cl--transform-lambda FORM BIND-BLOCK)

Documentation

Transform a function form FORM of name BIND-BLOCK.

BIND-BLOCK is the name of the symbol to which the function will be bound, and which will be used for the name of the cl-block surrounding the function's body. FORM is of the form (ARGS . BODY).

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/cl-macs.el.gz
(defun cl--transform-lambda (form bind-block)
  "Transform a function form FORM of name BIND-BLOCK.
BIND-BLOCK is the name of the symbol to which the function will be bound,
and which will be used for the name of the `cl-block' surrounding the
function's body.
FORM is of the form (ARGS . BODY)."
  (let* ((args (car form)) (body (cdr form)) (orig-args args)
	 (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
         (parsed-body (macroexp-parse-body body))
	 (header (car parsed-body)) (simple-args nil))
    (setq body (cdr parsed-body))
    ;; "(. X) to (&rest X)" conversion already done in cl--do-arglist, but we
    ;; do it here as well, so as to be able to see if we can avoid
    ;; cl--do-arglist.
    (setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
    (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
    (let ((cl-defs (memq '&cl-defs args)))
      (when cl-defs
        (setq cl--bind-defs (cadr cl-defs))
	;; Remove "&cl-defs DEFS" from args.
        (setcdr cl-defs (cddr cl-defs))
	(setq args (delq '&cl-defs args))))
    (if (setq cl--bind-enquote (memq '&cl-quote args))
	(setq args (delq '&cl-quote args)))
    (if (memq '&whole args) (error "&whole not currently implemented"))
    (let* ((p (memq '&environment args))
           (v (cadr p)))
      (if p (setq args (nconc (delq (car p) (delq v args))
                              `(&aux (,v macroexpand-all-environment))))))
    ;; Take away all the simple args whose parsing can be handled more
    ;; efficiently by a plain old `lambda' than the manual parsing generated
    ;; by `cl--do-arglist'.
    (let ((optional nil))
      (while (and args (symbolp (car args))
                  (not (memq (car args) '(nil &rest &body &key &aux)))
                  (or (not optional)
                      ;; Optional args whose default is nil are simple.
                      (null (nth 1 (assq (car args) (cdr cl--bind-defs)))))
                  (not (and (eq (car args) '&optional) (setq optional t)
                            (car cl--bind-defs))))
        (push (pop args) simple-args))
      (when optional
        (if args (push '&optional args))
        ;; Don't keep a dummy trailing &optional without actual optional args.
        (if (eq '&optional (car simple-args)) (pop simple-args))))
    (or (eq cl--bind-block 'cl-none)
	(setq body (list `(cl-block ,cl--bind-block ,@body))))
    (let* ((cl--bind-lets nil) (cl--bind-forms nil)
           (rest-args
            (cond
             ((null args) nil)
             ((eq (car args) '&aux)
              (cl--do-&aux args)
              (setq cl--bind-lets (nreverse cl--bind-lets))
              nil)
             (t ;; `simple-args' doesn't handle all the parsing that we need,
              ;; so we pass the rest to cl--do-arglist which will do
              ;; "manual" parsing.
              (let ((slen (length simple-args))
                    (usage-str
                      ;; Macro expansion can take place in the middle of
                      ;; apparently harmless computation, so it should not
                      ;; touch the match-data.
                      (save-match-data
                        (help--docstring-quote
                         (let ((print-gensym nil) (print-quoted t)
                               (print-escape-newlines t))
                           (format "%S" (cons 'fn (cl--make-usage-args
                                                   orig-args))))))))
                (when (memq '&optional simple-args)
                  (cl-decf slen))
                (setq header
                      (cons
                       (if (eq :documentation (car-safe (car header)))
                           `(:documentation (help-add-fundoc-usage
                                             ,(cadr (pop header))
                                             ,usage-str))
                         (help-add-fundoc-usage
                          (if (stringp (car header)) (pop header))
                          ;; Be careful with make-symbol and (back)quote,
                          ;; see bug#12884.
                          usage-str))
                       header))
                ;; FIXME: we'd want to choose an arg name for the &rest param
                ;; and pass that as `expr' to cl--do-arglist, but that ends up
                ;; generating code with a redundant let-binding, so we instead
                ;; pass a dummy and then look in cl--bind-lets to find what var
                ;; this was bound to.
                (cl--do-arglist args :dummy slen)
                (setq cl--bind-lets (nreverse cl--bind-lets))
                ;; (cl-assert (eq :dummy (nth 1 (car cl--bind-lets))))
                (list '&rest (car (pop cl--bind-lets))))))))
      `((,@(nreverse simple-args) ,@rest-args)
        ,@header
        ;; Function arguments are unconditionally statically scoped (bug#47552).
        ,(cl--slet* cl--bind-lets
                    (macroexp-progn
                     `(,@(nreverse cl--bind-forms)
                       ,@body)))))))