[Emacs-diffs] scratch/record 8b7ea88 4/4: Make cl-defstruct use records by default.

[Lars Brinkhoff]

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

    Make cl-defstruct use records by default.
---
 lisp/emacs-lisp/cl-generic.el   | 19 +------------------
 lisp/emacs-lisp/cl-macs.el      | 14 ++++++--------
 lisp/emacs-lisp/cl-preloaded.el |  4 ++--
 3 files changed, 9 insertions(+), 28 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 8c6d3d5..9fe4de7 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1082,24 +1082,7 @@ 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))))
+  `(and (recordp ,name) (aref ,name 0)))
 
 (defun cl--generic-class-parents (class)
   (let ((parents ())
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 166f34b..e09fecb 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2656,8 +2656,6 @@ non-nil value, that slot cannot be set via `setf'.
                                  descs)))
              (t
               (error "Structure option %s unrecognized" opt)))))
-    (if (eq type 'record)
-        (setq named t))
     (unless (or include-name type)
       (setq include-name cl--struct-default-parent))
     (when include-name (setq include (cl--struct-get-class include-name)))
@@ -2698,13 +2696,13 @@ non-nil value, that slot cannot be set via `setf'.
                                       (length (memq (assq 'cl-tag-slot descs)
                                                     descs)))))
                           (cond
-                            ((memq type '(nil vector))
+                            ((memq type '(nil record))
+                             `(and (recordp cl-x)
+                                   (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)))
-                            ((eq type 'record)
-                             `(and (recordp cl-x)
-                                   (memq (type-of cl-x) ,tag-symbol)))
                             ((= pos 0) `(memq (car-safe cl-x) ,tag-symbol))
                             (t `(and (consp cl-x)
                                     (memq (nth ,pos cl-x) ,tag-symbol))))))
@@ -2813,7 +2811,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
@@ -2877,7 +2875,7 @@ is a shorthand for (NAME NAME)."
                            (record . recordp)))))
     (if cons
         (cdr cons)
-      'vectorp)))
+      'recordp)))
 
 (defun cl--pcase-mutually-exclusive-p (orig pred1 pred2)
   "Extra special cases for `cl-typep' predicates."
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index bba7b83..b19aa7c 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-struct-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.