Remove redundant slot validation in eieio-persistent-read

Actual object creation (in `make-instance') will later run all slot
values through cl-typep, which does a better job of validation. This
validation is redundant, and slows the read process down.

* lisp/emacs-lisp/eieio-base.el (eieio-persistent-fix-value): Rename
from `eieio-persistent-validate/fix-slot-value', as we no longer
validate, and we don't care about the slot definition.
(eieio-persistent-slot-type-is-class-p): Delete function.
(eieio-persistent-convert-list-to-object): Still call
`eieio--full-class-object', to trigger an autoload if necessary, but
discard the return value.

1 files changed, 63 insertions, 148 deletions

diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 2cb1f614ce3..f09d1997eee 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -266,105 +266,75 @@ malicious code.
 
 Note: This function recurses when a slot of :type of some object is
 identified, and needing more object creation."
-  (let* ((objclass (nth 0 inputlist))
-         ;; Earlier versions of `object-write' added a string name for
-         ;; the object, now obsolete.
-         (slots (nthcdr
-                 (if (stringp (nth 1 inputlist)) 2 1)
-                 inputlist))
-         (createslots nil)
-         (class
-          (progn
-            ;; If OBJCLASS is an eieio autoload object, then we need to
-            ;; load it.
-            (eieio--full-class-object objclass))))
-
+  (let ((objclass (nth 0 inputlist))
+        ;; Earlier versions of `object-write' added a string name for
+        ;; the object, now obsolete.
+        (slots (nthcdr
+                (if (stringp (nth 1 inputlist)) 2 1)
+                inputlist))
+        (createslots nil))
+    ;; If OBJCLASS is an eieio autoload object, then we need to
+    ;; load it (we don't need the return value).
+    (eieio--full-class-object objclass)
     (while slots
       (let ((initarg (car slots))
             (value (car (cdr slots))))
 
-        ;; Make sure that the value proposed for SLOT is valid.
-        ;; In addition, strip out quotes, list functions, and update
-        ;; object constructors as needed.
-        (setq value (eieio-persistent-validate/fix-slot-value
-                     class (eieio--initarg-to-attribute class initarg) value))
+        ;; Strip out quotes, list functions, and update object
+        ;; constructors as needed.
+        (setq value (eieio-persistent-fix-value value))
 
         (push initarg createslots)
-        (push value createslots)
-        )
+        (push value createslots))
 
       (setq slots (cdr (cdr slots))))
 
-    (apply #'make-instance objclass (nreverse createslots))
+    (apply #'make-instance objclass (nreverse createslots))))
 
-    ;;(eval inputlist)
-    ))
+(defun eieio-persistent-fix-value (proposed-value)
+  "Fix PROPOSED-VALUE.
+Remove leading quotes from lists, and the symbol `list' from the
+head of lists.  Explicitly construct any objects found, and strip
+any text properties from string values.
 
-(defun eieio-persistent-validate/fix-slot-value (class slot proposed-value)
-  "Validate that in CLASS, the SLOT with PROPOSED-VALUE is good, then fix.
-A limited number of functions, such as quote, list, and valid object
-constructor functions are considered valid.
-Second, any text properties will be stripped from strings."
+This function will descend into the contents of lists, hash
+tables, and vectors."
   (cond ((consp proposed-value)
          ;; Lists with something in them need special treatment.
-         (let* ((slot-idx (- (eieio--slot-name-index class slot)
-                             (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)))
-
-           (cond ((eq (car proposed-value) 'quote)
-                  (car (cdr proposed-value)))
-
-                 ;; An empty list sometimes shows up as (list), which is dumb, but
-                 ;; we need to support it for backward compat.
-                 ((and (eq (car proposed-value) 'list)
-                       (= (length proposed-value) 1))
-                  nil)
-
-                 ;; List of object constructors.
-                 ((and (eq (car proposed-value) 'list)
-                       ;; 2nd item is a list.
-                       (consp (car (cdr proposed-value)))
-                       ;; 1st elt of 2nd item is a class name.
-                       (class-p (car (car (cdr proposed-value))))
-                       )
-
-                  ;; Check the value against the input class type.
-                  ;; If something goes wrong, issue a smart warning
-                  ;; about how a :type is needed for this to work.
-                  (unless (and
-                           ;; Do we have a type?
-                           (consp classtype) (class-p (car classtype)))
-                    (error "In save file, list of object constructors found, but no :type specified for slot %S of type %S"
-                           slot classtype))
-
-                  ;; We have a predicate, but it doesn't satisfy the predicate?
-                  (dolist (PV (cdr proposed-value))
-                    (unless (child-of-class-p (car PV) (car classtype))
-                      (error "Invalid object: slot member %s does not match class %s"
-                             (car PV) (car classtype))))
-
-                  ;; We have a list of objects here.  Lets load them
-                  ;; in.
-                  (let ((objlist nil))
-                    (dolist (subobj (cdr proposed-value))
-                      (push (eieio-persistent-convert-list-to-object subobj)
-                            objlist))
-                    ;; return the list of objects ... reversed.
-                    (nreverse objlist)))
-                 ;; We have a slot with a single object that can be
-                 ;; saved here.  Recurse and evaluate that
-                 ;; sub-object.
-                 ((and classtype
-                       (seq-some
-                        (lambda (elt)
-                          (child-of-class-p (car proposed-value) elt))
-                        (if (listp classtype) classtype (list classtype))))
-                  (eieio-persistent-convert-list-to-object
-                   proposed-value))
-                 (t
-                  proposed-value))))
+         (cond ((eq (car proposed-value) 'quote)
+                (while (eq (car-safe proposed-value) 'quote)
+                  (setq proposed-value (car (cdr proposed-value))))
+                proposed-value)
+
+               ;; An empty list sometimes shows up as (list), which is dumb, but
+               ;; we need to support it for backward compar.
+               ((and (eq (car proposed-value) 'list)
+                     (= (length proposed-value) 1))
+                nil)
+
+               ;; List of object constructors.
+               ((and (eq (car proposed-value) 'list)
+                     ;; 2nd item is a list.
+                     (consp (car (cdr proposed-value)))
+                     ;; 1st elt of 2nd item is a class name.
+                     (class-p (car (car (cdr proposed-value)))))
+
+                ;; We have a list of objects here.  Lets load them
+                ;; in.
+                (let ((objlist nil))
+                  (dolist (subobj (cdr proposed-value))
+                    (push (eieio-persistent-convert-list-to-object subobj)
+                          objlist))
+                  ;; return the list of objects ... reversed.
+                  (nreverse objlist)))
+               ;; We have a slot with a single object that can be
+               ;; saved here.  Recurse and evaluate that
+               ;; sub-object.
+               ((class-p (car proposed-value))
+                (eieio-persistent-convert-list-to-object
+                 proposed-value))
+               (t
+                proposed-value)))
         ;; For hash-tables and vectors, the top-level `read' will not
         ;; "look inside" member values, so we need to do that
         ;; explicitly.  Because `eieio-override-prin1' is recursive in
@@ -377,8 +347,7 @@ Second, any text properties will be stripped from strings."
                   (if (class-p (car-safe value))
                       (eieio-persistent-convert-list-to-object
                        value)
-                    (eieio-persistent-validate/fix-slot-value
-                     class slot value))))
+                    (eieio-persistent-fix-value value))))
           proposed-value)
          proposed-value)
 
@@ -389,70 +358,16 @@ Second, any text properties will be stripped from strings."
                    (if (class-p (car-safe val))
                        (eieio-persistent-convert-list-to-object
                         val)
-                     (eieio-persistent-validate/fix-slot-value
-                      class slot val)))))
+                     (eieio-persistent-fix-value val)))))
          proposed-value)
 
-         ((stringp proposed-value)
-          ;; Else, check for strings, remove properties.
-          (substring-no-properties proposed-value))
-
-         (t
-          ;; Else, just return whatever the constant was.
-          proposed-value))
-  )
-
-(defun eieio-persistent-slot-type-is-class-p (type)
-  "Return the class referred to in TYPE.
-If no class is referenced there, then return nil."
-  (cond ((class-p type)
-         ;; If the type is a class, then return it.
-         type)
-        ((and (eq 'list-of (car-safe type)) (class-p (cadr type)))
-         ;; If it is the type of a list of a class, then return that class and
-         ;; the type.
-         (cons (cadr type) type))
-
-        ((and (symbolp type) (get type 'cl-deftype-handler))
-         ;; Macro-expand the type according to cl-deftype definitions.
-         (eieio-persistent-slot-type-is-class-p
-          (funcall (get type 'cl-deftype-handler))))
-
-        ;; FIXME: foo-child should not be a valid type!
-        ((and (symbolp type) (string-match "-child\\'" (symbol-name type))
-              (class-p (intern-soft (substring (symbol-name type) 0
-                                               (match-beginning 0)))))
-         (unless eieio-backward-compatibility
-           (error "Use of bogus %S type instead of %S"
-                  type (intern-soft (substring (symbol-name type) 0
-                                               (match-beginning 0)))))
-         ;; If it is the predicate ending with -child, then return
-         ;; that class.  Unfortunately, in EIEIO, typep of just the
-         ;; class is the same as if we used -child, so no further work needed.
-         (intern-soft (substring (symbol-name type) 0
-                                 (match-beginning 0))))
-        ;; FIXME: foo-list should not be a valid type!
-        ((and (symbolp type) (string-match "-list\\'" (symbol-name type))
-              (class-p (intern-soft (substring (symbol-name type) 0
-                                               (match-beginning 0)))))
-         (unless eieio-backward-compatibility
-           (error "Use of bogus %S type instead of (list-of %S)"
-                  type (intern-soft (substring (symbol-name type) 0
-                                               (match-beginning 0)))))
-         ;; If it is the predicate ending with -list, then return
-         ;; that class and the predicate to use.
-         (cons (intern-soft (substring (symbol-name type) 0
-                                       (match-beginning 0)))
-               type))
-
-        ((eq (car-safe type) 'or)
-         ;; If type is a list, and is an `or', return all valid class
-         ;; types within the `or' statement.
-         (seq-filter #'eieio-persistent-slot-type-is-class-p (cdr type)))
+        ((stringp proposed-value)
+         ;; Else, check for strings, remove properties.
+         (substring-no-properties proposed-value))
 
         (t
-         ;; No match, not a class.
-         nil)))
+         ;; Else, just return whatever the constant was.
+         proposed-value)))
 
 (cl-defmethod object-write ((this eieio-persistent) &optional comment)
   "Write persistent object THIS out to the current stream.