4 files changed, 118 insertions, 0 deletions

diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi
index e51e245c736..7219494391b 100644
--- a/doc/misc/cl.texi
+++ b/doc/misc/cl.texi
@@ -4066,6 +4066,55 @@ A documentation string describing the slot.
 
 Other slot options are currently ignored.
 
+@defmac cl-with-accessors name bindings body@dot{}
+You can use @code{cl-with-accessors} to lexically define symbols as
+expressions calling the given accessor functions on a single instance of
+a structure or class defined by @code{cl-defstruct} or @code{defclass}
+(@pxref{eieio}).  This can simplify code that repeatedly accesses slots.
+With it, you can use @code{setf} and @code{setq} on the symbols like
+normal variables, modifying the values in the structure.  Unlike the
+macro @code{with-slots} (@pxref{Accessing Slots,,,eieio,EIEIO}), because
+the symbol expands to a function call, @code{cl-with-accessors} can be
+used with any generalized variable that can take a single argument, such
+as @code{cl-first} and @code{cl-rest}.
+@end defmac
+
+@example
+;; Using accessors with long, clear names without the macro:
+(defun internal-normalization (person)
+  "Correct the values of the slots in PERSON to be as expected."
+  ;; Check the values of the structure:
+  (when (equal (person-optional-secondary-data person) "")
+    (setf (person-optional-secondary-data person) nil))
+  (when (null (person-access-settings person))
+    (setf (person-access-settings person) 'default))
+  (when (< (long-accessor-name-that-can-become-unreadable-when-repeated
+            person)
+           9)
+    (cl-incf (long-accessor-name-that-can-become-unreadable-when-repeated
+              person)
+             100))
+  ;; And so on before returning the structure:
+  person)
+
+;; Using accessors with long, clear names with the macro:
+(defun internal-normalization (person)
+  "Correct the values of the slots in PERSON to be as expected."
+  (cl-with-accessors ((secondary-data person-optional-secondary-data)
+                      (access-settings person-access-settings)
+                      (short-name person-much-longer-accessor-name))
+      person
+    ;; Check the values of the structure:
+    (when (equal secondary-data "")
+      (setf secondary-data nil))
+    (when (null access-settings)
+      (setf access-settings 'default))
+    (when (< short-name 9)
+      (cl-incf short-name 100))
+    ;; And so on before returning the structure:
+    person))
+@end example
+
 For obscure historical reasons, structure options take a different
 form than slot options.  A structure option is either a keyword
 symbol, or a list beginning with a keyword symbol possibly followed
diff --git a/etc/NEWS b/etc/NEWS
index afa45c5ca0d..8c65b195b1a 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1611,6 +1611,16 @@ New faces have been added to 'icomplete-vertical-mode':
 - 'icomplete-vertical-unselected-prefix-indicator-face' controls the
   appearance of unselected candidate prefixes.
 
+** CL-Lib
+
++++
+*** New macro 'cl-with-accessors'.
+This macro is similar to 'with-slots', but uses accessor functions
+instead of slot names.  It is useful when slots' accessor functions are
+used repeatedly, such as reading from a slot and then writing to that
+slot.  Symbol macros are created for the accessor functions using
+'cl-symbol-macrolet', so that they can be used with 'setq' and 'setf'.
+
 ** Miscellaneous
 
 ---
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 960f2e6742b..cc1c6a6a5ad 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2576,6 +2576,50 @@ See also `macroexp-let2'."
                           collect `(,(car name) ,gensym))
              ,@body)))))
 
+;;;###autoload
+(defmacro cl-with-accessors (bindings instance &rest body)
+  "Use BINDINGS as function calls on INSTANCE inside BODY.
+
+This macro helps when writing code that makes repeated use of the
+accessor functions of a structure or object instance, such as those
+created by `cl-defstruct' and `defclass'.
+
+BINDINGS is a list of (NAME ACCESSOR) pairs.  Inside BODY, NAME is
+treated as the function call (ACCESSOR INSTANCE) using
+`cl-symbol-macrolet'.  NAME can be used with `setf' and `setq' as a
+generalized variable.  Because of how the accessor is used,
+`cl-with-accessors' can be used with any generalized variable that can
+take a single argument, such as `car' and `cdr'.
+
+See also the macro `with-slots' described in the Info
+node `(eieio)Accessing Slots', which is similar, but uses slot names
+instead of accessor functions.
+
+\(fn ((NAME ACCESSOR) ...) INSTANCE &rest BODY)"
+  (declare (debug [(&rest (symbolp symbolp)) form body])
+           (indent 2))
+  (cond ((null body)
+         (macroexp-warn-and-return "`cl-with-accessors' used with empty body"
+                                   nil 'empty-body))
+        ((null bindings)
+         (macroexp-warn-and-return "`cl-with-accessors' used without accessors"
+                                   (macroexp-progn body)
+                                   'suspicious))
+        (t
+         (cl-once-only (instance)
+           (let ((symbol-macros))
+             (dolist (b bindings)
+               (pcase b
+                 (`(,(and (pred symbolp) var)
+                    ,(and (pred symbolp) accessor))
+                  (push `(,var (,accessor ,instance))
+                        symbol-macros))
+                 (_
+                  (error "Malformed `cl-with-accessors' binding: %S" b))))
+             `(cl-symbol-macrolet
+                  ,symbol-macros
+                ,@body))))))
+
 ;;; Multiple values.
 
 ;;;###autoload
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index b4b939d3d31..ed6b1c2e4d4 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -541,6 +541,21 @@ collection clause."
   (should (mystruct-p (cl-lib--con-1)))
   (should (mystruct-p (cl-lib--con-2))))
 
+(ert-deftest cl-lib-struct-with-accessors ()
+  (let ((x (make-mystruct :abc 1 :def 2)))
+    (cl-with-accessors ((abc mystruct-abc)
+                        (def mystruct-def))
+        x
+      (should (= abc 1))
+      (should-error (setf abc 99))
+      (should (= def 2))
+      (setf def 3)
+      (should (= def 3))
+      (setq def 4)
+      (should (= def 4)))
+    (should (= 4 (mystruct-def x)))
+    (should (= 1 (mystruct-abc x)))))
+ 
 (ert-deftest cl-lib-arglist-performance ()
   ;; An `&aux' should not cause lambda's arglist to be turned into an &rest
   ;; that's parsed by hand.