[Emacs-diffs] scratch/record cc0d513: Tweak cl's structs; make EIEIO use records

[Stefan Monnier]

branch: scratch/record
commit cc0d5131d5d8251906521f48f807a3fa212debb7
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    Tweak cl's structs; make EIEIO use records
    
    * lisp/emacs-lisp/cl-generic.el (cl--generic-struct-tag): Use type-of.
    (cl--generic-struct-specializers): Adjust to new tag.
    
    * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Use type=nil as before.
    Use the type symbol as the tag.
    (cl--defstruct-predicate): Add missing `cl-struct-sequence-type'.
    
    * lisp/emacs-lisp/cl-preloaded.el (cl--make-slot-desc): Adjust ad-hoc
    code to new format.
    (cl-struct-define): Don't touch the tag's symbol-value and
    symbol-function slots when we use the type as tag.
    
    * 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.
    (eieio-defclass-internal): Use `make-record'.
    (eieio--generic-generalizer): Adjust generalizer code accordingly.
    
    * lisp/emacs-lisp/eieio.el (make-instance): Use copy-record.
    
    * lisp/emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates):
    Add `recordp'.
    
    * src/alloc.c (Fcopy_record): New function.
    (syms_of_alloc): defsubr it.
    
    * src/data.c (syms_of_data): Define `Qrecordp'.
    
    * src/lisp.h (CHECK_RECORD_TYPE): Allow anything for now.
    (CHECK_RECORD): New function.
---
 lisp/emacs-lisp/cl-generic.el   |  7 +++---
 lisp/emacs-lisp/cl-macs.el      | 47 ++++++++++++++++++++++++++---------------
 lisp/emacs-lisp/cl-preloaded.el |  4 ++--
 lisp/emacs-lisp/eieio-core.el   | 28 ++++++------------------
 lisp/emacs-lisp/eieio.el        |  4 ++--
 lisp/emacs-lisp/pcase.el        |  6 ++++++
 src/alloc.c                     | 16 ++++++++++++++
 src/data.c                      |  1 +
 src/lisp.h                      | 18 ++++++++++------
 9 files changed, 80 insertions(+), 51 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 9fe4de7..e15c942 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1082,7 +1082,8 @@ These match if the argument is `eql' to VAL."
 ;;; Support for cl-defstructs specializers.
 
 (defun cl--generic-struct-tag (name &rest _)
-  `(and (recordp ,name) (aref ,name 0)))
+  ;; Use exactly the same code as for `typeof'.
+  `(if ,name (type-of ,name) 'null))
 
 (defun cl--generic-class-parents (class)
   (let ((parents ())
@@ -1096,8 +1097,8 @@ These match if the argument is `eql' to VAL."
     (nreverse parents)))
 
 (defun cl--generic-struct-specializers (tag &rest _)
-  (and (symbolp tag) (boundp tag)
-       (let ((class (symbol-value tag)))
+  (and (symbolp tag)
+       (let ((class (get tag 'cl--class)))
          (when (cl-typep class 'cl-structure-class)
            (cl--generic-class-parents class)))))
 
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index e09fecb..6f00f29 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2604,11 +2604,24 @@ non-nil value, that slot cannot be set via `setf'.
         (print-func nil) (print-auto nil)
         (safety (if (cl--compiling-file) cl--optimize-safety 3))
         (include nil)
-        (tag (intern (format "cl-struct-%s" name)))
+         ;; There are 4 types of structs:
+         ;; - `vector' type: means we should use a vector, which can come
+         ;;   with or without a tag `name', which is usually in slot 0
+         ;;   but obeys :initial-offset.
+         ;; - `list' type: same as `vector' but using lists.
+         ;; - `record' type: means we should use a record, which necessarily
+         ;;   comes tagged in slot 0.  Currently we'll use the `name' as
+         ;;   the tag, but we may want to change it so that the class object
+         ;;   is used as the tag.
+         ;; - nil type: this is the "pre-record default", which uses a vector
+         ;;   with a tag in slot 0 which is a symbol of the form
+         ;;   `cl-struct-NAME'.  We need to still support this for backward
+         ;;   compatibility with old .elc files.
+        (tag name)
         (tag-symbol (intern (format "cl-struct-%s-tags" name)))
         (include-descs nil)
         (include-name nil)
-        (type nil)
+        (type nil)         ;nil here means not specified explicitly.
         (named nil)
         (forms nil)
          (docstring (if (stringp (car descs)) (pop descs)))
@@ -2648,7 +2661,9 @@ non-nil value, that slot cannot be set via `setf'.
              ((eq opt :print-function)
               (setq print-func (car args)))
              ((eq opt :type)
-              (setq type (car args)))
+              (setq type (car args))
+               (unless (memq type '(vector list))
+                 (error "Invalid :type specifier: %s" type)))
              ((eq opt :named)
               (setq named t))
              ((eq opt :initial-offset)
@@ -2680,13 +2695,11 @@ non-nil value, that slot cannot be set via `setf'.
                    (pop include-descs)))
          (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
                type inc-type
-               named (if type (assq 'cl-tag-slot descs) 'true))
-         (if (cl--struct-class-named include) (setq tag name named t)))
-      (if type
-         (progn
-           (or (memq type '(vector list record))
-               (error "Invalid :type specifier: %s" type))
-           (if named (setq tag name)))
+               named (if (memq type '(vector list))
+                          (assq 'cl-tag-slot descs)
+                        'true))
+         (if (cl--struct-class-named include) (setq named t)))
+      (unless type
        (setq named 'true)))
     (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
     (when (and (null predicate) named)
@@ -2696,9 +2709,8 @@ non-nil value, that slot cannot be set via `setf'.
                                       (length (memq (assq 'cl-tag-slot descs)
                                                     descs)))))
                           (cond
-                            ((memq type '(nil record))
-                             `(and (recordp cl-x)
-                                   (memq (type-of cl-x) ,tag-symbol)))
+                            ((null type) ;Record type.
+                             `(memq (type-of cl-x) ,tag-symbol))
                             ((eq type 'vector)
                              `(and (vectorp cl-x)
                                    (>= (length cl-x) ,(length descs))
@@ -2743,7 +2755,7 @@ non-nil value, that slot cannot be set via `setf'.
                              (list `(or ,pred-check
                                          (signal 'wrong-type-argument
                                                  (list ',name cl-x)))))
-                       ,(if (memq type '(nil vector record)) `(aref cl-x ,pos)
+                       ,(if (memq type '(nil vector)) `(aref cl-x ,pos)
                           (if (= pos 0) '(car cl-x)
                             `(nth ,pos cl-x))))
                     forms)
@@ -2870,9 +2882,10 @@ is a shorthand for (NAME NAME)."
            fields)))
 
 (defun cl--defstruct-predicate (type)
-  (let ((cons (assq type `((list . consp)
-                           (vector . vectorp)
-                           (record . recordp)))))
+  (let ((cons (assq (cl-struct-sequence-type type)
+                    `((list . consp)
+                      (vector . vectorp)
+                      (nil . recordp)))))
     (if cons
         (cdr cons)
       'recordp)))
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index b19aa7c..bd77654 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -64,7 +64,7 @@
       ;; cl--slot-descriptor.
       ;; BEWARE: Obviously, it's important to keep the two in sync!
       (lambda (name &optional initform type props)
-        (record 'cl-struct-cl-slot-descriptor
+        (record 'cl-slot-descriptor
                 name initform type props)))
 
 (defun cl--struct-get-class (name)
@@ -150,7 +150,7 @@
                    parent name))))
     (add-to-list 'current-load-list `(define-type . ,name))
     (cl--struct-register-child parent-class tag)
-    (unless (eq named t)
+    (unless (or (eq named t) (eq tag name))
       ;; We used to use `defconst' instead of `set' but that
       ;; has a side-effect of purecopying during the dump, so that the
       ;; class object stored in the tag ends up being a *copy* of the
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 5cc6d02..882e7fb 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -122,7 +122,7 @@ Currently under control of this var:
     (length (cl-struct-slot-info 'eieio--object))))
 
 (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 +166,7 @@ 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))))))
+  (eieio--class-p (type-of obj)))
 
 (define-obsolete-function-alias 'object-p 'eieio-object-p "25.1")
 
@@ -496,18 +490,10 @@ 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))
+    (let ((cache (make-record newc
+                              (+ (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)
+                              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 +1046,9 @@ 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))
+    (and (eieio--class-p tag)
          (mapcar #'eieio--class-name
-                 (eieio--class-precedence-list (symbol-value tag))))))
+                 (eieio--class-precedence-list tag)))))
 
 (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..8be24f2 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -701,8 +701,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))))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 289265a..6c4ac51 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)
diff --git a/src/alloc.c b/src/alloc.c
index f7dd934..14a179f 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3446,6 +3446,21 @@ usage: (record TYPE &rest SLOTS)  */)
 }
 
 
+DEFUN ("copy-record", Fcopy_record, Scopy_record, 1, 1, 0,
+       doc: /* Shallow copy of a record.  */)
+  (Lisp_Object record)
+{
+  CHECK_RECORD (record);
+  struct Lisp_Vector *src = XVECTOR (record);
+  ptrdiff_t size = ASIZE (record) & PSEUDOVECTOR_SIZE_MASK;
+  struct Lisp_Vector *new = allocate_record (size);
+  memcpy (&(new->contents[0]), &(src->contents[0]),
+          size * sizeof (Lisp_Object));
+  XSETVECTOR (record, new);
+  return record;
+}
+
+
 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
        doc: /* Return a newly created vector of length LENGTH, with each 
element being INIT.
 See also the function `vector'.  */)
@@ -7516,6 +7531,7 @@ The time is in seconds as a floating point value.  */);
   defsubr (&Slist);
   defsubr (&Svector);
   defsubr (&Srecord);
+  defsubr (&Scopy_record);
   defsubr (&Sbool_vector);
   defsubr (&Smake_byte_code);
   defsubr (&Smake_list);
diff --git a/src/data.c b/src/data.c
index e3998b6..8e0bccc 100644
--- a/src/data.c
+++ b/src/data.c
@@ -3624,6 +3624,7 @@ syms_of_data (void)
   DEFSYM (Qsequencep, "sequencep");
   DEFSYM (Qbufferp, "bufferp");
   DEFSYM (Qvectorp, "vectorp");
+  DEFSYM (Qrecordp, "recordp");
   DEFSYM (Qbool_vector_p, "bool-vector-p");
   DEFSYM (Qchar_or_string_p, "char-or-string-p");
   DEFSYM (Qmarkerp, "markerp");
diff --git a/src/lisp.h b/src/lisp.h
index 4f3ab35..d3793ac 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1409,12 +1409,6 @@ CHECK_VECTOR (Lisp_Object x)
   CHECK_TYPE (VECTORP (x), Qvectorp, x);
 }
 
-INLINE void
-CHECK_RECORD_TYPE (Lisp_Object x)
-{
-  CHECK_SYMBOL (x);
-}
-
 
 /* A pseudovector is like a vector, but has other non-Lisp components.  */
 
@@ -2742,6 +2736,18 @@ RECORDP (Lisp_Object a)
   return PSEUDOVECTORP (a, PVEC_RECORD);
 }
 
+INLINE void
+CHECK_RECORD (Lisp_Object x)
+{
+  CHECK_TYPE (RECORDP (x), Qrecordp, x);
+}
+
+INLINE void
+CHECK_RECORD_TYPE (Lisp_Object x)
+{
+  /* CHECK_SYMBOL (x); */
+}
+
 /* Test for image (image . spec)  */
 INLINE bool
 IMAGEP (Lisp_Object x)