emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

scratch/oclosure 3906eb80b6: oclosure.el: Add support for `slot-value`


From: Stefan Monnier
Subject: scratch/oclosure 3906eb80b6: oclosure.el: Add support for `slot-value`
Date: Wed, 5 Jan 2022 01:16:58 -0500 (EST)

branch: scratch/oclosure
commit 3906eb80b66c97d8f05917f4f5dc0eb94367b980
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    oclosure.el: Add support for `slot-value`
    
    * lisp/emacs-lisp/oclosure.el (oclosure): Rename from `oclosure-object`.
    (oclosure--p): Rename from `oclosure--object-p`.
    (oclosure--slot-mutable-p): New function.
    (oclosure--defstruct-make-copiers, oclosure-define, oclosure-lambda):
    Use it.
    (oclosure-define): Require `gv` before using `gv-setter`.
    (oclosure--define): Mark slot names as such to silence warnings in
    `slot-value`.
    (oclosure--mixin-slot-index): New function.
    (oclosure--mixin-accessor-prototype, oclosure--mut-mixin-getter-prototype)
    (oclosure--mut-mixin-setter-prototype): Use it.
    (oclosure--slot-value, oclosure--set-slot-value): New functions.
    
    * lisp/emacs-lisp/eieio-core.el (eieio--object-class): Always return
    the class object rather than the class name.
    (eieio--add-new-slot, eieio-oset-default, eieio-declare-slots):
    Adjust to new known-slot-name tracking.
    (eieio-oref, eieio-oset): Add support for OClosures.
    
    * lisp/emacs-lisp/eieio.el (defclass): Adjust to new known-slot-name 
tracking.
    
    * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-tests-slot-value):
    New test.
---
 lisp/emacs-lisp/cl-generic.el          |  2 +-
 lisp/emacs-lisp/eieio-core.el          | 94 ++++++++++++++++++----------------
 lisp/emacs-lisp/eieio.el               |  6 +--
 lisp/emacs-lisp/oclosure.el            | 64 ++++++++++++++---------
 test/lisp/emacs-lisp/oclosure-tests.el | 32 +++++++++++-
 5 files changed, 123 insertions(+), 75 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 09c0561b37..e8923ade74 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1313,7 +1313,7 @@ Used internally for the (major-mode MODE) context 
specializers."
             (list cl-generic--oclosure-generalizer))))
    (cl-call-next-method)))
 
-(cl--generic-prefill-dispatchers 0 oclosure-object)
+(cl--generic-prefill-dispatchers 0 oclosure)
 
 ;;; Support for unloading.
 
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index ca47ec77f7..04dd750f88 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -1,6 +1,6 @@
 ;;; eieio-core.el --- Core implementation for eieio  -*- lexical-binding:t -*-
 
-;; Copyright (C) 1995-1996, 1998-2021 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 1998-2022 Free Software Foundation, Inc.
 
 ;; Author: Eric M. Ludlam <zappo@gnu.org>
 ;; Version: 1.4
@@ -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.
@@ -614,7 +611,7 @@ if default value is nil."
                               :key #'cl--slot-descriptor-name)))
          (cold (car (cl-member a (eieio--class-class-slots newc)
                                :key #'cl--slot-descriptor-name))))
-    (cl-pushnew a eieio--known-slot-names)
+    (put a 'slot-name t)
     (when (eq alloc :class)
       (cl-pushnew a eieio--known-class-slot-names))
     (condition-case nil
@@ -746,31 +743,33 @@ 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 (get name 'slot-name))))
                  (macroexp-warn-and-return
                   (format-message "Unknown slot `%S'" name)
                   exp nil 'compile-only))
                 (_ exp))))
            (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 +781,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 (get name 'slot-name))))
                  (macroexp-warn-and-return
                   (format-message "Unknown slot `%S'" name)
                   exp nil 'compile-only))
@@ -817,24 +816,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 +848,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 (get name 'slot-name))))
                  (macroexp-warn-and-return
                   (format-message "Unknown slot `%S'" name)
                   exp nil 'compile-only))
@@ -1136,7 +1140,7 @@ These match if the argument is the name of a subclass of 
CLASS."
        ,@(when classslots
            (mapcar (lambda (s) `(add-to-list 'eieio--known-class-slot-names 
',s))
                    classslots))
-       ,@(mapcar (lambda (s) `(add-to-list 'eieio--known-slot-names ',s))
+       ,@(mapcar (lambda (s) `(put ',s 'slot-name t))
                  slotnames))))
 
 (provide 'eieio-core)
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 2850c91ecd..e6798f38ec 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -1,7 +1,7 @@
 ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects  -*- 
lexical-binding:t -*-
 ;;;              or maybe Eric's Implementation of Emacs Interpreted Objects
 
-;; Copyright (C) 1995-1996, 1998-2021 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 1998-2022 Free Software Foundation, Inc.
 
 ;; Author: Eric M. Ludlam <zappo@gnu.org>
 ;; Version: 1.4
@@ -144,9 +144,9 @@ and reference them using the function `class-option'."
             (alloc   (plist-get soptions :allocation))
             (label   (plist-get soptions :label)))
 
-        ;; Update eieio--known-slot-names already in case we compile code which
+        ;; Update `slot-name' prop already in case we compile code which
         ;; uses this before the class is loaded.
-        (cl-pushnew sname eieio--known-slot-names)
+        (put sname 'slot-name t)
         (when (eq alloc :class)
           (cl-pushnew sname eieio--known-class-slot-names))
 
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 70fb9aa043..4fc41bdfad 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -149,15 +149,18 @@
   (pinned nil :read-only t :type natnum) ;Number of pinned slots.
   (allparents nil :read-only t :type (list-of symbol)))
 
-(setf (cl--find-class 'oclosure-object)
-      (oclosure--class-make 'oclosure-object
+(setf (cl--find-class 'oclosure)
+      (oclosure--class-make 'oclosure
                             "The root parent of all OClosure classes"
-                            nil nil 0 '(oclosure-object)))
-(defun oclosure--object-p (oclosure)
+                            nil nil 0 '(oclosure)))
+(defun oclosure--p (oclosure)
   (let ((type (oclosure-type oclosure)))
     (when type
-      (memq 'oclosure-object (oclosure--class-allparents (cl--find-class 
type))))))
-(cl-deftype oclosure-object () '(satisfies oclosure--object-p))
+      (memq 'oclosure (oclosure--class-allparents (cl--find-class type))))))
+(cl-deftype oclosure () '(satisfies oclosure--p))
+
+(defun oclosure--slot-mutable-p (slotdesc)
+  (not (alist-get :read-only (cl--slot-descriptor-props slotdesc))))
 
 (defun oclosure--defstruct-make-copiers (copiers slotdescs name)
   (require 'cl-macs)            ;`cl--arglist-args' is not autoloaded.
@@ -165,8 +168,7 @@
          (slots (mapcar
                  (lambda (desc)
                   (let ((name (cl--slot-descriptor-name desc)))
-                    (unless (alist-get :read-only
-                                       (cl--slot-descriptor-props desc))
+                    (when (oclosure--slot-mutable-p desc)
                       (push name mutables))
                     name))
                 slotdescs)))
@@ -214,7 +216,7 @@
 
 (defun oclosure--merge-classes (names)
   (if (null (cdr names))
-      (cl--find-class (or (car names) 'oclosure-object))
+      (cl--find-class (or (car names) 'oclosure))
     (let* ((total-slots '())
            (name (vconcat names))
            (pinned 0)
@@ -353,9 +355,7 @@
        ,@(let ((i -1))
            (mapcar (lambda (desc)
                      (let* ((slot (cl--slot-descriptor-name desc))
-                            (mutable
-                             (not (alist-get :read-only
-                                             (cl--slot-descriptor-props 
desc))))
+                            (mutable (oclosure--slot-mutable-p desc))
                             ;; Always use a double hyphen: if users wants to
                             ;; make it public, they can do so with an alias.
                             (aname (intern (format "%S--%S" name slot))))
@@ -370,6 +370,7 @@
                                     'oclosure--accessor-prototype
                                   'oclosure--mixin-accessor-prototype)
                                nil ',name ',slot ,i))
+                         (require 'gv)  ;For `gv-setter'.
                          `(progn
                             (defalias ',aname
                               (oclosure--accessor-copy
@@ -391,6 +392,8 @@
   (let* ((name (cl--class-name class))
          (predname (intern (format "%s--internal-p" name))))
     (setf (cl--find-class name) class)
+    (dolist (slot (oclosure--class-slots class))
+      (put (cl--slot-descriptor-name slot) 'slot-name t))
     (defalias predname pred)
     (put name 'cl-deftype-satisfies predname)))
 
@@ -455,9 +458,8 @@ ARGS and BODY are the same as for `lambda'."
        (slots (oclosure--class-slots class))
        (mutables '())
        (slotbinds (mapcar (lambda (slot)
-                            (let ((name (cl--slot-descriptor-name slot))
-                                  (props (cl--slot-descriptor-props slot)))
-                              (unless (alist-get :read-only props)
+                            (let ((name (cl--slot-descriptor-name slot)))
+                              (when (oclosure--slot-mutable-p slot)
                                 (push name mutables))
                               (list name)))
                           slots))
@@ -574,15 +576,33 @@ ARGS and BODY are the same as for `lambda'."
   "OClosure function to access a specific slot of an OClosure function."
   index)
 
+(defun oclosure--mixin-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--mixin-slot-index oclosure slotname)))
+    (oclosure--get oclosure index
+                   (oclosure--slot-mutable-p
+                    (nth index (cl--class-slots class))))))
+
+(defun oclosure--set-slot-value (oclosure slotname value)
+  (let ((class (cl--find-class (oclosure-type oclosure)))
+        (index (oclosure--mixin-slot-index oclosure slotname)))
+    (unless (oclosure--slot-mutable-p
+             (nth index (cl--class-slots class)))
+      (signal 'setting-constant (list oclosure slotname)))
+    (oclosure--set value oclosure index)))
+
 (defconst oclosure--mixin-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)) (oclosure)
     (oclosure--get oclosure
-                   (gethash slot
-                            (oclosure--class-index-table
-                             (cl--find-class (oclosure-type oclosure))))
+                   (oclosure--mixin-slot-index oclosure slot)
                    nil)))
 
 (defconst oclosure--mut-getter-prototype
@@ -595,16 +615,12 @@ ARGS and BODY are the same as for `lambda'."
 (defconst oclosure--mut-mixin-getter-prototype
   (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure)
     (oclosure--get oclosure
-                   (gethash slot
-                            (oclosure--class-index-table
-                             (cl--find-class (oclosure-type oclosure))))
+                   (oclosure--mixin-slot-index oclosure slot)
                    t)))
 (defconst oclosure--mut-mixin-setter-prototype
   ;; FIXME: The generated docstring is wrong.
   (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (val oclosure)
     (oclosure--set val oclosure
-                   (gethash slot
-                            (oclosure--class-index-table
-                             (cl--find-class (oclosure-type oclosure)))))))
+                   (oclosure--mixin-slot-index oclosure slot))))
 (provide 'oclosure)
 ;;; oclosure.el ends here
diff --git a/test/lisp/emacs-lisp/oclosure-tests.el 
b/test/lisp/emacs-lisp/oclosure-tests.el
index e138602dfc..423b3305e3 100644
--- a/test/lisp/emacs-lisp/oclosure-tests.el
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -33,7 +33,7 @@
 
 (cl-defmethod oclosure-test-gen ((_x cons)) "#<cons>")
 
-(cl-defmethod oclosure-test-gen ((_x oclosure-object))
+(cl-defmethod oclosure-test-gen ((_x oclosure))
   (format "#<oclosure:%s>" (cl-call-next-method)))
 
 (cl-defmethod oclosure-test-gen ((_x oclosure-test))
@@ -60,7 +60,7 @@
     (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44)))
     (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44)))
     (should (cl-typep ocl1 'oclosure-test))
-    (should (cl-typep ocl1 'oclosure-object))
+    (should (cl-typep ocl1 'oclosure))
     (should (member (oclosure-test-gen ocl1)
                     '("#<oclosure-test:#<oclosure:#<cons>>>"
                       "#<oclosure-test:#<oclosure:#<bytecode>>>")))
@@ -154,4 +154,32 @@
     (should (equal 'cm3 (oclosure-test-mixin2--cm ocl3)))
     (should (equal 'd3 (oclosure-test-mixin3--d ocl3)))))
 
+(ert-deftest oclosure-tests-slot-value ()
+  (require 'eieio)
+  (let ((ocl1 (oclosure-lambda (oclosure-test-mixin1 (a 'a1) (b 'b1) (bm 'bm1))
+                  (x) (list a b x)))
+        (ocl2 (oclosure-lambda (oclosure-test-mixin2 (a 'a2) (c 'c2) (cm 'cm2))
+                  (x) (list a c x)))
+        (ocl3 (oclosure-lambda (oclosure-test-mixin3
+                                (a 'a3) (b 'b3) (bm 'bm3) (c 'c3) (cm 'cm3)
+                                (d 'd3))
+                  (x) (list a b c d x))))
+    (should (equal 'a1  (slot-value ocl1 'a)))
+    (should (equal 'a2  (slot-value ocl2 'a)))
+    (should (equal 'a3  (slot-value ocl3 'a)))
+    (should (equal 'b1  (slot-value ocl1 'b)))
+    (should (equal 'b3  (slot-value ocl3 'b)))
+    (should (equal 'bm1 (slot-value ocl1 'bm)))
+    (should (equal 'bm3 (slot-value ocl3 'bm)))
+    (should (equal 'c2  (slot-value ocl2 'c)))
+    (should (equal 'c3  (slot-value ocl3 'c)))
+    (should (equal 'cm2 (slot-value ocl2 'cm)))
+    (should (equal 'cm3 (slot-value ocl3 'cm)))
+    (should (equal 'd3  (slot-value ocl3 'd)))
+    (setf (slot-value ocl3 'cm) 'new-cm3)
+    (should (equal 'new-cm3 (slot-value ocl3 'cm)))
+    (should-error (setf (slot-value ocl3 'c) 'new-cm3) :type 'setting-constant)
+    (should (equal 'c3 (slot-value ocl3 'c)))
+    ))
+
 ;;; oclosure-tests.el ends here.



reply via email to

[Prev in Thread] Current Thread [Next in Thread]