From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Wed, 22 Dec 2021 15:52:21 +0000 (-0500)
Subject: oclosure.el (oclosure-define): Use `oclosure--copy` to define accessors
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=01002ebba0ac51d19fb22c2c70616642f4679e81;p=emacs.git

oclosure.el (oclosure-define): Use `oclosure--copy` to define accessors

* lisp/emacs-lisp/oclosure.el (oclosure-define): Use `oclosure--copy` to
define accessors.  Fix call to `oclosure--defstruct-make-copiers`.
(oclosure--lambda): New macro extracted from `oclosure-lambda`.
(oclosure-lambda): Use it.
(oclosure--accessor-prototype): New constant.
(oclosure-accessor): New type.
---

diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 956dff7ffa5..b88d108853f 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.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))
-                          (oclosure-lambda accessor ((type ',name) (slot ',slot))
-                                      (oclosure)
-                            (oclosure-get oclosure ,i)))))
+                          ;; We use `oclosure--copy' instead of `oclosure--accessor-copy'
+                          ;; here to circumvent bootstrapping problems.
+                          (oclosure--copy oclosure--accessor-prototype
+                                     ',name ',slot ,i))))
                    slotdescs))
-       ,@(oclosure--defstruct-make-copiers copiers slots name))))
+       ,@(oclosure--defstruct-make-copiers
+          copiers (mapcar #'cl--slot-descriptor-name slotdescs) name))))
 
 (defun oclosure--define (class pred)
   (let* ((name (cl--class-name class))
@@ -210,13 +211,51 @@
     (defalias predname pred)
     (put name 'cl-deftype-satisfies predname)))
 
-(defmacro oclosure-lambda (type fields args &rest body)
+(defmacro oclosure--lambda (type bindings args &rest body)
+  "Low level construction of an OClosure object.
+TYPE is expected to be a symbol that is (or will be) defined as an OClosure 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 `oclosure-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 OClosures.
+      ((`(,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).
+       (oclosure--fix-type
+        ;; This `oclosure--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 oclosure-lambda (type fields args &rest body)
+  "Define anonymous OClosure function.
+TYPE should be an OClosure 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 `oclosure-define' 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 (oclosure--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 OClosures.
-       (`(,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).
-         (oclosure--fix-type
-          ;; This `oclosure--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))))))
+       (oclosure--lambda ,type ,slotbinds ,args ,@body))))
 
 (defun oclosure--fix-type (_ignore oclosure)
   (if (byte-code-function-p oclosure)
@@ -323,8 +336,14 @@
            (and (eq :type (car-safe first-var))
                 (cdr first-var))))))
 
+(defconst oclosure--accessor-prototype
+  ;; Use `oclosure--lambda' to circumvent a bootstrapping problem:
+  ;; `oclosure-accessor' is not yet defined at this point but
+  ;; `oclosure--accessor-prototype' is needed when defining `oclosure-accessor'.
+  (oclosure--lambda oclosure-accessor ((type) (slot) (index)) (oclosure) (oclosure-get oclosure index)))
+
 (oclosure-define accessor
-  "OClosure to access the field of an object."
+  "OClosure function to access a specific slot of an object."
   type slot)
 
 (defun oclosure--accessor-cl-print (object stream)
@@ -340,5 +359,11 @@
 \(fn OBJ)"
           (accessor--slot f) (accessor--type f)))
 
+(oclosure-define (oclosure-accessor
+                (:parent accessor)
+                (:copier oclosure--accessor-copy (type slot index)))
+  "OClosure function to access a specific slot of an OClosure function."
+  index)
+
 (provide 'oclosure)
 ;;; oclosure.el ends here