diff options
Diffstat (limited to 'lisp/emacs-lisp/eieio.el')
| -rw-r--r-- | lisp/emacs-lisp/eieio.el | 149 |
1 files changed, 78 insertions, 71 deletions
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 131997a7ef0..c16d8e110ec 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 @@ -131,6 +132,7 @@ and reference them using the function `class-option'." (let ((testsym1 (intern (concat (symbol-name name) "-p"))) (testsym2 (intern (format "%s--eieio-childp" name))) + (warnings '()) (accessors ())) ;; Collect the accessors we need to define. @@ -145,6 +147,8 @@ and reference them using the function `class-option'." ;; Update eieio--known-slot-names already in case we compile code which ;; uses this before the class is loaded. (cl-pushnew sname eieio--known-slot-names) + (when (eq alloc :class) + (cl-pushnew sname eieio--known-class-slot-names)) (if eieio-error-unsupported-class-tags (let ((tmp soptions)) @@ -176,8 +180,22 @@ and reference them using the function `class-option'." (signal 'invalid-slot-type (list :label label))) ;; Is there an initarg, but allocation of class? - (if (and initarg (eq alloc :class)) - (message "Class allocated slots do not need :initarg")) + (when (and initarg (eq alloc :class)) + (push (format "Meaningless :initarg for class allocated slot '%S'" + sname) + warnings)) + + (let ((init (plist-get soptions :initform))) + (unless (or (macroexp-const-p init) + (eieio--eval-default-p init)) + ;; FIXME: Historically, EIEIO used a heuristic to try and guess + ;; whether the initform is a form to be evaluated or just + ;; a constant. We use `eieio--eval-default-p' to see what the + ;; heuristic says and if it disagrees with normal evaluation + ;; then tweak the initform to make it fit and emit + ;; a warning accordingly. + (push (format "Ambiguous initform needs quoting: %S" init) + warnings))) ;; Anyone can have an accessor function. This creates a function ;; of the specified name, and also performs a `defsetf' if applicable @@ -223,6 +241,9 @@ This method is obsolete." )) `(progn + ,@(mapcar (lambda (w) + (macroexp-warn-and-return w `(progn ',w) nil 'compile-only)) + warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only ;; pointers to itself. @@ -233,7 +254,7 @@ This method is obsolete." ,@(when eieio-backward-compatibility (let ((f (intern (format "%s-child-p" name)))) - `((defalias ',f ',testsym2) + `((defalias ',f #',testsym2) (make-obsolete ',f ,(format "use (cl-typep ... \\='%s) instead" name) "25.1")))) @@ -269,7 +290,7 @@ This method is obsolete." (lambda (whole) (if (not (stringp (car slots))) whole - (macroexp--warn-and-return + (macroexp-warn-and-return (format "Obsolete name arg %S to constructor %S" (car slots) (car whole)) ;; Keep the name arg, for backward compatibility, @@ -282,23 +303,19 @@ This method is obsolete." ;;; Get/Set slots in an object. ;; (defmacro oref (obj slot) - "Retrieve the value stored in OBJ in the slot named by SLOT. -Slot is the name of the slot when created by `defclass' or the label -created by the :initarg tag." + "Retrieve the value stored in OBJ in the slot named by SLOT." (declare (debug (form symbolp))) `(eieio-oref ,obj (quote ,slot))) -(defalias 'slot-value 'eieio-oref) -(defalias 'set-slot-value 'eieio-oset) +(defalias 'slot-value #'eieio-oref) +(defalias 'set-slot-value #'eieio-oset) (make-obsolete 'set-slot-value "use (setf (slot-value ..) ..) instead" "25.1") -(defmacro oref-default (obj slot) - "Get the default value of OBJ (maybe a class) for SLOT. -The default value is the value installed in a class with the :initform -tag. SLOT can be the slot name, or the tag specified by the :initarg -tag in the `defclass' call." +(defmacro oref-default (class slot) + "Get the value of class allocated slot SLOT. +CLASS can also be an object, in which case we use the object's class." (declare (debug (form symbolp))) - `(eieio-oref-default ,obj (quote ,slot))) + `(eieio-oref-default ,class (quote ,slot))) ;;; Handy CLOS macros ;; @@ -351,24 +368,20 @@ Elements of FIELDS can be of the form (NAME PAT) in which case the contents of field NAME is matched against PAT, or they can be of the form NAME which is a shorthand for (NAME NAME)." (declare (debug (&rest [&or (sexp pcase-PAT) sexp]))) - (let ((is (make-symbol "table"))) - ;; FIXME: This generates a horrendous mess of redundant let bindings. - ;; `pcase' needs to be improved somehow to introduce let-bindings more - ;; sparingly, or the byte-compiler needs to be taught to optimize - ;; them away. - ;; FIXME: `pcase' does not do a good job here of sharing tests&code among - ;; various branches. - `(and (pred eieio-object-p) - (app eieio-pcase-slot-index-table ,is) - ,@(mapcar (lambda (field) - (let* ((name (if (consp field) (car field) field)) - (pat (if (consp field) (cadr field) field)) - (i (make-symbol "index"))) - `(and (let (and ,i (pred natnump)) - (eieio-pcase-slot-index-from-index-table - ,is ',name)) - (app (pcase--flip aref ,i) ,pat)))) - fields)))) + ;; FIXME: This generates a horrendous mess of redundant let bindings. + ;; `pcase' needs to be improved somehow to introduce let-bindings more + ;; sparingly, or the byte-compiler needs to be taught to optimize + ;; them away. + ;; FIXME: `pcase' does not do a good job here of sharing tests&code among + ;; various branches. + `(and (pred eieio-object-p) + ,@(mapcar (lambda (field) + (pcase-exhaustive field + (`(,name ,pat) + `(app (pcase--flip eieio-oref ',name) ,pat)) + ((pred symbolp) + `(app (pcase--flip eieio-oref ',field) ,field)))) + fields))) ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. @@ -422,7 +435,7 @@ If EXTRA, include that in the string returned to represent the symbol." (cl-check-type obj eieio-object) (eieio-class-name (eieio--object-class obj))) (define-obsolete-function-alias - 'object-class-name 'eieio-object-class-name "24.4") + 'object-class-name #'eieio-object-class-name "24.4") (defun eieio-class-parents (class) ;; FIXME: What does "(overload of variable)" mean here? @@ -450,7 +463,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (defmacro eieio-class-parent (class) "Return first parent class to CLASS. (overload of variable)." `(car (eieio-class-parents ,class))) -(define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4") +(define-obsolete-function-alias 'class-parent #'eieio-class-parent "24.4") (defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." @@ -465,7 +478,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function." ;; class will be checked one layer down (child-of-class-p (eieio--object-class obj) class)) ;; Backwards compatibility -(defalias 'obj-of-class-p 'object-of-class-p) +(defalias 'obj-of-class-p #'object-of-class-p) (defun child-of-class-p (child class) "Return non-nil if CHILD class is a subclass of CLASS." @@ -542,11 +555,11 @@ OBJECT can be an instance or a class." ((eieio-object-p object) (eieio-oref object slot)) ((symbolp object) (eieio-oref-default object slot)) (t (signal 'wrong-type-argument (list 'eieio-object-p object)))) - eieio-unbound)))) + eieio--unbound)))) (defun slot-makeunbound (object slot) "In OBJECT, make SLOT unbound." - (eieio-oset object slot eieio-unbound)) + (eieio-oset object slot eieio--unbound)) (defun slot-exists-p (object-or-class slot) "Return non-nil if OBJECT-OR-CLASS has SLOT." @@ -649,14 +662,6 @@ If SLOT is unbound, do nothing." nil (eieio-oset object slot (delete item (eieio-oref object slot))))) -;;; Here are some CLOS items that need the CL package -;; - -;; FIXME: Shouldn't this be a more complex gv-expander which extracts the -;; common code between oref and oset, so as to reduce the redundant work done -;; in (push foo (oref bar baz)), like we do for the `nth' expander? -(gv-define-simple-setter eieio-oref eieio-oset) - ;;; ;; We want all objects created by EIEIO to have some default set of @@ -677,7 +682,7 @@ This class is not stored in the `parent' slot of a class vector." (setq eieio-default-superclass (cl--find-class 'eieio-default-superclass)) (define-obsolete-function-alias 'standard-class - 'eieio-default-superclass "26.1") + #'eieio-default-superclass "26.1") (cl-defgeneric make-instance (class &rest initargs) "Make a new instance of CLASS based on INITARGS. @@ -737,35 +742,37 @@ Called from the constructor routine." "Construct the new object THIS based on SLOTS.") (cl-defmethod initialize-instance ((this eieio-default-superclass) - &optional slots) - "Construct the new object THIS based on SLOTS. -SLOTS is a tagged list where odd numbered elements are tags, and + &optional args) + "Construct the new object THIS based on ARGS. +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. - ;; - ;; Paul Landes said in an email: - ;; > CL evaluates it if it can, and otherwise, leaves it as - ;; > the quoted thing as you already have. This is by the - ;; > Sonya E. Keene book and other things I've look at on the - ;; > web. + ;; For each slot, see if we need to evaluate its initform. (let* ((slot (aref slots i)) - (initform (cl--slot-descriptor-initform slot)) - (dflt (eieio-default-eval-maybe initform))) - (when (not (eq dflt initform)) - ;; FIXME: We should be able to just do (aset this (+ i <cst>) dflt)! - (eieio-oset this (cl--slot-descriptor-name slot) dflt))))) - ;; Shared initialize will parse our slots for us. - (shared-initialize this slots)) + (slot-name (eieio-slot-descriptor-name slot)) + (initform (cl--slot-descriptor-initform slot))) + (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. @@ -887,7 +894,7 @@ this object." ;; Now output readable lisp to recreate this object ;; It should look like this: ;; (<constructor> <name> <slot> <slot> ... ) - ;; Each slot's slot is writen using its :writer. + ;; Each slot's slot is written using its :writer. (when eieio-print-indentation (princ (make-string (* eieio-print-depth 2) ? ))) (princ "(") @@ -984,13 +991,13 @@ this object." This may create or delete slots, but does not affect the return value of `eq'." (error "EIEIO: `change-class' is unimplemented")) -(define-obsolete-function-alias 'change-class 'eieio-change-class "26.1") +(define-obsolete-function-alias 'change-class #'eieio-change-class "26.1") ;; Hook ourselves into help system for describing classes and methods. ;; FIXME: This is not actually needed any more since we can click on the ;; hyperlink from the constructor's docstring to see the type definition. -(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) +(add-hook 'help-fns-describe-function-functions #'eieio-help-constructor) (provide 'eieio) -;;; eieio ends here +;;; eieio.el ends here |