Make cl-defstruct use records.

* lisp/emacs-lisp/cl-extra.el (cl--describe-class) (cl--describe-class-slots): Use the new `type-of'. * 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.
2017-03-14 13:52:40 +01:00 · 2017-03-14 13:52:40 +01:00 · 0565482838
commit 0565482838
parent a2c3343029
8 changed files with 87 additions and 74 deletions
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@ -775,8 +775,7 @@ including `cl-block' and `cl-eval-when'."
 (defun cl--describe-class (type &optional class)
  (unless class (setq class (cl--find-class type)))
  (let ((location (find-lisp-object-file-name type 'define-type))
-        ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch.
-        (metatype (cl--class-name (symbol-value (aref class 0)))))
+        (metatype (type-of class)))
    (insert (symbol-name type)
            (substitute-command-keys " is a type (of kind `"))
    (help-insert-xref-button (symbol-name metatype)
@ -901,8 +900,7 @@ including `cl-block' and `cl-eval-when'."
  "Print help description for the slots in CLASS.
 Outputs to the current buffer."
  (let* ((slots (cl--class-slots class))
-         ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch.
-         (metatype (cl--class-name (symbol-value (aref class 0))))
+         (metatype (type-of class))
         ;; ¡For EIEIO!
         (cslots (condition-case nil
                     (cl-struct-slot-value metatype 'class-slots class)
--- 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)))))

--- 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)))

--- 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
--- 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))