[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master 1f4f6b956b: OClosure: add support for `slot-value`
From: |
Stefan Monnier |
Subject: |
master 1f4f6b956b: OClosure: add support for `slot-value` |
Date: |
Mon, 4 Apr 2022 15:06:56 -0400 (EDT) |
branch: master
commit 1f4f6b956bee611ffa406b3851e5264ee74e3bfb
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
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.
---
lisp/emacs-lisp/eieio-core.el | 104 ++++++++++++++++++---------------
lisp/emacs-lisp/oclosure.el | 20 +++++++
test/lisp/emacs-lisp/oclosure-tests.el | 19 +++++-
3 files changed, 95 insertions(+), 48 deletions(-)
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index ed1a28a24f..d687289b22 100644
--- 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 c37a5352a3..3df64ad280 100644
--- 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 c72a9dbd7a..d3e2b3870a 100644
--- 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.
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- master 1f4f6b956b: OClosure: add support for `slot-value`,
Stefan Monnier <=