From: Stefan Monnier Date: Thu, 8 Jan 2015 20:47:32 +0000 (-0500) Subject: * lisp/emacs-lisp/eieio*.el: Move the function defs to defclass. X-Git-Tag: emacs-25.0.90~2605^2~18^2 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=6a67b20ddd458d71a1d63746504d91b1acea9b2b;p=emacs.git * 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 -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 -list-p function, the variable and the 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. --- diff --git a/etc/NEWS b/etc/NEWS index 14a91768680..0f20be86b9b 100644 --- a/etc/NEWS +++ b/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 -list-p and -child-p functions are declared obsolete. +*** The variables are declared obsolete. +*** The 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 diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 66b3b8eb061..6d7bfae31ce 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,9 +1,27 @@ +2015-01-08 Stefan Monnier + + * 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 -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 -list-p function, the variable and + the 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 * 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 diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index fba4d8f50c7..dc2c873eb42 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -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 diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 60bbd503adf..13ad120a9b5 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -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))) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index bf51986b133..205f13108b8 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -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.