;;; 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-2011 Free Software Foundation, Inc.
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Version: 0.2
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Version: 1.3
;; Keywords: OO, lisp
;; This file is part of GNU Emacs.
;; Emacs running environment.
;;
;; See eieio.texi for complete documentation on using this package.
+;;
+;; Note: the implementation of the c3 algorithm is based on:
+;; Kim Barrett et al.: A Monotonic Superclass Linearization for Dylan
+;; Retrieved from:
+;; http://192.220.96.201/dylan/linearization-oopsla96.html
;; There is funny stuff going on with typep and deftype. This
;; is the only way I seem to be able to make this stuff load properly.
;;; Code:
-(require 'cl)
-(eval-when-compile (require 'eieio-comp))
+(eval-when-compile
+ (require 'cl))
-(defvar eieio-version "1.2"
+(defvar eieio-version "1.3"
"Current version of EIEIO.")
(defun eieio-version ()
(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 is unsupported.
This may prevent classes from CLOS applications from being used with EIEIO
since EIEIO does not support all CLOS tags.")
"Non-nil means to optimize the method dispatch on primary methods.")
;; State Variables
+;; FIXME: These two constants below should have an `eieio-' prefix added!!
(defvar this nil
"Inside a method, this variable is the object in question.
DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots.
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.
;; while it is being built itself.
(defvar eieio-default-superclass nil)
+;; FIXME: The constants below should have an `eieio-' prefix added!!
(defconst class-symbol 1 "Class's symbol (self-referencing.).")
(defconst class-parent 2 "Class parent slot.")
(defconst class-children 3 "Class children class slot.")
(defconst method-generic-after 6 "Index into generic :after tag on a method.")
(defconst method-num-slots 7 "Number of indexes into a method's vector.")
-;; How to specialty compile stuff.
-(autoload 'byte-compile-file-form-defmethod "eieio-comp"
- "This function is used to byte compile methods in a nice way.")
-(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
+(defsubst eieio-specialized-key-to-generic-key (key)
+ "Convert a specialized KEY into a generic method key."
+ (cond ((eq key method-static) 0) ;; don't convert
+ ((< key method-num-lists) (+ key 3)) ;; The conversion
+ (t key) ;; already generic.. maybe.
+ ))
+
\f
;;; Important macros used in eieio.
;;
(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, or 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."
+ ;; FIXME: Most of this should be moved to the `defclass' macro.
+ "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
;; Make sure the method invocation order is a valid value.
(let ((io (class-option-assoc options :method-invocation-order)))
- (when (and io (not (member io '(:depth-first :breadth-first))))
+ (when (and io (not (member io '(:depth-first :breadth-first :c3))))
(error "Method invocation order %s is not allowed" io)
))
;; "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
;; so that users can `setf' the space returned by this function
(if acces
(progn
- (eieio-defmethod acces
- (list (if (eq alloc :class) :static :primary)
- (list (list 'this cname))
- (format
+ (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)
- (list 'if (list 'slot-boundp 'this (list 'quote name))
- (list 'eieio-oref 'this (list 'quote name))
+ (if (slot-boundp this ',name)
+ (eieio-oref this ',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
- (progn
- (eieio-defmethod writer
- (list (list (list 'this cname) 'value)
- (format "Set the slot `%s' of an object of class `%s'"
+ (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)))
- ))
+ (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
- (progn
- (eieio-defmethod reader
- (list (list (list 'this cname))
- (format "Access the slot `%s' from object of class `%s'"
+ (eieio--defmethod
+ reader nil cname
+ `(lambda (this)
+ ,(format "Access the slot `%s' from object of class `%s'"
name cname)
- `(slot-value this ',name)))))
+ (slot-value this ',name))))
)
(setq slots (cdr slots)))
(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."
- (let ((val (eieio-default-eval-maybe value)))
- (if (and (not eieio-skip-typecheck)
- (not (and skipnil (null val)))
- (not (eieio-perform-slot-validation spec val)))
- (signal 'invalid-slot-type (list slot spec val)))))
+If SKIPNIL is non-nil, then if VALUE is nil return t instead."
+ (if (and (not (eieio-eval-default-p value))
+ (not eieio-skip-typecheck)
+ (not (and skipnil (null value)))
+ (not (eieio-perform-slot-validation spec value)))
+ (signal 'invalid-slot-type (list slot spec value))))
(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc
&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.
\f
;;; CLOS methods and generics
;;
+
+(put 'eieio--defalias 'byte-hunk-handler
+ #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
+(defun eieio--defalias (name body)
+ "Like `defalias', but with less side-effects.
+More specifically, it has no side-effects at all when the new function
+definition is the same (`eq') as the old one."
+ (unless (and (fboundp name)
+ (eq (symbol-function name) body))
+ (defalias name body)))
+
(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))
+ `(eieio--defalias ',method
+ (eieio--defgeneric-init-form ',method ,doc-string)))
+
+(defun eieio--defgeneric-init-form (method doc-string)
+ "Form to use for the initial definition of a generic."
+ (cond
+ ((or (not (fboundp method))
+ (eq 'autoload (car-safe (symbol-function method))))
+ ;; Make sure the method tables are installed.
+ (eieiomt-install method)
+ ;; Construct the actual body of this function.
+ (eieio-defgeneric-form method doc-string))
+ ((generic-p method) (symbol-function method)) ;Leave it as-is.
+ (t (error "You cannot create a generic/method over an existing symbol: %s"
+ method))))
(defun eieio-defgeneric-form (method doc-string)
"The lambda form that would be used as the function defined on METHOD.
;; is faster to execute this for not byte-compiled. ie, install this,
;; then measure calls going through here. I wonder why.
(require 'bytecomp)
- (let ((byte-compile-free-references nil)
- (byte-compile-warnings nil)
- )
- (byte-compile-lambda
+ (let ((byte-compile-warnings nil))
+ (byte-compile
`(lambda (&rest local-args)
,doc-string
;; This is a cool cheat. Usually we need to look up in the
;; of that one implementation, then clearly, there is no method def.
(if (not (eieio-object-p (car local-args)))
;; Not an object. Just signal.
- (signal 'no-method-definition (list ,(list 'quote method) local-args))
+ (signal 'no-method-definition
+ (list ',method local-args))
;; We do have an object. Make sure it is the right type.
(if ,(if (eq class eieio-default-superclass)
- nil ; default superclass means just an obj. Already asked.
+ nil ; default superclass means just an obj. Already asked.
`(not (child-of-class-p (aref (car local-args) object-class)
- ,(list 'quote class)))
- )
+ ',class)))
;; If not the right kind of object, call no applicable
(apply 'no-applicable-method (car local-args)
- ,(list 'quote method) local-args)
+ ',method local-args)
;; It is ok, do the call.
;; Fill in inter-call variables then evaluate the method.
- (let ((scoped-class ,(list 'quote class))
+ (let ((scoped-class ',class)
(eieio-generic-call-next-method-list nil)
(eieio-generic-call-key method-primary)
- (eieio-generic-call-methodname ,(list 'quote method))
+ (eieio-generic-call-methodname ',method)
(eieio-generic-call-arglst local-args)
)
- (apply ,(list 'quote impl) local-args)
- ;(,impl local-args)
- ))))
- )
- ))
+ (apply #',impl local-args)
+ ;;(,impl local-args)
+ )))))))
(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method)
"Setup METHOD to call the generic form."
(cdr entry)
))))
-(defun eieio-defgeneric (method doc-string)
- "Engine part to `defgeneric' macro defining METHOD with DOC-STRING."
- (if (and (fboundp method) (not (generic-p method))
- (or (byte-code-function-p (symbol-function method))
- (not (eq 'autoload (car (symbol-function method)))))
- )
- (error "You cannot create a generic/method over an existing symbol: %s"
- method))
- ;; Don't do this over and over.
- (unless (fboundp 'method)
- ;; This defun tells emacs where the first definition of this
- ;; method is defined.
- `(defun ,method nil)
- ;; Make sure the method tables are installed.
- (eieiomt-install method)
- ;; Apply the actual body of this function.
- (fset method (eieio-defgeneric-form method doc-string))
- ;; Return the method
- '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:
((typearg class-name) arg2 &optional opt &rest rest)
\"doc-string\"
body)"
- `(eieio-defmethod (quote ,method) (quote ,args)))
-
-(defun eieio-defmethod (method args)
+ (let* ((key (if (keywordp (car args)) (pop args)))
+ (params (car args))
+ (arg1 (car params))
+ (fargs (if (consp arg1)
+ (cons (car arg1) (cdr params))
+ params))
+ (class (if (consp arg1) (nth 1 arg1)))
+ (code `(lambda ,fargs ,@(cdr args))))
+ `(progn
+ ;; Make sure there is a generic and the byte-compiler sees it.
+ (defgeneric ,method ,args
+ ,(or (documentation code)
+ (format "Generically created method `%s'." method)))
+ (eieio--defmethod ',method ',key ',class #',code))))
+
+(defun eieio--defmethod (method kind argclass code)
"Work part of the `defmethod' macro defining METHOD with ARGS."
- (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
+ (let ((key
;; find optional keys
- (setq key
- (cond ((or (eq ':BEFORE (car args))
- (eq ':before (car args)))
- (setq args (cdr args))
+ (cond ((or (eq ':BEFORE kind)
+ (eq ':before kind))
method-before)
- ((or (eq ':AFTER (car args))
- (eq ':after (car args)))
- (setq args (cdr args))
+ ((or (eq ':AFTER kind)
+ (eq ':after kind))
method-after)
- ((or (eq ':PRIMARY (car args))
- (eq ':primary (car args)))
- (setq args (cdr args))
+ ((or (eq ':PRIMARY kind)
+ (eq ':primary kind))
method-primary)
- ((or (eq ':STATIC (car args))
- (eq ':static (car args)))
- (setq args (cdr args))
+ ((or (eq ':STATIC kind)
+ (eq ':static kind))
method-static)
;; Primary key
- (t method-primary)))
- ;; get body, and fix contents of args to be the arguments of the fn.
- (setq body (cdr args)
- args (car args))
- (setq loopa args)
- ;; Create a fixed version of the arguments
- (while loopa
- (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa))
- argfix))
- (setq loopa (cdr loopa)))
- ;; make sure there is a generic
- (eieio-defgeneric
- method
- (if (stringp (car body))
- (car body) (format "Generically created method `%s'" method)))
+ (t method-primary))))
+ ;; Make sure there is a generic (when called from defclass).
+ (eieio--defalias
+ method (eieio--defgeneric-init-form
+ method (or (documentation code)
+ (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
;; under the type `primary' which is a non-specific calling of the
;; function.
- (setq firstarg (car args))
- (if (listp firstarg)
- (progn
- (setq argclass (nth 1 firstarg))
+ (if argclass
(if (not (class-p argclass))
(error "Unknown class type %s in method parameters"
- (nth 1 firstarg))))
+ argclass))
(if (= key -1)
(signal 'wrong-type-argument (list :static 'non-class-arg)))
;; generics are higher
- (setq key (+ key 3)))
+ (setq key (eieio-specialized-key-to-generic-key key)))
;; Put this lambda into the symbol so we can find it
- (if (byte-code-function-p (car-safe body))
- (eieiomt-add method (car-safe body) key argclass)
- (eieiomt-add method (append (list 'lambda (reverse argfix)) body)
- key argclass))
+ (eieiomt-add method code key argclass)
)
(when eieio-optimize-primary-methods-flag
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)
(slot-unbound instance (object-class instance) slotname fn)
value))
-;;; Missing types that are useful to me.
-;;
-(defun boolean-p (bool)
- "Return non-nil if BOOL is nil or t."
- (or (null bool) (eq bool t)))
-
;;; Get/Set slots in an object.
;;
(defmacro oref (obj slot)
(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-default-eval-maybe val))
obj cl 'oref-default))))
+(defsubst eieio-eval-default-p (val)
+ "Whether the default value VAL should be evaluated for use."
+ (and (consp val) (symbolp (car val)) (fboundp (car val))))
+
(defun eieio-default-eval-maybe (val)
"Check VAL, and return what `oref-default' would provide."
- ;; check for quoted things, and unquote them
- (if (and (listp val) (eq (car val) 'quote))
- (car (cdr val))
- ;; return it verbatim
- val))
+ (cond
+ ;; Is it a function call? If so, evaluate it.
+ ((eieio-eval-default-p val)
+ (eval val))
+ ;;;; check for quoted things, and unquote them
+ ;;((and (consp val) (eq (car val) 'quote))
+ ;; (car (cdr val)))
+ ;; return it verbatim
+ (t val)))
;;; Object Set macros
;;
`(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)))
(class-children-fast class))
+(defun eieio-c3-candidate (class remaining-inputs)
+ "Returns CLASS if it can go in the result now, otherwise nil"
+ ;; Ensure CLASS is not in any position but the first in any of the
+ ;; element lists of REMAINING-INPUTS.
+ (and (not (let ((found nil))
+ (while (and remaining-inputs (not found))
+ (setq found (member class (cdr (car remaining-inputs)))
+ remaining-inputs (cdr remaining-inputs)))
+ found))
+ class))
+
+(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs)
+ "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible.
+If a consistent order does not exist, signal an error."
+ (if (let ((tail remaining-inputs)
+ (found nil))
+ (while (and tail (not found))
+ (setq found (car tail) tail (cdr tail)))
+ (not found))
+ ;; If all remaining inputs are empty lists, we are done.
+ (nreverse reversed-partial-result)
+ ;; Otherwise, we try to find the next element of the result. This
+ ;; is achieved by considering the first element of each
+ ;; (non-empty) input list and accepting a candidate if it is
+ ;; consistent with the rests of the input lists.
+ (let* ((found nil)
+ (tail remaining-inputs)
+ (next (progn
+ (while (and tail (not found))
+ (setq found (and (car tail)
+ (eieio-c3-candidate (caar tail)
+ remaining-inputs))
+ tail (cdr tail)))
+ found)))
+ (if next
+ ;; The graph is consistent so far, add NEXT to result and
+ ;; merge input lists, dropping NEXT from their heads where
+ ;; applicable.
+ (eieio-c3-merge-lists
+ (cons next reversed-partial-result)
+ (mapcar (lambda (l) (if (eq (first l) next) (rest l) l))
+ remaining-inputs))
+ ;; The graph is inconsistent, give up
+ (signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
+
+(defun eieio-class-precedence-dfs (class)
+ "Return all parents of CLASS in depth-first order."
+ (let* ((parents (class-parents-fast class))
+ (classes (copy-sequence
+ (apply #'append
+ (list class)
+ (or
+ (mapcar
+ (lambda (parent)
+ (cons parent
+ (eieio-class-precedence-dfs parent)))
+ parents)
+ '((eieio-default-superclass))))))
+ (tail classes))
+ ;; Remove duplicates.
+ (while tail
+ (setcdr tail (delq (car tail) (cdr tail)))
+ (setq tail (cdr tail)))
+ classes))
+
+(defun eieio-class-precedence-bfs (class)
+ "Return all parents of CLASS in breadth-first order."
+ (let ((result)
+ (queue (or (class-parents-fast class)
+ '(eieio-default-superclass))))
+ (while queue
+ (let ((head (pop queue)))
+ (unless (member head result)
+ (push head result)
+ (unless (eq head 'eieio-default-superclass)
+ (setq queue (append queue (or (class-parents-fast head)
+ '(eieio-default-superclass))))))))
+ (cons class (nreverse result)))
+ )
+
+(defun eieio-class-precedence-c3 (class)
+ "Return all parents of CLASS in c3 order."
+ (let ((parents (class-parents-fast class)))
+ (eieio-c3-merge-lists
+ (list class)
+ (append
+ (or
+ (mapcar
+ (lambda (x)
+ (eieio-class-precedence-c3 x))
+ parents)
+ '((eieio-default-superclass)))
+ (list parents))))
+ )
+
+(defun class-precedence-list (class)
+ "Return (transitively closed) list of parents of CLASS.
+The order, in which the parents are returned depends on the
+method invocation orders of the involved classes."
+ (if (or (null class) (eq class 'eieio-default-superclass))
+ nil
+ (case (class-method-invocation-order class)
+ (:depth-first
+ (eieio-class-precedence-dfs class))
+ (:breadth-first
+ (eieio-class-precedence-bfs class))
+ (:c3
+ (eieio-class-precedence-c3 class))))
+ )
+
;; Official CLOS functions.
(defalias 'class-direct-superclasses 'class-parents)
(defalias 'class-direct-subclasses 'class-children)
(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."
;; Skip typechecking while retrieving this value.
(let ((eieio-skip-typecheck t))
;; Return nil if the magic symbol is in there.
- (if (eieio-object-p object)
- (if (eq (eieio-oref object slot) eieio-unbound) nil t)
- (if (class-p object)
- (if (eq (eieio-oref-default object slot) eieio-unbound) nil t)
- (signal 'wrong-type-argument (list 'eieio-object-p object))))))
+ (not (eq (cond
+ ((eieio-object-p object) (eieio-oref object slot))
+ ((class-p object) (eieio-oref-default object slot))
+ (t (signal 'wrong-type-argument (list 'eieio-object-p object))))
+ eieio-unbound))))
(defun slot-makeunbound (object slot)
"In OBJECT, make SLOT unbound."
(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)
keys (append (make-list (length tlambdas) method-before) keys))
)
- ;; If there were no methods found, then there could be :static methods.
- (when (not lambdas)
+ (if mclass
+ ;; For the case of a class,
+ ;; if there were no methods found, then there could be :static methods.
+ (when (not lambdas)
+ (setq tlambdas
+ (eieio-generic-form method method-static mclass))
+ (setq lambdas (cons tlambdas lambdas)
+ keys (cons method-static keys)
+ primarymethodlist ;; Re-use even with bad name here
+ (eieiomt-method-list method method-static mclass)))
+ ;; For the case of no class (ie - mclass == nil) then there may
+ ;; be a primary method.
(setq tlambdas
- (eieio-generic-form method method-static mclass))
- (setq lambdas (cons tlambdas lambdas)
- keys (cons method-static keys)
- primarymethodlist ;; Re-use even with bad name here
- (eieiomt-method-list method method-static mclass)))
+ (eieio-generic-form method method-primary nil))
+ (when tlambdas
+ (setq lambdas (cons tlambdas lambdas)
+ keys (cons method-primary keys)
+ primarymethodlist
+ (eieiomt-method-list method method-primary nil)))
+ )
(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))
If CLASS is nil, then an empty list of methods should be returned."
;; Note: eieiomt - the MT means MethodTree. See more comments below
;; for the rest of the eieiomt methods.
- (let ((lambdas nil)
- (mclass (list class)))
- (while mclass
- ;; Note: a nil can show up in the class list once we start
- ;; searching through the method tree.
- (when (car mclass)
- ;; lookup the form to use for the PRIMARY object for the next level
- (let ((tmpl (eieio-generic-form method key (car mclass))))
- (when (or (not lambdas)
- ;; This prevents duplicates coming out of the
- ;; class method optimizer. Perhaps we should
- ;; just not optimize before/afters?
- (not (eq (car tmpl) (car (car lambdas)))))
- (setq lambdas (cons tmpl lambdas))
- (if (null (car lambdas))
- (setq lambdas (cdr lambdas))))))
- ;; Add new classes to mclass. Since our input might not be a class
- ;; protect against that.
- (if (car mclass)
- ;; If there is a class, append any methods it may provide
- ;; to the remainder of the class list.
- (let ((io (class-method-invocation-order (car mclass))))
- (if (eq io :depth-first)
- ;; Depth first.
- (setq mclass (append (eieiomt-next (car mclass)) (cdr mclass)))
- ;; Breadth first.
- (setq mclass (append (cdr mclass) (eieiomt-next (car mclass)))))
- )
- ;; Advance to next entry in mclass if it is nil.
- (setq mclass (cdr mclass)))
- )
+
+ ;; Collect lambda expressions stored for the class and its parent
+ ;; classes.
+ (let (lambdas)
+ (dolist (ancestor (class-precedence-list class))
+ ;; Lookup the form to use for the PRIMARY object for the next level
+ (let ((tmpl (eieio-generic-form method key ancestor)))
+ (when (and tmpl
+ (or (not lambdas)
+ ;; This prevents duplicates coming out of the
+ ;; class method optimizer. Perhaps we should
+ ;; just not optimize before/afters?
+ (not (member tmpl lambdas))))
+ (push tmpl lambdas))))
+
+ ;; Return collected lambda. For :after methods, return in current
+ ;; order (most general class last); Otherwise, reverse order.
(if (eq key method-after)
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")
(apply 'no-next-method (car newargs) (cdr newargs))
(let* ((eieio-generic-call-next-method-list
(cdr eieio-generic-call-next-method-list))
+ (eieio-generic-call-arglst newargs)
(scoped-class (cdr next))
(fcn (car next))
)
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)
(defun eieiomt-sym-optimize (s)
"Find the next class above S which has a function body for the optimizer."
- ;; (message "Optimizing %S" s)
- (let* ((es (intern-soft (symbol-name s))) ;external symbol of class
- (io (class-method-invocation-order es))
- (ov nil)
- (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.
- ;; 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))
- (if (fboundp ov)
- (progn
- (set s ov) ;store ov as our next symbol
- (setq cont nil))
- (if (eq io :depth-first)
- ;; Pre-pend the subclasses of (car es) so we get
- ;; DEPTH FIRST optimization.
- (setq es (append (eieiomt-next (car es)) (cdr es)))
- ;; Else, we are breadth first.
- ;; (message "Class %s is breadth first" es)
- (setq es (append (cdr es) (eieiomt-next (car es))))
- )))
- ;; If there is no nearest call, then set our value to nil
- (if (not es) (set s nil))
- ))
+ ;; Set the value to nil in case there is no nearest cell.
+ (set s nil)
+ ;; Find the nearest cell that has a function body. If we find one,
+ ;; we replace the nil from above.
+ (let ((external-symbol (intern-soft (symbol-name s))))
+ (catch 'done
+ (dolist (ancestor (rest (class-precedence-list external-symbol)))
+ (let ((ov (intern-soft (symbol-name ancestor)
+ eieiomt-optimizing-obarray)))
+ (when (fboundp ov)
+ (set s ov) ;; store ov as our next symbol
+ (throw 'done ancestor)))))))
(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 key (eieio-specialized-key-to-generic-key key)))))
(if (class-p class)
;; 1) find our symbol
(let ((cs (intern-soft (symbol-name class) emto)))
;; 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
nil)))
;; for a generic call, what is a list, is the function body we want.
(let ((emtl (aref (get method 'eieio-method-tree)
- (if class key (+ key 3)))))
+ (if class key (eieio-specialized-key-to-generic-key key)))))
(if emtl
;; The car of EMTL is supposed to be a class, which in this
;; case is nil, so skip it.
(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)
(put 'unbound-slot 'error-conditions '(unbound-slot error nil))
(put 'unbound-slot 'error-message "Unbound slot")
+(intern "inconsistent-class-hierarchy")
+(put 'inconsistent-class-hierarchy 'error-conditions
+ '(inconsistent-class-hierarchy error nil))
+(put 'inconsistent-class-hierarchy 'error-message "Inconsistent class hierarchy")
+
;;; Here are some CLOS items that need the CL package
;;
;; 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.
(slot (aref scoped-class class-public-a))
(defaults (aref scoped-class class-public-d)))
(while slot
+ ;; For each slot, see if we need to evaluate it.
+ ;;
+ ;; Paul Landes said in an email:
+ ;; > CL evaluates it if it can, and otherwise, leaves it as
+ ;; > the quoted thing as you already have. This is by the
+ ;; > Sonya E. Keene book and other things I've look at on the
+ ;; > web.
+ (let ((dflt (eieio-default-eval-maybe (car defaults))))
+ (when (not (eq dflt (car defaults)))
+ (eieio-oset this (car slot) dflt) ))
+ ;; Next.
(setq slot (cdr slot)
defaults (cdr defaults))))
;; Shared initialize will parse our slots for us.
&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-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)
+\f
+;;; Start of automatically extracted autoloads.
+\f
+;;;### (autoloads (customize-object) "eieio-custom" "eieio-custom.el"
+;;;;;; "cf1bd64c76a6e6406545e8c5a5530d43")
+;;; Generated autoloads from eieio-custom.el
-(autoload 'customize-object "eieio-custom" "Create a custom buffer editing OBJ.")
+(autoload 'customize-object "eieio-custom" "\
+Customize OBJ in a custom buffer.
+Optional argument GROUP is the sub-group of slots to display.
-(provide 'eieio)
+\(fn OBJ &optional GROUP)" nil nil)
-;; Local variables:
-;; byte-compile-warnings: (not cl-functions)
-;; End:
+;;;***
+\f
+;;;### (autoloads (eieio-help-mode-augmentation-maybee eieio-describe-generic
+;;;;;; eieio-describe-constructor eieio-describe-class eieio-browse)
+;;;;;; "eieio-opt" "eieio-opt.el" "1bed0a56310f402683419139ebc18d7f")
+;;; Generated autoloads from eieio-opt.el
+
+(autoload 'eieio-browse "eieio-opt" "\
+Create an object browser window to show all objects.
+If optional ROOT-CLASS, then start with that, otherwise start with
+variable `eieio-default-superclass'.
+
+\(fn &optional ROOT-CLASS)" t nil)
+
+(defalias 'describe-class 'eieio-describe-class)
+
+(autoload 'eieio-describe-class "eieio-opt" "\
+Describe a CLASS defined by a string or symbol.
+If CLASS is actually an object, then also display current values of that object.
+Optional HEADERFCN should be called to insert a few bits of info first.
+
+\(fn CLASS &optional HEADERFCN)" t nil)
+
+(autoload 'eieio-describe-constructor "eieio-opt" "\
+Describe the constructor function FCN.
+Uses `eieio-describe-class' to describe the class being constructed.
+
+\(fn FCN)" t nil)
+
+(defalias 'describe-generic 'eieio-describe-generic)
+
+(autoload 'eieio-describe-generic "eieio-opt" "\
+Describe the generic function GENERIC.
+Also extracts information about all methods specific to this generic.
+
+\(fn GENERIC)" t nil)
+
+(autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "\
+For buffers thrown into help mode, augment for EIEIO.
+Arguments UNUSED are not used.
+
+\(fn &rest UNUSED)" nil nil)
+
+;;;***
+\f
+;;; End of automatically extracted autoloads.
+
+(provide 'eieio)
;;; eieio ends here
HCoop / bpt / emacs.git / blobdiff