mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 18:40:39 -08:00
Code Issues Projects Releases Wiki Activity

* lisp/emacs-lisp/eieio*.el: Use hashtables rather than obarrays

Browse source 
* lisp/emacs-lisp/eieio-core.el (class): Rename field symbol-obarray to
symbol-hashtable.  It contains a hashtable instead of an obarray.
(generic-p): Use symbol property `eieio-method-hashtable' instead of
`eieio-method-obarray'.
(generic-primary-only-p, generic-primary-only-one-p):
Slight optimization.
(eieio-defclass-autoload-map): Use a hashtable instead of an obarray.
(eieio-defclass-autoload, eieio-defclass): Adjust/simplify accordingly.
(eieio-class-un-autoload): Use autoload-do-load.
(eieio-defclass): Use dolist, cl-pushnew, cl-callf.
Use new cl-deftype-satisfies.  Adjust to use of hashtables.
Don't hardcode the value of eieio--object-num-slots.
(eieio-defgeneric-form-primary-only-one): Remove `doc-string' arg.
Use a closure rather than a backquoted lambda.
(eieio--defmethod): Adjust call accordingly.  Set doc-string via the
function-documentation property.
(eieio-slot-originating-class-p, eieio-slot-name-index)
(eieiomt--optimizing-hashtable, eieiomt-install, eieiomt-add)
(eieio-generic-form): Adjust to use of hashtables.
(eieiomt--sym-optimize): Rename from eieiomt-sym-optimize; take
additional class argument.
(eieio-generic-call-methodname): Remove, unused.

* lisp/emacs-lisp/eieio-custom.el: Use lexical-binding.
(eieio-object-value-to-abstract): Simplify.

* lisp/emacs-lisp/eieio-datadebug.el: Use lexical-binding.

* lisp/emacs-lisp/eieio-opt.el (eieio-build-class-list): Use cl-mapcan.
(eieio-build-class-alist): Use dolist.
(eieio-all-generic-functions): Adjust to use of hashtables.

* lisp/emacs-lisp/eieio.el (child-of-class-p): Fix case where `class' is
`eieio-default-superclass'.

* test/automated/eieio-test-methodinvoke.el (eieio-test-method-store):
Remove use of eieio-generic-call-methodname.
(eieio-test-method-order-list-3, eieio-test-method-order-list-6)
(eieio-test-method-order-list-7, eieio-test-method-order-list-8):
Adjust the expected result accordingly.

* lisp/emacs-lisp/eieio-base.el (eieio-persistent-slot-type-is-class-p):
Prefer \' to $.
This commit is contained in:
Stefan Monnier 2014-12-22 15:13:02 -05:00
parent b11d8924b5
commit bcebc831bb
9 changed files with 365 additions and 383 deletions
Download patch file Download diff file Expand all files Collapse all files

48
lisp/ChangeLog
View file

@ -1,3 +1,43 @@
2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio.el (child-of-class-p): Fix case where `class' is
`eieio-default-superclass'.
* emacs-lisp/eieio-datadebug.el: Use lexical-binding.
* emacs-lisp/eieio-custom.el: Use lexical-binding.
(eieio-object-value-to-abstract): Simplify.
* emacs-lisp/eieio-opt.el (eieio-build-class-list): Use cl-mapcan.
(eieio-build-class-alist): Use dolist.
(eieio-all-generic-functions): Adjust to use of hashtables.
* emacs-lisp/eieio-core.el (class): Rename field symbol-obarray to
symbol-hashtable. It contains a hashtable instead of an obarray.
(generic-p): Use symbol property `eieio-method-hashtable' instead of
`eieio-method-obarray'.
(generic-primary-only-p, generic-primary-only-one-p):
Slight optimization.
(eieio-defclass-autoload-map): Use a hashtable instead of an obarray.
(eieio-defclass-autoload, eieio-defclass): Adjust/simplify accordingly.
(eieio-class-un-autoload): Use autoload-do-load.
(eieio-defclass): Use dolist, cl-pushnew, cl-callf.
Use new cl-deftype-satisfies. Adjust to use of hashtables.
Don't hardcode the value of eieio--object-num-slots.
(eieio-defgeneric-form-primary-only-one): Remove `doc-string' arg.
Use a closure rather than a backquoted lambda.
(eieio--defmethod): Adjust call accordingly. Set doc-string via the
function-documentation property.
(eieio-slot-originating-class-p, eieio-slot-name-index)
(eieiomt--optimizing-hashtable, eieiomt-install, eieiomt-add)
(eieio-generic-form): Adjust to use of hashtables.
(eieiomt--sym-optimize): Rename from eieiomt-sym-optimize; take
additional class argument.
(eieio-generic-call-methodname): Remove, unused.
* emacs-lisp/eieio-base.el (eieio-persistent-slot-type-is-class-p):
Prefer \' to $.
2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca> 2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca>
* completion.el: Use post-self-insert-hook (bug#19400). * completion.el: Use post-self-insert-hook (bug#19400).
@ -95,8 +135,8 @@
* electric.el (Electric-pop-up-window): * electric.el (Electric-pop-up-window):
* help.el (resize-temp-buffer-window): Call fit-window-to-buffer * help.el (resize-temp-buffer-window): Call fit-window-to-buffer
with `preserve-size' t. with `preserve-size' t.
* minibuffer.el (minibuffer-completion-help): Use * minibuffer.el (minibuffer-completion-help):
`resize-temp-buffer-window' instead of `fit-window-to-buffer' Use `resize-temp-buffer-window' instead of `fit-window-to-buffer'
(Bug#19355). Preserve size of completions window. (Bug#19355). Preserve size of completions window.
* register.el (register-preview): Preserve size of register * register.el (register-preview): Preserve size of register
preview window. preview window.
@ -106,8 +146,8 @@
`window-preserve-size'. `window-preserve-size'.
(window-min-pixel-size, window--preservable-size) (window-min-pixel-size, window--preservable-size)
(window-preserve-size, window-preserved-size) (window-preserve-size, window-preserved-size)
(window--preserve-size, window--min-size-ignore-p): New (window--preserve-size, window--min-size-ignore-p):
functions. New functions.
(window-min-size, window-min-delta, window--resizable) (window-min-size, window-min-delta, window--resizable)
(window--resize-this-window, split-window-below) (window--resize-this-window, split-window-below)
(split-window-right): Amend doc-string. (split-window-right): Amend doc-string.

10
lisp/emacs-lisp/eieio-base.el
View file

@ -375,13 +375,13 @@ Second, any text properties will be stripped from strings."
) )
(defun eieio-persistent-slot-type-is-class-p (type) (defun eieio-persistent-slot-type-is-class-p (type)
"Return the class refered to in TYPE. "Return the class referred to in TYPE.
If no class is referenced there, then return nil." If no class is referenced there, then return nil."
(cond ((class-p type) (cond ((class-p type)
;; If the type is a class, then return it. ;; If the type is a class, then return it.
type) type)
;; FIXME: foo-child should not be a valid type!
((and (symbolp type) (string-match "-child$" (symbol-name type)) ((and (symbolp type) (string-match "-child\\'" (symbol-name type))
(class-p (intern-soft (substring (symbol-name type) 0 (class-p (intern-soft (substring (symbol-name type) 0
(match-beginning 0))))) (match-beginning 0)))))
;; If it is the predicate ending with -child, then return ;; If it is the predicate ending with -child, then return
@ -389,8 +389,8 @@ If no class is referenced there, then return nil."
;; class is the same as if we used -child, so no further work needed. ;; class is the same as if we used -child, so no further work needed.
(intern-soft (substring (symbol-name type) 0 (intern-soft (substring (symbol-name type) 0
(match-beginning 0)))) (match-beginning 0))))
;; FIXME: foo-list should not be a valid type!
((and (symbolp type) (string-match "-list$" (symbol-name type)) ((and (symbolp type) (string-match "-list\\'" (symbol-name type))
(class-p (intern-soft (substring (symbol-name type) 0 (class-p (intern-soft (substring (symbol-name type) 0
(match-beginning 0))))) (match-beginning 0)))))
;; If it is the predicate ending with -list, then return ;; If it is the predicate ending with -list, then return

418
lisp/emacs-lisp/eieio-core.el
View file

@ -132,10 +132,10 @@ default setting for optimization purposes.")
(defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index)))) (defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index))))
(eieio--define-field-accessors class (eieio--define-field-accessors class
(-unused-0 ;;FIXME: not sure, but at least there was no accessor! (-unused-0 ;;Constant slot, set to `defclass'.
(symbol "symbol (self-referencing)") (symbol "symbol (self-referencing)")
parent children parent children
(symbol-obarray "obarray permitting fast access to variable position indexes") (symbol-hashtable "hashtable permitting fast access to variable position indexes")
;; @todo ;; @todo
;; the word "public" here is leftovers from the very first version. ;; the word "public" here is leftovers from the very first version.
;; Get rid of it! ;; Get rid of it!
@ -166,9 +166,9 @@ from the default.")
Stored outright without modifications or stripping."))) Stored outright without modifications or stripping.")))
(eieio--define-field-accessors object (eieio--define-field-accessors object
(-unused-0 ;;FIXME: not sure, but at least there was no accessor! (-unused-0 ;;Constant slot, set to `object'.
(class "class struct defining OBJ") (class "class struct defining OBJ")
name)) name)) ;FIXME: Get rid of this field!
;; FIXME: The constants below should have an `eieio-' prefix added!! ;; FIXME: The constants below should have an `eieio-' prefix added!!
@ -239,41 +239,41 @@ CLASS is a symbol."
(defsubst generic-p (method) (defsubst generic-p (method)
"Return non-nil if symbol METHOD is a generic function. "Return non-nil if symbol METHOD is a generic function.
Only methods have the symbol `eieio-method-obarray' as a property Only methods have the symbol `eieio-method-hashtable' as a property
\(which contains a list of all bindings to that method type.)" \(which contains a list of all bindings to that method type.)"
(and (fboundp method) (get method 'eieio-method-obarray))) (and (fboundp method) (get method 'eieio-method-hashtable)))
(defun generic-primary-only-p (method) (defun generic-primary-only-p (method)
"Return t if symbol METHOD is a generic function with only primary methods. "Return t if symbol METHOD is a generic function with only primary methods.
Only methods have the symbol `eieio-method-obarray' as a property (which Only methods have the symbol `eieio-method-hashtable' as a property (which
contains a list of all bindings to that method type.) contains a list of all bindings to that method type.)
Methods with only primary implementations are executed in an optimized way." Methods with only primary implementations are executed in an optimized way."
(and (generic-p method) (and (generic-p method)
(let ((M (get method 'eieio-method-tree))) (let ((M (get method 'eieio-method-tree)))
(and (< 0 (length (aref M method-primary))) (not (or (>= 0 (length (aref M method-primary)))
(not (aref M method-static)) (aref M method-static)
(not (aref M method-before)) (aref M method-before)
(not (aref M method-after)) (aref M method-after)
(not (aref M method-generic-before)) (aref M method-generic-before)
(not (aref M method-generic-primary)) (aref M method-generic-primary)
(not (aref M method-generic-after)))) (aref M method-generic-after)))
)) )))
(defun generic-primary-only-one-p (method) (defun generic-primary-only-one-p (method)
"Return t if symbol METHOD is a generic function with only primary methods. "Return t if symbol METHOD is a generic function with only primary methods.
Only methods have the symbol `eieio-method-obarray' as a property (which Only methods have the symbol `eieio-method-hashtable' as a property (which
contains a list of all bindings to that method type.) contains a list of all bindings to that method type.)
Methods with only primary implementations are executed in an optimized way." Methods with only primary implementations are executed in an optimized way."
(and (generic-p method) (and (generic-p method)
(let ((M (get method 'eieio-method-tree))) (let ((M (get method 'eieio-method-tree)))
(and (= 1 (length (aref M method-primary))) (not (or (/= 1 (length (aref M method-primary)))
(not (aref M method-static)) (aref M method-static)
(not (aref M method-before)) (aref M method-before)
(not (aref M method-after)) (aref M method-after)
(not (aref M method-generic-before)) (aref M method-generic-before)
(not (aref M method-generic-primary)) (aref M method-generic-primary)
(not (aref M method-generic-after)))) (aref M method-generic-after)))
)) )))
(defmacro class-option-assoc (list option) (defmacro class-option-assoc (list option)
"Return from LIST the found OPTION, or nil if it doesn't exist." "Return from LIST the found OPTION, or nil if it doesn't exist."
@ -308,7 +308,7 @@ Abstract classes cannot be instantiated."
;;; ;;;
;; Class Creation ;; Class Creation
(defvar eieio-defclass-autoload-map (make-vector 7 nil) (defvar eieio-defclass-autoload-map (make-hash-table)
"Symbol map of superclasses we find in autoloads.") "Symbol map of superclasses we find in autoloads.")
;; We autoload this because it's used in `make-autoload'. ;; We autoload this because it's used in `make-autoload'.
@ -348,25 +348,14 @@ It creates an autoload function for CNAME's constructor."
;; map needs to be cleared! ;; map needs to be cleared!
;; Does our parent exist? ;; Save the child in the parent.
(if (not (class-p SC)) (cl-pushnew cname (if (class-p SC)
(eieio--class-children (class-v SC))
;; Parent doesn't exist yet.
(gethash SC eieio-defclass-autoload-map)))
;; Create a symbol for this parent, and then store this ;; Save parent in child.
;; parent on that symbol. (push SC (eieio--class-parent newc)))
(let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map)))
(if (not (boundp sym))
(set sym (list cname))
(add-to-list sym cname))
)
;; We have a parent, save the child in there.
(when (not (member cname (eieio--class-children (class-v SC))))
(setf (eieio--class-children (class-v SC))
(cons cname (eieio--class-children (class-v SC))))))
;; save parent in child
(setf (eieio--class-parent newc) (cons SC (eieio--class-parent newc)))
)
;; turn this into a usable self-pointing symbol ;; turn this into a usable self-pointing symbol
(set cname cname) (set cname cname)
@ -390,8 +379,7 @@ It creates an autoload function for CNAME's constructor."
(defsubst eieio-class-un-autoload (cname) (defsubst eieio-class-un-autoload (cname)
"If class CNAME is in an autoload state, load its file." "If class CNAME is in an autoload state, load its file."
(when (eq (car-safe (symbol-function cname)) 'autoload) (autoload-do-load (symbol-function cname))) ; cname
(load-library (car (cdr (symbol-function cname))))))
(cl-deftype list-of (elem-type) (cl-deftype list-of (elem-type)
`(and list `(and list
@ -430,16 +418,13 @@ See `defclass' for more information."
;; byte compiling an EIEIO file. ;; byte compiling an EIEIO file.
(if oldc (if oldc
(setf (eieio--class-children newc) (eieio--class-children oldc)) (setf (eieio--class-children newc) (eieio--class-children oldc))
;; If the old class did not exist, but did exist in the autoload map, then adopt those children. ;; If the old class did not exist, but did exist in the autoload map,
;; This is like the above, but deals with autoloads nicely. ;; then adopt those children. This is like the above, but deals with
(let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) ;; autoloads nicely.
(when sym (let ((children (gethash cname eieio-defclass-autoload-map)))
(condition-case nil (when children
(setf (eieio--class-children newc) (symbol-value sym)) (setf (eieio--class-children newc) children)
(error nil)) (remhash cname eieio-defclass-autoload-map))))
(unintern (symbol-name cname) eieio-defclass-autoload-map)
))
)
(cond ((and (stringp (car options-and-doc)) (cond ((and (stringp (car options-and-doc))
(/= 1 (% (length options-and-doc) 2))) (/= 1 (% (length options-and-doc) 2)))
@ -456,39 +441,35 @@ See `defclass' for more information."
(if pname (if pname
(progn (progn
(while pname (dolist (p pname)
(if (and (car pname) (symbolp (car pname))) (if (and p (symbolp p))
(if (not (class-p (car pname))) (if (not (class-p p))
;; bad class ;; bad class
(error "Given parent class %s is not a class" (car pname)) (error "Given parent class %S is not a class" p)
;; good parent class... ;; good parent class...
;; save new child in parent ;; save new child in parent
(when (not (member cname (eieio--class-children (class-v (car pname))))) (cl-pushnew cname (eieio--class-children (class-v p)))
(setf (eieio--class-children (class-v (car pname)))
(cons cname (eieio--class-children (class-v (car pname))))))
;; Get custom groups, and store them into our local copy. ;; Get custom groups, and store them into our local copy.
(mapc (lambda (g) (cl-pushnew g groups :test #'equal)) (mapc (lambda (g) (cl-pushnew g groups :test #'equal))
(class-option (car pname) :custom-groups)) (class-option p :custom-groups))
;; save parent in child ;; save parent in child
(setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc)))) (push p (eieio--class-parent newc)))
(error "Invalid parent class %s" pname)) (error "Invalid parent class %S" p)))
(setq pname (cdr pname)))
;; Reverse the list of our parents so that they are prioritized in ;; Reverse the list of our parents so that they are prioritized in
;; the same order as specified in the code. ;; the same order as specified in the code.
(setf (eieio--class-parent newc) (nreverse (eieio--class-parent newc))) ) (cl-callf nreverse (eieio--class-parent newc)))
;; If there is nothing to loop over, then inherit from the ;; If there is nothing to loop over, then inherit from the
;; default superclass. ;; default superclass.
(unless (eq cname 'eieio-default-superclass) (unless (eq cname 'eieio-default-superclass)
;; adopt the default parent here, but clear it later... ;; adopt the default parent here, but clear it later...
(setq clearparent t) (setq clearparent t)
;; save new child in parent ;; save new child in parent
(if (not (member cname (eieio--class-children (class-v 'eieio-default-superclass)))) (cl-pushnew cname (eieio--class-children
(setf (eieio--class-children (class-v 'eieio-default-superclass)) (class-v 'eieio-default-superclass)))
(cons cname (eieio--class-children (class-v 'eieio-default-superclass)))))
;; save parent in child ;; save parent in child
(setf (eieio--class-parent newc) (list eieio-default-superclass)))) (setf (eieio--class-parent newc) '(eieio-default-superclass))))
;; turn this into a usable self-pointing symbol ;; turn this into a usable self-pointing symbol; FIXME: Why?
(set cname cname) (set cname cname)
;; These two tests must be created right away so we can have self- ;; These two tests must be created right away so we can have self-
@ -519,6 +500,16 @@ See `defclass' for more information."
(and (eieio-object-p obj) (and (eieio-object-p obj)
(object-of-class-p obj ,cname)))) (object-of-class-p obj ,cname))))
;; When using typep, (typep OBJ 'myclass) returns t for objects which
;; are subclasses of myclass. For our predicates, however, it is
;; important for EIEIO to be backwards compatible, where
;; myobject-p, and myobject-child-p are different.
;; "cl" uses this technique to specify symbols with specific typep
;; test, so we can let typep have the CLOS documented behavior
;; while keeping our above predicate clean.
(put cname 'cl-deftype-satisfies csym))
;; Create a handy list of the class test too ;; Create a handy list of the class test too
(let ((csym (intern (concat (symbol-name cname) "-list-p")))) (let ((csym (intern (concat (symbol-name cname) "-list-p"))))
(fset csym (fset csym
@ -536,18 +527,6 @@ See `defclass' for more information."
(setq obj (cdr obj))) (setq obj (cdr obj)))
ans))))) 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
;; myobject-p, and myobject-child-p are different.
;; "cl" uses this technique to specify symbols with specific typep
;; test, so we can let typep have the CLOS documented behavior
;; while keeping our above predicate clean.
;; FIXME: It would be cleaner to use `cl-deftype' here.
(put cname 'cl-deftype-handler
(list 'lambda () `(list 'satisfies (quote ,csym)))))
;; Before adding new slots, let's add all the methods and classes ;; Before adding new slots, let's add all the methods and classes
;; in from the parent class. ;; in from the parent class.
(eieio-copy-parents-into-subclass newc superclasses) (eieio-copy-parents-into-subclass newc superclasses)
@ -693,52 +672,41 @@ See `defclass' for more information."
;; Now that everything has been loaded up, all our lists are backwards! ;; Now that everything has been loaded up, all our lists are backwards!
;; Fix that up now. ;; Fix that up now.
(setf (eieio--class-public-a newc) (nreverse (eieio--class-public-a newc))) (cl-callf nreverse (eieio--class-public-a newc))
(setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc))) (cl-callf nreverse (eieio--class-public-d newc))
(setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc newc))) (cl-callf nreverse (eieio--class-public-doc newc))
(setf (eieio--class-public-type newc) (cl-callf (lambda (types) (apply #'vector (nreverse types)))
(apply #'vector (nreverse (eieio--class-public-type newc)))) (eieio--class-public-type newc))
(setf (eieio--class-public-custom newc) (nreverse (eieio--class-public-custom newc))) (cl-callf nreverse (eieio--class-public-custom newc))
(setf (eieio--class-public-custom-label newc) (nreverse (eieio--class-public-custom-label newc))) (cl-callf nreverse (eieio--class-public-custom-label newc))
(setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc))) (cl-callf nreverse (eieio--class-public-custom-group newc))
(setf (eieio--class-public-printer newc) (nreverse (eieio--class-public-printer newc))) (cl-callf nreverse (eieio--class-public-printer newc))
(setf (eieio--class-protection newc) (nreverse (eieio--class-protection newc))) (cl-callf nreverse (eieio--class-protection newc))
(setf (eieio--class-initarg-tuples newc) (nreverse (eieio--class-initarg-tuples newc))) (cl-callf nreverse (eieio--class-initarg-tuples newc))
;; The storage for class-class-allocation-type needs to be turned into ;; The storage for class-class-allocation-type needs to be turned into
;; a vector now. ;; a vector now.
(setf (eieio--class-class-allocation-type newc) (cl-callf (lambda (cat) (apply #'vector cat))
(apply #'vector (eieio--class-class-allocation-type newc))) (eieio--class-class-allocation-type newc))
;; Also, take class allocated values, and vectorize them for speed. ;; Also, take class allocated values, and vectorize them for speed.
(setf (eieio--class-class-allocation-values newc) (cl-callf (lambda (cavs) (apply #'vector cavs))
(apply #'vector (eieio--class-class-allocation-values newc))) (eieio--class-class-allocation-values newc))
;; Attach slot symbols into an obarray, and store the index of ;; Attach slot symbols into a hashtable, and store the index of
;; this slot as the variable slot in this new symbol. We need to ;; this slot as the value this table.
;; know about primes, because obarrays are best set in vectors of
;; prime number length, and we also need to make our vector small
;; to save space, and also optimal for the number of items we have.
(let* ((cnt 0) (let* ((cnt 0)
(pubsyms (eieio--class-public-a newc)) (pubsyms (eieio--class-public-a newc))
(prots (eieio--class-protection newc)) (prots (eieio--class-protection newc))
(l (length pubsyms)) (oa (make-hash-table :test #'eq)))
(vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47
53 59 61 67 71 73 79 83 89 97 101 )))
(while (and primes (< (car primes) l))
(setq primes (cdr primes)))
(car primes)))
(oa (make-vector vl 0))
(newsym))
(while pubsyms (while pubsyms
(setq newsym (intern (symbol-name (car pubsyms)) oa)) (let ((newsym (list cnt)))
(set newsym cnt) (setf (gethash (car pubsyms) oa) newsym)
(setq cnt (1+ cnt)) (setq cnt (1+ cnt))
(if (car prots) (put newsym 'protection (car prots))) (if (car prots) (setcdr newsym (car prots))))
(setq pubsyms (cdr pubsyms) (setq pubsyms (cdr pubsyms)
prots (cdr prots))) prots (cdr prots)))
(setf (eieio--class-symbol-obarray newc) oa) (setf (eieio--class-symbol-hashtable newc) oa))
)
;; Create the constructor function ;; Create the constructor function
(if (class-option-assoc options :abstract) (if (class-option-assoc options :abstract)
@ -787,7 +755,8 @@ See `defclass' for more information."
(if clearparent (setf (eieio--class-parent newc) nil)) (if clearparent (setf (eieio--class-parent newc) nil))
;; Create the cached default object. ;; Create the cached default object.
(let ((cache (make-vector (+ (length (eieio--class-public-a newc)) 3) (let ((cache (make-vector (+ (length (eieio--class-public-a newc))
(eval-when-compile eieio--object-num-slots))
nil))) nil)))
(aset cache 0 'object) (aset cache 0 'object)
(setf (eieio--object-class cache) cname) (setf (eieio--object-class cache) cname)
@ -1123,56 +1092,56 @@ the new child class."
;; Make sure the method tables are installed. ;; Make sure the method tables are installed.
(eieiomt-install method) (eieiomt-install method)
;; Construct the actual body of this function. ;; Construct the actual body of this function.
(eieio-defgeneric-form method doc-string)) (put method 'function-documentation doc-string)
(eieio-defgeneric-form method))
((generic-p method) (symbol-function method)) ;Leave it as-is. ((generic-p method) (symbol-function method)) ;Leave it as-is.
(t (error "You cannot create a generic/method over an existing symbol: %s" (t (error "You cannot create a generic/method over an existing symbol: %s"
method)))) method))))
(defun eieio-defgeneric-form (method doc-string) (defun eieio-defgeneric-form (method)
"The lambda form that would be used as the function defined on METHOD. "The lambda form that would be used as the function defined on METHOD.
All methods should call the same EIEIO function for dispatch. All methods should call the same EIEIO function for dispatch.
DOC-STRING is the documentation attached to METHOD." DOC-STRING is the documentation attached to METHOD."
`(lambda (&rest local-args) (lambda (&rest local-args)
,doc-string (eieio-generic-call method local-args)))
(eieio-generic-call (quote ,method) local-args)))
(defsubst eieio-defgeneric-reset-generic-form (method) (defsubst eieio-defgeneric-reset-generic-form (method)
"Setup METHOD to call the generic form." "Setup METHOD to call the generic form."
(let ((doc-string (documentation method))) (let ((doc-string (documentation method 'raw)))
(fset method (eieio-defgeneric-form method doc-string)))) (put method 'function-documentation doc-string)
(fset method (eieio-defgeneric-form method))))
(defun eieio-defgeneric-form-primary-only (method doc-string) (defun eieio-defgeneric-form-primary-only (method)
"The lambda form that would be used as the function defined on METHOD. "The lambda form that would be used as the function defined on METHOD.
All methods should call the same EIEIO function for dispatch. All methods should call the same EIEIO function for dispatch.
DOC-STRING is the documentation attached to METHOD." DOC-STRING is the documentation attached to METHOD."
`(lambda (&rest local-args) (lambda (&rest local-args)
,doc-string (eieio-generic-call-primary-only method local-args)))
(eieio-generic-call-primary-only (quote ,method) local-args)))
(defsubst eieio-defgeneric-reset-generic-form-primary-only (method) (defsubst eieio-defgeneric-reset-generic-form-primary-only (method)
"Setup METHOD to call the generic form." "Setup METHOD to call the generic form."
(let ((doc-string (documentation method))) (let ((doc-string (documentation method 'raw)))
(fset method (eieio-defgeneric-form-primary-only method doc-string)))) (put method 'function-documentation doc-string)
(fset method (eieio-defgeneric-form-primary-only method))))
(declare-function no-applicable-method "eieio" (object method &rest args)) (declare-function no-applicable-method "eieio" (object method &rest args))
(defun eieio-defgeneric-form-primary-only-one (method doc-string (defvar eieio-generic-call-arglst nil
class "When using `call-next-method', provides a context for parameters.")
impl (defvar eieio-generic-call-key nil
) "When using `call-next-method', provides a context for the current key.
Keys are a number representing :before, :primary, and :after methods.")
(defvar eieio-generic-call-next-method-list nil
"When executing a PRIMARY or STATIC method, track the 'next-method'.
During executions, the list is first generated, then as each next method
is called, the next method is popped off the stack.")
(defun eieio-defgeneric-form-primary-only-one (method class impl)
"The lambda form that would be used as the function defined on METHOD. "The lambda form that would be used as the function defined on METHOD.
All methods should call the same EIEIO function for dispatch. All methods should call the same EIEIO function for dispatch.
DOC-STRING is the documentation attached to METHOD.
CLASS is the class symbol needed for private method access. CLASS is the class symbol needed for private method access.
IMPL is the symbol holding the method implementation." IMPL is the symbol holding the method implementation."
;; NOTE: I tried out byte compiling this little fcn. Turns out it (lambda (&rest local-args)
;; 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-warnings nil))
(byte-compile
`(lambda (&rest local-args)
,doc-string
;; This is a cool cheat. Usually we need to look up in the ;; This is a cool cheat. Usually we need to look up in the
;; method table to find out if there is a method or not. We can ;; method table to find out if there is a method or not. We can
;; instead make that determination at load time when there is ;; instead make that determination at load time when there is
@ -1181,50 +1150,41 @@ IMPL is the symbol holding the method implementation."
(if (not (eieio-object-p (car local-args))) (if (not (eieio-object-p (car local-args)))
;; Not an object. Just signal. ;; Not an object. Just signal.
(signal 'no-method-definition (signal 'no-method-definition
(list ',method local-args)) (list method local-args))
;; We do have an object. Make sure it is the right type. ;; We do have an object. Make sure it is the right type.
(if ,(if (eq class eieio-default-superclass) (if (not (child-of-class-p (eieio--object-class (car local-args))
nil ; default superclass means just an obj. Already asked. class))
`(not (child-of-class-p (eieio--object-class (car local-args))
',class)))
;; If not the right kind of object, call no applicable ;; If not the right kind of object, call no applicable
(apply #'no-applicable-method (car local-args) (apply #'no-applicable-method (car local-args)
',method local-args) method local-args)
;; It is ok, do the call. ;; It is ok, do the call.
;; Fill in inter-call variables then evaluate the method. ;; Fill in inter-call variables then evaluate the method.
(let ((eieio-generic-call-next-method-list nil) (let ((eieio-generic-call-next-method-list nil)
(eieio-generic-call-key method-primary) (eieio-generic-call-key method-primary)
(eieio-generic-call-methodname ',method)
(eieio-generic-call-arglst local-args) (eieio-generic-call-arglst local-args)
) )
(eieio--with-scoped-class ',class (eieio--with-scoped-class class
,(if (< emacs-major-version 24) (apply impl local-args)))))))
`(apply ,(list 'quote impl) local-args)
`(apply #',impl local-args)))
;(,impl local-args)
)))))))
(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) (defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method)
"Setup METHOD to call the generic form." "Setup METHOD to call the generic form."
(let* ((doc-string (documentation method)) (let* ((doc-string (documentation method 'raw))
(M (get method 'eieio-method-tree)) (M (get method 'eieio-method-tree))
(entry (car (aref M method-primary))) (entry (car (aref M method-primary)))
) )
(put method 'function-documentation doc-string)
(fset method (eieio-defgeneric-form-primary-only-one (fset method (eieio-defgeneric-form-primary-only-one
method doc-string method (car entry) (cdr entry)))))
(car entry)
(cdr entry)
))))
(defun eieio-unbind-method-implementations (method) (defun eieio-unbind-method-implementations (method)
"Make the generic method METHOD have no implementations. "Make the generic method METHOD have no implementations.
It will leave the original generic function in place, It will leave the original generic function in place,
but remove reference to all implementations of METHOD." but remove reference to all implementations of METHOD."
(put method 'eieio-method-tree nil) (put method 'eieio-method-tree nil)
(put method 'eieio-method-obarray nil)) (put method 'eieio-method-hashtable nil))
(defun eieio--defmethod (method kind argclass code) (defun eieio--defmethod (method kind argclass code)
"Work part of the `defmethod' macro defining METHOD with ARGS." "Work part of the `defmethod' macro defining METHOD with ARGS."
@ -1248,7 +1208,7 @@ but remove reference to all implementations of METHOD."
;; under the type `primary' which is a non-specific calling of the ;; under the type `primary' which is a non-specific calling of the
;; function. ;; function.
(if argclass (if argclass
(if (not (class-p argclass)) (if (not (class-p argclass)) ;FIXME: Accept cl-defstructs!
(error "Unknown class type %s in method parameters" (error "Unknown class type %s in method parameters"
argclass)) argclass))
;; Generics are higher. ;; Generics are higher.
@ -1440,8 +1400,7 @@ so that we can protect private slots."
(if (not par) (if (not par)
t t
(while (and par ret) (while (and par ret)
(if (intern-soft (symbol-name slot) (if (gethash slot (eieio--class-symbol-hashtable (class-v (car par))))
(eieio--class-symbol-obarray (class-v (car par))))
(setq ret nil)) (setq ret nil))
(setq par (cdr par))) (setq par (cdr par)))
ret))) ret)))
@ -1455,20 +1414,19 @@ scoped class.
If SLOT is the value created with :initarg instead, If SLOT is the value created with :initarg instead,
reverse-lookup that name, and recurse with the associated slot value." reverse-lookup that name, and recurse with the associated slot value."
;; Removed checks to outside this call ;; Removed checks to outside this call
(let* ((fsym (intern-soft (symbol-name slot) (let* ((fsym (gethash slot (eieio--class-symbol-hashtable (class-v class))))
(eieio--class-symbol-obarray (class-v class)))) (fsi (car fsym)))
(fsi (if (symbolp fsym) (symbol-value fsym) nil)))
(if (integerp fsi) (if (integerp fsi)
(cond (cond
((not (get fsym 'protection)) ((not (cdr fsym))
(+ 3 fsi)) (+ 3 fsi))
((and (eq (get fsym 'protection) 'protected) ((and (eq (cdr fsym) 'protected)
(eieio--scoped-class) (eieio--scoped-class)
(or (child-of-class-p class (eieio--scoped-class)) (or (child-of-class-p class (eieio--scoped-class))
(and (eieio-object-p obj) (and (eieio-object-p obj)
(child-of-class-p class (eieio--object-class obj))))) (child-of-class-p class (eieio--object-class obj)))))
(+ 3 fsi)) (+ 3 fsi))
((and (eq (get fsym 'protection) 'private) ((and (eq (cdr fsym) 'private)
(or (and (eieio--scoped-class) (or (and (eieio--scoped-class)
(eieio-slot-originating-class-p (eieio--scoped-class) slot)) (eieio-slot-originating-class-p (eieio--scoped-class) slot))
eieio-initializing-object)) eieio-initializing-object))
@ -1651,17 +1609,6 @@ method invocation orders of the involved classes."
;;; CLOS generics internal function handling ;;; CLOS generics internal function handling
;; ;;
(defvar eieio-generic-call-methodname nil
"When using `call-next-method', provides a context on how to do it.")
(defvar eieio-generic-call-arglst nil
"When using `call-next-method', provides a context for parameters.")
(defvar eieio-generic-call-key nil
"When using `call-next-method', provides a context for the current key.
Keys are a number representing :before, :primary, and :after methods.")
(defvar eieio-generic-call-next-method-list nil
"When executing a PRIMARY or STATIC method, track the 'next-method'.
During executions, the list is first generated, then as each next method
is called, the next method is popped off the stack.")
(define-obsolete-variable-alias 'eieio-pre-method-execution-hooks (define-obsolete-variable-alias 'eieio-pre-method-execution-hooks
'eieio-pre-method-execution-functions "24.3") 'eieio-pre-method-execution-functions "24.3")
@ -1677,7 +1624,6 @@ This should only be called from a generic function."
;; We must expand our arguments first as they are always ;; We must expand our arguments first as they are always
;; passed in as quoted symbols ;; passed in as quoted symbols
(let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil)
(eieio-generic-call-methodname method)
(eieio-generic-call-arglst args) (eieio-generic-call-arglst args)
(firstarg nil) (firstarg nil)
(primarymethodlist nil)) (primarymethodlist nil))
@ -1818,7 +1764,6 @@ for this common case to improve performance."
;; We must expand our arguments first as they are always ;; We must expand our arguments first as they are always
;; passed in as quoted symbols ;; passed in as quoted symbols
(let ((newargs nil) (mclass nil) (lambdas nil) (let ((newargs nil) (mclass nil) (lambdas nil)
(eieio-generic-call-methodname method)
(eieio-generic-call-arglst args) (eieio-generic-call-arglst args)
(firstarg nil) (firstarg nil)
(primarymethodlist nil) (primarymethodlist nil)
@ -1918,7 +1863,7 @@ If CLASS is nil, then an empty list of methods should be returned."
;; (eieio-method-tree . [BEFORE PRIMARY AFTER ;; (eieio-method-tree . [BEFORE PRIMARY AFTER
;; genericBEFORE genericPRIMARY genericAFTER]) ;; genericBEFORE genericPRIMARY genericAFTER])
;; and ;; and
;; (eieio-method-obarray . [BEFORE PRIMARY AFTER ;; (eieio-method-hashtable . [BEFORE PRIMARY AFTER
;; genericBEFORE genericPRIMARY genericAFTER]) ;; genericBEFORE genericPRIMARY genericAFTER])
;; where the association is a vector. ;; where the association is a vector.
;; (aref 0 -- all static methods. ;; (aref 0 -- all static methods.
@ -1929,25 +1874,22 @@ If CLASS is nil, then an empty list of methods should be returned."
;; (aref 5 -- a generic classified as :primary ;; (aref 5 -- a generic classified as :primary
;; (aref 6 -- a generic classified as :after ;; (aref 6 -- a generic classified as :after
;; ;;
(defvar eieiomt-optimizing-obarray nil (defvar eieiomt--optimizing-hashtable nil
"While mapping atoms, this contain the obarray being optimized.") "While mapping atoms, this contain the hashtable being optimized.")
(defun eieiomt-install (method-name) (defun eieiomt-install (method-name)
"Install the method tree, and obarray onto METHOD-NAME. "Install the method tree, and hashtable onto METHOD-NAME.
Do not do the work if they already exist." Do not do the work if they already exist."
(let ((emtv (get method-name 'eieio-method-tree)) (unless (and (get method-name 'eieio-method-tree)
(emto (get method-name 'eieio-method-obarray))) (get method-name 'eieio-method-hashtable))
(if (or (not emtv) (not emto)) (put method-name 'eieio-method-tree
(progn
(setq emtv (put method-name 'eieio-method-tree
(make-vector method-num-slots nil)) (make-vector method-num-slots nil))
emto (put method-name 'eieio-method-obarray (let ((emto (put method-name 'eieio-method-hashtable
(make-vector method-num-slots nil))) (make-vector method-num-slots nil))))
(aset emto 0 (make-vector 11 0)) (aset emto 0 (make-hash-table :test 'eq))
(aset emto 1 (make-vector 11 0)) (aset emto 1 (make-hash-table :test 'eq))
(aset emto 2 (make-vector 41 0)) (aset emto 2 (make-hash-table :test 'eq))
(aset emto 3 (make-vector 11 0)) (aset emto 3 (make-hash-table :test 'eq)))))
))))
(defun eieiomt-add (method-name method key class) (defun eieiomt-add (method-name method key class)
"Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS.
@ -1960,36 +1902,33 @@ CLASS is the class this method is associated with."
(if (or (> key method-num-slots) (< key 0)) (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)) (let ((emtv (get method-name 'eieio-method-tree))
(emto (get method-name 'eieio-method-obarray))) (emto (get method-name 'eieio-method-hashtable)))
;; Make sure the method tables are available. ;; Make sure the method tables are available.
(if (or (not emtv) (not emto)) (unless (and emtv emto)
(error "Programmer error: eieiomt-add")) (error "Programmer error: eieiomt-add"))
;; only add new cells on if it doesn't already exist! ;; only add new cells on if it doesn't already exist!
(if (assq class (aref emtv key)) (if (assq class (aref emtv key))
(setcdr (assq class (aref emtv key)) method) (setcdr (assq class (aref emtv key)) method)
(aset emtv key (cons (cons class method) (aref emtv key)))) (aset emtv key (cons (cons class method) (aref emtv key))))
;; Add function definition into newly created symbol, and store ;; Add function definition into newly created symbol, and store
;; said symbol in the correct obarray, otherwise use the ;; said symbol in the correct hashtable, otherwise use the
;; other array to keep this stuff ;; other array to keep this stuff.
(if (< key method-num-lists) (if (< key method-num-lists)
(let ((nsym (intern (symbol-name class) (aref emto key)))) (puthash class (list method) (aref emto key)))
(fset nsym method)))
;; Save the defmethod file location in a symbol property. ;; Save the defmethod file location in a symbol property.
(let ((fname (if load-in-progress (let ((fname (if load-in-progress
load-file-name load-file-name
buffer-file-name)) buffer-file-name)))
loc)
(when fname (when fname
(when (string-match "\\.elc$" fname) (when (string-match "\\.elc\\'" fname)
(setq fname (substring fname 0 (1- (length fname))))) (setq fname (substring fname 0 (1- (length fname)))))
(setq loc (get method-name 'method-locations)) (cl-pushnew (list class fname) (get method-name 'method-locations)
(cl-pushnew (list class fname) loc :test 'equal) :test 'equal)))
(put method-name 'method-locations loc))) ;; Now optimize the entire hashtable.
;; Now optimize the entire obarray
(if (< key method-num-lists) (if (< key method-num-lists)
(let ((eieiomt-optimizing-obarray (aref emto key))) (let ((eieiomt--optimizing-hashtable (aref emto key)))
;; @todo - Is this overkill? Should we just clear the symbol? ;; @todo - Is this overkill? Should we just clear the symbol?
(mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray))) (maphash #'eieiomt--sym-optimize eieiomt--optimizing-hashtable)))
)) ))
(defun eieiomt-next (class) (defun eieiomt-next (class)
@ -2005,21 +1944,19 @@ nil for superclasses. This function performs no type checking!"
nil nil
'(eieio-default-superclass)))) '(eieio-default-superclass))))
(defun eieiomt-sym-optimize (s) (defun eieiomt--sym-optimize (class s)
"Find the next class above S which has a function body for the optimizer." "Find the next class above S which has a function body for the optimizer."
;; Set the value to nil in case there is no nearest cell. ;; Set the value to nil in case there is no nearest cell.
(set s nil) (setcdr s nil)
;; Find the nearest cell that has a function body. If we find one, ;; Find the nearest cell that has a function body. If we find one,
;; we replace the nil from above. ;; we replace the nil from above.
(let ((external-symbol (intern-soft (symbol-name s))))
(catch 'done (catch 'done
(dolist (ancestor (dolist (ancestor
(cl-rest (eieio-class-precedence-list external-symbol))) (cl-rest (eieio-class-precedence-list class)))
(let ((ov (intern-soft (symbol-name ancestor) (let ((ov (gethash ancestor eieiomt--optimizing-hashtable)))
eieiomt-optimizing-obarray))) (when (car ov)
(when (fboundp ov) (setcdr s ancestor) ;; store ov as our next symbol
(set s ov) ;; store ov as our next symbol (throw 'done ancestor))))))
(throw 'done ancestor)))))))
(defun eieio-generic-form (method key class) (defun eieio-generic-form (method key class)
"Return the lambda form belonging to METHOD using KEY based upon CLASS. "Return the lambda form belonging to METHOD using KEY based upon CLASS.
@ -2027,33 +1964,33 @@ 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. 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 The first time a form is requested from a symbol, an optimized path
is memorized for faster future use." is memorized for faster future use."
(let ((emto (aref (get method 'eieio-method-obarray) (let ((emto (aref (get method 'eieio-method-hashtable)
(if class key (eieio-specialized-key-to-generic-key key))))) (if class key (eieio-specialized-key-to-generic-key key)))))
(if (class-p class) (if (class-p class)
;; 1) find our symbol ;; 1) find our symbol
(let ((cs (intern-soft (symbol-name class) emto))) (let ((cs (gethash class emto)))
(if (not cs) (unless cs
;; 2) If there isn't one, then make one. ;; 2) If there isn't one, then make one.
;; This can be slow since it only occurs once ;; This can be slow since it only occurs once
(progn (puthash class (setq cs (list nil)) emto)
(setq cs (intern (symbol-name class) emto))
;; 2.1) Cache its 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 ;; which should only occur once for this call ever
(let ((eieiomt-optimizing-obarray emto)) (let ((eieiomt--optimizing-hashtable emto))
(eieiomt-sym-optimize cs)))) (eieiomt--sym-optimize class cs)))
;; 3) If it's bound return this one. ;; 3) If it's bound return this one.
(if (fboundp cs) (if (car cs)
(cons cs (eieio--class-symbol (class-v class))) ;; FIXME: Why (eieio--class-symbol (class-v class))?
(cons (car cs) class)
;; 4) If it's not bound then this variable knows something ;; 4) If it's not bound then this variable knows something
(if (symbol-value cs) (if (cdr cs)
(progn (progn
;; 4.1) This symbol holds the next class in its value ;; 4.1) This symbol holds the next class in its value
(setq class (symbol-value cs) (setq class (cdr cs)
cs (intern-soft (symbol-name class) emto)) cs (gethash class emto))
;; 4.2) The optimizer should always have chosen a ;; 4.2) The optimizer should always have chosen a
;; function-symbol ;; function-symbol
;;(if (fboundp cs) ;;(if (car cs)
(cons cs (eieio--class-symbol (class-v (intern (symbol-name class))))) (cons (car cs) class)
;;(error "EIEIO optimizer: erratic data loss!")) ;;(error "EIEIO optimizer: erratic data loss!"))
) )
;; There never will be a funcall... ;; There never will be a funcall...
@ -2166,7 +2103,8 @@ is memorized for faster future use."
;; Make sure the method tables are installed. ;; Make sure the method tables are installed.
(eieiomt-install method) (eieiomt-install method)
;; Apply the actual body of this function. ;; Apply the actual body of this function.
(fset method (eieio-defgeneric-form method doc-string)) (put method 'function-documentation doc-string)
(fset method (eieio-defgeneric-form method))
;; Return the method ;; Return the method
'method)) 'method))
(make-obsolete 'eieio-defgeneric nil "24.1") (make-obsolete 'eieio-defgeneric nil "24.1")

24
lisp/emacs-lisp/eieio-custom.el
View file

@ -1,4 +1,4 @@
;;; eieio-custom.el -- eieio object customization ;;; eieio-custom.el -- eieio object customization -*- lexical-binding:t -*-
;; Copyright (C) 1999-2001, 2005, 2007-2014 Free Software Foundation, ;; Copyright (C) 1999-2001, 2005, 2007-2014 Free Software Foundation,
;; Inc. ;; Inc.
@ -136,7 +136,7 @@ Updates occur regardless of the current customization group.")
)) ))
(widget-value-set vc (widget-value vc)))) (widget-value-set vc (widget-value vc))))
(defun eieio-custom-toggle-parent (widget &rest ignore) (defun eieio-custom-toggle-parent (widget &rest _)
"Toggle visibility of parent of WIDGET. "Toggle visibility of parent of WIDGET.
Optional argument IGNORE is an extraneous parameter." Optional argument IGNORE is an extraneous parameter."
(eieio-custom-toggle-hide (widget-get widget :parent))) (eieio-custom-toggle-hide (widget-get widget :parent)))
@ -154,7 +154,7 @@ Optional argument IGNORE is an extraneous parameter."
:clone-object-children nil :clone-object-children nil
) )
(defun eieio-object-match (widget value) (defun eieio-object-match (_widget _value)
"Match info for WIDGET against VALUE." "Match info for WIDGET against VALUE."
;; Write me ;; Write me
t) t)
@ -216,7 +216,7 @@ Optional argument IGNORE is an extraneous parameter."
(widget-insert "*" (capitalize (symbol-name master-group)) "*") (widget-insert "*" (capitalize (symbol-name master-group)) "*")
(widget-create 'push-button (widget-create 'push-button
:thing (cons obj (car groups)) :thing (cons obj (car groups))
:notify (lambda (widget &rest stuff) :notify (lambda (widget &rest _)
(eieio-customize-object (eieio-customize-object
(car (widget-get widget :thing)) (car (widget-get widget :thing))
(cdr (widget-get widget :thing)))) (cdr (widget-get widget :thing))))
@ -389,14 +389,14 @@ These groups are specified with the `:group' slot flag."
"Insert an Apply and Reset button into the object editor. "Insert an Apply and Reset button into the object editor.
Argument OBJ is the object being customized." Argument OBJ is the object being customized."
(widget-create 'push-button (widget-create 'push-button
:notify (lambda (&rest ignore) :notify (lambda (&rest _)
(widget-apply eieio-wo :value-get) (widget-apply eieio-wo :value-get)
(eieio-done-customizing eieio-co) (eieio-done-customizing eieio-co)
(bury-buffer)) (bury-buffer))
"Accept") "Accept")
(widget-insert " ") (widget-insert " ")
(widget-create 'push-button (widget-create 'push-button
:notify (lambda (&rest ignore) :notify (lambda (&rest _)
;; I think the act of getting it sets ;; I think the act of getting it sets
;; its value through the get function. ;; its value through the get function.
(message "Applying Changes...") (message "Applying Changes...")
@ -406,13 +406,13 @@ Argument OBJ is the object being customized."
"Apply") "Apply")
(widget-insert " ") (widget-insert " ")
(widget-create 'push-button (widget-create 'push-button
:notify (lambda (&rest ignore) :notify (lambda (&rest _)
(message "Resetting") (message "Resetting")
(eieio-customize-object eieio-co eieio-cog)) (eieio-customize-object eieio-co eieio-cog))
"Reset") "Reset")
(widget-insert " ") (widget-insert " ")
(widget-create 'push-button (widget-create 'push-button
:notify (lambda (&rest ignore) :notify (lambda (&rest _)
(bury-buffer)) (bury-buffer))
"Cancel")) "Cancel"))
@ -431,13 +431,11 @@ Must return the created widget."
:clone-object-children t :clone-object-children t
) )
(defun eieio-object-value-to-abstract (widget value) (defun eieio-object-value-to-abstract (_widget value)
"For WIDGET, convert VALUE to an abstract /safe/ representation." "For WIDGET, convert VALUE to an abstract /safe/ representation."
(if (eieio-object-p value) value (if (eieio-object-p value) value))
(if (null value) value
nil)))
(defun eieio-object-abstract-to-value (widget value) (defun eieio-object-abstract-to-value (_widget value)
"For WIDGET, convert VALUE from an abstract /safe/ representation." "For WIDGET, convert VALUE from an abstract /safe/ representation."
value) value)

4
lisp/emacs-lisp/eieio-datadebug.el
View file

@ -1,4 +1,4 @@
;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. ;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -*- lexical-binding:t -*-
;; Copyright (C) 2007-2014 Free Software Foundation, Inc. ;; Copyright (C) 2007-2014 Free Software Foundation, Inc.
@ -137,7 +137,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
(data (data
(catch 'moose (eieio-generic-call (catch 'moose (eieio-generic-call
method (list class)))) method (list class))))
(buf (data-debug-new-buffer "*Method Invocation*")) (_buf (data-debug-new-buffer "*Method Invocation*"))
(data2 (mapcar (lambda (sym) (data2 (mapcar (lambda (sym)
(symbol-function (car sym))) (symbol-function (car sym)))
data))) data)))

58
lisp/emacs-lisp/eieio-opt.el
View file

@ -218,11 +218,10 @@ Outputs to the current buffer."
(defun eieio-build-class-list (class) (defun eieio-build-class-list (class)
"Return a list of all classes that inherit from CLASS." "Return a list of all classes that inherit from CLASS."
(if (class-p class) (if (class-p class)
(apply #'append (cl-mapcan
(mapcar
(lambda (c) (lambda (c)
(append (list c) (eieio-build-class-list c))) (append (list c) (eieio-build-class-list c)))
(eieio-class-children-fast class))) (eieio-class-children-fast class))
(list class))) (list class)))
(defun eieio-build-class-alist (&optional class instantiable-only buildlist) (defun eieio-build-class-alist (&optional class instantiable-only buildlist)
@ -235,11 +234,12 @@ Optional argument BUILDLIST is more list to attach and is used internally."
(sublst (eieio--class-children (class-v cc)))) (sublst (eieio--class-children (class-v cc))))
(unless (assoc (symbol-name cc) buildlist) (unless (assoc (symbol-name cc) buildlist)
(when (or (not instantiable-only) (not (class-abstract-p cc))) (when (or (not instantiable-only) (not (class-abstract-p cc)))
;; FIXME: Completion tables don't need alists, and ede/generic.el needs
;; the symbols rather than their names.
(setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))
(while sublst (dolist (elem sublst)
(setq buildlist (eieio-build-class-alist (setq buildlist (eieio-build-class-alist
(car sublst) instantiable-only buildlist)) elem instantiable-only buildlist)))
(setq sublst (cdr sublst)))
buildlist)) buildlist))
(defvar eieio-read-class nil (defvar eieio-read-class nil
@ -378,18 +378,17 @@ are not abstract."
"Return a list of all generic functions. "Return a list of all generic functions.
Optional CLASS argument returns only those functions that contain Optional CLASS argument returns only those functions that contain
methods for CLASS." methods for CLASS."
(let ((l nil) tree (cn (if class (symbol-name class) nil))) (let ((l nil))
(mapatoms (mapatoms
(lambda (symbol) (lambda (symbol)
(setq tree (get symbol 'eieio-method-obarray)) (let ((tree (get symbol 'eieio-method-hashtable)))
(if tree (when tree
(progn
;; A symbol might be interned for that class in one of ;; A symbol might be interned for that class in one of
;; these three slots in the method-obarray. ;; these three slots in the method-obarray.
(if (or (not class) (if (or (not class)
(fboundp (intern-soft cn (aref tree 0))) (car (gethash class (aref tree 0)))
(fboundp (intern-soft cn (aref tree 1))) (car (gethash class (aref tree 1)))
(fboundp (intern-soft cn (aref tree 2)))) (car (gethash class (aref tree 2))))
(setq l (cons symbol l))))))) (setq l (cons symbol l)))))))
l)) l))
@ -397,32 +396,29 @@ methods for CLASS."
"Return a list of the specific documentation of GENERIC for CLASS. "Return a list of the specific documentation of GENERIC for CLASS.
If there is not an explicit method for CLASS in GENERIC, or if that If there is not an explicit method for CLASS in GENERIC, or if that
function has no documentation, then return nil." function has no documentation, then return nil."
(let ((tree (get generic 'eieio-method-obarray)) (let ((tree (get generic 'eieio-method-hashtable)))
(cn (symbol-name class)) (when tree
before primary after)
(if (not tree)
nil
;; A symbol might be interned for that class in one of ;; A symbol might be interned for that class in one of
;; these three slots in the method-obarray. ;; these three slots in the method-hashtable.
(setq before (intern-soft cn (aref tree 0)) ;; FIXME: Where do these 0/1/2 come from? Isn't 0 for :static,
primary (intern-soft cn (aref tree 1)) ;; 1 for before, and 2 for primary (and 3 for after)?
after (intern-soft cn (aref tree 2))) (let ((before (car (gethash class (aref tree 0))))
(if (not (or (fboundp before) (primary (car (gethash class (aref tree 1))))
(fboundp primary) (after (car (gethash class (aref tree 2)))))
(fboundp after))) (if (not (or before primary after))
nil nil
(list (if (fboundp before) (list (if before
(cons (help-function-arglist before) (cons (help-function-arglist before)
(documentation before)) (documentation before))
nil) nil)
(if (fboundp primary) (if primary
(cons (help-function-arglist primary) (cons (help-function-arglist primary)
(documentation primary)) (documentation primary))
nil) nil)
(if (fboundp after) (if after
(cons (help-function-arglist after) (cons (help-function-arglist after)
(documentation after)) (documentation after))
nil)))))) nil)))))))
(defvar eieio-read-generic nil (defvar eieio-read-generic nil
"History of the `eieio-read-generic' prompt.") "History of the `eieio-read-generic' prompt.")
@ -627,7 +623,7 @@ Optional argument HISTORYVAR is the variable to use as history."
() ()
"Menu part in easymenu format used in speedbar while in `eieio' mode.") "Menu part in easymenu format used in speedbar while in `eieio' mode.")
(defun eieio-class-speedbar (dir-or-object depth) (defun eieio-class-speedbar (_dir-or-object _depth)
"Create buttons in speedbar that represents the current project. "Create buttons in speedbar that represents the current project.
DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the
current expansion depth." current expansion depth."
@ -676,7 +672,7 @@ Argument INDENT is the depth of indentation."
(t (error "Ooops... not sure what to do"))) (t (error "Ooops... not sure what to do")))
(speedbar-center-buffer-smartly)) (speedbar-center-buffer-smartly))
(defun eieio-describe-class-sb (text token indent) (defun eieio-describe-class-sb (_text token _indent)
"Describe the class TEXT in TOKEN. "Describe the class TEXT in TOKEN.
INDENT is the current indentation level." INDENT is the current indentation level."
(dframe-with-attached-buffer (dframe-with-attached-buffer

7
lisp/emacs-lisp/eieio.el
View file

@ -343,12 +343,15 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
"Return non-nil if CHILD class is a subclass of CLASS." "Return non-nil if CHILD class is a subclass of CLASS."
(eieio--check-type class-p class) (eieio--check-type class-p class)
(eieio--check-type class-p child) (eieio--check-type class-p child)
;; `eieio-default-superclass' is never mentioned in eieio--class-parent,
;; so we have to special case it here.
(or (eq class 'eieio-default-superclass)
(let ((p nil)) (let ((p nil))
(while (and child (not (eq child class))) (while (and child (not (eq child class)))
(setq p (append p (eieio--class-parent (class-v child))) (setq p (append p (eieio--class-parent (class-v child)))
child (car p) child (car p)
p (cdr p))) p (cdr p)))
(if child t))) (if child t))))
(defun object-slots (obj) (defun object-slots (obj)
"Return list of slots available in OBJ." "Return list of slots available in OBJ."
@ -906,7 +909,7 @@ Optional argument GROUP is the sub-group of slots to display.
;;;*** ;;;***
;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "889c0a935dddf758dbb65488470ffa06") ;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "e50a67ebd0c6258c615e4bf16714e81f")
;;; Generated autoloads from eieio-opt.el ;;; Generated autoloads from eieio-opt.el
(autoload 'eieio-browse "eieio-opt" "\ (autoload 'eieio-browse "eieio-opt" "\

22
test/ChangeLog
View file

@ -1,3 +1,11 @@
2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/eieio-test-methodinvoke.el (eieio-test-method-store):
Remove use of eieio-generic-call-methodname.
(eieio-test-method-order-list-3, eieio-test-method-order-list-6)
(eieio-test-method-order-list-7, eieio-test-method-order-list-8):
Adjust the expected result accordingly.
2014-12-19 Artur Malabarba <bruce.connor.am@gmail.com> 2014-12-19 Artur Malabarba <bruce.connor.am@gmail.com>
* automated/let-alist.el: require `cl-lib' * automated/let-alist.el: require `cl-lib'
@ -27,8 +35,8 @@
(vc-test--create-repo-function): Rename from (vc-test--create-repo-function): Rename from
`vc-test--create-repo-if-not-supported'. Adapt all callees. `vc-test--create-repo-if-not-supported'. Adapt all callees.
(vc-test--create-repo): Check also for revision-granularity. (vc-test--create-repo): Check also for revision-granularity.
(vc-test--unregister-function): Additional argument FILE. Adapt (vc-test--unregister-function): Additional argument FILE.
all callees. Adapt all callees.
(vc-test--working-revision): New defun. (vc-test--working-revision): New defun.
(vc-test-*-working-revision): New tests. (vc-test-*-working-revision): New tests.
@ -65,7 +73,7 @@
2014-11-21 Ulf Jasper <ulf.jasper@web.de> 2014-11-21 Ulf Jasper <ulf.jasper@web.de>
* automated/libxml-tests.el * automated/libxml-tests.el
(libxml-tests--data-comments-preserved): Renamed from (libxml-tests--data-comments-preserved): Rename from
'libxml-tests--data'. 'libxml-tests--data'.
(libxml-tests--data-comments-discarded): New. (libxml-tests--data-comments-discarded): New.
(libxml-tests): Check whether 'libxml-parse-xml-region' is (libxml-tests): Check whether 'libxml-parse-xml-region' is
@ -92,8 +100,8 @@
2014-11-17 Ulf Jasper <ulf.jasper@web.de> 2014-11-17 Ulf Jasper <ulf.jasper@web.de>
* automated/icalendar-tests.el (icalendar-tests--test-export): New * automated/icalendar-tests.el (icalendar-tests--test-export):
optional parameter `alarms'. New optional parameter `alarms'.
(icalendar-export-alarms): New test for exporting icalendar (icalendar-export-alarms): New test for exporting icalendar
alarms. alarms.
(icalendar-tests--test-cycle): Let `icalendar-export-alarms' be nil. (icalendar-tests--test-cycle): Let `icalendar-export-alarms' be nil.
@ -107,8 +115,8 @@
2014-11-16 Ulf Jasper <ulf.jasper@web.de> 2014-11-16 Ulf Jasper <ulf.jasper@web.de>
* automated/icalendar-tests.el (icalendar--parse-vtimezone): Add * automated/icalendar-tests.el (icalendar--parse-vtimezone):
testcase where offsets of standard time and daylight saving time Add testcase where offsets of standard time and daylight saving time
are equal. are equal.
(icalendar-real-world): Fix error in test case. Expected result (icalendar-real-world): Fix error in test case. Expected result
was wrong when offsets of standard time and daylight saving time was wrong when offsets of standard time and daylight saving time

45
test/automated/eieio-test-methodinvoke.el
View file

@ -61,9 +61,8 @@
"Store current invocation class symbol in the invocation order list." "Store current invocation class symbol in the invocation order list."
(let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ] (let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ]
(or eieio-generic-call-key 0))) (or eieio-generic-call-key 0)))
(c (list eieio-generic-call-methodname keysym (eieio--scoped-class)))) (c (list keysym (eieio--scoped-class))))
(setq eieio-test-method-order-list (push c eieio-test-method-order-list)))
(cons c eieio-test-method-order-list))))
(defun eieio-test-match (rightanswer) (defun eieio-test-match (rightanswer)
"Do a test match." "Do a test match."
@ -120,17 +119,17 @@
(ert-deftest eieio-test-method-order-list-3 () (ert-deftest eieio-test-method-order-list-3 ()
(let ((eieio-test-method-order-list nil) (let ((eieio-test-method-order-list nil)
(ans '( (ans '(
(eitest-F :BEFORE eitest-B) (:BEFORE eitest-B)
(eitest-F :BEFORE eitest-B-base1) (:BEFORE eitest-B-base1)
(eitest-F :BEFORE eitest-B-base2) (:BEFORE eitest-B-base2)
(eitest-F :PRIMARY eitest-B) (:PRIMARY eitest-B)
(eitest-F :PRIMARY eitest-B-base1) (:PRIMARY eitest-B-base1)
(eitest-F :PRIMARY eitest-B-base2) (:PRIMARY eitest-B-base2)
(eitest-F :AFTER eitest-B-base2) (:AFTER eitest-B-base2)
(eitest-F :AFTER eitest-B-base1) (:AFTER eitest-B-base1)
(eitest-F :AFTER eitest-B) (:AFTER eitest-B)
))) )))
(eitest-F (eitest-B nil)) (eitest-F (eitest-B nil))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
@ -193,9 +192,9 @@
(ert-deftest eieio-test-method-order-list-6 () (ert-deftest eieio-test-method-order-list-6 ()
(let ((eieio-test-method-order-list nil) (let ((eieio-test-method-order-list nil)
(ans '( (ans '(
(constructor :STATIC C) (:STATIC C)
(constructor :STATIC C-base1) (:STATIC C-base1)
(constructor :STATIC C-base2) (:STATIC C-base2)
))) )))
(C nil) (C nil)
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
@ -238,10 +237,10 @@
(ert-deftest eieio-test-method-order-list-7 () (ert-deftest eieio-test-method-order-list-7 ()
(let ((eieio-test-method-order-list nil) (let ((eieio-test-method-order-list nil)
(ans '( (ans '(
(eitest-F :PRIMARY D) (:PRIMARY D)
(eitest-F :PRIMARY D-base1) (:PRIMARY D-base1)
;; (eitest-F :PRIMARY D-base2) ;; (:PRIMARY D-base2)
(eitest-F :PRIMARY D-base0) (:PRIMARY D-base0)
))) )))
(eitest-F (D nil)) (eitest-F (D nil))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
@ -277,10 +276,10 @@
(ert-deftest eieio-test-method-order-list-8 () (ert-deftest eieio-test-method-order-list-8 ()
(let ((eieio-test-method-order-list nil) (let ((eieio-test-method-order-list nil)
(ans '( (ans '(
(eitest-F :PRIMARY E) (:PRIMARY E)
(eitest-F :PRIMARY E-base1) (:PRIMARY E-base1)
(eitest-F :PRIMARY E-base2) (:PRIMARY E-base2)
(eitest-F :PRIMARY E-base0) (:PRIMARY E-base0)
))) )))
(eitest-F (E nil)) (eitest-F (E nil))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))