master 4d741e5 1/2: Remove redundant slot validation in eieio-persistent-read

[Eric Abrahamsen]

branch: master
commit 4d741e577fbab8adf444c6c1930525bb7e8fc08d
Author: Eric Abrahamsen <eric@ericabrahamsen.net>
Commit: Eric Abrahamsen <eric@ericabrahamsen.net>

    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.
---
 lisp/emacs-lisp/eieio-base.el | 211 +++++++++++++-----------------------------
 1 file changed, 63 insertions(+), 148 deletions(-)

diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 2cb1f61..f09d199 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.