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.
This commit is contained in:
Stefan Monnier
parent
6c4a4cc94e
commit
1f4f6b956b
3 changed files with 95 additions and 48 deletions
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue