[Emacs-diffs] scratch/record 8d2551f 2/7: Make cl-defstruct use records.

[Lars Brinkhoff]

branch: scratch/record
commit 8d2551f5a0df2d9ac5a8f1fdd16e488caba6d68b
Author: Lars Brinkhoff <address@hidden>
Commit: Lars Brinkhoff <address@hidden>

    Make cl-defstruct 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): When type is nil, use records.
    Use the type symbol as the tag.  Use copy-record to copy structs.
    (cl--defstruct-predicate): New function.
    (cl--pcase-mutually-exclusive-p): Use it.
    (cl-struct-sequence-type): Can now return `record'.
    
    * lisp/emacs-lisp/cl-preloaded.el (cl--make-slot-desc): Adjust ad-hoc
    code to new format.
    (cl--struct-register-child): Work with records.
    (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/cl-print.el (cl-print-object): Adjust to new tag.
    
    * test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-defstruct-record):
    New test.
    
    * doc/lispref/records.texi, doc/misc/cl.texi: Update for records.
---
 doc/lispref/records.texi             |  3 +-
 doc/misc/cl.texi                     | 51 +++++++++++++++--------------
 lisp/emacs-lisp/cl-generic.el        | 24 +++-----------
 lisp/emacs-lisp/cl-macs.el           | 62 +++++++++++++++++++++++++-----------
 lisp/emacs-lisp/cl-preloaded.el      |  6 ++--
 lisp/emacs-lisp/cl-print.el          |  2 +-
 test/lisp/emacs-lisp/cl-lib-tests.el |  7 ++++
 7 files changed, 85 insertions(+), 70 deletions(-)

diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi
index a11b431..63ea5fb 100644
--- a/doc/lispref/records.texi
+++ b/doc/lispref/records.texi
@@ -8,7 +8,8 @@
 @cindex record
 
   The purpose of records is to allow programmers to create objects
-with new types that are not built into Emacs.
+with new types that are not built into Emacs.  They are used as the
+underlying representation of @code{cl-defstruct} 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/cl.texi b/doc/misc/cl.texi
index 079f534..abfac5d 100644
--- a/doc/misc/cl.texi
+++ b/doc/misc/cl.texi
@@ -4012,10 +4012,7 @@ Given a @code{person}, @code{(copy-person @var{p})} 
makes a new
 object of the same type whose slots are @code{eq} to those of @var{p}.
 
 Given any Lisp object @var{x}, @code{(person-p @var{x})} returns
-true if @var{x} looks like a @code{person}, and false otherwise.  (Again,
-in Common Lisp this predicate would be exact; in Emacs Lisp the
-best it can do is verify that @var{x} is a vector of the correct
-length that starts with the correct tag symbol.)
+true if @var{x} is a @code{person}, and false otherwise.
 
 Accessors like @code{person-name} normally check their arguments
 (effectively using @code{person-p}) and signal an error if the
@@ -4221,16 +4218,16 @@ allow for such a feature, so this package simply ignores
 @code{:print-function}.
 
 @item :type
-The argument should be one of the symbols @code{vector} or @code{list}.
-This tells which underlying Lisp data type should be used to implement
-the new structure type.  Vectors are used by default, but
address@hidden(:type list)} will cause structure objects to be stored as
-lists instead.
+The argument should be one of the symbols @code{vector} or
address@hidden  This tells which underlying Lisp data type should be
+used to implement the new structure type.  Records are used by
+default, but @code{(:type vector)} will cause structure objects to be
+stored as vectors and @code{(:type list)} lists instead.
 
-The vector representation for structure objects has the advantage
-that all structure slots can be accessed quickly, although creating
-vectors is a bit slower in Emacs Lisp.  Lists are easier to create,
-but take a relatively long time accessing the later slots.
+The record and vector representations for structure objects has the
+advantage that all structure slots can be accessed quickly, although
+creating them are a bit slower in Emacs Lisp.  Lists are easier to
+create, but take a relatively long time accessing the later slots.
 
 @item :named
 This option, which takes no arguments, causes a characteristic ``tag''
@@ -4239,21 +4236,24 @@ symbol to be stored at the front of the structure 
object.  Using
 structure type stored as plain vectors or lists with no identifying
 features.
 
-The default, if you don't specify @code{:type} explicitly, is to
-use named vectors.  Therefore, @code{:named} is only useful in
-conjunction with @code{:type}.
+The default, if you don't specify @code{:type} explicitly, is to use
+records, which are always tagged.  Therefore, @code{:named} is only
+useful in conjunction with @code{:type}.
 
 @example
 (cl-defstruct (person1) name age sex)
 (cl-defstruct (person2 (:type list) :named) name age sex)
 (cl-defstruct (person3 (:type list)) name age sex)
+(cl-defstruct (person4 (:type vector)) name age sex)
 
 (setq p1 (make-person1))
-     @result{} [cl-struct-person1 nil nil nil]
+     @result{} #%[person1 nil nil nil]
 (setq p2 (make-person2))
      @result{} (person2 nil nil nil)
 (setq p3 (make-person3))
      @result{} (nil nil nil)
+(setq p4 (make-person4))
+     @result{} [nil nil nil]
 
 (person1-p p1)
      @result{} t
@@ -4293,9 +4293,9 @@ introspection functions.
 
 @defun cl-struct-sequence-type struct-type
 This function returns the underlying data structure for
address@hidden, which is a symbol.  It returns @code{vector} or
address@hidden, or @code{nil} if @code{struct-type} is not actually a
-structure.
address@hidden, which is a symbol.  It returns @code{record},
address@hidden or @code{list}, or @code{nil} if @code{struct-type} is
+not actually a structure.
 @end defun
 
 @defun cl-struct-slot-info struct-type
@@ -4562,9 +4562,8 @@ set down in Steele's book.
 
 The variable @code{cl--gensym-counter} starts out with zero.
 
-The @code{cl-defstruct} facility is compatible, except that structures
-are of type @code{:type vector :named} by default rather than some
-special, distinct type.  Also, the @code{:type} slot option is ignored.
+The @code{cl-defstruct} facility is compatible, except that the
address@hidden:type} slot option is ignored.
 
 The second argument of @code{cl-check-type} is treated differently.
 
@@ -4713,9 +4712,9 @@ Lisp.  Rational numbers and complex numbers are not 
present,
 nor are large integers (all integers are ``fixnums'').  All
 arrays are one-dimensional.  There are no readtables or pathnames;
 streams are a set of existing data types rather than a new data
-type of their own.  Hash tables, random-states, structures, and
-packages (obarrays) are built from Lisp vectors or lists rather
-than being distinct types.
+type of their own.  Hash tables, random-states, and packages
+(obarrays) are built from Lisp vectors or lists rather than being
+distinct types.
 
 @item
 The Common Lisp Object System (CLOS) is not implemented,
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 8c6d3d5..e15c942 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1082,24 +1082,8 @@ These match if the argument is `eql' to VAL."
 ;;; Support for cl-defstructs specializers.
 
 (defun cl--generic-struct-tag (name &rest _)
-  ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
-  ;; but that would suffer from some problems:
-  ;; - the vector may have size 0.
-  ;; - when called on an actual vector (rather than an object), we'd
-  ;;   end up returning an arbitrary value, possibly colliding with
-  ;;   other tagcode's values.
-  ;; - it can also result in returning all kinds of irrelevant
-  ;;   values which would end up filling up the method-cache with
-  ;;   lots of irrelevant/redundant entries.
-  ;; FIXME: We could speed this up by introducing a dedicated
-  ;; vector type at the C level, so we could do something like
-  ;; (and (vector-objectp ,name) (aref ,name 0))
-  `(and (vectorp ,name)
-        (> (length ,name) 0)
-        (let ((tag (aref ,name 0)))
-          (and (symbolp tag)
-               (eq (symbol-function tag) :quick-object-witness-check)
-               tag))))
+  ;; Use exactly the same code as for `typeof'.
+  `(if ,name (type-of ,name) 'null))
 
 (defun cl--generic-class-parents (class)
   (let ((parents ())
@@ -1113,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 58bcdd5..c282938 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))
-               (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,7 +2709,9 @@ non-nil value, that slot cannot be set via `setf'.
                                       (length (memq (assq 'cl-tag-slot descs)
                                                     descs)))))
                           (cond
-                            ((memq type '(nil vector))
+                            ((null type) ;Record type.
+                             `(memq (type-of cl-x) ,tag-symbol))
+                            ((eq type 'vector)
                              `(and (vectorp cl-x)
                                    (>= (length cl-x) ,(length descs))
                                    (memq (aref cl-x ,pos) ,tag-symbol)))
@@ -2793,7 +2808,9 @@ non-nil value, that slot cannot be set via `setf'.
     (setq slots (nreverse slots)
          defaults (nreverse defaults))
     (and copier
-         (push `(defalias ',copier #'copy-sequence) forms))
+         (push `(defalias ',copier
+                    ,(if (null type) '#'copy-record '#'copy-sequence))
+               forms))
     (if constructor
        (push (list constructor
                     (cons '&key (delq nil (copy-sequence slots))))
@@ -2808,7 +2825,7 @@ non-nil value, that slot cannot be set via `setf'.
                     (format "Constructor for objects of type `%s'." name))
                  ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
                        '((declare (side-effect-free t))))
-                 (,(or type #'vector) ,@make))
+                 (,(or type #'record) ,@make))
               forms)))
     (if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
     ;; Don't bother adding to cl-custom-print-functions since it's not used
@@ -2866,6 +2883,15 @@ is a shorthand for (NAME NAME)."
                      ,pat)))
            fields)))
 
+(defun cl--defstruct-predicate (type)
+  (let ((cons (assq (cl-struct-sequence-type type)
+                    `((list . consp)
+                      (vector . vectorp)
+                      (nil . recordp)))))
+    (if cons
+        (cdr cons)
+      'recordp)))
+
 (defun cl--pcase-mutually-exclusive-p (orig pred1 pred2)
   "Extra special cases for `cl-typep' predicates."
   (let* ((x1 pred1) (x2 pred2)
@@ -2888,14 +2914,12 @@ is a shorthand for (NAME NAME)."
                           (memq c2 (cl--struct-all-parents c1)))))))
      (let ((c1 (and (symbolp t1) (cl--find-class t1))))
        (and c1 (cl--struct-class-p c1)
-            (funcall orig (if (eq 'list (cl-struct-sequence-type t1))
-                              'consp 'vectorp)
+            (funcall orig (cl--defstruct-predicate t1)
                      pred2)))
      (let ((c2 (and (symbolp t2) (cl--find-class t2))))
        (and c2 (cl--struct-class-p c2)
             (funcall orig pred1
-                     (if (eq 'list (cl-struct-sequence-type t2))
-                         'consp 'vectorp))))
+                     (cl--defstruct-predicate t2))))
      (funcall orig pred1 pred2))))
 (advice-add 'pcase--mutually-exclusive-p
             :around #'cl--pcase-mutually-exclusive-p)
@@ -2903,8 +2927,8 @@ is a shorthand for (NAME NAME)."
 
 (defun cl-struct-sequence-type (struct-type)
   "Return the sequence used to build STRUCT-TYPE.
-STRUCT-TYPE is a symbol naming a struct type.  Return `vector' or
-`list', or nil if STRUCT-TYPE is not a struct type. "
+STRUCT-TYPE is a symbol naming a struct type.  Return `record',
+`vector`, or `list' if STRUCT-TYPE is a struct type, nil otherwise."
   (declare (side-effect-free t) (pure t))
   (cl--struct-class-type (cl--struct-get-class struct-type)))
 
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 482b579..7432dd4 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)
-        (vector 'cl-struct-cl-slot-descriptor
+        (record 'cl-slot-descriptor
                 name initform type props)))
 
 (defun cl--struct-get-class (name)
@@ -101,7 +101,7 @@
 (defun cl--struct-register-child (parent tag)
   ;; Can't use (cl-typep parent 'cl-structure-class) at this stage
   ;; because `cl-structure-class' is defined later.
-  (while (vectorp parent)
+  (while (recordp parent)
     (add-to-list (cl--struct-class-children-sym parent) tag)
     ;; Only register ourselves as a child of the leftmost parent since structs
     ;; can only only have one parent.
@@ -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/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 8a8d4a4..65c86d2 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -137,7 +137,7 @@ call other entry points instead, such as `cl-prin1'."
 
 (cl-defmethod cl-print-object ((object cl-structure-object) stream)
   (princ "#s(" stream)
-  (let* ((class (symbol-value (aref object 0)))
+  (let* ((class (cl-find-class (type-of object)))
          (slots (cl--struct-class-slots class)))
     (princ (cl--struct-class-name class) stream)
     (dotimes (i (length slots))
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el 
b/test/lisp/emacs-lisp/cl-lib-tests.el
index 5edc3e7..26b19e9 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -493,4 +493,11 @@
   (should (cl-typep '* 'cl-lib-test-type))
   (should-not (cl-typep 1 'cl-lib-test-type)))
 
+(ert-deftest cl-lib-defstruct-record ()
+  (cl-defstruct foo x)
+  (let ((x (make-foo :x 42)))
+    (should (recordp x))
+    (should (eq (type-of x) 'foo))
+    (should (eql (foo-x x) 42))))
+
 ;;; cl-lib.el ends here