* lisp/emacs-lisp/eieio*.el: Move the function defs to defclass.
* lisp/emacs-lisp/eieio.el (defclass): Move from eieio-defclass all the code that creates functions, and most of the sanity checks. Mark as obsolete the <class>-child-p function. * lisp/emacs-lisp/eieio-core.el (eieio--define-field-accessors): Remove. (eieio--class, eieio--object): Use cl-defstruct. (eieio--object-num-slots): Define manually. (eieio-defclass-autoload): Use eieio--class-make. (eieio-defclass-internal): Rename from eieio-defclass. Move all the `(lambda...) definitions and most of the sanity checks to `defclass'. Mark as obsolete the <class>-list-p function, the <class> variable and the <initarg> variables. Use pcase-dolist. (eieio-defclass): New compatibility function. * lisp/emacs-lisp/eieio-opt.el (eieio-build-class-alist) (eieio-class-speedbar): Don't use eieio-default-superclass var.
This commit is contained in:
Stefan Monnier
parent
54181569d2
commit
6a67b20ddd
5 changed files with 299 additions and 270 deletions
7
etc/NEWS
7
etc/NEWS
|
|
@ -1,6 +1,6 @@
|
|||
GNU Emacs NEWS -- history of user-visible changes.
|
||||
|
||||
Copyright (C) 2014 Free Software Foundation, Inc.
|
||||
Copyright (C) 2014, 2015 Free Software Foundation, Inc.
|
||||
See the end of the file for license conditions.
|
||||
|
||||
Please send Emacs bug reports to bug-gnu-emacs@gnu.org.
|
||||
|
|
@ -187,6 +187,11 @@ Unicode standards.
|
|||
|
||||
|
||||
* Changes in Specialized Modes and Packages in Emacs 25.1
|
||||
|
||||
** EIEIO
|
||||
*** The <class>-list-p and <class>-child-p functions are declared obsolete.
|
||||
*** The <class> variables are declared obsolete.
|
||||
*** The <initarg> variables are declared obsolete.
|
||||
** ido
|
||||
*** New command `ido-bury-buffer-at-head' bound to C-S-b
|
||||
Bury the buffer at the head of `ido-matches', analogous to how C-k
|
||||
|
|
|
|||
|
|
@ -1,9 +1,27 @@
|
|||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/eieio.el (defclass): Move from eieio-defclass all the code
|
||||
that creates functions, and most of the sanity checks.
|
||||
Mark as obsolete the <class>-child-p function.
|
||||
* emacs-lisp/eieio-core.el (eieio--define-field-accessors): Remove.
|
||||
(eieio--class, eieio--object): Use cl-defstruct.
|
||||
(eieio--object-num-slots): Define manually.
|
||||
(eieio-defclass-autoload): Use eieio--class-make.
|
||||
(eieio-defclass-internal): Rename from eieio-defclass. Move all the
|
||||
`(lambda...) definitions and most of the sanity checks to `defclass'.
|
||||
Mark as obsolete the <class>-list-p function, the <class> variable and
|
||||
the <initarg> variables. Use pcase-dolist.
|
||||
(eieio-defclass): New compatibility function.
|
||||
* emacs-lisp/eieio-opt.el (eieio-build-class-alist)
|
||||
(eieio-class-speedbar): Don't use eieio-default-superclass var.
|
||||
|
||||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/eieio-generic.el: New file.
|
||||
* emacs-lisp/eieio-core.el: Move all generic function code to
|
||||
eieio-generic.el.
|
||||
(eieio--defmethod): Declare.
|
||||
|
||||
* emacs-lisp/eieio.el: Require eieio-generic. Move all generic
|
||||
function code to eieio-generic.el.
|
||||
* emacs-lisp/eieio-opt.el (eieio-help-generic): Move to
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@
|
|||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'pcase)
|
||||
|
||||
(put 'eieio--defalias 'byte-hunk-handler
|
||||
#'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
|
||||
|
|
@ -117,66 +118,70 @@ Currently under control of this var:
|
|||
`(let ((eieio--scoped-class-stack (cons ,class eieio--scoped-class-stack)))
|
||||
,@forms))
|
||||
|
||||
;;;
|
||||
;; Field Accessors
|
||||
;;
|
||||
(defmacro eieio--define-field-accessors (prefix fields)
|
||||
(declare (indent 1))
|
||||
(let ((index 0)
|
||||
(defs '()))
|
||||
(dolist (field fields)
|
||||
(let ((doc (if (listp field)
|
||||
(prog1 (cadr field) (setq field (car field))))))
|
||||
(push `(defmacro ,(intern (format "eieio--%s-%s" prefix field)) (x)
|
||||
,@(if doc (list (format (if (string-match "\n" doc)
|
||||
"Return %s" "Return %s of a %s.")
|
||||
doc prefix)))
|
||||
(list 'aref x ,index))
|
||||
defs)
|
||||
(setq index (1+ index))))
|
||||
`(eval-and-compile
|
||||
,@(nreverse defs)
|
||||
(defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index))))
|
||||
(progn
|
||||
;; Arrange for field access not to bother checking if the access is indeed
|
||||
;; made to an eieio--class object.
|
||||
(cl-declaim (optimize (safety 0)))
|
||||
(cl-defstruct (eieio--class
|
||||
(:constructor nil)
|
||||
(:constructor eieio--class-make (symbol &aux (tag 'defclass)))
|
||||
(:type vector)
|
||||
(:copier nil))
|
||||
;; We use an untagged cl-struct, with our own hand-made tag as first field
|
||||
;; (containing the symbol `defclass'). It would be better to use a normal
|
||||
;; cl-struct with its normal tag (e.g. so that cl-defstruct can define the
|
||||
;; predicate for us), but that breaks compatibility with .elc files compiled
|
||||
;; against older versions of EIEIO.
|
||||
tag
|
||||
symbol ;; symbol (self-referencing)
|
||||
parent children
|
||||
symbol-hashtable ;; hashtable permitting fast access to variable position indexes
|
||||
;; @todo
|
||||
;; the word "public" here is leftovers from the very first version.
|
||||
;; Get rid of it!
|
||||
public-a ;; class attribute index
|
||||
public-d ;; class attribute defaults index
|
||||
public-doc ;; class documentation strings for attributes
|
||||
public-type ;; class type for a slot
|
||||
public-custom ;; class custom type for a slot
|
||||
public-custom-label ;; class custom group for a slot
|
||||
public-custom-group ;; class custom group for a slot
|
||||
public-printer ;; printer for a slot
|
||||
protection ;; protection for a slot
|
||||
initarg-tuples ;; initarg tuples list
|
||||
class-allocation-a ;; class allocated attributes
|
||||
class-allocation-doc ;; class allocated documentation
|
||||
class-allocation-type ;; class allocated value type
|
||||
class-allocation-custom ;; class allocated custom descriptor
|
||||
class-allocation-custom-label ;; class allocated custom descriptor
|
||||
class-allocation-custom-group ;; class allocated custom group
|
||||
class-allocation-printer ;; class allocated printer for a slot
|
||||
class-allocation-protection ;; class allocated protection list
|
||||
class-allocation-values ;; class allocated value vector
|
||||
default-object-cache ;; what a newly created object would look like.
|
||||
; This will speed up instantiation time as
|
||||
; only a `copy-sequence' will be needed, instead of
|
||||
; looping over all the values and setting them from
|
||||
; the default.
|
||||
options ;; storage location of tagged class option
|
||||
; Stored outright without modifications or stripping
|
||||
)
|
||||
;; Set it back to the default value.
|
||||
(cl-declaim (optimize (safety 1))))
|
||||
|
||||
(eieio--define-field-accessors class
|
||||
(-unused-0 ;;Constant slot, set to `defclass'.
|
||||
(symbol "symbol (self-referencing)")
|
||||
parent children
|
||||
(symbol-hashtable "hashtable permitting fast access to variable position indexes")
|
||||
;; @todo
|
||||
;; the word "public" here is leftovers from the very first version.
|
||||
;; Get rid of it!
|
||||
(public-a "class attribute index")
|
||||
(public-d "class attribute defaults index")
|
||||
(public-doc "class documentation strings for attributes")
|
||||
(public-type "class type for a slot")
|
||||
(public-custom "class custom type for a slot")
|
||||
(public-custom-label "class custom group for a slot")
|
||||
(public-custom-group "class custom group for a slot")
|
||||
(public-printer "printer for a slot")
|
||||
(protection "protection for a slot")
|
||||
(initarg-tuples "initarg tuples list")
|
||||
(class-allocation-a "class allocated attributes")
|
||||
(class-allocation-doc "class allocated documentation")
|
||||
(class-allocation-type "class allocated value type")
|
||||
(class-allocation-custom "class allocated custom descriptor")
|
||||
(class-allocation-custom-label "class allocated custom descriptor")
|
||||
(class-allocation-custom-group "class allocated custom group")
|
||||
(class-allocation-printer "class allocated printer for a slot")
|
||||
(class-allocation-protection "class allocated protection list")
|
||||
(class-allocation-values "class allocated value vector")
|
||||
(default-object-cache "what a newly created object would look like.
|
||||
This will speed up instantiation time as only a `copy-sequence' will
|
||||
be needed, instead of looping over all the values and setting them
|
||||
from the default.")
|
||||
(options "storage location of tagged class options.
|
||||
Stored outright without modifications or stripping.")))
|
||||
|
||||
(eieio--define-field-accessors object
|
||||
(cl-defstruct (eieio--object
|
||||
(:type vector) ;We manage our own tagging system.
|
||||
(:constructor nil)
|
||||
(:copier nil))
|
||||
;; `class-tag' holds a symbol, which is not the class name, but is instead
|
||||
;; properly prefixed as an internal EIEIO thingy and which holds the class
|
||||
;; object/struct in its `symbol-value' slot.
|
||||
((class-tag "tag containing the class struct")))
|
||||
class-tag)
|
||||
|
||||
(eval-and-compile
|
||||
(defconst eieio--object-num-slots
|
||||
(length (get 'eieio--object 'cl-struct-slots))))
|
||||
|
||||
(defsubst eieio--object-class-object (obj)
|
||||
(symbol-value (eieio--object-class-tag obj)))
|
||||
|
|
@ -297,15 +302,11 @@ It creates an autoload function for CNAME's constructor."
|
|||
;; Assume we've already debugged inputs.
|
||||
|
||||
(let* ((oldc (when (class-p cname) (eieio--class-v cname)))
|
||||
(newc (make-vector eieio--class-num-slots nil))
|
||||
(newc (eieio--class-make cname))
|
||||
)
|
||||
(if oldc
|
||||
nil ;; Do nothing if we already have this class.
|
||||
|
||||
;; Create the class in NEWC, but don't fill anything else in.
|
||||
(aset newc 0 'defclass)
|
||||
(setf (eieio--class-symbol newc) cname)
|
||||
|
||||
(let ((clear-parent nil))
|
||||
;; No parents?
|
||||
(when (not superclasses)
|
||||
|
|
@ -333,7 +334,8 @@ It creates an autoload function for CNAME's constructor."
|
|||
|
||||
;; turn this into a usable self-pointing symbol
|
||||
(when eieio-backward-compatibility
|
||||
(set cname cname))
|
||||
(set cname cname)
|
||||
(make-obsolete-variable cname (format "use '%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.
|
||||
|
|
@ -364,11 +366,10 @@ It creates an autoload function for CNAME's constructor."
|
|||
|
||||
(declare-function eieio--defmethod "eieio-generic" (method kind argclass code))
|
||||
|
||||
(defun eieio-defclass (cname superclasses slots options-and-doc)
|
||||
;; FIXME: Most of this should be moved to the `defclass' macro.
|
||||
(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 or
|
||||
documentation OPTIONS-AND-DOC is the toplevel documentation for this class.
|
||||
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
|
||||
|
|
@ -376,18 +377,12 @@ See `defclass' for more information."
|
|||
(run-hooks 'eieio-hook)
|
||||
(setq eieio-hook nil)
|
||||
|
||||
(eieio--check-type listp superclasses)
|
||||
|
||||
(let* ((pname superclasses)
|
||||
(newc (make-vector eieio--class-num-slots nil))
|
||||
(newc (eieio--class-make cname))
|
||||
(oldc (when (class-p cname) (eieio--class-v cname)))
|
||||
(groups nil) ;; list of groups id'd from slots
|
||||
(options nil)
|
||||
(clearparent nil))
|
||||
|
||||
(aset newc 0 'defclass)
|
||||
(setf (eieio--class-symbol newc) cname)
|
||||
|
||||
;; 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
|
||||
|
|
@ -403,19 +398,6 @@ See `defclass' for more information."
|
|||
(setf (eieio--class-children newc) children)
|
||||
(remhash cname eieio-defclass-autoload-map))))
|
||||
|
||||
(cond ((and (stringp (car options-and-doc))
|
||||
(/= 1 (% (length options-and-doc) 2)))
|
||||
(error "Too many arguments to `defclass'"))
|
||||
((and (symbolp (car options-and-doc))
|
||||
(/= 0 (% (length options-and-doc) 2)))
|
||||
(error "Too many arguments to `defclass'"))
|
||||
)
|
||||
|
||||
(setq options
|
||||
(if (stringp (car options-and-doc))
|
||||
(cons :documentation options-and-doc)
|
||||
options-and-doc))
|
||||
|
||||
(if pname
|
||||
(progn
|
||||
(dolist (p pname)
|
||||
|
|
@ -447,52 +429,13 @@ See `defclass' for more information."
|
|||
|
||||
;; turn this into a usable self-pointing symbol; FIXME: Why?
|
||||
(when eieio-backward-compatibility
|
||||
(set cname cname))
|
||||
|
||||
;; These two tests must be created right away so we can have self-
|
||||
;; referencing classes. ei, a class whose slot can contain only
|
||||
;; pointers to itself.
|
||||
|
||||
;; Create the test function
|
||||
(let ((csym (intern (concat (symbol-name cname) "-p"))))
|
||||
(fset csym
|
||||
`(lambda (obj)
|
||||
,(format "Test OBJ to see if it an object of type %s" cname)
|
||||
(and (eieio-object-p obj)
|
||||
(same-class-p obj ',cname)))))
|
||||
|
||||
;; Make sure the method invocation order is a valid value.
|
||||
(let ((io (eieio--class-option-assoc options :method-invocation-order)))
|
||||
(when (and io (not (member io '(:depth-first :breadth-first :c3))))
|
||||
(error "Method invocation order %s is not allowed" io)
|
||||
))
|
||||
|
||||
;; Create a handy child test too
|
||||
(let ((csym (if eieio-backward-compatibility
|
||||
(intern (concat (symbol-name cname) "-child-p"))
|
||||
(make-symbol (concat (symbol-name cname) "-child-p")))))
|
||||
(fset csym
|
||||
`(lambda (obj)
|
||||
,(format
|
||||
"Test OBJ to see if it an object is a child of type %s"
|
||||
cname)
|
||||
(and (eieio-object-p obj)
|
||||
(object-of-class-p obj ',cname))))
|
||||
|
||||
;; When using typep, (typep OBJ 'myclass) returns t for objects which
|
||||
;; are subclasses of myclass. For our predicates, however, it is
|
||||
;; important for EIEIO to be backwards compatible, where
|
||||
;; myobject-p, and myobject-child-p are different.
|
||||
;; "cl" uses this technique to specify symbols with specific typep
|
||||
;; test, so we can let typep have the CLOS documented behavior
|
||||
;; while keeping our above predicate clean.
|
||||
|
||||
(put cname 'cl-deftype-satisfies csym))
|
||||
(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"))))
|
||||
(fset csym
|
||||
(defalias csym
|
||||
`(lambda (obj)
|
||||
,(format
|
||||
"Test OBJ to see if it a list of objects which are a child of type %s"
|
||||
|
|
@ -505,7 +448,10 @@ See `defclass' for more information."
|
|||
(setq ans (and (eieio-object-p (car obj))
|
||||
(object-of-class-p (car obj) ,cname)))
|
||||
(setq obj (cdr obj)))
|
||||
ans))))))
|
||||
ans))))
|
||||
(make-obsolete csym (format "use (cl-typep ... '(list-of %s)) instead"
|
||||
cname)
|
||||
"25.1")))
|
||||
|
||||
;; Before adding new slots, let's add all the methods and classes
|
||||
;; in from the parent class.
|
||||
|
|
@ -519,19 +465,13 @@ See `defclass' for more information."
|
|||
|
||||
;; Query each slot in the declaration list and mangle into the
|
||||
;; class structure I have defined.
|
||||
(while slots
|
||||
(let* ((slot1 (car slots))
|
||||
(name (car slot1))
|
||||
(slot (cdr slot1))
|
||||
(acces (plist-get slot :accessor))
|
||||
(init (or (plist-get slot :initform)
|
||||
(pcase-dolist (`(,name . ,slot) slots)
|
||||
(let* ((init (or (plist-get slot :initform)
|
||||
(if (member :initform slot) nil
|
||||
eieio-unbound)))
|
||||
(initarg (plist-get slot :initarg))
|
||||
(docstr (plist-get slot :documentation))
|
||||
(prot (plist-get slot :protection))
|
||||
(reader (plist-get slot :reader))
|
||||
(writer (plist-get slot :writer))
|
||||
(alloc (plist-get slot :allocation))
|
||||
(type (plist-get slot :type))
|
||||
(custom (plist-get slot :custom))
|
||||
|
|
@ -542,51 +482,24 @@ See `defclass' for more information."
|
|||
(skip-nil (eieio--class-option-assoc options :allow-nil-initform))
|
||||
)
|
||||
|
||||
(if eieio-error-unsupported-class-tags
|
||||
(let ((tmp slot))
|
||||
(while tmp
|
||||
(if (not (member (car tmp) '(:accessor
|
||||
:initform
|
||||
:initarg
|
||||
:documentation
|
||||
:protection
|
||||
:reader
|
||||
:writer
|
||||
:allocation
|
||||
:type
|
||||
:custom
|
||||
:label
|
||||
:group
|
||||
:printer
|
||||
:allow-nil-initform
|
||||
:custom-groups)))
|
||||
(signal 'invalid-slot-type (list (car tmp))))
|
||||
(setq tmp (cdr (cdr tmp))))))
|
||||
|
||||
;; Clean up the meaning of protection.
|
||||
(cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil))
|
||||
((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected))
|
||||
((or (eq prot 'private) (eq prot :private)) (setq prot 'private))
|
||||
((eq prot nil) nil)
|
||||
(t (signal 'invalid-slot-type (list :protection prot))))
|
||||
|
||||
;; Make sure the :allocation parameter has a valid value.
|
||||
(if (not (or (not alloc) (eq alloc :class) (eq alloc :instance)))
|
||||
(signal 'invalid-slot-type (list :allocation alloc)))
|
||||
(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))
|
||||
|
||||
;; Label is nil, or a string
|
||||
(if (not (or (null label) (stringp label)))
|
||||
(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"))
|
||||
|
||||
;; intern the symbol so we can use it blankly
|
||||
(if initarg (set initarg initarg))
|
||||
(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 ((null customg)
|
||||
|
|
@ -604,63 +517,9 @@ See `defclass' for more information."
|
|||
prot initarg alloc 'defaultoverride skip-nil)
|
||||
|
||||
;; We need to id the group, and store them in a group list attribute.
|
||||
(mapc (lambda (cg) (cl-pushnew cg groups :test 'equal)) customg)
|
||||
|
||||
;; Anyone can have an accessor function. This creates a function
|
||||
;; of the specified name, and also performs a `defsetf' if applicable
|
||||
;; so that users can `setf' the space returned by this function.
|
||||
(if acces
|
||||
(progn
|
||||
(eieio--defmethod
|
||||
acces (if (eq alloc :class) :static :primary) cname
|
||||
`(lambda (this)
|
||||
,(format
|
||||
"Retrieves the slot `%s' from an object of class `%s'"
|
||||
name cname)
|
||||
(if (slot-boundp this ',name)
|
||||
;; Use oref-default for :class allocated slots, since
|
||||
;; these also accept the use of a class argument instead
|
||||
;; of an object argument.
|
||||
(,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref)
|
||||
this ',name)
|
||||
;; Else - Some error? nil?
|
||||
nil)))
|
||||
|
||||
;; FIXME: We should move more of eieio-defclass into the
|
||||
;; defclass macro so we don't have to use `eval' and require
|
||||
;; `gv' at run-time.
|
||||
;; FIXME: The defmethod above only defines a part of the generic
|
||||
;; function, but the define-setter below affects the whole
|
||||
;; generic function!
|
||||
(eval `(gv-define-setter ,acces (eieio--store eieio--object)
|
||||
;; Apparently, eieio-oset-default doesn't work like
|
||||
;; oref-default and only accept class arguments!
|
||||
(list ',(if nil ;; (eq alloc :class)
|
||||
'eieio-oset-default
|
||||
'eieio-oset)
|
||||
eieio--object '',name
|
||||
eieio--store)))))
|
||||
|
||||
;; If a writer is defined, then create a generic method of that
|
||||
;; name whose purpose is to set the value of the slot.
|
||||
(if writer
|
||||
(eieio--defmethod
|
||||
writer nil cname
|
||||
`(lambda (this value)
|
||||
,(format "Set the slot `%s' of an object of class `%s'"
|
||||
name cname)
|
||||
(setf (slot-value this ',name) value))))
|
||||
;; If a reader is defined, then create a generic method
|
||||
;; of that name whose purpose is to access this slot value.
|
||||
(if reader
|
||||
(eieio--defmethod
|
||||
reader nil cname
|
||||
`(lambda (this)
|
||||
,(format "Access the slot `%s' from object of class `%s'"
|
||||
name cname)
|
||||
(slot-value this ',name))))
|
||||
)
|
||||
(setq slots (cdr slots)))
|
||||
(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.
|
||||
|
|
@ -700,30 +559,6 @@ See `defclass' for more information."
|
|||
prots (cdr prots)))
|
||||
(setf (eieio--class-symbol-hashtable newc) oa))
|
||||
|
||||
;; Create the constructor function
|
||||
(if (eieio--class-option-assoc options :abstract)
|
||||
;; Abstract classes cannot be instantiated. Say so.
|
||||
(let ((abs (eieio--class-option-assoc options :abstract)))
|
||||
(if (not (stringp abs))
|
||||
(setq abs (format "Class %s is abstract" cname)))
|
||||
(fset cname
|
||||
`(lambda (&rest stuff)
|
||||
,(format "You cannot create a new object of type %s" cname)
|
||||
(error ,abs))))
|
||||
|
||||
;; Non-abstract classes need a constructor.
|
||||
(fset cname
|
||||
`(lambda (&rest slots)
|
||||
,(format "Create a new object with name NAME of class type %s" cname)
|
||||
(if (and slots
|
||||
(let ((x (car slots)))
|
||||
(or (stringp x) (null x))))
|
||||
(funcall (if eieio-backward-compatibility #'ignore #'message)
|
||||
"Obsolete name %S passed to %S constructor"
|
||||
(pop slots) ',cname))
|
||||
(apply #'eieio-constructor ',cname slots)))
|
||||
)
|
||||
|
||||
;; Set up a specialized doc string.
|
||||
;; Use stored value since it is calculated in a non-trivial way
|
||||
(put cname 'variable-documentation
|
||||
|
|
@ -1468,6 +1303,13 @@ method invocation orders of the involved classes."
|
|||
(define-error 'unbound-slot "Unbound slot")
|
||||
(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy")
|
||||
|
||||
;;; Backward compatibility functions
|
||||
;; To support .elc files compiled for older versions of EIEIO.
|
||||
|
||||
(defun eieio-defclass (cname superclasses slots options)
|
||||
(eval `(defclass ,cname ,superclasses ,slots ,options)))
|
||||
|
||||
|
||||
(provide 'eieio-core)
|
||||
|
||||
;;; eieio-core.el ends here
|
||||
|
|
|
|||
|
|
@ -230,7 +230,7 @@ Optional argument CLASS is the class to start with.
|
|||
If INSTANTIABLE-ONLY is non nil, only allow names of classes which
|
||||
are not abstract, otherwise allow all classes.
|
||||
Optional argument BUILDLIST is more list to attach and is used internally."
|
||||
(let* ((cc (or class eieio-default-superclass))
|
||||
(let* ((cc (or class 'eieio-default-superclass))
|
||||
(sublst (eieio--class-children (eieio--class-v cc))))
|
||||
(unless (assoc (symbol-name cc) buildlist)
|
||||
(when (or (not instantiable-only) (not (class-abstract-p cc)))
|
||||
|
|
@ -561,7 +561,7 @@ current expansion depth."
|
|||
(when (eq (point-min) (point-max))
|
||||
;; This function is only called once, to start the whole deal.
|
||||
;; Create and expand the default object.
|
||||
(eieio-class-button eieio-default-superclass 0)
|
||||
(eieio-class-button 'eieio-default-superclass 0)
|
||||
(forward-line -1)
|
||||
(speedbar-expand-line)))
|
||||
|
||||
|
|
|
|||
|
|
@ -58,13 +58,11 @@
|
|||
|
||||
;;; Defining a new class
|
||||
;;
|
||||
(defmacro defclass (name superclass slots &rest options-and-doc)
|
||||
(defmacro defclass (name superclasses slots &rest options-and-doc)
|
||||
"Define NAME as a new class derived from SUPERCLASS with SLOTS.
|
||||
OPTIONS-AND-DOC is used as the class' options and base documentation.
|
||||
SUPERCLASS is a list of superclasses to inherit from, with SLOTS
|
||||
being the slots residing in that class definition. NOTE: Currently
|
||||
only one slot may exist in SUPERCLASS as multiple inheritance is not
|
||||
yet supported. Supported tags are:
|
||||
SUPERCLASSES is a list of superclasses to inherit from, with SLOTS
|
||||
being the slots residing in that class definition. Supported tags are:
|
||||
|
||||
:initform - Initializing form.
|
||||
:initarg - Tag used during initialization.
|
||||
|
|
@ -115,12 +113,178 @@ Options in CLOS not supported in EIEIO:
|
|||
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))
|
||||
;; This is eval-and-compile only to silence spurious compiler warnings
|
||||
;; about functions and variables not known to be defined.
|
||||
;; When eieio-defclass code is merged here and this becomes
|
||||
;; transparent to the compiler, the eval-and-compile can be removed.
|
||||
`(eval-and-compile
|
||||
(eieio-defclass ',name ',superclass ',slots ',options-and-doc)))
|
||||
(eieio--check-type listp superclasses)
|
||||
|
||||
(cond ((and (stringp (car options-and-doc))
|
||||
(/= 1 (% (length options-and-doc) 2)))
|
||||
(error "Too many arguments to `defclass'"))
|
||||
((and (symbolp (car options-and-doc))
|
||||
(/= 0 (% (length options-and-doc) 2)))
|
||||
(error "Too many arguments to `defclass'")))
|
||||
|
||||
(if (stringp (car options-and-doc))
|
||||
(setq options-and-doc
|
||||
(cons :documentation options-and-doc)))
|
||||
|
||||
;; Make sure the method invocation order is a valid value.
|
||||
(let ((io (eieio--class-option-assoc options-and-doc
|
||||
:method-invocation-order)))
|
||||
(when (and io (not (member io '(:depth-first :breadth-first :c3))))
|
||||
(error "Method invocation order %s is not allowed" io)))
|
||||
|
||||
(let ((testsym1 (intern (concat (symbol-name name) "-p")))
|
||||
(testsym2 (intern (format "eieio--childp--%s" name)))
|
||||
(accessors ()))
|
||||
|
||||
;; Collect the accessors we need to define.
|
||||
(pcase-dolist (`(,sname . ,soptions) slots)
|
||||
(let* ((acces (plist-get soptions :accessor))
|
||||
(initarg (plist-get soptions :initarg))
|
||||
(reader (plist-get soptions :reader))
|
||||
(writer (plist-get soptions :writer))
|
||||
(alloc (plist-get soptions :allocation))
|
||||
(label (plist-get soptions :label)))
|
||||
|
||||
(if eieio-error-unsupported-class-tags
|
||||
(let ((tmp soptions))
|
||||
(while tmp
|
||||
(if (not (member (car tmp) '(:accessor
|
||||
:initform
|
||||
:initarg
|
||||
:documentation
|
||||
:protection
|
||||
:reader
|
||||
:writer
|
||||
:allocation
|
||||
:type
|
||||
:custom
|
||||
:label
|
||||
:group
|
||||
:printer
|
||||
:allow-nil-initform
|
||||
:custom-groups)))
|
||||
(signal 'invalid-slot-type (list (car tmp))))
|
||||
(setq tmp (cdr (cdr tmp))))))
|
||||
|
||||
;; Make sure the :allocation parameter has a valid value.
|
||||
(if (not (memq alloc '(nil :class :instance)))
|
||||
(signal 'invalid-slot-type (list :allocation alloc)))
|
||||
|
||||
;; Label is nil, or a string
|
||||
(if (not (or (null label) (stringp label)))
|
||||
(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"))
|
||||
|
||||
;; Anyone can have an accessor function. This creates a function
|
||||
;; of the specified name, and also performs a `defsetf' if applicable
|
||||
;; so that users can `setf' the space returned by this function.
|
||||
(when acces
|
||||
;; FIXME: The defmethod below only defines a part of the generic
|
||||
;; function (good), but the define-setter below affects the whole
|
||||
;; generic function (bad)!
|
||||
(push `(gv-define-setter ,acces (store object)
|
||||
;; Apparently, eieio-oset-default doesn't work like
|
||||
;; oref-default and only accept class arguments!
|
||||
(list ',(if nil ;; (eq alloc :class)
|
||||
'eieio-oset-default
|
||||
'eieio-oset)
|
||||
object '',sname store))
|
||||
accessors)
|
||||
(push `(defmethod ,acces ,(if (eq alloc :class) :static :primary)
|
||||
((this ,name))
|
||||
,(format
|
||||
"Retrieve the slot `%S' from an object of class `%S'."
|
||||
sname name)
|
||||
(if (slot-boundp this ',sname)
|
||||
;; Use oref-default for :class allocated slots, since
|
||||
;; these also accept the use of a class argument instead
|
||||
;; of an object argument.
|
||||
(,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref)
|
||||
this ',sname)
|
||||
;; Else - Some error? nil?
|
||||
nil))
|
||||
accessors))
|
||||
|
||||
;; If a writer is defined, then create a generic method of that
|
||||
;; name whose purpose is to set the value of the slot.
|
||||
(if writer
|
||||
(push `(defmethod ,writer ((this ,name) value)
|
||||
,(format "Set the slot `%S' of an object of class `%S'."
|
||||
sname name)
|
||||
(setf (slot-value this ',sname) value))
|
||||
accessors))
|
||||
;; If a reader is defined, then create a generic method
|
||||
;; of that name whose purpose is to access this slot value.
|
||||
(if reader
|
||||
(push `(defmethod ,reader ((this ,name))
|
||||
,(format "Access the slot `%S' from object of class `%S'."
|
||||
sname name)
|
||||
(slot-value this ',sname))
|
||||
accessors))
|
||||
))
|
||||
|
||||
`(progn
|
||||
;; 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.
|
||||
|
||||
;; 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)))
|
||||
|
||||
,@(when eieio-backward-compatibility
|
||||
(let ((f (intern (format "%s-child-p" name))))
|
||||
`((defalias ',f ',testsym2)
|
||||
(make-obsolete
|
||||
',f ,(format "use (cl-typep ... '%s) instead" name) "25.1"))))
|
||||
|
||||
;; When using typep, (typep OBJ 'myclass) returns t for objects which
|
||||
;; are subclasses of myclass. For our predicates, however, it is
|
||||
;; important for EIEIO to be backwards compatible, where
|
||||
;; myobject-p, and myobject-child-p are different.
|
||||
;; "cl" uses this technique to specify symbols with specific typep
|
||||
;; test, so we can let typep have the CLOS documented behavior
|
||||
;; while keeping our above predicate clean.
|
||||
|
||||
(put ',name 'cl-deftype-satisfies #',testsym2)
|
||||
|
||||
(eieio-defclass-internal ',name ',superclasses ',slots ',options-and-doc)
|
||||
|
||||
,@accessors
|
||||
|
||||
;; Create the constructor function
|
||||
,(if (eieio--class-option-assoc options-and-doc :abstract)
|
||||
;; Abstract classes cannot be instantiated. Say so.
|
||||
(let ((abs (eieio--class-option-assoc options-and-doc :abstract)))
|
||||
(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)
|
||||
(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)
|
||||
(if (and slots
|
||||
(let ((x (car slots)))
|
||||
(or (stringp x) (null x))))
|
||||
(funcall (if eieio-backward-compatibility #'ignore #'message)
|
||||
"Obsolete name %S passed to %S constructor"
|
||||
(pop slots) ',name))
|
||||
(apply #'eieio-constructor ',name slots))))))
|
||||
|
||||
|
||||
;;; CLOS style implementation of object creators.
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue