;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects
;;; or maybe Eric's Implementation of Emacs Intrepreted Objects
-;;; Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003,
-;;; 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, lisp
;;; Code:
-(require 'cl)
-(eval-when-compile (require 'eieio-comp))
+(eval-when-compile
+ (require 'cl)
+ (require 'eieio-comp))
(defvar eieio-version "1.2"
"Current version of EIEIO.")
(message eieio-version))
(eval-and-compile
-;; About the above. EIEIO must process it's own code when it compiles
+;; About the above. EIEIO must process its own code when it compiles
;; itself, thus, by eval-and-compiling outselves, we solve the problem.
;; Compatibility
"*This hook is executed, then cleared each time `defclass' is called.")
(defvar eieio-error-unsupported-class-tags nil
- "*Non nil to throw an error if an encountered tag us unsupported.
+ "*Non-nil to throw an error if an encountered tag us unsupported.
This may prevent classes from CLOS applications from being used with EIEIO
since EIEIO does not support all CLOS tags.")
Note: Embedded methods are no longer supported. The variable THIS is
still set for CLOS methods for the sake of routines like
-`call-next-method'")
+`call-next-method'.")
(defvar scoped-class nil
"This is set to a class when a method is running.
(defmacro generic-p (method)
"Return t if symbol METHOD is a generic function.
-Only methods have the symbol `eieio-method-obarray' as a property (which
-contains a list of all bindings to that method type.)"
+Only methods have the symbol `eieio-method-obarray' as a property
+\(which contains a list of all bindings to that method type.)"
`(and (fboundp ,method) (get ,method 'eieio-method-obarray)))
(defun generic-primary-only-p (method)
))
(defmacro class-option-assoc (list option)
- "Return from LIST the found OPTION. Nil if it doesn't exist."
+ "Return from LIST the found OPTION.
+Return nil if it doesn't exist."
`(car-safe (cdr (memq ,option ,list))))
(defmacro class-option (class option)
only one slot may exist in SUPERCLASS as multiple inheritance is not
yet supported. Supported tags are:
- :initform - initializing form
- :initarg - tag used during initialization
- :accessor - tag used to create a function to access this slot
- :allocation - specify where the value is stored.
- defaults to `:instance', but could also be `:class'
- :writer - a function symbol which will `write' an object's slot
- :reader - a function symbol which will `read' an object
- :type - the type of data allowed in this slot (see `typep')
+ :initform - Initializing form.
+ :initarg - Tag used during initialization.
+ :accessor - Tag used to create a function to access this slot.
+ :allocation - Specify where the value is stored.
+ Defaults to `:instance', but could also be `:class'.
+ :writer - A function symbol which will `write' an object's slot.
+ :reader - A function symbol which will `read' an object.
+ :type - The type of data allowed in this slot (see `typep').
:documentation
- A string documenting use of this slot.
The following are extensions on CLOS:
:protection - Specify protection for this slot.
- Defaults to `:public'. Also use `:protected', or `:private'
+ Defaults to `:public'. Also use `:protected', or `:private'.
:custom - When customizing an object, the custom :type. Public only.
:label - A text string label used for a slot when customizing.
:group - Name of a customization group this slot belongs in.
See `eieio-override-prin1' as an example.
A class can also have optional options. These options happen in place
-of documentation, (including a :documentation tag) in addition to
+of documentation (including a :documentation tag), in addition to
documentation, or not at all. Supported options are:
:documentation - The doc-string used for this class.
Options added to EIEIO:
- :allow-nil-initform - Non-nil to skip typechecking of initforms if nil.
+ :allow-nil-initform - Non-nil to skip typechecking of null initforms.
:custom-groups - List of custom group names. Organizes slots into
reasonable groups for customizations.
:abstract - Non-nil to prevent instances of this class.
If a string, use as an error string if someone does
try to make an instance.
:method-invocation-order
- - Control the method invokation order if there is
+ - Control the method invocation order if there is
multiple inheritance. Valid values are:
:breadth-first - The default.
:depth-first
:default-initargs - Initargs to use when initializing new objects of
this class.
-Due to the way class options are set up, you can add any tags in you
-wish, and reference them using the function `class-option'."
+Due to the way class options are set up, you can add any tags you wish,
+and reference them using the function `class-option'."
;; We must `eval-and-compile' this so that when we byte compile
;; an eieio program, there is no need to load it ahead of time.
;; It also provides lots of nice debugging errors at compile time.
;;;###autoload
(defun eieio-defclass-autoload (cname superclasses filename doc)
"Create autoload symbols for the EIEIO class CNAME.
-SUPERCLASSES are the superclasses that CNAME inherites from.
+SUPERCLASSES are the superclasses that CNAME inherits from.
DOC is the docstring for CNAME.
This function creates a mock-class for CNAME and adds it into
SUPERCLASSES as children.
))))
(defsubst eieio-class-un-autoload (cname)
- "If class CNAME is in an autoload state, load it's file."
+ "If class CNAME is in an autoload state, load its file."
(when (eq (car-safe (symbol-function cname)) 'autoload)
(load-library (car (cdr (symbol-function cname))))))
(defun eieio-defclass (cname superclasses slots options-and-doc)
- "See `defclass' for more information.
-Define CNAME as a new subclass of SUPERCLASSES, with SLOTS being the
-slots residing in that class definition, and with options or documentation
-OPTIONS-AND-DOC as the toplevel documentation for this class."
+ "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.
+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.
(aset newc 0 'defclass)
(aset newc class-symbol cname)
- ;; If this class already existed, and we are updating it's structure,
+ ;; 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
;; "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.
- (eval `(deftype ,cname ()
- '(satisfies
- ,(intern (concat (symbol-name cname) "-child-p")))))
- )
+ ;; It would be cleaner to use `defsetf' here, but that requires cl
+ ;; at runtime.
+ (put cname 'cl-deftype-handler
+ (list 'lambda () `(list 'satisfies (quote ,csym)))))
;; before adding new slots, lets add all the methods and classes
;; in from the parent class
(list 'if (list 'slot-boundp 'this (list 'quote name))
(list 'eieio-oref 'this (list 'quote name))
;; Else - Some error? nil?
- nil
- )))
- ;; Thanks Pascal Bourguignon <pjb@informatimago.com>
- ;; For this complex macro.
- (eval (macroexpand
- (list 'defsetf acces '(widget) '(store)
- (list 'list ''eieio-oset 'widget
- (list 'quote (list 'quote name)) 'store))))
- ;;`(defsetf ,acces (widget) (store) (eieio-oset widget ',cname store))
- )
- )
+ nil)))
+
+ ;; Provide a setf method. It would be cleaner to use
+ ;; defsetf, but that would require CL at runtime.
+ (put acces 'setf-method
+ `(lambda (widget)
+ (let* ((--widget-sym-- (make-symbol "--widget--"))
+ (--store-sym-- (make-symbol "--store--")))
+ (list
+ (list --widget-sym--)
+ (list widget)
+ (list --store-sym--)
+ (list 'eieio-oset --widget-sym-- '',name --store-sym--)
+ (list 'getfoo --widget-sym--)))))))
+
;; 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
(defun eieio-perform-slot-validation-for-default (slot spec value skipnil)
"For SLOT, signal if SPEC does not match VALUE.
-If SKIPNIL is non-nil, then if VALUE is nil, return t."
+If SKIPNIL is non-nil, then if VALUE is nil return t instead."
(let ((val (eieio-default-eval-maybe value)))
(if (and (not eieio-skip-typecheck)
(not (and skipnil (null val)))
&optional defaultoverride skipnil)
"Add into NEWC attribute A.
If A already exists in NEWC, then do nothing. If it doesn't exist,
-then also add in D (defualt), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg.
+then also add in D (default), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg.
Argument ALLOC specifies if the slot is allocated per instance, or per class.
If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC,
-we must override it's value for a default.
+we must override its value for a default.
Optional argument SKIPNIL indicates if type checking should be skipped
if default value is nil."
;; Make sure we duplicate those items that are sequences.
(tp (if np (nth num (aref newc class-public-type))))
)
(if (not np)
- (error "Eieio internal error overriding default value for %s"
+ (error "EIEIO internal error overriding default value for %s"
a)
;; If type is passed in, is it the same?
(if (not (eq type t))
;; End original PLN
;; PLN Tue Jun 26 11:57:06 2007 :
- ;; We do a non redundant combination of ancient
- ;; custom groups and new ones using the common lisp
- ;; `union' method.
+ ;; Do a non redundant combination of ancient custom
+ ;; groups and new ones.
(when custg
- (let ((where-groups
- (nthcdr num (aref newc class-public-custom-group))))
- (setcar where-groups
- (union (car where-groups)
- (if (listp custg) custg (list custg))))))
+ (let* ((groups
+ (nthcdr num (aref newc class-public-custom-group)))
+ (list1 (car groups))
+ (list2 (if (listp custg) custg (list custg))))
+ (if (< (length list1) (length list2))
+ (setq list1 (prog1 list2 (setq list2 list1))))
+ (dolist (elt list2)
+ (unless (memq elt list1)
+ (push elt list1)))
+ (setcar groups list1)))
;; End PLN
;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is
(tp (if np (nth num (aref newc class-class-allocation-type))
nil)))
(if (not np)
- (error "Eieio internal error overriding default value for %s"
+ (error "EIEIO internal error overriding default value for %s"
a)
;; If type is passed in, is it the same?
(if (not (eq type t))
(if (not (eq prot super-prot))
(error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
prot super-prot a)))
- ;; We do a non redundant combination of ancient
- ;; custom groups and new ones using the common lisp
- ;; `union' method.
+ ;; Do a non redundant combination of ancient custom groups
+ ;; and new ones.
(when custg
- (let ((where-groups
- (nthcdr num (aref newc class-class-allocation-custom-group))))
- (setcar where-groups
- (union (car where-groups)
- (if (listp custg) custg (list custg))))))
- ;; End PLN
+ (let* ((groups
+ (nthcdr num (aref newc class-class-allocation-custom-group)))
+ (list1 (car groups))
+ (list2 (if (listp custg) custg (list custg))))
+ (if (< (length list1) (length list2))
+ (setq list1 (prog1 list2 (setq list2 list1))))
+ (dolist (elt list2)
+ (unless (memq elt list1)
+ (push elt list1)))
+ (setcar groups list1)))
;; PLN Sat Jun 30 17:24:42 2007 : when a new
;; doc is specified, simply replaces the old one.
(defun eieio-copy-parents-into-subclass (newc parents)
"Copy into NEWC the slots of PARENTS.
-Follow the rules of not overwritting early parents when applying to
+Follow the rules of not overwriting early parents when applying to
the new child class."
(let ((ps (aref newc class-parent))
(sn (class-option-assoc (aref newc class-options)
(make-instance 'foo :slot1 value1 :slotN valueN)
-Compatability note:
+Compatibility note:
If the first element of INITARGS is a string, it is used as the
name of the class.
;;; CLOS methods and generics
;;
(defmacro defgeneric (method args &optional doc-string)
- "Create a generic function METHOD. ARGS is ignored.
+ "Create a generic function METHOD.
DOC-STRING is the base documentation for this class. A generic
-function has no body, as it's purpose is to decide which method body
-is appropriate to use. Use `defmethod' to create methods, and it
-calls defgeneric for you. With this implementation the arguments are
+function has no body, as its purpose is to decide which method body
+is appropriate to use. Uses `defmethod' to create methods, and calls
+`defgeneric' for you. With this implementation the ARGS are
currently ignored. You can use `defgeneric' to apply specialized
top level documentation to a method."
`(eieio-defgeneric (quote ,method) ,doc-string))
'method))
(defun eieio-unbind-method-implementations (method)
- "Make the generic method METHOD have no implementations..
-It will leave the original generic function in place, but remove
-reference to all implementations of METHOD."
+ "Make the generic method METHOD have no implementations.
+It will leave the original generic function in place,
+but remove reference to all implementations of METHOD."
(put method 'eieio-method-tree nil)
(put method 'eieio-method-obarray nil))
(defmacro defmethod (method &rest args)
"Create a new METHOD through `defgeneric' with ARGS.
-The second optional argument KEY is a specifier that
+The optional second argument KEY is a specifier that
modifies how the method is called, including:
- :before - Method will be called before the :primary
- :primary - The default if not specified.
- :after - Method will be called after the :primary
- :static - First arg could be an object or class
+ :before - Method will be called before the :primary
+ :primary - The default if not specified
+ :after - Method will be called after the :primary
+ :static - First arg could be an object or class
The next argument is the ARGLIST. The ARGLIST specifies the arguments
to the method as with `defun'. The first argument can have a type
specifier, such as:
(eieio-defgeneric
method
(if (stringp (car body))
- (car body) (format "Generically created method `%s'" method)))
+ (car body) (format "Generically created method `%s'." method)))
;; create symbol for property to bind to. If the first arg is of
;; the form (varname vartype) and `vartype' is a class, then
;; that class will be the type symbol. If not, then it will fall
method)
;;; Slot type validation
-;;
+
+;; This is a hideous hack for replacing `typep' from cl-macs, to avoid
+;; requiring the CL library at run-time. It can be eliminated if/when
+;; `typep' is merged into Emacs core.
+(defun eieio--typep (val type)
+ (if (symbolp type)
+ (cond ((get type 'cl-deftype-handler)
+ (eieio--typep val (funcall (get type 'cl-deftype-handler))))
+ ((eq type t) t)
+ ((eq type 'null) (null val))
+ ((eq type 'atom) (atom val))
+ ((eq type 'float) (and (numberp val) (not (integerp val))))
+ ((eq type 'real) (numberp val))
+ ((eq type 'fixnum) (integerp val))
+ ((memq type '(character string-char)) (characterp val))
+ (t
+ (let* ((name (symbol-name type))
+ (namep (intern (concat name "p"))))
+ (if (fboundp namep)
+ (funcall `(lambda () (,namep val)))
+ (funcall `(lambda ()
+ (,(intern (concat name "-p")) val)))))))
+ (cond ((get (car type) 'cl-deftype-handler)
+ (eieio--typep val (apply (get (car type) 'cl-deftype-handler)
+ (cdr type))))
+ ((memq (car type) '(integer float real number))
+ (and (eieio--typep val (car type))
+ (or (memq (cadr type) '(* nil))
+ (if (consp (cadr type))
+ (> val (car (cadr type)))
+ (>= val (cadr type))))
+ (or (memq (caddr type) '(* nil))
+ (if (consp (car (cddr type)))
+ (< val (caar (cddr type)))
+ (<= val (car (cddr type)))))))
+ ((memq (car type) '(and or not))
+ (eval (cons (car type)
+ (mapcar (lambda (x)
+ `(eieio--typep (quote ,val) (quote ,x)))
+ (cdr type)))))
+ ((memq (car type) '(member member*))
+ (memql val (cdr type)))
+ ((eq (car type) 'satisfies)
+ (funcall `(lambda () (,(cadr type) val))))
+ (t (error "Bad type spec: %s" type)))))
+
(defun eieio-perform-slot-validation (spec value)
"Return non-nil if SPEC does not match VALUE."
- ;; typep is in cl-macs
(or (eq spec t) ; t always passes
(eq value eieio-unbound) ; unbound always passes
- (typep value spec)))
+ (eieio--typep value spec)))
(defun eieio-validate-slot-value (class slot-idx value slot)
- "Make sure that for CLASS referencing SLOT-IDX, that VALUE is valid.
+ "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
Checks the :type specifier.
SLOT is the slot that is being checked, and is only used when throwing
-and error."
+an error."
(if eieio-skip-typecheck
nil
;; Trim off object IDX junk added in for the object index.
(signal 'invalid-slot-type (list class slot st value))))))
(defun eieio-validate-class-slot-value (class slot-idx value slot)
- "Make sure that for CLASS referencing SLOT-IDX, that VALUE is valid.
+ "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
Checks the :type specifier.
SLOT is the slot that is being checked, and is only used when throwing
-and error."
+an error."
(if eieio-skip-typecheck
nil
(let ((st (aref (aref (class-v class) class-class-allocation-type)
(aref (aref (class-v class) class-class-allocation-values) c)
;; The slot-missing method is a cool way of allowing an object author
;; to intercept missing slot definitions. Since it is also the LAST
- ;; thing called in this fn, it's return value would be retrieved.
+ ;; thing called in this fn, its return value would be retrieved.
(slot-missing obj slot 'oref)
;;(signal 'invalid-slot-name (list (object-name obj) slot))
)
(defalias 'set-slot-value 'eieio-oset)
(defmacro oref-default (obj slot)
- "Gets the default value of OBJ (maybe a class) for SLOT.
+ "Get the default value of OBJ (maybe a class) for SLOT.
The default value is the value installed in a class with the :initform
tag. SLOT can be the slot name, or the tag specified by the :initarg
tag in the `defclass' call."
`(eieio-oref-default ,obj (quote ,slot)))
(defun eieio-oref-default (obj slot)
- "Does the work for the macro `oref-default' with similar parameters.
-Fills in OBJ's SLOT with it's default value."
+ "Do the work for the macro `oref-default' with similar parameters.
+Fills in OBJ's SLOT with its default value."
(if (not (or (eieio-object-p obj) (class-p obj))) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
(if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot)))
(let* ((cl (if (eieio-object-p obj) (aref obj object-class) obj))
`(eieio-oset ,obj (quote ,slot) ,value))
(defun eieio-oset (obj slot value)
- "Does the work for the macro `oset'.
+ "Do the work for the macro `oset'.
Fills in OBJ's SLOT with VALUE."
(if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
(if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot)))
`(eieio-oset-default ,class (quote ,slot) ,value))
(defun eieio-oset-default (class slot value)
- "Does the work for the macro `oset-default'.
+ "Do the work for the macro `oset-default'.
Fills in the default value in CLASS' in SLOT with VALUE."
(if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
(if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot)))
(VARN+1 SLOTN+1))
Where each VAR is the local variable given to the associated
-SLOT. A Slot specified without a variable name is given a
+SLOT. A slot specified without a variable name is given a
variable name of the same name as the slot."
+ (declare (indent 2))
;; Transform the spec-list into a symbol-macrolet spec-list.
(let ((mappings (mapcar (lambda (entry)
(let ((var (if (listp entry) (car entry) entry))
spec-list)))
(append (list 'symbol-macrolet mappings)
body)))
-(put 'with-slots 'lisp-indent-function 2)
-
\f
;;; Simple generators, and query functions. None of these would do
;; well embedded into an object.
`(aref (class-v ,class) class-children))
(defun class-children (class)
-"Return child classses to CLASS.
+"Return child classes to CLASS.
The CLOS function `class-direct-subclasses' is aliased to this function."
(if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
(defalias 'obj-of-class-p 'object-of-class-p)
(defun child-of-class-p (child class)
- "If CHILD class is a subclass of CLASS."
+ "Return non-nil if CHILD class is a subclass of CLASS."
(if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
(if (not (class-p child)) (signal 'wrong-type-argument (list 'class-p child)))
(let ((p nil))
p (cdr p)))
(if child t)))
-(defun object-slots (obj) "List of slots available in OBJ."
+(defun object-slots (obj) "Return list of slots available in OBJ."
(if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
(aref (class-v (object-class-fast obj)) class-public-a))
;;; CLOS queries into classes and slots
;;
(defun slot-boundp (object slot)
- "Non-nil if OBJECT's SLOT is bound.
+ "Return non-nil if OBJECT's SLOT is bound.
Setting a slot's value makes it bound. Calling `slot-makeunbound' will
make a slot unbound.
OBJECT can be an instance or a class."
(eieio-oset object slot eieio-unbound))
(defun slot-exists-p (object-or-class slot)
- "Non-nil if OBJECT-OR-CLASS has SLOT."
+ "Return non-nil if OBJECT-OR-CLASS has SLOT."
(let ((cv (class-v (cond ((eieio-object-p object-or-class)
(object-class object-or-class))
((class-p object-or-class)
;;
(defun object-assoc (key slot list)
"Return an object if KEY is `equal' to SLOT's value of an object in LIST.
-LIST is a list of objects who's slots are searched.
+LIST is a list of objects whose slots are searched.
Objects in LIST do not need to have a slot named SLOT, nor does
SLOT need to be bound. If these errors occur, those objects will
be ignored."
(defun object-remove-from-list (object slot item)
"In OBJECT's SLOT, remove occurrences of ITEM.
-Deletion is done with `delete', which deletes by side effect
+Deletion is done with `delete', which deletes by side effect,
and comparisons are done with `equal'.
If SLOT is unbound, do nothing."
(if (not (slot-boundp object slot))
;;; EIEIO internal search functions
;;
(defun eieio-slot-originating-class-p (start-class slot)
- "Return Non-nil if START-CLASS is the first class to define SLOT.
+ "Return non-nil if START-CLASS is the first class to define SLOT.
This is for testing if `scoped-class' is the class that defines SLOT
so that we can protect private slots."
(let ((par (class-parents start-class))
"In CLASS for OBJ find the index of the named SLOT.
The slot is a symbol which is installed in CLASS by the `defclass'
call. OBJ can be nil, but if it is an object, and the slot in question
-is protected, access will be allowed if obj is a child of the currently
+is protected, access will be allowed if OBJ is a child of the currently
`scoped-class'.
If SLOT is the value created with :initarg instead,
reverse-lookup that name, and recurse with the associated slot value."
(defvar eieio-pre-method-execution-hooks nil
"*Hooks run just before a method is executed.
-The hook function must accept on argument, this list of forms
+The hook function must accept one argument, the list of forms
about to be executed.")
(defun eieio-generic-call (method args)
(run-hook-with-args 'eieio-pre-method-execution-hooks
primarymethodlist)
- ;; Now loop through all occurances forms which we must execute
+ ;; Now loop through all occurrences forms which we must execute
;; (which are happily sorted now) and execute them all!
(let ((rval nil) (lastval nil) (rvalever nil) (found nil))
(while lambdas
(setq primarymethodlist ;; Re-use even with bad name here
(eieiomt-method-list method method-primary mclass))
- ;; Now loop through all occurances forms which we must execute
+ ;; Now loop through all occurrences forms which we must execute
;; (which are happily sorted now) and execute them all!
(let* ((rval nil) (lastval nil) (rvalever nil)
(scoped-class (cdr lambdas))
(nreverse lambdas))))
(defun next-method-p ()
- "Non-nil if there is a next method.
+ "Return non-nil if there is a next method.
Returns a list of lambda expressions which is the `next-method'
order."
eieio-generic-call-next-method-list)
Use `next-method-p' to find out if there is a next method to call."
(if (not scoped-class)
- (error "Call-next-method not called within a class specific method"))
+ (error "`call-next-method' not called within a class specific method"))
(if (and (/= eieio-generic-call-key method-primary)
(/= eieio-generic-call-key method-static))
(error "Cannot `call-next-method' except in :primary or :static methods")
It also indicates if CLASS is defined or not.
CLASS is the class this method is associated with."
(if (or (> key method-num-slots) (< key 0))
- (error "Eieiomt-add: method key error!"))
+ (error "eieiomt-add: method key error!"))
(let ((emtv (get method-name 'eieio-method-tree))
(emto (get method-name 'eieio-method-obarray)))
;; Make sure the method tables are available.
(defun eieiomt-next (class)
"Return the next parent class for CLASS.
-If CLASS is a superclass, return variable `eieio-default-superclass'. If CLASS
-is variable `eieio-default-superclass' then return nil. This is different from
-function `class-parent' as class parent returns nil for superclasses. This
-function performs no type checking!"
+If CLASS is a superclass, return variable `eieio-default-superclass'.
+If CLASS is variable `eieio-default-superclass' then return nil.
+This is different from function `class-parent' as class parent returns
+nil for superclasses. This function performs no type checking!"
;; No type-checking because all calls are made from functions which
;; are safe and do checking for us.
(or (class-parents-fast class)
(cont t))
;; This converts ES from a single symbol to a list of parent classes.
(setq es (eieiomt-next es))
- ;; Loop over ES, then it's children individually.
+ ;; Loop over ES, then its children individually.
;; We can have multiple hits only at one level of the parent tree.
(while (and es cont)
(setq ov (intern-soft (symbol-name (car es)) eieiomt-optimizing-obarray))
(defun eieio-generic-form (method key class)
"Return the lambda form belonging to METHOD using KEY based upon CLASS.
-If CLASS is not a class then use `generic' instead. If class has no
-form, but has a parent class, then trace to that parent class. The
-first time a form is requested from a symbol, an optimized path is
-memoized for future faster use."
+If CLASS is not a class then use `generic' instead. If class has
+no form, but has a parent class, then trace to that parent class.
+The first time a form is requested from a symbol, an optimized path
+is memorized for faster future use."
(let ((emto (aref (get method 'eieio-method-obarray)
(if class key (+ key 3)))))
(if (class-p class)
;; This can be slow since it only occurs once
(progn
(setq cs (intern (symbol-name class) emto))
- ;; 2.1) Cache it's nearest neighbor with a quick optimize
+ ;; 2.1) Cache its nearest neighbor with a quick optimize
;; which should only occur once for this call ever
(let ((eieiomt-optimizing-obarray emto))
(eieiomt-sym-optimize cs))))
;; 4) If it's not bound then this variable knows something
(if (symbol-value cs)
(progn
- ;; 4.1) This symbol holds the next class in it's value
+ ;; 4.1) This symbol holds the next class in its value
(setq class (symbol-value cs)
cs (intern-soft (symbol-name class) emto))
;; 4.2) The optimizer should always have chosen a
(defun eieio-initarg-to-attribute (class initarg)
"For CLASS, convert INITARG to the actual attribute name.
If there is no translation, pass it in directly (so we can cheat if
-need be.. May remove that later...)"
+need be... May remove that later...)"
(let ((tuple (assoc initarg (aref (class-v class) class-initarg-tuples))))
(if tuple
(cdr tuple)
;; The below setf method was written by Arnd Kohrs <kohrs@acm.org>
(define-setf-method oref (obj slot)
- (let ((obj-temp (gensym))
- (slot-temp (gensym))
- (store-temp (gensym)))
- (list (list obj-temp slot-temp)
- (list obj `(quote ,slot))
- (list store-temp)
- (list 'set-slot-value obj-temp slot-temp
- store-temp)
- (list 'slot-value obj-temp slot-temp))))
+ (with-no-warnings
+ (require 'cl)
+ (let ((obj-temp (gensym))
+ (slot-temp (gensym))
+ (store-temp (gensym)))
+ (list (list obj-temp slot-temp)
+ (list obj `(quote ,slot))
+ (list store-temp)
+ (list 'set-slot-value obj-temp slot-temp
+ store-temp)
+ (list 'slot-value obj-temp slot-temp)))))
\f
;;;
(defclass eieio-default-superclass nil
nil
"Default parent class for classes with no specified parent class.
-Its slots are automatically adopted by classes with no specified
-parents. This class is not stored in the `parent' slot of a class vector."
+Its slots are automatically adopted by classes with no specified parents.
+This class is not stored in the `parent' slot of a class vector."
:abstract t)
(defalias 'standard-class 'eieio-default-superclass)
(defgeneric constructor (class newname &rest slots)
- "Default constructor for CLASS `eieio-defualt-superclass'.")
+ "Default constructor for CLASS `eieio-default-superclass'.")
(defmethod constructor :static
((class eieio-default-superclass) newname &rest slots)
- "Default constructor for CLASS `eieio-defualt-superclass'.
+ "Default constructor for CLASS `eieio-default-superclass'.
NEWNAME is the name to be given to the constructed object.
SLOTS are the initialization slots used by `shared-initialize'.
This static method is called when an object is constructed.
(setq slots (cdr (cdr slots))))))
(defgeneric initialize-instance (this &optional slots)
- "Constructs the new object THIS based on SLOTS.")
+ "Construct the new object THIS based on SLOTS.")
(defmethod initialize-instance ((this eieio-default-superclass)
&optional slots)
- "Constructs the new object THIS based on SLOTS.
+ "Construct the new object THIS based on SLOTS.
SLOTS is a tagged list where odd numbered elements are tags, and
-even numbered elements are the values to store in the tagged slot. If
-you overload the `initialize-instance', there you will need to call
-`shared-initialize' yourself, or you can call `call-next-method' to
-have this constructor called automatically. If these steps are not
-taken, then new objects of your class will not have their values
+even numbered elements are the values to store in the tagged slot.
+If you overload the `initialize-instance', there you will need to
+call `shared-initialize' yourself, or you can call `call-next-method'
+to have this constructor called automatically. If these steps are
+not taken, then new objects of your class will not have their values
dynamically set from SLOTS."
;; First, see if any of our defaults are `lambda', and
;; re-evaluate them and apply the value to our slots.
&rest args)
"Called from `call-next-method' when no additional methods are available.
OBJECT is othe object being called on `call-next-method'.
-ARGS are the arguments it is called by.
+ARGS are the arguments it is called by.
This method signals `no-next-method' by default. Override this
-method to not throw an error, and it's return value becomes the
+method to not throw an error, and its return value becomes the
return value of `call-next-method'."
(signal 'no-next-method (list (object-name object) args))
)
"Pretty printer for object THIS. Call function `object-name' with STRINGS.
It is sometimes useful to put a summary of the object into the
-default #<notation> string when using eieio browsing tools.
+default #<notation> string when using EIEIO browsing tools.
Implement this method to customize the summary.")
(defmethod object-print ((this eieio-default-superclass) &rest strings)
function `object-name'.
It is sometimes useful to put a summary of the object into the
-default #<notation> string when using eieio browsing tools.
+default #<notation> string when using EIEIO browsing tools.
Implement this function and specify STRINGS in a call to
`call-next-method' to provide additional summary information.
(defgeneric object-write (this &optional comment)
"Write out object THIS to the current stream.
-Optional COMMENDS will add comments to the beginning of the output.")
+Optional COMMENT will add comments to the beginning of the output.")
(defmethod object-write ((this eieio-default-superclass) &optional comment)
"Write object THIS out to the current stream.
(princ ")\n")))
(defun eieio-override-prin1 (thing)
- "Perform a prin1 on THING taking advantage of object knowledge."
+ "Perform a `prin1' on THING taking advantage of object knowledge."
(cond ((eieio-object-p thing)
(object-write thing))
((listp thing)
"Change the class of OBJ to type CLASS.
This may create or delete slots, but does not affect the return value
of `eq'."
- (error "Eieio: `change-class' is unimplemented"))
+ (error "EIEIO: `change-class' is unimplemented"))
)
;;; Interfacing with edebug
;;
(defun eieio-edebug-prin1-to-string (object &optional noescape)
- "Display eieio OBJECT in fancy format. Overrides the edebug default.
+ "Display EIEIO OBJECT in fancy format.
+Overrides the edebug default.
Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate."
(cond ((class-p object) (class-name object))
((eieio-object-p object) (object-print object))
;;; Autoloading some external symbols, and hooking into the help system
;;
-(autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "For buffers thrown into help mode, augment for eieio.")
-(autoload 'eieio-browse "eieio-opt" "Create an object browser window" t)
+(autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "For buffers thrown into help mode, augment for EIEIO.")
+(autoload 'eieio-browse "eieio-opt" "Create an object browser window." t)
(autoload 'eieio-describe-class "eieio-opt" "Describe CLASS defined by a string or symbol" t)
(autoload 'eieio-describe-constructor "eieio-opt" "Describe the constructor function FCN." t)
-(autoload 'describe-class "eieio-opt" "Describe CLASS defined by a string or symbol" t)
-(autoload 'eieio-describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol" t)
-(autoload 'describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol" t)
+(autoload 'describe-class "eieio-opt" "Describe CLASS defined by a string or symbol." t)
+(autoload 'eieio-describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol." t)
+(autoload 'describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol." t)
(autoload 'customize-object "eieio-custom" "Create a custom buffer editing OBJ.")
(provide 'eieio)
-;; Local variables:
-;; byte-compile-warnings: (not cl-functions)
-;; End:
-
+;; arch-tag: c1aeab9c-2938-41a3-842b-1a38bd26e9f2
;;; eieio ends here
HCoop / bpt / emacs.git / blobdiff