Shrink EIEIO object header. Move generics to eieio-generic.el.
This commit is contained in:
Stefan Monnier
commit
a749f1c648
41 changed files with 2384 additions and 1987 deletions
5
etc/NEWS
5
etc/NEWS
|
|
@ -194,6 +194,11 @@ the old behavior -- *shell* buffer displays in current window -- use
|
|||
(add-to-list 'display-buffer-alist
|
||||
'("^\\*shell\\*$" . (display-buffer-same-window))).
|
||||
|
||||
|
||||
** EIEIO
|
||||
*** The <class>-list-p and <class>-child-p functions are declared obsolete.
|
||||
*** The <class> variables are declared obsolete.
|
||||
*** The <initarg> variables are declared obsolete.
|
||||
** ido
|
||||
*** New command `ido-bury-buffer-at-head' bound to C-S-b
|
||||
Bury the buffer at the head of `ido-matches', analogous to how C-k
|
||||
|
|
|
|||
256
lisp/ChangeLog
256
lisp/ChangeLog
|
|
@ -1,3 +1,255 @@
|
|||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/eieio.el (defclass): Move from eieio-defclass all the code
|
||||
that creates functions, and most of the sanity checks.
|
||||
Mark as obsolete the <class>-child-p function.
|
||||
* emacs-lisp/eieio-core.el (eieio--define-field-accessors): Remove.
|
||||
(eieio--class, eieio--object): Use cl-defstruct.
|
||||
(eieio--object-num-slots): Define manually.
|
||||
(eieio-defclass-autoload): Use eieio--class-make.
|
||||
(eieio-defclass-internal): Rename from eieio-defclass. Move all the
|
||||
`(lambda...) definitions and most of the sanity checks to `defclass'.
|
||||
Mark as obsolete the <class>-list-p function, the <class> variable and
|
||||
the <initarg> variables. Use pcase-dolist.
|
||||
(eieio-defclass): New compatibility function.
|
||||
* emacs-lisp/eieio-opt.el (eieio-build-class-alist)
|
||||
(eieio-class-speedbar): Don't use eieio-default-superclass var.
|
||||
|
||||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/eieio-generic.el: New file.
|
||||
* emacs-lisp/eieio-core.el: Move all generic function code to
|
||||
eieio-generic.el.
|
||||
(eieio--defmethod): Declare.
|
||||
|
||||
* emacs-lisp/eieio.el: Require eieio-generic. Move all generic
|
||||
function code to eieio-generic.el.
|
||||
* emacs-lisp/eieio-opt.el (eieio-help-generic): Move to
|
||||
eieio-generic.el.
|
||||
* emacs-lisp/eieio-datadebug.el (eieio-debug-methodinvoke): Update call
|
||||
to eieio--generic-call.
|
||||
* emacs-lisp/eieio-base.el (eieio-instance-inheritor): Don't use
|
||||
<class>-child type.
|
||||
|
||||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/chart.el (chart-add-sequence, chart-bar-quickie):
|
||||
Don't use <class> as a variable.
|
||||
|
||||
* emacs-lisp/eieio.el (same-class-p): Accept class object as well.
|
||||
(call-next-method): Simplify.
|
||||
(clone): Obey eieio-backward-compatibility.
|
||||
|
||||
* emacs-lisp/eieio-opt.el (eieio-read-generic-p): Remove.
|
||||
(eieio-read-generic): Use `generic-p' instead.
|
||||
|
||||
* emacs-lisp/eieio-core.el (eieio-backward-compatibility): New var.
|
||||
(eieio-defclass-autoload): Obey it.
|
||||
(eieio--class-object): Improve error behavior.
|
||||
(eieio-class-children-fast, same-class-fast-p): Remove. Inline at
|
||||
every use site.
|
||||
(eieio--defgeneric-form-primary-only): Rename from
|
||||
eieio-defgeneric-form-primary-only; update all callers.
|
||||
(eieio--defgeneric-form-primary-only-one): Rename from
|
||||
eieio-defgeneric-form-primary-only-one; update all callers.
|
||||
(eieio-defgeneric-reset-generic-form)
|
||||
(eieio-defgeneric-reset-generic-form-primary-only)
|
||||
(eieio-defgeneric-reset-generic-form-primary-only-one): Remove.
|
||||
(eieio--method-optimize-primary): New function to replace them.
|
||||
(eieio--defmethod, eieio-defmethod): Use it.
|
||||
(eieio--perform-slot-validation): Rename from
|
||||
eieio-perform-slot-validation; update all callers.
|
||||
(eieio--validate-slot-value): Rename from eieio-validate-slot-value.
|
||||
Change `class' to be a class object. Update all callers.
|
||||
(eieio--validate-class-slot-value): Rename from
|
||||
eieio-validate-class-slot-value. Change `class' to be a class object.
|
||||
Update all callers.
|
||||
(eieio-oset-default): Accept class object as well.
|
||||
(eieio--generic-call-primary-only): Rename from
|
||||
eieio-generic-call-primary-only. Update all callers.
|
||||
|
||||
* emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value):
|
||||
Improve error messages.
|
||||
(eieio-persistent-slot-type-is-class-p): Handle `list-of' types, as
|
||||
well as user-defined types. Emit errors for legacy types like
|
||||
<class>-child and <class>-list, if not eieio-backward-compatibility.
|
||||
|
||||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/eieio.el (eieio-class-parents): Accept class objects.
|
||||
(eieio--class-slot-initarg): Rename from class-slot-initarg.
|
||||
Change `class' arg to be a class object. Update all callers.
|
||||
(call-next-method): Adjust to new return value of `eieio-generic-form'.
|
||||
(eieio-default-superclass): Set var to the class object.
|
||||
(eieio-edebug-prin1-to-string): Fix recursive call for lists.
|
||||
Change print behavior to affect class objects rather than
|
||||
class symbols.
|
||||
|
||||
* emacs-lisp/eieio-core.el (eieio-class-object): New function.
|
||||
(eieio-class-parents-fast): Remove macro.
|
||||
(eieio--class-option-assoc): Rename from class-option-assoc.
|
||||
Update all callers.
|
||||
(eieio--class-option): Rename from class-option. Change `class' arg to
|
||||
be a class object. Update all callers.
|
||||
(eieio--class-method-invocation-order): Rename from
|
||||
class-method-invocation-order. Change `class' arg to be a class
|
||||
object. Update all callers.
|
||||
(eieio-defclass-autoload, eieio-defclass): Set the `parent' field to
|
||||
a list of class objects rather than names.
|
||||
(eieio-defclass): Remove redundant quotes. Use `eieio-oref-default'
|
||||
for accessors to class allocated slots.
|
||||
(eieio--perform-slot-validation-for-default): Rename from
|
||||
eieio-perform-slot-validation-for-default. Update all callers.
|
||||
(eieio--add-new-slot): Rename from eieio-add-new-slot.
|
||||
Update all callers. Use push.
|
||||
(eieio-copy-parents-into-subclass): Adjust to new content of
|
||||
`parent' field. Use dolist.
|
||||
(eieio-oref): Remove support for providing a class rather than
|
||||
an object.
|
||||
(eieio-oref-default): Prefer class objects over class names.
|
||||
(eieio--slot-originating-class-p): Rename from
|
||||
eieio-slot-originating-class-p. Update all callers. Use `or'.
|
||||
(eieio--slot-name-index): Turn check into assertion.
|
||||
(eieio--class-slot-name-index): Rename from
|
||||
eieio-class-slot-name-index. Change `class' arg to be a class object.
|
||||
Update all callers.
|
||||
(eieio-attribute-to-initarg): Move to eieio-test-persist.el.
|
||||
(eieio--c3-candidate): Rename from eieio-c3-candidate.
|
||||
Update all callers.
|
||||
(eieio--c3-merge-lists): Rename from eieio-c3-merge-lists.
|
||||
Update all callers.
|
||||
(eieio--class-precedence-c3): Rename from eieio-class-precedence-c3.
|
||||
Update all callers.
|
||||
(eieio--class-precedence-dfs): Rename from eieio-class-precedence-dfs.
|
||||
Update all callers.
|
||||
(eieio--class-precedence-bfs): Rename from eieio-class-precedence-bfs.
|
||||
Update all callers. Adjust to new `parent' content.
|
||||
(eieio--class-precedence-list): Rename from -class-precedence-list.
|
||||
Update all callers.
|
||||
(eieio-generic-call): Use autoloadp and autoload-do-load.
|
||||
Slight simplification.
|
||||
(eieio-generic-call, eieio-generic-call-primary-only): Adjust to new
|
||||
return value of `eieio-generic-form'.
|
||||
(eieiomt-add): Index the hashtable with class objects rather than
|
||||
class names.
|
||||
(eieio-generic-form): Accept class objects as well.
|
||||
|
||||
* emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object):
|
||||
Adjust to new convention for eieio-persistent-validate/fix-slot-value.
|
||||
(eieio-persistent-validate/fix-slot-value):
|
||||
Change `class' arg to be a class object. Update all callers.
|
||||
|
||||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/eieio.el (child-of-class-p): Make it accept class objects
|
||||
additionally to class names.
|
||||
|
||||
* emacs-lisp/eieio-core.el (eieio--with-scoped-class): Use let-binding.
|
||||
(object): Remove first (constant) slot; rename second to `class-tag'.
|
||||
(eieio--object-class-object, eieio--object-class-name): New funs
|
||||
to replace eieio--object-class.
|
||||
(eieio--class-object, eieio--class-p): New functions.
|
||||
(same-class-fast-p): Make it a defsubst, change its implementation
|
||||
to check the class objects rather than their names.
|
||||
(eieio-object-p): Rewrite.
|
||||
(eieio-defclass): Adjust the object initialization according to the new
|
||||
object layout.
|
||||
(eieio--scoped-class): Declare it returns a class object (not a class
|
||||
name any more). Adjust calls accordingly (along with calls to
|
||||
eieio--with-scoped-class).
|
||||
(eieio--slot-name-index): Rename from eieio-slot-name-index and change
|
||||
its class arg to be a class object. Adjust callers accordingly.
|
||||
(eieio-slot-originating-class-p): Make its start-class arg a class
|
||||
object. Adjust all callers.
|
||||
(eieio--initarg-to-attribute): Rename from eieio-initarg-to-attribute.
|
||||
Make its `class' arg a class object. Adjust all callers.
|
||||
|
||||
* emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value):
|
||||
Use eieio--slot-name-index rather than eieio-slot-name-index.
|
||||
|
||||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/eieio.el (make-instance): Simplify by not adding an object
|
||||
name argument.
|
||||
(eieio-object-name): Use eieio-object-name-string.
|
||||
(eieio--object-names): New const.
|
||||
(eieio-object-name-string, eieio-object-set-name-string): Re-implement
|
||||
using a hashtable rather than a built-in slot.
|
||||
(eieio-constructor): Rename from `constructor'. Remove `newname' arg.
|
||||
(clone): Don't mess with the object's "name".
|
||||
|
||||
* emacs-lisp/eieio-custom.el (eieio-widget-test): Remove dummy arg.
|
||||
(eieio-object-value-get): Use eieio-object-set-name-string.
|
||||
|
||||
* emacs-lisp/eieio-core.el (eieio--defalias): Follow aliases.
|
||||
(eieio--object): Remove `name' field.
|
||||
(eieio-defclass): Adjust to new convention where constructors don't
|
||||
take an "object name" any more.
|
||||
(eieio--defgeneric-init-form, eieio--defmethod): Follow aliases.
|
||||
(eieio-validate-slot-value, eieio-oset-default)
|
||||
(eieio-slot-name-index): Don't hardcode eieio--object-num-slots.
|
||||
(eieio-generic-call-primary-only): Simplify.
|
||||
|
||||
* emacs-lisp/eieio-base.el (clone) <eieio-instance-inheritor>:
|
||||
Use call-next-method.
|
||||
(eieio-constructor): Rename from `constructor'.
|
||||
(eieio-persistent-convert-list-to-object): Drop objname.
|
||||
(eieio-persistent-validate/fix-slot-value): Don't hardcode
|
||||
eieio--object-num-slots.
|
||||
(eieio-named): Use a normal slot.
|
||||
(slot-missing) <eieio-named>: Remove.
|
||||
(eieio-object-name-string, eieio-object-set-name-string, clone)
|
||||
<eieio-named>: New methods.
|
||||
|
||||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/eieio-core.el (eieio--class-v): Rename from class-v.
|
||||
(method-*): Add a "eieio--" prefix to those constants.
|
||||
|
||||
* emacs-lisp/eieio.el: Move edebug specs to the corresponding macro.
|
||||
|
||||
* emacs-lisp/eieio-speedbar.el: Use lexical-binding.
|
||||
|
||||
2015-01-08 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 $.
|
||||
|
||||
2015-01-08 Eli Zaretskii <eliz@gnu.org>
|
||||
|
||||
* simple.el (line-move-visual): When converting X pixel coordinate
|
||||
|
|
@ -609,8 +861,8 @@
|
|||
* electric.el (Electric-pop-up-window):
|
||||
* help.el (resize-temp-buffer-window): Call fit-window-to-buffer
|
||||
with `preserve-size' t.
|
||||
* minibuffer.el (minibuffer-completion-help): Use
|
||||
`resize-temp-buffer-window' instead of `fit-window-to-buffer'
|
||||
* minibuffer.el (minibuffer-completion-help):
|
||||
Use `resize-temp-buffer-window' instead of `fit-window-to-buffer'
|
||||
(Bug#19355). Preserve size of completions window.
|
||||
* register.el (register-preview): Preserve size of register
|
||||
preview window.
|
||||
|
|
|
|||
|
|
@ -1,3 +1,52 @@
|
|||
2015-01-07 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
Don't use <class> as a variable and don't assume that <class>-list-p is
|
||||
automatically defined.
|
||||
|
||||
* ede/speedbar.el (ede-speedbar-compile-line)
|
||||
(ede-speedbar-get-top-project-for-line):
|
||||
* ede.el (ede-buffer-belongs-to-target-p)
|
||||
(ede-buffer-belongs-to-project-p, ede-build-forms-menu)
|
||||
(ede-add-project-to-global-list):
|
||||
* semantic/db-typecache.el (semanticdb-get-typecache):
|
||||
* semantic/db-file.el (semanticdb-load-database):
|
||||
* semantic/db-el.el (semanticdb-elisp-sym->tag):
|
||||
* semantic/db-ebrowse.el (semanticdb-ebrowse-load-helper):
|
||||
* ede/project-am.el (project-am-preferred-target-type):
|
||||
* ede/proj.el (ede-proj-load):
|
||||
* ede/custom.el (ede-customize-current-target, ede-customize-target):
|
||||
* semantic/ede-grammar.el ("semantic grammar"):
|
||||
* semantic/scope.el (semantic-scope-reset-cache)
|
||||
(semantic-calculate-scope):
|
||||
* srecode/map.el (srecode-map-update-map):
|
||||
* srecode/insert.el (srecode-insert-show-error-report)
|
||||
(srecode-insert-method, srecode-insert-include-lookup)
|
||||
(srecode-insert-method):
|
||||
* srecode/fields.el (srecode-active-template-region):
|
||||
* srecode/compile.el (srecode-flush-active-templates)
|
||||
(srecode-compile-inserter): Don't use <class> as a variable.
|
||||
Use `oref-default' for class slots.
|
||||
|
||||
* semantic/grammar.el (semantic-grammar-eldoc-last-data): New var.
|
||||
(semantic-grammar-eldoc-get-macro-docstring): Use it instead of
|
||||
eldoc-last-data.
|
||||
* semantic/fw.el (semantic-exit-on-input): Use `declare'.
|
||||
(semantic-throw-on-input): Use `with-current-buffer'.
|
||||
* semantic/db.el (semanticdb-abstract-table-list): Define if not
|
||||
pre-defined.
|
||||
* semantic/db-find.el (semanticdb-find-tags-collector):
|
||||
Use save-current-buffer.
|
||||
(semanticdb-find-tags-collector): Don't use <class> as a variable.
|
||||
* semantic/complete.el (semantic-complete-active-default)
|
||||
(semantic-complete-current-matched-tag): Declare.
|
||||
(semantic-complete-inline-custom-type): Don't use <class> as a variable.
|
||||
* semantic/bovine/make.el (semantic-analyze-possible-completions):
|
||||
Use with-current-buffer.
|
||||
* semantic.el (semantic-parser-warnings): Declare.
|
||||
* ede/base.el (ede-target-list): Define if not pre-defined.
|
||||
(ede-with-projectfile): Prefer find-file-noselect over
|
||||
save-window-excursion.
|
||||
|
||||
2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* srecode/srt-mode.el (srecode-macro-help): Use eieio-class-children.
|
||||
|
|
|
|||
|
|
@ -248,12 +248,12 @@ Argument LIST-O-O is the list of objects to choose from."
|
|||
(let ((obj ede-object))
|
||||
(if (consp obj)
|
||||
(setq obj (car obj)))
|
||||
(and obj (obj-of-class-p obj ede-target))))
|
||||
(and obj (obj-of-class-p obj 'ede-target))))
|
||||
|
||||
(defun ede-buffer-belongs-to-project-p ()
|
||||
"Return non-nil if this buffer belongs to at least one project."
|
||||
(if (or (null ede-object) (consp ede-object)) nil
|
||||
(obj-of-class-p ede-object-project ede-project)))
|
||||
(obj-of-class-p ede-object-project 'ede-project)))
|
||||
|
||||
(defun ede-menu-obj-of-class-p (class)
|
||||
"Return non-nil if some member of `ede-object' is a child of CLASS."
|
||||
|
|
@ -281,7 +281,7 @@ Argument MENU-DEF is the menu definition to use."
|
|||
;; First, collect the build items from the project
|
||||
(setq newmenu (append newmenu (ede-menu-items-build obj t)))
|
||||
;; Second, declare the current target menu items
|
||||
(if (and ede-obj (ede-menu-obj-of-class-p ede-target))
|
||||
(if (and ede-obj (ede-menu-obj-of-class-p 'ede-target))
|
||||
(while ede-obj
|
||||
(setq newmenu (append newmenu
|
||||
(ede-menu-items-build (car ede-obj) t))
|
||||
|
|
@ -1078,7 +1078,7 @@ On success, return the added project."
|
|||
(error "No project created to add to master list"))
|
||||
(when (not (eieio-object-p proj))
|
||||
(error "Attempt to add non-object to master project list"))
|
||||
(when (not (obj-of-class-p proj ede-project-placeholder))
|
||||
(when (not (obj-of-class-p proj 'ede-project-placeholder))
|
||||
(error "Attempt to add a non-project to the ede projects list"))
|
||||
(add-to-list 'ede-projects proj)
|
||||
proj)
|
||||
|
|
@ -1099,6 +1099,8 @@ Flush the dead projects from the project cache."
|
|||
(ede-delete-project-from-global-list D))
|
||||
))
|
||||
|
||||
(defvar ede--disable-inode) ;Defined in ede/files.el.
|
||||
|
||||
(defun ede-global-list-sanity-check ()
|
||||
"Perform a sanity check to make sure there are no duplicate projects."
|
||||
(interactive)
|
||||
|
|
|
|||
|
|
@ -159,6 +159,9 @@ and querying them will cause the actual project to get loaded.")
|
|||
;; Projects can also affect how EDE works, by changing what appears in
|
||||
;; the EDE menu, or how some keys are bound.
|
||||
;;
|
||||
(unless (fboundp 'ede-target-list-p)
|
||||
(cl-deftype ede-target-list () '(list-of ede-target)))
|
||||
|
||||
(defclass ede-project (ede-project-placeholder)
|
||||
((subproj :initform nil
|
||||
:type list
|
||||
|
|
@ -287,16 +290,18 @@ All specific project types must derive from this project."
|
|||
;;
|
||||
(defmacro ede-with-projectfile (obj &rest forms)
|
||||
"For the project in which OBJ resides, execute FORMS."
|
||||
`(save-window-excursion
|
||||
(let* ((pf (if (obj-of-class-p ,obj ede-target)
|
||||
(ede-target-parent ,obj)
|
||||
,obj))
|
||||
(dbka (get-file-buffer (oref pf file))))
|
||||
(if (not dbka) (find-file (oref pf file))
|
||||
(switch-to-buffer dbka))
|
||||
(declare (indent 1))
|
||||
(unless (symbolp obj)
|
||||
(message "Beware! ede-with-projectfile's first arg is copied: %S" obj))
|
||||
`(let* ((pf (if (obj-of-class-p ,obj 'ede-target)
|
||||
(ede-target-parent ,obj)
|
||||
,obj))
|
||||
(dbka (get-file-buffer (oref pf file))))
|
||||
(with-current-buffer
|
||||
(if (not dbka) (find-file-noselect (oref pf file))
|
||||
dbka)
|
||||
,@forms
|
||||
(if (not dbka) (kill-buffer (current-buffer))))))
|
||||
(put 'ede-with-projectfile 'lisp-indent-function 1)
|
||||
|
||||
;;; The EDE persistent cache.
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@
|
|||
"Edit fields of the current target through EIEIO & Custom."
|
||||
(interactive)
|
||||
(require 'eieio-custom)
|
||||
(if (not (obj-of-class-p ede-object ede-target))
|
||||
(if (not (obj-of-class-p ede-object 'ede-target))
|
||||
(error "Current file is not part of a target"))
|
||||
(ede-customize-target ede-object))
|
||||
|
||||
|
|
@ -72,7 +72,7 @@
|
|||
"Edit fields of the current target through EIEIO & Custom.
|
||||
OBJ is the target object to customize."
|
||||
(require 'eieio-custom)
|
||||
(if (and obj (not (obj-of-class-p obj ede-target)))
|
||||
(if (and obj (not (obj-of-class-p obj 'ede-target)))
|
||||
(error "No logical target to customize"))
|
||||
(ede-customize obj))
|
||||
|
||||
|
|
|
|||
|
|
@ -297,7 +297,7 @@ for the tree being read in. If ROOTPROJ is nil, then assume that
|
|||
the PROJECT being read in is the root project."
|
||||
(save-excursion
|
||||
(let ((ret (eieio-persistent-read (concat project "Project.ede")
|
||||
ede-proj-project))
|
||||
'ede-proj-project))
|
||||
(subdirs (directory-files project nil "[^.].*" nil)))
|
||||
(if (not (object-of-class-p ret 'ede-proj-project))
|
||||
(error "Corrupt project file"))
|
||||
|
|
|
|||
|
|
@ -853,13 +853,13 @@ Argument FILE is the file to extract the end directory name from."
|
|||
(defun project-am-preferred-target-type (file)
|
||||
"For FILE, return the preferred type for that file."
|
||||
(cond ((string-match "\\.texi?\\(nfo\\)$" file)
|
||||
project-am-texinfo)
|
||||
'project-am-texinfo)
|
||||
((string-match "\\.[0-9]$" file)
|
||||
project-am-man)
|
||||
'project-am-man)
|
||||
((string-match "\\.el$" file)
|
||||
project-am-lisp)
|
||||
'project-am-lisp)
|
||||
(t
|
||||
project-am-program)))
|
||||
'project-am-program)))
|
||||
|
||||
(defmethod ede-buffer-header-file((this project-am-objectcode) buffer)
|
||||
"There are no default header files."
|
||||
|
|
|
|||
|
|
@ -121,9 +121,9 @@ Argument DIR is the directory from which to derive the list of objects."
|
|||
(let ((obj (eieio-speedbar-find-nearest-object)))
|
||||
(if (not (eieio-object-p obj))
|
||||
nil
|
||||
(cond ((obj-of-class-p obj ede-project)
|
||||
(cond ((obj-of-class-p obj 'ede-project)
|
||||
(project-compile-project obj))
|
||||
((obj-of-class-p obj ede-target)
|
||||
((obj-of-class-p obj 'ede-target)
|
||||
(project-compile-target obj))
|
||||
(t (error "Error in speedbar structure"))))))
|
||||
|
||||
|
|
@ -133,9 +133,9 @@ Argument DIR is the directory from which to derive the list of objects."
|
|||
(let ((obj (eieio-speedbar-find-nearest-object)))
|
||||
(if (not (eieio-object-p obj))
|
||||
(error "Error in speedbar or ede structure")
|
||||
(if (obj-of-class-p obj ede-target)
|
||||
(if (obj-of-class-p obj 'ede-target)
|
||||
(setq obj (ede-target-parent obj)))
|
||||
(if (obj-of-class-p obj ede-project)
|
||||
(if (obj-of-class-p obj 'ede-project)
|
||||
obj
|
||||
(error "Error in speedbar or ede structure")))))
|
||||
|
||||
|
|
|
|||
|
|
@ -573,6 +573,7 @@ string."
|
|||
;; The best way to call the parser from programs is via
|
||||
;; `semantic-fetch-tags'. This, in turn, uses other internal
|
||||
;; API functions which plug-in parsers can take advantage of.
|
||||
(defvar semantic-parser-warnings)
|
||||
|
||||
(defun semantic-fetch-tags ()
|
||||
"Fetch semantic tags from the current buffer.
|
||||
|
|
@ -602,49 +603,49 @@ was marked unparseable, then do nothing, and return the cache."
|
|||
(garbage-collect)
|
||||
(cond
|
||||
|
||||
;;;; Try the incremental parser to do a fast update.
|
||||
((semantic-parse-tree-needs-update-p)
|
||||
(setq res (semantic-parse-changes))
|
||||
(if (semantic-parse-tree-needs-rebuild-p)
|
||||
;; If the partial reparse fails, jump to a full reparse.
|
||||
(semantic-fetch-tags)
|
||||
;; Clear the cache of unmatched syntax tokens
|
||||
;;
|
||||
;; NOTE TO SELF:
|
||||
;;
|
||||
;; Move this into the incremental parser. This is a bug.
|
||||
;;
|
||||
(semantic-clear-unmatched-syntax-cache)
|
||||
(run-hook-with-args ;; Let hooks know the updated tags
|
||||
'semantic-after-partial-cache-change-hook res))
|
||||
(setq semantic--completion-cache nil))
|
||||
;; Try the incremental parser to do a fast update.
|
||||
((semantic-parse-tree-needs-update-p)
|
||||
(setq res (semantic-parse-changes))
|
||||
(if (semantic-parse-tree-needs-rebuild-p)
|
||||
;; If the partial reparse fails, jump to a full reparse.
|
||||
(semantic-fetch-tags)
|
||||
;; Clear the cache of unmatched syntax tokens
|
||||
;;
|
||||
;; NOTE TO SELF:
|
||||
;;
|
||||
;; Move this into the incremental parser. This is a bug.
|
||||
;;
|
||||
(semantic-clear-unmatched-syntax-cache)
|
||||
(run-hook-with-args ;; Let hooks know the updated tags
|
||||
'semantic-after-partial-cache-change-hook res))
|
||||
(setq semantic--completion-cache nil))
|
||||
|
||||
;;;; Parse the whole system.
|
||||
((semantic-parse-tree-needs-rebuild-p)
|
||||
;; Use Emacs's built-in progress-reporter (only interactive).
|
||||
(if noninteractive
|
||||
(setq res (semantic-parse-region (point-min) (point-max)))
|
||||
(let ((semantic--progress-reporter
|
||||
(and (>= (point-max) semantic-minimum-working-buffer-size)
|
||||
(eq semantic-working-type 'percent)
|
||||
(make-progress-reporter
|
||||
(semantic-parser-working-message (buffer-name))
|
||||
0 100))))
|
||||
(setq res (semantic-parse-region (point-min) (point-max)))
|
||||
(if semantic--progress-reporter
|
||||
(progress-reporter-done semantic--progress-reporter))))
|
||||
;; Parse the whole system.
|
||||
((semantic-parse-tree-needs-rebuild-p)
|
||||
;; Use Emacs's built-in progress-reporter (only interactive).
|
||||
(if noninteractive
|
||||
(setq res (semantic-parse-region (point-min) (point-max)))
|
||||
(let ((semantic--progress-reporter
|
||||
(and (>= (point-max) semantic-minimum-working-buffer-size)
|
||||
(eq semantic-working-type 'percent)
|
||||
(make-progress-reporter
|
||||
(semantic-parser-working-message (buffer-name))
|
||||
0 100))))
|
||||
(setq res (semantic-parse-region (point-min) (point-max)))
|
||||
(if semantic--progress-reporter
|
||||
(progress-reporter-done semantic--progress-reporter))))
|
||||
|
||||
;; Clear the caches when we see there were no errors.
|
||||
;; But preserve the unmatched syntax cache and warnings!
|
||||
(let (semantic-unmatched-syntax-cache
|
||||
semantic-unmatched-syntax-cache-check
|
||||
semantic-parser-warnings)
|
||||
(semantic-clear-toplevel-cache))
|
||||
;; Set up the new overlays
|
||||
(semantic--tag-link-list-to-buffer res)
|
||||
;; Set up the cache with the new results
|
||||
(semantic--set-buffer-cache res)
|
||||
))))
|
||||
;; Clear the caches when we see there were no errors.
|
||||
;; But preserve the unmatched syntax cache and warnings!
|
||||
(let (semantic-unmatched-syntax-cache
|
||||
semantic-unmatched-syntax-cache-check
|
||||
semantic-parser-warnings)
|
||||
(semantic-clear-toplevel-cache))
|
||||
;; Set up the new overlays
|
||||
(semantic--tag-link-list-to-buffer res)
|
||||
;; Set up the cache with the new results
|
||||
(semantic--set-buffer-cache res)
|
||||
))))
|
||||
|
||||
;; Always return the current parse tree.
|
||||
semantic--buffer-cache)
|
||||
|
|
|
|||
|
|
@ -178,9 +178,8 @@ This is the same as a regular prototype."
|
|||
makefile-mode (context)
|
||||
"Return a list of possible completions in a Makefile.
|
||||
Uses default implementation, and also gets a list of filenames."
|
||||
(save-excursion
|
||||
(require 'semantic/analyze/complete)
|
||||
(set-buffer (oref context buffer))
|
||||
(require 'semantic/analyze/complete)
|
||||
(with-current-buffer (oref context buffer)
|
||||
(let* ((normal (semantic-analyze-possible-completions-default context))
|
||||
(classes (oref context :prefixclass))
|
||||
(filetags nil))
|
||||
|
|
|
|||
|
|
@ -188,6 +188,8 @@ Value should be a ... what?")
|
|||
"Default history variable for any unhistoried prompt.
|
||||
Keeps STRINGS only in the history.")
|
||||
|
||||
(defvar semantic-complete-active-default)
|
||||
(defvar semantic-complete-current-matched-tag)
|
||||
|
||||
(defun semantic-complete-read-tag-engine (collector displayor prompt
|
||||
default-tag initial-input
|
||||
|
|
@ -1871,7 +1873,7 @@ completion text in ghost text."
|
|||
(list 'const
|
||||
:tag doc1
|
||||
C)))
|
||||
(eieio-build-class-alist semantic-displayor-abstract t))
|
||||
(eieio-build-class-alist 'semantic-displayor-abstract t))
|
||||
)
|
||||
"Possible options for inline completion displayors.
|
||||
Use this to enable custom editing.")
|
||||
|
|
|
|||
|
|
@ -192,7 +192,7 @@ is specified by `semanticdb-default-save-directory'."
|
|||
If DIRECTORY is found to be defunct, it won't load the DB, and will
|
||||
warn instead."
|
||||
(if (file-directory-p directory)
|
||||
(semanticdb-create-database semanticdb-project-database-ebrowse
|
||||
(semanticdb-create-database 'semanticdb-project-database-ebrowse
|
||||
directory)
|
||||
(let* ((BF (semanticdb-ebrowse-file-for-directory directory))
|
||||
(BFL (concat BF "-load.el"))
|
||||
|
|
|
|||
|
|
@ -225,7 +225,7 @@ TOKTYPE is a hint to the type of tag desired."
|
|||
(semantic-elisp-desymbolify
|
||||
;; FIXME: This only gives the instance slots and ignores the
|
||||
;; class-allocated slots.
|
||||
(eieio--class-public-a (find-class semanticdb-project-database))) ;; slots ;FIXME: eieio--
|
||||
(eieio--class-public-a (find-class 'semanticdb-project-database))) ;; slots ;FIXME: eieio--
|
||||
(semantic-elisp-desymbolify (eieio-class-parents sym)) ;; parents
|
||||
))
|
||||
((not toktype)
|
||||
|
|
|
|||
|
|
@ -158,7 +158,8 @@ If DIRECTORY doesn't exist, create a new one."
|
|||
(defun semanticdb-load-database (filename)
|
||||
"Load the database FILENAME."
|
||||
(condition-case foo
|
||||
(let* ((r (eieio-persistent-read filename semanticdb-project-database-file))
|
||||
(let* ((r (eieio-persistent-read filename
|
||||
'semanticdb-project-database-file))
|
||||
(c (semanticdb-get-database-tables r))
|
||||
(tv (oref r semantic-tag-version))
|
||||
(fv (oref r semanticdb-version))
|
||||
|
|
|
|||
|
|
@ -1114,7 +1114,7 @@ for backward compatibility.
|
|||
If optional argument BRUTISH is non-nil, then ignore include statements,
|
||||
and search all tables in this project tree."
|
||||
(let (found match)
|
||||
(save-excursion
|
||||
(save-current-buffer
|
||||
;; If path is a buffer, set ourselves up in that buffer
|
||||
;; so that the override methods work correctly.
|
||||
(when (bufferp path) (set-buffer path))
|
||||
|
|
@ -1127,7 +1127,7 @@ and search all tables in this project tree."
|
|||
;; databases and not associated with a file.
|
||||
(unless (and find-file-match
|
||||
(obj-of-class-p
|
||||
(car tableandtags) semanticdb-search-results-table))
|
||||
(car tableandtags) 'semanticdb-search-results-table))
|
||||
(when (setq match (funcall function
|
||||
(car tableandtags) (cdr tableandtags)))
|
||||
(when find-file-match
|
||||
|
|
@ -1144,7 +1144,7 @@ and search all tables in this project tree."
|
|||
;; `semanticdb-search-results-table', since those are system
|
||||
;; databases and not associated with a file.
|
||||
(unless (and find-file-match
|
||||
(obj-of-class-p table semanticdb-search-results-table))
|
||||
(obj-of-class-p table 'semanticdb-search-results-table))
|
||||
(when (and table (setq match (funcall function table nil)))
|
||||
(semanticdb-find-log-activity table match)
|
||||
(when find-file-match
|
||||
|
|
|
|||
|
|
@ -180,7 +180,7 @@ If there is no table, create one, and fill it in."
|
|||
(defmethod semanticdb-get-typecache ((db semanticdb-project-database))
|
||||
"Retrieve the typecache from the semantic database DB.
|
||||
If there is no table, create one, and fill it in."
|
||||
(semanticdb-cache-get db semanticdb-database-typecache)
|
||||
(semanticdb-cache-get db 'semanticdb-database-typecache)
|
||||
)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -330,6 +330,10 @@ Adds the number of tags in this file to the object print name."
|
|||
|
||||
;;; DATABASE BASE CLASS
|
||||
;;
|
||||
(unless (fboundp 'semanticdb-abstract-table-list-p)
|
||||
(cl-deftype semanticdb-abstract-table-list ()
|
||||
'(list-of semanticdb-abstract-table)))
|
||||
|
||||
(defclass semanticdb-project-database (eieio-instance-tracker)
|
||||
((tracking-symbol :initform semanticdb-database-list)
|
||||
(reference-directory :type string
|
||||
|
|
|
|||
|
|
@ -213,7 +213,7 @@ Argument THIS is the target that should insert stuff."
|
|||
;; "Target class for Emacs/Semantic grammar files." nil nil)
|
||||
|
||||
(ede-proj-register-target "semantic grammar"
|
||||
semantic-ede-proj-target-grammar)
|
||||
'semantic-ede-proj-target-grammar)
|
||||
|
||||
(provide 'semantic/ede-grammar)
|
||||
|
||||
|
|
|
|||
|
|
@ -378,11 +378,11 @@ If FORMS includes a call to `semantic-throw-on-input', then
|
|||
if a user presses any key during execution, this form macro
|
||||
will exit with the value passed to `semantic-throw-on-input'.
|
||||
If FORMS completes, then the return value is the same as `progn'."
|
||||
(declare (indent 1))
|
||||
`(let ((semantic-current-input-throw-symbol ,symbol)
|
||||
(semantic--on-input-start-marker (point-marker)))
|
||||
(catch ,symbol
|
||||
,@forms)))
|
||||
(put 'semantic-exit-on-input 'lisp-indent-function 1)
|
||||
|
||||
(defmacro semantic-throw-on-input (from)
|
||||
"Exit with `throw' when in `semantic-exit-on-input' on user input.
|
||||
|
|
@ -391,15 +391,14 @@ to pass to `throw'. It is recommended to use the name of the function
|
|||
calling this one."
|
||||
`(when (and semantic-current-input-throw-symbol
|
||||
(or (input-pending-p)
|
||||
(save-excursion
|
||||
;; Timers might run during accept-process-output.
|
||||
;; If they redisplay, point must be where the user
|
||||
;; expects. (Bug#15045)
|
||||
(set-buffer (marker-buffer
|
||||
semantic--on-input-start-marker))
|
||||
(goto-char (marker-position
|
||||
semantic--on-input-start-marker))
|
||||
(accept-process-output))))
|
||||
(with-current-buffer
|
||||
;; Timers might run during accept-process-output.
|
||||
;; If they redisplay, point must be where the user
|
||||
;; expects. (Bug#15045)
|
||||
(marker-buffer semantic--on-input-start-marker)
|
||||
(save-excursion
|
||||
(goto-char semantic--on-input-start-marker)
|
||||
(accept-process-output)))))
|
||||
(throw semantic-current-input-throw-symbol ,from)))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1665,13 +1665,14 @@ Select the buffer containing the tag's definition, and move point there."
|
|||
(declare-function eldoc-get-fnsym-args-string "eldoc")
|
||||
(declare-function eldoc-get-var-docstring "eldoc")
|
||||
|
||||
(defvar semantic-grammar-eldoc-last-data (cons nil nil))
|
||||
|
||||
(defun semantic-grammar-eldoc-get-macro-docstring (macro expander)
|
||||
"Return a one-line docstring for the given grammar MACRO.
|
||||
EXPANDER is the name of the function that expands MACRO."
|
||||
(require 'eldoc)
|
||||
(if (and (eq expander (aref eldoc-last-data 0))
|
||||
(eq 'function (aref eldoc-last-data 2)))
|
||||
(aref eldoc-last-data 1)
|
||||
(if (eq expander (car semantic-grammar-eldoc-last-data))
|
||||
(cdr semantic-grammar-eldoc-last-data)
|
||||
(let ((doc (help-split-fundoc (documentation expander t) expander)))
|
||||
(cond
|
||||
(doc
|
||||
|
|
@ -1684,7 +1685,7 @@ EXPANDER is the name of the function that expands MACRO."
|
|||
(setq doc
|
||||
(eldoc-docstring-format-sym-doc
|
||||
macro (format "==> %s %s" expander doc) 'default))
|
||||
(eldoc-last-data-store expander doc 'function))
|
||||
(setq semantic-grammar-eldoc-last-data (cons expander doc)))
|
||||
doc)))
|
||||
|
||||
(define-mode-local-override semantic-idle-summary-current-symbol-info
|
||||
|
|
|
|||
|
|
@ -134,7 +134,7 @@ Saves scoping information between runs of the analyzer.")
|
|||
"Get the current cached scope, and reset it."
|
||||
(when semanticdb-current-table
|
||||
(let ((co (semanticdb-cache-get semanticdb-current-table
|
||||
semantic-scope-cache)))
|
||||
'semantic-scope-cache)))
|
||||
(semantic-reset co))))
|
||||
|
||||
(defmethod semantic-scope-set-typecache ((cache semantic-scope-cache)
|
||||
|
|
@ -706,7 +706,7 @@ The class returned from the scope calculation is variable
|
|||
(let* ((TAG (semantic-current-tag))
|
||||
(scopecache
|
||||
(semanticdb-cache-get semanticdb-current-table
|
||||
semantic-scope-cache))
|
||||
'semantic-scope-cache))
|
||||
)
|
||||
(when (not (semantic-equivalent-tag-p TAG (oref scopecache tag)))
|
||||
(semantic-reset scopecache))
|
||||
|
|
|
|||
|
|
@ -87,10 +87,10 @@ for push, pop, and peek for the active template.")
|
|||
Useful if something goes wrong in SRecode, and the active template
|
||||
stack is broken."
|
||||
(interactive)
|
||||
(if (oref srecode-template active)
|
||||
(if (oref-default 'srecode-template active)
|
||||
(when (y-or-n-p (format "%d active templates. Flush? "
|
||||
(length (oref srecode-template active))))
|
||||
(oset-default srecode-template active nil))
|
||||
(length (oref-default 'srecode-template active))))
|
||||
(oset-default 'srecode-template active nil))
|
||||
(message "No active templates to flush."))
|
||||
)
|
||||
|
||||
|
|
@ -514,7 +514,7 @@ to the inserter constructor."
|
|||
;;(message "Compile: %s %S" name props)
|
||||
(if (not key)
|
||||
(apply 'srecode-template-inserter-variable name props)
|
||||
(let ((classes (eieio-class-children srecode-template-inserter))
|
||||
(let ((classes (eieio-class-children 'srecode-template-inserter))
|
||||
(new nil))
|
||||
;; Loop over the various subclasses and
|
||||
;; create the correct inserter.
|
||||
|
|
|
|||
|
|
@ -237,7 +237,7 @@ If SET-TO is a string, then replace the text of OLAID wit SET-TO."
|
|||
|
||||
(defsubst srecode-active-template-region ()
|
||||
"Return the active region for template fields."
|
||||
(oref srecode-template-inserted-region active-region))
|
||||
(oref-default 'srecode-template-inserted-region active-region))
|
||||
|
||||
(defun srecode-field-post-command ()
|
||||
"Srecode field handler in the post command hook."
|
||||
|
|
|
|||
|
|
@ -211,7 +211,7 @@ insertions."
|
|||
(propertize " (most recent at bottom)" 'face '(:slant italic))
|
||||
":\n")
|
||||
(data-debug-insert-stuff-list
|
||||
(reverse (oref srecode-template active)) "> ")
|
||||
(reverse (oref-default 'srecode-template active)) "> ")
|
||||
;; Show the current dictionary.
|
||||
(insert (propertize "Dictionary" 'face '(:weight bold)) "\n")
|
||||
(data-debug-insert-thing dictionary "" "> ")
|
||||
|
|
@ -396,7 +396,7 @@ Specify the :blank argument to enable this inserter.")
|
|||
(pm (point-marker)))
|
||||
(when (and inbuff
|
||||
;; Don't do this if we are not the active template.
|
||||
(= (length (oref srecode-template active)) 1))
|
||||
(= (length (oref-default 'srecode-template active)) 1))
|
||||
|
||||
(when (and (eq i t) inbuff (not (eq (oref sti where) 'begin)))
|
||||
(indent-according-to-mode)
|
||||
|
|
@ -773,7 +773,7 @@ generalized marker will do something else. See
|
|||
;; valid. Compare this to the actual template nesting depth and
|
||||
;; maybe use the override function which is stored in the cdr.
|
||||
(if (and srecode-template-inserter-point-override
|
||||
(<= (length (oref srecode-template active))
|
||||
(<= (length (oref-default 'srecode-template active))
|
||||
(car srecode-template-inserter-point-override)))
|
||||
;; Disable the old override while we do this.
|
||||
(let ((over (cdr srecode-template-inserter-point-override))
|
||||
|
|
@ -943,7 +943,7 @@ this template instance."
|
|||
;; Calculate and store the discovered template
|
||||
(let ((tmpl (srecode-template-get-table (srecode-table)
|
||||
templatenamepart))
|
||||
(active (oref srecode-template active))
|
||||
(active (oref-default 'srecode-template active))
|
||||
ctxt)
|
||||
(when (not tmpl)
|
||||
;; If it isn't just available, scan back through
|
||||
|
|
@ -1053,7 +1053,7 @@ template where a ^ inserter occurs."
|
|||
(lexical-let ((inserter1 sti))
|
||||
(cons
|
||||
;; DEPTH
|
||||
(+ (length (oref srecode-template active)) 1)
|
||||
(+ (length (oref-default 'srecode-template active)) 1)
|
||||
;; FUNCTION
|
||||
(lambda (dict)
|
||||
(let ((srecode-template-inserter-point-override nil))
|
||||
|
|
|
|||
|
|
@ -298,7 +298,7 @@ if that file is NEW, otherwise assume the mode has not changed."
|
|||
(when (not srecode-current-map)
|
||||
(condition-case nil
|
||||
(setq srecode-current-map
|
||||
(eieio-persistent-read srecode-map-save-file srecode-map))
|
||||
(eieio-persistent-read srecode-map-save-file 'srecode-map))
|
||||
(error
|
||||
;; There was an error loading the old map. Create a new one.
|
||||
(setq srecode-current-map
|
||||
|
|
|
|||
|
|
@ -422,7 +422,7 @@ or is created with the bounds of SEQ."
|
|||
(if (stringp (car (oref seq data)))
|
||||
(let ((labels (oref seq data)))
|
||||
(if (not axis)
|
||||
(setq axis (make-instance chart-axis-names
|
||||
(setq axis (make-instance 'chart-axis-names
|
||||
:name (oref seq name)
|
||||
:items labels
|
||||
:chart c))
|
||||
|
|
@ -430,7 +430,7 @@ or is created with the bounds of SEQ."
|
|||
(let ((range (cons 0 1))
|
||||
(l (oref seq data)))
|
||||
(if (not axis)
|
||||
(setq axis (make-instance chart-axis-range
|
||||
(setq axis (make-instance 'chart-axis-range
|
||||
:name (oref seq name)
|
||||
:chart c)))
|
||||
(while l
|
||||
|
|
@ -577,19 +577,19 @@ labeled NUMTITLE.
|
|||
Optional arguments:
|
||||
Set the chart's max element display to MAX, and sort lists with
|
||||
SORT-PRED if desired."
|
||||
(let ((nc (make-instance chart-bar
|
||||
(let ((nc (make-instance 'chart-bar
|
||||
:title title
|
||||
:key-label "8-m" ; This is a text key pic
|
||||
:direction dir
|
||||
))
|
||||
(iv (eq dir 'vertical)))
|
||||
(chart-add-sequence nc
|
||||
(make-instance chart-sequece
|
||||
(make-instance 'chart-sequece
|
||||
:data namelst
|
||||
:name nametitle)
|
||||
(if iv 'x-axis 'y-axis))
|
||||
(chart-add-sequence nc
|
||||
(make-instance chart-sequece
|
||||
(make-instance 'chart-sequece
|
||||
:data numlst
|
||||
:name numtitle)
|
||||
(if iv 'y-axis 'x-axis))
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@
|
|||
;; error if a slot is unbound.
|
||||
(defclass eieio-instance-inheritor ()
|
||||
((parent-instance :initarg :parent-instance
|
||||
:type eieio-instance-inheritor-child
|
||||
:type eieio-instance-inheritor
|
||||
:documentation
|
||||
"The parent of this instance.
|
||||
If a slot of this class is referenced, and is unbound, then the parent
|
||||
|
|
@ -63,25 +63,10 @@ SLOT-NAME is the offending slot. FN is the function signaling the error."
|
|||
;; Throw the regular signal.
|
||||
(call-next-method)))
|
||||
|
||||
(defmethod clone ((obj eieio-instance-inheritor) &rest params)
|
||||
(defmethod clone ((obj eieio-instance-inheritor) &rest _params)
|
||||
"Clone OBJ, initializing `:parent' to OBJ.
|
||||
All slots are unbound, except those initialized with PARAMS."
|
||||
(let ((nobj (make-vector (length obj) eieio-unbound))
|
||||
(nm (eieio--object-name obj))
|
||||
(passname (and params (stringp (car params))))
|
||||
(num 1))
|
||||
(aset nobj 0 'object)
|
||||
(setf (eieio--object-class nobj) (eieio--object-class obj))
|
||||
;; The following was copied from the default clone.
|
||||
(if (not passname)
|
||||
(save-match-data
|
||||
(if (string-match "-\\([0-9]+\\)" nm)
|
||||
(setq num (1+ (string-to-number (match-string 1 nm)))
|
||||
nm (substring nm 0 (match-beginning 0))))
|
||||
(setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
|
||||
(setf (eieio--object-name nobj) (car params)))
|
||||
;; Now initialize from params.
|
||||
(if params (shared-initialize nobj (if passname (cdr params) params)))
|
||||
(let ((nobj (call-next-method)))
|
||||
(oset nobj parent-instance obj)
|
||||
nobj))
|
||||
|
||||
|
|
@ -155,7 +140,7 @@ Multiple calls to `make-instance' will return this object."))
|
|||
A singleton is a class which will only ever have one instance."
|
||||
:abstract t)
|
||||
|
||||
(defmethod constructor :STATIC ((class eieio-singleton) _name &rest _slots)
|
||||
(defmethod eieio-constructor :STATIC ((class eieio-singleton) &rest _slots)
|
||||
"Constructor for singleton CLASS.
|
||||
NAME and SLOTS initialize the new object.
|
||||
This constructor guarantees that no matter how many you request,
|
||||
|
|
@ -270,7 +255,7 @@ malicious code.
|
|||
Note: This function recurses when a slot of :type of some object is
|
||||
identified, and needing more object creation."
|
||||
(let ((objclass (nth 0 inputlist))
|
||||
(objname (nth 1 inputlist))
|
||||
;; (objname (nth 1 inputlist))
|
||||
(slots (nthcdr 2 inputlist))
|
||||
(createslots nil))
|
||||
|
||||
|
|
@ -285,7 +270,7 @@ identified, and needing more object creation."
|
|||
;; In addition, strip out quotes, list functions, and update
|
||||
;; object constructors as needed.
|
||||
(setq value (eieio-persistent-validate/fix-slot-value
|
||||
objclass name value))
|
||||
(eieio--class-v objclass) name value))
|
||||
|
||||
(push name createslots)
|
||||
(push value createslots)
|
||||
|
|
@ -293,7 +278,7 @@ identified, and needing more object creation."
|
|||
|
||||
(setq slots (cdr (cdr slots))))
|
||||
|
||||
(apply 'make-instance objclass objname (nreverse createslots))
|
||||
(apply #'make-instance objclass (nreverse createslots))
|
||||
|
||||
;;(eval inputlist)
|
||||
))
|
||||
|
|
@ -305,11 +290,13 @@ constructor functions are considered valid.
|
|||
Second, any text properties will be stripped from strings."
|
||||
(cond ((consp proposed-value)
|
||||
;; Lists with something in them need special treatment.
|
||||
(let ((slot-idx (eieio-slot-name-index class nil slot))
|
||||
(let ((slot-idx (eieio--slot-name-index class
|
||||
nil slot))
|
||||
(type nil)
|
||||
(classtype nil))
|
||||
(setq slot-idx (- slot-idx 3))
|
||||
(setq type (aref (eieio--class-public-type (class-v class))
|
||||
(setq slot-idx (- slot-idx
|
||||
(eval-when-compile eieio--object-num-slots)))
|
||||
(setq type (aref (eieio--class-public-type class)
|
||||
slot-idx))
|
||||
|
||||
(setq classtype (eieio-persistent-slot-type-is-class-p
|
||||
|
|
@ -346,8 +333,8 @@ Second, any text properties will be stripped from strings."
|
|||
(unless (and
|
||||
;; Do we have a type?
|
||||
(consp classtype) (class-p (car classtype)))
|
||||
(error "In save file, list of object constructors found, but no :type specified for slot %S"
|
||||
slot))
|
||||
(error "In save file, list of object constructors found, but no :type specified for slot %S of type %S"
|
||||
slot classtype))
|
||||
|
||||
;; We have a predicate, but it doesn't satisfy the predicate?
|
||||
(dolist (PV (cdr proposed-value))
|
||||
|
|
@ -375,31 +362,49 @@ Second, any text properties will be stripped from strings."
|
|||
)
|
||||
|
||||
(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."
|
||||
(cond ((class-p type)
|
||||
;; If the type is a class, then return it.
|
||||
type)
|
||||
((and (eq 'list-of (car-safe type)) (class-p (cadr type)))
|
||||
;; If it is the type of a list of a class, then return that class and
|
||||
;; the type.
|
||||
(cons (cadr type) type))
|
||||
|
||||
((and (symbolp type) (string-match "-child$" (symbol-name type))
|
||||
((and (symbolp type) (get type 'cl-deftype-handler))
|
||||
;; Macro-expand the type according to cl-deftype definitions.
|
||||
(eieio-persistent-slot-type-is-class-p
|
||||
(funcall (get type 'cl-deftype-handler))))
|
||||
|
||||
;; FIXME: foo-child should not be a valid type!
|
||||
((and (symbolp type) (string-match "-child\\'" (symbol-name type))
|
||||
(class-p (intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0)))))
|
||||
(unless eieio-backward-compatibility
|
||||
(error "Use of bogus %S type instead of %S"
|
||||
type (intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0)))))
|
||||
;; If it is the predicate ending with -child, then return
|
||||
;; that class. Unfortunately, in EIEIO, typep of just the
|
||||
;; class is the same as if we used -child, so no further work needed.
|
||||
(intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0))))
|
||||
|
||||
((and (symbolp type) (string-match "-list$" (symbol-name type))
|
||||
;; FIXME: foo-list should not be a valid type!
|
||||
((and (symbolp type) (string-match "-list\\'" (symbol-name type))
|
||||
(class-p (intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0)))))
|
||||
(unless eieio-backward-compatibility
|
||||
(error "Use of bogus %S type instead of (list-of %S)"
|
||||
type (intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0)))))
|
||||
;; If it is the predicate ending with -list, then return
|
||||
;; that class and the predicate to use.
|
||||
(cons (intern-soft (substring (symbol-name type) 0
|
||||
(match-beginning 0)))
|
||||
type))
|
||||
|
||||
((and (consp type) (eq (car type) 'or))
|
||||
((eq (car-safe type) 'or)
|
||||
;; If type is a list, and is an or, it is possibly something
|
||||
;; like (or null myclass), so check for that.
|
||||
(let ((ans nil))
|
||||
|
|
@ -463,34 +468,38 @@ instance."
|
|||
|
||||
|
||||
;;; Named object
|
||||
;;
|
||||
;; Named objects use the objects `name' as a slot, and that slot
|
||||
;; is accessed with the `object-name' symbol.
|
||||
|
||||
(defclass eieio-named ()
|
||||
()
|
||||
"Object with a name.
|
||||
Name storage already occurs in an object. This object provides get/set
|
||||
access to it."
|
||||
((object-name :initarg :object-name :initform nil))
|
||||
"Object with a name."
|
||||
:abstract t)
|
||||
|
||||
(defmethod slot-missing ((obj eieio-named)
|
||||
slot-name operation &optional new-value)
|
||||
"Called when a non-existent slot is accessed.
|
||||
For variable `eieio-named', provide an imaginary `object-name' slot.
|
||||
Argument OBJ is the named object.
|
||||
Argument SLOT-NAME is the slot that was attempted to be accessed.
|
||||
OPERATION is the type of access, such as `oref' or `oset'.
|
||||
NEW-VALUE is the value that was being set into SLOT if OPERATION were
|
||||
a set type."
|
||||
(if (memq slot-name '(object-name :object-name))
|
||||
(cond ((eq operation 'oset)
|
||||
(if (not (stringp new-value))
|
||||
(signal 'invalid-slot-type
|
||||
(list obj slot-name 'string new-value)))
|
||||
(eieio-object-set-name-string obj new-value))
|
||||
(t (eieio-object-name-string obj)))
|
||||
(call-next-method)))
|
||||
(defmethod eieio-object-name-string ((obj eieio-named))
|
||||
"Return a string which is OBJ's name."
|
||||
(or (slot-value obj 'object-name)
|
||||
(symbol-name (eieio-object-class obj))))
|
||||
|
||||
(defmethod eieio-object-set-name-string ((obj eieio-named) name)
|
||||
"Set the string which is OBJ's NAME."
|
||||
(eieio--check-type stringp name)
|
||||
(eieio-oset obj 'object-name name))
|
||||
|
||||
(defmethod clone ((obj eieio-named) &rest params)
|
||||
"Clone OBJ, initializing `:parent' to OBJ.
|
||||
All slots are unbound, except those initialized with PARAMS."
|
||||
(let* ((newname (and (stringp (car params)) (pop params)))
|
||||
(nobj (apply #'call-next-method obj params))
|
||||
(nm (slot-value obj 'object-name)))
|
||||
(eieio-oset obj 'object-name
|
||||
(or newname
|
||||
(save-match-data
|
||||
(if (and nm (string-match "-\\([0-9]+\\)" nm))
|
||||
(let ((num (1+ (string-to-number
|
||||
(match-string 1 nm)))))
|
||||
(concat (substring nm 0 (match-beginning 0))
|
||||
"-" (int-to-string num)))
|
||||
(concat nm "-1")))))
|
||||
nobj))
|
||||
|
||||
(provide 'eieio-base)
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -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-2015 Free Software Foundation,
|
||||
;; Inc.
|
||||
|
|
@ -70,7 +70,7 @@ of these.")
|
|||
:documentation "A number of thingies."))
|
||||
"A class for testing the widget on.")
|
||||
|
||||
(defcustom eieio-widget-test (eieio-widget-test-class "Foo")
|
||||
(defcustom eieio-widget-test (eieio-widget-test-class)
|
||||
"Test variable for editing an object."
|
||||
:type 'object
|
||||
:group 'eieio)
|
||||
|
|
@ -136,7 +136,7 @@ Updates occur regardless of the current customization group.")
|
|||
))
|
||||
(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.
|
||||
Optional argument IGNORE is an extraneous parameter."
|
||||
(eieio-custom-toggle-hide (widget-get widget :parent)))
|
||||
|
|
@ -154,7 +154,7 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
:clone-object-children nil
|
||||
)
|
||||
|
||||
(defun eieio-object-match (widget value)
|
||||
(defun eieio-object-match (_widget _value)
|
||||
"Match info for WIDGET against VALUE."
|
||||
;; Write me
|
||||
t)
|
||||
|
|
@ -193,7 +193,7 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
(let* ((chil nil)
|
||||
(obj (widget-get widget :value))
|
||||
(master-group (widget-get widget :eieio-group))
|
||||
(cv (class-v (eieio--object-class obj)))
|
||||
(cv (eieio--object-class-object obj))
|
||||
(slots (eieio--class-public-a cv))
|
||||
(flabel (eieio--class-public-custom-label cv))
|
||||
(fgroup (eieio--class-public-custom-group cv))
|
||||
|
|
@ -208,7 +208,8 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
chil)))
|
||||
;; Display information about the group being shown
|
||||
(when master-group
|
||||
(let ((groups (class-option (eieio--object-class obj) :custom-groups)))
|
||||
(let ((groups (eieio--class-option (eieio--object-class-object obj)
|
||||
:custom-groups)))
|
||||
(widget-insert "Groups:")
|
||||
(while groups
|
||||
(widget-insert " ")
|
||||
|
|
@ -216,7 +217,7 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
(widget-insert "*" (capitalize (symbol-name master-group)) "*")
|
||||
(widget-create 'push-button
|
||||
:thing (cons obj (car groups))
|
||||
:notify (lambda (widget &rest stuff)
|
||||
:notify (lambda (widget &rest _)
|
||||
(eieio-customize-object
|
||||
(car (widget-get widget :thing))
|
||||
(cdr (widget-get widget :thing))))
|
||||
|
|
@ -260,8 +261,8 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
(car flabel)
|
||||
(let ((s (symbol-name
|
||||
(or
|
||||
(class-slot-initarg
|
||||
(eieio--object-class obj)
|
||||
(eieio--class-slot-initarg
|
||||
(eieio--object-class-object obj)
|
||||
(car slots))
|
||||
(car slots)))))
|
||||
(capitalize
|
||||
|
|
@ -288,7 +289,7 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
"Get the value of WIDGET."
|
||||
(let* ((obj (widget-get widget :value))
|
||||
(master-group eieio-cog)
|
||||
(cv (class-v (eieio--object-class obj)))
|
||||
(cv (eieio--object-class-object obj))
|
||||
(fgroup (eieio--class-public-custom-group cv))
|
||||
(wids (widget-get widget :children))
|
||||
(name (if (widget-get widget :eieio-show-name)
|
||||
|
|
@ -296,7 +297,7 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
nil))
|
||||
(chil (if (widget-get widget :eieio-show-name)
|
||||
(nthcdr 1 wids) wids))
|
||||
(cv (class-v (eieio--object-class obj)))
|
||||
(cv (eieio--object-class-object obj))
|
||||
(slots (eieio--class-public-a cv))
|
||||
(fcust (eieio--class-public-custom cv)))
|
||||
;; If there are any prefix widgets, clear them.
|
||||
|
|
@ -317,11 +318,11 @@ Optional argument IGNORE is an extraneous parameter."
|
|||
fgroup (cdr fgroup)
|
||||
fcust (cdr fcust)))
|
||||
;; Set any name updates on it.
|
||||
(if name (setf (eieio--object-name obj) name))
|
||||
(if name (eieio-object-set-name-string obj name))
|
||||
;; This is the same object we had before.
|
||||
obj))
|
||||
|
||||
(defmethod eieio-done-customizing ((obj eieio-default-superclass))
|
||||
(defmethod eieio-done-customizing ((_obj eieio-default-superclass))
|
||||
"When applying change to a widget, call this method.
|
||||
This method is called by the default widget-edit commands.
|
||||
User made commands should also call this method when applying changes.
|
||||
|
|
@ -385,18 +386,18 @@ These groups are specified with the `:group' slot flag."
|
|||
(make-local-variable 'eieio-cog)
|
||||
(setq eieio-cog g)))
|
||||
|
||||
(defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass))
|
||||
(defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass))
|
||||
"Insert an Apply and Reset button into the object editor.
|
||||
Argument OBJ is the object being customized."
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
:notify (lambda (&rest _)
|
||||
(widget-apply eieio-wo :value-get)
|
||||
(eieio-done-customizing eieio-co)
|
||||
(bury-buffer))
|
||||
"Accept")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
:notify (lambda (&rest _)
|
||||
;; I think the act of getting it sets
|
||||
;; its value through the get function.
|
||||
(message "Applying Changes...")
|
||||
|
|
@ -406,13 +407,13 @@ Argument OBJ is the object being customized."
|
|||
"Apply")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
:notify (lambda (&rest _)
|
||||
(message "Resetting")
|
||||
(eieio-customize-object eieio-co eieio-cog))
|
||||
"Reset")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
:notify (lambda (&rest _)
|
||||
(bury-buffer))
|
||||
"Cancel"))
|
||||
|
||||
|
|
@ -431,13 +432,11 @@ Must return the created widget."
|
|||
: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."
|
||||
(if (eieio-object-p value) value
|
||||
(if (null value) value
|
||||
nil)))
|
||||
(if (eieio-object-p value) value))
|
||||
|
||||
(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."
|
||||
value)
|
||||
|
||||
|
|
@ -453,7 +452,7 @@ Must return the created widget."
|
|||
(vector (concat "Group " (symbol-name group))
|
||||
(list 'customize-object obj (list 'quote group))
|
||||
t))
|
||||
(class-option (eieio--object-class obj) :custom-groups)))
|
||||
(eieio--class-option (eieio--object-class-object obj) :custom-groups)))
|
||||
|
||||
(defvar eieio-read-custom-group-history nil
|
||||
"History for the custom group reader.")
|
||||
|
|
@ -461,7 +460,8 @@ Must return the created widget."
|
|||
(defmethod eieio-read-customization-group ((obj eieio-default-superclass))
|
||||
"Do a completing read on the name of a customization group in OBJ.
|
||||
Return the symbol for the group, or nil"
|
||||
(let ((g (class-option (eieio--object-class obj) :custom-groups)))
|
||||
(let ((g (eieio--class-option (eieio--object-class-object obj)
|
||||
:custom-groups)))
|
||||
(if (= (length g) 1)
|
||||
(car g)
|
||||
;; Make the association list
|
||||
|
|
|
|||
|
|
@ -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-2015 Free Software Foundation, Inc.
|
||||
|
||||
|
|
@ -87,7 +87,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
|
|||
prefix
|
||||
"Name: ")
|
||||
(let* ((cl (eieio-object-class obj))
|
||||
(cv (class-v cl)))
|
||||
(cv (eieio--class-v cl)))
|
||||
(data-debug-insert-thing (class-constructor cl)
|
||||
prefix
|
||||
"Class: ")
|
||||
|
|
@ -96,7 +96,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
|
|||
)
|
||||
(while publa
|
||||
(if (slot-boundp obj (car publa))
|
||||
(let* ((i (class-slot-initarg cl (car publa)))
|
||||
(let* ((i (eieio--class-slot-initarg (eieio--class-v cl)
|
||||
(car publa)))
|
||||
(v (eieio-oref obj (car publa))))
|
||||
(data-debug-insert-thing
|
||||
v prefix (concat
|
||||
|
|
@ -104,7 +105,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
|
|||
(symbol-name (car publa)))
|
||||
" ")))
|
||||
;; Unbound case
|
||||
(let ((i (class-slot-initarg cl (car publa))))
|
||||
(let ((i (eieio--class-slot-initarg (eieio--class-v cl)
|
||||
(car publa))))
|
||||
(data-debug-insert-custom
|
||||
"#unbound" prefix
|
||||
(concat (if i (symbol-name i)
|
||||
|
|
@ -135,9 +137,9 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
|
|||
(let* ((eieio-pre-method-execution-functions
|
||||
(lambda (l) (throw 'moose l) ))
|
||||
(data
|
||||
(catch 'moose (eieio-generic-call
|
||||
(catch 'moose (eieio--generic-call
|
||||
method (list class))))
|
||||
(buf (data-debug-new-buffer "*Method Invocation*"))
|
||||
(_buf (data-debug-new-buffer "*Method Invocation*"))
|
||||
(data2 (mapcar (lambda (sym)
|
||||
(symbol-function (car sym)))
|
||||
data)))
|
||||
|
|
|
|||
904
lisp/emacs-lisp/eieio-generic.el
Normal file
904
lisp/emacs-lisp/eieio-generic.el
Normal file
|
|
@ -0,0 +1,904 @@
|
|||
;;; eieio-generic.el --- CLOS-style generics for EIEIO -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Keywords: OO, lisp
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; The "core" part of EIEIO is the implementation for the object
|
||||
;; system (such as eieio-defclass, or eieio-defmethod) but not the
|
||||
;; base classes for the object system, which are defined in EIEIO.
|
||||
;;
|
||||
;; See the commentary for eieio.el for more about EIEIO itself.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'eieio-core)
|
||||
(declare-function child-of-class-p "eieio")
|
||||
|
||||
(defconst eieio--method-static 0 "Index into :static tag on a method.")
|
||||
(defconst eieio--method-before 1 "Index into :before tag on a method.")
|
||||
(defconst eieio--method-primary 2 "Index into :primary tag on a method.")
|
||||
(defconst eieio--method-after 3 "Index into :after tag on a method.")
|
||||
(defconst eieio--method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.")
|
||||
(defconst eieio--method-generic-before 4 "Index into generic :before tag on a method.")
|
||||
(defconst eieio--method-generic-primary 5 "Index into generic :primary tag on a method.")
|
||||
(defconst eieio--method-generic-after 6 "Index into generic :after tag on a method.")
|
||||
(defconst eieio--method-num-slots 7 "Number of indexes into a method's vector.")
|
||||
|
||||
(defsubst eieio--specialized-key-to-generic-key (key)
|
||||
"Convert a specialized KEY into a generic method key."
|
||||
(cond ((eq key eieio--method-static) 0) ;; don't convert
|
||||
((< key eieio--method-num-lists) (+ key 3)) ;; The conversion
|
||||
(t key) ;; already generic.. maybe.
|
||||
))
|
||||
|
||||
|
||||
(defsubst generic-p (method)
|
||||
"Return non-nil if symbol METHOD is a generic function.
|
||||
Only methods have the symbol `eieio-method-hashtable' as a property
|
||||
\(which contains a list of all bindings to that method type.)"
|
||||
(and (fboundp method) (get method 'eieio-method-hashtable)))
|
||||
|
||||
(defun eieio--generic-primary-only-p (method)
|
||||
"Return t if symbol METHOD is a generic function with only primary methods.
|
||||
Only methods have the symbol `eieio-method-hashtable' as a property (which
|
||||
contains a list of all bindings to that method type.)
|
||||
Methods with only primary implementations are executed in an optimized way."
|
||||
(and (generic-p method)
|
||||
(let ((M (get method 'eieio-method-tree)))
|
||||
(not (or (>= 0 (length (aref M eieio--method-primary)))
|
||||
(aref M eieio--method-static)
|
||||
(aref M eieio--method-before)
|
||||
(aref M eieio--method-after)
|
||||
(aref M eieio--method-generic-before)
|
||||
(aref M eieio--method-generic-primary)
|
||||
(aref M eieio--method-generic-after)))
|
||||
)))
|
||||
|
||||
(defun eieio--generic-primary-only-one-p (method)
|
||||
"Return t if symbol METHOD is a generic function with only primary methods.
|
||||
Only methods have the symbol `eieio-method-hashtable' as a property (which
|
||||
contains a list of all bindings to that method type.)
|
||||
Methods with only primary implementations are executed in an optimized way."
|
||||
(and (generic-p method)
|
||||
(let ((M (get method 'eieio-method-tree)))
|
||||
(not (or (/= 1 (length (aref M eieio--method-primary)))
|
||||
(aref M eieio--method-static)
|
||||
(aref M eieio--method-before)
|
||||
(aref M eieio--method-after)
|
||||
(aref M eieio--method-generic-before)
|
||||
(aref M eieio--method-generic-primary)
|
||||
(aref M eieio--method-generic-after)))
|
||||
)))
|
||||
|
||||
(defun eieio--defgeneric-init-form (method doc-string)
|
||||
"Form to use for the initial definition of a generic."
|
||||
(while (and (fboundp method) (symbolp (symbol-function method)))
|
||||
;; Follow aliases, so methods applied to obsolete aliases still work.
|
||||
(setq method (symbol-function method)))
|
||||
|
||||
(cond
|
||||
((or (not (fboundp method))
|
||||
(eq 'autoload (car-safe (symbol-function method))))
|
||||
;; Make sure the method tables are installed.
|
||||
(eieio--mt-install method)
|
||||
;; Construct the actual body of this function.
|
||||
(put method 'function-documentation doc-string)
|
||||
(eieio--defgeneric-form method))
|
||||
((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)
|
||||
"The lambda form that would be used as the function defined on METHOD.
|
||||
All methods should call the same EIEIO function for dispatch.
|
||||
DOC-STRING is the documentation attached to METHOD."
|
||||
(lambda (&rest local-args)
|
||||
(eieio--generic-call method local-args)))
|
||||
|
||||
(defun eieio--defgeneric-form-primary-only (method)
|
||||
"The lambda form that would be used as the function defined on METHOD.
|
||||
All methods should call the same EIEIO function for dispatch.
|
||||
DOC-STRING is the documentation attached to METHOD."
|
||||
(lambda (&rest local-args)
|
||||
(eieio--generic-call-primary-only method local-args)))
|
||||
|
||||
(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.")
|
||||
|
||||
(defun eieio--defgeneric-form-primary-only-one (method class impl)
|
||||
"The lambda form that would be used as the function defined on METHOD.
|
||||
All methods should call the same EIEIO function for dispatch.
|
||||
CLASS is the class symbol needed for private method access.
|
||||
IMPL is the symbol holding the method implementation."
|
||||
(lambda (&rest local-args)
|
||||
;; 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
|
||||
;; instead make that determination at load time when there is
|
||||
;; only one method. If the first arg is not a child of the class
|
||||
;; 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 method local-args))
|
||||
|
||||
;; We do have an object. Make sure it is the right type.
|
||||
(if (not (child-of-class-p (eieio--object-class-object (car local-args))
|
||||
class))
|
||||
|
||||
;; If not the right kind of object, call no applicable
|
||||
(apply #'no-applicable-method (car local-args)
|
||||
method local-args)
|
||||
|
||||
;; It is ok, do the call.
|
||||
;; Fill in inter-call variables then evaluate the method.
|
||||
(let ((eieio--generic-call-next-method-list nil)
|
||||
(eieio--generic-call-key eieio--method-primary)
|
||||
(eieio--generic-call-arglst local-args)
|
||||
)
|
||||
(eieio--with-scoped-class (eieio--class-v class)
|
||||
(apply impl local-args)))))))
|
||||
|
||||
(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."
|
||||
(put method 'eieio-method-tree nil)
|
||||
(put method 'eieio-method-hashtable nil))
|
||||
|
||||
(defun eieio--method-optimize-primary (method)
|
||||
(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.
|
||||
(let ((doc-string (documentation method 'raw)))
|
||||
(put method 'function-documentation doc-string)
|
||||
;; Use `defalias' so as to interact properly with nadvice.el.
|
||||
(defalias method
|
||||
(if (eieio--generic-primary-only-p method)
|
||||
;; If there is only one primary method, then we can go one more
|
||||
;; optimization step.
|
||||
(if (eieio--generic-primary-only-one-p method)
|
||||
(let* ((M (get method 'eieio-method-tree))
|
||||
(entry (car (aref M eieio--method-primary))))
|
||||
(eieio--defgeneric-form-primary-only-one
|
||||
method (car entry) (cdr entry)))
|
||||
(eieio--defgeneric-form-primary-only method))
|
||||
(eieio--defgeneric-form method))))))
|
||||
|
||||
(defun eieio--defmethod (method kind argclass code)
|
||||
"Work part of the `defmethod' macro defining METHOD with ARGS."
|
||||
(let ((key
|
||||
;; Find optional keys.
|
||||
(cond ((memq kind '(:BEFORE :before)) eieio--method-before)
|
||||
((memq kind '(:AFTER :after)) eieio--method-after)
|
||||
((memq kind '(:STATIC :static)) eieio--method-static)
|
||||
((memq kind '(:PRIMARY :primary nil)) eieio--method-primary)
|
||||
;; Primary key.
|
||||
;; (t eieio--method-primary)
|
||||
(t (error "Unknown method kind %S" kind)))))
|
||||
|
||||
(while (and (fboundp method) (symbolp (symbol-function method)))
|
||||
;; Follow aliases, so methods applied to obsolete aliases still work.
|
||||
(setq method (symbol-function method)))
|
||||
|
||||
;; 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.
|
||||
(if argclass
|
||||
(if (not (class-p argclass)) ;FIXME: Accept cl-defstructs!
|
||||
(error "Unknown class type %s in method parameters"
|
||||
argclass))
|
||||
;; Generics are higher.
|
||||
(setq key (eieio--specialized-key-to-generic-key key)))
|
||||
;; Put this lambda into the symbol so we can find it.
|
||||
(eieio--mt-add method code key argclass)
|
||||
)
|
||||
|
||||
(eieio--method-optimize-primary method)
|
||||
|
||||
method)
|
||||
|
||||
(define-obsolete-variable-alias 'eieio-pre-method-execution-hooks
|
||||
'eieio-pre-method-execution-functions "24.3")
|
||||
(defvar eieio-pre-method-execution-functions nil
|
||||
"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.")
|
||||
|
||||
(defun eieio--generic-call (method args)
|
||||
"Call METHOD with ARGS.
|
||||
ARGS provides the context on which implementation to use.
|
||||
This should only be called from a generic function."
|
||||
;; We must expand our arguments first as they are always
|
||||
;; passed in as quoted symbols
|
||||
(let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil)
|
||||
(eieio--generic-call-arglst args)
|
||||
(firstarg nil)
|
||||
(primarymethodlist nil))
|
||||
;; get a copy
|
||||
(setq newargs args
|
||||
firstarg (car newargs))
|
||||
;; Is the class passed in autoloaded?
|
||||
;; Since class names are also constructors, they can be autoloaded
|
||||
;; via the autoload command. Check for this, and load them in.
|
||||
;; It is ok if it doesn't turn out to be a class. Probably want that
|
||||
;; function loaded anyway.
|
||||
(if (and (symbolp firstarg)
|
||||
(fboundp firstarg)
|
||||
(autoloadp (symbol-function firstarg)))
|
||||
(autoload-do-load (symbol-function firstarg)))
|
||||
;; Determine the class to use.
|
||||
(cond ((eieio-object-p firstarg)
|
||||
(setq mclass (eieio--object-class-name firstarg)))
|
||||
((class-p firstarg)
|
||||
(setq mclass firstarg))
|
||||
)
|
||||
;; Make sure the class is a valid class
|
||||
;; mclass can be nil (meaning a generic for should be used.
|
||||
;; mclass cannot have a value that is not a class, however.
|
||||
(unless (or (null mclass) (class-p mclass))
|
||||
(error "Cannot dispatch method %S on class %S"
|
||||
method mclass)
|
||||
)
|
||||
;; Now create a list in reverse order of all the calls we have
|
||||
;; make in order to successfully do this right. Rules:
|
||||
;; 1) Only call generics if scoped-class is not defined
|
||||
;; This prevents multiple calls in the case of recursion
|
||||
;; 2) Only call static if this is a static method.
|
||||
;; 3) Only call specifics if the definition allows for them.
|
||||
;; 4) Call in order based on :before, :primary, and :after
|
||||
(when (eieio-object-p firstarg)
|
||||
;; Non-static calls do all this stuff.
|
||||
|
||||
;; :after methods
|
||||
(setq tlambdas
|
||||
(if mclass
|
||||
(eieio--mt-method-list method eieio--method-after mclass)
|
||||
(list (eieio--generic-form method eieio--method-after nil)))
|
||||
;;(or (and mclass (eieio--generic-form method eieio--method-after mclass))
|
||||
;; (eieio--generic-form method eieio--method-after nil))
|
||||
)
|
||||
(setq lambdas (append tlambdas lambdas)
|
||||
keys (append (make-list (length tlambdas) eieio--method-after) keys))
|
||||
|
||||
;; :primary methods
|
||||
(setq tlambdas
|
||||
(or (and mclass (eieio--generic-form method eieio--method-primary mclass))
|
||||
(eieio--generic-form method eieio--method-primary nil)))
|
||||
(when tlambdas
|
||||
(setq lambdas (cons tlambdas lambdas)
|
||||
keys (cons eieio--method-primary keys)
|
||||
primarymethodlist
|
||||
(eieio--mt-method-list method eieio--method-primary mclass)))
|
||||
|
||||
;; :before methods
|
||||
(setq tlambdas
|
||||
(if mclass
|
||||
(eieio--mt-method-list method eieio--method-before mclass)
|
||||
(list (eieio--generic-form method eieio--method-before nil)))
|
||||
;;(or (and mclass (eieio--generic-form method eieio--method-before mclass))
|
||||
;; (eieio--generic-form method eieio--method-before nil))
|
||||
)
|
||||
(setq lambdas (append tlambdas lambdas)
|
||||
keys (append (make-list (length tlambdas) eieio--method-before) keys))
|
||||
)
|
||||
|
||||
(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 eieio--method-static mclass))
|
||||
(setq lambdas (cons tlambdas lambdas)
|
||||
keys (cons eieio--method-static keys)
|
||||
primarymethodlist ;; Re-use even with bad name here
|
||||
(eieio--mt-method-list method eieio--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 eieio--method-primary nil))
|
||||
(when tlambdas
|
||||
(setq lambdas (cons tlambdas lambdas)
|
||||
keys (cons eieio--method-primary keys)
|
||||
primarymethodlist
|
||||
(eieio--mt-method-list method eieio--method-primary nil)))
|
||||
)
|
||||
|
||||
(run-hook-with-args 'eieio-pre-method-execution-functions
|
||||
primarymethodlist)
|
||||
|
||||
;; Now loop through all occurrences forms which we must execute
|
||||
;; (which are happily sorted now) and execute them all!
|
||||
(let ((rval nil) (lastval nil) (found nil))
|
||||
(while lambdas
|
||||
(if (car lambdas)
|
||||
(eieio--with-scoped-class (cdr (car lambdas))
|
||||
(let* ((eieio--generic-call-key (car keys))
|
||||
(has-return-val
|
||||
(or (= eieio--generic-call-key eieio--method-primary)
|
||||
(= eieio--generic-call-key eieio--method-static)))
|
||||
(eieio--generic-call-next-method-list
|
||||
;; Use the cdr, as the first element is the fcn
|
||||
;; we are calling right now.
|
||||
(when has-return-val (cdr primarymethodlist)))
|
||||
)
|
||||
(setq found t)
|
||||
;;(setq rval (apply (car (car lambdas)) newargs))
|
||||
(setq lastval (apply (car (car lambdas)) newargs))
|
||||
(when has-return-val
|
||||
(setq rval lastval))
|
||||
)))
|
||||
(setq lambdas (cdr lambdas)
|
||||
keys (cdr keys)))
|
||||
(if (not found)
|
||||
(if (eieio-object-p (car args))
|
||||
(setq rval (apply #'no-applicable-method (car args) method args))
|
||||
(signal
|
||||
'no-method-definition
|
||||
(list method args))))
|
||||
rval)))
|
||||
|
||||
(defun eieio--generic-call-primary-only (method args)
|
||||
"Call METHOD with ARGS for methods with only :PRIMARY implementations.
|
||||
ARGS provides the context on which implementation to use.
|
||||
This should only be called from a generic function.
|
||||
|
||||
This method is like `eieio--generic-call', but only
|
||||
implementations in the :PRIMARY slot are queried. After many
|
||||
years of use, it appears that over 90% of methods in use
|
||||
have :PRIMARY implementations only. We can therefore optimize
|
||||
for this common case to improve performance."
|
||||
;; We must expand our arguments first as they are always
|
||||
;; passed in as quoted symbols
|
||||
(let ((newargs nil) (mclass nil) (lambdas nil)
|
||||
(eieio--generic-call-arglst args)
|
||||
(firstarg nil)
|
||||
(primarymethodlist nil)
|
||||
)
|
||||
;; get a copy
|
||||
(setq newargs args
|
||||
firstarg (car newargs))
|
||||
|
||||
;; Determine the class to use.
|
||||
(cond ((eieio-object-p firstarg)
|
||||
(setq mclass (eieio--object-class-name firstarg)))
|
||||
((not firstarg)
|
||||
(error "Method %s called on nil" method))
|
||||
(t
|
||||
(error "Primary-only method %s called on something not an object" method)))
|
||||
;; Make sure the class is a valid class
|
||||
;; mclass can be nil (meaning a generic for should be used.
|
||||
;; mclass cannot have a value that is not a class, however.
|
||||
(when (null mclass)
|
||||
(error "Cannot dispatch method %S on class %S" method mclass)
|
||||
)
|
||||
|
||||
;; :primary methods
|
||||
(setq lambdas (eieio--generic-form method eieio--method-primary mclass))
|
||||
(setq primarymethodlist ;; Re-use even with bad name here
|
||||
(eieio--mt-method-list method eieio--method-primary mclass))
|
||||
|
||||
;; Now loop through all occurrences forms which we must execute
|
||||
;; (which are happily sorted now) and execute them all!
|
||||
(eieio--with-scoped-class (cdr lambdas)
|
||||
(let* ((rval nil) (lastval nil)
|
||||
(eieio--generic-call-key eieio--method-primary)
|
||||
;; Use the cdr, as the first element is the fcn
|
||||
;; we are calling right now.
|
||||
(eieio--generic-call-next-method-list (cdr primarymethodlist))
|
||||
)
|
||||
|
||||
(if (or (not lambdas) (not (car lambdas)))
|
||||
|
||||
;; No methods found for this impl...
|
||||
(if (eieio-object-p (car args))
|
||||
(setq rval (apply #'no-applicable-method
|
||||
(car args) method args))
|
||||
(signal
|
||||
'no-method-definition
|
||||
(list method args)))
|
||||
|
||||
;; Do the regular implementation here.
|
||||
|
||||
(run-hook-with-args 'eieio-pre-method-execution-functions
|
||||
lambdas)
|
||||
|
||||
(setq lastval (apply (car lambdas) newargs))
|
||||
(setq rval lastval))
|
||||
|
||||
rval))))
|
||||
|
||||
(defun eieio--mt-method-list (method key class)
|
||||
"Return an alist list of methods lambdas.
|
||||
METHOD is the method name.
|
||||
KEY represents either :before, or :after methods.
|
||||
CLASS is the starting class to search from in the method tree.
|
||||
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.
|
||||
|
||||
;; Collect lambda expressions stored for the class and its parent
|
||||
;; classes.
|
||||
(let (lambdas)
|
||||
(dolist (ancestor (eieio--class-precedence-list (eieio--class-v 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 eieio--method-after)
|
||||
lambdas
|
||||
(nreverse lambdas))))
|
||||
|
||||
|
||||
;;;
|
||||
;; eieio-method-tree : eieio--mt-
|
||||
;;
|
||||
;; Stored as eieio-method-tree in property list of a generic method
|
||||
;;
|
||||
;; (eieio-method-tree . [BEFORE PRIMARY AFTER
|
||||
;; genericBEFORE genericPRIMARY genericAFTER])
|
||||
;; and
|
||||
;; (eieio-method-hashtable . [BEFORE PRIMARY AFTER
|
||||
;; genericBEFORE genericPRIMARY genericAFTER])
|
||||
;; where the association is a vector.
|
||||
;; (aref 0 -- all static methods.
|
||||
;; (aref 1 -- all methods classified as :before
|
||||
;; (aref 2 -- all methods classified as :primary
|
||||
;; (aref 3 -- all methods classified as :after
|
||||
;; (aref 4 -- a generic classified as :before
|
||||
;; (aref 5 -- a generic classified as :primary
|
||||
;; (aref 6 -- a generic classified as :after
|
||||
;;
|
||||
(defvar eieio--mt--optimizing-hashtable nil
|
||||
"While mapping atoms, this contain the hashtable being optimized.")
|
||||
|
||||
(defun eieio--mt-install (method-name)
|
||||
"Install the method tree, and hashtable onto METHOD-NAME.
|
||||
Do not do the work if they already exist."
|
||||
(unless (and (get method-name 'eieio-method-tree)
|
||||
(get method-name 'eieio-method-hashtable))
|
||||
(put method-name 'eieio-method-tree
|
||||
(make-vector eieio--method-num-slots nil))
|
||||
(let ((emto (put method-name 'eieio-method-hashtable
|
||||
(make-vector eieio--method-num-slots nil))))
|
||||
(aset emto 0 (make-hash-table :test 'eq))
|
||||
(aset emto 1 (make-hash-table :test 'eq))
|
||||
(aset emto 2 (make-hash-table :test 'eq))
|
||||
(aset emto 3 (make-hash-table :test 'eq)))))
|
||||
|
||||
(defun eieio--mt-add (method-name method key class)
|
||||
"Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS.
|
||||
METHOD-NAME is the name created by a call to `defgeneric'.
|
||||
METHOD are the forms for a given implementation.
|
||||
KEY is an integer (see comment in eieio.el near this function) which
|
||||
is associated with the :static :before :primary and :after tags.
|
||||
It also indicates if CLASS is defined or not.
|
||||
CLASS is the class this method is associated with."
|
||||
(if (or (> key eieio--method-num-slots) (< key 0))
|
||||
(error "eieio--mt-add: method key error!"))
|
||||
(let ((emtv (get method-name 'eieio-method-tree))
|
||||
(emto (get method-name 'eieio-method-hashtable)))
|
||||
;; Make sure the method tables are available.
|
||||
(unless (and emtv emto)
|
||||
(error "Programmer error: eieio--mt-add"))
|
||||
;; only add new cells on if it doesn't already exist!
|
||||
(if (assq class (aref emtv key))
|
||||
(setcdr (assq class (aref emtv key)) method)
|
||||
(aset emtv key (cons (cons class method) (aref emtv key))))
|
||||
;; Add function definition into newly created symbol, and store
|
||||
;; said symbol in the correct hashtable, otherwise use the
|
||||
;; other array to keep this stuff.
|
||||
(if (< key eieio--method-num-lists)
|
||||
(puthash (eieio--class-v class) (list method) (aref emto key)))
|
||||
;; Save the defmethod file location in a symbol property.
|
||||
(let ((fname (if load-in-progress
|
||||
load-file-name
|
||||
buffer-file-name)))
|
||||
(when fname
|
||||
(when (string-match "\\.elc\\'" fname)
|
||||
(setq fname (substring fname 0 (1- (length fname)))))
|
||||
(cl-pushnew (list class fname) (get method-name 'method-locations)
|
||||
:test 'equal)))
|
||||
;; Now optimize the entire hashtable.
|
||||
(if (< key eieio--method-num-lists)
|
||||
(let ((eieio--mt--optimizing-hashtable (aref emto key)))
|
||||
;; @todo - Is this overkill? Should we just clear the symbol?
|
||||
(maphash #'eieio--mt--sym-optimize eieio--mt--optimizing-hashtable)))
|
||||
))
|
||||
|
||||
(defun eieio--mt-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!"
|
||||
;; No type-checking because all calls are made from functions which
|
||||
;; are safe and do checking for us.
|
||||
(or (eieio--class-parent (eieio--class-v class))
|
||||
(if (eq class 'eieio-default-superclass)
|
||||
nil
|
||||
'(eieio-default-superclass))))
|
||||
|
||||
(defun eieio--mt--sym-optimize (class s)
|
||||
"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.
|
||||
(setcdr s nil)
|
||||
;; Find the nearest cell that has a function body. If we find one,
|
||||
;; we replace the nil from above.
|
||||
(catch 'done
|
||||
(dolist (ancestor
|
||||
(cl-rest (eieio--class-precedence-list class)))
|
||||
(let ((ov (gethash ancestor eieio--mt--optimizing-hashtable)))
|
||||
(when (car ov)
|
||||
(setcdr s ancestor) ;; 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 memorized for faster future use."
|
||||
(if (symbolp class) (setq class (eieio--class-v class)))
|
||||
(let ((emto (aref (get method 'eieio-method-hashtable)
|
||||
(if class key (eieio--specialized-key-to-generic-key key)))))
|
||||
(if (eieio--class-p class)
|
||||
;; 1) find our symbol
|
||||
(let ((cs (gethash class emto)))
|
||||
(unless cs
|
||||
;; 2) If there isn't one, then make one.
|
||||
;; This can be slow since it only occurs once
|
||||
(puthash class (setq cs (list nil)) emto)
|
||||
;; 2.1) Cache its nearest neighbor with a quick optimize
|
||||
;; which should only occur once for this call ever
|
||||
(let ((eieio--mt--optimizing-hashtable emto))
|
||||
(eieio--mt--sym-optimize class cs)))
|
||||
;; 3) If it's bound return this one.
|
||||
(if (car cs)
|
||||
(cons (car cs) class)
|
||||
;; 4) If it's not bound then this variable knows something
|
||||
(if (cdr cs)
|
||||
(progn
|
||||
;; 4.1) This symbol holds the next class in its value
|
||||
(setq class (cdr cs)
|
||||
cs (gethash class emto))
|
||||
;; 4.2) The optimizer should always have chosen a
|
||||
;; function-symbol
|
||||
;;(if (car cs)
|
||||
(cons (car cs) class)
|
||||
;;(error "EIEIO optimizer: erratic data loss!"))
|
||||
)
|
||||
;; There never will be a funcall...
|
||||
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 (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.
|
||||
(cons (cdr (car emtl)) nil)
|
||||
nil)))))
|
||||
|
||||
|
||||
(define-error 'no-method-definition "No method definition")
|
||||
(define-error 'no-next-method "No next method")
|
||||
|
||||
;;; CLOS methods and generics
|
||||
;;
|
||||
(defmacro defgeneric (method _args &optional doc-string)
|
||||
"Create a generic function METHOD.
|
||||
DOC-STRING is the base documentation for this class. A generic
|
||||
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."
|
||||
(declare (doc-string 3))
|
||||
`(eieio--defalias ',method
|
||||
(eieio--defgeneric-init-form ',method ,doc-string)))
|
||||
|
||||
(defmacro defmethod (method &rest args)
|
||||
"Create a new METHOD through `defgeneric' with ARGS.
|
||||
|
||||
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
|
||||
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:
|
||||
((VARNAME CLASS) ARG2 ...)
|
||||
where VARNAME is the name of the local variable for the method being
|
||||
created. The CLASS is a class symbol for a class made with `defclass'.
|
||||
A DOCSTRING comes after the ARGLIST, and is optional.
|
||||
All the rest of the args are the BODY of the method. A method will
|
||||
return the value of the last form in the BODY.
|
||||
|
||||
Summary:
|
||||
|
||||
(defmethod mymethod [:before | :primary | :after | :static]
|
||||
((typearg class-name) arg2 &optional opt &rest rest)
|
||||
\"doc-string\"
|
||||
body)"
|
||||
(declare (doc-string 3)
|
||||
(debug
|
||||
(&define ; this means we are defining something
|
||||
[&or name ("setf" :name setf name)]
|
||||
;; ^^ This is the methods symbol
|
||||
[ &optional symbolp ] ; this is key :before etc
|
||||
list ; arguments
|
||||
[ &optional stringp ] ; documentation string
|
||||
def-body ; part to be debugged
|
||||
)))
|
||||
(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))))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;; Method Calling Functions
|
||||
|
||||
(defun next-method-p ()
|
||||
"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)
|
||||
|
||||
(defun call-next-method (&rest replacement-args)
|
||||
"Call the superclass method from a subclass method.
|
||||
The superclass method is specified in the current method list,
|
||||
and is called the next method.
|
||||
|
||||
If REPLACEMENT-ARGS is non-nil, then use them instead of
|
||||
`eieio--generic-call-arglst'. The generic arg list are the
|
||||
arguments passed in at the top level.
|
||||
|
||||
Use `next-method-p' to find out if there is a next method to call."
|
||||
(if (not (eieio--scoped-class))
|
||||
(error "`call-next-method' not called within a class specific method"))
|
||||
(if (and (/= eieio--generic-call-key eieio--method-primary)
|
||||
(/= eieio--generic-call-key eieio--method-static))
|
||||
(error "Cannot `call-next-method' except in :primary or :static methods")
|
||||
)
|
||||
(let ((newargs (or replacement-args eieio--generic-call-arglst))
|
||||
(next (car eieio--generic-call-next-method-list))
|
||||
)
|
||||
(if (not (and next (car next)))
|
||||
(apply #'no-next-method newargs)
|
||||
(let* ((eieio--generic-call-next-method-list
|
||||
(cdr eieio--generic-call-next-method-list))
|
||||
(eieio--generic-call-arglst newargs)
|
||||
(fcn (car next))
|
||||
)
|
||||
(eieio--with-scoped-class (cdr next)
|
||||
(apply fcn newargs)) ))))
|
||||
|
||||
(defgeneric no-applicable-method (object method &rest args)
|
||||
"Called if there are no implementations for OBJECT in METHOD.")
|
||||
|
||||
(defmethod no-applicable-method (object method &rest _args)
|
||||
"Called if there are no implementations for OBJECT in METHOD.
|
||||
OBJECT is the object which has no method implementation.
|
||||
ARGS are the arguments that were passed to METHOD.
|
||||
|
||||
Implement this for a class to block this signal. The return
|
||||
value becomes the return value of the original method call."
|
||||
(signal 'no-method-definition (list method object)))
|
||||
|
||||
(defgeneric no-next-method (object &rest args)
|
||||
"Called from `call-next-method' when no additional methods are available.")
|
||||
|
||||
(defmethod no-next-method (object &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.
|
||||
This method signals `no-next-method' by default. Override this
|
||||
method to not throw an error, and its return value becomes the
|
||||
return value of `call-next-method'."
|
||||
(signal 'no-next-method (list object args)))
|
||||
|
||||
(add-hook 'help-fns-describe-function-functions 'eieio--help-generic)
|
||||
(defun eieio--help-generic (generic)
|
||||
"Describe GENERIC if it is a generic function."
|
||||
(when (and (symbolp generic) (generic-p generic))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(when (re-search-forward " in `.+'.$" nil t)
|
||||
(replace-match ".")))
|
||||
(save-excursion
|
||||
(insert "\n\nThis is a generic function"
|
||||
(cond
|
||||
((and (eieio--generic-primary-only-p generic)
|
||||
(eieio--generic-primary-only-one-p generic))
|
||||
" with only one primary method")
|
||||
((eieio--generic-primary-only-p generic)
|
||||
" with only primary methods")
|
||||
(t ""))
|
||||
".\n\n")
|
||||
(insert (propertize "Implementations:\n\n" 'face 'bold))
|
||||
(let ((i 4)
|
||||
(prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
|
||||
;; Loop over fanciful generics
|
||||
(while (< i 7)
|
||||
(let ((gm (aref (get generic 'eieio-method-tree) i)))
|
||||
(when gm
|
||||
(insert "Generic "
|
||||
(aref prefix (- i 3))
|
||||
"\n"
|
||||
(or (nth 2 gm) "Undocumented")
|
||||
"\n\n")))
|
||||
(setq i (1+ i)))
|
||||
(setq i 0)
|
||||
;; Loop over defined class-specific methods
|
||||
(while (< i 4)
|
||||
(let* ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
|
||||
cname location)
|
||||
(while gm
|
||||
(setq cname (caar gm))
|
||||
(insert "`")
|
||||
(help-insert-xref-button (symbol-name cname)
|
||||
'help-variable cname)
|
||||
(insert "' " (aref prefix i) " ")
|
||||
;; argument list
|
||||
(let* ((func (cdr (car gm)))
|
||||
(arglst (help-function-arglist func)))
|
||||
(prin1 arglst (current-buffer)))
|
||||
(insert "\n"
|
||||
(or (documentation (cdr (car gm)))
|
||||
"Undocumented"))
|
||||
;; Print file location if available
|
||||
(when (and (setq location (get generic 'method-locations))
|
||||
(setq location (assoc cname location)))
|
||||
(setq location (cadr location))
|
||||
(insert "\n\nDefined in `")
|
||||
(help-insert-xref-button
|
||||
(file-name-nondirectory location)
|
||||
'eieio-method-def cname generic location)
|
||||
(insert "'\n"))
|
||||
(setq gm (cdr gm))
|
||||
(insert "\n")))
|
||||
(setq i (1+ i)))))))
|
||||
|
||||
;;; 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 ((memq (car args) '(:BEFORE :before))
|
||||
(setq args (cdr args))
|
||||
eieio--method-before)
|
||||
((memq (car args) '(:AFTER :after))
|
||||
(setq args (cdr args))
|
||||
eieio--method-after)
|
||||
((memq (car args) '(:STATIC :static))
|
||||
(setq args (cdr args))
|
||||
eieio--method-static)
|
||||
((memq (car args) '(:PRIMARY :primary))
|
||||
(setq args (cdr args))
|
||||
eieio--method-primary)
|
||||
;; Primary key.
|
||||
(t eieio--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))))
|
||||
;; 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))
|
||||
(eieio--mt-add method (car-safe body) key argclass)
|
||||
(eieio--mt-add method (append (list 'lambda (reverse argfix)) body)
|
||||
key argclass))
|
||||
)
|
||||
|
||||
(eieio--method-optimize-primary 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.
|
||||
(eieio--mt-install method)
|
||||
;; Apply the actual body of this function.
|
||||
(put method 'function-documentation doc-string)
|
||||
(fset method (eieio--defgeneric-form method))
|
||||
;; Return the method
|
||||
'method))
|
||||
(make-obsolete 'eieio-defgeneric nil "24.1")
|
||||
|
||||
(provide 'eieio-generic)
|
||||
|
||||
;;; eieio-generic.el ends here
|
||||
|
|
@ -60,7 +60,7 @@ Argument PREFIX is the character prefix to use.
|
|||
Argument CH-PREFIX is another character prefix to display."
|
||||
(eieio--check-type class-p this-root)
|
||||
(let ((myname (symbol-name this-root))
|
||||
(chl (eieio--class-children (class-v this-root)))
|
||||
(chl (eieio--class-children (eieio--class-v this-root)))
|
||||
(fprefix (concat ch-prefix " +--"))
|
||||
(mprefix (concat ch-prefix " | "))
|
||||
(lprefix (concat ch-prefix " ")))
|
||||
|
|
@ -81,7 +81,7 @@ If CLASS is actually an object, then also display current values of that object.
|
|||
;; Header line
|
||||
(prin1 class)
|
||||
(insert " is a"
|
||||
(if (class-option class :abstract)
|
||||
(if (eieio--class-option (eieio--class-v class) :abstract)
|
||||
"n abstract"
|
||||
"")
|
||||
" class")
|
||||
|
|
@ -149,7 +149,7 @@ If CLASS is actually an object, then also display current values of that object.
|
|||
(defun eieio-help-class-slots (class)
|
||||
"Print help description for the slots in CLASS.
|
||||
Outputs to the current buffer."
|
||||
(let* ((cv (class-v class))
|
||||
(let* ((cv (eieio--class-v class))
|
||||
(docs (eieio--class-public-doc cv))
|
||||
(names (eieio--class-public-a cv))
|
||||
(deflt (eieio--class-public-d cv))
|
||||
|
|
@ -218,11 +218,10 @@ Outputs to the current buffer."
|
|||
(defun eieio-build-class-list (class)
|
||||
"Return a list of all classes that inherit from CLASS."
|
||||
(if (class-p class)
|
||||
(apply #'append
|
||||
(mapcar
|
||||
(lambda (c)
|
||||
(append (list c) (eieio-build-class-list c)))
|
||||
(eieio-class-children-fast class)))
|
||||
(cl-mapcan
|
||||
(lambda (c)
|
||||
(append (list c) (eieio-build-class-list c)))
|
||||
(eieio--class-children (eieio--class-v class)))
|
||||
(list class)))
|
||||
|
||||
(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
|
||||
|
|
@ -231,15 +230,16 @@ Optional argument CLASS is the class to start with.
|
|||
If INSTANTIABLE-ONLY is non nil, only allow names of classes which
|
||||
are not abstract, otherwise allow all classes.
|
||||
Optional argument BUILDLIST is more list to attach and is used internally."
|
||||
(let* ((cc (or class eieio-default-superclass))
|
||||
(sublst (eieio--class-children (class-v cc))))
|
||||
(let* ((cc (or class 'eieio-default-superclass))
|
||||
(sublst (eieio--class-children (eieio--class-v cc))))
|
||||
(unless (assoc (symbol-name cc) buildlist)
|
||||
(when (or (not instantiable-only) (not (class-abstract-p cc)))
|
||||
;; 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))))
|
||||
(while sublst
|
||||
(dolist (elem sublst)
|
||||
(setq buildlist (eieio-build-class-alist
|
||||
(car sublst) instantiable-only buildlist))
|
||||
(setq sublst (cdr sublst)))
|
||||
elem instantiable-only buildlist)))
|
||||
buildlist))
|
||||
|
||||
(defvar eieio-read-class nil
|
||||
|
|
@ -311,132 +311,59 @@ are not abstract."
|
|||
(eieio-help-class ctr))
|
||||
))))
|
||||
|
||||
|
||||
;;;###autoload
|
||||
(defun eieio-help-generic (generic)
|
||||
"Describe GENERIC if it is a generic function."
|
||||
(when (and (symbolp generic) (generic-p generic))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(when (re-search-forward " in `.+'.$" nil t)
|
||||
(replace-match ".")))
|
||||
(save-excursion
|
||||
(insert "\n\nThis is a generic function"
|
||||
(cond
|
||||
((and (generic-primary-only-p generic)
|
||||
(generic-primary-only-one-p generic))
|
||||
" with only one primary method")
|
||||
((generic-primary-only-p generic)
|
||||
" with only primary methods")
|
||||
(t ""))
|
||||
".\n\n")
|
||||
(insert (propertize "Implementations:\n\n" 'face 'bold))
|
||||
(let ((i 4)
|
||||
(prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
|
||||
;; Loop over fanciful generics
|
||||
(while (< i 7)
|
||||
(let ((gm (aref (get generic 'eieio-method-tree) i)))
|
||||
(when gm
|
||||
(insert "Generic "
|
||||
(aref prefix (- i 3))
|
||||
"\n"
|
||||
(or (nth 2 gm) "Undocumented")
|
||||
"\n\n")))
|
||||
(setq i (1+ i)))
|
||||
(setq i 0)
|
||||
;; Loop over defined class-specific methods
|
||||
(while (< i 4)
|
||||
(let* ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
|
||||
cname location)
|
||||
(while gm
|
||||
(setq cname (caar gm))
|
||||
(insert "`")
|
||||
(help-insert-xref-button (symbol-name cname)
|
||||
'help-variable cname)
|
||||
(insert "' " (aref prefix i) " ")
|
||||
;; argument list
|
||||
(let* ((func (cdr (car gm)))
|
||||
(arglst (help-function-arglist func)))
|
||||
(prin1 arglst (current-buffer)))
|
||||
(insert "\n"
|
||||
(or (documentation (cdr (car gm)))
|
||||
"Undocumented"))
|
||||
;; Print file location if available
|
||||
(when (and (setq location (get generic 'method-locations))
|
||||
(setq location (assoc cname location)))
|
||||
(setq location (cadr location))
|
||||
(insert "\n\nDefined in `")
|
||||
(help-insert-xref-button
|
||||
(file-name-nondirectory location)
|
||||
'eieio-method-def cname generic location)
|
||||
(insert "'\n"))
|
||||
(setq gm (cdr gm))
|
||||
(insert "\n")))
|
||||
(setq i (1+ i)))))))
|
||||
|
||||
(defun eieio-all-generic-functions (&optional class)
|
||||
"Return a list of all generic functions.
|
||||
Optional CLASS argument returns only those functions that contain
|
||||
methods for CLASS."
|
||||
(let ((l nil) tree (cn (if class (symbol-name class) nil)))
|
||||
(let ((l nil))
|
||||
(mapatoms
|
||||
(lambda (symbol)
|
||||
(setq tree (get symbol 'eieio-method-obarray))
|
||||
(if tree
|
||||
(progn
|
||||
;; A symbol might be interned for that class in one of
|
||||
;; these three slots in the method-obarray.
|
||||
(if (or (not class)
|
||||
(fboundp (intern-soft cn (aref tree 0)))
|
||||
(fboundp (intern-soft cn (aref tree 1)))
|
||||
(fboundp (intern-soft cn (aref tree 2))))
|
||||
(setq l (cons symbol l)))))))
|
||||
(let ((tree (get symbol 'eieio-method-hashtable)))
|
||||
(when tree
|
||||
;; A symbol might be interned for that class in one of
|
||||
;; these three slots in the method-obarray.
|
||||
(if (or (not class)
|
||||
(car (gethash class (aref tree 0)))
|
||||
(car (gethash class (aref tree 1)))
|
||||
(car (gethash class (aref tree 2))))
|
||||
(setq l (cons symbol l)))))))
|
||||
l))
|
||||
|
||||
(defun eieio-method-documentation (generic 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
|
||||
function has no documentation, then return nil."
|
||||
(let ((tree (get generic 'eieio-method-obarray))
|
||||
(cn (symbol-name class))
|
||||
before primary after)
|
||||
(if (not tree)
|
||||
nil
|
||||
(let ((tree (get generic 'eieio-method-hashtable)))
|
||||
(when tree
|
||||
;; A symbol might be interned for that class in one of
|
||||
;; these three slots in the method-obarray.
|
||||
(setq before (intern-soft cn (aref tree 0))
|
||||
primary (intern-soft cn (aref tree 1))
|
||||
after (intern-soft cn (aref tree 2)))
|
||||
(if (not (or (fboundp before)
|
||||
(fboundp primary)
|
||||
(fboundp after)))
|
||||
nil
|
||||
(list (if (fboundp before)
|
||||
(cons (help-function-arglist before)
|
||||
(documentation before))
|
||||
nil)
|
||||
(if (fboundp primary)
|
||||
(cons (help-function-arglist primary)
|
||||
(documentation primary))
|
||||
nil)
|
||||
(if (fboundp after)
|
||||
(cons (help-function-arglist after)
|
||||
(documentation after))
|
||||
nil))))))
|
||||
;; these three slots in the method-hashtable.
|
||||
;; FIXME: Where do these 0/1/2 come from? Isn't 0 for :static,
|
||||
;; 1 for before, and 2 for primary (and 3 for after)?
|
||||
(let ((before (car (gethash class (aref tree 0))))
|
||||
(primary (car (gethash class (aref tree 1))))
|
||||
(after (car (gethash class (aref tree 2)))))
|
||||
(if (not (or before primary after))
|
||||
nil
|
||||
(list (if before
|
||||
(cons (help-function-arglist before)
|
||||
(documentation before))
|
||||
nil)
|
||||
(if primary
|
||||
(cons (help-function-arglist primary)
|
||||
(documentation primary))
|
||||
nil)
|
||||
(if after
|
||||
(cons (help-function-arglist after)
|
||||
(documentation after))
|
||||
nil)))))))
|
||||
|
||||
(defvar eieio-read-generic nil
|
||||
"History of the `eieio-read-generic' prompt.")
|
||||
|
||||
(defun eieio-read-generic-p (fn)
|
||||
"Function used in function `eieio-read-generic'.
|
||||
This is because `generic-p' is a macro.
|
||||
Argument FN is the function to test."
|
||||
(generic-p fn))
|
||||
|
||||
(defun eieio-read-generic (prompt &optional historyvar)
|
||||
"Read a generic function from the minibuffer with PROMPT.
|
||||
Optional argument HISTORYVAR is the variable to use as history."
|
||||
(intern (completing-read prompt obarray 'eieio-read-generic-p
|
||||
(intern (completing-read prompt obarray #'generic-p
|
||||
t nil (or historyvar 'eieio-read-generic))))
|
||||
|
||||
;;; METHOD STATS
|
||||
|
|
@ -627,21 +554,21 @@ Optional argument HISTORYVAR is the variable to use as history."
|
|||
()
|
||||
"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.
|
||||
DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the
|
||||
current expansion depth."
|
||||
(when (eq (point-min) (point-max))
|
||||
;; This function is only called once, to start the whole deal.
|
||||
;; Create and expand the default object.
|
||||
(eieio-class-button eieio-default-superclass 0)
|
||||
(eieio-class-button 'eieio-default-superclass 0)
|
||||
(forward-line -1)
|
||||
(speedbar-expand-line)))
|
||||
|
||||
(defun eieio-class-button (class depth)
|
||||
"Draw a speedbar button at the current point for CLASS at DEPTH."
|
||||
(eieio--check-type class-p class)
|
||||
(let ((subclasses (eieio--class-children (class-v class))))
|
||||
(let ((subclasses (eieio--class-children (eieio--class-v class))))
|
||||
(if subclasses
|
||||
(speedbar-make-tag-line 'angle ?+
|
||||
'eieio-sb-expand
|
||||
|
|
@ -666,7 +593,7 @@ Argument INDENT is the depth of indentation."
|
|||
(speedbar-with-writable
|
||||
(save-excursion
|
||||
(end-of-line) (forward-char 1)
|
||||
(let ((subclasses (eieio--class-children (class-v class))))
|
||||
(let ((subclasses (eieio--class-children (eieio--class-v class))))
|
||||
(while subclasses
|
||||
(eieio-class-button (car subclasses) (1+ indent))
|
||||
(setq subclasses (cdr subclasses)))))))
|
||||
|
|
@ -676,7 +603,7 @@ Argument INDENT is the depth of indentation."
|
|||
(t (error "Ooops... not sure what to do")))
|
||||
(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.
|
||||
INDENT is the current indentation level."
|
||||
(dframe-with-attached-buffer
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;; eieio-speedbar.el -- Classes for managing speedbar displays.
|
||||
;;; eieio-speedbar.el -- Classes for managing speedbar displays. -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 1999-2002, 2005, 2007-2015 Free Software Foundation,
|
||||
;; Inc.
|
||||
|
|
@ -200,7 +200,7 @@ that path."
|
|||
"Return a string describing OBJECT."
|
||||
(eieio-object-name-string object))
|
||||
|
||||
(defmethod eieio-speedbar-derive-line-path (object)
|
||||
(defmethod eieio-speedbar-derive-line-path (_object)
|
||||
"Return the path which OBJECT has something to do with."
|
||||
nil)
|
||||
|
||||
|
|
@ -321,7 +321,7 @@ Argument DEPTH is the depth at which the tag line is inserted."
|
|||
(if exp
|
||||
(eieio-speedbar-expand object (1+ depth))))))
|
||||
|
||||
(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth)
|
||||
(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) _depth)
|
||||
"Base method for creating tag lines for non-object children."
|
||||
(error "You must implement `eieio-speedbar-child-make-tag-lines' for %s"
|
||||
(eieio-object-name object)))
|
||||
|
|
@ -340,7 +340,7 @@ OBJECT."
|
|||
|
||||
;;; Speedbar specific function callbacks.
|
||||
;;
|
||||
(defun eieio-speedbar-object-click (text token indent)
|
||||
(defun eieio-speedbar-object-click (_text token _indent)
|
||||
"Handle a user click on TEXT representing object TOKEN.
|
||||
The object is at indentation level INDENT."
|
||||
(eieio-speedbar-handle-click token))
|
||||
|
|
@ -412,7 +412,7 @@ Optional DEPTH is the depth we start at."
|
|||
|
||||
;;; Methods to the eieio-speedbar-* classes which need to be overridden.
|
||||
;;
|
||||
(defmethod eieio-speedbar-object-children ((object eieio-speedbar))
|
||||
(defmethod eieio-speedbar-object-children ((_object eieio-speedbar))
|
||||
"Return a list of children to be displayed in speedbar.
|
||||
If the return value is a list of OBJECTs, then those objects are
|
||||
queried for details. If the return list is made of strings,
|
||||
|
|
|
|||
|
|
@ -53,17 +53,16 @@
|
|||
(message eieio-version))
|
||||
|
||||
(require 'eieio-core)
|
||||
(require 'eieio-generic)
|
||||
|
||||
|
||||
;;; Defining a new class
|
||||
;;
|
||||
(defmacro defclass (name superclass slots &rest options-and-doc)
|
||||
(defmacro defclass (name superclasses slots &rest options-and-doc)
|
||||
"Define NAME as a new class derived from SUPERCLASS with SLOTS.
|
||||
OPTIONS-AND-DOC is used as the class' options and base documentation.
|
||||
SUPERCLASS is a list of superclasses to inherit from, with SLOTS
|
||||
being the slots residing in that class definition. NOTE: Currently
|
||||
only one slot may exist in SUPERCLASS as multiple inheritance is not
|
||||
yet supported. Supported tags are:
|
||||
SUPERCLASSES is a list of superclasses to inherit from, with SLOTS
|
||||
being the slots residing in that class definition. Supported tags are:
|
||||
|
||||
:initform - Initializing form.
|
||||
:initarg - Tag used during initialization.
|
||||
|
|
@ -114,12 +113,178 @@ Options in CLOS not supported in EIEIO:
|
|||
Due to the way class options are set up, you can add any tags you wish,
|
||||
and reference them using the function `class-option'."
|
||||
(declare (doc-string 4))
|
||||
;; This is eval-and-compile only to silence spurious compiler warnings
|
||||
;; about functions and variables not known to be defined.
|
||||
;; When eieio-defclass code is merged here and this becomes
|
||||
;; transparent to the compiler, the eval-and-compile can be removed.
|
||||
`(eval-and-compile
|
||||
(eieio-defclass ',name ',superclass ',slots ',options-and-doc)))
|
||||
(eieio--check-type listp superclasses)
|
||||
|
||||
(cond ((and (stringp (car options-and-doc))
|
||||
(/= 1 (% (length options-and-doc) 2)))
|
||||
(error "Too many arguments to `defclass'"))
|
||||
((and (symbolp (car options-and-doc))
|
||||
(/= 0 (% (length options-and-doc) 2)))
|
||||
(error "Too many arguments to `defclass'")))
|
||||
|
||||
(if (stringp (car options-and-doc))
|
||||
(setq options-and-doc
|
||||
(cons :documentation options-and-doc)))
|
||||
|
||||
;; Make sure the method invocation order is a valid value.
|
||||
(let ((io (eieio--class-option-assoc options-and-doc
|
||||
:method-invocation-order)))
|
||||
(when (and io (not (member io '(:depth-first :breadth-first :c3))))
|
||||
(error "Method invocation order %s is not allowed" io)))
|
||||
|
||||
(let ((testsym1 (intern (concat (symbol-name name) "-p")))
|
||||
(testsym2 (intern (format "eieio--childp--%s" name)))
|
||||
(accessors ()))
|
||||
|
||||
;; Collect the accessors we need to define.
|
||||
(pcase-dolist (`(,sname . ,soptions) slots)
|
||||
(let* ((acces (plist-get soptions :accessor))
|
||||
(initarg (plist-get soptions :initarg))
|
||||
(reader (plist-get soptions :reader))
|
||||
(writer (plist-get soptions :writer))
|
||||
(alloc (plist-get soptions :allocation))
|
||||
(label (plist-get soptions :label)))
|
||||
|
||||
(if eieio-error-unsupported-class-tags
|
||||
(let ((tmp soptions))
|
||||
(while tmp
|
||||
(if (not (member (car tmp) '(:accessor
|
||||
:initform
|
||||
:initarg
|
||||
:documentation
|
||||
:protection
|
||||
:reader
|
||||
:writer
|
||||
:allocation
|
||||
:type
|
||||
:custom
|
||||
:label
|
||||
:group
|
||||
:printer
|
||||
:allow-nil-initform
|
||||
:custom-groups)))
|
||||
(signal 'invalid-slot-type (list (car tmp))))
|
||||
(setq tmp (cdr (cdr tmp))))))
|
||||
|
||||
;; Make sure the :allocation parameter has a valid value.
|
||||
(if (not (memq alloc '(nil :class :instance)))
|
||||
(signal 'invalid-slot-type (list :allocation alloc)))
|
||||
|
||||
;; Label is nil, or a string
|
||||
(if (not (or (null label) (stringp label)))
|
||||
(signal 'invalid-slot-type (list :label label)))
|
||||
|
||||
;; Is there an initarg, but allocation of class?
|
||||
(if (and initarg (eq alloc :class))
|
||||
(message "Class allocated slots do not need :initarg"))
|
||||
|
||||
;; Anyone can have an accessor function. This creates a function
|
||||
;; of the specified name, and also performs a `defsetf' if applicable
|
||||
;; so that users can `setf' the space returned by this function.
|
||||
(when acces
|
||||
;; FIXME: The defmethod below only defines a part of the generic
|
||||
;; function (good), but the define-setter below affects the whole
|
||||
;; generic function (bad)!
|
||||
(push `(gv-define-setter ,acces (store object)
|
||||
;; Apparently, eieio-oset-default doesn't work like
|
||||
;; oref-default and only accept class arguments!
|
||||
(list ',(if nil ;; (eq alloc :class)
|
||||
'eieio-oset-default
|
||||
'eieio-oset)
|
||||
object '',sname store))
|
||||
accessors)
|
||||
(push `(defmethod ,acces ,(if (eq alloc :class) :static :primary)
|
||||
((this ,name))
|
||||
,(format
|
||||
"Retrieve the slot `%S' from an object of class `%S'."
|
||||
sname name)
|
||||
(if (slot-boundp this ',sname)
|
||||
;; Use oref-default for :class allocated slots, since
|
||||
;; these also accept the use of a class argument instead
|
||||
;; of an object argument.
|
||||
(,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref)
|
||||
this ',sname)
|
||||
;; Else - Some error? nil?
|
||||
nil))
|
||||
accessors))
|
||||
|
||||
;; If a writer is defined, then create a generic method of that
|
||||
;; name whose purpose is to set the value of the slot.
|
||||
(if writer
|
||||
(push `(defmethod ,writer ((this ,name) value)
|
||||
,(format "Set the slot `%S' of an object of class `%S'."
|
||||
sname name)
|
||||
(setf (slot-value this ',sname) value))
|
||||
accessors))
|
||||
;; If a reader is defined, then create a generic method
|
||||
;; of that name whose purpose is to access this slot value.
|
||||
(if reader
|
||||
(push `(defmethod ,reader ((this ,name))
|
||||
,(format "Access the slot `%S' from object of class `%S'."
|
||||
sname name)
|
||||
(slot-value this ',sname))
|
||||
accessors))
|
||||
))
|
||||
|
||||
`(progn
|
||||
;; This test must be created right away so we can have self-
|
||||
;; referencing classes. ei, a class whose slot can contain only
|
||||
;; pointers to itself.
|
||||
|
||||
;; Create the test function.
|
||||
(defun ,testsym1 (obj)
|
||||
,(format "Test OBJ to see if it an object of type %S." name)
|
||||
(and (eieio-object-p obj)
|
||||
(same-class-p obj ',name)))
|
||||
|
||||
(defun ,testsym2 (obj)
|
||||
,(format
|
||||
"Test OBJ to see if it an object is a child of type %S."
|
||||
name)
|
||||
(and (eieio-object-p obj)
|
||||
(object-of-class-p obj ',name)))
|
||||
|
||||
,@(when eieio-backward-compatibility
|
||||
(let ((f (intern (format "%s-child-p" name))))
|
||||
`((defalias ',f ',testsym2)
|
||||
(make-obsolete
|
||||
',f ,(format "use (cl-typep ... '%s) instead" name) "25.1"))))
|
||||
|
||||
;; When using typep, (typep OBJ 'myclass) returns t for objects which
|
||||
;; are subclasses of myclass. For our predicates, however, it is
|
||||
;; important for EIEIO to be backwards compatible, where
|
||||
;; myobject-p, and myobject-child-p are different.
|
||||
;; "cl" uses this technique to specify symbols with specific typep
|
||||
;; test, so we can let typep have the CLOS documented behavior
|
||||
;; while keeping our above predicate clean.
|
||||
|
||||
(put ',name 'cl-deftype-satisfies #',testsym2)
|
||||
|
||||
(eieio-defclass-internal ',name ',superclasses ',slots ',options-and-doc)
|
||||
|
||||
,@accessors
|
||||
|
||||
;; Create the constructor function
|
||||
,(if (eieio--class-option-assoc options-and-doc :abstract)
|
||||
;; Abstract classes cannot be instantiated. Say so.
|
||||
(let ((abs (eieio--class-option-assoc options-and-doc :abstract)))
|
||||
(if (not (stringp abs))
|
||||
(setq abs (format "Class %s is abstract" name)))
|
||||
`(defun ,name (&rest _)
|
||||
,(format "You cannot create a new object of type %S." name)
|
||||
(error ,abs)))
|
||||
|
||||
;; Non-abstract classes need a constructor.
|
||||
`(defun ,name (&rest slots)
|
||||
,(format "Create a new object with name NAME of class type %S."
|
||||
name)
|
||||
(if (and slots
|
||||
(let ((x (car slots)))
|
||||
(or (stringp x) (null x))))
|
||||
(funcall (if eieio-backward-compatibility #'ignore #'message)
|
||||
"Obsolete name %S passed to %S constructor"
|
||||
(pop slots) ',name))
|
||||
(apply #'eieio-constructor ',name slots))))))
|
||||
|
||||
|
||||
;;; CLOS style implementation of object creators.
|
||||
|
|
@ -144,75 +309,16 @@ In EIEIO, the class' constructor requires a name for use when printing.
|
|||
`make-instance' in CLOS doesn't use names the way Emacs does, so the
|
||||
class is used as the name slot instead when INITARGS doesn't start with
|
||||
a string."
|
||||
(if (and (car initargs) (stringp (car initargs)))
|
||||
(apply (class-constructor class) initargs)
|
||||
(apply (class-constructor class)
|
||||
(cond ((symbolp class) (symbol-name class))
|
||||
(t (format "%S" class)))
|
||||
initargs)))
|
||||
(apply (class-constructor class) initargs))
|
||||
|
||||
|
||||
;;; CLOS methods and generics
|
||||
;;
|
||||
(defmacro defgeneric (method _args &optional doc-string)
|
||||
"Create a generic function METHOD.
|
||||
DOC-STRING is the base documentation for this class. A generic
|
||||
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."
|
||||
(declare (doc-string 3))
|
||||
`(eieio--defalias ',method
|
||||
(eieio--defgeneric-init-form ',method ,doc-string)))
|
||||
|
||||
(defmacro defmethod (method &rest args)
|
||||
"Create a new METHOD through `defgeneric' with ARGS.
|
||||
|
||||
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
|
||||
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:
|
||||
((VARNAME CLASS) ARG2 ...)
|
||||
where VARNAME is the name of the local variable for the method being
|
||||
created. The CLASS is a class symbol for a class made with `defclass'.
|
||||
A DOCSTRING comes after the ARGLIST, and is optional.
|
||||
All the rest of the args are the BODY of the method. A method will
|
||||
return the value of the last form in the BODY.
|
||||
|
||||
Summary:
|
||||
|
||||
(defmethod mymethod [:before | :primary | :after | :static]
|
||||
((typearg class-name) arg2 &optional opt &rest rest)
|
||||
\"doc-string\"
|
||||
body)"
|
||||
(declare (doc-string 3))
|
||||
(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))))
|
||||
|
||||
;;; Get/Set slots in an object.
|
||||
;;
|
||||
(defmacro oref (obj slot)
|
||||
"Retrieve the value stored in OBJ in the slot named by SLOT.
|
||||
Slot is the name of the slot when created by `defclass' or the label
|
||||
created by the :initarg tag."
|
||||
(declare (debug (form symbolp)))
|
||||
`(eieio-oref ,obj (quote ,slot)))
|
||||
|
||||
(defalias 'slot-value 'eieio-oref)
|
||||
|
|
@ -223,6 +329,7 @@ created by the :initarg tag."
|
|||
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."
|
||||
(declare (debug (form symbolp)))
|
||||
`(eieio-oref-default ,obj (quote ,slot)))
|
||||
|
||||
;;; Handy CLOS macros
|
||||
|
|
@ -246,7 +353,7 @@ SPEC-LIST is of a form similar to `let'. For example:
|
|||
Where each VAR is the local variable given to the associated
|
||||
SLOT. A slot specified without a variable name is given a
|
||||
variable name of the same name as the slot."
|
||||
(declare (indent 2))
|
||||
(declare (indent 2) (debug (sexp sexp def-body)))
|
||||
(require 'cl-lib)
|
||||
;; Transform the spec-list into a cl-symbol-macrolet spec-list.
|
||||
(let ((mappings (mapcar (lambda (entry)
|
||||
|
|
@ -261,33 +368,43 @@ variable name of the same name as the slot."
|
|||
;; well embedded into an object.
|
||||
;;
|
||||
(define-obsolete-function-alias
|
||||
'object-class-fast #'eieio--object-class "24.4")
|
||||
'object-class-fast #'eieio--object-class-name "24.4")
|
||||
|
||||
(defun eieio-object-name (obj &optional extra)
|
||||
"Return a Lisp like symbol string for object OBJ.
|
||||
If EXTRA, include that in the string returned to represent the symbol."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(format "#<%s %s%s>" (symbol-name (eieio--object-class obj))
|
||||
(eieio--object-name obj) (or extra "")))
|
||||
(format "#<%s %s%s>" (eieio--object-class-name obj)
|
||||
(eieio-object-name-string obj) (or extra "")))
|
||||
(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4")
|
||||
|
||||
(defun eieio-object-name-string (obj) "Return a string which is OBJ's name."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(eieio--object-name obj))
|
||||
(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key))
|
||||
|
||||
;; In the past, every EIEIO object had a `name' field, so we had the two method
|
||||
;; below "for free". Since this field is very rarely used, we got rid of it
|
||||
;; and instead we keep it in a weak hash-tables, for those very rare objects
|
||||
;; that use it.
|
||||
(defmethod eieio-object-name-string (obj)
|
||||
"Return a string which is OBJ's name."
|
||||
(declare (obsolete eieio-named "25.1"))
|
||||
(or (gethash obj eieio--object-names)
|
||||
(symbol-name (eieio-object-class obj))))
|
||||
(define-obsolete-function-alias
|
||||
'object-name-string #'eieio-object-name-string "24.4")
|
||||
|
||||
(defun eieio-object-set-name-string (obj name)
|
||||
(defmethod eieio-object-set-name-string (obj name)
|
||||
"Set the string which is OBJ's NAME."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(declare (obsolete eieio-named "25.1"))
|
||||
(eieio--check-type stringp name)
|
||||
(setf (eieio--object-name obj) name))
|
||||
(setf (gethash obj eieio--object-names) name))
|
||||
(define-obsolete-function-alias
|
||||
'object-set-name-string 'eieio-object-set-name-string "24.4")
|
||||
|
||||
(defun eieio-object-class (obj) "Return the class struct defining OBJ."
|
||||
(defun eieio-object-class (obj)
|
||||
"Return the class struct defining OBJ."
|
||||
;; FIXME: We say we return a "struct" but we return a symbol instead!
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(eieio--object-class obj))
|
||||
(eieio--object-class-name obj))
|
||||
(define-obsolete-function-alias 'object-class #'eieio-object-class "24.4")
|
||||
;; CLOS name, maybe?
|
||||
(define-obsolete-function-alias 'class-of #'eieio-object-class "24.4")
|
||||
|
|
@ -295,7 +412,7 @@ If EXTRA, include that in the string returned to represent the symbol."
|
|||
(defun eieio-object-class-name (obj)
|
||||
"Return a Lisp like symbol name for OBJ's class."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(eieio-class-name (eieio--object-class obj)))
|
||||
(eieio-class-name (eieio--object-class-name obj)))
|
||||
(define-obsolete-function-alias
|
||||
'object-class-name 'eieio-object-class-name "24.4")
|
||||
|
||||
|
|
@ -303,15 +420,16 @@ If EXTRA, include that in the string returned to represent the symbol."
|
|||
"Return parent classes to CLASS. (overload of variable).
|
||||
|
||||
The CLOS function `class-direct-superclasses' is aliased to this function."
|
||||
(eieio--check-type class-p class)
|
||||
(eieio-class-parents-fast class))
|
||||
(let ((c (eieio-class-object class)))
|
||||
(eieio--class-parent c)))
|
||||
|
||||
(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4")
|
||||
|
||||
(defun eieio-class-children (class)
|
||||
"Return child classes to CLASS.
|
||||
The CLOS function `class-direct-subclasses' is aliased to this function."
|
||||
(eieio--check-type class-p class)
|
||||
(eieio-class-children-fast class))
|
||||
(eieio--class-children (eieio--class-v class)))
|
||||
(define-obsolete-function-alias
|
||||
'class-children #'eieio-class-children "24.4")
|
||||
|
||||
|
|
@ -326,38 +444,44 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
|
|||
`(car (eieio-class-parents ,class)))
|
||||
(define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4")
|
||||
|
||||
(defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS."
|
||||
(eieio--check-type class-p class)
|
||||
(defun same-class-p (obj class)
|
||||
"Return t if OBJ is of class-type CLASS."
|
||||
(setq class (eieio--class-object class))
|
||||
(eieio--check-type eieio--class-p class)
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(same-class-fast-p obj class))
|
||||
(eq (eieio--object-class-object obj) class))
|
||||
|
||||
(defun object-of-class-p (obj class)
|
||||
"Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
;; class will be checked one layer down
|
||||
(child-of-class-p (eieio--object-class obj) class))
|
||||
(child-of-class-p (eieio--object-class-object obj) class))
|
||||
;; Backwards compatibility
|
||||
(defalias 'obj-of-class-p 'object-of-class-p)
|
||||
|
||||
(defun child-of-class-p (child class)
|
||||
"Return non-nil if CHILD class is a subclass of CLASS."
|
||||
(eieio--check-type class-p class)
|
||||
(eieio--check-type class-p child)
|
||||
(let ((p nil))
|
||||
(while (and child (not (eq child class)))
|
||||
(setq p (append p (eieio--class-parent (class-v child)))
|
||||
child (car p)
|
||||
p (cdr p)))
|
||||
(if child t)))
|
||||
(setq child (eieio--class-object child))
|
||||
(eieio--check-type eieio--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))
|
||||
(setq class (eieio--class-object class))
|
||||
(eieio--check-type eieio--class-p class)
|
||||
(while (and child (not (eq child class)))
|
||||
(setq p (append p (eieio--class-parent child))
|
||||
child (pop p)))
|
||||
(if child t))))
|
||||
|
||||
(defun object-slots (obj)
|
||||
"Return list of slots available in OBJ."
|
||||
(eieio--check-type eieio-object-p obj)
|
||||
(eieio--class-public-a (class-v (eieio--object-class obj))))
|
||||
(eieio--class-public-a (eieio--object-class-object obj)))
|
||||
|
||||
(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
|
||||
(eieio--check-type class-p class)
|
||||
(let ((ia (eieio--class-initarg-tuples (class-v class)))
|
||||
(defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
|
||||
(eieio--check-type eieio--class-p class)
|
||||
(let ((ia (eieio--class-initarg-tuples class))
|
||||
(f nil))
|
||||
(while (and ia (not f))
|
||||
(if (eq (cdr (car ia)) slot)
|
||||
|
|
@ -371,6 +495,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
|
|||
"Set the value in OBJ for slot SLOT to VALUE.
|
||||
SLOT is the slot name as specified in `defclass' or the tag created
|
||||
with in the :initarg slot. VALUE can be any Lisp object."
|
||||
(declare (debug (form symbolp form)))
|
||||
`(eieio-oset ,obj (quote ,slot) ,value))
|
||||
|
||||
(defmacro oset-default (class slot value)
|
||||
|
|
@ -378,6 +503,7 @@ with in the :initarg slot. VALUE can be any Lisp object."
|
|||
The default value is usually set with the :initform tag during class
|
||||
creation. This allows users to change the default behavior of classes
|
||||
after they are created."
|
||||
(declare (debug (form symbolp form)))
|
||||
`(eieio-oset-default ,class (quote ,slot) ,value))
|
||||
|
||||
;;; CLOS queries into classes and slots
|
||||
|
|
@ -402,11 +528,9 @@ OBJECT can be an instance or a class."
|
|||
|
||||
(defun slot-exists-p (object-or-class slot)
|
||||
"Return non-nil if OBJECT-OR-CLASS has SLOT."
|
||||
(let ((cv (class-v (cond ((eieio-object-p object-or-class)
|
||||
(eieio-object-class object-or-class))
|
||||
((class-p object-or-class)
|
||||
object-or-class))
|
||||
)))
|
||||
(let ((cv (cond ((eieio-object-p object-or-class)
|
||||
(eieio--object-class-object object-or-class))
|
||||
(t (eieio-class-object object-or-class)))))
|
||||
(or (memq slot (eieio--class-public-a cv))
|
||||
(memq slot (eieio--class-class-allocation-a cv)))
|
||||
))
|
||||
|
|
@ -418,7 +542,7 @@ If ERRORP is non-nil, `wrong-argument-type' is signaled."
|
|||
(if (not (class-p symbol))
|
||||
(if errorp (signal 'wrong-type-argument (list 'class-p symbol))
|
||||
nil)
|
||||
(class-v symbol)))
|
||||
(eieio--class-v symbol)))
|
||||
|
||||
;;; Slightly more complex utility functions for objects
|
||||
;;
|
||||
|
|
@ -496,44 +620,6 @@ If SLOT is unbound, do nothing."
|
|||
nil
|
||||
(eieio-oset object slot (delete item (eieio-oref object slot)))))
|
||||
|
||||
;;;
|
||||
;; Method Calling Functions
|
||||
|
||||
(defun next-method-p ()
|
||||
"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)
|
||||
|
||||
(defun call-next-method (&rest replacement-args)
|
||||
"Call the superclass method from a subclass method.
|
||||
The superclass method is specified in the current method list,
|
||||
and is called the next method.
|
||||
|
||||
If REPLACEMENT-ARGS is non-nil, then use them instead of
|
||||
`eieio-generic-call-arglst'. The generic arg list are the
|
||||
arguments passed in at the top level.
|
||||
|
||||
Use `next-method-p' to find out if there is a next method to call."
|
||||
(if (not (eieio--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))
|
||||
(error "Cannot `call-next-method' except in :primary or :static methods")
|
||||
)
|
||||
(let ((newargs (or replacement-args eieio-generic-call-arglst))
|
||||
(next (car eieio-generic-call-next-method-list))
|
||||
)
|
||||
(if (or (not next) (not (car next)))
|
||||
(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)
|
||||
(fcn (car next))
|
||||
)
|
||||
(eieio--with-scoped-class (cdr next)
|
||||
(apply fcn newargs)) ))))
|
||||
|
||||
;;; Here are some CLOS items that need the CL package
|
||||
;;
|
||||
|
||||
|
|
@ -556,22 +642,23 @@ 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)
|
||||
|
||||
(setq eieio-default-superclass (eieio--class-v 'eieio-default-superclass))
|
||||
|
||||
(defalias 'standard-class 'eieio-default-superclass)
|
||||
|
||||
(defgeneric constructor (class newname &rest slots)
|
||||
(defgeneric eieio-constructor (class &rest slots)
|
||||
"Default constructor for CLASS `eieio-default-superclass'.")
|
||||
|
||||
(defmethod constructor :static
|
||||
((class eieio-default-superclass) newname &rest slots)
|
||||
(define-obsolete-function-alias 'constructor #'eieio-constructor "25.1")
|
||||
|
||||
(defmethod eieio-constructor :static
|
||||
((class eieio-default-superclass) &rest slots)
|
||||
"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.
|
||||
It allocates the vector used to represent an EIEIO object, and then
|
||||
calls `shared-initialize' on that object."
|
||||
(let* ((new-object (copy-sequence (eieio--class-default-object-cache (class-v class)))))
|
||||
;; Update the name for the newly created object.
|
||||
(setf (eieio--object-name new-object) newname)
|
||||
(let* ((new-object (copy-sequence (eieio--class-default-object-cache (eieio--class-v class)))))
|
||||
;; Call the initialize method on the new object with the slots
|
||||
;; that were passed down to us.
|
||||
(initialize-instance new-object slots)
|
||||
|
|
@ -585,10 +672,10 @@ Called from the constructor routine.")
|
|||
(defmethod shared-initialize ((obj eieio-default-superclass) slots)
|
||||
"Set slots of OBJ with SLOTS which is a list of name/value pairs.
|
||||
Called from the constructor routine."
|
||||
(eieio--with-scoped-class (eieio--object-class obj)
|
||||
(eieio--with-scoped-class (eieio--object-class-object obj)
|
||||
(while slots
|
||||
(let ((rn (eieio-initarg-to-attribute (eieio--object-class obj)
|
||||
(car slots))))
|
||||
(let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj)
|
||||
(car slots))))
|
||||
(if (not rn)
|
||||
(slot-missing obj (car slots) 'oset (car (cdr slots)))
|
||||
(eieio-oset obj rn (car (cdr slots)))))
|
||||
|
|
@ -609,7 +696,7 @@ 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.
|
||||
(let* ((this-class (class-v (eieio--object-class this)))
|
||||
(let* ((this-class (eieio--object-class-object this))
|
||||
(slot (eieio--class-public-a this-class))
|
||||
(defaults (eieio--class-public-d this-class)))
|
||||
(while slot
|
||||
|
|
@ -662,34 +749,6 @@ EIEIO can only dispatch on the first argument, so the first two are swapped."
|
|||
(signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object)
|
||||
slot-name fn)))
|
||||
|
||||
(defgeneric no-applicable-method (object method &rest args)
|
||||
"Called if there are no implementations for OBJECT in METHOD.")
|
||||
|
||||
(defmethod no-applicable-method ((object eieio-default-superclass)
|
||||
method &rest _args)
|
||||
"Called if there are no implementations for OBJECT in METHOD.
|
||||
OBJECT is the object which has no method implementation.
|
||||
ARGS are the arguments that were passed to METHOD.
|
||||
|
||||
Implement this for a class to block this signal. The return
|
||||
value becomes the return value of the original method call."
|
||||
(signal 'no-method-definition (list method (eieio-object-name object)))
|
||||
)
|
||||
|
||||
(defgeneric no-next-method (object &rest args)
|
||||
"Called from `call-next-method' when no additional methods are available.")
|
||||
|
||||
(defmethod no-next-method ((object eieio-default-superclass)
|
||||
&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.
|
||||
This method signals `no-next-method' by default. Override this
|
||||
method to not throw an error, and its return value becomes the
|
||||
return value of `call-next-method'."
|
||||
(signal 'no-next-method (list (eieio-object-name object) args))
|
||||
)
|
||||
|
||||
(defgeneric clone (obj &rest params)
|
||||
"Make a copy of OBJ, and then supply PARAMS.
|
||||
PARAMS is a parameter list of the same form used by `initialize-instance'.
|
||||
|
|
@ -699,18 +758,11 @@ first and modify the returned object.")
|
|||
|
||||
(defmethod clone ((obj eieio-default-superclass) &rest params)
|
||||
"Make a copy of OBJ, and then apply PARAMS."
|
||||
(let ((nobj (copy-sequence obj))
|
||||
(nm (eieio--object-name obj))
|
||||
(passname (and params (stringp (car params))))
|
||||
(num 1))
|
||||
(if params (shared-initialize nobj (if passname (cdr params) params)))
|
||||
(if (not passname)
|
||||
(save-match-data
|
||||
(if (string-match "-\\([0-9]+\\)" nm)
|
||||
(setq num (1+ (string-to-number (match-string 1 nm)))
|
||||
nm (substring nm 0 (match-beginning 0))))
|
||||
(setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
|
||||
(setf (eieio--object-name nobj) (car params)))
|
||||
(let ((nobj (copy-sequence obj)))
|
||||
(if (stringp (car params))
|
||||
(funcall (if eieio-backward-compatibility #'ignore #'message)
|
||||
"Obsolete name %S passed to clone" (pop params)))
|
||||
(if params (shared-initialize nobj params))
|
||||
nobj))
|
||||
|
||||
(defgeneric destructor (this &rest params)
|
||||
|
|
@ -764,7 +816,7 @@ this object."
|
|||
(princ comment)
|
||||
(princ "\n"))
|
||||
(let* ((cl (eieio-object-class this))
|
||||
(cv (class-v cl)))
|
||||
(cv (eieio--class-v cl)))
|
||||
;; Now output readable lisp to recreate this object
|
||||
;; It should look like this:
|
||||
;; (<constructor> <name> <slot> <slot> ... )
|
||||
|
|
@ -782,7 +834,7 @@ this object."
|
|||
(eieio-print-depth (1+ eieio-print-depth)))
|
||||
(while publa
|
||||
(when (slot-boundp this (car publa))
|
||||
(let ((i (class-slot-initarg cl (car publa)))
|
||||
(let ((i (eieio--class-slot-initarg cv (car publa)))
|
||||
(v (eieio-oref this (car publa)))
|
||||
)
|
||||
(unless (or (not i) (equal v (car publd)))
|
||||
|
|
@ -848,7 +900,6 @@ of `eq'."
|
|||
(error "EIEIO: `change-class' is unimplemented"))
|
||||
|
||||
;; Hook ourselves into help system for describing classes and methods.
|
||||
(add-hook 'help-fns-describe-function-functions 'eieio-help-generic)
|
||||
(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor)
|
||||
|
||||
;;; Interfacing with edebug
|
||||
|
|
@ -859,43 +910,23 @@ of `eq'."
|
|||
Used as advice around `edebug-prin1-to-string', held in the
|
||||
variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
|
||||
`prin1-to-string' when appropriate."
|
||||
(cond ((class-p object) (eieio-class-name object))
|
||||
(cond ((eieio--class-p object) (eieio-class-name object))
|
||||
((eieio-object-p object) (object-print object))
|
||||
((and (listp object) (or (class-p (car object))
|
||||
((and (listp object) (or (eieio--class-p (car object))
|
||||
(eieio-object-p (car object))))
|
||||
(concat "(" (mapconcat #'eieio-edebug-prin1-to-string object " ")
|
||||
(concat "(" (mapconcat
|
||||
(lambda (x) (eieio-edebug-prin1-to-string print-function x))
|
||||
object " ")
|
||||
")"))
|
||||
(t (funcall print-function object noescape))))
|
||||
|
||||
(add-hook 'edebug-setup-hook
|
||||
(lambda ()
|
||||
(def-edebug-spec defmethod
|
||||
(&define ; this means we are defining something
|
||||
[&or name ("setf" :name setf name)]
|
||||
;; ^^ This is the methods symbol
|
||||
[ &optional symbolp ] ; this is key :before etc
|
||||
list ; arguments
|
||||
[ &optional stringp ] ; documentation string
|
||||
def-body ; part to be debugged
|
||||
))
|
||||
;; The rest of the macros
|
||||
(def-edebug-spec oref (form quote))
|
||||
(def-edebug-spec oref-default (form quote))
|
||||
(def-edebug-spec oset (form quote form))
|
||||
(def-edebug-spec oset-default (form quote form))
|
||||
(def-edebug-spec class-v form)
|
||||
(def-edebug-spec class-p form)
|
||||
(def-edebug-spec eieio-object-p form)
|
||||
(def-edebug-spec class-constructor form)
|
||||
(def-edebug-spec generic-p form)
|
||||
(def-edebug-spec with-slots (list list def-body))
|
||||
(advice-add 'edebug-prin1-to-string
|
||||
:around #'eieio-edebug-prin1-to-string)))
|
||||
(advice-add 'edebug-prin1-to-string
|
||||
:around #'eieio-edebug-prin1-to-string)
|
||||
|
||||
|
||||
;;; Start of automatically extracted autoloads.
|
||||
|
||||
;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "62709d76ae43f4fe70ed922391f9c64d")
|
||||
;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "9a908efef1720439feb6323c1dd01770")
|
||||
;;; Generated autoloads from eieio-custom.el
|
||||
|
||||
(autoload 'customize-object "eieio-custom" "\
|
||||
|
|
@ -906,7 +937,7 @@ Optional argument GROUP is the sub-group of slots to display.
|
|||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "76058d02377b677eed3d15c28fc7ab21")
|
||||
;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "e922bf7ebc7dcb272480c4ba148da1ac")
|
||||
;;; Generated autoloads from eieio-opt.el
|
||||
|
||||
(autoload 'eieio-browse "eieio-opt" "\
|
||||
|
|
@ -927,11 +958,6 @@ Describe CTR if it is a class constructor.
|
|||
|
||||
\(fn CTR)" nil nil)
|
||||
|
||||
(autoload 'eieio-help-generic "eieio-opt" "\
|
||||
Describe GENERIC if it is a generic function.
|
||||
|
||||
\(fn GENERIC)" nil nil)
|
||||
|
||||
;;;***
|
||||
|
||||
;;; End of automatically extracted autoloads.
|
||||
|
|
|
|||
|
|
@ -1,3 +1,7 @@
|
|||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* registry.el: Don't use <class> as a variable.
|
||||
|
||||
2014-12-29 Paul Eggert <eggert@cs.ucla.edu>
|
||||
|
||||
* message.el (message-make-fqdn):
|
||||
|
|
@ -12,8 +16,8 @@
|
|||
|
||||
2014-12-19 Andreas Schwab <schwab@linux-m68k.org>
|
||||
|
||||
* gnus-group.el (gnus-read-ephemeral-bug-group): Bind
|
||||
coding-system-for-read and coding-system-for-write only around
|
||||
* gnus-group.el (gnus-read-ephemeral-bug-group):
|
||||
Bind coding-system-for-read and coding-system-for-write only around
|
||||
with-temp-file, and make buffer unibyte. Don't write temp file twice.
|
||||
|
||||
2014-12-18 Paul Eggert <eggert@cs.ucla.edu>
|
||||
|
|
@ -73,9 +77,9 @@
|
|||
|
||||
2014-12-09 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* gnus-art.el (gnus-article-mime-handles): Refactored out into own
|
||||
* gnus-art.el (gnus-article-mime-handles): Refactor out into own
|
||||
function for reuse.
|
||||
(gnus-mime-buttonize-attachments-in-header): Adjusted.
|
||||
(gnus-mime-buttonize-attachments-in-header): Adjust.
|
||||
|
||||
2014-12-07 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
|
|
|
|||
|
|
@ -124,7 +124,7 @@
|
|||
:type hash-table
|
||||
:documentation "The data hashtable.")))
|
||||
;; Do this separately, since defclass doesn't allow expressions in :initform.
|
||||
(oset-default registry-db max-size most-positive-fixnum)
|
||||
(oset-default 'registry-db max-size most-positive-fixnum)
|
||||
|
||||
(defmethod initialize-instance :BEFORE ((this registry-db) slots)
|
||||
"Check whether a registry object needs to be upgraded."
|
||||
|
|
|
|||
|
|
@ -1,3 +1,57 @@
|
|||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* automated/eieio-tests.el (eieio-test-23-inheritance-check): Don't use
|
||||
<foo>-child-p.
|
||||
|
||||
* automated/eieio-test-methodinvoke.el (eieio-test-method-store):
|
||||
Update reference to eieio--generic-call-key.
|
||||
|
||||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* automated/eieio-tests.el: Use cl-lib. Don't use <class> as a variable.
|
||||
Don't use <class>-list types and <class>-list-p predicates.
|
||||
|
||||
* automated/eieio-test-persist.el (persistent-with-objs-list-slot):
|
||||
Don't use <class>-list type.
|
||||
|
||||
* automated/eieio-test-methodinvoke.el
|
||||
(eieio-test-method-order-list-4):
|
||||
Don't use <class> as a variable.
|
||||
|
||||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* automated/eieio-tests.el (eieio-test-04-static-method)
|
||||
(eieio-test-05-static-method-2): Use oref-default to access
|
||||
class slots.
|
||||
(eieio-test-23-inheritance-check): Don't assume that
|
||||
eieio-class-parents returns class names, or that a class can only have
|
||||
a single name.
|
||||
|
||||
* automated/eieio-test-persist.el (eieio--attribute-to-initarg):
|
||||
Move from eieio-core.el. Rename from eieio-attribute-to-initarg.
|
||||
Change arg to be a class object. Update all callers.
|
||||
|
||||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* automated/eieio-test-methodinvoke.el (eieio-test-method-store):
|
||||
Adjust to new semantics of eieio--scoped-class.
|
||||
(eieio-test-match): Improve error feedback.
|
||||
|
||||
2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* automated/eieio-tests.el: Remove dummy object names.
|
||||
|
||||
* automated/eieio-test-persist.el (persistent-with-objs-slot-subs):
|
||||
The type FOO-child is the same as FOO.
|
||||
|
||||
2015-01-08 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.
|
||||
|
||||
2015-01-01 Michael Albinus <michael.albinus@gmx.de>
|
||||
|
||||
* automated/tramp-tests.el (tramp--test-smb-or-windows-nt-p):
|
||||
|
|
@ -19,8 +73,7 @@
|
|||
2014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org>
|
||||
|
||||
* automated/python-tests.el
|
||||
(python-shell-completion-native-interpreter-disabled-p-1): New
|
||||
test.
|
||||
(python-shell-completion-native-interpreter-disabled-p-1): New test.
|
||||
|
||||
2014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org>
|
||||
|
||||
|
|
@ -110,8 +163,8 @@
|
|||
(vc-test--create-repo-function): Rename from
|
||||
`vc-test--create-repo-if-not-supported'. Adapt all callees.
|
||||
(vc-test--create-repo): Check also for revision-granularity.
|
||||
(vc-test--unregister-function): Additional argument FILE. Adapt
|
||||
all callees.
|
||||
(vc-test--unregister-function): Additional argument FILE.
|
||||
Adapt all callees.
|
||||
(vc-test--working-revision): New defun.
|
||||
(vc-test-*-working-revision): New tests.
|
||||
|
||||
|
|
@ -148,7 +201,7 @@
|
|||
2014-11-21 Ulf Jasper <ulf.jasper@web.de>
|
||||
|
||||
* automated/libxml-tests.el
|
||||
(libxml-tests--data-comments-preserved): Renamed from
|
||||
(libxml-tests--data-comments-preserved): Rename from
|
||||
'libxml-tests--data'.
|
||||
(libxml-tests--data-comments-discarded): New.
|
||||
(libxml-tests): Check whether 'libxml-parse-xml-region' is
|
||||
|
|
@ -175,8 +228,8 @@
|
|||
|
||||
2014-11-17 Ulf Jasper <ulf.jasper@web.de>
|
||||
|
||||
* automated/icalendar-tests.el (icalendar-tests--test-export): New
|
||||
optional parameter `alarms'.
|
||||
* automated/icalendar-tests.el (icalendar-tests--test-export):
|
||||
New optional parameter `alarms'.
|
||||
(icalendar-export-alarms): New test for exporting icalendar
|
||||
alarms.
|
||||
(icalendar-tests--test-cycle): Let `icalendar-export-alarms' be nil.
|
||||
|
|
@ -190,8 +243,8 @@
|
|||
|
||||
2014-11-16 Ulf Jasper <ulf.jasper@web.de>
|
||||
|
||||
* automated/icalendar-tests.el (icalendar--parse-vtimezone): Add
|
||||
testcase where offsets of standard time and daylight saving time
|
||||
* automated/icalendar-tests.el (icalendar--parse-vtimezone):
|
||||
Add testcase where offsets of standard time and daylight saving time
|
||||
are equal.
|
||||
(icalendar-real-world): Fix error in test case. Expected result
|
||||
was wrong when offsets of standard time and daylight saving time
|
||||
|
|
|
|||
|
|
@ -61,16 +61,17 @@
|
|||
(defun eieio-test-method-store ()
|
||||
"Store current invocation class symbol in the invocation order list."
|
||||
(let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ]
|
||||
(or eieio-generic-call-key 0)))
|
||||
(c (list eieio-generic-call-methodname keysym (eieio--scoped-class))))
|
||||
(setq eieio-test-method-order-list
|
||||
(cons c eieio-test-method-order-list))))
|
||||
(or eieio--generic-call-key 0)))
|
||||
;; FIXME: Don't depend on `eieio--scoped-class'!
|
||||
(c (list keysym (eieio--class-symbol (eieio--scoped-class)))))
|
||||
(push c eieio-test-method-order-list)))
|
||||
|
||||
(defun eieio-test-match (rightanswer)
|
||||
"Do a test match."
|
||||
(if (equal rightanswer eieio-test-method-order-list)
|
||||
t
|
||||
(error "eieio-test-methodinvoke.el: Test Failed!")))
|
||||
(error "eieio-test-methodinvoke.el: Test Failed: %S != %S"
|
||||
rightanswer eieio-test-method-order-list)))
|
||||
|
||||
(defvar eieio-test-call-next-method-arguments nil
|
||||
"List of passed to methods during execution of `call-next-method'.")
|
||||
|
|
@ -121,17 +122,17 @@
|
|||
(ert-deftest eieio-test-method-order-list-3 ()
|
||||
(let ((eieio-test-method-order-list nil)
|
||||
(ans '(
|
||||
(eitest-F :BEFORE eitest-B)
|
||||
(eitest-F :BEFORE eitest-B-base1)
|
||||
(eitest-F :BEFORE eitest-B-base2)
|
||||
(:BEFORE eitest-B)
|
||||
(:BEFORE eitest-B-base1)
|
||||
(:BEFORE eitest-B-base2)
|
||||
|
||||
(eitest-F :PRIMARY eitest-B)
|
||||
(eitest-F :PRIMARY eitest-B-base1)
|
||||
(eitest-F :PRIMARY eitest-B-base2)
|
||||
(:PRIMARY eitest-B)
|
||||
(:PRIMARY eitest-B-base1)
|
||||
(:PRIMARY eitest-B-base2)
|
||||
|
||||
(eitest-F :AFTER eitest-B-base2)
|
||||
(eitest-F :AFTER eitest-B-base1)
|
||||
(eitest-F :AFTER eitest-B)
|
||||
(:AFTER eitest-B-base2)
|
||||
(:AFTER eitest-B-base1)
|
||||
(:AFTER eitest-B)
|
||||
)))
|
||||
(eitest-F (eitest-B nil))
|
||||
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
||||
|
|
@ -145,7 +146,7 @@
|
|||
|
||||
(ert-deftest eieio-test-method-order-list-4 ()
|
||||
;; Both of these situations should succeed.
|
||||
(should (eitest-H eitest-A))
|
||||
(should (eitest-H 'eitest-A))
|
||||
(should (eitest-H (eitest-A nil))))
|
||||
|
||||
;;; Return value from :PRIMARY
|
||||
|
|
@ -176,17 +177,18 @@
|
|||
(defclass C-base2 () ())
|
||||
(defclass C (C-base1 C-base2) ())
|
||||
|
||||
;; Just use the obsolete name once, to make sure it also works.
|
||||
(defmethod constructor :STATIC ((p C-base1) &rest args)
|
||||
(eieio-test-method-store)
|
||||
(if (next-method-p) (call-next-method))
|
||||
)
|
||||
|
||||
(defmethod constructor :STATIC ((p C-base2) &rest args)
|
||||
(defmethod eieio-constructor :STATIC ((p C-base2) &rest args)
|
||||
(eieio-test-method-store)
|
||||
(if (next-method-p) (call-next-method))
|
||||
)
|
||||
|
||||
(defmethod constructor :STATIC ((p C) &rest args)
|
||||
(defmethod eieio-constructor :STATIC ((p C) &rest args)
|
||||
(eieio-test-method-store)
|
||||
(call-next-method)
|
||||
)
|
||||
|
|
@ -194,9 +196,9 @@
|
|||
(ert-deftest eieio-test-method-order-list-6 ()
|
||||
(let ((eieio-test-method-order-list nil)
|
||||
(ans '(
|
||||
(constructor :STATIC C)
|
||||
(constructor :STATIC C-base1)
|
||||
(constructor :STATIC C-base2)
|
||||
(:STATIC C)
|
||||
(:STATIC C-base1)
|
||||
(:STATIC C-base2)
|
||||
)))
|
||||
(C nil)
|
||||
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
||||
|
|
@ -239,10 +241,10 @@
|
|||
(ert-deftest eieio-test-method-order-list-7 ()
|
||||
(let ((eieio-test-method-order-list nil)
|
||||
(ans '(
|
||||
(eitest-F :PRIMARY D)
|
||||
(eitest-F :PRIMARY D-base1)
|
||||
;; (eitest-F :PRIMARY D-base2)
|
||||
(eitest-F :PRIMARY D-base0)
|
||||
(:PRIMARY D)
|
||||
(:PRIMARY D-base1)
|
||||
;; (:PRIMARY D-base2)
|
||||
(:PRIMARY D-base0)
|
||||
)))
|
||||
(eitest-F (D nil))
|
||||
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
||||
|
|
@ -278,10 +280,10 @@
|
|||
(ert-deftest eieio-test-method-order-list-8 ()
|
||||
(let ((eieio-test-method-order-list nil)
|
||||
(ans '(
|
||||
(eitest-F :PRIMARY E)
|
||||
(eitest-F :PRIMARY E-base1)
|
||||
(eitest-F :PRIMARY E-base2)
|
||||
(eitest-F :PRIMARY E-base0)
|
||||
(:PRIMARY E)
|
||||
(:PRIMARY E-base1)
|
||||
(:PRIMARY E-base2)
|
||||
(:PRIMARY E-base0)
|
||||
)))
|
||||
(eitest-F (E nil))
|
||||
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
||||
|
|
|
|||
|
|
@ -32,6 +32,14 @@
|
|||
(require 'eieio-base)
|
||||
(require 'ert)
|
||||
|
||||
(defun eieio--attribute-to-initarg (class attribute)
|
||||
"In CLASS, convert the ATTRIBUTE into the corresponding init argument tag.
|
||||
This is usually a symbol that starts with `:'."
|
||||
(let ((tuple (rassoc attribute (eieio--class-initarg-tuples class))))
|
||||
(if tuple
|
||||
(car tuple)
|
||||
nil)))
|
||||
|
||||
(defun persist-test-save-and-compare (original)
|
||||
"Compare the object ORIGINAL against the one read fromdisk."
|
||||
|
||||
|
|
@ -40,7 +48,7 @@
|
|||
(let* ((file (oref original :file))
|
||||
(class (eieio-object-class original))
|
||||
(fromdisk (eieio-persistent-read file class))
|
||||
(cv (class-v class))
|
||||
(cv (eieio--class-v class))
|
||||
(slot-names (eieio--class-public-a cv))
|
||||
(slot-deflt (eieio--class-public-d cv))
|
||||
)
|
||||
|
|
@ -53,7 +61,8 @@
|
|||
(let* ((oneslot (car slot-names))
|
||||
(origvalue (eieio-oref original oneslot))
|
||||
(fromdiskvalue (eieio-oref fromdisk oneslot))
|
||||
(initarg-p (eieio-attribute-to-initarg class oneslot))
|
||||
(initarg-p (eieio--attribute-to-initarg
|
||||
(eieio--class-v class) oneslot))
|
||||
)
|
||||
|
||||
(if initarg-p
|
||||
|
|
@ -175,7 +184,7 @@ persistent class.")
|
|||
|
||||
(defclass persistent-with-objs-slot-subs (eieio-persistent)
|
||||
((pnp :initarg :pnp
|
||||
:type (or null persist-not-persistent-child)
|
||||
:type (or null persist-not-persistent)
|
||||
:initform nil))
|
||||
"Class for testing the saving of slots with objects in them.")
|
||||
|
||||
|
|
@ -194,7 +203,7 @@ persistent class.")
|
|||
;; A slot that contains another object that isn't persistent
|
||||
(defclass persistent-with-objs-list-slot (eieio-persistent)
|
||||
((pnp :initarg :pnp
|
||||
:type persist-not-persistent-list
|
||||
:type (list-of persist-not-persistent)
|
||||
:initform nil))
|
||||
"Class for testing the saving of slots with objects in them.")
|
||||
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@
|
|||
(require 'eieio-base)
|
||||
(require 'eieio-opt)
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
|
||||
;;; Code:
|
||||
;; Set up some test classes
|
||||
|
|
@ -158,7 +158,7 @@
|
|||
(ert-deftest eieio-test-02-abstract-class ()
|
||||
;; Abstract classes cannot be instantiated, so this should throw an
|
||||
;; error
|
||||
(should-error (abstract-class "Test")))
|
||||
(should-error (abstract-class)))
|
||||
|
||||
(defgeneric generic1 () "First generic function")
|
||||
|
||||
|
|
@ -180,7 +180,7 @@
|
|||
"Method generic1 that can take a non-object."
|
||||
not-an-object)
|
||||
|
||||
(let ((ans-obj (generic1 (class-a "test")))
|
||||
(let ((ans-obj (generic1 (class-a)))
|
||||
(ans-num (generic1 666)))
|
||||
(should (eq ans-obj 'monkey))
|
||||
(should (eq ans-num 666))))
|
||||
|
|
@ -199,10 +199,10 @@ Argument C is the class bound to this static method."
|
|||
|
||||
(ert-deftest eieio-test-04-static-method ()
|
||||
;; Call static method on a class and see if it worked
|
||||
(static-method-class-method static-method-class 'class)
|
||||
(should (eq (oref static-method-class some-slot) 'class))
|
||||
(static-method-class-method (static-method-class "test") 'object)
|
||||
(should (eq (oref static-method-class some-slot) 'object)))
|
||||
(static-method-class-method 'static-method-class 'class)
|
||||
(should (eq (oref-default 'static-method-class some-slot) 'class))
|
||||
(static-method-class-method (static-method-class) 'object)
|
||||
(should (eq (oref-default 'static-method-class some-slot) 'object)))
|
||||
|
||||
(ert-deftest eieio-test-05-static-method-2 ()
|
||||
(defclass static-method-class-2 (static-method-class)
|
||||
|
|
@ -215,10 +215,10 @@ Argument C is the class bound to this static method."
|
|||
(if (eieio-object-p c) (setq c (eieio-object-class c)))
|
||||
(oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
|
||||
|
||||
(static-method-class-method static-method-class-2 'class)
|
||||
(should (eq (oref static-method-class-2 some-slot) 'moose-class))
|
||||
(static-method-class-method (static-method-class-2 "test") 'object)
|
||||
(should (eq (oref static-method-class-2 some-slot) 'moose-object)))
|
||||
(static-method-class-method 'static-method-class-2 'class)
|
||||
(should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class))
|
||||
(static-method-class-method (static-method-class-2) 'object)
|
||||
(should (eq (oref-default 'static-method-class-2 some-slot) 'moose-object)))
|
||||
|
||||
|
||||
;;; Perform method testing
|
||||
|
|
@ -231,14 +231,14 @@ Argument C is the class bound to this static method."
|
|||
(defvar eitest-b nil)
|
||||
(ert-deftest eieio-test-06-allocate-objects ()
|
||||
;; allocate an object to use
|
||||
(should (setq eitest-ab (class-ab "abby")))
|
||||
(should (setq eitest-a (class-a "aye")))
|
||||
(should (setq eitest-b (class-b "fooby"))))
|
||||
(should (setq eitest-ab (class-ab)))
|
||||
(should (setq eitest-a (class-a)))
|
||||
(should (setq eitest-b (class-b))))
|
||||
|
||||
(ert-deftest eieio-test-07-make-instance ()
|
||||
(should (make-instance 'class-ab))
|
||||
(should (make-instance 'class-a :water 'cho))
|
||||
(should (make-instance 'class-b "a name")))
|
||||
(should (make-instance 'class-b)))
|
||||
|
||||
(defmethod class-cn ((a class-a))
|
||||
"Try calling `call-next-method' when there isn't one.
|
||||
|
|
@ -355,7 +355,7 @@ METHOD is the method that was attempting to be called."
|
|||
(call-next-method)
|
||||
(oset a test-tag 1))
|
||||
|
||||
(let ((ca (class-a "class act")))
|
||||
(let ((ca (class-a)))
|
||||
(should-not (/= (oref ca test-tag) 2))))
|
||||
|
||||
|
||||
|
|
@ -404,7 +404,7 @@ METHOD is the method that was attempting to be called."
|
|||
(t (call-next-method))))
|
||||
|
||||
(ert-deftest eieio-test-17-virtual-slot ()
|
||||
(setq eitest-vsca (virtual-slot-class "eitest-vsca" :base-value 1))
|
||||
(setq eitest-vsca (virtual-slot-class :base-value 1))
|
||||
;; Check slot values
|
||||
(should (= (oref eitest-vsca :base-value) 1))
|
||||
(should (= (oref eitest-vsca :derived-value) 2))
|
||||
|
|
@ -419,7 +419,7 @@ METHOD is the method that was attempting to be called."
|
|||
|
||||
;; should also be possible to initialize instance using virtual slot
|
||||
|
||||
(setq eitest-vscb (virtual-slot-class "eitest-vscb" :derived-value 5))
|
||||
(setq eitest-vscb (virtual-slot-class :derived-value 5))
|
||||
(should (= (oref eitest-vscb :base-value) 4))
|
||||
(should (= (oref eitest-vscb :derived-value) 5)))
|
||||
|
||||
|
|
@ -445,7 +445,7 @@ METHOD is the method that was attempting to be called."
|
|||
;; After setting 'water to 'moose, make sure a new object has
|
||||
;; the right stuff.
|
||||
(oset-default (eieio-object-class eitest-a) water 'penguin)
|
||||
(should (eq (oref (class-a "foo") water) 'penguin))
|
||||
(should (eq (oref (class-a) water) 'penguin))
|
||||
|
||||
;; Revert the above
|
||||
(defmethod slot-unbound ((a class-a) &rest foo)
|
||||
|
|
@ -459,12 +459,12 @@ METHOD is the method that was attempting to be called."
|
|||
;; We should not be able to set a string here
|
||||
(should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type)
|
||||
(should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type)
|
||||
(should-error (class-a "broken-type-a" :water "a string not a symbol") :type 'invalid-slot-type))
|
||||
(should-error (class-a :water "a string not a symbol") :type 'invalid-slot-type))
|
||||
|
||||
(ert-deftest eieio-test-20-class-allocated-slots ()
|
||||
;; Test out class allocated slots
|
||||
(defvar eitest-aa nil)
|
||||
(setq eitest-aa (class-a "another"))
|
||||
(setq eitest-aa (class-a))
|
||||
|
||||
;; Make sure class slots do not track between objects
|
||||
(let ((newval 'moose))
|
||||
|
|
@ -474,12 +474,12 @@ METHOD is the method that was attempting to be called."
|
|||
|
||||
;; Slot should be bound
|
||||
(should (slot-boundp eitest-a 'classslot))
|
||||
(should (slot-boundp class-a 'classslot))
|
||||
(should (slot-boundp 'class-a 'classslot))
|
||||
|
||||
(slot-makeunbound eitest-a 'classslot)
|
||||
|
||||
(should-not (slot-boundp eitest-a 'classslot))
|
||||
(should-not (slot-boundp class-a 'classslot)))
|
||||
(should-not (slot-boundp 'class-a 'classslot)))
|
||||
|
||||
|
||||
(defvar eieio-test-permuting-value nil)
|
||||
|
|
@ -499,7 +499,7 @@ METHOD is the method that was attempting to be called."
|
|||
(ert-deftest eieio-test-21-eval-at-construction-time ()
|
||||
;; initforms that need to be evalled at construction time.
|
||||
(setq eieio-test-permuting-value 2)
|
||||
(setq eitest-pvinit (inittest "permuteme"))
|
||||
(setq eitest-pvinit (inittest))
|
||||
|
||||
(should (eq (oref eitest-pvinit staticval) 1))
|
||||
(should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value))
|
||||
|
|
@ -515,11 +515,11 @@ METHOD is the method that was attempting to be called."
|
|||
"Test class that will be a calculated value.")
|
||||
|
||||
(defclass eitest-superior nil
|
||||
((sub :initform (eitest-subordinate "test")
|
||||
((sub :initform (eitest-subordinate)
|
||||
:type eitest-subordinate))
|
||||
"A class with an initform that creates a class.")
|
||||
|
||||
(should (setq eitest-tests (eitest-superior "test")))
|
||||
(should (setq eitest-tests (eitest-superior)))
|
||||
|
||||
(should-error
|
||||
(eval
|
||||
|
|
@ -530,33 +530,35 @@ METHOD is the method that was attempting to be called."
|
|||
:type 'invalid-slot-type))
|
||||
|
||||
(ert-deftest eieio-test-23-inheritance-check ()
|
||||
(should (child-of-class-p class-ab class-a))
|
||||
(should (child-of-class-p class-ab class-b))
|
||||
(should (object-of-class-p eitest-a class-a))
|
||||
(should (object-of-class-p eitest-ab class-a))
|
||||
(should (object-of-class-p eitest-ab class-b))
|
||||
(should (object-of-class-p eitest-ab class-ab))
|
||||
(should (eq (eieio-class-parents class-a) nil))
|
||||
(should (equal (eieio-class-parents class-ab) '(class-a class-b)))
|
||||
(should (same-class-p eitest-a class-a))
|
||||
(should (child-of-class-p 'class-ab 'class-a))
|
||||
(should (child-of-class-p 'class-ab 'class-b))
|
||||
(should (object-of-class-p eitest-a 'class-a))
|
||||
(should (object-of-class-p eitest-ab 'class-a))
|
||||
(should (object-of-class-p eitest-ab 'class-b))
|
||||
(should (object-of-class-p eitest-ab 'class-ab))
|
||||
(should (eq (eieio-class-parents 'class-a) nil))
|
||||
;; FIXME: eieio-class-parents now returns class objects!
|
||||
(should (equal (mapcar #'eieio-class-object (eieio-class-parents 'class-ab))
|
||||
(mapcar #'eieio-class-object '(class-a class-b))))
|
||||
(should (same-class-p eitest-a 'class-a))
|
||||
(should (class-a-p eitest-a))
|
||||
(should (not (class-a-p eitest-ab)))
|
||||
(should (class-a-child-p eitest-a))
|
||||
(should (class-a-child-p eitest-ab))
|
||||
(should (cl-typep eitest-a 'class-a))
|
||||
(should (cl-typep eitest-ab 'class-a))
|
||||
(should (not (class-a-p "foo")))
|
||||
(should (not (class-a-child-p "foo"))))
|
||||
(should (not (cl-typep "foo" 'class-a))))
|
||||
|
||||
(ert-deftest eieio-test-24-object-predicates ()
|
||||
(let ((listooa (list (class-ab "ab") (class-a "a")))
|
||||
(listoob (list (class-ab "ab") (class-b "b"))))
|
||||
(should (class-a-list-p listooa))
|
||||
(should (class-b-list-p listoob))
|
||||
(should-not (class-b-list-p listooa))
|
||||
(should-not (class-a-list-p listoob))))
|
||||
(let ((listooa (list (class-ab) (class-a)))
|
||||
(listoob (list (class-ab) (class-b))))
|
||||
(should (cl-typep listooa '(list-of class-a)))
|
||||
(should (cl-typep listoob '(list-of class-b)))
|
||||
(should-not (cl-typep listooa '(list-of class-b)))
|
||||
(should-not (cl-typep listoob '(list-of class-a)))))
|
||||
|
||||
(defvar eitest-t1 nil)
|
||||
(ert-deftest eieio-test-25-slot-tests ()
|
||||
(setq eitest-t1 (class-c "C1"))
|
||||
(setq eitest-t1 (class-c))
|
||||
;; Slot initialization
|
||||
(should (eq (oref eitest-t1 slot-1) 'moose))
|
||||
(should (eq (oref eitest-t1 :moose) 'moose))
|
||||
|
|
@ -565,9 +567,9 @@ METHOD is the method that was attempting to be called."
|
|||
;; Check private slot accessor
|
||||
(should (string= (get-slot-2 eitest-t1) "penguin"))
|
||||
;; Pass string instead of symbol
|
||||
(should-error (class-c "C2" :moose "not a symbol") :type 'invalid-slot-type)
|
||||
(should-error (class-c :moose "not a symbol") :type 'invalid-slot-type)
|
||||
(should (eq (get-slot-3 eitest-t1) 'emu))
|
||||
(should (eq (get-slot-3 class-c) 'emu))
|
||||
(should (eq (get-slot-3 'class-c) 'emu))
|
||||
;; Check setf
|
||||
(setf (get-slot-3 eitest-t1) 'setf-emu)
|
||||
(should (eq (get-slot-3 eitest-t1) 'setf-emu))
|
||||
|
|
@ -577,13 +579,13 @@ METHOD is the method that was attempting to be called."
|
|||
(defvar eitest-t2 nil)
|
||||
(ert-deftest eieio-test-26-default-inheritance ()
|
||||
;; See previous test, nor for subclass
|
||||
(setq eitest-t2 (class-subc "subc"))
|
||||
(setq eitest-t2 (class-subc))
|
||||
(should (eq (oref eitest-t2 slot-1) 'moose))
|
||||
(should (eq (oref eitest-t2 :moose) 'moose))
|
||||
(should (string= (get-slot-2 eitest-t2) "linux"))
|
||||
(should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
|
||||
(should (string= (get-slot-2 eitest-t2) "linux"))
|
||||
(should-error (class-subc "C2" :moose "not a symbol") :type 'invalid-slot-type))
|
||||
(should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type))
|
||||
|
||||
;;(ert-deftest eieio-test-27-inherited-new-value ()
|
||||
;;; HACK ALERT: The new value of a class slot is inherited by the
|
||||
|
|
@ -647,8 +649,8 @@ Do not override for `prot-2'."
|
|||
(defvar eitest-p1 nil)
|
||||
(defvar eitest-p2 nil)
|
||||
(ert-deftest eieio-test-28-slot-protection ()
|
||||
(setq eitest-p1 (prot-1 ""))
|
||||
(setq eitest-p2 (prot-2 ""))
|
||||
(setq eitest-p1 (prot-1))
|
||||
(setq eitest-p2 (prot-2))
|
||||
;; Access public slots
|
||||
(oref eitest-p1 slot-1)
|
||||
(oref eitest-p2 slot-1)
|
||||
|
|
@ -743,7 +745,7 @@ Subclasses to override slot attributes.")
|
|||
"This class should throw an error.")))
|
||||
|
||||
;; Initform should override instance allocation
|
||||
(let ((obj (slotattr-ok "moose")))
|
||||
(let ((obj (slotattr-ok)))
|
||||
(should (eq (oref obj initform) 'no-init))))
|
||||
|
||||
(defclass slotattr-class-base ()
|
||||
|
|
@ -792,10 +794,10 @@ Subclasses to override slot attributes.")
|
|||
((type :type string)
|
||||
)
|
||||
"This class should throw an error.")))
|
||||
(should (eq (oref-default slotattr-class-ok initform) 'no-init)))
|
||||
(should (eq (oref-default 'slotattr-class-ok initform) 'no-init)))
|
||||
|
||||
(ert-deftest eieio-test-32-slot-attribute-override-2 ()
|
||||
(let* ((cv (class-v 'slotattr-ok))
|
||||
(let* ((cv (eieio--class-v 'slotattr-ok))
|
||||
(docs (eieio--class-public-doc cv))
|
||||
(names (eieio--class-public-a cv))
|
||||
(cust (eieio--class-public-custom cv))
|
||||
|
|
@ -826,7 +828,7 @@ Subclasses to override slot attributes.")
|
|||
|
||||
(ert-deftest eieio-test-32-test-clone-boring-objects ()
|
||||
;; A simple make instance with EIEIO extension
|
||||
(should (setq eitest-CLONETEST1 (make-instance 'class-a "a")))
|
||||
(should (setq eitest-CLONETEST1 (make-instance 'class-a)))
|
||||
(should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))
|
||||
|
||||
;; CLOS form of make-instance
|
||||
|
|
@ -840,7 +842,7 @@ Subclasses to override slot attributes.")
|
|||
|
||||
(ert-deftest eieio-test-33-instance-tracker ()
|
||||
(let (IT-list IT1)
|
||||
(should (setq IT1 (IT "trackme")))
|
||||
(should (setq IT1 (IT)))
|
||||
;; The instance tracker must find this
|
||||
(should (eieio-instance-tracker-find 'die 'slot1 'IT-list))
|
||||
;; Test deletion
|
||||
|
|
@ -852,8 +854,8 @@ Subclasses to override slot attributes.")
|
|||
"A Singleton test object.")
|
||||
|
||||
(ert-deftest eieio-test-34-singletons ()
|
||||
(let ((obj1 (SINGLE "Moose"))
|
||||
(obj2 (SINGLE "Cow")))
|
||||
(let ((obj1 (SINGLE))
|
||||
(obj2 (SINGLE)))
|
||||
(should (eieio-object-p obj1))
|
||||
(should (eieio-object-p obj2))
|
||||
(should (eq obj1 obj2))
|
||||
|
|
@ -866,7 +868,7 @@ Subclasses to override slot attributes.")
|
|||
|
||||
(ert-deftest eieio-test-35-named-object ()
|
||||
(let (N)
|
||||
(should (setq N (NAMED "Foo")))
|
||||
(should (setq N (NAMED :object-name "Foo")))
|
||||
(should (string= "Foo" (oref N object-name)))
|
||||
(should-error (oref N missing-slot) :type 'invalid-slot-name)
|
||||
(oset N object-name "NewName")
|
||||
|
|
@ -882,8 +884,8 @@ Subclasses to override slot attributes.")
|
|||
"Instantiable child")
|
||||
|
||||
(ert-deftest eieio-test-36-build-class-alist ()
|
||||
(should (= (length (eieio-build-class-alist opt-test1 nil)) 2))
|
||||
(should (= (length (eieio-build-class-alist opt-test1 t)) 1)))
|
||||
(should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2))
|
||||
(should (= (length (eieio-build-class-alist 'opt-test1 t)) 1)))
|
||||
|
||||
(provide 'eieio-tests)
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue