bug#49291: [akater] [PATCH] lisp/emacs-lisp/eieio.el (initialize-instance): Fix initform

[akater <nuclearspace@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 287 bytes --]


A version with correct code generation.  Tests pass on 27.

“when-initargs” is not a perfect name but it's not a global macro, and
the name is short enough to allow two descriptive initargs to fit into
80 chars width so I decided not to spend time seeking for alternatives.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Fix eval initform --]
[-- Type: text/x-diff, Size: 16407 bytes --]

From 43288c414f00018b9f79c43e9e1232af41d4e1f5 Mon Sep 17 00:00:00 2001
From: akater <nuclearspace@gmail.com>
Date: Wed, 30 Jun 2021 11:43:23 +0000
Subject: [PATCH] lisp/emacs-lisp/eieio.el (initialize-instance): Fix eval
 initform:

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

Add corresponding tests.

Replace :initform (symbol-value 'x) to :initform x everywhere.

Quote all initforms explicitly where necessary.
---
 lisp/emacs-lisp/eieio.el                      |  28 +++--
 lisp/gnus/gnus-search.el                      |  52 ++++-----
 lisp/registry.el                              |   2 +-
 .../emacs-lisp/eieio-tests/eieio-tests.el     | 101 +++++++++++++++---
 4 files changed, 132 insertions(+), 51 deletions(-)

diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 1c8c372aae..76b2eab494 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -53,6 +53,7 @@ defun eieio-version ()
   (message eieio-version))
 
 (require 'eieio-core)
+(eval-when-compile (require 'subr-x))
 
 \f
 ;;; Defining a new class
@@ -740,7 +741,7 @@ defclass eieio-default-superclass nil
   "Construct the new object THIS based on SLOTS.")
 
 (cl-defmethod initialize-instance ((this eieio-default-superclass)
-				&optional slots)
+				   &optional slots)
   "Construct the new object THIS based on SLOTS.
 SLOTS is a tagged list where odd numbered elements are tags, and
 even numbered elements are the values to store in the tagged slot.
@@ -749,20 +750,27 @@ defclass eieio-default-superclass nil
 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.
   (let* ((this-class (eieio--object-class this))
+         (initargs slots)
          (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))))))
+        (unless (or (eq eieio--unbound initform)
+                    (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 slots for us.
   (shared-initialize this slots))
 
diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el
index 70bde264c1..202d93e053 100644
--- a/lisp/gnus/gnus-search.el
+++ b/lisp/gnus/gnus-search.el
@@ -787,7 +787,7 @@ defclass gnus-search-imap (gnus-search-engine)
     This slot is set automatically by the imap server, and cannot
     be set manually.  Currently only partially implemented.")
    (raw-queries-p
-    :initform (symbol-value 'gnus-search-imap-raw-queries-p)))
+    :initform gnus-search-imap-raw-queries-p))
     :documentation
   "The base IMAP search engine, using an IMAP server's search capabilities.
 This backend may be subclassed to handle particular IMAP servers'
@@ -841,67 +841,67 @@ defclass gnus-search-indexed (gnus-search-engine
 (defclass gnus-search-swish-e (gnus-search-indexed)
   ((index-files
     :init-arg :index-files
-    :initform (symbol-value 'gnus-search-swish-e-index-files)
+    :initform gnus-search-swish-e-index-files
     :type list)
    (program
-    :initform (symbol-value 'gnus-search-swish-e-program))
+    :initform gnus-search-swish-e-program)
    (remove-prefix
-    :initform (symbol-value 'gnus-search-swish-e-remove-prefix))
+    :initform gnus-search-swish-e-remove-prefix)
    (switches
-    :initform (symbol-value 'gnus-search-swish-e-switches))
+    :initform gnus-search-swish-e-switches)
    (raw-queries-p
-    :initform (symbol-value 'gnus-search-swish-e-raw-queries-p))))
+    :initform gnus-search-swish-e-raw-queries-p)))
 
 (defclass gnus-search-swish++ (gnus-search-indexed)
   ((program
-    :initform (symbol-value 'gnus-search-swish++-program))
+    :initform gnus-search-swish++-program)
    (remove-prefix
-    :initform (symbol-value 'gnus-search-swish++-remove-prefix))
+    :initform gnus-search-swish++-remove-prefix)
    (switches
-    :initform (symbol-value 'gnus-search-swish++-switches))
+    :initform gnus-search-swish++-switches)
    (config-file
-    :initform (symbol-value 'gnus-search-swish++-config-file))
+    :initform gnus-search-swish++-config-file)
    (raw-queries-p
-    :initform (symbol-value 'gnus-search-swish++-raw-queries-p))))
+    :initform gnus-search-swish++-raw-queries-p)))
 
 (defclass gnus-search-mairix (gnus-search-indexed)
   ((program
-    :initform (symbol-value 'gnus-search-mairix-program))
+    :initform gnus-search-mairix-program)
    (remove-prefix
-    :initform (symbol-value 'gnus-search-mairix-remove-prefix))
+    :initform gnus-search-mairix-remove-prefix)
    (switches
-    :initform (symbol-value 'gnus-search-mairix-switches))
+    :initform gnus-search-mairix-switches)
    (config-file
-    :initform (symbol-value 'gnus-search-mairix-config-file))
+    :initform gnus-search-mairix-config-file)
    (raw-queries-p
-    :initform (symbol-value 'gnus-search-mairix-raw-queries-p))))
+    :initform gnus-search-mairix-raw-queries-p)))
 
 (defclass gnus-search-namazu (gnus-search-indexed)
   ((index-directory
     :initarg :index-directory
-    :initform (symbol-value 'gnus-search-namazu-index-directory)
+    :initform gnus-search-namazu-index-directory
     :type string
     :custom directory)
    (program
-    :initform (symbol-value 'gnus-search-namazu-program))
+    :initform gnus-search-namazu-program)
    (remove-prefix
-    :initform (symbol-value 'gnus-search-namazu-remove-prefix))
+    :initform gnus-search-namazu-remove-prefix)
    (switches
-    :initform (symbol-value 'gnus-search-namazu-switches))
+    :initform gnus-search-namazu-switches)
    (raw-queries-p
-    :initform (symbol-value 'gnus-search-namazu-raw-queries-p))))
+    :initform gnus-search-namazu-raw-queries-p)))
 
 (defclass gnus-search-notmuch (gnus-search-indexed)
   ((program
-    :initform (symbol-value 'gnus-search-notmuch-program))
+    :initform gnus-search-notmuch-program)
    (remove-prefix
-    :initform (symbol-value 'gnus-search-notmuch-remove-prefix))
+    :initform gnus-search-notmuch-remove-prefix)
    (switches
-    :initform (symbol-value 'gnus-search-notmuch-switches))
+    :initform gnus-search-notmuch-switches)
    (config-file
-    :initform (symbol-value 'gnus-search-notmuch-config-file))
+    :initform gnus-search-notmuch-config-file)
    (raw-queries-p
-    :initform (symbol-value 'gnus-search-notmuch-raw-queries-p))))
+    :initform gnus-search-notmuch-raw-queries-p)))
 
 (define-obsolete-variable-alias 'nnir-method-default-engines
   'gnus-search-default-engines "28.1")
diff --git a/lisp/registry.el b/lisp/registry.el
index 258f7fc904..e0aa9d1728 100644
--- a/lisp/registry.el
+++ b/lisp/registry.el
@@ -102,7 +102,7 @@ defclass registry-db (eieio-persistent)
 	     ;; value rather than an expression, so in order to get the value
 	     ;; of `most-positive-fixnum', we need to use an
 	     ;; expression that's not just a symbol.
-             :initform (symbol-value 'most-positive-fixnum)
+             :initform most-positive-fixnum
              :type integer
              :custom integer
              :documentation "The maximum number of registry entries.")
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
index 11ffc115f7..723d67ab5f 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
@@ -30,15 +30,16 @@
 (require 'eieio-opt)
 
 (eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'cl-macs))
 
 ;;; Code:
 ;; Set up some test classes
 (defclass class-a ()
   ((water :initarg :water
-	  :initform h20
+	  :initform 'h20
 	  :type symbol
 	  :documentation "Detail about water.")
-   (classslot :initform penguin
+   (classslot :initform 'penguin
 	      :type symbol
 	      :documentation "A class allocated slot."
 	      :allocation :class)
@@ -63,7 +64,7 @@ defclass class-ab (class-a class-b)
 
 (defclass class-c ()
   ((slot-1 :initarg :moose
-	   :initform moose
+	   :initform 'moose
 	   :type symbol
 	   :allocation :instance
 	   :documentation "First slot testing slot arguments."
@@ -82,7 +83,7 @@ defclass class-c ()
 	   :accessor get-slot-2
 	   :protection :private)
    (slot-3 :initarg :emu
-	   :initform emu
+	   :initform 'emu
 	   :type symbol
 	   :allocation :class
 	   :documentation "Third slot test class allocated accessor"
@@ -489,9 +490,9 @@ defvar eitest-pvinit nil)
 
 (defclass inittest nil
   ((staticval :initform 1)
-   (symval :initform eieio-test-permuting-value)
-   (evalval :initform (symbol-value 'eieio-test-permuting-value))
-   (evalnow :initform (symbol-value 'eieio-test-permuting-value)
+   (symval :initform 'eieio-test-permuting-value)
+   (evalval :initform eieio-test-permuting-value)
+   (evalnow :initform eieio-test-permuting-value
 	    :allocation :class)
    )
   "Test initforms that eval.")
@@ -555,6 +556,15 @@ defclass eitest-superior nil
     (should-not (cl-typep listooa '(list-of class-b)))
     (should-not (cl-typep listoob '(list-of class-a)))))
 
+(defclass eieio-tests-initargs-initform-interplay ()
+  ((slot-with-initarg-and-initform
+    :initarg :slot-with-initarg-and-initform
+    :initform 'value-specified-in-defclass-form)
+   (slot-with-initarg-only
+    :initarg :slot-with-initarg-only)
+   (slot-with-initform-only
+    :initform 'value-specified-in-defclass-form)))
+
 (defvar eitest-t1 nil)
 (ert-deftest eieio-test-25-slot-tests ()
   (setq eitest-t1 (class-c))
@@ -574,7 +584,70 @@ defvar eitest-t1 nil)
   (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)
+  ;; Slot initialization according to initargs and initforms
+  (cl-macrolet
+      ((when-initargs (slots &rest noerrorp
+                             &key
+                             slot-with-initarg-and-initform
+                             slot-with-initarg-only
+                             slot-with-initform-only)
+         (cl-macrolet ((code-for
+                        (arg)
+                        `(let ((slot ,arg))
+                           (cl-case slot
+                             (unbound `(not (slot-boundp eitest-t1 ',',arg)))
+                             ((nil)
+                              ;; it would be cleaner
+                              ;; to introduce and check supplied-p arguments
+                              ;; but it's not worth the added complexity
+                              t)
+                             (t `(eq ,slot (oref eitest-t1 ,',arg)))))))
+           (let ((make-instance
+                  `(setq eitest-t1
+                         (make-instance
+                          'eieio-tests-initargs-initform-interplay
+                          ,@(cl-loop
+                             for initarg in slots
+                             collect initarg
+                             collect
+                             ''value-specified-in-make-instance-form)))))
+             (if noerrorp
+                 `(progn
+                    ,make-instance
+                    (should (and ,(code-for slot-with-initarg-and-initform)
+                                 ,(code-for slot-with-initarg-only)
+                                 ,(code-for slot-with-initform-only))))
+               `(should-error ,make-instance))))))
+    ;; Whenever slot without initarg is initialized by initarg, it's an error;
+    ;; see CLHS, 7.1.2 Declaring the Validity of Initialization Arguments.
+    ;; So, the following four should just error:
+    (when-initargs (:slot-with-initform-only))
+    (when-initargs (:slot-with-initform-only :slot-with-initarg-and-initform))
+    (when-initargs (:slot-with-initform-only :slot-with-initarg-only))
+    (when-initargs (:slot-with-initform-only :slot-with-initarg-and-initform
+                                             :slot-with-initarg-only))
+    ;; The rest should not.
+
+    (when-initargs (:slot-with-initarg-and-initform :slot-with-initarg-only)
+      :slot-with-initarg-and-initform 'value-specified-in-make-instance-form
+      :slot-with-initarg-only 'value-specified-in-make-instance-form
+      :slot-with-initform-only 'value-specified-in-defclass-form)
+
+    (when-initargs (:slot-with-initarg-and-initform)
+      :slot-with-initarg-and-initform 'value-specified-in-make-instance-form
+      :slot-with-initarg-only unbound
+      :slot-with-initform-only 'value-specified-in-defclass-form)
+
+    (when-initargs (:slot-with-initarg-only)
+      :slot-with-initarg-and-initform 'value-specified-in-defclass-form
+      :slot-with-initarg-only 'value-specified-in-make-instance-form
+      :slot-with-initform-only 'value-specified-in-defclass-form)
+
+    (when-initargs ()
+      :slot-with-initarg-and-initform 'value-specified-in-defclass-form
+      :slot-with-initarg-only unbound
+      :slot-with-initform-only 'value-specified-in-defclass-form)))
 
 (defvar eitest-t2 nil)
 (ert-deftest eieio-test-26-default-inheritance ()
@@ -696,7 +769,7 @@ defvar eitest-II3 nil)
   (setq eitest-II3 (clone eitest-II2 "eitest-II3 Test."))
   (oset eitest-II3 slot3 'penguin)
 
-  ;; Test that slots are non-initialized slots are unbounded
+  ;; Test that non-initialized slots are unbounded
   (oref eitest-II2 slot1)
   (should (slot-boundp eitest-II2 'slot1))
   (should-not (slot-boundp eitest-II2 'slot2))
@@ -715,7 +788,7 @@ defvar eitest-II3 nil)
   (should (eq (oref eitest-II3 slot3) 'penguin)))
 
 (defclass slotattr-base ()
-  ((initform :initform init)
+  ((initform :initform 'init)
    (type :type list)
    (initarg :initarg :initarg)
    (protection :protection :private)
@@ -730,7 +803,7 @@ defclass slotattr-base ()
 Subclasses to override slot attributes.")
 
 (defclass slotattr-ok (slotattr-base)
-  ((initform :initform no-init)
+  ((initform :initform 'no-init)
    (initarg :initarg :initblarg)
    (custom :custom string
 	   :label "One String"
@@ -766,7 +839,7 @@ defclass slotattr-ok (slotattr-base)
 
 (defclass slotattr-class-base ()
   ((initform :allocation :class
-	     :initform init)
+	     :initform 'init)
    (type :allocation :class
 	 :type list)
    (initarg :allocation :class
@@ -785,7 +858,7 @@ defclass slotattr-class-base ()
 Subclasses to override slot attributes.")
 
 (defclass slotattr-class-ok (slotattr-class-base)
-  ((initform :initform no-init)
+  ((initform :initform 'no-init)
    (initarg :initarg :initblarg)
    (custom :custom string
 	   :label "One String"
@@ -847,7 +920,7 @@ defvar eitest-CLONETEST2 nil)
   (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))))
 
 (defclass IT (eieio-instance-tracker)
-  ((tracking-symbol :initform IT-list)
+  ((tracking-symbol :initform 'IT-list)
    (slot1 :initform 'die))
   "Instance Tracker test object.")
 
-- 
2.31.1