scratch/fcr eed3450: fcr.el (fcr-defstruct): Use `fcr--copy` to define accessors

[Stefan Monnier]

branch: scratch/fcr
commit eed3450af0a0892db67409b073203c9f1454354a
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    fcr.el (fcr-defstruct): Use `fcr--copy` to define accessors
    
    * lisp/emacs-lisp/fcr.el (fcr-defstruct): Use `fcr--copy` to
    define accessors.  Fix call to `fcr--defstruct-make-copiers`.
    (fcr--lambda): New macro extracted from `fcr-lambda`.
    (fcr-lambda): Use it.
    (fcr--accessor-prototype): New constant.
    (fcr-accessor): New type.
---
 lisp/emacs-lisp/fcr.el | 99 +++++++++++++++++++++++++++++++-------------------
 1 file changed, 62 insertions(+), 37 deletions(-)

diff --git a/lisp/emacs-lisp/fcr.el b/lisp/emacs-lisp/fcr.el
index 51933f0..77baec8 100644
--- a/lisp/emacs-lisp/fcr.el
+++ b/lisp/emacs-lisp/fcr.el
@@ -195,13 +195,14 @@
                        (setf (gethash slot it) i)
                        ;; Always use a double hyphen: if users wants to
                        ;; make it public, they can do so with an alias.
-                       ;; FIXME: Use a copier!
                        `(defalias ',(intern (format "%S--%S" name slot))
-                          (fcr-lambda accessor ((type ',name) (slot ',slot))
-                                      (fcr)
-                            (fcr-get fcr ,i)))))
+                          ;; We use `fcr--copy' instead of `fcr--accessor-copy'
+                          ;; here to circumvent bootstrapping problems.
+                          (fcr--copy fcr--accessor-prototype
+                                     ',name ',slot ,i))))
                    slotdescs))
-       ,@(fcr--defstruct-make-copiers copiers slots name))))
+       ,@(fcr--defstruct-make-copiers
+          copiers (mapcar #'cl--slot-descriptor-name slotdescs) name))))
 
 (defun fcr--define (class pred)
   (let* ((name (cl--class-name class))
@@ -210,13 +211,51 @@
     (defalias predname pred)
     (put name 'cl-deftype-satisfies predname)))
 
-(defmacro fcr-lambda (type fields args &rest body)
+(defmacro fcr--lambda (type bindings args &rest body)
+  "Low level construction of an FCR object.
+TYPE is expected to be a symbol that is (or will be) defined as an FCR type.
+BINDINGS should list all the slots expected by this type, in the proper order.
+No checking is performed,"
+  (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body)))
   ;; FIXME: Fundamentally `fcr-lambda' should be a special form.
   ;; We define it here as a macro which expands to something that
   ;; looks like "normal code" in order to avoid backward compatibility
   ;; issues with third party macros that do "code walks" and would
   ;; likely mishandle such a new special form (e.g. `generator.el').
   ;; But don't be fooled: this macro is tightly bound to `cconv.el'.
+  (pcase-let*
+      ;; FIXME: Since we use the docstring internally to store the
+      ;; type we can't handle actual docstrings.  We could fix this by adding
+      ;; a docstring slot to FCRs.
+      ((`(,prebody . ,body) (macroexp-parse-body body)))
+    `(let ,(mapcar (lambda (bind)
+                     (if (cdr bind) bind
+                       ;; Bind to something that doesn't look
+                       ;; like a value to avoid the "Variable
+                       ;; ‘foo’ left uninitialized" warning.
+                       `(,(car bind) (progn nil))))
+                   (reverse bindings))
+       ;; FIXME: Make sure the slotbinds whose value is duplicable aren't
+       ;; just value/variable-propagated by the optimizer (tho I think our
+       ;; optimizer is too naive to be a problem currently).
+       (fcr--fix-type
+        ;; This `fcr--fix-type' + `ignore' call is used by the compiler (in
+        ;; `cconv.el') to detect and signal an error in case of
+        ;; store-conversion (i.e. if a variable/slot is mutated).
+        (ignore ,@(mapcar #'car bindings))
+        (lambda ,args
+          (:documentation ',type)
+          ,@prebody
+          ;; Add dummy code which accesses the field's vars to make sure
+          ;; they're captured in the closure.
+          (if t nil ,@(mapcar #'car bindings))
+          ,@body)))))
+
+(defmacro fcr-lambda (type fields args &rest body)
+  "Define anonymous FCR function.
+TYPE should be an FCR type.
+FIELDS is a let-style list of bindings for the various slots of TYPE.
+ARGS is and BODY are the same as for `lambda'."
   (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body)))
   ;; FIXME: Should `fcr-defstruct' distinguish "optional" from
   ;; "mandatory" slots, and/or provide default values for slots missing
@@ -224,14 +263,9 @@
   (pcase-let*
       ((class (cl--find-class type))
        (slots (fcr--class-slots class))
-       ;; FIXME: Since we use the docstring internally to store the
-       ;; type we can't handle actual docstrings.  We could fix this by adding
-       ;; a docstring slot to FCRs.
-       (`(,prebody . ,body) (macroexp-parse-body body))
-       (slotbinds (nreverse
-                   (mapcar (lambda (slot)
-                             (list (cl--slot-descriptor-name slot)))
-                           slots)))
+       (slotbinds (mapcar (lambda (slot)
+                            (list (cl--slot-descriptor-name slot)))
+                          slots))
        (tempbinds (mapcar
                    (lambda (field)
                      (let* ((name (car field))
@@ -248,28 +282,7 @@
                    fields)))
     ;; FIXME: Optimize temps away when they're provided in the right order?
     `(let ,tempbinds
-       (let ,(mapcar (lambda (bind)
-                       (if (cdr bind) bind
-                         ;; Bind to something that doesn't look
-                         ;; like a value to avoid the "Variable
-                         ;; ‘foo’ left uninitialized" warning.
-                         `(,(car bind) (progn nil))))
-                     slotbinds)
-         ;; FIXME: Make sure the slotbinds whose value is duplicable aren't
-         ;; just value/variable-propagated by the optimizer (tho I think our
-         ;; optimizer is too naive to be a problem currently).
-         (fcr--fix-type
-          ;; This `fcr--fix-type' + `ignore' call is used by the compiler (in
-          ;; `cconv.el') to detect and signal an error in case of
-          ;; store-conversion (i.e. if a variable/slot is mutated).
-          (ignore ,@(mapcar #'car slotbinds))
-          (lambda ,args
-            (:documentation ',type)
-            ,@prebody
-            ;; Add dummy code which accesses the field's vars to make sure
-            ;; they're captured in the closure.
-            (if t nil ,@(mapcar #'car slotbinds))
-            ,@body))))))
+       (fcr--lambda ,type ,slotbinds ,args ,@body))))
 
 (defun fcr--fix-type (_ignore fcr)
   (if (byte-code-function-p fcr)
@@ -323,8 +336,14 @@
            (and (eq :type (car-safe first-var))
                 (cdr first-var))))))
 
+(defconst fcr--accessor-prototype
+  ;; Use `fcr--lambda' to circumvent a bootstrapping problem:
+  ;; `fcr-accessor' is not yet defined at this point but
+  ;; `fcr--accessor-prototype' is needed when defining `fcr-accessor'.
+  (fcr--lambda fcr-accessor ((type) (slot) (index)) (fcr) (fcr-get fcr index)))
+
 (fcr-defstruct accessor
-  "FCR to access the field of an object."
+  "FCR function to access a specific slot of an object."
   type slot)
 
 (defun fcr--accessor-cl-print (object stream)
@@ -340,5 +359,11 @@
 \(fn OBJ)"
           (accessor--slot f) (accessor--type f)))
 
+(fcr-defstruct (fcr-accessor
+                (:parent accessor)
+                (:copier fcr--accessor-copy (type slot index)))
+  "FCR function to access a specific slot of an FCR function."
+  index)
+
 (provide 'fcr)
 ;;; fcr.el ends here