Function: eieio-defclass-internal
eieio-defclass-internal is a byte-compiled function defined in
eieio-core.el.gz.
Signature
(eieio-defclass-internal CNAME SUPERCLASSES SLOTS OPTIONS)
Documentation
Define CNAME as a new subclass of SUPERCLASSES.
SLOTS are the slots residing in that class definition, and OPTIONS
holds the class options.
See defclass for more information.
This function has :after advice: eieio-defclass-internal@closql-object.
Source Code
;; Defined in /usr/src/emacs/lisp/emacs-lisp/eieio-core.el.gz
(defun eieio-defclass-internal (cname superclasses slots options)
"Define CNAME as a new subclass of SUPERCLASSES.
SLOTS are the slots residing in that class definition, and OPTIONS
holds the class options.
See `defclass' for more information."
;; Run our eieio-hook each time, and clear it when we are done.
;; This way people can add hooks safely if they want to modify eieio
;; or add definitions when eieio is loaded or something like that.
(run-hooks 'eieio-hook)
(setq eieio-hook nil)
(let* ((oldc (let ((c (cl--find-class cname))) (if (eieio--class-p c) c)))
(newc (or oldc
;; Reuse `oldc' instead of creating a new one, so that
;; existing references stay valid. E.g. when
;; reloading the file that does the `defclass', we don't
;; want to create a new class object.
(eieio--class-make cname)))
(groups nil)) ;; list of groups id'd from slots
;; If this class already existed, and we are updating its structure,
;; make sure we keep the old child list. This can cause bugs, but
;; if no new slots are created, it also saves time, and prevents
;; method table breakage, particularly when the users is only
;; byte compiling an EIEIO file.
(if oldc
(progn
(cl-assert (eq newc oldc))
;; Reset the fields.
(setf (eieio--class-parents newc) nil)
(setf (eieio--class-slots newc) nil)
(setf (eieio--class-initarg-tuples newc) nil)
(setf (eieio--class-class-slots newc) nil))
;; If the old class did not exist, but did exist in the autoload map,
;; then adopt those children. This is like the above, but deals with
;; autoloads nicely.
(let ((children (gethash cname eieio-defclass-autoload-map)))
(when children
(setf (eieio--class-children newc) children)
(remhash cname eieio-defclass-autoload-map))))
(unless (or superclasses (eq cname 'eieio-default-superclass))
(setq superclasses '(eieio-default-superclass)))
(if superclasses
(progn
(dolist (p superclasses)
(if (not (and p (symbolp p)))
(error "Invalid parent class %S" p)
(let ((c (cl--find-class p)))
(if (not (eieio--class-p c))
;; bad class
(error "Given parent class %S is not a class" p)
;; good parent class...
;; save new child in parent
(cl-pushnew cname (eieio--class-children c))
;; Get custom groups, and store them into our local copy.
(mapc (lambda (g) (cl-pushnew g groups :test #'equal))
(eieio--class-option c :custom-groups))
;; Save parent in child.
(push c (eieio--class-parents newc))))))
;; Reverse the list of our parents so that they are prioritized in
;; the same order as specified in the code.
(cl-callf nreverse (eieio--class-parents newc))
;; Before adding new slots, let's add all the methods and classes
;; in from the parent class.
(eieio-copy-parents-into-subclass newc))
(cl-assert (eq cname 'eieio-default-superclass))
(setf (eieio--class-parents newc) (list (cl--find-class 'record))))
;; turn this into a usable self-pointing symbol; FIXME: Why?
(when eieio-backward-compatibility
(set cname cname)
(make-obsolete-variable cname (format "use '%s instead" cname)
"25.1"))
;; Create a handy list of the class test too
(when eieio-backward-compatibility
(let ((csym (intern (concat (symbol-name cname) "-list-p"))))
(defalias csym
(lambda (obj)
(:documentation
(internal--format-docstring-line
"Test OBJ to see if it a list of objects which are a child of type `%s'."
cname))
(when (listp obj)
(let ((ans t)) ;; nil is valid
;; Loop over all the elements of the input list, test
;; each to make sure it is a child of the desired object class.
(while (and obj ans)
(setq ans (and (eieio-object-p (car obj))
(object-of-class-p (car obj) 'cname)))
(setq obj (cdr obj)))
ans))))
(make-obsolete csym (format
"use (cl-typep ... '(list-of %s)) instead"
cname)
"25.1")))
;; Store the new class vector definition into the symbol. We need to
;; do this first so that we can call defmethod for the accessor.
;; The vector will be updated by the following while loop and will not
;; need to be stored a second time.
(setf (cl--find-class cname) newc)
;; Query each slot in the declaration list and mangle into the
;; class structure I have defined.
(pcase-dolist (`(,name . ,slot) slots)
(let* ((init (or (plist-get slot :initform)
(if (member :initform slot) nil
eieio--unbound-form)))
(initarg (plist-get slot :initarg))
(docstr (plist-get slot :documentation))
(prot (plist-get slot :protection))
(alloc (plist-get slot :allocation))
(type (plist-get slot :type))
(custom (plist-get slot :custom))
(label (plist-get slot :label))
(customg (plist-get slot :group))
(printer (plist-get slot :printer))
(skip-nil (eieio--class-option-assoc options :allow-nil-initform))
)
(unless (or (macroexp-const-p init)
(eieio--eval-default-p init))
;; FIXME: We duplicate this test here and in `defclass' because
;; if we move this part to `defclass' we may break some existing
;; code (because the `fboundp' test in `eieio--eval-default-p'
;; returns a different result at compile time).
(setq init (macroexp-quote init)))
;; Clean up the meaning of protection.
(setq prot
(pcase prot
((or 'nil 'public :public) nil)
((or 'protected :protected) 'protected)
((or 'private :private) 'private)
(_ (signal 'invalid-slot-type (list :protection prot)))))
;; The default type specifier is supposed to be t, meaning anything.
(if (not type) (setq type t))
;; intern the symbol so we can use it blankly
(if eieio-backward-compatibility
(and initarg (not (keywordp initarg))
(progn
(set initarg initarg)
(make-obsolete-variable
initarg (format "use '%s instead" initarg) "25.1"))))
;; The customgroup should be a list of symbols.
(cond ((and (null customg) custom)
(setq customg '(default)))
((not (listp customg))
(setq customg (list customg))))
;; The customgroup better be a list of symbols.
(dolist (cg customg)
(unless (symbolp cg)
(signal 'invalid-slot-type (list :group cg))))
;; First up, add this slot into our new class.
(eieio--add-new-slot
newc (cl--make-slot-descriptor
name init type
`(,@(if docstr `((:documentation . ,docstr)))
,@(if custom `((:custom . ,custom)))
,@(if label `((:label . ,label)))
,@(if customg `((:group . ,customg)))
,@(if printer `((:printer . ,printer)))
,@(if prot `((:protection . ,prot)))))
initarg alloc 'defaultoverride skip-nil)
;; We need to id the group, and store them in a group list attribute.
(dolist (cg customg)
(cl-pushnew cg groups :test #'equal))
))
;; Now that everything has been loaded up, all our lists are backwards!
;; Fix that up now and turn them into vectors.
(cl-callf (lambda (slots) (apply #'vector (nreverse slots)))
(eieio--class-slots newc))
(cl-callf nreverse (eieio--class-initarg-tuples newc))
;; The storage for class-class-allocation-type needs to be turned into
;; a vector now.
(cl-callf (lambda (slots) (apply #'vector slots))
(eieio--class-class-slots newc))
;; Also, setup the class allocated values.
(let* ((slots (eieio--class-class-slots newc))
(n (length slots))
(v (make-vector n nil)))
(dotimes (i n)
(setf (aref v i) (eval
(cl--slot-descriptor-initform (aref slots i))
t)))
(setf (eieio--class-class-allocation-values newc) v))
;; Attach slot symbols into a hash table, and store the index of
;; this slot as the value this table.
(let* ((slots (eieio--class-slots newc))
;; (cslots (eieio--class-class-slots newc))
(oa (make-hash-table :test #'eq)))
;; (dotimes (cnt (length cslots))
;; (setf (gethash (cl--slot-descriptor-name (aref cslots cnt)) oa) (- -1 cnt)))
(dotimes (cnt (length slots))
(setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa)
(+ (eval-when-compile eieio--object-num-slots) cnt)))
(setf (eieio--class-index-table newc) oa))
;; Set up a specialized doc string.
;; Use stored value since it is calculated in a non-trivial way
(let ((docstring (eieio--class-option-assoc options :documentation)))
(setf (eieio--class-docstring newc) docstring)
(when eieio-backward-compatibility
(put cname 'variable-documentation docstring)))
;; Save the file location where this class is defined.
(add-to-list 'current-load-list `(define-type . ,cname))
;; We have a list of custom groups. Store them into the options.
(let ((g (eieio--class-option-assoc options :custom-groups)))
(mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups)
(if (memq :custom-groups options)
(setcar (cdr (memq :custom-groups options)) g)
(setq options (cons :custom-groups (cons g options)))))
;; Set up the options we have collected.
(setf (eieio--class-options newc) options)
;; Create the cached default object.
(let ((cache (make-record newc
(+ (length (eieio--class-slots newc))
;; FIXME: Why +1 -1 ?
(eval-when-compile eieio--object-num-slots)
-1)
nil)))
(let ((eieio-skip-typecheck t))
;; All type-checking has been done to our satisfaction
;; before this call. Don't waste our time in this call..
(eieio-set-defaults cache t))
(setf (eieio--class-default-object-cache newc) cache))
;; Return our new class object
;; newc
cname
))