* lisp/emacs-lisp/subr-x.el (with-memoization): New macro

Extracted from `cl-generic.el`.

* lisp/emacs-lisp/cl-generic.el (cl--generic-get-dispatcher)
(cl--generic-build-combined-method, cl-generic-generalizers): Use it.
(cl--generic-with-memoization): Delete.

diff --git a/etc/NEWS b/etc/NEWS
index 9acde7e9e3a2323957b90326f8e297204ecb914a..8c22230daf5a612f6e35aad8b035ef80b52e9627 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -61,6 +61,10 @@ This change also affects 'cl-macrolet', 'cl-flet*' and
 The new command 'image-dired-unmark-all-marks' has been added with a
 binding in the menu.
 
+
+** subr-x
+*** New macro 'with-memoization' provides a very primitive form of memoization
+
 \f
 * New Modes and Packages in Emacs 29.1
 

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 4834fb13c6ad1ba44b8f60376913763cfc74306f..20516130645eb4b275071f7e6ad2e0206d9841e9 100644 (file)
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -100,6 +100,7 @@
 (eval-when-compile (require 'cl-lib))
 (eval-when-compile (require 'cl-macs))  ;For cl--find-class.
 (eval-when-compile (require 'pcase))
+(eval-when-compile (require 'subr-x))
 
 (cl-defstruct (cl--generic-generalizer
                (:constructor nil)
@@ -589,19 +590,10 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
         ;; e.g. for tracing/debug-on-entry.
         (defalias sym gfun)))))
 
-(defmacro cl--generic-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)))))
-
 (defvar cl--generic-dispatchers (make-hash-table :test #'equal))
 
 (defun cl--generic-get-dispatcher (dispatch)
-  (cl--generic-with-memoization
+  (with-memoization
       (gethash dispatch cl--generic-dispatchers)
     ;; (message "cl--generic-get-dispatcher (%S)" dispatch)
     (let* ((dispatch-arg (car dispatch))
@@ -647,7 +639,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
           (let ((method-cache (make-hash-table :test #'eql)))
             (lambda (,@fixedargs &rest args)
               (let ,bindings
-                (apply (cl--generic-with-memoization
+                (apply (with-memoization
                            (gethash ,tag-exp method-cache)
                          (cl--generic-cache-miss
                           generic ',dispatch-arg dispatches-left methods
@@ -691,7 +683,7 @@ for all those different tags in the method-cache.")
       ;; Special case needed to fix a circularity during bootstrap.
       (cl--generic-standard-method-combination generic methods)
     (let ((f
-           (cl--generic-with-memoization
+           (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
@@ -1143,7 +1135,7 @@ These match if the argument is a cons cell whose car is `eql' to VAL."
   ;; 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
+    (with-memoization
         (gethash (cadr specializer) cl--generic-head-used)
       specializer)
     (list cl--generic-head-generalizer)))

diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 3de666682faee76520b5fb6c76d46ec1a02669b6..91ebbf9fb92ebc0f33f2201fc815d18835faba06 100644 (file)
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -400,6 +400,18 @@ as the new values of the bound variables in the recursive invocation."
       (cl-labels ((,name ,fargs . ,body)) #',name)
       . ,aargs)))
 
+(defmacro with-memoization (place &rest code)
+  "Return the value of CODE and stash it in PLACE.
+If PLACE's value is non-nil, then don't bother evaluating CODE
+and return the value found in PLACE instead."
+  (declare (indent 1) (debug (gv-place body)))
+  (gv-letplace (getter setter) place
+    `(or ,getter
+         ,(macroexp-let2 nil val (macroexp-progn code)
+            `(progn
+               ,(funcall setter val)
+               ,val)))))
+
 
 (provide 'subr-x)