Re: [PATCH] Some improvements for cl-flet

[akater <nuclearspace@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 2198 bytes --]

Sorry it took so long; Emacs build broke several times, an on top of
that Org is having some tectonic changes as well, and I've had my own
time trouble.

I tried the following patch.

Stefan Monnier <monnier@iro.umontreal.ca> writes:

> But that's a very minor cosmetic detail.  Either way works, I was just
> curious why you did it this way.
>
>
>         Stefan
>
>
> diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
> index 1852471bcbb..ad0477e3b68 100644
> --- a/lisp/emacs-lisp/cl-macs.el
> +++ b/lisp/emacs-lisp/cl-macs.el
> @@ -2030,7 +2030,10 @@ cl-flet
>    (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 (car-safe fname) 'setf)
> +            (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))
> @@ -2038,7 +2041,7 @@ cl-flet
>                                (car args-and-body)
>                              `(cl-function (lambda . ,args-and-body))))
>                  binds))
> -	(push (cons (car binding)
> +	(push (cons fname
>                      (lambda (&rest args)
>                        (if (eq (car args) cl--labels-magic)
>                            (list cl--labels-magic var)

Four of my tests failed which did pass for the solution I've proposed.

The first case is not even supported with global functions in Elisp so
I'm not sure how relevant it is.

Here are the summaries; the rest (results vs expected, some comments) is
attached.  I've received some complaints about my usage of Org markup in
the mailing list so details are omitted from the mail body.

** TEST-FAILED setf with #'(setf ..) in body
** TEST-FAILED non-setf local function within (setf ..) local function
** TEST-FAILED Local setf function within local non-setf function within local setf function
** TEST-FAILED Eponymous local macro, local function and its setf, local macro, local function


[-- Attachment #1.2: signature.asc --]
[-- Type: application/pgp-signature, Size: 865 bytes --]

[-- Attachment #2: Failed tests for gv-setter-based implementation of local setfs --]
[-- Type: text/plain, Size: 5434 bytes --]

#+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