master 109c273: EIEIO: Prevent excessive evaluation of :initform

[Stefan Monnier]

branch: master
commit 109c27341e35fae778b95e0eb5d4d72927bf4ea8
Author: akater <nuclearspace@gmail.com>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    EIEIO: Prevent excessive evaluation of :initform
    
    * lisp/emacs-lisp/eieio.el (initialize-instance):
    Do not evaluate initform of a slot when initarg for the slot is provided,
    according to the following secitons of CLHS:
    - Object Creation and Initialization
    - Initialization Arguments
    - Defaulting of Initialization Arguments
    - Rules for Initialization Arguments
    
    * test/lisp/emacs-lisp/eieio-etests/eieio-tests.el:
    Add corresponding tests
    Fix a typo
---
 lisp/emacs-lisp/eieio.el                        | 35 +++++++++++++++----------
 test/lisp/emacs-lisp/eieio-tests/eieio-tests.el | 16 ++++++++++-
 2 files changed, 36 insertions(+), 15 deletions(-)

diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 1c8c372..b31ea42a 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -53,6 +53,7 @@
   (message eieio-version))
 
 (require 'eieio-core)
+(eval-when-compile (require 'subr-x))
 
 
 ;;; Defining a new class
@@ -740,31 +741,37 @@ Called from the constructor routine."
   "Construct the new object THIS based on SLOTS.")
 
 (cl-defmethod initialize-instance ((this eieio-default-superclass)
-                               &optional slots)
+                                  &optional args)
   "Construct the new object THIS based on SLOTS.
-SLOTS is a tagged list where odd numbered elements are tags, and
+ARGS is a property list where odd numbered elements are tags, and
 even numbered elements are the values to store in the tagged slot.
 If you overload the `initialize-instance', there you will need to
 call `shared-initialize' yourself, or you can call `call-next-method'
 to have this constructor called automatically.  If these steps are
 not taken, then new objects of your class will not have their values
-dynamically set from SLOTS."
-  ;; First, see if any of our defaults are `lambda', and
-  ;; re-evaluate them and apply the value to our slots.
+dynamically set from ARGS."
   (let* ((this-class (eieio--object-class this))
+         (initargs args)
          (slots (eieio--class-slots this-class)))
     (dotimes (i (length slots))
-      ;; For each slot, see if we need to evaluate it.
+      ;; For each slot, see if we need to evaluate its initform.
       (let* ((slot (aref slots i))
+             (slot-name (eieio-slot-descriptor-name slot))
              (initform (cl--slot-descriptor-initform slot)))
-        ;; Those slots whose initform is constant already have the right
-        ;; value set in the default-object.
-        (unless (macroexp-const-p initform)
-          ;; FIXME: We should be able to just do (aset this (+ i <cst>) dflt)!
-          (eieio-oset this (cl--slot-descriptor-name slot)
-                      (eval initform t))))))
-  ;; Shared initialize will parse our slots for us.
-  (shared-initialize this slots))
+        (unless (or (when-let ((initarg
+                                (car (rassq slot-name
+                                            (eieio--class-initarg-tuples
+                                             this-class)))))
+                      (plist-get initargs initarg))
+                    ;; Those slots whose initform is constant already have
+                    ;; the right value set in the default-object.
+                    (macroexp-const-p initform))
+          ;; FIXME: Use `aset' instead of `eieio-oset', relying on that
+          ;; vector returned by `eieio--class-slots'
+          ;; should be congruent with the object itself.
+          (eieio-oset this slot-name (eval initform t))))))
+  ;; Shared initialize will parse our args for us.
+  (shared-initialize this args))
 
 (cl-defgeneric slot-missing (object slot-name _operation &optional _new-value)
   "Method invoked when an attempt to access a slot in OBJECT fails.
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el 
b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
index 11ffc11..3ec4234 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
@@ -574,7 +574,21 @@ METHOD is the method that was attempting to be called."
   (setf (get-slot-3 eitest-t1) 'setf-emu)
   (should (eq (get-slot-3 eitest-t1) 'setf-emu))
   ;; Roll back
-  (setf (get-slot-3 eitest-t1) 'emu))
+  (setf (get-slot-3 eitest-t1) 'emu)
+  (defvar eieio-tests-initform-was-evaluated)
+  (defclass eieio-tests-initform-not-evaluated-when-initarg-is-present ()
+    ((slot-with-initarg-and-initform
+      :initarg :slot-with-initarg-and-initform
+      :initform (setf eieio-tests-initform-was-evaluated t))))
+  (setq eieio-tests-initform-was-evaluated nil)
+  (make-instance
+   'eieio-tests-initform-not-evaluated-when-initarg-is-present)
+  (should eieio-tests-initform-was-evaluated)
+  (setq eieio-tests-initform-was-evaluated nil)
+  (make-instance
+   'eieio-tests-initform-not-evaluated-when-initarg-is-present
+   :slot-with-initarg-and-initform t)
+  (should-not eieio-tests-initform-was-evaluated))
 
 (defvar eitest-t2 nil)
 (ert-deftest eieio-test-26-default-inheritance ()