>From 43288c414f00018b9f79c43e9e1232af41d4e1f5 Mon Sep 17 00:00:00 2001 From: akater 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)) ;;; 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 ) 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