Re: [PATCH] Some improvements for cl-flet

[akater <nuclearspace@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 54 bytes --]

And here's the actual patch which I forgot to supply.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: cl-flet improvements --]
[-- Type: text/x-diff, Size: 20822 bytes --]

From 2f045c0043de702cda8bb686635b393a2ff9f2d8 Mon Sep 17 00:00:00 2001
From: akater <nuclearspace@gmail.com>
Date: Tue, 21 Sep 2021 23:14:12 +0000
Subject: [PATCH] * lisp/emacs-lisp/cl-macs.el (cl-flet): Improved definition

Fixes the following issues with cl-flet:
- No error on illegal function names
- No error on malformed specs
- Incorrectly treated (setf ..) local functions
- No warning on duplicated definitions
- No warning on unused definitions
- No way to capture definitions present in the body

* lisp/emacs-lisp/cl-generic.el (cl--generic-with-memoization):
Move definition to cl-macs
* lisp/emacs-lisp/cl-macs.el
(cl--expand-flet): New function for more robust cl-flet definition and
more featureful expansion
(cl--with-memoization): Move definition from cl-generic
(cl--flet-convert-with-setf, cl--valid-function-name-symbol-p,
cl--check-function-name, cl--valid-let-symbol-p,
cl--call-flet-expander, cl--expand-local-setf): New function to
accomodate cl--expand-flet
(with--cl-flet-macroexp): New macro to accomodate cl--expand-flet
(cl--flet-convert-with-setf-cache, cl--local-setf-expanders): New
variable to accomodate cl--expand-flet
---
 lisp/emacs-lisp/cl-generic.el |  12 +-
 lisp/emacs-lisp/cl-macs.el    | 335 +++++++++++++++++++++++++++++++---
 2 files changed, 317 insertions(+), 30 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 1640975b84..39e38e29fa 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -98,7 +98,7 @@
 ;; usually be simplified, or even completely skipped.
 
 (eval-when-compile (require 'cl-lib))
-(eval-when-compile (require 'cl-macs))  ;For cl--find-class.
+(eval-when-compile (require 'cl-macs))  ;For cl--find-class, with-memoization.
 (eval-when-compile (require 'pcase))
 
 (cl-defstruct (cl--generic-generalizer
@@ -589,7 +589,7 @@ defalias sym 'dummy))   ;Record definition into load-history.
         ;; e.g. for tracing/debug-on-entry.
         (defalias sym gfun)))))
 
-(defmacro cl--generic-with-memoization (place &rest code)
+(defmacro cl--with-memoization (place &rest code)
   (declare (indent 1) (debug t))
   (gv-letplace (getter setter) place
     `(or ,getter
@@ -601,7 +601,7 @@ defmacro cl--generic-with-memoization (place &rest code)
 (defvar cl--generic-dispatchers (make-hash-table :test #'equal))
 
 (defun cl--generic-get-dispatcher (dispatch)
-  (cl--generic-with-memoization
+  (cl--with-memoization
       (gethash dispatch cl--generic-dispatchers)
     ;; (message "cl--generic-get-dispatcher (%S)" dispatch)
     (let* ((dispatch-arg (car dispatch))
@@ -647,7 +647,7 @@ defun cl--generic-get-dispatcher (dispatch)
           (let ((method-cache (make-hash-table :test #'eql)))
             (lambda (,@fixedargs &rest args)
               (let ,bindings
-                (apply (cl--generic-with-memoization
+                (apply (cl--with-memoization
                            (gethash ,tag-exp method-cache)
                          (cl--generic-cache-miss
                           generic ',dispatch-arg dispatches-left methods
@@ -691,7 +691,7 @@ defun cl--generic-build-combined-method (generic methods)
       ;; Special case needed to fix a circularity during bootstrap.
       (cl--generic-standard-method-combination generic methods)
     (let ((f
-           (cl--generic-with-memoization
+           (cl--with-memoization
                ;; FIXME: Since the fields of `generic' are modified, this
                ;; hash-table won't work right, because the hashes will change!
                ;; It's not terribly serious, but reduces the effectiveness of
@@ -1140,7 +1140,7 @@ defvar cl--generic-head-used (make-hash-table :test #'eql))
   ;; since we can't use the `head' specializer to implement itself.
   (if (not (eq (car-safe specializer) 'head))
       (cl-call-next-method)
-    (cl--generic-with-memoization
+    (cl--with-memoization
         (gethash (cadr specializer) cl--generic-head-used)
       specializer)
     (list cl--generic-head-generalizer)))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 6d6482c349..ecbe8e86fc 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2004,6 +2004,282 @@ defun cl--labels-convert (f)
           (setq cl--labels-convert-cache (cons f res))
           res))))))
 
+(defvar cl--flet-convert-with-setf-cache nil
+  "Like `cl--labels-convert-cache' but for local setf functions.")
+
+(defun cl--flet-convert-with-setf (f)
+  "Special macro-expander to rename (function F) references in `cl-flet', including (function (setf F)).
+
+See also `cl--labels-convert'."
+  ;; Note: If this function, or `cl--labels-convert', for that matter,
+  ;; is redefined at runtime,
+  ;; the whole replacement mechanism breaks!
+  (if (and (consp f) (eq 'setf (car f)))
+      (cond
+       ;; We repeat lots of code from `cl--labels-convert'
+       ((eq (cadr f) (car cl--flet-convert-with-setf-cache))
+        (cdr cl--flet-convert-with-setf-cache))
+       (t
+        (let* ((found (assoc f macroexpand-all-environment #'equal))
+               (replacement (and found
+                                 (ignore-errors
+                                   (funcall (cdr found) cl--labels-magic)))))
+          (if (and replacement (eq cl--labels-magic (car replacement)))
+              (nth 1 replacement)
+            (let ((res `(function ,f)))
+              (setq cl--flet-convert-with-setf-cache (cons (cadr f) res))
+              res)))))
+    (cl--labels-convert f)))
+
+(defmacro cl--with-memoization (place &rest code)
+  (declare (indent 1) (debug t))
+  (gv-letplace (getter setter) place
+    `(or ,getter
+         ,(macroexp-let2 nil val (macroexp-progn code)
+            `(progn
+               ,(funcall setter val)
+               ,val)))))
+
+(defun cl--valid-function-name-symbol-p (expr)
+  "If expr is a symbol permitted to be a function name, return non-nil.
+
+Otherwise, return nil."
+  (and (symbolp expr) (not (eq t expr)) expr))
+
+(defun cl--check-function-name (expr)
+  "Signal error if EXPR is invalid function name.  Otherwise, return nil."
+  (unless (or (cl--valid-function-name-symbol-p expr)
+              (and (consp expr) (eq 'setf (car expr))
+                   (consp (cdr expr))
+                   (symbolp (cadr expr))
+                   (null (cddr expr))))
+    (error "Illegal function name: %s" expr)))
+
+(defun cl--valid-let-symbol-p (x)
+  "If X is a symbol permitted to be a variable in a let binding, return non-nil.
+
+Otherwise, return nil."
+  ;; Not nil, t, :keywords ---
+  ;; according to error message `Attempt to set a constant symbol' from `let'
+  ;; and description of SYMBOL_CONSTANT_P in data.c.
+  ;;
+  ;; Unfortunately we can't use symbol-constant-p directly.
+  (and (symbolp x) (not (or (null x) (eq t x) (keywordp x)))))
+
+(defun cl--call-flet-expander (expander function-name)
+  "Call flet expander EXPANDER for local function FUNCTION-NAME,
+checking return value type."
+  (let ((binding-or-pseudo-binding (funcall expander)))
+    (unless (and (consp binding-or-pseudo-binding)
+                 (or (cl--valid-let-symbol-p (car binding-or-pseudo-binding))
+                     (null (car binding-or-pseudo-binding)))
+                 (consp (cdr binding-or-pseudo-binding))
+                 (null (cddr binding-or-pseudo-binding)))
+      (error "cl--expand-flet expander %s for local function %s returns illegal value: %s"
+             expander function-name binding-or-pseudo-binding))
+    binding-or-pseudo-binding))
+
+(defmacro with--cl-flet-macroexp ( arglist var
+                                   function-name expander memoized-alist
+                                   &rest body)
+  "Return lambda (with ARGLIST being its arglist) that can
+serve as a macroexpanding function in
+`macroexpand-all-environment' to expand local function calls of
+the form (FUNCTION-NAME ..).
+
+The body of lambda will be BODY, with variable named VAR
+implicitly bound to the return value of flet-expander EXPANDER,
+retreived from the place MEMOIZED-ALIST if possible, and saved in
+the place MEMOIZED-ALIST otherwise.
+
+MEMOIZED-ALIST is presumed to refer to an alist."
+  (declare (indent 5))
+  (unless (proper-list-p arglist)
+    (error "Arglist is not a proper list: %s" arglist))
+  (unless (cl--valid-let-symbol-p var)
+    (error "Can't be a `let' variable: %s" var))
+  `(lambda ,arglist
+     (let ((,var
+            (let ((return-value
+                   (cl--with-memoization (alist-get ,function-name
+                                                    ,memoized-alist
+                                                    nil nil #'equal)
+                     (cl--call-flet-expander ,expander ,function-name))))
+              (if (null (car return-value)) (cadr return-value)
+                (car return-value)))))
+       ,@body)))
+
+(defvar cl--local-setf-expanders nil
+  "Holds expanders for local non-generic setf functions.
+
+Holds the same data as flet-expanders-plist argument to
+`cl--expand-flet', only this one is alist and its keys are F
+rather than (setf F).")
+
+(defun cl--expand-local-setf (&rest places-and-values)
+  "Expand `(setf . ,PLACES-AND-VALUES)
+according to `cl--local-setf-expanders'.
+
+Presumes the caller has `macroexpand-all-environment' bound."
+  (macroexp-progn
+   (cl-loop
+    for cons on places-and-values by #'cddr
+    for (place new) on places-and-values by #'cddr
+    as expander = nil
+    if (null (cdr cons))
+    do (error "Odd number of arguments to setf: %s"
+              (cons 'setf places-and-values))
+    else collect
+    (cond ((or (not (consp place))
+               ;; Do not override local macros.
+               (assq (car place) macroexpand-all-environment))
+           (macroexpand-all
+            (macroexpand-1 `(setf ,place ,new)
+                           (remove '(setf . cl--expand-local-setf)
+                                   macroexpand-all-environment))
+            macroexpand-all-environment))
+          ((progn
+             (unless (proper-list-p (cdr place))
+               (error "Malformed place: %s" place))
+             (setq expander
+                   (alist-get (car place) cl--local-setf-expanders
+                              nil nil #'eq)))
+           (funcall expander place new))
+          (t
+           (macroexpand-all
+            (macroexpand-1 `(setf ,place ,new)
+                           (remove '(setf . cl--expand-local-setf)
+                                   macroexpand-all-environment))
+            macroexpand-all-environment))))))
+
+(defun cl--expand-flet (env body &rest flet-expanders-plist)
+  "Return a form equivalent to `(cl-flet ,bindings BODY)
+where bindings correspond to FLET-EXPANDERS-PLIST as described below.
+
+ENV should be macroexpansion environment
+to be augmented with some definitions from FLET-EXPANDERS-PLIST
+to then expand forms in BODY with.
+
+FLET-EXPANDERS-PLIST should be a plist
+where keys are function names
+and values are 0-argument lambdas
+to be called if the corresponding function name is encountered
+in BODY and then only (that is, at most once).
+
+The return value of said lambdas should be either
+
+- a valid let-binding (SYMBOL function) to be used in let*
+  bindings over BODY so that SYMBOL could be used in place of the
+  corresponding function name in BODY
+
+or
+
+- a list (NIL EXPR) for EXPR to be used in BODY in place of the
+  corresponding function name as is.
+
+In case several identical function names are specified in
+FLET-EXPANDERS-PLIST, the first one is used
+(and a warning is issued).
+
+Note: ENV is not used as is, but is copied."
+  (declare (indent 2))
+  (let ((cl--local-setf-expanders cl--local-setf-expanders) memoized-setf
+        memoized all-names)
+    (cl-loop
+     for cons on flet-expanders-plist by #'cddr
+     for (function-name expander) on flet-expanders-plist by #'cddr
+     if (null (cdr cons))
+     do (error "Odd number of arguments to cl--expand-flet: %s"
+               (apply #'list 'cl--expand-flet env body flet-expanders-plist))
+     else
+     do (cl--check-function-name function-name)
+     ;; TODO: Maybe allow t as a pseudo-function-name
+     ;; for unconditional code execution during macroexpansion.
+     (unless (cl-typep expander 'function)
+       (signal 'wrong-type-argument
+               (list 'function expander 'expander)))
+     (let ((seen (assoc function-name all-names
+                        ;; Here and after, names may be symbols or conses.
+                        #'equal)))
+       (if seen (cl-symbol-macrolet ((warned (cdr seen)))
+                  (unless warned
+                    (warn "Duplicate local function definition: %s"
+                          function-name)
+                    (setf warned t)))
+         (push (cons function-name nil) all-names)
+         ;; The last definition should be the effectual one.
+         ;; Our implementation presumes
+         ;; `cl--expand-flet' lists entries in reverse order
+         ;; compared to `cl-flet'.
+         ;; This makes implementations of `cl--expand-flet', `cl-flet' simpler
+         ;; while the difference in the interface
+         ;; only matters for incorrect or stylistically bad code
+         ;; so it shouldn't bother us.
+         (let ((f function-name)
+               ;; Don't capture loop's vars in lambdas below
+               ;; returned by `with--cl-flet-macroexp'.
+               (thunk expander))
+           (if (not (and (consp function-name)
+                         (eq 'setf (car function-name))))
+               (push (cons function-name
+                           (with--cl-flet-macroexp (&rest args) var
+                                                   f thunk memoized
+                             (if (eq (car args) cl--labels-magic)
+                                 (list cl--labels-magic var)
+                               `(funcall ,var ,@args))))
+                     env)
+             (push (cons (cadr function-name)
+                         (with--cl-flet-macroexp (place new) var
+                                                 f thunk memoized-setf
+                           ;; `gv' does the same but a gv-based implementation
+                           ;; we could think of required advising function-get
+                           ;; and advising is ugly.
+                           ;; This is also more CL-self-contained.
+                           (let ((new-gensym (let ((gensym-counter 0))
+                                               (gensym "setf-arg-")))
+                                 setf-args)
+                             `(let (,@(let ((gensym-counter 1))
+                                        (mapcar
+                                         (lambda (arg)
+                                           (let ((gensym
+                                                  (gensym "setf-arg-")))
+                                             (push gensym setf-args)
+                                             (list gensym arg)))
+                                         (cdr place)))
+                                    (,new-gensym ,new))
+                                (funcall ,var ,new-gensym
+                                         ,@(nreverse setf-args))))))
+                   cl--local-setf-expanders)
+             (push (cons function-name
+                         (with--cl-flet-macroexp (&rest _args) var
+                                                 f thunk
+                                                 ;; TODO: memoized?
+                                                 memoized-setf
+                           (list cl--labels-magic var)))
+                   ;; This is meant solely for `cl--flet-convert-with-setf'.
+                   env))))))
+    (let* ((macroexpanded-body
+            (let ((newenv (cons '(setf . cl--expand-local-setf) env)))
+              ;; TODO: Get rid of the newenv binding
+              ;; if the order of 'function and 'setf
+              ;; in the `macroxpand-all-environment' is not essential.
+              (macroexpand-all (macroexp-progn body)
+                               (if (assq 'function newenv) newenv
+                                 (cons (cons 'function
+                                             #'cl--flet-convert-with-setf)
+                                       newenv)))))
+           (memoized (nconc memoized memoized-setf))
+           (binds
+            ;; Preserve cdrs to use nset-difference below.
+            (mapcar #'cdr memoized)))
+      (dolist (missing (cl-nset-difference all-names memoized
+                                           :key #'car :test #'equal))
+        (warn "Local function defined but is missing in body: %s"
+              (car missing)))
+      (macroexp-let* (cl-delete nil binds :key #'car :test #'eq)
+                     macroexpanded-body))))
+
+
 ;;;###autoload
 (defmacro cl-flet (bindings &rest body)
   "Make local function definitions.
@@ -2027,30 +2303,41 @@ defmacro cl-flet (bindings &rest body)
                                         [&optional ("interactive" interactive)]
                                         def-body)])
                    cl-declarations body)))
-  (let ((binds ()) (newenv macroexpand-all-environment))
-    (dolist (binding bindings)
-      (let ((var (make-symbol (format "--cl-%s--" (car binding))))
-            (args-and-body (cdr binding)))
-        (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 (car binding)
-                    (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))))))
+  (apply #'cl--expand-flet macroexpand-all-environment body
+         (let (flet-expanders-plist)
+           (dolist (binding bindings flet-expanders-plist)
+             (let (function-name args-and-body)
+               (unless (and (consp binding)
+                            (proper-list-p
+                             (setq args-and-body (cdr binding)))
+                            args-and-body)
+                 (error "The flet definition spec %s is malformed" binding))
+               ;; Function name will be checked for correctness by expand-flet.
+               ;; TODO: Consider checking it right here to error earlier.
+               (setq function-name (car binding))
+               ;; TODO: We push a quoted lambda form;
+               ;; maybe it's better to push a closure?
+               (push `(lambda ()
+                        ,(or (and (null (cdr args-and-body))
+                                  (symbolp (car args-and-body))
+                                  `(list nil ',(car args-and-body)))
+                             (progn
+                               (unless (listp (car args-and-body))
+                                 (error "The lambda expression has a non-list lambda-list: %s"
+                                        (cons 'lambda args-and-body)
+                                        ;; TODO: When implicit cl-block is implemented, change this to
+                                        ;; `(lambda ,(car args-and-body)
+                                        ;;    (cl-block ,function-name ,@(cdr args-and-body)))
+                                        ;; for consistency.
+                                        ))
+                               `(list (make-symbol
+                                       (format "--cl-%s--" ',function-name))
+                                      (list 'cl-function
+                                            (cons 'lambda
+                                                  ;; TODO: Implement implicit cl-block
+                                                  ',args-and-body))))))
+                     flet-expanders-plist)
+               (push function-name flet-expanders-plist))))))
 
 ;;;###autoload
 (defmacro cl-flet* (bindings &rest body)
-- 
2.32.0