Function: cl--letf

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

Signature

(cl--letf BINDINGS SIMPLEBINDS BINDS BODY)

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/cl-macs.el.gz
;; FIXME: `letf' is unsatisfactory because it does not really "restore" the
;; previous state.  If the getter/setter loses information, that info is
;; not recovered.

(defun cl--letf (bindings simplebinds binds body)
  ;; It's not quite clear what the semantics of cl-letf should be.
  ;; E.g. in (cl-letf ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear
  ;; that the actual assignments ("bindings") should only happen after
  ;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions of
  ;; PLACE1 and PLACE2 should be evaluated.  Should we have
  ;;    PLACE1; VAL1; PLACE2; VAL2; bind1; bind2
  ;; or
  ;;    VAL1; VAL2; PLACE1; PLACE2; bind1; bind2
  ;; or
  ;;    VAL1; VAL2; PLACE1; bind1; PLACE2; bind2
  ;; Common-Lisp's `psetf' does the first, so we'll do the same.
  (if (null bindings)
      (if (and (null binds) (null simplebinds)) (macroexp-progn body)
        `(let* (,@(mapcar (lambda (x)
                            (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x))
                              (list vold getter)))
                          binds)
                ,@simplebinds)
           (unwind-protect
               ,(macroexp-progn
                 (append
                  (delq nil
                        (mapcar (lambda (x)
                                  (pcase x
                                    ;; If there's no vnew, do nothing.
                                    (`(,_vold ,_getter ,setter ,vnew)
                                     (funcall setter vnew))))
                                binds))
                  body))
             ,@(mapcar (lambda (x)
                         (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x))
                           (funcall setter vold)))
                       binds))))
    (let* ((binding (car bindings))
           (place (macroexpand (car binding) macroexpand-all-environment)))
      (gv-letplace (getter setter) place
        (macroexp-let2 nil vnew (cadr binding)
          (if (symbolp place)
              ;; Special-case for simple variables.
              (cl--letf (cdr bindings)
                        (cons `(,getter ,(if (cdr binding) vnew getter))
                              simplebinds)
                        binds body)
            (cl--letf (cdr bindings) simplebinds
                      (cons `(,(make-symbol "old") ,getter ,setter
                              ,@(if (cdr binding) (list vnew)))
                            binds)
                      body)))))))