[Emacs-diffs] scratch/record cb31583 3/5: Make EIEIO use records.

[Lars Brinkhoff]

branch: scratch/record
commit cb315830a6bb2637316bef8664822dac4b8ad0f8
Author: Stefan Monnier <address@hidden>
Commit: Lars Brinkhoff <address@hidden>

    Make EIEIO use records.
    
    * lisp/emacs-lisp/eieio-compat.el
    (eieio--generic-static-object-generalizer): Adjust to new tags.
    
    * lisp/emacs-lisp/eieio-core.el: Use records, and place the class object
    directly as tag.
    (eieio--object-class): Adjust to new tag representation.
    (eieio-object-p): Rewrite, and adapt to new `type-of' behavior.
    (eieio-defclass-internal): Use `make-record'.
    (eieio--generic-generalizer): Adjust generalizer code accordingly.
    
    * lisp/emacs-lisp/eieio.el (make-instance, clone): Use copy-record.
    
    * lisp/emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates):
    Add `recordp'.
    
    * doc/lispref/records.texi, doc/misc/eieio.texi: Update for records.
---
 doc/lispref/records.texi        |  3 ++-
 doc/misc/eieio.texi             |  8 +++----
 lisp/emacs-lisp/eieio-base.el   |  3 +--
 lisp/emacs-lisp/eieio-compat.el |  2 +-
 lisp/emacs-lisp/eieio-core.el   | 50 +++++++++++++----------------------------
 lisp/emacs-lisp/eieio.el        | 12 +++++-----
 lisp/emacs-lisp/pcase.el        |  6 +++++
 7 files changed, 35 insertions(+), 49 deletions(-)

diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi
index 618f30a..822fd2b 100644
--- a/doc/lispref/records.texi
+++ b/doc/lispref/records.texi
@@ -9,7 +9,8 @@
 
   The purpose of records is to allow programmers to create objects
 with new types that are not built into Emacs.  They are used as the
-underlying representation of @code{cl-defstruct} instances.
+underlying representation of @code{cl-defstruct} and @code{defclass}
+instances.
 
   Internally, a record object is much like a vector; its slots can be
 accessed using @code{aref}.  However, the first slot is used to hold
diff --git a/doc/misc/eieio.texi b/doc/misc/eieio.texi
index dfae565..7076c24 100644
--- a/doc/misc/eieio.texi
+++ b/doc/misc/eieio.texi
@@ -1017,7 +1017,7 @@ If @var{errorp} is address@hidden, 
@code{wrong-argument-type} is signaled.
 
 @defun class-p class
 @anchor{class-p}
-Return @code{t} if @var{class} is a valid class vector.
+Return @code{t} if @var{class} is a valid class object.
 @var{class} is a symbol.
 @end defun
 
@@ -1055,7 +1055,7 @@ Will fetch the documentation string for 
@code{eieio-default-superclass}.
 Return a string of the form @samp{#<object-class myobjname>} for @var{obj}.
 This should look like Lisp symbols from other parts of Emacs such as
 buffers and processes, and is shorter and cleaner than printing the
-object's vector.  It is more useful to use @code{object-print} to get
+object's record.  It is more useful to use @code{object-print} to get
 and object's print form, as this allows the object to add extra display
 information into the symbol.
 @end defun
@@ -1212,7 +1212,7 @@ items defined in this second slot.
 
 Introspection permits a programmer to peek at the contents of a class
 without any previous knowledge of that class.  While @eieio{} implements
-objects on top of vectors, and thus everything is technically visible,
+objects on top of records, and thus everything is technically visible,
 some functions have been provided.  None of these functions are a part
 of CLOS.
 
@@ -1525,7 +1525,7 @@ Currently, the default superclass is defined as follows:
   nil
   "Default parent class for classes with no specified parent class.
 Its slots are automatically adopted by classes with no specified
-parents.  This class is not stored in the `parent' slot of a class vector."
+parents.  This class is not stored in the `parent' slot of a class object."
   :abstract t)
 @end example
 
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 986d028..33c71ec 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -294,8 +294,7 @@ Second, any text properties will be stripped from strings."
   (cond ((consp proposed-value)
         ;; Lists with something in them need special treatment.
         (let* ((slot-idx (- (eieio--slot-name-index class slot)
-                             (eval-when-compile
-                               (length (cl-struct-slot-info 'eieio--object)))))
+                             (eval-when-compile eieio--object-num-slots)))
                 (type (cl--slot-descriptor-type (aref (eieio--class-slots 
class)
                                                       slot-idx)))
                 (classtype (eieio-persistent-slot-type-is-class-p type)))
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index 888d85f..d6eb0b4 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -145,7 +145,7 @@ Summary:
   ;; interleaved list comes before the class's non-interleaved list.
   51 #'cl--generic-struct-tag
   (lambda (tag &rest _)
-    (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag))
+    (and (symbolp tag) (setq tag (cl--find-class tag))
          (eieio--class-p tag)
          (let ((superclasses (eieio--class-precedence-list tag))
                (specializers ()))
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 5cc6d02..c59f85d 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -108,21 +108,14 @@ Currently under control of this var:
   (cl-declaim (optimize (safety 1))))
 
 
-(cl-defstruct (eieio--object
-               (:type vector)           ;We manage our own tagging system.
-               (:constructor nil)
-               (:copier nil))
-  ;; `class-tag' holds a symbol, which is not the class name, but is instead
-  ;; properly prefixed as an internal EIEIO thingy and which holds the class
-  ;; object/struct in its `symbol-value' slot.
-  class-tag)
+(eval-and-compile
+  (defconst eieio--object-num-slots 1))
 
-(eval-when-compile
-  (defconst eieio--object-num-slots
-    (length (cl-struct-slot-info 'eieio--object))))
+(defsubst eieio--object-class-tag (obj)
+  (aref obj 0))
 
 (defsubst eieio--object-class (obj)
-  (symbol-value (eieio--object-class-tag obj)))
+  (eieio--object-class-tag obj))
 
 
 ;;; Important macros used internally in eieio.
@@ -166,13 +159,8 @@ Return nil if that option doesn't exist."
 
 (defun eieio-object-p (obj)
   "Return non-nil if OBJ is an EIEIO object."
-  (and (vectorp obj)
-       (> (length obj) 0)
-       (let ((tag (eieio--object-class-tag obj)))
-         (and (symbolp tag)
-              ;; (eq (symbol-function tag) :quick-object-witness-check)
-              (boundp tag)
-              (eieio--class-p (symbol-value tag))))))
+  (and (recordp obj)
+       (eieio--class-p (eieio--object-class-tag obj))))
 
 (define-obsolete-function-alias 'object-p 'eieio-object-p "25.1")
 
@@ -496,18 +484,11 @@ See `defclass' for more information."
     (if clearparent (setf (eieio--class-parents newc) nil))
 
     ;; Create the cached default object.
-    (let ((cache (make-vector (+ (length (eieio--class-slots newc))
-                                 (eval-when-compile eieio--object-num-slots))
-                              nil))
-          ;; We don't strictly speaking need to use a symbol, but the old
-          ;; code used the class's name rather than the class's object, so
-          ;; we follow this preference for using a symbol, which is probably
-          ;; convenient to keep the printed representation of such Elisp
-          ;; objects readable.
-          (tag (intern (format "eieio-class-tag--%s" cname))))
-      (set tag newc)
-      (fset tag :quick-object-witness-check)
-      (setf (eieio--object-class-tag cache) tag)
+    (let ((cache (make-record newc
+                              (+ (length (eieio--class-slots newc))
+                                 (eval-when-compile eieio--object-num-slots)
+                                 -1)
+                              nil)))
       (let ((eieio-skip-typecheck t))
        ;; All type-checking has been done to our satisfaction
        ;; before this call.  Don't waste our time in this call..
@@ -1060,9 +1041,10 @@ method invocation orders of the involved classes."
   ;; part of the dispatch code.
   50 #'cl--generic-struct-tag
   (lambda (tag &rest _)
-    (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
-         (mapcar #'eieio--class-name
-                 (eieio--class-precedence-list (symbol-value tag))))))
+    (let ((class (cl--find-class tag)))
+      (and (eieio--class-p class)
+           (mapcar #'eieio--class-name
+                   (eieio--class-precedence-list class))))))
 
 (cl-defmethod cl-generic-generalizers :extra "class" (specializer)
   "Support for dispatch on types defined by EIEIO's `defclass'."
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 1a6d5e9..858b2fd 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -337,14 +337,12 @@ variable name of the same name as the slot."
 ;; hard-coded in random .elc files.
 (defun eieio-pcase-slot-index-table (obj)
   "Return some data structure from which can be extracted the slot offset."
-  (eieio--class-index-table
-   (symbol-value (eieio--object-class-tag obj))))
+  (eieio--class-index-table (eieio--object-class obj)))
 
 (defun eieio-pcase-slot-index-from-index-table (index-table slot)
   "Find the index to pass to `aref' to access SLOT."
   (let ((index (gethash slot index-table)))
-    (if index (+ (eval-when-compile
-                   (length (cl-struct-slot-info 'eieio--object)))
+    (if index (+ (eval-when-compile eieio--object-num-slots)
                  index))))
 
 (pcase-defmacro eieio (&rest fields)
@@ -701,8 +699,8 @@ SLOTS are the initialization slots used by 
`initialize-instance'.
 This static method is called when an object is constructed.
 It allocates the vector used to represent an EIEIO object, and then
 calls `initialize-instance' on that object."
-  (let* ((new-object (copy-sequence (eieio--class-default-object-cache
-                                     (eieio--class-object class)))))
+  (let* ((new-object (copy-record (eieio--class-default-object-cache
+                                   (eieio--class-object class)))))
     (if (and slots
              (let ((x (car slots)))
                (or (stringp x) (null x))))
@@ -806,7 +804,7 @@ first and modify the returned object.")
 
 (cl-defmethod clone ((obj eieio-default-superclass) &rest params)
   "Make a copy of OBJ, and then apply PARAMS."
-  (let ((nobj (copy-sequence obj)))
+  (let ((nobj (copy-record obj)))
     (if (stringp (car params))
         (funcall (if eieio-backward-compatibility #'ignore #'message)
                  "Obsolete name %S passed to clone" (pop params)))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index fc5474e..4a06ab2 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -503,24 +503,30 @@ MATCH is the pattern that needs to be matched, of the 
form:
     (symbolp . vectorp)
     (symbolp . stringp)
     (symbolp . byte-code-function-p)
+    (symbolp . recordp)
     (integerp . consp)
     (integerp . arrayp)
     (integerp . vectorp)
     (integerp . stringp)
     (integerp . byte-code-function-p)
+    (integerp . recordp)
     (numberp . consp)
     (numberp . arrayp)
     (numberp . vectorp)
     (numberp . stringp)
     (numberp . byte-code-function-p)
+    (numberp . recordp)
     (consp . arrayp)
     (consp . atom)
     (consp . vectorp)
     (consp . stringp)
     (consp . byte-code-function-p)
+    (consp . recordp)
     (arrayp . byte-code-function-p)
     (vectorp . byte-code-function-p)
+    (vectorp . recordp)
     (stringp . vectorp)
+    (stringp . recordp)
     (stringp . byte-code-function-p)))
 
 (defun pcase--mutually-exclusive-p (pred1 pred2)