[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.
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- scratch/oclosure 3906eb80b6: oclosure.el: Add support for `slot-value`,
Stefan Monnier <=