#+title: Improving cl-flet in Emacs 29: Local setf solution by Stefan Monnier
#+author: =#<PERSON akater A24961DE3ADD04E057ADCF4599555CE6F2E1B21D>=
#+property: header-args :lexical t
#+startup: nologdone show2levels
#+todo: TEST-FAILED(f) | TEST-PASSED(p)

* Definition
#+begin_src emacs-lisp :results none
(defmacro cl-flet (bindings &rest body)
  "Make local function definitions.
Each definition can take the form (FUNC EXP) where
FUNC is the function name, and EXP is an expression that returns the
function value to which it should be bound, or it can take the more common
form (FUNC ARGLIST BODY...) which is a shorthand
for (FUNC (lambda ARGLIST BODY)).

FUNC is defined only within FORM, not BODY, so you can't write
recursive function definitions.  Use `cl-labels' for that.  See
info node `(cl) Function Bindings' for details.

\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
  (declare (indent 1)
           (debug ((&rest [&or (&define name function-form) (cl-defun)])
                   cl-declarations body)))
  (let ((binds ()) (newenv macroexpand-all-environment))
    (dolist (binding bindings)
      (let ((var (make-symbol (format "--cl-%s--" (car binding))))
            (fname (car binding))
            (args-and-body (cdr binding)))
        (if (eq 'setf (car-safe fname))
            (setq fname (gv-setter (cadr fname))))
        (if (and (= (length args-and-body) 1) (symbolp (car args-and-body)))
            ;; Optimize (cl-flet ((fun var)) body).
            (setq var (car args-and-body))
          (push (list var (if (= (length args-and-body) 1)
                              (car args-and-body)
                            `(cl-function (lambda . ,args-and-body))))
                binds))
	(push (cons fname
                    (lambda (&rest args)
                      (if (eq (car args) cl--labels-magic)
                          (list cl--labels-magic var)
                        `(funcall ,var ,@args))))
              newenv)))
    ;; FIXME: Eliminate those functions which aren't referenced.
    (macroexp-let* (nreverse binds)
                   (macroexpand-all
                    `(progn ,@body)
                    ;; Don't override lexical-let's macro-expander.
                    (if (assq 'function newenv) newenv
                      (cons (cons 'function #'cl--labels-convert) newenv))))))
#+end_src

* Tests
** TEST-FAILED setf with #'(setf ..) in body
The difference in ~(let ((setf-arg-0 t)) ..)~ is irrelevant, what's relevant is, ~#'(setf kar)~ is not recognized.
#+begin_src emacs-lisp :tangle no :results code :wrap example emacs-lisp
(macroexpand-1
 `(cl-flet (((setf kar) (new) 'just-an-example))
    (setf (kar) t)
    (funcall #'(setf kar) t)))
#+end_src

#+RESULTS:
#+begin_example emacs-lisp
(let*
    ((--cl-\(setf\ kar\)--
      (cl-function
       (lambda
         (new)
         'just-an-example))))
  (progn
    (funcall --cl-\(setf\ kar\)-- t)
    (funcall
     #'(setf kar)
     t)))
#+end_example

#+EXPECTED:
#+begin_example emacs-lisp
(let*
    ((--cl-\(setf\ kar\)--
      (cl-function
       (lambda
         (new)
         'just-an-example))))
  (progn
    (let
        ((setf-arg-0 t))
      (funcall --cl-\(setf\ kar\)-- setf-arg-0))
    (funcall --cl-\(setf\ kar\)-- t)))
#+end_example

** TEST-FAILED non-setf local function within (setf ..) local function
#+begin_src emacs-lisp :tangle no :results code :wrap example emacs-lisp
(condition-case err
    (let ((x (cons (cons nil nil) nil)))
      (cl-flet ((kar (x) (car x))
                ((setf kar) (new cons) (setf (car cons) new)))
        (setf (kar (kar x)) t))
      x)
  (t err))
#+end_src

#+RESULTS:
#+begin_example emacs-lisp
(void-function \(setf\ funcall\))
#+end_example

#+EXPECTED:
#+begin_example emacs-lisp
((t))
#+end_example

** TEST-FAILED Local setf function within local non-setf function within local setf function
#+begin_src emacs-lisp :tangle no :results code :wrap example emacs-lisp
(condition-case err
    (let ((x (cons (cons nil nil) nil))
          (y (cons (cons nil nil) nil)))
      (cl-flet ((kar (x) (car x))
                ((setf kar) (new cons) (setf (car cons) new)))
        (setf (kar (kar (setf (kar y) x))) t))
      (cl-values x y))
  (t err))
#+end_src

#+RESULTS:
#+begin_example emacs-lisp
(void-function \(setf\ funcall\))
#+end_example

#+EXPECTED:
#+begin_example emacs-lisp
(((t))
 (((t))))
#+end_example

** TEST-FAILED Eponymous local macro, local function and its setf, local macro, local function
#+begin_src emacs-lisp :tangle no :results code :wrap example emacs-lisp
(condition-case err
    (let (result)
      (cl-macrolet ((f (x) ``(f1 ,,x)))
        (push (f 0) result)
        (cl-flet ((f (x) `(f2 ,x))
        ((setf f) (new x) (f (list x new))))
          (push (f 1) result)
          (push (setf (f (f (setf (f 2) 3))) (f 4)) result)
          (cl-macrolet ((f (x) `(car (list `(f3 ,,x)))))
            (push (f 5) result)
            (push (setf (f (f (f 6))) (f 8)) result)
            (cl-flet ((f (x) `(f4 ,x)))
              (push (f 9) result)
              (push (setf (f (f (setf (f 10) 11))) (f 12)) result)))))
      result)
  (t err))
#+end_src

#+RESULTS:
#+begin_example emacs-lisp
(void-function \(setf\ funcall\))
#+end_example

#+EXPECTED:
#+begin_example emacs-lisp
((f1
  ((f4
    (f1
     (10 11)))
   (f4 12)))
 (f4 9)
 (f3 8)
 (f3 5)
 (f1
  ((f2
    (f1
     (2 3)))
   (f2 4)))
 (f2 1)
 (f1 0))
#+end_example