OClosure: add support for `slot-value`

* lisp/emacs-lisp/oclosure.el (oclosure--slot-index)
(oclosure--slot-value, oclosure--set-slot-value): New functions.

* lisp/emacs-lisp/eieio-core.el (eieio-oset, eieio-oref):
Consolidate the type test.  Use `oclosure--(set-)slot-value`.
(eieio--validate-slot-value, eieio--validate-class-slot-value):
Don't presume `class` is an EIEIO class.
(eieio--class): Fix bogus `:type` info.
(eieio--object-class): Simplify.
(eieio--known-slot-name-p): New function.
(eieio-oref, eieio-oref-default, eieio-oset-default): Use it.

* test/lisp/emacs-lisp/oclosure-tests.el: Require `eieio`.
(oclosure-test): Make `name` field mutable.
(oclosure-test-slot-value): New test.

diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index ed1a28a24fb9ef642415278ee494e024cb4856bc..d687289b22fd1959edb172726d459aa10ae82c62 100644 (file)
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -92,7 +92,7 @@ Currently under control of this var:
                (:copier nil))
   children
   initarg-tuples                  ;; initarg tuples list
-  (class-slots nil :type eieio--slot)
+  (class-slots nil :type (vector-of eieio--slot))
   class-allocation-values         ;; class allocated value vector
   default-object-cache ;; what a newly created object would look like.
                        ; This will speed up instantiation time as
@@ -130,10 +130,7 @@ Currently under control of this var:
     class))
 
 (defsubst eieio--object-class (obj)
-  (let ((tag (eieio--object-class-tag obj)))
-    (if eieio-backward-compatibility
-        (eieio--class-object tag)
-      tag)))
+  (eieio--class-object (eieio--object-class-tag obj)))
 
 (defun class-p (x)
   "Return non-nil if X is a valid class vector.
@@ -265,6 +262,10 @@ use '%s or turn off `eieio-backward-compatibility' instead" cname)
 (defvar eieio--known-slot-names nil)
 (defvar eieio--known-class-slot-names nil)
 
+(defun eieio--known-slot-name-p (name)
+  (or (memq name eieio--known-slot-names)
+      (get name 'slot-name)))
+
 (defun eieio-defclass-internal (cname superclasses slots options)
   "Define CNAME as a new subclass of SUPERCLASSES.
 SLOTS are the slots residing in that class definition, and OPTIONS
@@ -704,13 +705,13 @@ an error."
       nil
     ;; Trim off object IDX junk added in for the object index.
     (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots)))
-    (let* ((sd (aref (cl--class-slots class)
+    (let* ((sd (aref (eieio--class-slots class)
                      slot-idx))
            (st (cl--slot-descriptor-type sd)))
       (cond
        ((not (eieio--perform-slot-validation st value))
        (signal 'invalid-slot-type
-                (list (eieio--class-name class) slot st value)))
+                (list (cl--class-name class) slot st value)))
        ((alist-get :read-only (cl--slot-descriptor-props sd))
         (signal 'eieio-read-only (list (cl--class-name class) slot)))))))
 
@@ -725,7 +726,7 @@ an error."
                                               slot-idx))))
       (if (not (eieio--perform-slot-validation st value))
          (signal 'invalid-slot-type
-                  (list (eieio--class-name class) slot st value))))))
+                  (list (cl--class-name class) slot st value))))))
 
 (defun eieio-barf-if-slot-unbound (value instance slotname fn)
   "Throw a signal if VALUE is a representation of an UNBOUND slot.
@@ -746,31 +747,35 @@ Argument FN is the function calling this verifier."
               (ignore obj)
               (pcase slot
                 ((and (or `',name (and name (pred keywordp)))
-                      (guard (not (memq name eieio--known-slot-names))))
+                      (guard (not (eieio--known-slot-name-p name))))
                  (macroexp-warn-and-return
                   (format-message "Unknown slot `%S'" name)
                   exp nil 'compile-only name))
                 (_ exp))))
+           ;; FIXME: Make it a gv-expander such that the hash-table lookup is
+           ;; only performed once when used in `push' and friends?
            (gv-setter eieio-oset))
   (cl-check-type slot symbol)
-  (cl-check-type obj (or eieio-object class cl-structure-object))
-  (let* ((class (cond ((symbolp obj)
-                       (error "eieio-oref called on a class: %s" obj)
-                       (eieio--full-class-object obj))
-                      (t (eieio--object-class obj))))
-        (c (eieio--slot-name-index class slot)))
-    (if (not c)
-       ;; It might be missing because it is a :class allocated slot.
-       ;; Let's check that info out.
-       (if (setq c (eieio--class-slot-name-index class slot))
-           ;; Oref that slot.
-           (aref (eieio--class-class-allocation-values class) c)
-         ;; The slot-missing method is a cool way of allowing an object author
-         ;; to intercept missing slot definitions.  Since it is also the LAST
-         ;; thing called in this fn, its return value would be retrieved.
-         (slot-missing obj slot 'oref))
-      (cl-check-type obj (or eieio-object cl-structure-object))
-      (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref))))
+  (cond
+   ((cl-typep obj '(or eieio-object cl-structure-object))
+    (let* ((class (eieio--object-class obj))
+           (c (eieio--slot-name-index class slot)))
+      (if (not c)
+         ;; It might be missing because it is a :class allocated slot.
+         ;; Let's check that info out.
+         (if (setq c (eieio--class-slot-name-index class slot))
+             ;; Oref that slot.
+             (aref (eieio--class-class-allocation-values class) c)
+           ;; The slot-missing method is a cool way of allowing an object author
+           ;; to intercept missing slot definitions.  Since it is also the LAST
+           ;; thing called in this fn, its return value would be retrieved.
+           (slot-missing obj slot 'oref))
+       (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref))))
+   ((cl-typep obj 'oclosure) (oclosure--slot-value obj slot))
+   (t
+    (signal 'wrong-type-argument
+            (list '(or eieio-object cl-structure-object oclosure) obj)))))
+
 
 
 (defun eieio-oref-default (class slot)
@@ -782,7 +787,7 @@ Fills in CLASS's SLOT with its default value."
               (ignore class)
               (pcase slot
                 ((and (or `',name (and name (pred keywordp)))
-                      (guard (not (memq name eieio--known-slot-names))))
+                      (guard (not (eieio--known-slot-name-p name))))
                  (macroexp-warn-and-return
                   (format-message "Unknown slot `%S'" name)
                   exp nil 'compile-only name))
@@ -817,24 +822,29 @@ Fills in CLASS's SLOT with its default value."
 (defun eieio-oset (obj slot value)
   "Do the work for the macro `oset'.
 Fills in OBJ's SLOT with VALUE."
-  (cl-check-type obj (or eieio-object cl-structure-object))
   (cl-check-type slot symbol)
-  (let* ((class (eieio--object-class obj))
-         (c (eieio--slot-name-index class slot)))
-    (if (not c)
-       ;; It might be missing because it is a :class allocated slot.
-       ;; Let's check that info out.
-       (if (setq c
-                 (eieio--class-slot-name-index class slot))
-           ;; Oset that slot.
-           (progn
-             (eieio--validate-class-slot-value class c value slot)
-             (aset (eieio--class-class-allocation-values class)
-                   c value))
-         ;; See oref for comment on `slot-missing'
-         (slot-missing obj slot 'oset value))
-      (eieio--validate-slot-value class c value slot)
-      (aset obj c value))))
+  (cond
+   ((cl-typep obj '(or eieio-object cl-structure-object))
+    (let* ((class (eieio--object-class obj))
+           (c (eieio--slot-name-index class slot)))
+      (if (not c)
+         ;; It might be missing because it is a :class allocated slot.
+         ;; Let's check that info out.
+         (if (setq c
+                   (eieio--class-slot-name-index class slot))
+             ;; Oset that slot.
+             (progn
+               (eieio--validate-class-slot-value class c value slot)
+               (aset (eieio--class-class-allocation-values class)
+                     c value))
+           ;; See oref for comment on `slot-missing'
+           (slot-missing obj slot 'oset value))
+       (eieio--validate-slot-value class c value slot)
+       (aset obj c value))))
+   ((cl-typep obj 'oclosure) (oclosure--set-slot-value obj slot value))
+   (t
+    (signal 'wrong-type-argument
+            (list '(or eieio-object cl-structure-object oclosure) obj)))))
 
 (defun eieio-oset-default (class slot value)
   "Do the work for the macro `oset-default'.
@@ -844,7 +854,7 @@ Fills in the default value in CLASS' in SLOT with VALUE."
               (ignore class value)
               (pcase slot
                 ((and (or `',name (and name (pred keywordp)))
-                      (guard (not (memq name eieio--known-slot-names))))
+                      (guard (not (eieio--known-slot-name-p name))))
                  (macroexp-warn-and-return
                   (format-message "Unknown slot `%S'" name)
                   exp nil 'compile-only name))
@@ -867,7 +877,7 @@ Fills in the default value in CLASS' in SLOT with VALUE."
               (eieio--validate-class-slot-value class c value slot)
               (aset (eieio--class-class-allocation-values class) c
                     value))
-          (signal 'invalid-slot-name (list (eieio--class-name class) slot)))
+          (signal 'invalid-slot-name (list (cl--class-name class) slot)))
       ;; `oset-default' on an instance-allocated slot is allowed by EIEIO but
       ;; not by CLOS and is mildly inconsistent with the :initform thingy, so
       ;; it'd be nice to get rid of it.

diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index c37a5352a3a2e520bfb747a42b6cc75b6fae6d42..3df64ad28067d2bb3e2beef51029475addf6a30b 100644 (file)
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -511,6 +511,26 @@ This has 2 uses:
   "OClosure function to access a specific slot of an OClosure function."
   index)
 
+(defun oclosure--slot-index (oclosure slotname)
+  (gethash slotname
+           (oclosure--class-index-table
+            (cl--find-class (oclosure-type oclosure)))))
+
+(defun oclosure--slot-value (oclosure slotname)
+  (let ((class (cl--find-class (oclosure-type oclosure)))
+        (index (oclosure--slot-index oclosure slotname)))
+    (oclosure--get oclosure index
+                   (oclosure--slot-mutable-p
+                    (nth index (oclosure--class-slots class))))))
+
+(defun oclosure--set-slot-value (oclosure slotname value)
+  (let ((class (cl--find-class (oclosure-type oclosure)))
+        (index (oclosure--slot-index oclosure slotname)))
+    (unless (oclosure--slot-mutable-p
+             (nth index (oclosure--class-slots class)))
+      (signal 'setting-constant (list oclosure slotname)))
+    (oclosure--set value oclosure index)))
+
 (defconst oclosure--mut-getter-prototype
   (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure)
     (oclosure--get oclosure index t)))

diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el
index c72a9dbd7ad63dfebfa3cd44a3d8ada1c692a340..d3e2b3870a64f02b37411a103cfbbfbdcb589f07 100644 (file)
--- a/test/lisp/emacs-lisp/oclosure-tests.el
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -22,12 +22,13 @@
 (require 'ert)
 (require 'oclosure)
 (require 'cl-lib)
+(require 'eieio)
 
 (oclosure-define (oclosure-test
                   (:copier oclosure-test-copy)
                   (:copier oclosure-test-copy1 (fst)))
   "Simple OClosure."
-  fst snd name)
+  fst snd (name :mutable t))
 
 (cl-defmethod oclosure-test-gen ((_x compiled-function)) "#<bytecode>")
 
@@ -123,4 +124,20 @@
     (should (equal (funcall f 5) 15))
     (should (equal (funcall f2 15) 68))))
 
+(ert-deftest oclosure-test-slot-value ()
+  (require 'eieio)
+  (let ((ocl (oclosure-lambda
+                 (oclosure-test (fst 'fst1) (snd 'snd1) (name 'name1))
+                 (x)
+               (list name fst snd x))))
+    (should (equal 'fst1  (slot-value ocl 'fst)))
+    (should (equal 'snd1  (slot-value ocl 'snd)))
+    (should (equal 'name1  (slot-value ocl 'name)))
+    (setf (slot-value ocl 'name) 'new-name)
+    (should (equal 'new-name (slot-value ocl 'name)))
+    (should (equal '(new-name fst1 snd1 arg) (funcall ocl 'arg)))
+    (should-error (setf (slot-value ocl 'fst) 'new-fst) :type 'setting-constant)
+    (should (equal 'fst1  (slot-value ocl 'fst)))
+    ))
+
 ;;; oclosure-tests.el ends here.