Commit 6a67b20d authored by Stefan Monnier's avatar Stefan Monnier

* 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.
parent 54181569
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
......
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))))
(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
(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))))
(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