;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects
-;;; or maybe Eric's Implementation of Emacs Intrepreted Objects
+;;; or maybe Eric's Implementation of Emacs Interpreted Objects
-;; Copyright (C) 1995-1996, 1998-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 1998-2012 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Version: 1.3
;; Keywords: OO, lisp
;; This file is part of GNU Emacs.
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib!
(defvar eieio-version "1.3"
"Current version of EIEIO.")
(eval-and-compile
;; About the above. EIEIO must process its own code when it compiles
-;; itself, thus, by eval-and-compiling outselves, we solve the problem.
+;; itself, thus, by eval-and-compiling ourselves, we solve the problem.
;; Compatibility
(if (fboundp 'compiled-function-arglist)
;;
(defvar eieio-hook nil
- "*This hook is executed, then cleared each time `defclass' is called.")
+ "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 is unsupported.
since EIEIO does not support all CLOS tags.")
(defvar eieio-skip-typecheck nil
- "*If non-nil, skip all slot typechecking.
+ "If non-nil, skip all slot typechecking.
Set this to t permanently if a program is functioning well to get a
small speed increase. This variable is also used internally to handle
default setting for optimization purposes.")
(defvar eieio-optimize-primary-methods-flag t
"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'.")
-
-(defvar scoped-class nil
- "This is set to a class when a method is running.
-This is so we know we are allowed to check private parts or how to
-execute a `call-next-method'. DO NOT SET THIS YOURSELF!")
-
(defvar eieio-initializing-object nil
"Set to non-nil while initializing an object.")
(aset newc class-parent (cons SC (aref newc class-parent)))
)
- ;; turn this into a useable self-pointing symbol
+ ;; turn this into a usable self-pointing symbol
(set cname cname)
;; Store the new class vector definition into the symbol. We need to
(autoload cname filename doc nil nil)
(autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil)
(autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil)
+ (autoload (intern (concat (symbol-name cname) "-list-p")) filename "" nil nil)
))))
(run-hooks 'eieio-hook)
(setq eieio-hook nil)
- (if (not (symbolp cname)) (signal 'wrong-type-argument '(symbolp cname)))
- (if (not (listp superclasses)) (signal 'wrong-type-argument '(listp superclasses)))
+ (if (not (listp superclasses))
+ (signal 'wrong-type-argument '(listp superclasses)))
- (let* ((pname (if superclasses superclasses nil))
+ (let* ((pname superclasses)
(newc (make-vector class-num-slots nil))
(oldc (when (class-p cname) (class-v cname)))
(groups nil) ;; list of groups id'd from slots
;; save parent in child
(aset newc class-parent (list eieio-default-superclass))))
- ;; turn this into a useable self-pointing symbol
+ ;; turn this into a usable self-pointing symbol
(set cname cname)
;; These two tests must be created right away so we can have self-
(and (eieio-object-p obj)
(object-of-class-p obj ,cname))))
+ ;; Create a handy list of the class test too
+ (let ((csym (intern (concat (symbol-name cname) "-list-p"))))
+ (fset csym
+ `(lambda (obj)
+ ,(format
+ "Test OBJ to see if it a list of objects which are a child of type %s"
+ cname)
+ (when (listp obj)
+ (let ((ans t)) ;; nil is valid
+ ;; Loop over all the elements of the input list, test
+ ;; each to make sure it is a child of the desired object class.
+ (while (and obj ans)
+ (setq ans (and (eieio-object-p (car obj))
+ (object-of-class-p (car obj) ,cname)))
+ (setq obj (cdr obj)))
+ ans)))))
+
;; When using typep, (typep OBJ 'myclass) returns t for objects which
;; are subclasses of myclass. For our predicates, however, it is
;; important for EIEIO to be backwards compatible, where
(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
+ ;; Before adding new slots, let's add all the methods and classes
+ ;; in from the parent class.
(eieio-copy-parents-into-subclass newc superclasses)
;; Store the new class vector definition into the symbol. We need to
;; We need to id the group, and store them in a group list attribute.
(mapc (lambda (cg) (add-to-list 'groups cg)) customg)
- ;; anyone can have an accessor function. This creates a function
+ ;; Anyone can have an accessor function. This creates a function
;; of the specified name, and also performs a `defsetf' if applicable
- ;; so that users can `setf' the space returned by this function
+ ;; so that users can `setf' the space returned by this function.
(if acces
(progn
(eieio--defmethod
;; Else - Some error? nil?
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 (fboundp 'gv-define-setter)
+ ;; FIXME: We should move more of eieio-defclass into the
+ ;; defclass macro so we don't have to use `eval' and require
+ ;; `gv' at run-time.
+ (eval `(gv-define-setter ,acces (eieio--store eieio--object)
+ (list 'eieio-oset eieio--object '',name
+ eieio--store)))
+ ;; 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.
)
(setq slots (cdr slots)))
- ;; Now that everything has been loaded up, all our lists are backwards! Fix that up now.
+ ;; Now that everything has been loaded up, all our lists are backwards!
+ ;; Fix that up now.
(aset newc class-public-a (nreverse (aref newc class-public-a)))
(aset newc class-public-d (nreverse (aref newc class-public-d)))
(aset newc class-public-doc (nreverse (aref newc class-public-doc)))
(put cname 'variable-documentation
(class-option-assoc options :documentation))
+ ;; Save the file location where this class is defined.
+ (let ((fname (if load-in-progress
+ load-file-name
+ buffer-file-name))
+ loc)
+ (when fname
+ (when (string-match "\\.elc$" fname)
+ (setq fname (substring fname 0 (1- (length fname)))))
+ (put cname 'class-location fname)))
+
;; We have a list of custom groups. Store them into the options.
(let ((g (class-option-assoc options :custom-groups)))
(mapc (lambda (cg) (add-to-list 'g cg)) groups)
;; Make sure we duplicate those items that are sequences.
(condition-case nil
(if (sequencep d) (setq d (copy-sequence d)))
- ;; This copy can fail on a cons cell with a non-cons in the cdr. Lets skip it if it doesn't work.
+ ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work.
(error nil))
(if (sequencep type) (setq type (copy-sequence type)))
(if (sequencep cust) (setq cust (copy-sequence cust)))
(progn
(eieio-perform-slot-validation-for-default a type value skipnil)
;; Here we have found a :class version of a slot. This
- ;; requires a very different aproach.
+ ;; requires a very different approach.
(aset newc class-class-allocation-a (cons a (aref newc class-class-allocation-a)))
(aset newc class-class-allocation-doc (cons doc (aref newc class-class-allocation-doc)))
(aset newc class-class-allocation-type (cons type (aref newc class-class-allocation-type)))
;; EML - Note: the only reason to override a class bound slot
;; is to change the default, so allow unbound in.
- ;; If we have a repeat, only update the vlaue...
+ ;; If we have a repeat, only update the value...
(eieio-perform-slot-validation-for-default a tp value skipnil)
(setcar dp value))
(if (not (eieio-object-p (car local-args)))
;; Not an object. Just signal.
(signal 'no-method-definition
- (list ,(list 'quote method) local-args))
+ (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)
+ ,(if (< emacs-major-version 24)
+ `(apply ,(list 'quote impl) local-args)
+ `(apply #',impl local-args))
;(,impl local-args)
)))))))
(defgeneric ,method ,args
,(or (documentation code)
(format "Generically created method `%s'." method)))
- (eieio--defmethod ',method ',key ',class ',code))))
+ (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
- ;; find optional keys
+ ;; find optional keys
(cond ((or (eq ':BEFORE kind)
(eq ':before kind))
- method-before)
+ method-before)
((or (eq ':AFTER kind)
(eq ':after kind))
- method-after)
+ method-after)
((or (eq ':PRIMARY kind)
(eq ':primary kind))
- method-primary)
+ method-primary)
((or (eq ':STATIC kind)
(eq ':static kind))
- method-static)
- ;; Primary key
+ method-static)
+ ;; Primary key
(t method-primary))))
;; Make sure there is a generic (when called from defclass).
(eieio--defalias
;; under the type `primary' which is a non-specific calling of the
;; function.
(if argclass
- (if (not (class-p argclass))
- (error "Unknown class type %s in method parameters"
+ (if (not (class-p argclass))
+ (error "Unknown class type %s in method parameters"
argclass))
(if (= key -1)
(signal 'wrong-type-argument (list :static 'non-class-arg)))
(c (eieio-slot-name-index class obj slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
- ;; Lets check that info out.
+ ;; Let's check that info out.
(if (setq c (eieio-class-slot-name-index class slot))
;; Oref that slot.
(aref (aref (class-v class) class-class-allocation-values) c)
(c (eieio-slot-name-index cl obj slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
- ;; Lets check that info out.
+ ;; Let's check that info out.
(if (setq c
(eieio-class-slot-name-index cl slot))
;; Oref that slot.
(let ((c (eieio-slot-name-index (object-class-fast obj) obj slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
- ;; Lets check that info out.
+ ;; Let's check that info out.
(if (setq c
(eieio-class-slot-name-index (aref obj object-class) slot))
;; Oset that slot.
(c (eieio-slot-name-index class nil slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
- ;; Lets check that info out.
+ ;; Let's check that info out.
(if (setq c (eieio-class-slot-name-index class slot))
(progn
;; Oref that slot.
((not (get fsym 'protection))
(+ 3 fsi))
((and (eq (get fsym 'protection) 'protected)
- scoped-class
+ (bound-and-true-p scoped-class)
(or (child-of-class-p class scoped-class)
(and (eieio-object-p obj)
(child-of-class-p class (object-class obj)))))
(+ 3 fsi))
((and (eq (get fsym 'protection) 'private)
- (or (and scoped-class
+ (or (and (bound-and-true-p scoped-class)
(eieio-slot-originating-class-p scoped-class slot))
eieio-initializing-object))
(+ 3 fsi))
is called, the next method is popped off the stack.")
(defvar eieio-pre-method-execution-hooks nil
- "*Hooks run just before a method is executed.
+ "Abnormal hook run just before an EIEIO method is executed.
The hook function must accept one argument, the list of forms
about to be executed.")
arguments passed in at the top level.
Use `next-method-p' to find out if there is a next method to call."
- (if (not scoped-class)
+ (if (not (bound-and-true-p scoped-class))
(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))
(if (< key method-num-lists)
(let ((nsym (intern (symbol-name class) (aref emto key))))
(fset nsym method)))
+ ;; Save the defmethod file location in a symbol property.
+ (let ((fname (if load-in-progress
+ load-file-name
+ buffer-file-name))
+ loc)
+ (when fname
+ (when (string-match "\\.elc$" fname)
+ (setq fname (substring fname 0 (1- (length fname)))))
+ (setq loc (get method-name 'method-locations))
+ (add-to-list 'loc
+ (list class fname))
+ (put method-name 'method-locations loc)))
;; Now optimize the entire obarray
(if (< key method-num-lists)
(let ((eieiomt-optimizing-obarray (aref emto key)))
;;; Here are some CLOS items that need the CL package
;;
-(defsetf slot-value (obj slot) (store) (list 'eieio-oset obj slot store))
-(defsetf eieio-oref (obj slot) (store) (list 'eieio-oset obj slot store))
+(defsetf eieio-oref eieio-oset)
+
+(if (eval-when-compile (fboundp 'gv-define-expander))
+ ;; Not needed for Emacs>=24.3 since gv.el's setf expands macros and
+ ;; follows aliases.
+ nil
+(defsetf slot-value eieio-oset)
;; The below setf method was written by Arnd Kohrs <kohrs@acm.org>
(define-setf-method oref (obj slot)
(list store-temp)
(list 'set-slot-value obj-temp slot-temp
store-temp)
- (list 'slot-value obj-temp slot-temp)))))
+ (list 'slot-value obj-temp slot-temp))))))
\f
;;;
;; We want all objects created by EIEIO to have some default set of
-;; behaviours so we can create object utilities, and allow various
+;; behaviors so we can create object utilities, and allow various
;; types of error checking. To do this, create the default EIEIO
;; class, and when no parent class is specified, use this as the
;; default. (But don't store it in the other classes as the default,
(princ (make-string (* eieio-print-depth 2) ? ))
(princ "(")
(princ (symbol-name (class-constructor (object-class this))))
- (princ " \"")
- (princ (object-name-string this))
- (princ "\"\n")
+ (princ " ")
+ (prin1 (object-name-string this))
+ (princ "\n")
;; Loop over all the public slots
(let ((publa (aref cv class-public-a))
(publd (aref cv class-public-d))
)
-\f
+;;; Obsolete backward compatibility functions.
+;; Needed to run byte-code compiled with the EIEIO of Emacs-23.
+
+(defun eieio-defmethod (method args)
+ "Obsolete work part of an old version of the `defmethod' macro."
+ (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
+ ;; find optional keys
+ (setq key
+ (cond ((or (eq ':BEFORE (car args))
+ (eq ':before (car args)))
+ (setq args (cdr args))
+ method-before)
+ ((or (eq ':AFTER (car args))
+ (eq ':after (car args)))
+ (setq args (cdr args))
+ method-after)
+ ((or (eq ':PRIMARY (car args))
+ (eq ':primary (car args)))
+ (setq args (cdr args))
+ method-primary)
+ ((or (eq ':STATIC (car args))
+ (eq ':static (car args)))
+ (setq args (cdr args))
+ 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)))
+ ;; 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 (not (class-p argclass))
+ (error "Unknown class type %s in method parameters"
+ (nth 1 firstarg))))
+ (if (= key -1)
+ (signal 'wrong-type-argument (list :static 'non-class-arg)))
+ ;; generics are higher
+ (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))
+ )
+
+ (when eieio-optimize-primary-methods-flag
+ ;; Optimizing step:
+ ;;
+ ;; If this method, after this setup, only has primary methods, then
+ ;; we can setup the generic that way.
+ (if (generic-primary-only-p method)
+ ;; If there is only one primary method, then we can go one more
+ ;; optimization step.
+ (if (generic-primary-only-one-p method)
+ (eieio-defgeneric-reset-generic-form-primary-only-one method)
+ (eieio-defgeneric-reset-generic-form-primary-only method))
+ (eieio-defgeneric-reset-generic-form method)))
+
+ method)
+(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1")
+
+(defun eieio-defgeneric (method doc-string)
+ "Obsolete work part of an old version of the `defgeneric' macro."
+ (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))
+(make-obsolete 'eieio-defgeneric nil "24.1")
+
;;; Interfacing with edebug
;;
(defun eieio-edebug-prin1-to-string (object &optional noescape)
;;; Start of automatically extracted autoloads.
\f
;;;### (autoloads (customize-object) "eieio-custom" "eieio-custom.el"
-;;;;;; "cf1bd64c76a6e6406545e8c5a5530d43")
+;;;;;; "928623502e8bf40454822355388542b5")
;;; Generated autoloads from eieio-custom.el
(autoload 'customize-object "eieio-custom" "\
\f
;;;### (autoloads (eieio-help-mode-augmentation-maybee eieio-describe-generic
;;;;;; eieio-describe-constructor eieio-describe-class eieio-browse)
-;;;;;; "eieio-opt" "eieio-opt.el" "1bed0a56310f402683419139ebc18d7f")
+;;;;;; "eieio-opt" "eieio-opt.el" "d808328f9c0156ecbd412d77ba8c569e")
;;; Generated autoloads from eieio-opt.el
(autoload 'eieio-browse "eieio-opt" "\
variable `eieio-default-superclass'.
\(fn &optional ROOT-CLASS)" t nil)
-
(defalias 'describe-class 'eieio-describe-class)
(autoload 'eieio-describe-class "eieio-opt" "\
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" "\
HCoop / bpt / emacs.git / blobdiff