Due to the way class options are set up, you can add any tags you wish,
and reference them using the function `class-option'."
(declare (doc-string 4))
- (eieio--check-type listp superclasses)
+ (cl-check-type superclasses list)
(cond ((and (stringp (car options-and-doc))
(/= 1 (% (length options-and-doc) 2)))
(error "Method invocation order %s is not allowed" io)))
(let ((testsym1 (intern (concat (symbol-name name) "-p")))
- (testsym2 (intern (format "eieio--childp--%s" name)))
+ (testsym2 (intern (format "%s--eieio-childp" name)))
(accessors ()))
;; Collect the accessors we need to define.
(alloc (plist-get soptions :allocation))
(label (plist-get soptions :label)))
+ ;; 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)
+
(if eieio-error-unsupported-class-tags
(let ((tmp soptions))
(while tmp
;; referencing classes. ei, a class whose slot can contain only
;; pointers to itself.
- ;; Create the test function.
- (defun ,testsym1 (obj)
- ,(format "Test OBJ to see if it an object of type %S." name)
- (and (eieio-object-p obj)
- (same-class-p obj ',name)))
-
- (defun ,testsym2 (obj)
- ,(format
- "Test OBJ to see if it an object is a child of type %S."
- name)
- (and (eieio-object-p obj)
- (object-of-class-p obj ',name)))
+ ;; Create the test functions.
+ (defalias ',testsym1 (eieio-make-class-predicate ',name))
+ (defalias ',testsym2 (eieio-make-child-predicate ',name))
,@(when eieio-backward-compatibility
(let ((f (intern (format "%s-child-p" name))))
(if (not (stringp abs))
(setq abs (format "Class %s is abstract" name)))
`(defun ,name (&rest _)
- ,(format "You cannot create a new object of type %S." name)
+ ,(format "You cannot create a new object of type `%S'." name)
(error ,abs)))
;; Non-abstract classes need a constructor.
`(defun ,name (&rest slots)
- ,(format "Create a new object with name NAME of class type %S."
- name)
+ ,(format "Create a new object of class type `%S'." name)
(declare (compiler-macro
(lambda (whole)
(if (not (stringp (car slots)))
;; but hide it so we don't trigger indefinitely.
`(,(car whole) (identity ,(car slots))
,@(cdr slots)))))))
- (apply #'eieio-constructor ',name slots))))))
-
-
-;;; CLOS style implementation of object creators.
-;;
-(defun make-instance (class &rest initargs)
- "Make a new instance of CLASS based on INITARGS.
-CLASS is a class symbol. For example:
-
- (make-instance 'foo)
-
- INITARGS is a property list with keywords based on the :initarg
-for each slot. For example:
-
- (make-instance 'foo :slot1 value1 :slotN valueN)
-
-Compatibility note:
-
-If the first element of INITARGS is a string, it is used as the
-name of the class.
+ (apply #'make-instance ',name slots))))))
-In EIEIO, the class' constructor requires a name for use when printing.
-`make-instance' in CLOS doesn't use names the way Emacs does, so the
-class is used as the name slot instead when INITARGS doesn't start with
-a string."
- (apply (eieio--class-constructor class) initargs))
-\f
;;; Get/Set slots in an object.
;;
(defmacro oref (obj slot)
(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.
(declare (indent 2) (debug (sexp sexp def-body)))
(require 'cl-lib)
;; Transform the spec-list into a cl-symbol-macrolet spec-list.
- (let ((mappings (mapcar (lambda (entry)
- (let ((var (if (listp entry) (car entry) entry))
- (slot (if (listp entry) (cadr entry) entry)))
- (list var `(slot-value ,object ',slot))))
- spec-list)))
- (append (list 'cl-symbol-macrolet mappings)
- body)))
+ (macroexp-let2 nil object object
+ `(cl-symbol-macrolet
+ ,(mapcar (lambda (entry)
+ (let ((var (if (listp entry) (car entry) entry))
+ (slot (if (listp entry) (cadr entry) entry)))
+ (list var `(slot-value ,object ',slot))))
+ spec-list)
+ ,@body)))
+
+;; Keep it as a non-inlined function, so the internals of object don't get
+;; hard-coded in random .elc files.
+(defun eieio-pcase-slot-index-table (obj)
+ "Return some data structure from which can be extracted the slot offset."
+ (eieio--class-index-table
+ (symbol-value (eieio--object-class-tag obj))))
+
+(defun eieio-pcase-slot-index-from-index-table (index-table slot)
+ "Find the index to pass to `aref' to access SLOT."
+ (let ((index (gethash slot index-table)))
+ (if index (+ (eval-when-compile
+ (length (cl-struct-slot-info 'eieio--object)))
+ index))))
+
+(pcase-defmacro eieio (&rest fields)
+ "Pcase patterns to match EIEIO objects.
+Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of
+field NAME is matched against UPAT, or they can be of the form NAME which
+is a shorthand for (NAME NAME)."
+ (declare (debug (&rest [&or (sexp pcase-UPAT) 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))))
\f
;;; Simple generators, and query functions. None of these would do
;; well embedded into an object.
;;
+
(define-obsolete-function-alias
- 'object-class-fast #'eieio--object-class-name "24.4")
+ 'object-class-fast #'eieio-object-class "24.4")
(cl-defgeneric eieio-object-name-string (obj)
"Return a string which is OBJ's name."
(declare (obsolete eieio-named "25.1")))
(defun eieio-object-name (obj &optional extra)
- "Return a Lisp like symbol string for object OBJ.
+ "Return a printed representation for object OBJ.
If EXTRA, include that in the string returned to represent the symbol."
- (eieio--check-type eieio-object-p obj)
- (format "#<%s %s%s>" (eieio--object-class-name obj)
+ (cl-check-type obj eieio-object)
+ (format "#<%s %s%s>" (eieio-object-class obj)
(eieio-object-name-string obj) (or extra "")))
(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4")
(cl-defmethod eieio-object-set-name-string (obj name)
"Set the string which is OBJ's NAME."
(declare (obsolete eieio-named "25.1"))
- (eieio--check-type stringp name)
+ (cl-check-type name string)
(setf (gethash obj eieio--object-names) name))
(define-obsolete-function-alias
'object-set-name-string 'eieio-object-set-name-string "24.4")
(defun eieio-object-class (obj)
"Return the class struct defining OBJ."
;; FIXME: We say we return a "struct" but we return a symbol instead!
- (eieio--check-type eieio-object-p obj)
- (eieio--object-class-name obj))
+ (cl-check-type obj eieio-object)
+ (eieio--class-name (eieio--object-class obj)))
(define-obsolete-function-alias 'object-class #'eieio-object-class "24.4")
;; CLOS name, maybe?
(define-obsolete-function-alias 'class-of #'eieio-object-class "24.4")
(defun eieio-object-class-name (obj)
"Return a Lisp like symbol name for OBJ's class."
- (eieio--check-type eieio-object-p obj)
- (eieio-class-name (eieio--object-class-name obj)))
+ (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")
"Return parent classes to CLASS. (overload of variable).
The CLOS function `class-direct-superclasses' is aliased to this function."
- (let ((c (eieio-class-object class)))
- (eieio--class-parent c)))
+ (eieio--class-parents (eieio--class-object class)))
(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4")
(defun eieio-class-children (class)
"Return child classes to CLASS.
The CLOS function `class-direct-subclasses' is aliased to this function."
- (eieio--check-type class-p class)
- (eieio--class-children (eieio--class-v class)))
+ (cl-check-type class class)
+ (eieio--class-children (cl--find-class class)))
(define-obsolete-function-alias
'class-children #'eieio-class-children "24.4")
(defun same-class-p (obj class)
"Return t if OBJ is of class-type CLASS."
(setq class (eieio--class-object class))
- (eieio--check-type eieio--class-p class)
- (eieio--check-type eieio-object-p obj)
- (eq (eieio--object-class-object obj) class))
+ (cl-check-type class eieio--class)
+ (cl-check-type obj eieio-object)
+ (eq (eieio--object-class obj) class))
(defun object-of-class-p (obj class)
"Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses."
- (eieio--check-type eieio-object-p obj)
+ (cl-check-type obj eieio-object)
;; class will be checked one layer down
- (child-of-class-p (eieio--object-class-object obj) class))
+ (child-of-class-p (eieio--object-class obj) class))
;; Backwards compatibility
(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."
(setq child (eieio--class-object child))
- (eieio--check-type eieio--class-p child)
- ;; `eieio-default-superclass' is never mentioned in eieio--class-parent,
+ (cl-check-type child eieio--class)
+ ;; `eieio-default-superclass' is never mentioned in eieio--class-parents,
;; so we have to special case it here.
(or (eq class 'eieio-default-superclass)
(let ((p nil))
(setq class (eieio--class-object class))
- (eieio--check-type eieio--class-p class)
+ (cl-check-type class eieio--class)
(while (and child (not (eq child class)))
- (setq p (append p (eieio--class-parent child))
+ (setq p (append p (eieio--class-parents child))
child (pop p)))
(if child t))))
-(defun object-slots (obj)
- "Return list of slots available in OBJ."
- (eieio--check-type eieio-object-p obj)
- (eieio--class-public-a (eieio--object-class-object obj)))
+(defun eieio-slot-descriptor-name (slot)
+ (cl--slot-descriptor-name slot))
-(defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
- (eieio--check-type eieio--class-p class)
+(defun eieio-class-slots (class)
+ "Return list of slots available in instances of CLASS."
+ ;; FIXME: This only gives the instance slots and ignores the
+ ;; class-allocated slots.
+ (setq class (eieio--class-object class))
+ (cl-check-type class eieio--class)
+ (mapcar #'identity (eieio--class-slots class)))
+
+(defun object-slots (obj)
+ "Return list of slot names available in OBJ."
+ (declare (obsolete eieio-class-slots "25.1"))
+ (cl-check-type obj eieio-object)
+ (mapcar #'cl--slot-descriptor-name
+ (eieio-class-slots (eieio--object-class obj))))
+
+(defun eieio--class-slot-initarg (class slot)
+ "Fetch from CLASS, SLOT's :initarg."
+ (cl-check-type class eieio--class)
(let ((ia (eieio--class-initarg-tuples class))
(f nil))
(while (and ia (not f))
;; Return nil if the magic symbol is in there.
(not (eq (cond
((eieio-object-p object) (eieio-oref object slot))
- ((class-p object) (eieio-oref-default object slot))
+ ((symbolp object) (eieio-oref-default object slot))
(t (signal 'wrong-type-argument (list 'eieio-object-p object))))
eieio-unbound))))
(defun slot-exists-p (object-or-class slot)
"Return non-nil if OBJECT-OR-CLASS has SLOT."
(let ((cv (cond ((eieio-object-p object-or-class)
- (eieio--object-class-object object-or-class))
- (t (eieio-class-object object-or-class)))))
- (or (memq slot (eieio--class-public-a cv))
- (memq slot (eieio--class-class-allocation-a cv)))
- ))
+ (eieio--object-class object-or-class))
+ ((eieio--class-p object-or-class) object-or-class)
+ (t (find-class object-or-class 'error)))))
+ (or (gethash slot (eieio--class-index-table cv))
+ ;; FIXME: We could speed this up by adding class slots into the
+ ;; index-table (e.g. with a negative index?).
+ (let ((cs (eieio--class-class-slots cv))
+ found)
+ (dotimes (i (length cs))
+ (if (eq slot (cl--slot-descriptor-name (aref cs i)))
+ (setq found t)))
+ found))))
(defun find-class (symbol &optional errorp)
"Return the class that SYMBOL represents.
If there is no class, nil is returned if ERRORP is nil.
If ERRORP is non-nil, `wrong-argument-type' is signaled."
- (if (not (class-p symbol))
- (if errorp (signal 'wrong-type-argument (list 'class-p symbol))
- nil)
- (eieio--class-v symbol)))
+ (let ((class (cl--find-class symbol)))
+ (cond
+ ((eieio--class-p class) class)
+ (errorp (signal 'wrong-type-argument (list 'class-p symbol))))))
;;; Slightly more complex utility functions for objects
;;
Objects in LIST do not need to have a slot named SLOT, nor does
SLOT need to be bound. If these errors occur, those objects will
be ignored."
- (eieio--check-type listp list)
+ (cl-check-type list list)
(while (and list (not (condition-case nil
;; This prevents errors for missing slots.
(equal key (eieio-oref (car list) slot))
"Return an association list with the contents of SLOT as the key element.
LIST must be a list of objects with SLOT in it.
This is useful when you need to do completing read on an object group."
- (eieio--check-type listp list)
+ (cl-check-type list list)
(let ((assoclist nil))
(while list
(setq assoclist (cons (cons (eieio-oref (car list) slot)
LIST must be a list of objects, but those objects do not need to have
SLOT in it. If it does not, then that element is left out of the association
list."
- (eieio--check-type listp list)
+ (cl-check-type list list)
(let ((assoclist nil))
(while list
(if (slot-exists-p (car list) 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)
\f
This class is not stored in the `parent' slot of a class vector."
:abstract t)
-(setq eieio-default-superclass (eieio--class-v 'eieio-default-superclass))
+(setq eieio-default-superclass (cl--find-class 'eieio-default-superclass))
(defalias 'standard-class 'eieio-default-superclass)
-(cl-defgeneric eieio-constructor (class &rest slots)
- "Default constructor for CLASS `eieio-default-superclass'.")
+(cl-defgeneric make-instance (class &rest initargs)
+ "Make a new instance of CLASS based on INITARGS.
+For example:
-(define-obsolete-function-alias 'constructor #'eieio-constructor "25.1")
+ (make-instance 'foo)
+
+INITARGS is a property list with keywords based on the `:initarg'
+for each slot. For example:
-(cl-defmethod eieio-constructor
- ((class (subclass eieio-default-superclass)) &rest slots)
+ (make-instance 'foo :slot1 value1 :slotN valueN)")
+
+(define-obsolete-function-alias 'constructor #'make-instance "25.1")
+
+(cl-defmethod make-instance
+ ((class (subclass eieio-default-superclass)) &rest slots)
"Default constructor for CLASS `eieio-default-superclass'.
-SLOTS are the initialization slots used by `shared-initialize'.
+SLOTS are the initialization slots used by `initialize-instance'.
This static method is called when an object is constructed.
It allocates the vector used to represent an EIEIO object, and then
-calls `shared-initialize' on that object."
+calls `initialize-instance' on that object."
(let* ((new-object (copy-sequence (eieio--class-default-object-cache
- (eieio--class-v class)))))
+ (eieio--class-object class)))))
(if (and slots
(let ((x (car slots)))
(or (stringp x) (null x))))
;; Return the created object.
new-object))
+;; FIXME: CLOS uses "&rest INITARGS" instead.
(cl-defgeneric shared-initialize (obj slots)
"Set slots of OBJ with SLOTS which is a list of name/value pairs.
Called from the constructor routine.")
"Set slots of OBJ with SLOTS which is a list of name/value pairs.
Called from the constructor routine."
(while slots
- (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj)
+ (let ((rn (eieio--initarg-to-attribute (eieio--object-class obj)
(car slots))))
(if (not rn)
(slot-missing obj (car slots) 'oset (car (cdr slots)))
(eieio-oset obj rn (car (cdr slots)))))
(setq slots (cdr (cdr slots)))))
+;; FIXME: CLOS uses "&rest INITARGS" instead.
(cl-defgeneric initialize-instance (this &optional slots)
"Construct the new object THIS based on SLOTS.")
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-object this))
- (slot (eieio--class-public-a this-class))
- (defaults (eieio--class-public-d this-class)))
- (while slot
+ (let* ((this-class (eieio--object-class this))
+ (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:
;; > 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.
- (let ((dflt (eieio-default-eval-maybe (car defaults))))
- (when (not (eq dflt (car defaults)))
- (eieio-oset this (car slot) dflt) ))
- ;; Next.
- (setq slot (cdr slot)
- defaults (cdr defaults))))
+ (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))
In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but
EIEIO can only dispatch on the first argument, so the first two are swapped."
- (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object)
+ (signal 'unbound-slot (list (eieio-class-name class)
+ (eieio-object-name object)
slot-name fn)))
(cl-defgeneric clone (obj &rest params)
(princ comment)
(princ "\n"))
(let* ((cl (eieio-object-class this))
- (cv (eieio--class-v cl)))
+ (cv (cl--find-class cl)))
;; Now output readable lisp to recreate this object
;; It should look like this:
;; (<constructor> <name> <slot> <slot> ... )
(prin1 (eieio-object-name-string this))
(princ "\n")
;; Loop over all the public slots
- (let ((publa (eieio--class-public-a cv))
- (publd (eieio--class-public-d cv))
- (publp (eieio--class-public-printer cv))
+ (let ((slots (eieio--class-slots cv))
(eieio-print-depth (1+ eieio-print-depth)))
- (while publa
- (when (slot-boundp this (car publa))
- (let ((i (eieio--class-slot-initarg cv (car publa)))
- (v (eieio-oref this (car publa)))
- )
- (unless (or (not i) (equal v (car publd)))
- (unless (bolp)
- (princ "\n"))
- (princ (make-string (* eieio-print-depth 2) ? ))
- (princ (symbol-name i))
- (if (car publp)
- ;; Use our public printer
- (progn
- (princ " ")
- (funcall (car publp) v))
- ;; Use our generic override prin1 function.
- (princ (if (or (eieio-object-p v)
- (eieio-object-p (car-safe v)))
- "\n" " "))
- (eieio-override-prin1 v)))))
- (setq publa (cdr publa) publd (cdr publd)
- publp (cdr publp))))
+ (dotimes (i (length slots))
+ (let ((slot (aref slots i)))
+ (when (slot-boundp this (cl--slot-descriptor-name slot))
+ (let ((i (eieio--class-slot-initarg
+ cv (cl--slot-descriptor-name slot)))
+ (v (eieio-oref this (cl--slot-descriptor-name slot))))
+ (unless (or (not i) (equal v (cl--slot-descriptor-initform slot)))
+ (unless (bolp)
+ (princ "\n"))
+ (princ (make-string (* eieio-print-depth 2) ? ))
+ (princ (symbol-name i))
+ (if (alist-get :printer (cl--slot-descriptor-props slot))
+ ;; Use our public printer
+ (progn
+ (princ " ")
+ (funcall (alist-get :printer
+ (cl--slot-descriptor-props slot))
+ v))
+ ;; Use our generic override prin1 function.
+ (princ (if (or (eieio-object-p v)
+ (eieio-object-p (car-safe v)))
+ "\n" " "))
+ (eieio-override-prin1 v))))))))
(princ ")")
(when (= eieio-print-depth 0)
(princ "\n"))))
(object-write thing))
((consp thing)
(eieio-list-prin1 thing))
- ((class-p thing)
- (princ (eieio-class-name thing)))
- ((or (keywordp thing) (booleanp thing))
- (prin1 thing))
- ((symbolp thing)
- (princ (concat "'" (symbol-name thing))))
+ ((eieio--class-p thing)
+ (princ (eieio--class-print-name thing)))
(t (prin1 thing))))
(defun eieio-list-prin1 (list)
(error "EIEIO: `change-class' is unimplemented"))
;; 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)
;;; Interfacing with edebug
Used as advice around `edebug-prin1-to-string', held in the
variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
`prin1-to-string' when appropriate."
- (cond ((eieio--class-p object) (eieio-class-name object))
+ (cond ((eieio--class-p object) (eieio--class-print-name object))
((eieio-object-p object) (object-print object))
((and (listp object) (or (eieio--class-p (car object))
(eieio-object-p (car object))))
\f
;;; Start of automatically extracted autoloads.
\f
-;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "2ec91e473fcad1ff20cd76edc4aab706")
+;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "916f54b818479a77a02f3ecccda84a11")
;;; Generated autoloads from eieio-custom.el
(autoload 'customize-object "eieio-custom" "\
;;;***
\f
-;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "b849f8bf1312d5ef57e53d02173e4b5a")
+;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "cb1aba7670b6a4b9c6f968c0ad6dc130")
;;; Generated autoloads from eieio-opt.el
(autoload 'eieio-browse "eieio-opt" "\
\(fn &optional ROOT-CLASS)" t nil)
-(autoload 'eieio-help-class "eieio-opt" "\
-Print help description for CLASS.
-If CLASS is actually an object, then also display current values of that object.
-
-\(fn CLASS)" nil nil)
+(define-obsolete-function-alias 'eieio-help-class 'cl--describe-class "25.1")
(autoload 'eieio-help-constructor "eieio-opt" "\
Describe CTR if it is a class constructor.